From 54db1bf2ba1722aaedea911119bc3f3eed3122bd Mon Sep 17 00:00:00 2001 From: Cezary Czaplewski Date: Wed, 25 Mar 2020 00:04:57 +0100 Subject: [PATCH] update 5D --- source/cluster/wham/src-HCD/CMakeLists.txt | 173 + source/cluster/wham/src-HCD/COMMON.CHAIN | 21 + source/cluster/wham/src-HCD/COMMON.CLUSTER | 23 + source/cluster/wham/src-HCD/COMMON.CONTACTS.org | 73 + source/cluster/wham/src-HCD/COMMON.CONTROL | 16 + source/cluster/wham/src-HCD/COMMON.DFA | 101 + source/cluster/wham/src-HCD/COMMON.FFIELD | 32 + source/cluster/wham/src-HCD/COMMON.FREE | 3 + source/cluster/wham/src-HCD/COMMON.GEO | 2 + source/cluster/wham/src-HCD/COMMON.HEADER | 2 + source/cluster/wham/src-HCD/COMMON.HOMOLOGY | 8 + source/cluster/wham/src-HCD/COMMON.HOMRESTR | 39 + source/cluster/wham/src-HCD/COMMON.IOUNITS | 63 + source/cluster/wham/src-HCD/COMMON.LANGEVIN | 8 + source/cluster/wham/src-HCD/COMMON.MCM | 70 + source/cluster/wham/src-HCD/COMMON.MINIM | 3 + source/cluster/wham/src-HCD/COMMON.MPI | 8 + source/cluster/wham/src-HCD/COMMON.NAMES | 7 + source/cluster/wham/src-HCD/COMMON.SAXS | 7 + source/cluster/wham/src-HCD/COMMON.SBRIDGE | 29 + source/cluster/wham/src-HCD/COMMON.SCCOR | 19 + source/cluster/wham/src-HCD/COMMON.SCROT | 3 + source/cluster/wham/src-HCD/COMMON.SHIELD | 14 + source/cluster/wham/src-HCD/COMMON.TEMPFAC | 2 + source/cluster/wham/src-HCD/COMMON.THREAD | 7 + source/cluster/wham/src-HCD/COMMON.TIME1 | 4 + source/cluster/wham/src-HCD/COMMON.TORSION.org | 35 + source/cluster/wham/src-HCD/COMMON.VAR | 17 + source/cluster/wham/src-HCD/DIMENSIONS | 87 + source/cluster/wham/src-HCD/DIMENSIONS.COMPAR | 20 + source/cluster/wham/src-HCD/Makefile | 1 + .../cluster/wham/src-HCD/Makefile-MPICH-gfortran | 76 + source/cluster/wham/src-HCD/Makefile-MPICH-ifort | 73 + .../wham/src-HCD/Makefile-MPICH-ifort-okeanos | 98 + .../wham/src-HCD/Makefile-MPICH-ifort-prometheus | 77 + source/cluster/wham/src-HCD/Makefile-okeanos | 71 + source/cluster/wham/src-HCD/TMscore.F | 1095 ++ source/cluster/wham/src-HCD/arcos.f | 9 + source/cluster/wham/src-HCD/bakup/main_clust.F | 443 + source/cluster/wham/src-HCD/bakup/permut.f | 60 + source/cluster/wham/src-HCD/bakup/probabl.F | 308 + source/cluster/wham/src-HCD/bakup/read_coords.F | 721 ++ source/cluster/wham/src-HCD/cartprint.f | 19 + source/cluster/wham/src-HCD/chain_symmetry.F | 135 + source/cluster/wham/src-HCD/chainbuild.f | 252 + source/cluster/wham/src-HCD/compinfo.c | 82 + source/cluster/wham/src-HCD/contact.f | 69 + source/cluster/wham/src-HCD/convert.f | 59 + source/cluster/wham/src-HCD/dfa.F | 3548 +++++++ source/cluster/wham/src-HCD/energy_p_new.F |10724 +++++++++++++++++++ source/cluster/wham/src-HCD/energy_p_new.F.safe | 9056 ++++++++++++++++ source/cluster/wham/src-HCD/fitsq.f | 352 + source/cluster/wham/src-HCD/geomout.F | 201 + source/cluster/wham/src-HCD/gnmr1.f | 74 + source/cluster/wham/src-HCD/hc.f | 479 + source/cluster/wham/src-HCD/icant.f | 9 + .../cluster/wham/src-HCD/include_unres/COMMON.CALC | 15 + .../wham/src-HCD/include_unres/COMMON.CONTACTS | 4 + .../wham/src-HCD/include_unres/COMMON.CONTACTS.org | 77 + .../src-HCD/include_unres/COMMON.CONTACTS.safe | 68 + .../wham/src-HCD/include_unres/COMMON.CONTMAT | 26 + .../wham/src-HCD/include_unres/COMMON.CONTPAR | 3 + .../wham/src-HCD/include_unres/COMMON.CORRMAT | 47 + .../wham/src-HCD/include_unres/COMMON.DERIV | 69 + .../wham/src-HCD/include_unres/COMMON.DERIV.org | 30 + .../cluster/wham/src-HCD/include_unres/COMMON.FRAG | 5 + .../cluster/wham/src-HCD/include_unres/COMMON.GEO | 2 + .../wham/src-HCD/include_unres/COMMON.HEADER | 2 + .../wham/src-HCD/include_unres/COMMON.INTERACT | 36 + .../wham/src-HCD/include_unres/COMMON.LOCAL | 53 + .../wham/src-HCD/include_unres/COMMON.MINIM | 3 + .../wham/src-HCD/include_unres/COMMON.SCCOR | 6 + .../wham/src-HCD/include_unres/COMMON.SCROT | 3 + .../wham/src-HCD/include_unres/COMMON.SETUP | 21 + .../wham/src-HCD/include_unres/COMMON.SPLITELE | 2 + .../wham/src-HCD/include_unres/COMMON.TIME1 | 13 + .../wham/src-HCD/include_unres/COMMON.TORCNSTR | 17 + .../wham/src-HCD/include_unres/COMMON.TORSION | 60 + .../wham/src-HCD/include_unres/COMMON.TORSION.org | 25 + .../wham/src-HCD/include_unres/COMMON.VECTORS | 3 + .../wham/src-HCD/include_unres/COMMON.WEIGHTS | 22 + source/cluster/wham/src-HCD/initialize.f | 99 + source/cluster/wham/src-HCD/initialize.f_org | 92 + source/cluster/wham/src-HCD/initialize_p.F | 551 + source/cluster/wham/src-HCD/int_from_cart1.f | 63 + source/cluster/wham/src-HCD/intcor.f | 91 + source/cluster/wham/src-HCD/iperm.f | 15 + source/cluster/wham/src-HCD/log | 24 + source/cluster/wham/src-HCD/main_clust.F | 400 + source/cluster/wham/src-HCD/matmult.f | 17 + source/cluster/wham/src-HCD/misc.f | 203 + source/cluster/wham/src-HCD/noyes.f | 16 + source/cluster/wham/src-HCD/oligomer.f | 86 + source/cluster/wham/src-HCD/parmread.F | 1598 +++ source/cluster/wham/src-HCD/permut.F | 61 + source/cluster/wham/src-HCD/pinorm.f | 17 + source/cluster/wham/src-HCD/printmat.f | 16 + source/cluster/wham/src-HCD/probabl.F | 302 + source/cluster/wham/src-HCD/proc_proc.c | 140 + source/cluster/wham/src-HCD/read_constr_homology.F | 717 ++ source/cluster/wham/src-HCD/read_coords.F | 763 ++ source/cluster/wham/src-HCD/read_ref_str.F | 159 + source/cluster/wham/src-HCD/readpdb.F | 751 ++ source/cluster/wham/src-HCD/readpdb.f.safe | 307 + source/cluster/wham/src-HCD/readrtns.F | 1413 +++ source/cluster/wham/src-HCD/refsys.f | 70 + source/cluster/wham/src-HCD/rescode.f | 31 + source/cluster/wham/src-HCD/rmscalc.F | 208 + source/cluster/wham/src-HCD/rmsnat.f | 48 + source/cluster/wham/src-HCD/seq2chains.f | 56 + source/cluster/wham/src-HCD/setup_var.f | 31 + source/cluster/wham/src-HCD/sizesclu.dat | 37 + source/cluster/wham/src-HCD/srtclust.f | 117 + source/cluster/wham/src-HCD/ssMD.F | 2178 ++++ source/cluster/wham/src-HCD/timing.F | 180 + source/cluster/wham/src-HCD/track.F | 277 + source/cluster/wham/src-HCD/work_partition.F | 86 + source/cluster/wham/src-HCD/wrtclust.f | 646 ++ source/cluster/wham/src-HCD/xdrf/Makefile | 27 + source/cluster/wham/src-HCD/xdrf/Makefile_jubl | 31 + source/cluster/wham/src-HCD/xdrf/Makefile_linux | 27 + source/cluster/wham/src-HCD/xdrf/RS6K.m4 | 20 + source/cluster/wham/src-HCD/xdrf/ftocstr.c | 35 + source/cluster/wham/src-HCD/xdrf/libxdrf.m4 | 1238 +++ source/cluster/wham/src-HCD/xdrf/types.h | 99 + source/cluster/wham/src-HCD/xdrf/underscore.m4 | 19 + source/cluster/wham/src-HCD/xdrf/xdr.c | 752 ++ source/cluster/wham/src-HCD/xdrf/xdr.h | 379 + source/cluster/wham/src-HCD/xdrf/xdr_array.c | 174 + source/cluster/wham/src-HCD/xdrf/xdr_float.c | 307 + source/cluster/wham/src-HCD/xdrf/xdr_stdio.c | 196 + source/cluster/wham/src-HCD/xdrf/xdrf.h | 10 + source/unres/src-HCD-5D/MD_A-MTS.F | 8 +- .../unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos | 16 +- source/unres/src-HCD-5D/lagrangian_lesyng.F | 4 +- source/unres/src-HCD-5D/stochfric.F | 26 +- .../unres/src_MD-M-SAXS/energy_p_new-sep_barrier.F | 1928 ++-- source/unres/src_MD-M-SAXS/energy_p_new_barrier.F | 1473 ++- source/wham/src-HCD/CMakeLists.txt | 329 + source/wham/src-HCD/COMMON.ALLPARM | 113 + source/wham/src-HCD/COMMON.CHAIN | 20 + source/wham/src-HCD/COMMON.COMPAR | 39 + source/wham/src-HCD/COMMON.CONTACTS1 | 5 + source/wham/src-HCD/COMMON.CONTROL | 16 + source/wham/src-HCD/COMMON.CONTROL.org | 9 + source/wham/src-HCD/COMMON.DFA | 101 + source/wham/src-HCD/COMMON.ENEPS | 3 + source/wham/src-HCD/COMMON.ENERGIES | 4 + source/wham/src-HCD/COMMON.FREE | 12 + source/wham/src-HCD/COMMON.HOMOLOGY | 8 + source/wham/src-HCD/COMMON.HOMRESTR | 39 + source/wham/src-HCD/COMMON.IOUNITS | 54 + source/wham/src-HCD/COMMON.LANGEVIN | 8 + source/wham/src-HCD/COMMON.MPI | 8 + source/wham/src-HCD/COMMON.OBCINKA | 3 + source/wham/src-HCD/COMMON.PEPTCONT | 7 + source/wham/src-HCD/COMMON.PMF | 3 + source/wham/src-HCD/COMMON.PROT | 2 + source/wham/src-HCD/COMMON.PROTFILES | 10 + source/wham/src-HCD/COMMON.SAXS | 7 + source/wham/src-HCD/COMMON.SHIELD | 14 + source/wham/src-HCD/COMMON.SPLITELE | 2 + source/wham/src-HCD/COMMON.VAR | 18 + source/wham/src-HCD/DIMENSIONS | 164 + source/wham/src-HCD/DIMENSIONS.COMPAR | 25 + source/wham/src-HCD/DIMENSIONS.FREE | 13 + source/wham/src-HCD/DIMENSIONS.FREE.old | 12 + source/wham/src-HCD/DIMENSIONS.ZSCOPT | 40 + source/wham/src-HCD/Makefile | 1 + source/wham/src-HCD/Makefile-okeanos | 107 + source/wham/src-HCD/Makefile_MPICH_ifort | 104 + source/wham/src-HCD/Makefile_MPICH_ifort-okeanos | 146 + .../wham/src-HCD/Makefile_MPICH_ifort-prometheus | 118 + source/wham/src-HCD/Makefile_MPICH_pgi | 96 + source/wham/src-HCD/PMFprocess.F | 124 + source/wham/src-HCD/a | 17 + source/wham/src-HCD/angnorm.f | 454 + source/wham/src-HCD/arcos.f | 9 + source/wham/src-HCD/bxread.F | 89 + source/wham/src-HCD/cartder.f | 306 + source/wham/src-HCD/cartprint.f | 20 + source/wham/src-HCD/chain_symmetry.F | 135 + source/wham/src-HCD/chainbuild.F | 281 + source/wham/src-HCD/chainbuild.rrr | Bin 0 -> 20568 bytes source/wham/src-HCD/compinfo.c | 82 + source/wham/src-HCD/conf_compar.F | 403 + source/wham/src-HCD/cont_frag.f | 99 + source/wham/src-HCD/contact.f | 176 + source/wham/src-HCD/contfunc.f | 96 + source/wham/src-HCD/cxread.F | 340 + source/wham/src-HCD/cxread.F.org | 248 + source/wham/src-HCD/define_pairs.f | 120 + source/wham/src-HCD/dfa.F | 3549 +++++++ source/wham/src-HCD/elecont.f | 258 + source/wham/src-HCD/enecalc1.F | 825 ++ source/wham/src-HCD/energy_p_new.F |10790 ++++++++++++++++++++ source/wham/src-HCD/energy_p_new.F.org | 6452 ++++++++++++ source/wham/src-HCD/fitsq.f | 352 + source/wham/src-HCD/geomout.F | 198 + source/wham/src-HCD/gnmr1.f | 73 + source/wham/src-HCD/icant.f | 9 + source/wham/src-HCD/include_unres/COMMON.CALC | 15 + source/wham/src-HCD/include_unres/COMMON.CONTACTS | 5 + .../src-HCD/include_unres/COMMON.CONTACTS.safe | 71 + source/wham/src-HCD/include_unres/COMMON.CONTMAT | 26 + source/wham/src-HCD/include_unres/COMMON.CONTPAR | 3 + source/wham/src-HCD/include_unres/COMMON.CORRMAT | 47 + source/wham/src-HCD/include_unres/COMMON.DERIV | 69 + .../wham/src-HCD/include_unres/COMMON.DERIV_safe | 48 + source/wham/src-HCD/include_unres/COMMON.FFIELD | 31 + source/wham/src-HCD/include_unres/COMMON.FRAG | 5 + source/wham/src-HCD/include_unres/COMMON.GEO | 2 + source/wham/src-HCD/include_unres/COMMON.HEADER | 2 + source/wham/src-HCD/include_unres/COMMON.INTERACT | 36 + source/wham/src-HCD/include_unres/COMMON.LOCAL | 55 + source/wham/src-HCD/include_unres/COMMON.MINIM | 3 + source/wham/src-HCD/include_unres/COMMON.NAMES | 8 + source/wham/src-HCD/include_unres/COMMON.SBRIDGE | 29 + source/wham/src-HCD/include_unres/COMMON.SCCOR | 20 + source/wham/src-HCD/include_unres/COMMON.SCROT | 3 + source/wham/src-HCD/include_unres/COMMON.SETUP | 21 + source/wham/src-HCD/include_unres/COMMON.TIME1 | 13 + source/wham/src-HCD/include_unres/COMMON.TORCNSTR | 17 + source/wham/src-HCD/include_unres/COMMON.TORSION | 60 + .../wham/src-HCD/include_unres/COMMON.TORSION.safe | 55 + .../wham/src-HCD/include_unres/COMMON.TOTSION_safe | 35 + source/wham/src-HCD/include_unres/COMMON.VECTORS | 3 + source/wham/src-HCD/include_unres/COMMON.WEIGHTS | 22 + source/wham/src-HCD/initialize_p.F | 602 ++ source/wham/src-HCD/initialize_p.F.org | 571 ++ source/wham/src-HCD/int_from_cart.f | 65 + source/wham/src-HCD/intcor.f | 94 + source/wham/src-HCD/iperm.f | 15 + source/wham/src-HCD/make_ensemble1.F | 424 + source/wham/src-HCD/match_contact.f | 345 + source/wham/src-HCD/matmult.f | 18 + source/wham/src-HCD/misc.f | 203 + source/wham/src-HCD/molread_zs.F | 492 + source/wham/src-HCD/mygetenv.F | 55 + source/wham/src-HCD/mysort.f | 52 + source/wham/src-HCD/odlodc.f | 55 + source/wham/src-HCD/oligomer.F | 76 + source/wham/src-HCD/openunits.F | 109 + source/wham/src-HCD/parmread.F | 1828 ++++ source/wham/src-HCD/parmread.F.safe | 1651 +++ source/wham/src-HCD/permut.F | 61 + source/wham/src-HCD/pinorm.f | 17 + source/wham/src-HCD/printmat.f | 16 + source/wham/src-HCD/proc_cont.f | 156 + source/wham/src-HCD/proc_proc.c | 124 + source/wham/src-HCD/promienie.f | 46 + source/wham/src-HCD/qwolynes.f | 195 + source/wham/src-HCD/read_constr_homology.F | 719 ++ source/wham/src-HCD/read_dist_constr.F | 307 + source/wham/src-HCD/read_ref_str.F | 172 + source/wham/src-HCD/readpdb.F | 752 ++ source/wham/src-HCD/readpdb.unr | 513 + source/wham/src-HCD/readrtns.F | 1231 +++ source/wham/src-HCD/readrtns.F.org | 691 ++ source/wham/src-HCD/readrtns_compar.F | 167 + source/wham/src-HCD/refsys.f | 70 + source/wham/src-HCD/rescode.f | 32 + source/wham/src-HCD/rmscalc.F | 303 + source/wham/src-HCD/scr | 1 + source/wham/src-HCD/secondary.f | 713 ++ source/wham/src-HCD/seq2chains.f | 56 + source/wham/src-HCD/setup_var.f | 31 + source/wham/src-HCD/slices.F | 80 + source/wham/src-HCD/ssMD.F | 2168 ++++ source/wham/src-HCD/store_parm.F | 594 ++ source/wham/src-HCD/testseqchains | Bin 0 -> 897912 bytes source/wham/src-HCD/testseqchains.f | 33 + source/wham/src-HCD/timing.F | 238 + source/wham/src-HCD/timing.F.org | 163 + source/wham/src-HCD/wham_calc1.F | 1554 +++ source/wham/src-HCD/wham_calc1.F.safe | 1298 +++ source/wham/src-HCD/wham_multparm.F | 280 + source/wham/src-HCD/xdrf/CMakeLists.txt | 19 + source/wham/src-HCD/xdrf/Makefile | 27 + source/wham/src-HCD/xdrf/Makefile_jubl | 31 + source/wham/src-HCD/xdrf/Makefile_linux | 27 + source/wham/src-HCD/xdrf/RS6K.m4 | 20 + source/wham/src-HCD/xdrf/ftocstr.c | 35 + source/wham/src-HCD/xdrf/libxdrf.m4 | 1237 +++ source/wham/src-HCD/xdrf/underscore.m4 | 19 + source/wham/src-HCD/xdrf/xdrf.h | 10 + source/wham/src-HCD/xread.F | 187 + 287 files changed, 96010 insertions(+), 1141 deletions(-) create mode 100644 source/cluster/wham/src-HCD/CMakeLists.txt create mode 100644 source/cluster/wham/src-HCD/COMMON.CHAIN create mode 100644 source/cluster/wham/src-HCD/COMMON.CLUSTER create mode 100644 source/cluster/wham/src-HCD/COMMON.CONTACTS.org create mode 100644 source/cluster/wham/src-HCD/COMMON.CONTROL create mode 100644 source/cluster/wham/src-HCD/COMMON.DFA create mode 100644 source/cluster/wham/src-HCD/COMMON.FFIELD create mode 100644 source/cluster/wham/src-HCD/COMMON.FREE create mode 100644 source/cluster/wham/src-HCD/COMMON.GEO create mode 100644 source/cluster/wham/src-HCD/COMMON.HEADER create mode 100644 source/cluster/wham/src-HCD/COMMON.HOMOLOGY create mode 100644 source/cluster/wham/src-HCD/COMMON.HOMRESTR create mode 100644 source/cluster/wham/src-HCD/COMMON.IOUNITS create mode 100644 source/cluster/wham/src-HCD/COMMON.LANGEVIN create mode 100644 source/cluster/wham/src-HCD/COMMON.MCM create mode 100644 source/cluster/wham/src-HCD/COMMON.MINIM create mode 100644 source/cluster/wham/src-HCD/COMMON.MPI create mode 100644 source/cluster/wham/src-HCD/COMMON.NAMES create mode 100644 source/cluster/wham/src-HCD/COMMON.SAXS create mode 100644 source/cluster/wham/src-HCD/COMMON.SBRIDGE create mode 100644 source/cluster/wham/src-HCD/COMMON.SCCOR create mode 100644 source/cluster/wham/src-HCD/COMMON.SCROT create mode 100644 source/cluster/wham/src-HCD/COMMON.SHIELD create mode 100644 source/cluster/wham/src-HCD/COMMON.TEMPFAC create mode 100644 source/cluster/wham/src-HCD/COMMON.THREAD create mode 100644 source/cluster/wham/src-HCD/COMMON.TIME1 create mode 100644 source/cluster/wham/src-HCD/COMMON.TORSION.org create mode 100644 source/cluster/wham/src-HCD/COMMON.VAR create mode 100644 source/cluster/wham/src-HCD/DIMENSIONS create mode 100644 source/cluster/wham/src-HCD/DIMENSIONS.COMPAR create mode 120000 source/cluster/wham/src-HCD/Makefile create mode 100644 source/cluster/wham/src-HCD/Makefile-MPICH-gfortran create mode 100644 source/cluster/wham/src-HCD/Makefile-MPICH-ifort create mode 100644 source/cluster/wham/src-HCD/Makefile-MPICH-ifort-okeanos create mode 100644 source/cluster/wham/src-HCD/Makefile-MPICH-ifort-prometheus create mode 100644 source/cluster/wham/src-HCD/Makefile-okeanos create mode 100644 source/cluster/wham/src-HCD/TMscore.F create mode 100644 source/cluster/wham/src-HCD/arcos.f create mode 100644 source/cluster/wham/src-HCD/bakup/main_clust.F create mode 100644 source/cluster/wham/src-HCD/bakup/permut.f create mode 100644 source/cluster/wham/src-HCD/bakup/probabl.F create mode 100644 source/cluster/wham/src-HCD/bakup/read_coords.F create mode 100644 source/cluster/wham/src-HCD/cartprint.f create mode 100644 source/cluster/wham/src-HCD/chain_symmetry.F create mode 100644 source/cluster/wham/src-HCD/chainbuild.f create mode 100644 source/cluster/wham/src-HCD/compinfo.c create mode 100644 source/cluster/wham/src-HCD/contact.f create mode 100644 source/cluster/wham/src-HCD/convert.f create mode 100644 source/cluster/wham/src-HCD/dfa.F create mode 100644 source/cluster/wham/src-HCD/energy_p_new.F create mode 100644 source/cluster/wham/src-HCD/energy_p_new.F.safe create mode 100644 source/cluster/wham/src-HCD/fitsq.f create mode 100644 source/cluster/wham/src-HCD/geomout.F create mode 100644 source/cluster/wham/src-HCD/gnmr1.f create mode 100644 source/cluster/wham/src-HCD/hc.f create mode 100644 source/cluster/wham/src-HCD/icant.f create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.CALC create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.CONTACTS create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.CONTACTS.org create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.CONTACTS.safe create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.CONTMAT create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.CONTPAR create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.CORRMAT create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.DERIV create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.DERIV.org create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.FRAG create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.GEO create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.HEADER create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.INTERACT create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.LOCAL create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.MINIM create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.SCCOR create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.SCROT create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.SETUP create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.SPLITELE create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.TIME1 create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.TORCNSTR create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.TORSION create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.TORSION.org create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.VECTORS create mode 100644 source/cluster/wham/src-HCD/include_unres/COMMON.WEIGHTS create mode 100644 source/cluster/wham/src-HCD/initialize.f create mode 100644 source/cluster/wham/src-HCD/initialize.f_org create mode 100644 source/cluster/wham/src-HCD/initialize_p.F create mode 100644 source/cluster/wham/src-HCD/int_from_cart1.f create mode 100644 source/cluster/wham/src-HCD/intcor.f create mode 100644 source/cluster/wham/src-HCD/iperm.f create mode 100644 source/cluster/wham/src-HCD/log create mode 100644 source/cluster/wham/src-HCD/main_clust.F create mode 100644 source/cluster/wham/src-HCD/matmult.f create mode 100644 source/cluster/wham/src-HCD/misc.f create mode 100644 source/cluster/wham/src-HCD/noyes.f create mode 100644 source/cluster/wham/src-HCD/oligomer.f create mode 100644 source/cluster/wham/src-HCD/parmread.F create mode 100644 source/cluster/wham/src-HCD/permut.F create mode 100644 source/cluster/wham/src-HCD/pinorm.f create mode 100644 source/cluster/wham/src-HCD/printmat.f create mode 100644 source/cluster/wham/src-HCD/probabl.F create mode 100644 source/cluster/wham/src-HCD/proc_proc.c create mode 100644 source/cluster/wham/src-HCD/read_constr_homology.F create mode 100644 source/cluster/wham/src-HCD/read_coords.F create mode 100644 source/cluster/wham/src-HCD/read_ref_str.F create mode 100644 source/cluster/wham/src-HCD/readpdb.F create mode 100644 source/cluster/wham/src-HCD/readpdb.f.safe create mode 100644 source/cluster/wham/src-HCD/readrtns.F create mode 100644 source/cluster/wham/src-HCD/refsys.f create mode 100644 source/cluster/wham/src-HCD/rescode.f create mode 100644 source/cluster/wham/src-HCD/rmscalc.F create mode 100644 source/cluster/wham/src-HCD/rmsnat.f create mode 100644 source/cluster/wham/src-HCD/seq2chains.f create mode 100644 source/cluster/wham/src-HCD/setup_var.f create mode 100644 source/cluster/wham/src-HCD/sizesclu.dat create mode 100644 source/cluster/wham/src-HCD/srtclust.f create mode 100644 source/cluster/wham/src-HCD/ssMD.F create mode 100644 source/cluster/wham/src-HCD/timing.F create mode 100644 source/cluster/wham/src-HCD/track.F create mode 100644 source/cluster/wham/src-HCD/work_partition.F create mode 100644 source/cluster/wham/src-HCD/wrtclust.f create mode 100644 source/cluster/wham/src-HCD/xdrf/Makefile create mode 100644 source/cluster/wham/src-HCD/xdrf/Makefile_jubl create mode 100644 source/cluster/wham/src-HCD/xdrf/Makefile_linux create mode 100644 source/cluster/wham/src-HCD/xdrf/RS6K.m4 create mode 100644 source/cluster/wham/src-HCD/xdrf/ftocstr.c create mode 100644 source/cluster/wham/src-HCD/xdrf/libxdrf.m4 create mode 100644 source/cluster/wham/src-HCD/xdrf/types.h create mode 100644 source/cluster/wham/src-HCD/xdrf/underscore.m4 create mode 100644 source/cluster/wham/src-HCD/xdrf/xdr.c create mode 100644 source/cluster/wham/src-HCD/xdrf/xdr.h create mode 100644 source/cluster/wham/src-HCD/xdrf/xdr_array.c create mode 100644 source/cluster/wham/src-HCD/xdrf/xdr_float.c create mode 100644 source/cluster/wham/src-HCD/xdrf/xdr_stdio.c create mode 100644 source/cluster/wham/src-HCD/xdrf/xdrf.h create mode 100644 source/wham/src-HCD/CMakeLists.txt create mode 100644 source/wham/src-HCD/COMMON.ALLPARM create mode 100644 source/wham/src-HCD/COMMON.CHAIN create mode 100644 source/wham/src-HCD/COMMON.COMPAR create mode 100644 source/wham/src-HCD/COMMON.CONTACTS1 create mode 100644 source/wham/src-HCD/COMMON.CONTROL create mode 100644 source/wham/src-HCD/COMMON.CONTROL.org create mode 100644 source/wham/src-HCD/COMMON.DFA create mode 100644 source/wham/src-HCD/COMMON.ENEPS create mode 100644 source/wham/src-HCD/COMMON.ENERGIES create mode 100644 source/wham/src-HCD/COMMON.FREE create mode 100644 source/wham/src-HCD/COMMON.HOMOLOGY create mode 100644 source/wham/src-HCD/COMMON.HOMRESTR create mode 100644 source/wham/src-HCD/COMMON.IOUNITS create mode 100644 source/wham/src-HCD/COMMON.LANGEVIN create mode 100644 source/wham/src-HCD/COMMON.MPI create mode 100644 source/wham/src-HCD/COMMON.OBCINKA create mode 100644 source/wham/src-HCD/COMMON.PEPTCONT create mode 100644 source/wham/src-HCD/COMMON.PMF create mode 100644 source/wham/src-HCD/COMMON.PROT create mode 100644 source/wham/src-HCD/COMMON.PROTFILES create mode 100644 source/wham/src-HCD/COMMON.SAXS create mode 100644 source/wham/src-HCD/COMMON.SHIELD create mode 100644 source/wham/src-HCD/COMMON.SPLITELE create mode 100644 source/wham/src-HCD/COMMON.VAR create mode 100644 source/wham/src-HCD/DIMENSIONS create mode 100644 source/wham/src-HCD/DIMENSIONS.COMPAR create mode 100644 source/wham/src-HCD/DIMENSIONS.FREE create mode 100644 source/wham/src-HCD/DIMENSIONS.FREE.old create mode 100644 source/wham/src-HCD/DIMENSIONS.ZSCOPT create mode 120000 source/wham/src-HCD/Makefile create mode 100644 source/wham/src-HCD/Makefile-okeanos create mode 100644 source/wham/src-HCD/Makefile_MPICH_ifort create mode 100644 source/wham/src-HCD/Makefile_MPICH_ifort-okeanos create mode 100644 source/wham/src-HCD/Makefile_MPICH_ifort-prometheus create mode 100644 source/wham/src-HCD/Makefile_MPICH_pgi create mode 100644 source/wham/src-HCD/PMFprocess.F create mode 100644 source/wham/src-HCD/a create mode 100644 source/wham/src-HCD/angnorm.f create mode 100644 source/wham/src-HCD/arcos.f create mode 100644 source/wham/src-HCD/bxread.F create mode 100644 source/wham/src-HCD/cartder.f create mode 100644 source/wham/src-HCD/cartprint.f create mode 100644 source/wham/src-HCD/chain_symmetry.F create mode 100644 source/wham/src-HCD/chainbuild.F create mode 100644 source/wham/src-HCD/chainbuild.rrr create mode 100644 source/wham/src-HCD/compinfo.c create mode 100644 source/wham/src-HCD/conf_compar.F create mode 100644 source/wham/src-HCD/cont_frag.f create mode 100644 source/wham/src-HCD/contact.f create mode 100644 source/wham/src-HCD/contfunc.f create mode 100644 source/wham/src-HCD/cxread.F create mode 100644 source/wham/src-HCD/cxread.F.org create mode 100644 source/wham/src-HCD/define_pairs.f create mode 100644 source/wham/src-HCD/dfa.F create mode 100644 source/wham/src-HCD/elecont.f create mode 100644 source/wham/src-HCD/enecalc1.F create mode 100644 source/wham/src-HCD/energy_p_new.F create mode 100644 source/wham/src-HCD/energy_p_new.F.org create mode 100644 source/wham/src-HCD/fitsq.f create mode 100644 source/wham/src-HCD/geomout.F create mode 100644 source/wham/src-HCD/gnmr1.f create mode 100644 source/wham/src-HCD/icant.f create mode 100644 source/wham/src-HCD/include_unres/COMMON.CALC create mode 100644 source/wham/src-HCD/include_unres/COMMON.CONTACTS create mode 100644 source/wham/src-HCD/include_unres/COMMON.CONTACTS.safe create mode 100644 source/wham/src-HCD/include_unres/COMMON.CONTMAT create mode 100644 source/wham/src-HCD/include_unres/COMMON.CONTPAR create mode 100644 source/wham/src-HCD/include_unres/COMMON.CORRMAT create mode 100644 source/wham/src-HCD/include_unres/COMMON.DERIV create mode 100644 source/wham/src-HCD/include_unres/COMMON.DERIV_safe create mode 100644 source/wham/src-HCD/include_unres/COMMON.FFIELD create mode 100644 source/wham/src-HCD/include_unres/COMMON.FRAG create mode 100644 source/wham/src-HCD/include_unres/COMMON.GEO create mode 100644 source/wham/src-HCD/include_unres/COMMON.HEADER create mode 100644 source/wham/src-HCD/include_unres/COMMON.INTERACT create mode 100644 source/wham/src-HCD/include_unres/COMMON.LOCAL create mode 100644 source/wham/src-HCD/include_unres/COMMON.MINIM create mode 100644 source/wham/src-HCD/include_unres/COMMON.NAMES create mode 100644 source/wham/src-HCD/include_unres/COMMON.SBRIDGE create mode 100644 source/wham/src-HCD/include_unres/COMMON.SCCOR create mode 100644 source/wham/src-HCD/include_unres/COMMON.SCROT create mode 100644 source/wham/src-HCD/include_unres/COMMON.SETUP create mode 100644 source/wham/src-HCD/include_unres/COMMON.TIME1 create mode 100644 source/wham/src-HCD/include_unres/COMMON.TORCNSTR create mode 100644 source/wham/src-HCD/include_unres/COMMON.TORSION create mode 100644 source/wham/src-HCD/include_unres/COMMON.TORSION.safe create mode 100644 source/wham/src-HCD/include_unres/COMMON.TOTSION_safe create mode 100644 source/wham/src-HCD/include_unres/COMMON.VECTORS create mode 100644 source/wham/src-HCD/include_unres/COMMON.WEIGHTS create mode 100644 source/wham/src-HCD/initialize_p.F create mode 100644 source/wham/src-HCD/initialize_p.F.org create mode 100644 source/wham/src-HCD/int_from_cart.f create mode 100644 source/wham/src-HCD/intcor.f create mode 100644 source/wham/src-HCD/iperm.f create mode 100644 source/wham/src-HCD/make_ensemble1.F create mode 100644 source/wham/src-HCD/match_contact.f create mode 100644 source/wham/src-HCD/matmult.f create mode 100644 source/wham/src-HCD/misc.f create mode 100644 source/wham/src-HCD/module create mode 100644 source/wham/src-HCD/molread_zs.F create mode 100644 source/wham/src-HCD/mygetenv.F create mode 100644 source/wham/src-HCD/mysort.f create mode 100644 source/wham/src-HCD/odlodc.f create mode 100644 source/wham/src-HCD/oligomer.F create mode 100644 source/wham/src-HCD/openunits.F create mode 100644 source/wham/src-HCD/parmread.F create mode 100644 source/wham/src-HCD/parmread.F.safe create mode 100644 source/wham/src-HCD/permut.F create mode 100644 source/wham/src-HCD/pinorm.f create mode 100644 source/wham/src-HCD/printmat.f create mode 100644 source/wham/src-HCD/proc_cont.f create mode 100644 source/wham/src-HCD/proc_proc.c create mode 100644 source/wham/src-HCD/promienie.f create mode 100644 source/wham/src-HCD/qwolynes.f create mode 100644 source/wham/src-HCD/read_constr_homology.F create mode 100644 source/wham/src-HCD/read_dist_constr.F create mode 100644 source/wham/src-HCD/read_ref_str.F create mode 100644 source/wham/src-HCD/readpdb.F create mode 100644 source/wham/src-HCD/readpdb.unr create mode 100644 source/wham/src-HCD/readrtns.F create mode 100644 source/wham/src-HCD/readrtns.F.org create mode 100644 source/wham/src-HCD/readrtns_compar.F create mode 100644 source/wham/src-HCD/refsys.f create mode 100644 source/wham/src-HCD/rescode.f create mode 100644 source/wham/src-HCD/rmscalc.F create mode 100644 source/wham/src-HCD/scr create mode 100644 source/wham/src-HCD/secondary.f create mode 100644 source/wham/src-HCD/seq2chains.f create mode 100644 source/wham/src-HCD/setup_var.f create mode 100644 source/wham/src-HCD/slices.F create mode 100644 source/wham/src-HCD/ssMD.F create mode 100644 source/wham/src-HCD/store_parm.F create mode 100644 source/wham/src-HCD/testseqchains create mode 100644 source/wham/src-HCD/testseqchains.f create mode 100644 source/wham/src-HCD/timing.F create mode 100644 source/wham/src-HCD/timing.F.org create mode 100644 source/wham/src-HCD/wham_calc1.F create mode 100644 source/wham/src-HCD/wham_calc1.F.safe create mode 100644 source/wham/src-HCD/wham_multparm.F create mode 100644 source/wham/src-HCD/xdrf/CMakeLists.txt create mode 100644 source/wham/src-HCD/xdrf/Makefile create mode 100644 source/wham/src-HCD/xdrf/Makefile_jubl create mode 100644 source/wham/src-HCD/xdrf/Makefile_linux create mode 100644 source/wham/src-HCD/xdrf/RS6K.m4 create mode 100644 source/wham/src-HCD/xdrf/ftocstr.c create mode 100644 source/wham/src-HCD/xdrf/libxdrf.m4 create mode 100644 source/wham/src-HCD/xdrf/underscore.m4 create mode 100644 source/wham/src-HCD/xdrf/xdrf.h create mode 100644 source/wham/src-HCD/xread.F diff --git a/source/cluster/wham/src-HCD/CMakeLists.txt b/source/cluster/wham/src-HCD/CMakeLists.txt new file mode 100644 index 0000000..30193dd --- /dev/null +++ b/source/cluster/wham/src-HCD/CMakeLists.txt @@ -0,0 +1,173 @@ +# +# CMake project file for cluster analysis from WHAM for oligomeric proteins +# + +enable_language (Fortran C) + +#================================ +# Set source file lists +#================================ +set(UNRES_CLUSTER_WHAM_M_SRC0 + arcos.f + cartprint.f + chainbuild.f + contact.f + convert.f + energy_p_new.F + fitsq.f + geomout.F + gnmr1.f + hc.f + icant.f + initialize_p.F + intcor.f + int_from_cart1.f + main_clust.F + matmult.f + misc.f + noyes.f + parmread.F + permut.f + pinorm.f + printmat.f + probabl.F + read_coords.F + readpdb.f + readrtns.F + rescode.f + setup_var.f + srtclust.f + ssMD.F + timing.F + track.F + wrtclust.f + work_partition.F +) + +set(UNRES_CLUSTER_WHAM_M_PP_SRC + energy_p_new.F + initialize_p.F + geomout.F + main_clust.F + parmread.F + probabl.F + read_coords.F + readrtns.F + ssMD.F + timing.F + track.F + work_partition.F +) + + +#================================================ +# Set comipiler flags for different sourcefiles +#================================================ +if (Fortran_COMPILER_NAME STREQUAL "ifort") + set(FFLAGS0 "-mcmodel=medium -shared-intel -ip -w -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" ) +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + set(FFLAGS0 "-std=legacy -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" ) +else () + set(FFLAGS0 "-I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" ) +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + +#========================================= +# Add MPI compiler flags +#========================================= +if(UNRES_WITH_MPI) + set(FFLAGS0 "${FFLAGS0} -I${MPI_Fortran_INCLUDE_PATH}") +endif(UNRES_WITH_MPI) + +set_property(SOURCE ${UNRES_CLUSTER_WHAM_M_SRC0} PROPERTY COMPILE_FLAGS ${FFLAGS0} ) + +#========================================= +# Settings for GAB force field +#========================================= +if(UNRES_MD_FF STREQUAL "GAB" ) + # set preprocesor flags + set(CPPFLAGS "PROCOR -DSPLITELE -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCCORPDB" ) + +#========================================= +# Settings for E0LL2Y force field +#========================================= +elseif(UNRES_MD_FF STREQUAL "E0LL2Y") + # set preprocesor flags + set(CPPFLAGS "PROCOR -DSPLITELE -DSCCORPDB" ) +endif(UNRES_MD_FF STREQUAL "GAB") + +#========================================= +# Additional flags +#========================================= +set(CPPFLAGS "${CPPFLAGS} -DUNRES -DISNAN") + +#========================================= +# Compiler specific flags +#========================================= +if (Fortran_COMPILER_NAME STREQUAL "ifort") + # Add ifort preprocessor flags + set(CPPFLAGS "${CPPFLAGS} -DPGI" ) +elseif (Fortran_COMPILER_NAME STREQUAL "f95") + # Add new gfortran flags + set(CPPFLAGS "${CPPFLAGS} -DG77") +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + # Add old gfortran flags + set(CPPFLAGS "${CPPFLAGS} -DG77") +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + + +#========================================= +# System specific flags +#========================================= +if(${CMAKE_SYSTEM_NAME} MATCHES "Linux") + set(CPPFLAGS "${CPPFLAGS} -DLINUX") +endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux") + +#========================================= +# Add MPI preprocessor flags +#========================================= +if (UNRES_WITH_MPI) + set(CPPFLAGS "${CPPFLAGS} -DMP -DMPI") +endif(UNRES_WITH_MPI) + + +#========================================= +# Apply preprocesor flags to *.F files +#========================================= +set_property(SOURCE ${UNRES_CLUSTER_WHAM_M_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) + +set_property(SOURCE proc_proc.c PROPERTY COMPILE_DEFINITIONS "LINUX -DPGI" ) + +#======================================== +# Setting binary name +#======================================== +set(UNRES_CLUSTER_WHAM_M_BIN +"cluster_wham-M_${Fortran_COMPILER_NAME}_${UNRES_MD_FF}.exe") + +#========================================= +# Set full unres CLUSTER sources +#========================================= +set(UNRES_CLUSTER_WHAM_M_SRCS ${UNRES_CLUSTER_WHAM_M_SRC0} proc_proc.c) + +#========================================= +# Build the binary +#========================================= +add_executable(UNRES_CLUSTER_WHAM_M_BIN ${UNRES_CLUSTER_WHAM_M_SRCS} ) +set_target_properties(UNRES_CLUSTER_WHAM_M_BIN PROPERTIES OUTPUT_NAME ${UNRES_CLUSTER_WHAM_M_BIN}) +set_property(TARGET UNRES_CLUSTER_WHAM_M_BIN PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin ) + +#========================================= +# Link libraries +#========================================= +# link MPI libraries +if(UNRES_WITH_MPI) + target_link_libraries( UNRES_CLUSTER_WHAM_M_BIN ${MPI_Fortran_LIBRARIES} ) +endif(UNRES_WITH_MPI) +# link libxdrf.a +target_link_libraries( UNRES_CLUSTER_WHAM_M_BIN xdrf ) + + +#========================================= +# Install Path +#========================================= +install(TARGETS UNRES_CLUSTER_WHAM_M_BIN DESTINATION ${CMAKE_INSTALL_PREFIX}/cluster) + diff --git a/source/cluster/wham/src-HCD/COMMON.CHAIN b/source/cluster/wham/src-HCD/COMMON.CHAIN new file mode 100644 index 0000000..9de64dd --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.CHAIN @@ -0,0 +1,21 @@ + integer nres,nres0,nsup,nstart_sup,nend_sup,nstart_seq, + & nchain,chain_border,chain_length,ireschain,npermchain, + & tabpermchain,ishift_pdb,iz_sc + double precision c,cref,crefjlee,cref_pdb,dc,xloc,xrot,dc_norm, + & t,r,prod,rt,chomo + common /chain/ c(3,maxres2+2),dc(3,maxres2),xloc(3,maxres), + & xrot(3,maxres),dc_norm(3,maxres2),nres,nres0 + common /rotmat/ t(3,3,maxres),r(3,3,maxres),prod(3,3,maxres), + & rt(3,3,maxres) + common /refstruct/ cref(3,maxres2+2),crefjlee(3,maxres2+2), + & cref_pdb(3,maxres2+2),iz_sc,nsup,nstart_sup, + & nstart_seq,nend_sup, + & chain_length(maxchain),npermchain,ireschain(maxres), + & tabpermchain(maxchain,maxperm), + & chain_border(2,maxchain),nchain + double precision boxxsize,boxysize,boxzsize,enecut,sscut,sss, + & sssgrad, + & buflipbot, bufliptop,bordlipbot,bordliptop,lipbufthick,lipthick + common /box/ boxxsize,boxysize,boxzsize,enecut,sscut,sss,sssgrad, + & buflipbot, bufliptop,bordlipbot,bordliptop,lipbufthick,lipthick + common /chomo_models/ chomo(3,maxres2+2,max_template) diff --git a/source/cluster/wham/src-HCD/COMMON.CLUSTER b/source/cluster/wham/src-HCD/COMMON.CLUSTER new file mode 100644 index 0000000..46dbf75 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.CLUSTER @@ -0,0 +1,23 @@ + logical tree,plot_tree,lgrp,min_var + real*8 rcutoff,ecut + double precision totfree_gr + real*4 diss,allcart + double precision entfac,totfree,energy,rmstb,gdt_ts_tb, + & gdt_ha_tb,tmscore_tb + integer ncut,ngr,licz,nconf,iass,icc,mult,list_conf, + & nss_all,ihpb_all,jhpb_all,iass_tot,iscore,nprop,nclust + real*8 rmsave,rms_closest,gdt_ts_ave,gdt_ts_closest, + & gdt_ha_ave,gdt_ha_closest,tmscore_ave,tmscore_closest + common /clu/ diss(maxdist),energy(0:maxconf),ecut, + & entfac(maxconf),totfree(0:maxconf),totfree_gr(maxgr), + & rcutoff(max_cut+1),ncut,nclust,min_var,tree,plot_tree,lgrp + common /clu1/ ngr,licz(maxgr),nconf(maxgr,maxingr),iass(maxgr), + & iass_tot(maxgr,max_cut),list_conf(maxconf) + common /alles/ allcart(3,maxres2,maxconf),rmstb(maxconf), + & gdt_ts_tb(maxconf),gdt_ha_tb(maxconf),tmscore_tb(maxconf), + & rmsave(maxgr),rms_closest(maxgr),gdt_ts_ave(maxgr), + & gdt_ts_closest(maxgr),gdt_ha_ave(maxgr),gdt_ha_closest(maxgr), + & tmscore_ave(maxgr),tmscore_closest(maxgr), + & icc(maxconf), + & mult(maxres),nss_all(maxconf),ihpb_all(maxss,maxconf), + & jhpb_all(maxss,maxconf),iscore(maxconf),nprop diff --git a/source/cluster/wham/src-HCD/COMMON.CONTACTS.org b/source/cluster/wham/src-HCD/COMMON.CONTACTS.org new file mode 100644 index 0000000..1487839 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.CONTACTS.org @@ -0,0 +1,73 @@ +C Change 12/1/95 - common block CONTACTS1 included. + integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont + double precision facont,gacont + common /contacts/ ncont,ncont_ref,icont(2,maxcont), + & icont_ref(2,maxcont) + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + double precision gacontp_hb1,gacontp_hb2,gacontp_hb3,gacontm_hb1, + & gacontm_hb2,gacontm_hb3,gacont_hbr,facont_hb,ees0p,ees0m,d_cont, + & grij_hb_cont + integer num_cont_hb,jcont_hb + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +C Interactions of pseudo-dipoles generated by loc-el interactions. + double precision dip,dipderg,dipderx + common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), + & dipderx(3,5,4,maxconts,maxres) +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres), + & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder,Ug2DtEUg,Ug2DtEUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),DtUg2EUgder(2,2,2,maxres), + & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres),muder(2,maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx,EAEA,EAEAderg,EAEAderx, + & ADtEA1,ADtEA1derg,ADtEA1derx,g_contij,ekont + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont diff --git a/source/cluster/wham/src-HCD/COMMON.CONTROL b/source/cluster/wham/src-HCD/COMMON.CONTROL new file mode 100644 index 0000000..cd8d0fe --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.CONTROL @@ -0,0 +1,16 @@ + double precision betaT + integer iscode,indpdb,outpdb,outmol2,iopt,nstart,nend,symetr, + & constr_dist,shield_mode,tor_mode,constr_homology,homol_nset + logical refstr,pdbref,punch_dist,print_dist,caonly,lside, + & lprint_cart,lprint_int,from_cart,lefree,from_bx,from_cx, + & with_dihed_constr,with_theta_constr,energy_dec,print_fittest, + & read2sigma,read_homol_frag,out_template_coord,out_template_restr, + & unres_pdb + common /cntrl/ betaT,iscode,indpdb,refstr,pdbref,outpdb,outmol2, + & punch_dist,print_dist,caonly,lside,lprint_cart,lprint_int, + & from_cart,from_bx,from_cx, with_dihed_constr,with_theta_constr, + & lefree,iopt,nstart,nend,symetr,unres_pdb, + & tor_mode,shield_mode, + & constr_dist,energy_dec,print_fittest, + & constr_homology,homol_nset,read2sigma,read_homol_frag, + & out_template_coord,out_template_restr diff --git a/source/cluster/wham/src-HCD/COMMON.DFA b/source/cluster/wham/src-HCD/COMMON.DFA new file mode 100644 index 0000000..c6add4f --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.DFA @@ -0,0 +1,101 @@ +C ======= +C COMMON.DFA +C ======= +C 2010/12/20 By Juyong Lee +C +c parameter +C [ 8 * ( Nres - 8 ) ] distance restraints +C [ 2 * ( Nres - 8 ) ] angle restraints +C [ Nres ] neighbor restraints +C Total : ~ 11 * Nres restraints +C +C + INTEGER IDFAMAX,IDFAMX2,IDFACMD,IDMAXMIN, MAXN + PARAMETER(IDFAMAX=4000,IDFAMX2=1000,IDFACMD=500,IDMAXMIN=500) + PARAMETER(MAXN=4) + real*8 wwdist,wwangle,wwnei + parameter(wwdist=1.0d0,wwangle=1.0d0,wwnei=1.0d0) + +C IDFAMAX - maximum number of DFA restraint including distance, angle and +C number of neighbors ( Max of assign statement ) +C IDFAMX2 - maximum number of atoms which are targets of restraints +C IDFACMD - maximum number of 'DFA' command call +C IDMAXMIN - Maximum number of minima of dist, angle and neighbor info. from fragments +C MAXN - Maximum Number of shell, currently 4 +C MAXRES - Maximum number of CAs + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc +C INTEGER +C DFANUM - Number of ALL DFA restrants +c IDFA[DIS, PHI, THE, NEI] - NUMBER of restraints +c IDISNUM - number of minima for a distance restraint +c IPHINUM - number of minima for a phi angle restraint +c ITHENUM - number of minima for a theta angle restraint +c INEINUM - number of minima for a number of neighbors restraint + +c IDISLIS - atom number of two atoms for distance restraint +c IPHILIS - atom numbers of four atoms for angle restraint +c ITHELIS - atom numbers of four atoms for angle restraint +c INEILIS - atom number of center of neighbor calculation +c JNEILIS - atom number of target of neighboring calculation +c JNEINUM - number of target atoms of neighboring term +C KSHELL - SHELL number + +C ishiftca - index shift for CA atoms in UNRES (1 if the 1st aa != GLY) +C ilastca - index of the last CA atom in UNRES (nres-1 if last aa != GLY) + +C old only for CHARMM +C STOAGDF - Store assign information ( How many assign within one command ) +C NMAP - mapping between dfanum and ndis, nphi, nthe, nnei + + INTEGER IDFADIS,IDFAPHI,IDFATHE,IDFANEI, + & IDISLIS,IPHILIS,ITHELIS,INEILIS, + & IDISNUM,IPHINUM,ITHENUM,INEINUM, + & FNEI,DFACMD, DFANUM, + & NCA,ICAIDX, + & STOAGDF, NMAP, IDFACAT, KDISNUM, KSHELL + & ishiftca,ilastca + COMMON /IDFA/ DFACMD, DFANUM, + & IDFADIS, IDFAPHI, IDFANEI, IDFATHE, + & IDISNUM(IDFAMAX), IPHINUM(IDFAMAX), + & ITHENUM(IDFAMAX), INEINUM(IDFAMAX), + & FNEI(IDFAMAX,IDMAXMIN), IDISLIS(2,IDFAMAX), + & IPHILIS(5,IDFAMAX), ITHELIS(5,IDFAMAX), + & INEILIS(IDFAMAX), + & KSHELL(IDFAMAX), + & IDFACAT(IDFACMD), + & KDISNUM(IDFAMAX), + & NCA, ICAIDX(MAXRES) + COMMON /IDFA2/ ishiftca,ilastca + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C REAL VARIABLES +C +c SCC[DIST, PHI, THE] - weight of each calculations +c FDIST - distance minima +C FPHI - phi minima +c FTHE - theta minima +C DFAEXP : calculate expential function in advance +C + REAL*8 SCCDIST, SCCPHI, SCCTHE, SCCNEI, FDIST, FPHI1, FPHI2, + & FTHE1, FTHE2, + & DIS_INC, PHI_INC, THE_INC, NEI_INC, BETA_INC, + & WSHET, EDFABET, + & CK, SCK, S1, S2 +c & ,DFAEXP + + COMMON /RDFA/ SCCDIST(IDFAMAX,IDMAXMIN),FDIST(IDFAMAX,IDMAXMIN), + & SCCPHI(IDFAMAX,IDMAXMIN), SCCTHE(IDFAMAX,IDMAXMIN), + & SCCNEI(IDFAMAX,IDMAXMIN), + & FPHI1(IDFAMAX,IDMAXMIN), FPHI2(IDFAMAX,IDMAXMIN), + & FTHE1(IDFAMAX,IDMAXMIN), FTHE2(IDFAMAX,IDMAXMIN), + & DIS_INC, PHI_INC, THE_INC, NEI_INC, BETA_INC, + & WSHET(MAXRES,MAXRES), EDFABET, + & CK(4),SCK(4),S1(4),S2(4) +c & ,DFAEXP(15001), + + DATA CK/1.0D0,1.58740105197D0,2.08008382305D0,2.51984209979D0/ + DATA SCK/1.0D0,1.25992104989D0,1.44224957031D0,1.58740105197D0/ + DATA S1/3.75D0,5.75D0,7.75D0,9.75D0/ + DATA S2/4.25D0,6.25D0,8.25D0,10.25D0/ diff --git a/source/cluster/wham/src-HCD/COMMON.FFIELD b/source/cluster/wham/src-HCD/COMMON.FFIELD new file mode 100644 index 0000000..aab43b9 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.FFIELD @@ -0,0 +1,32 @@ +C----------------------------------------------------------------------- +C The following COMMON block selects the type of the force field used in +C calculations and defines weights of various energy terms. +C 12/1/95 wcorr added +C----------------------------------------------------------------------- + double precision wsc,wscp,welec,wstrain,wtor,wtor_d,wang,wscloc, + & wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4,wturn6, + & wvdwpp,wbond,weights,scal14,scalscp,cutoff_corr,delt_corr, + & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta, + & r0_corr,wliptran,wsaxs + integer ipot,n_ene_comp,rescale_mode + common /ffield/ wsc,wscp,welec,wstrain,wtor,wtor_d,wang,wscloc, + & wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4,wturn6, + & wvdwpp,wbond,wliptran,wsaxs, + & weights(max_ene),scalscp, + & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta, + & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp, + & rescale_mode + common /potentials/ potname(5) + character*3 potname +C----------------------------------------------------------------------- +C wlong,welec,wtor,wang,wscloc are the weight of the energy terms +C corresponding to side-chain, electrostatic, torsional, valence-angle, +C and local side-chain terms. +C +C IPOT determines which SC...SC interaction potential will be used: +C 1 - LJ: 2n-n Lennard-Jones +C 2 - LJK: 2n-n Kihara type (shifted Lennard-Jones) +C 3 - BP; Berne-Pechukas (angular dependence) +C 4 - GB; Gay-Berne (angular dependence) +C 5 - GBV; Gay-Berne-Vorobjev; angularly-dependent Kihara potential +C------------------------------------------------------------------------ diff --git a/source/cluster/wham/src-HCD/COMMON.FREE b/source/cluster/wham/src-HCD/COMMON.FREE new file mode 100644 index 0000000..7e86fe7 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.FREE @@ -0,0 +1,3 @@ + integer nT + double precision beta_h(maxT),prob_limit + common /free/ beta_h,prob_limit,nT diff --git a/source/cluster/wham/src-HCD/COMMON.GEO b/source/cluster/wham/src-HCD/COMMON.GEO new file mode 100644 index 0000000..8cfbbde --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.GEO @@ -0,0 +1,2 @@ + double precision pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin + common /geo/ pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin diff --git a/source/cluster/wham/src-HCD/COMMON.HEADER b/source/cluster/wham/src-HCD/COMMON.HEADER new file mode 100644 index 0000000..7154812 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.HEADER @@ -0,0 +1,2 @@ + character*80 titel + common /header/ titel diff --git a/source/cluster/wham/src-HCD/COMMON.HOMOLOGY b/source/cluster/wham/src-HCD/COMMON.HOMOLOGY new file mode 100644 index 0000000..e2a7754 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.HOMOLOGY @@ -0,0 +1,8 @@ + logical l_homo + integer iset,ihset + real*8 waga_homology + real*8 waga_dist, waga_angle, waga_theta, waga_d, dist_cut, + & dist2_cut + common /homol/ waga_homology(10), + & waga_dist,waga_angle,waga_theta,waga_d,dist_cut,dist2_cut, + & iset,ihset,l_homo(max_template,maxdim) diff --git a/source/cluster/wham/src-HCD/COMMON.HOMRESTR b/source/cluster/wham/src-HCD/COMMON.HOMRESTR new file mode 100644 index 0000000..95ea932 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.HOMRESTR @@ -0,0 +1,39 @@ + real*8 odl(max_template,maxdim),sigma_odl(max_template,maxdim), + & dih(max_template,maxres),sigma_dih(max_template,maxres), + & sigma_odlir(max_template,maxdim) +c +c Specification of new variables used in subroutine e_modeller +c modified by FP (Nov.,2014) + real*8 xxtpl(max_template,maxres),yytpl(max_template,maxres), + & zztpl(max_template,maxres),thetatpl(max_template,maxres), + & sigma_theta(max_template,maxres), + & sigma_d(max_template,maxres) +c + + integer ires_homo(maxdim),jres_homo(maxdim) + + double precision + & Ucdfrag,Ucdpair,dUdconst(3,0:MAXRES),Uconst, + & dUdxconst(3,0:MAXRES),dqwol(3,0:MAXRES),dxqwol(3,0:MAXRES), + & dutheta(maxres),dugamma(maxres), + & duscdiff(3,maxres), + & duscdiffx(3,maxres), + & uconst_back + integer lim_odl,lim_dih,link_start_homo,link_end_homo, + & idihconstr_start_homo,idihconstr_end_homo +c +c FP (30/10/2014) +c +c integer ithetaconstr_start_homo,ithetaconstr_end_homo +c + integer nresn,nyosh,nnos + common /back_constr/ uconst_back, + & dutheta,dugamma,duscdiff,duscdiffx + common /homrestr/ odl,dih,sigma_dih,sigma_odl, + & lim_odl,lim_dih,ires_homo,jres_homo,link_start_homo, + & link_end_homo,idihconstr_start_homo,idihconstr_end_homo, +c +c FP (30/10/2014,04/03/2015) +c + & xxtpl,yytpl,zztpl,thetatpl,sigma_theta,sigma_d,sigma_odlir +c diff --git a/source/cluster/wham/src-HCD/COMMON.IOUNITS b/source/cluster/wham/src-HCD/COMMON.IOUNITS new file mode 100644 index 0000000..d171ae0 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.IOUNITS @@ -0,0 +1,63 @@ +C----------------------------------------------------------------------- +C I/O units used by the program +C----------------------------------------------------------------------- +C 9/18/99 - unit ifourier and filename fouriername included to identify +C the file from which the coefficients of second-order Fourier expansion +C of the local-interaction energy are read. +C 8/9/01 - file for SCP interaction constants named scpname (unit iscpp) +C included. +C----------------------------------------------------------------------- +C General I/O units & files + integer inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,irotam, + & itorp,itordp,ifourier,ielep,isidep,iscpp,icbase,istat, + & ientin,ientout,isidep1,ibond,isccor,jrms,jplot, + & iliptranpar + common /iounits/ inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep, + & irotam,itorp,itordp,ifourier,ielep,isidep,iscpp,icbase, + & istat,ientin,ientout,isidep1,ibond,isccor,jrms,jplot, + & iliptranpar + character*256 outname,intname,pdbname,mol2name,statname,intinname, + & entname,restartname,prefix,scratchdir,sidepname,pdbfile, + & sccorname,rmsname,prefintin,prefout + common /fnames/ outname,intname,pdbname,mol2name,statname, + & intinname,entname,restartname,prefix,pot,scratchdir, + & sccorname,sidepname,pdbfile,rmsname,prefintin,prefout +C CSA I/O units & files + character*256 csa_rbank,csa_seed,csa_history,csa_bank, + & csa_bank1,csa_alpha,csa_alpha1,csa_bankt,csa_int, + & csa_bank_reminimized,csa_native_int,csa_in + common /csafiles/ csa_rbank,csa_seed,csa_history,csa_bank, + & csa_bank1,csa_alpha,csa_alpha1,csa_bankt,csa_int, + & csa_bank_reminimized,csa_native_int,csa_in + integer icsa_rbank,icsa_seed,icsa_history,icsa_bank, + & icsa_bank1,icsa_alpha,icsa_alpha1,icsa_bankt,icsa_int, + & icsa_bank_reminimized,icsa_native_int,icsa_in + common /csaunits/ icsa_rbank,icsa_seed,icsa_history,icsa_bank, + & icsa_bank1,icsa_alpha,icsa_alpha1,icsa_bankt,icsa_int, + & icsa_bank_reminimized,icsa_native_int,icsa_in +C Parameter files + character*256 bondname,thetname,rotname,torname,tordname, + & fouriername,elename,sidename,scpname,patname,liptranname + common /parfiles/ thetname,rotname,torname,tordname,bondname, + & fouriername,elename,sidename,scpname,patname,liptranname + character*3 pot +C----------------------------------------------------------------------- +C INP - main input file +C IOUT - list file +C IGEOM - geometry output in the form of virtual-chain internal coordinates +C INTIN - geometry input (for multiple conformation processing) in int. coords. +C IPDB - Cartesian-coordinate output in PDB format +C IMOL2 - Cartesian-coordinate output in Tripos mol2 format +C IPDBIN - PDB input file +C ITHEP - virtual-bond torsional angle parametrs +C IROTAM - side-chain geometry and local-interaction parameters +C ITORP - torsional parameters +C ITORDP - double torsional parameters +C IFOURIER - coefficients of the expansion of local-interaction energy +C IELEP - electrostatic-interaction parameters +C ISIDEP - side-chain interaction parameters. +C ISCPP - SCp interaction parameters. +C ICBASE - data base with Cartesian coords of known structures. +C ISTAT - energies and other conf. characteristics from an MCM run. +C IENTIN - entropy from preceding simulation(s) to be read in. +C----------------------------------------------------------------------- diff --git a/source/cluster/wham/src-HCD/COMMON.LANGEVIN b/source/cluster/wham/src-HCD/COMMON.LANGEVIN new file mode 100644 index 0000000..982bde9 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.LANGEVIN @@ -0,0 +1,8 @@ + double precision scal_fric,rwat,etawat,gamp, + & gamsc(ntyp1),stdfp,stdfsc(ntyp),stdforcp(MAXRES), + & stdforcsc(MAXRES),pstok,restok(ntyp+1),cPoise,Rb + common /langevin/ pstok,restok,gamp,gamsc, + & stdfp,stdfsc,stdforcp,stdforcsc,rwat,etawat,cPoise,Rb + double precision IP,ISC(ntyp+1),mp, + & msc(ntyp+1) + common /inertia/ IP,ISC,MP,MSC diff --git a/source/cluster/wham/src-HCD/COMMON.MCM b/source/cluster/wham/src-HCD/COMMON.MCM new file mode 100644 index 0000000..576f912 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.MCM @@ -0,0 +1,70 @@ +C... Following COMMON block contains general variables controlling the MC/MCM +C... procedure +c----------------------------------------------------------------------------- + double precision Tcur,Tmin,Tmax,TstepH,TstepC,RanFract, + & overlap_cut,e_up,delte + integer nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter, + & maxrepm,ngen,ntrial,ntherm,nrepm,neneval,nsave,maxoverlap, + & nsave_part,max_mcm_it,nsweep,print_mc + logical print_stat,print_int + common /mcm/ Tcur,Tmin,Tmax,TstepH,TstepC,Rbol,betbol,RanFract, + & overlap_cut,e_up,delte, + & nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter,maxrepm, + & maxoverlap,ntrial,max_mcm_it, + & ngen,ntherm,nrepm,neneval,nsave,nsave_part(max_cg_procs),nsweep, + & print_mc,print_stat,print_int +c----------------------------------------------------------------------------- +C... The meaning of the above variables is as follows: +C... Tcur,Tmin,Tmax - Current,minimum and maximum temperature, respectively; +C... NstepC,NStepH - Number of cooling and heating steps, respectively; +C... TstepH,TstepC - factors by which T is multiplied in order to be +C... increased or decreased. +C... betbol - Boltzmann's inverse temperature (1/(Rbol*Tcur)); +C... Rbol - the gas constant; +C... RanFract - the chance that a new conformation will be random-generated; +C... maxacc - maximum number of accepted conformations; +C... maxgen,ngen - Maximum and current number of generated conformations; +C... maxtrial,ntrial - maximum number of trials before temperature is increased +C... and current number of trials, respectively; +C... maxrepm,nrepm - maximum number of allowed minima repetition and current +C... number of minima repetitions, respectively; +C... maxoverlap - max. # of overlapping confs generated in a single iteration; +C... neneval - number of energy evaluations; +C... nsave - number of confs. in the backup array; +C... nsweep - the number of macroiterations in generating the distributions. +c------------------------------------------------------------------------------ +C... Following COMMON block contains variables controlling motion. +c------------------------------------------------------------------------------ + double precision sumpro_type,sumpro_bond + integer koniecl, Nbm,MaxSideMove,nmove,moves(-1:MaxMoveType+1), + & moves_acc(-1:MaxMoveType+1),nacc_tot,nacc_part(0:MaxProcs) + common /move/ sumpro_type(0:MaxMoveType),sumpro_bond(0:maxres), + & koniecl,Nbm,MaxSideMove,nmove,nbond_move(maxres), + & nbond_acc(maxres),moves,moves_acc + common /accept_stats/ nacc_tot,nacc_part + integer nwindow,winstart,winend,winlen + common /windows/ nwindow,winstart(maxres),winend(maxres), + & winlen(maxres) + character*16 MovTypID + common /moveID/ MovTypID(-1:MaxMoveType+1) +c------------------------------------------------------------------------------ +C... koniecl - the number of bonds to be considered "end bonds" subjected to +C... end moves; +C... Nbm - The maximum length of N-bond segment to be moved; +C... MaxSideMove - maximum number of side chains subjected to local moves +C... simultaneously; +C... nmove - the current number of attempted moves; +C... nbond_move(*) array that stores the total numbers of 2-bond,3-bond,... +C... moves; +C... nendmove - number of endmoves; +C... nbackmove - number of backbone moves; +C... nsidemove - number of local side chain moves; +C... sumpro_type(*) - array that stores the lower and upper boundary of the +C... random-number range that determines the type of move +C... (N-bond, backbone or side chain); +C... sumpro_bond(*) - array that stores the probabilities to perform bond +C... moves of consecutive segment length. +C... winstart(*) - the starting position of the perturbation window; +C... winend(*) - the end position of the perturbation window; +C... winlen(*) - length of the perturbation window; +C... nwindow - the number of perturbation windows (0 - entire chain). diff --git a/source/cluster/wham/src-HCD/COMMON.MINIM b/source/cluster/wham/src-HCD/COMMON.MINIM new file mode 100644 index 0000000..b231b47 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.MINIM @@ -0,0 +1,3 @@ + double precision tolf,rtolf + integer maxfun,maxmin + common /minimm/ tolf,rtolf,maxfun,maxmin diff --git a/source/cluster/wham/src-HCD/COMMON.MPI b/source/cluster/wham/src-HCD/COMMON.MPI new file mode 100644 index 0000000..d2e7c00 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.MPI @@ -0,0 +1,8 @@ + integer me, me1, Master, Master1, Nprocs, Nprocs1, Comm1, + & Indstart, Indend, scount, idispl, i2ii + integer indstart_map,indend_map,idispl_map,scount_map + common /MPI_Data/ Nprocs, Master,Master1,Me,Comm1,Me1,Nprocs1, + & Indstart(0:MaxProcs),Indend(0:MaxProcs), idispl(0:MaxProcs), + & scount(0:MaxProcs), indstart_map(0:MaxProcs), + & indend_map(0:MaxProcs), idispl_map(0:MaxProcs), + & scount_map(0:MaxProcs) diff --git a/source/cluster/wham/src-HCD/COMMON.NAMES b/source/cluster/wham/src-HCD/COMMON.NAMES new file mode 100644 index 0000000..7c5b6ee --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.NAMES @@ -0,0 +1,7 @@ + common /names/ restyp(-ntyp1:ntyp1),onelet(-ntyp1:ntyp1) + character*3 restyp + character*1 onelet + character*10 ename,wname + integer nprint_ene,print_order,iw + common /namterm/ ename(max_ene),wname(max_ene),nprint_ene, + & print_order(max_ene),iw(max_ene) diff --git a/source/cluster/wham/src-HCD/COMMON.SAXS b/source/cluster/wham/src-HCD/COMMON.SAXS new file mode 100644 index 0000000..b787fa7 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.SAXS @@ -0,0 +1,7 @@ +! SAXS restraint parameters + integer nsaxs,saxs_mode + double precision Psaxs(maxsaxs),Pcalc(maxsaxs),distsaxs(maxsaxs), + & CSAXS(3,maxsaxs),scal_rad,wsaxs0,saxs_cutoff + common /saxsretr/ Psaxs,Pcalc,distsaxs,csaxs,Wsaxs0,scal_rad, + & saxs_cutoff,nsaxs,saxs_mode + diff --git a/source/cluster/wham/src-HCD/COMMON.SBRIDGE b/source/cluster/wham/src-HCD/COMMON.SBRIDGE new file mode 100644 index 0000000..ab78ed3 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.SBRIDGE @@ -0,0 +1,29 @@ + double precision ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss + integer ns,nss,nfree,iss + logical restr_on_coord + common /sbridge/ ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss, + & ns,nss,nfree,iss(maxss) + double precision dhpb,dhpb1,forcon,fordepth,xlscore,wboltzd, + & dhpb_peak,dhpb1_peak,forcon_peak,fordepth_peak,scal_peak,bfac + integer ihpb,jhpb,nhpb,idssb,jdssb,ibecarb,ibecarb_peak,npeak, + & ipeak,irestr_type,irestr_type_peak,ihpb_peak,jhpb_peak,nhpb_peak + common /links/ dhpb(maxdim),dhpb1(maxdim),forcon(maxdim), + & fordepth(maxdim),bfac(maxres),xlscore(maxdim),wboltzd, + & ihpb(maxdim),jhpb(maxdim),ibecarb(maxdim),irestr_type(maxdim), + & nhpb,restr_on_coord + common /NMRpeaks/ dhpb_peak(maxdim),dhpb1_peak(maxdim), + & forcon_peak(maxdim),fordepth_peak(maxdim),scal_peak, + & ihpb_peak(maxdim),jhpb_peak(maxdim),ibecarb_peak(maxdim), + & irestr_type_peak(maxdim),ipeak(2,maxdim),npeak,nhpb_peak + double precision weidis + common /restraints/ weidis + integer link_start,link_end,link_start_peak,link_end_peak + common /links_split/ link_start,link_end,link_start_peak, + & link_end_peak + double precision Ht,dyn_ssbond_ij,dtriss,atriss,btriss,ctriss + logical dyn_ss,dyn_ss_mask + common /dyn_ssbond/ dtriss,atriss,btriss,ctriss,Ht, + & dyn_ssbond_ij(maxres,maxres), + & idssb(maxdim),jdssb(maxdim) + common /dyn_ss_logic/ + & dyn_ss,dyn_ss_mask(maxres) diff --git a/source/cluster/wham/src-HCD/COMMON.SCCOR b/source/cluster/wham/src-HCD/COMMON.SCCOR new file mode 100644 index 0000000..c38cccb --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.SCCOR @@ -0,0 +1,19 @@ +cc Parameters of the SCCOR term + double precision v1sccor,v2sccor,vlor1sccor, + & vlor2sccor,vlor3sccor,gloc_sc, + & dcostau,dsintau,dtauangle,dcosomicron, + & domicron,v0sccor + integer nterm_sccor,isccortyp,nsccortyp,nlor_sccor + common /sccor/ v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp), + & v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp), + & v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp), + & vlor1sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp), + & vlor2sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp), + & vlor3sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp), + & gloc_sc(3,0:maxres2,10), + & dcostau(3,3,3,maxres2),dsintau(3,3,3,maxres2), + & dtauangle(3,3,3,maxres2),dcosomicron(3,3,3,maxres2), + & domicron(3,3,3,maxres2), + & nterm_sccor(-ntyp:ntyp,-ntyp:ntyp),isccortyp(-ntyp:ntyp), + & nsccortyp, + & nlor_sccor(-ntyp:ntyp,-ntyp:ntyp) diff --git a/source/cluster/wham/src-HCD/COMMON.SCROT b/source/cluster/wham/src-HCD/COMMON.SCROT new file mode 100644 index 0000000..a352775 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.SCROT @@ -0,0 +1,3 @@ +C Parameters of the SC rotamers (local) term + double precision sc_parmin + common/scrot/sc_parmin(maxsccoef,ntyp) diff --git a/source/cluster/wham/src-HCD/COMMON.SHIELD b/source/cluster/wham/src-HCD/COMMON.SHIELD new file mode 100644 index 0000000..1f96c94 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.SHIELD @@ -0,0 +1,14 @@ + double precision VSolvSphere,VSolvSphere_div,long_r_sidechain, + & short_r_sidechain,fac_shield,grad_shield_side,grad_shield, + & buff_shield,wshield,grad_shield_loc + integer ishield_list,shield_list,ees0plist + common /shield/ VSolvSphere,VSolvSphere_div,buff_shield, + & long_r_sidechain(ntyp), + & short_r_sidechain(ntyp),fac_shield(maxres),wshield, + & grad_shield_side(3,maxcont,-1:maxres),grad_shield(3,-1:maxres), + & grad_shield_loc(3,maxcont,-1:maxres), + & ishield_list(maxres),shield_list(maxcont,maxres), + & ees0plist(maxcont,maxres) + + + diff --git a/source/cluster/wham/src-HCD/COMMON.TEMPFAC b/source/cluster/wham/src-HCD/COMMON.TEMPFAC new file mode 100644 index 0000000..a778a4c --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.TEMPFAC @@ -0,0 +1,2 @@ + double precision tempfac(2,maxres) + common /factemp/ tempfac diff --git a/source/cluster/wham/src-HCD/COMMON.THREAD b/source/cluster/wham/src-HCD/COMMON.THREAD new file mode 100644 index 0000000..4020e75 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.THREAD @@ -0,0 +1,7 @@ + integer nthread,nexcl,iexam,ipatt + double precision ener0,ener,max_time_for_thread, + & ave_time_for_thread + common /thread/ nthread,nexcl,iexam(2,maxthread), + & ipatt(2,maxthread) + common /thread1/ ener0(n_ene,maxthread),ener(n_ene,maxthread), + & max_time_for_thread,ave_time_for_thread diff --git a/source/cluster/wham/src-HCD/COMMON.TIME1 b/source/cluster/wham/src-HCD/COMMON.TIME1 new file mode 100644 index 0000000..b6e9c88 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.TIME1 @@ -0,0 +1,4 @@ + DOUBLE PRECISION BATIME,TIMLIM,STIME,PREVTIM,SAFETY + INTEGER ISTOP + COMMON/TIME1/STIME,TIMLIM,BATIME,PREVTIM,SAFETY + COMMON/STOPTIM/ISTOP diff --git a/source/cluster/wham/src-HCD/COMMON.TORSION.org b/source/cluster/wham/src-HCD/COMMON.TORSION.org new file mode 100644 index 0000000..4da8585 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.TORSION.org @@ -0,0 +1,35 @@ +C Torsional constants of the rotation about virtual-bond dihedral angles + double precision v1,v2,vlor1,vlor2,vlor3,v0 + integer itortyp,ntortyp,nterm,nlor,nterm_old + common/torsion/v0(-maxtor:maxtor,-maxtor:maxtor,2), + & v1(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & v2(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & vlor1(maxlor,maxtor,maxtor), + & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor), + & itortyp(-ntyp:ntyp),ntortyp, + & nterm(-maxtor:maxtor,-maxtor:maxtor,2), + & nlor(-maxtor:maxtor,-maxtor:maxtor,2) + & ,nterm_old +C 6/23/01 - constants for double torsionals + double precision v1c,v1s,v2c,v2s + integer ntermd_1,ntermd_2 + common /torsiond/ + &v1c(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v1s(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v2c(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + &v2s(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + & ntermd_1(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + & ntermd_2(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) +C 9/18/99 - added Fourier coeffficients of the expansion of local energy +C surface + double precision b1,b2,cc,dd,ee,ctilde,dtilde,b1tilde + integer nloctyp + common/fourier/ b1(2,-maxtor:maxtor),b2(2,-maxtor:maxtor), + & cc(2,2,-maxtor:maxtor), + & dd(2,2,-maxtor:maxtor),ee(2,2,-maxtor:maxtor), + & ctilde(2,2,-maxtor:maxtor), + & dtilde(2,2,-maxtor:maxtor),b1tilde(2,-maxtor:maxtor),nloctyp + double precision b + common /fourier1/ b(13,0:maxtor) diff --git a/source/cluster/wham/src-HCD/COMMON.VAR b/source/cluster/wham/src-HCD/COMMON.VAR new file mode 100644 index 0000000..072f773 --- /dev/null +++ b/source/cluster/wham/src-HCD/COMMON.VAR @@ -0,0 +1,17 @@ +C Store the geometric variables in the following COMMON block. + integer ntheta,nphi,nside,nvar,ialph,ivar + double precision theta,phi,alph,omeg,vbld,vbld_ref, + & theta_ref,phi_ref,alph_ref,omeg_ref, + & costtab,sinttab,cost2tab,sint2tab,tauangle,omicron, + & xxtab,yytab,zztab,thetaref,phiref,xxref,yyref,zzref + common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), + & vbld(2*maxres),thetaref(maxres),phiref(maxres), + & costtab(maxres), sinttab(maxres), cost2tab(maxres), + & sint2tab(maxres),xxtab(maxres),yytab(maxres), + & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres), + & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar, + & omicron(2,maxres),tauangle(3,maxres) +C Angles from experimental structure + common /varref/ vbld_ref(maxres), + & theta_ref(maxres),phi_ref(maxres), + & alph_ref(maxres),omeg_ref(maxres) diff --git a/source/cluster/wham/src-HCD/DIMENSIONS b/source/cluster/wham/src-HCD/DIMENSIONS new file mode 100644 index 0000000..80ac845 --- /dev/null +++ b/source/cluster/wham/src-HCD/DIMENSIONS @@ -0,0 +1,87 @@ +******************************************************************************** +* Settings for the program of united-residue peptide simulation in real space * +* * +* ------- As of 5/10/95 ----------- * +* * +******************************************************************************** +C Max. number of processors. + integer maxprocs + parameter (maxprocs=48) +C Max. number of AA residues + integer maxres,maxres2 + parameter (maxres=1200) +c parameter (maxres=3300) +C Appr. max. number of interaction sites + parameter (maxres2=2*maxres) +C Max. number of variables + integer maxvar + parameter (maxvar=4*maxres) +C Max. number of groups of interactions that a given SC is involved in + integer maxint_gr + parameter (maxint_gr=2) +C Max number of symetric chains + integer maxchain + parameter (maxchain=50) + integer maxperm + parameter (maxperm=120) +C Max. number of derivatives of virtual-bond and side-chain vectors in theta +C or phi. + integer maxdim + parameter (maxdim=(maxres-1)*(maxres-2)/2) +C Max. number of SC contacts + integer maxcont + parameter (maxcont=12*maxres) +C Max. number of contacts per residue + integer maxconts + parameter (maxconts=maxres) +C Number of AA types (at present only natural AA's will be handled + integer ntyp,ntyp1 + parameter (ntyp=24,ntyp1=ntyp+1) +C Max. number of types of dihedral angles & multiplicity of torsional barriers + integer maxtor,maxterm,maxlor,maxtermd_1,maxtermd_2,maxtor_kcc, + & maxval_kcc + parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) + parameter (maxtor_kcc=6,maxval_kcc=6) +c Max number of new valence-angle (only) terms + integer maxang_kcc + parameter (maxang_kcc=36) +c Max number of torsional terms in SCCOR + integer maxterm_sccor + parameter (maxterm_sccor=6) +C Max. number of residue types and parameters in expressions for +C virtual-bond angle bending potentials + integer maxthetyp,maxthetyp1,maxtheterm,maxtheterm2,maxtheterm3, + & maxsingle,maxdouble,mmaxtheterm + parameter (maxthetyp=3,maxthetyp1=maxthetyp+1,maxtheterm=20, + & maxtheterm2=6,maxtheterm3=4,maxsingle=6,maxdouble=4, + & mmaxtheterm=maxtheterm) +C Max. number of lobes in SC distribution + integer maxlob + parameter (maxlob=4) +C Max. number of S-S bridges + integer maxss + parameter (maxss=20) +C Max. number of dihedral angle constraints + integer maxdih_constr + parameter (maxdih_constr=maxres) +C Max. number of energy components + integer max_ene + parameter (max_ene=31) +C Maximum number of bins in SAXS restraints + integer MaxSAXS + parameter (MaxSAXS=1000) +C Maximum number of templates in homology-modeling restraints + integer max_template + parameter(max_template=50) +c Maximum number of clusters of templates containing same fragments + integer maxclust + parameter(maxclust=1000) +C Max. number of temperatures + integer maxt + parameter (maxT=5) +C Maximum number of SC local term fitting function coefficiants + integer maxsccoef + parameter (maxsccoef=65) +C Maximum number of terms in SC bond-stretching potential + integer maxbondterm + parameter (maxbondterm=3) diff --git a/source/cluster/wham/src-HCD/DIMENSIONS.COMPAR b/source/cluster/wham/src-HCD/DIMENSIONS.COMPAR new file mode 100644 index 0000000..08e2231 --- /dev/null +++ b/source/cluster/wham/src-HCD/DIMENSIONS.COMPAR @@ -0,0 +1,20 @@ +****************************************************************** +* +* Array dimensions for level-based conformation comparison program: +* +* Max. number levels of comparison +* + integer maxlevel + PARAMETER (MAXLEVEL=3) +* +* Max. number of fragments at a given level of comparison +* + integer maxfrag,mmaxfrag + PARAMETER (MAXFRAG=30,MMAXFRAG=MAXFRAG*(MAXFRAG+1)/2) +* +* Max. number of pieces forming a substructure to be compared +* + integer maxpiece + PARAMETER (MAXPIECE=20) +* +******************************************************************* diff --git a/source/cluster/wham/src-HCD/Makefile b/source/cluster/wham/src-HCD/Makefile new file mode 120000 index 0000000..8aee570 --- /dev/null +++ b/source/cluster/wham/src-HCD/Makefile @@ -0,0 +1 @@ +Makefile-MPICH-ifort-okeanos \ No newline at end of file diff --git a/source/cluster/wham/src-HCD/Makefile-MPICH-gfortran b/source/cluster/wham/src-HCD/Makefile-MPICH-gfortran new file mode 100644 index 0000000..630299e --- /dev/null +++ b/source/cluster/wham/src-HCD/Makefile-MPICH-gfortran @@ -0,0 +1,76 @@ +################################################################## +INSTALL_DIR = /users/software/mpich2-1.0.7 + +FC= gfortran + +OPT = -O + +FFLAGS = ${OPT} -c -I. -Iinclude_unres -I$(INSTALL_DIR)/include + +LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpthread xdrf/libxdrf.a + +.c.o: + cc -c -DLINUX -DPGI $*.c + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} ${FFLAGS} $*.F + +object = main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o \ + geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o \ + track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o ssMD.o \ + int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o \ + setup_var.o read_ref_str.o gnmr1.o permut.o + +all: no_option + @echo "Specify force field: GAB, 4P or E0LL2Y" + +no_option: + +GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +GAB: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_GAB.exe +GAB: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +4P: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_4P.exe +4P: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +E0LL2Y: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DCLUST -DSPLITELE -DLANG0 +E0LL2Y: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_E0LL2Y.exe +E0LL2Y: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +NEWCORR: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DCLUST -DSPLITELE -DLANG0 -DNEWCORR +NEWCORR: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_NEWCORR.exe +NEWCORR: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} ${LIBS} -o ${BIN} + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + + diff --git a/source/cluster/wham/src-HCD/Makefile-MPICH-ifort b/source/cluster/wham/src-HCD/Makefile-MPICH-ifort new file mode 100644 index 0000000..79b8d0f --- /dev/null +++ b/source/cluster/wham/src-HCD/Makefile-MPICH-ifort @@ -0,0 +1,73 @@ +INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh +BIN=../../../../bin/cluster +FC = ifort +OPT = -O3 -ip -w -mcmodel=medium +OPT = -CB -g -mcmodel=medium +FFLAGS = ${OPT} -c -I. -Iinclude_unres -I$(INSTALL_DIR)/include +LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpmpich xdrf/libxdrf.a + +.c.o: + cc -c -DLINUX -DPGI $*.c + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} ${FFLAGS} $*.F + +object = main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o \ + geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o \ + track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o \ + int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o \ + setup_var.o read_ref_str.o gnmr1.o permut.o ssMD.o + +all: no_option + @echo "Specify force field: GAB, 4P or E0LL2Y" + +no_option: + +GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +GAB: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_GAB.exe +GAB: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +4P: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_4P.exe +4P: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +E0LL2Y: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \ + -DCLUST -DSPLITELE -DLANG0 +E0LL2Y: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_E0LL2Y.exe +E0LL2Y: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +NEWCORR: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \ + -DCLUST -DSPLITELE -DLANG0 -DNEWCORR +NEWCORR: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_NEWCORR.exe +NEWCORR: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + + diff --git a/source/cluster/wham/src-HCD/Makefile-MPICH-ifort-okeanos b/source/cluster/wham/src-HCD/Makefile-MPICH-ifort-okeanos new file mode 100644 index 0000000..f3ff018 --- /dev/null +++ b/source/cluster/wham/src-HCD/Makefile-MPICH-ifort-okeanos @@ -0,0 +1,98 @@ +#INSTALL_DIR = /opt/cray/mpt/7.3.2/gni/mpich-intel/15.0 +FC = ftn +OPT = -O3 -ip -mcmodel=medium -shared-intel -dynamic +#OPT = -CB -g -mcmodel=medium -shared-intel -dynamic +FFLAGS = ${OPT} -c -I. -Iinclude_unres -I$(INSTALL_DIR)/include +LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf/libxdrf.a + +.c.o: + cc -c -DLINUX -DPGI $*.c + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} ${FFLAGS} $*.F + +object = main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o \ + geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o \ + track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o \ + int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o \ + setup_var.o read_ref_str.o gnmr1.o permut.o seq2chains.o \ + chain_symmetry.o iperm.o rmscalc.o rmsnat.o TMscore.o ssMD.o refsys.o \ + read_constr_homology.o + +all: no_option + @echo "Specify force field: GAB, 4P, E0LL2Y or NEWCORR" + +no_option: + +GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC \ + -DFOURBODY +GAB: BIN = ~/bin/unres_clustMD_ifort_MPICH-okeanos_GAB-HCD.exe +GAB: ${object} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC \ + -DFOURBODY +4P: BIN = ~/bin/unres_clustMD_ifort_MPICH-okeanos_4P-HCD.exe +4P: ${object} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +E0LL2Y: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \ + -DCLUST -DSPLITELE -DFOURBODY +E0LL2Y: BIN = ~/bin/unres_clustMD_ifort_MPICH-okeanos_E0LL2Y-HCD.exe +E0LL2Y: ${object} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +E0LL2Y_DFA: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \ + -DCLUST -DSPLITELE -DFOURBODY -DDFA +E0LL2Y_DFA: BIN = ~/bin/unres_clustMD_ifort_MPICH-okeanos_E0LL2Y-HCD-DFA.exe +E0LL2Y_DFA: ${object} dfa.o xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} dfa.o cinfo.o ${LIBS} -o ${BIN} + +NEWCORR: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \ + -DCORRCD -DCLUST -DSPLITELE -DLANG0 -DNEWCORR +#-DCLUST -DSPLITELE -DLANG0 -DNEWCORR +NEWCORR: BIN = ~/bin/unres_clustMD_ifort_MPICH-okeanos_SC-HCD.exe +#NEWCORR: BIN = ~/bin/unres_clustMD-mult_ifort_MPICH_NEWCORR-fouriertor-test.exe +NEWCORR: ${object} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +NEWCORR_DFA: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \ + -DCORRCD -DCLUST -DSPLITELE -DLANG0 -DNEWCORR -DDFA +#-DCLUST -DSPLITELE -DLANG0 -DNEWCORR +NEWCORR_DFA: BIN = ~/bin/unres_clustMD_ifort_MPICH-okeanos_SC-HCD-DFA.exe +#NEWCORR: BIN = ~/bin/unres_clustMD-mult_ifort_MPICH_NEWCORR-fouriertor-test.exe +NEWCORR_DFA: ${object} dfa.o xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} dfa.o cinfo.o ${LIBS} -o ${BIN} + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + + diff --git a/source/cluster/wham/src-HCD/Makefile-MPICH-ifort-prometheus b/source/cluster/wham/src-HCD/Makefile-MPICH-ifort-prometheus new file mode 100644 index 0000000..1492755 --- /dev/null +++ b/source/cluster/wham/src-HCD/Makefile-MPICH-ifort-prometheus @@ -0,0 +1,77 @@ +FC = mpif90 -fc=ifort + +OPT = -O3 -ip -mcmodel=medium -shared-intel +#OPT = -O3 +#OPT = -g -CA -CB -mcmodel=medium -shared-intel + +FFLAGS = -c ${OPT} -Iinclude_unres +FFLAGS1 = -c -g -CA -CB -mcmodel=medium -shared-intel +#FFLAGS = ${FFLAGS1} + +LIBS = -lmpi xdrf/libxdrf.a + +.c.o: + cc -c -DLINUX -DPGI $*.c + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} ${FFLAGS} $*.F + +object = main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o \ + geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o \ + track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o \ + int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o \ + setup_var.o read_ref_str.o gnmr1.o permut.o rmsnat.o TMscore.o ssMD.o oligomer.o + +all: no_option + @echo "Specify force field: GAB, 4P or E0LL2Y" + +no_option: + +GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +GAB: BIN = ~/unres/bin/unres_clustMD-mult_ifort_MPICH_GAB-SAXS-MRAMB-Bfac.exe +GAB: ${object} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +4P: BIN = ~/unres/bin/unres_clustMD-mult_ifort_MPICH_4P-SAXS-MRSAMB-Bfac.exe +4P: ${object} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +E0LL2Y: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \ + -DCLUST -DSPLITELE -DLANG0 +E0LL2Y: BIN = ~/unres/bin/unres_clustMD-mult_ifort_MPICH_E0LL2Y-SAXS-MRAMB-Bfac.exe +E0LL2Y: ${object} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +NEWCORR: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \ + -DCORRCD -DCLUST -DSPLITELE -DLANG0 -DNEWCORR +NEWCORR: BIN = ~/unres/bin/unres_clustMD-mult_ifort_MPICH_NEWCORR-SAXS-MRAMB-Bfac.exe +NEWCORR: ${object} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + + diff --git a/source/cluster/wham/src-HCD/Makefile-okeanos b/source/cluster/wham/src-HCD/Makefile-okeanos new file mode 100644 index 0000000..ffb3dd5 --- /dev/null +++ b/source/cluster/wham/src-HCD/Makefile-okeanos @@ -0,0 +1,71 @@ +FC = ftn +OPT = -O3 -hfp3 +#OPT = -g -Rb +FFLAGS = ${OPT} -c -I. -Iinclude_unres +LIBS = xdrf/libxdrf.a + +.c.o: + cc -c -DLINUX -DPGI $*.c + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} ${FFLAGS} $*.F + +object = main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o \ + geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o \ + track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o \ + int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o \ + setup_var.o read_ref_str.o gnmr1.o permut.o ssMD.o + +all: no_option + @echo "Specify force field: GAB, 4P or E0LL2Y" + +no_option: + +GAB: CPPFLAGS = -DPROCOR -DCRAY -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +GAB: BIN = ~/bin/unres_clustMD-mult_ifort_MPICH_GAB.exe +GAB: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +4P: CPPFLAGS = -DCRAY -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +4P: BIN = ~/bin/unres_clustMD_MPI_4P.exe +4P: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +E0LL2Y: CPPFLAGS = -DCRAY -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \ + -DCLUST -DSPLITELE -DLANG0 +E0LL2Y: BIN = ~/bin/unres_clustMD-mult_MPI_E0LL2Y.exe +E0LL2Y: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +NEWCORR: CPPFLAGS = -DCRAY -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \ + -DCLUST -DSPLITELE -DLANG0 -DNEWCORR +NEWCORR: BIN = ~/bin/unres_clustMD-mult_MPI_NEWCORR.exe +NEWCORR: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + + diff --git a/source/cluster/wham/src-HCD/TMscore.F b/source/cluster/wham/src-HCD/TMscore.F new file mode 100644 index 0000000..2d7d441 --- /dev/null +++ b/source/cluster/wham/src-HCD/TMscore.F @@ -0,0 +1,1095 @@ +************************************************************************* +* This program is to compare two protein structures and identify the +* best superposition that has the highest TM-score. Input structures +* must be in the PDB format. By default, TM-score is normalized by +* the second protein. Users can obtain a brief instruction by simply +* running the program without arguments. For comments/suggestions, +* please contact email: zhng@umich.edu. +* +* Reference: +* Yang Zhang, Jeffrey Skolnick, Proteins, 2004 57:702-10. +* +* Permission to use, copy, modify, and distribute this program for +* any purpose, with or without fee, is hereby granted, provided that +* the notices on the head, the reference information, and this +* copyright notice appear in all copies or substantial portions of +* the Software. It is provided "as is" without express or implied +* warranty. +******************* Updating history ************************************ +* 2005/10/19: the program was reformed so that the score values. +* are not dependent on the specific compilers. +* 2006/06/20: selected 'A' if there is altLoc when reading PDB file. +* 2007/02/05: fixed a bug with length<15 in TMscore_32. +* 2007/02/27: rotation matrix from Chain-1 to Chain-2 was added. +* 2007/12/06: GDT-HA score was added, fixed a bug for reading PDB. +* 2010/08/02: A new RMSD matrix was used and obsolete statement removed. +* 2011/01/03: The length of pdb file names were extended to 500. +* 2011/01/30: An open source license is attached to the program. +* 2012/05/07: Improved RMSD calculation subroutine which speeds up +* TM-score program by 30%. +* 2012/06/05: Added option '-l L' which calculates TM-score (and maxsub +* and GDT scores) normalized by a specific length 'L'. +************************************************************************* + +c program TMscore + subroutine TMscore_sub(rmsd,gdt_ts,gdt_ha,tmscore,cfname,lprint) + include 'DIMENSIONS' + PARAMETER(nmax=5000) + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + + real*8 rmsd,gdt_ts,gdt_ha,tmscore + common/stru/xt(nmax),yt(nmax),zt(nmax),xb(nmax),yb(nmax),zb(nmax) + common/nres/nresA(nmax),nresB(nmax),nseqA,nseqB + common/para/d,d0,d0_fix + common/align/n_ali,iA(nmax),iB(nmax) + common/nscore/i_ali(nmax),n_cut ![1,n_ali],align residues for the score + dimension k_ali(nmax),k_ali0(nmax) + + character*500 fnam,pdb(100)!,outname + character*80 cfname + character*3 aa(-1:20),seqA(nmax),seqB(nmax) + character*500 s,du + character seq1A(nmax),seq1B(nmax),ali(nmax) + character sequenceA(nmax),sequenceB(nmax),sequenceM(nmax) + + dimension L_ini(100),iq(nmax) + common/scores/score,score_maxsub,score_fix,score10 + common/GDT/n_GDT05,n_GDT1,n_GDT2,n_GDT4,n_GDT8 + double precision score,score_max,score_fix,score_fix_max + double precision score_maxsub,score10 + dimension xa(nmax),ya(nmax),za(nmax) + +ccc RMSD: + double precision r_1(3,nmax),r_2(3,nmax),r_3(3,nmax),w(nmax) + double precision u(3,3),tt(3),rms,drms !armsd is real + data w /nmax*1.0/ + integer ii,ipermmin,iperm + + logical lprint +ccc + + data aa/ 'BCK','GLY','ALA','SER','CYS', + & 'VAL','THR','ILE','PRO','MET', + & 'ASP','ASN','LEU','LYS','GLU', + & 'GLN','ARG','HIS','PHE','TYR', + & 'TRP','CYX'/ + character*1 slc(-1:20) + data slc/'X','G','A','S','C', + & 'V','T','I','P','M', + & 'D','N','L','K','E', + & 'Q','R','H','F','Y', + & 'W','C'/ + +*****instructions -----------------> +c call getarg(1,fnam) +c if(fnam.eq.' '.or.fnam.eq.'?'.or.fnam.eq.'-h')then +c write(*,*) +c write(*,*)'Brief instruction for running TM-score program:' +c write(*,*)'(For detail: Zhang & Skolnick, Proteins, 2004', +c & ' 57:702-10)' +c write(*,*) +c write(*,*)'1. Run TM-score to compare ''model'' and ', +c & '''native'':' +c write(*,*)' >TMscore model native' +c write(*,*) +c write(*,*)'2. TM-score normalized with an assigned scale d0', +c & ' e.g. 5 A:' +c write(*,*)' >TMscore model native -d 5' +c write(*,*) +c write(*,*)'3. TM-score normalized by a specific length, ', +c & 'e.g. 120 AA:' +c write(*,*)' >TMscore model native -l 120' +c write(*,*) +c write(*,*)'4. TM-score with superposition output, e.g. ', +c & '''TM.sup'':' +c write(*,*)' >TMscore model native -o TM.sup' +c write(*,*)' To view the superimposed structures by rasmol:' +c write(*,*)' >rasmol -script TM.sup' +c write(*,*) +c goto 9999 +c endif + + pdb(1)=cfname + pdb(2)=pdbfile +******* options -----------> + m_out=-1 + m_fix=-1 + m_len=-1 +c narg=iargc() +c i=0 +c j=0 +c 115 continue +c i=i+1 +c call getarg(i,fnam) +c if(fnam.eq.'-o')then +c m_out=1 +c i=i+1 +c call getarg(i,outname) +c elseif(fnam.eq.'-d')then +c m_fix=1 +c i=i+1 +c call getarg(i,fnam) +c read(fnam,*)d0_fix +c elseif(fnam.eq.'-l')then +c m_len=1 +c i=i+1 +c call getarg(i,fnam) +c read(fnam,*)l0_fix +c else +c j=j+1 +c pdb(j)=fnam +c endif +c if(i.lt.narg)goto 115 +c +ccccccccc read data from first CA file: +c open(unit=10,file=pdb(1),status='old') +c i=0 +c 101 read(10,104,end=102) s +c if(s(1:3).eq.'TER') goto 102 +c if(s(1:4).eq.'ATOM')then +c if(s(13:16).eq.'CA '.or.s(13:16).eq.' CA '.or.s(13:16). +c & eq.' CA')then +c if(s(17:17).eq.' '.or.s(17:17).eq.'A')then +c i=i+1 +c read(s,103)du,seqA(i),du,nresA(i),du,xa(i),ya(i),za(i) +c do j=-1,20 +c if(seqA(i).eq.aa(j))then +c seq1A(i)=slc(j) +c goto 21 +c endif +c enddo +c seq1A(i)=slc(-1) +c 21 continue +c endif +c endif +c endif +c goto 101 +c 102 continue +c 103 format(A17,A3,A2,i4,A4,3F8.3) +c 104 format(A100) +c close(10) +c nseqA=i +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +c +ccccccccc read data from first CA file: +c open(unit=10,file=pdb(2),status='old') +c i=0 +c 201 read(10,204,end=202) s +c if(s(1:3).eq.'TER') goto 202 +c if(s(1:4).eq.'ATOM')then +c if(s(13:16).eq.'CA '.or.s(13:16).eq.' CA '.or.s(13:16). +c & eq.' CA')then +c if(s(17:17).eq.' '.or.s(17:17).eq.'A')then +c i=i+1 +c read(s,203)du,seqB(i),du,nresB(i),du,xb(i),yb(i),zb(i) +c do j=-1,20 +c if(seqB(i).eq.aa(j))then +c seq1B(i)=slc(j) +c goto 22 +c endif +c enddo +c seq1B(i)=slc(-1) +c 22 continue +c endif +c endif +c endif +c goto 201 +c 202 continue +c 203 format(A17,A3,A2,i4,A4,3F8.3) +c 204 format(A100) +c close(10) +c nseqB=i +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +****************************************************************** +* pickup the aligned residues: +****************************************************************** +c k=0 +c do i=1,nseqA +c do j=1,nseqB +c if(nresA(i).eq.nresB(j))then +c k=k+1 +c iA(k)=i +c iB(k)=j +c goto 205 +c endif +c enddo +c 205 continue +c enddo +c n_ali=k !number of aligned residues +c if(n_ali.lt.1)then +c write(*,*)'There is no common residues in the input structures' +c goto 9999 +c endif +c +************///// +* parameters: +***************** + + DO II=1,NPERMCHAIN + + noverlap=nres + if (nres.gt.nsup+nnt-1) noverlap=nsup+nnt-1 + nnsup=0 + do i=1,noverlap + if (itype(i).ne.ntyp1) then + nnsup=nnsup+1 + iA(nnsup)=nnsup + iB(nnsup)=nnsup + endif + enddo + nseqA=nnsup + nseqB=nnsup + n_ali=nnsup +*** d0-------------> + if(nseqB.gt.15)then + d0=1.24*(nseqB-15)**(1.0/3.0)-1.8 + else + d0=0.5 + endif + if(m_len.eq.1)then + d0=1.24*(l0_fix-15)**(1.0/3.0)-1.8 + endif + if(d0.lt.0.5)d0=0.5 + if(m_fix.eq.1)d0=d0_fix +*** d0_search -----> + d0_search=d0 + if(d0_search.gt.8)d0_search=8 + if(d0_search.lt.4.5)d0_search=4.5 +*** iterative parameters -----> + n_it=20 !maximum number of iterations + d_output=5 !for output alignment + if(m_fix.eq.1)d_output=d0_fix + n_init_max=6 !maximum number of L_init + n_init=0 + L_ini_min=4 + if(n_ali.lt.4)L_ini_min=n_ali + do i=1,n_init_max-1 + n_init=n_init+1 + L_ini(n_init)=n_ali/2**(n_init-1) + if(L_ini(n_init).le.L_ini_min)then + L_ini(n_init)=L_ini_min + goto 402 + endif + enddo + n_init=n_init+1 + L_ini(n_init)=L_ini_min + 402 continue + +****************************************************************** +* find the maximum score starting from local structures superposition +****************************************************************** + score_max=-1 !TM-score + score_maxsub_max=-1 !MaxSub-score + score10_max=-1 !TM-score10 + n_GDT05_max=-1 !number of residues<0.5 + n_GDT1_max=-1 !number of residues<1 + n_GDT2_max=-1 !number of residues<2 + n_GDT4_max=-1 !number of residues<4 + n_GDT8_max=-1 !number of residues<8 + +#ifdef DEBUG + write (iout,*) "cref and ccref" +#endif + noverlap=nres + if (nres.gt.nsup+nnt-1) noverlap=nsup+nnt-1 + nnsup=0 + do i=1,noverlap + if (itype(i).ne.ntyp1) then + nnsup=nnsup+1 + xa(nnsup)=c(1,iperm(i,ii)) + ya(nnsup)=c(2,iperm(i,ii)) + za(nnsup)=c(3,iperm(i,ii)) + xb(nnsup)=cref_pdb(1,i) + yb(nnsup)=cref_pdb(2,i) + zb(nnsup)=cref_pdb(3,i) +c do j=1,3 +c cc(j,nnsup)=c(j,i) +c ccref(j,nnsup)=cref_pdb(j,i,1) +c enddo +#ifdef DEBUG + write (iout,'(i5,3f10.5,5x,3f10.5)') nnsup, + & xa(nnsup),ya(nnsup),za(nnsup),xb(nnsup),yb(nnsup),zb(nnsup) +#endif + endif + enddo + + do 333 i_init=1,n_init + L_init=L_ini(i_init) + iL_max=n_ali-L_init+1 + do 300 iL=1,iL_max !on aligned residues, [1,nseqA] + LL=0 + ka=0 + do i=1,L_init + k=iL+i-1 ![1,n_ali] common aligned + r_1(1,i)=xa(iA(k)) + r_1(2,i)=ya(iA(k)) + r_1(3,i)=za(iA(k)) + r_2(1,i)=xb(iB(k)) + r_2(2,i)=yb(iB(k)) + r_2(3,i)=zb(iB(k)) + ka=ka+1 + k_ali(ka)=k + LL=LL+1 + enddo + if(i_init.eq.1)then !global superposition + call u3b(w,r_1,r_2,LL,2,rms,u,tt,ier) !0:rmsd; 1:u,t; 2:rmsd,u,t + armsd=dsqrt(rms/LL) + rmsd_ali=armsd + else + call u3b(w,r_1,r_2,LL,1,rms,u,tt,ier) !u rotate r_1 to r_2 + endif + do j=1,nseqA + xt(j)=tt(1)+u(1,1)*xa(j)+u(1,2)*ya(j)+u(1,3)*za(j) + yt(j)=tt(2)+u(2,1)*xa(j)+u(2,2)*ya(j)+u(2,3)*za(j) + zt(j)=tt(3)+u(3,1)*xa(j)+u(3,2)*ya(j)+u(3,3)*za(j) + enddo + d=d0_search-1 + call score_fun !init, get scores, n_cut+i_ali(i) for iteration + if(score_max.lt.score)then + score_max=score + ka0=ka + do i=1,ka0 + k_ali0(i)=k_ali(i) + enddo + endif + if(score10_max.lt.score10)score10_max=score10 + if(score_maxsub_max.lt.score_maxsub)score_maxsub_max= + & score_maxsub + if(n_GDT05_max.lt.n_GDT05)n_GDT05_max=n_GDT05 + if(n_GDT1_max.lt.n_GDT1)n_GDT1_max=n_GDT1 + if(n_GDT2_max.lt.n_GDT2)n_GDT2_max=n_GDT2 + if(n_GDT4_max.lt.n_GDT4)n_GDT4_max=n_GDT4 + if(n_GDT8_max.lt.n_GDT8)n_GDT8_max=n_GDT8 +*** iteration for extending ----------------------------------> + d=d0_search+1 + do 301 it=1,n_it + LL=0 + ka=0 + do i=1,n_cut + m=i_ali(i) ![1,n_ali] + r_1(1,i)=xa(iA(m)) + r_1(2,i)=ya(iA(m)) + r_1(3,i)=za(iA(m)) + r_2(1,i)=xb(iB(m)) + r_2(2,i)=yb(iB(m)) + r_2(3,i)=zb(iB(m)) + ka=ka+1 + k_ali(ka)=m + LL=LL+1 + enddo + call u3b(w,r_1,r_2,LL,1,rms,u,tt,ier) !u rotate r_1 to r_2 + do j=1,nseqA + xt(j)=tt(1)+u(1,1)*xa(j)+u(1,2)*ya(j)+u(1,3)*za(j) + yt(j)=tt(2)+u(2,1)*xa(j)+u(2,2)*ya(j)+u(2,3)*za(j) + zt(j)=tt(3)+u(3,1)*xa(j)+u(3,2)*ya(j)+u(3,3)*za(j) + enddo + call score_fun !get scores, n_cut+i_ali(i) for iteration + if(score_max.lt.score)then + score_max=score + ka0=ka + do i=1,ka + k_ali0(i)=k_ali(i) + enddo + endif + if(score10_max.lt.score10)score10_max=score10 + if(score_maxsub_max.lt.score_maxsub)score_maxsub_max + & =score_maxsub + if(n_GDT05_max.lt.n_GDT05)n_GDT05_max=n_GDT05 + if(n_GDT1_max.lt.n_GDT1)n_GDT1_max=n_GDT1 + if(n_GDT2_max.lt.n_GDT2)n_GDT2_max=n_GDT2 + if(n_GDT4_max.lt.n_GDT4)n_GDT4_max=n_GDT4 + if(n_GDT8_max.lt.n_GDT8)n_GDT8_max=n_GDT8 + if(it.eq.n_it)goto 302 + if(n_cut.eq.ka)then + neq=0 + do i=1,n_cut + if(i_ali(i).eq.k_ali(i))neq=neq+1 + enddo + if(n_cut.eq.neq)goto 302 + endif + 301 continue !for iteration + 302 continue + 300 continue !for shift + 333 continue !for initial length, L_ali/M +c + ratio=1 + if(m_len.gt.0)then + ratio=float(nseqB)/float(l0_fix) + endif + if(m_len.eq.1)then + score_max=score_max*float(nseqB)/float(l0_fix) + endif + score_GDT=(n_GDT1_max+n_GDT2_max+n_GDT4_max+n_GDT8_max) + & /float(4*nseqB) + score_GDT_HA=(n_GDT05_max+n_GDT1_max+n_GDT2_max+n_GDT4_max) + & /float(4*nseqB) + tmscore=score_max + gdt_ts=score_GDT*ratio + gdt_ha=score_GDT_HA*ratio + rmsd=rmsd_ali + + if (ii.eq.1 .or. rmsd.lt.rmsd_min) then + rmsd_min=rmsd + tmscore_min=tmscore + gdt_ts_min=gdt_ts + gdt_ha_min=gdt_ha + ipermmin=ii + endif + + ENDDO + + rmsd=rmsd_min + tmscore=tmscore_min + gdt_ts=gdt_ts_min + gdt_ha=gdt_ha_min + +****************************************************************** +* Output +****************************************************************** +*** output TM-scale ----------------------------> + + if (lprint) then + + write(iout,*) + write(iout,*)'**************************************************', + & '***************************' + write(iout,*)'* TM-SCORE ', + & ' *' + write(iout,*)'* A scoring function to assess the similarity of p', + & 'rotein structures *' + write(iout,*)'* Based on statistics: ', + & ' *' + write(iout,*)'* 0.0 < TM-score < 0.17, random structural s', + & 'imilarity *' + write(iout,*)'* 0.5 < TM-score < 1.00, in about the same f', + & 'old *' + write(iout,*)'* Reference: Yang Zhang and Jeffrey Skolnick, ', + & 'Proteins 2004 57: 702-710 *' + write(iout,*)'* For comments, please email to: zhng@umich.edu ', + & ' *' + write(iout,*)'**************************************************', + & '***************************' + write(iout,*) + write(iout,501)pdb(1),nseqA + 501 format('Structure1: ',A10,' Length= ',I4) + if(m_len.eq.1)then + write(iout,411)pdb(2),nseqB + write(iout,412)l0_fix + else + write(iout,502)pdb(2),nseqB + endif + 411 format('Structure2: ',A10,' Length= ',I4) + 412 format('TM-score is notmalized by ',I4) + 502 format('Structure2: ',A10,' Length= ',I4, + & ' (by which all scores are normalized)') + write(iout,503)n_ali + 503 format('Number of residues in common= ',I4) + write(iout,513)rmsd_ali + 513 format('RMSD of the common residues= ',F8.3) + write(iout,*) + write(iout,504)score_max,d0 + 504 format('TM-score = ',f6.4,' (d0=',f5.2,')') + write(iout,505)score_maxsub_max*ratio + 505 format('MaxSub-score= ',f6.4,' (d0= 3.50)') + write(iout,506)score_GDT*ratio,n_GDT1_max/float(nseqB)*ratio, + & n_GDT2_max/float(nseqB)*ratio,n_GDT4_max/float(nseqB)*ratio, + & n_GDT8_max/float(nseqB)*ratio + 506 format('GDT-TS-score= ',f6.4,' %(d<1)=',f6.4,' %(d<2)=',f6.4, + $ ' %(d<4)=',f6.4,' %(d<8)=',f6.4) + write(iout,507)score_GDT_HA*ratio,n_GDT05_max/float(nseqB)*ratio, + & n_GDT1_max/float(nseqB)*ratio,n_GDT2_max/float(nseqB)*ratio, + & n_GDT4_max/float(nseqB)*ratio + 507 format('GDT-HA-score= ',f6.4,' %(d<0.5)=',f6.4,' %(d<1)=',f6.4, + $ ' %(d<2)=',f6.4,' %(d<4)=',f6.4) + write (iout,*) "Permutation",ipermmin + write(iout,*) + + endif + + return + end +c------------------------------------------------------------------------ +*** recall and output the superposition of maxiumum TM-score: +c LL=0 +c do i=1,ka0 +c m=k_ali0(i) !record of the best alignment +c r_1(1,i)=xa(iA(m)) +c r_1(2,i)=ya(iA(m)) +c r_1(3,i)=za(iA(m)) +c r_2(1,i)=xb(iB(m)) +c r_2(2,i)=yb(iB(m)) +c r_2(3,i)=zb(iB(m)) +c LL=LL+1 +c enddo +c call u3b(w,r_1,r_2,LL,1,rms,u,t,ier) !u rotate r_1 to r_2 +c do j=1,nseqA +c xt(j)=t(1)+u(1,1)*xa(j)+u(1,2)*ya(j)+u(1,3)*za(j) +c yt(j)=t(2)+u(2,1)*xa(j)+u(2,2)*ya(j)+u(2,3)*za(j) +c zt(j)=t(3)+u(3,1)*xa(j)+u(3,2)*ya(j)+u(3,3)*za(j) +c enddo +c +c********* extract rotation matrix ------------> +c write(*,*)'-------- rotation matrix to rotate Chain-1 to ', +c & 'Chain-2 ------' +c write(*,*)'i t(i) u(i,1) u(i,2) ', +c & ' u(i,3)' +c do i=1,3 +c write(*,304)i,t(i),u(i,1),u(i,2),u(i,3) +c enddo +cc do j=1,nseqA +cc xt(j)=t(1)+u(1,1)*xa(j)+u(1,2)*ya(j)+u(1,3)*za(j) +cc yt(j)=t(2)+u(2,1)*xa(j)+u(2,2)*ya(j)+u(2,3)*za(j) +cc zt(j)=t(3)+u(3,1)*xa(j)+u(3,2)*ya(j)+u(3,3)*za(j) +cc write(*,*)j,xt(j),yt(j),zt(j) +cc enddo +c write(*,*) +c 304 format(I2,f18.10,f15.10,f15.10,f15.10) +c +c********* rmsd in superposed regions ---------------> +c d=d_output !for output +c call score_fun() !give i_ali(i), score_max=score now +c LL=0 +c do i=1,n_cut +c m=i_ali(i) ![1,nseqA] +c r_1(1,i)=xa(iA(m)) +c r_1(2,i)=ya(iA(m)) +c r_1(3,i)=za(iA(m)) +c r_2(1,i)=xb(iB(m)) +c r_2(2,i)=yb(iB(m)) +c r_2(3,i)=zb(iB(m)) +c LL=LL+1 +c enddo +c call u3b(w,r_1,r_2,LL,0,rms,u,t,ier) +c armsd=dsqrt(rms/LL) +c rmsd=armsd +c +c*** output rotated chain1 + chain2-----> +c if(m_out.ne.1)goto 999 +c OPEN(unit=7,file=outname,status='unknown') !pdb1.aln + pdb2.aln +c 900 format(A) +c 901 format('select ',I4) +c write(7,900)'load inline' +c write(7,900)'select atomno<1000' +cc write(7,900)'color [255,20,147]' +c write(7,900)'wireframe .45' +c write(7,900)'select none' +c write(7,900)'select atomno>1000' +cc write(7,900)'color [100,149,237]' +c write(7,900)'wireframe .15' +c write(7,900)'color white' +c do i=1,n_cut +c write(7,901)nresA(iA(i_ali(i))) +c write(7,900)'color red' +c enddo +c write(7,900)'select all' +c write(7,900)'exit' +c write(7,514)rmsd_ali +c 514 format('REMARK RMSD of the common residues=',F8.3) +c write(7,515)score_max,d0 +c 515 format('REMARK TM-score=',f6.4,' (d0=',f5.2,')') +c do i=1,nseqA +c write(7,1237)nresA(i),seqA(i),nresA(i),xt(i),yt(i),zt(i) +c enddo +c write(7,1238) +c do i=2,nseqA +c write(7,1239)nresA(i-1),nresA(i) +c enddo +c do i=1,nseqB +c write(7,1237)2000+nresB(i),seqB(i),nresB(i),xb(i),yb(i),zb(i) +c enddo +c write(7,1238) +c do i=2,nseqB +c write(7,1239)2000+nresB(i-1),2000+nresB(i) +c enddo +c 1237 format('ATOM ',i5,' CA ',A3,I6,4X,3F8.3) +c 1238 format('TER') +c 1239 format('CONECT',I5,I5) +c 999 continue +c +c*** record aligned residues by i=[1,nseqA], for sequenceM()------------> +c do i=1,nseqA +c iq(i)=0 +c enddo +c do i=1,n_cut +c j=iA(i_ali(i)) ![1,nseqA] +c k=iB(i_ali(i)) ![1,nseqB] +c dis=sqrt((xt(j)-xb(k))**2+(yt(j)-yb(k))**2+(zt(j)-zb(k))**2) +c if(dis.lt.d_output)then +c iq(j)=1 +c endif +c enddo +c******************************************************************* +c*** output aligned sequences +c k=0 +c i=1 +c j=1 +c 800 continue +c if(i.gt.nseqA.and.j.gt.nseqB)goto 802 +c if(i.gt.nseqA.and.j.le.nseqB)then +c k=k+1 +c sequenceA(k)='-' +c sequenceB(k)=seq1B(j) +c sequenceM(k)=' ' +c j=j+1 +c goto 800 +c endif +c if(i.le.nseqA.and.j.gt.nseqB)then +c k=k+1 +c sequenceA(k)=seq1A(i) +c sequenceB(k)='-' +c sequenceM(k)=' ' +c i=i+1 +c goto 800 +c endif +c if(nresA(i).eq.nresB(j))then +c k=k+1 +c sequenceA(k)=seq1A(i) +c sequenceB(k)=seq1B(j) +c if(iq(i).eq.1)then +c sequenceM(k)=':' +c else +c sequenceM(k)=' ' +c endif +c i=i+1 +c j=j+1 +c goto 800 +c elseif(nresA(i).lt.nresB(j))then +c k=k+1 +c sequenceA(k)=seq1A(i) +c sequenceB(k)='-' +c sequenceM(k)=' ' +c i=i+1 +c goto 800 +c elseif(nresB(j).lt.nresA(i))then +c k=k+1 +c sequenceA(k)='-' +c sequenceB(k)=seq1B(j) +c sequenceM(k)=' ' +c j=j+1 +c goto 800 +c endif +c 802 continue +c +c write(*,600)d_output,n_cut,rmsd +c 600 format('Superposition in the TM-score: Length(d<',f3.1, +c $ ')=',i3,' RMSD=',f6.2) +c write(*,603)d_output +c 603 format('(":" denotes the residue pairs of distance < ',f3.1, +c & ' Angstrom)') +c write(*,601)(sequenceA(i),i=1,k) +c write(*,601)(sequenceM(i),i=1,k) +c write(*,601)(sequenceB(i),i=1,k) +c write(*,602)(mod(i,10),i=1,k) +c 601 format(2000A1) +c 602 format(2000I1) +c write(*,*) +c +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +c 9999 END + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c 1, collect those residues with dis +#include +#include +#include +#include + +main() +{ +FILE *in, *in1, *out; +int i,j,k,iv1,iv2,iv3; +char *p1,buf[500],buf1[500],buf2[100],buf3[100]; +struct utsname Name; +time_t Tp; + +in=fopen("cinfo.f","r"); +out=fopen("cinfo.f.new","w"); +if (fgets(buf,498,in) != NULL) + fprintf(out,"C DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C\n"); +if (fgets(buf,498,in) != NULL) + sscanf(&buf[1],"%d %d %d",&iv1,&iv2,&iv3); +iv3++; +fprintf(out,"C %d %d %d\n",iv1,iv2,iv3); +fprintf(out," subroutine cinfo\n"); +fprintf(out," include 'COMMON.IOUNITS'\n"); +fprintf(out," write(iout,*)'++++ Compile info ++++'\n"); +fprintf(out," write(iout,*)'Version %d.%-d build %d'\n",iv1,iv2,iv3); +uname(&Name); +time(&Tp); +system("whoami > tmptmp"); +in1=fopen("tmptmp","r"); +if (fscanf(in1,"%s",buf1) != EOF) +{ +p1=ctime(&Tp); +p1[strlen(p1)-1]='\0'; +fprintf(out," write(iout,*)'compiled %s'\n",p1); +fprintf(out," write(iout,*)'compiled by %s@%s'\n",buf1,Name.nodename); +fprintf(out," write(iout,*)'OS name: %s '\n",Name.sysname); +fprintf(out," write(iout,*)'OS release: %s '\n",Name.release); +fprintf(out," write(iout,*)'OS version:',\n"); +fprintf(out," & ' %s '\n",Name.version); +fprintf(out," write(iout,*)'flags:'\n"); +} +system("rm tmptmp"); +fclose(in1); +in1=fopen("Makefile","r"); +while(fgets(buf,498,in1) != NULL) + { + if((p1=strchr(buf,'=')) != NULL && buf[0] != '#') + { + buf[strlen(buf)-1]='\0'; + if(strlen(buf) > 49) + { + buf[47]='\0'; + strcat(buf,"..."); + } + else + { + while(buf[strlen(buf)-1]=='\\') + { + strcat(buf,"\\"); + fprintf(out," write(iout,*)'%s'\n",buf); + if (fgets(buf,498,in1) != NULL) + buf[strlen(buf)-1]='\0'; + if(strlen(buf) > 49) + { + buf[47]='\0'; + strcat(buf,"..."); + } + } + } + + fprintf(out," write(iout,*)'%s'\n",buf); + } + } +fprintf(out," write(iout,*)'++++ End of compile info ++++'\n"); +fprintf(out," return\n"); +fprintf(out," end\n"); +fclose(out); +fclose(in1); +fclose(in); +system("mv cinfo.f.new cinfo.f"); +} diff --git a/source/cluster/wham/src-HCD/contact.f b/source/cluster/wham/src-HCD/contact.f new file mode 100644 index 0000000..6f01564 --- /dev/null +++ b/source/cluster/wham/src-HCD/contact.f @@ -0,0 +1,69 @@ + subroutine contact(lprint,ncont,icont) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.NAMES' + real*8 facont /1.569D0/ ! facont = (2/(1-sqrt(1-1/4)))**(1/6) + integer ncont,icont(2,maxcont) + logical lprint + ncont=0 + kkk=3 +c 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 +c rcomp=sigmaii(iti,itj)+1.0D0 + rcomp=facont*sigmaii(iti,itj) + else +c rcomp=sigma(iti,itj)+1.0D0 + rcomp=facont*sigma(iti,itj) + endif +c rcomp=6.5D0 +c print *,'rcomp=',rcomp,' dist=',dist(nres+i,nres+j) + if (dist(nres+i,nres+j).lt.rcomp) then + ncont=ncont+1 + icont(1,ncont)=i + icont(2,ncont)=j + endif + enddo + enddo + if (lprint) then + write (iout,'(a)') 'Contact map:' + do i=1,ncont + i1=icont(1,i) + i2=icont(2,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4)') + & i,restyp(it1),i1,restyp(it2),i2 + enddo + endif + return + end +c---------------------------------------------------------------------------- + double precision function contact_fract(ncont,ncont_ref, + & icont,icont_ref) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + integer ncont,ncont_ref,icont(2,maxcont),icont_ref(2,maxcont) + nmatch=0 +c print *,'ncont=',ncont,' ncont_ref=',ncont_ref +c write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) +c write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) +c write (iout,'(20i4)') (icont(1,i),i=1,ncont) +c write (iout,'(20i4)') (icont(2,i),i=1,ncont) + do i=1,ncont + do j=1,ncont_ref + if (icont(1,i).eq.icont_ref(1,j) .and. + & icont(2,i).eq.icont_ref(2,j)) nmatch=nmatch+1 + enddo + enddo +c print *,' nmatch=',nmatch +c contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) + contact_fract=dfloat(nmatch)/dfloat(ncont_ref) + return + end diff --git a/source/cluster/wham/src-HCD/convert.f b/source/cluster/wham/src-HCD/convert.f new file mode 100644 index 0000000..b53032a --- /dev/null +++ b/source/cluster/wham/src-HCD/convert.f @@ -0,0 +1,59 @@ + subroutine geom_to_var(n,x) +C +C Transfer the geometry parameters to the variable array. +C The positions of variables are as follows: +C 1. Virtual-bond torsional angles: 1 thru nres-3 +C 2. Virtual-bond valence angles: nres-2 thru 2*nres-5 +C 3. The polar angles alpha of local SC orientation: 2*nres-4 thru +C 2*nres-4+nside +C 4. The torsional angles omega of SC orientation: 2*nres-4+nside+1 +C thru 2*nre-4+2*nside +C + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + double precision x(n) +cd print *,'nres',nres,' nphi',nphi,' ntheta',ntheta,' nvar',nvar + do i=4,nres + x(i-3)=phi(i) +cd print *,i,i-3,phi(i) + enddo + if (n.eq.nphi) return + do i=3,nres + x(i-2+nphi)=theta(i) +cd print *,i,i-2+nphi,theta(i) + enddo + if (n.eq.nphi+ntheta) return + do i=2,nres-1 + if (ialph(i,1).gt.0) then + x(ialph(i,1))=alph(i) + x(ialph(i,1)+nside)=omeg(i) +cd print *,i,ialph(i,1),ialph(i,1)+nside,alph(i),omeg(i) + endif + enddo + return + end +C-------------------------------------------------------------------- + subroutine var_to_geom(n,x) +C +C Update geometry parameters according to the variable array. +C + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + dimension x(n) + do i=4,nres + phi(i)=pinorm(x(i-3)) + enddo + if (n.eq.nphi) return + do i=3,nres + theta(i)=x(i-2+nphi) + enddo + if (n.eq.nphi+ntheta) return + do i=1,nside + alph(ialph(i,2))=x(nphi+ntheta+i) + omeg(ialph(i,2))=pinorm(x(nphi+ntheta+nside+i)) + enddo + return + end diff --git a/source/cluster/wham/src-HCD/dfa.F b/source/cluster/wham/src-HCD/dfa.F new file mode 100644 index 0000000..c85191a --- /dev/null +++ b/source/cluster/wham/src-HCD/dfa.F @@ -0,0 +1,3548 @@ + subroutine init_dfa_vars + + include 'DIMENSIONS' + include 'COMMON.INTERACT' + include 'COMMON.DFA' + + integer ii + +C Number of restraints + idisnum = 0 + iphinum = 0 + ithenum = 0 + ineinum = 0 + + idislis = 0 + iphilis = 0 + ithelis = 0 + ineilis = 0 + jneilis = 0 + jneinum = 0 + kshell = 0 + fnei = 0 +C For beta + nca = 0 + icaidx = 0 + +C real variables +CC WEIGHTS for each min + sccdist = 0.0d0 + fdist = 0.0d0 + sccphi = 0.0d0 + sccthe = 0.0d0 + sccnei = 0.0d0 + fphi1 = 0.0d0 + fphi2 = 0.0d0 + fthe1 = 0.0d0 + fthe2 = 0.0d0 +C energies + edfatot = 0.0d0 + edfadis = 0.0d0 + edfaphi = 0.0d0 + edfathe = 0.0d0 + edfanei = 0.0d0 + edfabet = 0.0d0 +C weights for each E term +C these should be identical with + dis_inc = 0.0d0 + phi_inc = 0.0d0 + the_inc = 0.0d0 + nei_inc = 0.0d0 + beta_inc = 0.0d0 + wshet = 0.0d0 +C precalculate exp table! +c dfaexp = 0.0d0 +c do ii = 1, 15001 +c dfaexp(ii) = exp(-ii*0.001d0 + 0.0005d0) +c end do + + ishiftca=nnt-1 + ilastca=nct + + print *,'ishiftca=',ishiftca,'ilastca=',ilastca + + return + end + + + subroutine read_dfa_info +C +C read fragment informations +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DFA' + include 'COMMON.FFIELD' + + +C NOTE THAT FILENAMES are FIXED, CURRENTLY!! +C THIS SHOULD BE MODIFIED!! + + character*320 buffer + integer iodfa + parameter(iodfa=89) + + integer i, j, nval + integer ica1, ica2,ica3,ica4,ica5 + integer ishell, inca, itmp,iitmp + double precision wtmp +C +C READ DISTANCE +C + open(iodfa, file = 'dist_dfa.dat', status = 'old', err=33) + goto 34 + 33 write(iout,'(a)') 'Error opening dist_dfa.dat file' + stop + 34 continue + write(iout,'(a)') 'dist_dfa.dat is opened!' +C read title + read(iodfa, '(a)') buffer +C read number of restraints + read(iodfa, *) IDFADIS + read(iodfa, *) dis_inc + do i=1, idfadis + read(iodfa, '(i10,1x,i10,1x,i10)') ica1, ica2, nval + + idisnum(i)=nval + idislis(1,i)=ica1 + idislis(2,i)=ica2 + + do j=1, nval + read(iodfa,*) tmp + fdist(i,j) = tmp + enddo + + do j=1, nval + read(iodfa,*) tmp + sccdist(i,j) = tmp + enddo + + enddo + close(iodfa) + +C READ ANGLE RESTRAINTS +C PHI RESTRAINTS + open(iodfa, file='phi_dfa.dat',status='old',err=35) + goto 36 + 35 write(iout,'(a)') 'Error opening dist_dfa.dat file' + stop + + 36 continue + write(iout,'(a)') 'phi_dfa.dat is opened!' + +C READ TITLE + read(iodfa, '(a)') buffer +C READ NUMBER OF RESTRAINTS + READ(iodfa, *) IDFAPHI + read(iodfa,*) phi_inc + do i=1, idfaphi + read(iodfa,'(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval + + iphinum(i)=nval + + iphilis(1,i)=ica1 + iphilis(2,i)=ica2 + iphilis(3,i)=ica3 + iphilis(4,i)=ica4 + iphilis(5,i)=ica5 + + do j=1, nval + read(iodfa,*) tmp1,tmp2 + fphi1(i,j) = tmp1 + fphi2(i,j) = tmp2 + enddo + + do j=1, nval + read(iodfa,*) tmp + sccphi(i,j) = tmp + enddo + + enddo + close(iodfa) + +C THETA RESTRAINTS + open(iodfa, file='theta_dfa.dat',status='old',err=41) + goto 42 + 41 write(iout,'(a)') 'Error opening dist_dfa.dat file' + stop + 42 continue + write(iout,'(a)') 'theta_dfa.dat is opened!' +C READ TITLE + read(iodfa, '(a)') buffer +C READ NUMBER OF RESTRAINTS + READ(iodfa, *) IDFATHE + read(iodfa,*) the_inc + + do i=1, idfathe + read(iodfa, '(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval + + ithenum(i)=nval + + ithelis(1,i)=ica1 + ithelis(2,i)=ica2 + ithelis(3,i)=ica3 + ithelis(4,i)=ica4 + ithelis(5,i)=ica5 + + do j=1, nval + read(iodfa,*) tmp1,tmp2 + fthe1(i,j) = tmp1 + fthe2(i,j) = tmp2 + enddo + + do j=1, nval + read(iodfa,*) tmp + sccthe(i,j) = tmp + enddo + + enddo + close(iodfa) +C END of READING ANGLE RESTRAINT! + +C NUMBER OF NEIGHBOR CAs + open(iodfa,file='nei_dfa.dat',status='old',err=37) + goto 38 + 37 write(iout,'(a)') 'Error opening nei_dfa.dat file' + stop + 38 continue + write(iout,'(a)') 'nei_dfa.dat is opened!' +C READ TITLE + read(iodfa, '(a)') buffer +C READ NUMBER OF RESTRAINTS + READ(iodfa, *) idfanei + read(iodfa,*) nei_inc + + do i=1, idfanei + read(iodfa,'(2(i10,1x),i10)')ica1,ishell,nval + + ineilis(i)=ica1 + kshell(i)=ishell + ineinum(i)=nval + + do j=1, nval + read(iodfa,*) inca + fnei(i,j) = inca +C write(*,*) 'READ NEI:',i,j,fnei(i,j) + enddo + + do j=1, nval + read(iodfa,*) tmp + sccnei(i,j) = tmp + enddo + + enddo + close(iodfa) +C END OF NEIGHBORING CA + +C READ BETA RESTRAINT + if (wdfa_beta.eq.0.0) return + open(iodfa, file='beta_dfa.dat',status='old',err=39) + goto 40 + 39 write(iout,'(a)') 'Error opening beta_dfa.dat file' + stop + 40 continue + write(iout,'(a)') 'beta_dfa.dat is opened!' + + read(iodfa,'(a)') buffer + read(iodfa,*) itmp + read(iodfa,*) beta_inc + + do i=1,itmp + read(iodfa,*) ica1, iitmp + do j=1,itmp + read(iodfa,*) wtmp + wshet(i,j) = wtmp +c write(*,*) 'BETA:',i,j,wtmp,wshet(i,j) + enddo + enddo + + close(iodfa) +C END OF BETA RESTRAINT + + return + END + + subroutine edfad(edfadis) + + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.DFA' + + double precision edfadis + integer i, iatm1, iatm2,idiff + double precision ckk, sckk,dist,texp + double precision jix,jiy,jiz,ep,fp,scc + + edfadis=0 + gdfad=0.0d0 + + do i=1, idfadis + + iatm1=idislis(1,i)+ishiftca + iatm2=idislis(2,i)+ishiftca + idiff = abs(iatm1-iatm2) + + JIX=c(1,iatm2)-c(1,iatm1) + JIY=c(2,iatm2)-c(2,iatm1) + JIZ=c(3,iatm2)-c(3,iatm1) + DIST=SQRT(JIX*JIX+JIY*JIY+JIZ*JIZ) + + ckk=ck(idiff) + sckk=sck(idiff) + + scc = 0.0d0 + ep = 0.0d0 + fp = 0.0d0 + + do j=1,idisnum(i) + + dd = dist-fdist(i,j) + dtmp = dd*dd/ckk + if (dtmp.ge.15.0d0) then + texp = 0.0d0 + else +c texp = dfaexp( idint(dtmp*1000)+1 )/sckk + texp = exp(-dtmp)/sckk + endif + + ep=ep+sccdist(i,j)*texp + fp=fp+sccdist(i,j)*texp*dd*2.0d0/ckk + scc=scc+sccdist(i,j) +C write(*,'(2i8,6f12.5)') i, j, dist, +C & fdist(i,j), ep, fp, sccdist(i,j), scc + + enddo + + ep = -ep/scc + fp = fp/scc + + +c IF(ABS(EP).lt.1.0d-20)THEN +c EP=0.0D0 +c ENDIF +c IF (ABS(FP).lt.1.0d-20) THEN +c FP=0.0D0 +c ENDIF + + edfadis=edfadis+ep*dis_inc*wwdist + + gdfad(1,iatm1) = gdfad(1,iatm1)-jix/dist*fp*dis_inc*wwdist + gdfad(2,iatm1) = gdfad(2,iatm1)-jiy/dist*fp*dis_inc*wwdist + gdfad(3,iatm1) = gdfad(3,iatm1)-jiz/dist*fp*dis_inc*wwdist + + gdfad(1,iatm2) = gdfad(1,iatm2)+jix/dist*fp*dis_inc*wwdist + gdfad(2,iatm2) = gdfad(2,iatm2)+jiy/dist*fp*dis_inc*wwdist + gdfad(3,iatm2) = gdfad(3,iatm2)+jiz/dist*fp*dis_inc*wwdist + + enddo + + return + end + + subroutine edfat(edfator) +C DFA torsion angle + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.DFA' + + integer i,j,ii,iii + integer iatom(5) + double precision aphi(2),athe(2),tdx(5),tdy(5),tdz(5) + double precision cwidth, cwidth2 + PARAMETER(CWIDTH=0.1D0,CWIDTH2=0.2D0,PAI=3.14159265358979323846D0) + parameter (TENM20=1.0d-20) + + edfator= 0.0d0 + enephi = 0.0d0 + enethe = 0.0d0 + gdfat(:,:) = 0.0d0 + +C START OF PHI ANGLE + do i=1, idfaphi + + aphi = 0.0d0 + do iii=1,5 + iatom(iii)=iphilis(iii,i)+ishiftca + enddo + +C ANGLE VECTOR CALCULTION + RIX=C(1,IATOM(2))-C(1,IATOM(1)) + RIY=C(2,IATOM(2))-C(2,IATOM(1)) + RIZ=C(3,IATOM(2))-C(3,IATOM(1)) + + RIPX=C(1,IATOM(3))-C(1,IATOM(2)) + RIPY=C(2,IATOM(3))-C(2,IATOM(2)) + RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) + + RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) + RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) + RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) + + RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) + RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) + RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) + + GIX=RIY*RIPZ-RIZ*RIPY + GIY=RIZ*RIPX-RIX*RIPZ + GIZ=RIX*RIPY-RIY*RIPX + + GIPX=RIPY*RIPPZ-RIPZ*RIPPY + GIPY=RIPZ*RIPPX-RIPX*RIPPZ + GIPZ=RIPX*RIPPY-RIPY*RIPPX + + CIPX=C(1,IATOM(3))-C(1,IATOM(1)) + CIPY=C(2,IATOM(3))-C(2,IATOM(1)) + CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) + + CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) + CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) + CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) + + CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) + CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) + CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) + + DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) + DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) + DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) + DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) + +C END OF ANGLE VECTOR CALCULTION + + TDOT=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ + APHI(1)=TDOT/(DGI*DRIPP) + TDOT=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z + APHI(2)=TDOT/(DGIP*DRIP3) + + ephi = 0.0d0 + tfphi1=0.0d0 + tfphi2=0.0d0 + scc=0.0d0 + + do j=1, iphinum(i) + DDPS1=APHI(1)-FPHI1(i,j) + DDPS2=APHI(2)-FPHI2(i,j) + + DTMP = (DDPS1**2+DDPS2**2)/CWIDTH2 + + if (dtmp.ge.15.0d0) then + ps_tmp = 0.0d0 + else +c ps_tmp = dfaexp(idint(dtmp*1000)+1) + ps_tmp = exp(-dtmp) + endif + + ephi=ephi+sccphi(i,j)*ps_tmp + + tfphi1=tfphi1+sccphi(i,j)*ddps1/cwidth*ps_tmp + tfphi2=tfphi2+sccphi(i,j)*ddps2/cwidth*ps_tmp + + scc=scc+sccphi(i,j) +C write(*,'(2i8,8f12.6)')i,j,aphi(1),fphi1(i,j), +C & aphi(2),fphi2(i,j),tfphi1,tfphi2,ephi,sccphi(i,j) + ENDDO + + ephi=-ephi/scc*phi_inc*wwangle + tfphi1=tfphi1/scc*phi_inc*wwangle + tfphi2=tfphi2/scc*phi_inc*wwangle + + IF (ABS(EPHI).LT.1d-20) THEN + EPHI=0.0D0 + ENDIF + IF (ABS(TFPHI1).LT.1d-20) THEN + TFPHI1=0.0D0 + ENDIF + IF (ABS(TFPHI2).LT.1d-20) THEN + TFPHI2=0.0D0 + ENDIF + +C FORCE DIRECTION CALCULATION + TDX(1:5)=0.0D0 + TDY(1:5)=0.0D0 + TDZ(1:5)=0.0D0 + + DM1=1.0d0/(DGI*DRIPP) + + GIRPP=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ + DM2=GIRPP/(DGI**3*DRIPP) + DM3=GIRPP/(DGI*DRIPP**3) + + DM4=1.0d0/(DGIP*DRIP3) + + GIRP3=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z + DM5=GIRP3/(DGIP**3*DRIP3) + DM6=GIRP3/(DGIP*DRIP3**3) +C FIRST ATOM BY PHI1 + TDX(1)=(RIPZ*RIPPY-RIPY*RIPPZ)*DM1 + & +( GIZ* RIPY- GIY* RIPZ)*DM2 + TDY(1)=(RIPX*RIPPZ-RIPZ*RIPPX)*DM1 + & +( GIX* RIPZ- GIZ* RIPX)*DM2 + TDZ(1)=(RIPY*RIPPX-RIPX*RIPPY)*DM1 + & +( GIY* RIPX- GIX* RIPY)*DM2 + TDX(1)=TDX(1)*TFPHI1 + TDY(1)=TDY(1)*TFPHI1 + TDZ(1)=TDZ(1)*TFPHI1 +C SECOND ATOM BY PHI1 + TDX(2)=(CIPY*RIPPZ-CIPZ*RIPPY)*DM1 + & -(CIPY*GIZ-CIPZ*GIY)*DM2 + TDY(2)=(CIPZ*RIPPX-CIPX*RIPPZ)*DM1 + & -(CIPZ*GIX-CIPX*GIZ)*DM2 + TDZ(2)=(CIPX*RIPPY-CIPY*RIPPX)*DM1 + & -(CIPX*GIY-CIPY*GIX)*DM2 + TDX(2)=TDX(2)*TFPHI1 + TDY(2)=TDY(2)*TFPHI1 + TDZ(2)=TDZ(2)*TFPHI1 +C SECOND ATOM BY PHI2 + TDX(2)=TDX(2)+ + & ((RIPPZ*RIP3Y-RIPPY*RIP3Z)*DM4 + & +( GIPZ*RIPPY- GIPY*RIPPZ)*DM5)*TFPHI2 + TDY(2)=TDY(2)+ + & ((RIPPX*RIP3Z-RIPPZ*RIP3X)*DM4 + & +( GIPX*RIPPZ- GIPZ*RIPPX)*DM5)*TFPHI2 + TDZ(2)=TDZ(2)+ + & ((RIPPY*RIP3X-RIPPX*RIP3Y)*DM4 + & +( GIPY*RIPPX- GIPX*RIPPY)*DM5)*TFPHI2 +C THIRD ATOM BY PHI1 + TDX(3)=(-GIX+RIPPY*RIZ-RIPPZ*RIY)*DM1 + & -(GIY*RIZ-RIY*GIZ)*DM2+RIPPX*DM3 + TDY(3)=(-GIY+RIPPZ*RIX-RIPPX*RIZ)*DM1 + & -(GIZ*RIX-RIZ*GIX)*DM2+RIPPY*DM3 + TDZ(3)=(-GIZ+RIPPX*RIY-RIPPY*RIX)*DM1 + & -(GIX*RIY-RIX*GIY)*DM2+RIPPZ*DM3 + TDX(3)=TDX(3)*TFPHI1 + TDY(3)=TDY(3)*TFPHI1 + TDZ(3)=TDZ(3)*TFPHI1 +C THIRD ATOM BY PHI2 + TDX(3)=TDX(3)+ + & ((CIPPY*RIP3Z-CIPPZ*RIP3Y)*DM4 + & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5)*TFPHI2 + TDY(3)=TDY(3)+ + & ((CIPPZ*RIP3X-CIPPX*RIP3Z)*DM4 + & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5)*TFPHI2 + TDZ(3)=TDZ(3)+ + & ((CIPPX*RIP3Y-CIPPY*RIP3X)*DM4 + & -(CIPPX*GIPY-CIPPY*GIPX)*DM5)*TFPHI2 +C FOURTH ATOM BY PHI1 + TDX(4)=(GIX*DM1-RIPPX*DM3)*TFPHI1 + TDY(4)=(GIY*DM1-RIPPY*DM3)*TFPHI1 + TDZ(4)=(GIZ*DM1-RIPPZ*DM3)*TFPHI1 +C FOURTH ATOM BY PHI2 + TDX(4)=TDX(4)+ + & ((-GIPX+RIP3Y*RIPZ-RIP3Z*RIPY)*DM4 + & -( GIPY*RIPZ-RIPY*GIPZ)*DM5 + & + RIP3X*DM6)*TFPHI2 + TDY(4)=TDY(4)+ + & ((-GIPY+RIP3Z*RIPX-RIP3X*RIPZ)*DM4 + & -( GIPZ*RIPX-RIPZ*GIPX)*DM5 + & + RIP3Y*DM6)*TFPHI2 + TDZ(4)=TDZ(4)+ + & ((-GIPZ+RIP3X*RIPY-RIP3Y*RIPX)*DM4 + & -( GIPX*RIPY-RIPX*GIPY)*DM5 + & + RIP3Z*DM6)*TFPHI2 +C FIFTH ATOM BY PHI2 + TDX(5)=(GIPX*DM4-RIP3X*DM6)*TFPHI2 + TDY(5)=(GIPY*DM4-RIP3Y*DM6)*TFPHI2 + TDZ(5)=(GIPZ*DM4-RIP3Z*DM6)*TFPHI2 +C END OF FORCE DIRECTION +c force calcuation + DO II=1,5 + gdfat(1,IATOM(II))=gdfat(1,IATOM(II))+TDX(II) + gdfat(2,IATOM(II))=gdfat(2,IATOM(II))+TDY(II) + gdfat(3,IATOM(II))=gdfat(3,IATOM(II))+TDZ(II) + ENDDO +c energy calculation + enephi = enephi + ephi +c end of single assignment statement + ENDDO +C END OF PHI RESTRAINT + +C START OF THETA ANGLE + do i=1, idfathe + + athe = 0.0d0 + do iii=1,5 + iatom(iii)=ithelis(iii,i)+ishiftca + enddo + + +C ANGLE VECTOR CALCULTION + RIX=C(1,IATOM(2))-C(1,IATOM(1)) + RIY=C(2,IATOM(2))-C(2,IATOM(1)) + RIZ=C(3,IATOM(2))-C(3,IATOM(1)) + + RIPX=C(1,IATOM(3))-C(1,IATOM(2)) + RIPY=C(2,IATOM(3))-C(2,IATOM(2)) + RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) + + RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) + RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) + RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) + + RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) + RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) + RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) + + GIX=RIY*RIPZ-RIZ*RIPY + GIY=RIZ*RIPX-RIX*RIPZ + GIZ=RIX*RIPY-RIY*RIPX + + GIPX=RIPY*RIPPZ-RIPZ*RIPPY + GIPY=RIPZ*RIPPX-RIPX*RIPPZ + GIPZ=RIPX*RIPPY-RIPY*RIPPX + + GIPPX=RIPPY*RIP3Z-RIPPZ*RIP3Y + GIPPY=RIPPZ*RIP3X-RIPPX*RIP3Z + GIPPZ=RIPPX*RIP3Y-RIPPY*RIP3X + + CIPX=C(1,IATOM(3))-C(1,IATOM(1)) + CIPY=C(2,IATOM(3))-C(2,IATOM(1)) + CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) + + CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) + CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) + CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) + + CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) + CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) + CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) + + DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) + DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) + DGIPP=SQRT(GIPPX*GIPPX+GIPPY*GIPPY+GIPPZ*GIPPZ) + DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) + DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) +C END OF ANGLE VECTOR CALCULTION + + TDOT=GIX*GIPX+GIY*GIPY+GIZ*GIPZ + ATHE(1)=TDOT/(DGI*DGIP) + TDOT=GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ + ATHE(2)=TDOT/(DGIP*DGIPP) + + ETHE=0.0D0 + TFTHE1=0.0D0 + TFTHE2=0.0D0 + SCC=0.0D0 + TH_TMP=0.0d0 + + do j=1,ithenum(i) + ddth1=athe(1)-fthe1(i,j) !cos(the1)-cos(the1_ref) + ddth2=athe(2)-fthe2(i,j) !cos(the2)-cos(the2_ref) + dtmp= (ddth1**2+ddth2**2)/cwidth2 + if ( dtmp .ge. 15.0d0) then + th_tmp = 0.0d0 + else +c th_tmp = dfaexp ( idint(dtmp*1000)+1 ) + th_tmp = exp(-dtmp) + end if + + ethe=ethe+sccthe(i,j)*th_tmp + + tfthe1=tfthe1+sccthe(i,j)*ddth1/cwidth*th_tmp !-dv/dcos(the1) + tfthe2=tfthe2+sccthe(i,j)*ddth2/cwidth*th_tmp !-dv/dcos(the2) + scc=scc+sccthe(i,j) +C write(*,'(2i8,8f12.6)')i,j,athe(1),fthe1(i,j), +C & athe(2),fthe2(i,j),tfthe1,tfthe2,ethe,sccthe(i,j) + enddo + + ethe=-ethe/scc*the_inc*wwangle + tfthe1=tfthe1/scc*the_inc*wwangle + tfthe2=tfthe2/scc*the_inc*wwangle + + IF (ABS(ETHE).LT.TENM20) THEN + ETHE=0.0D0 + ENDIF + IF (ABS(TFTHE1).LT.TENM20) THEN + TFTHE1=0.0D0 + ENDIF + IF (ABS(TFTHE2).LT.TENM20) THEN + TFTHE2=0.0D0 + ENDIF + + TDX(1:5)=0.0D0 + TDY(1:5)=0.0D0 + TDZ(1:5)=0.0D0 + + DM1=1.0d0/(DGI*DGIP) + DM2=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI**3*DGIP) + DM3=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI*DGIP**3) + + DM4=1.0d0/(DGIP*DGIPP) + DM5=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP**3*DGIPP) + DM6=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP*DGIPP**3) + +C FIRST ATOM BY THETA1 + TDX(1)=((RIPZ*GIPY-RIPY*GIPZ)*DM1 + & -(GIY*RIPZ-GIZ*RIPY)*DM2)*TFTHE1 + TDY(1)=((-RIPZ*GIPX+RIPX*GIPZ)*DM1 + & -(-GIX*RIPZ+GIZ*RIPX)*DM2)*TFTHE1 + TDZ(1)=((RIPY*GIPX-RIPX*GIPY)*DM1 + & -(GIX*RIPY-GIY*RIPX)*DM2)*TFTHE1 +C SECOND ATOM BY THETA1 + TDX(2)=((CIPY*GIPZ-CIPZ*GIPY-RIPPY*GIZ+RIPPZ*GIY)*DM1 + & -(CIPY*GIZ-CIPZ*GIY)*DM2 + & +(RIPPY*GIPZ-RIPPZ*GIPY)*DM3)*TFTHE1 + TDY(2)=((CIPZ*GIPX-CIPX*GIPZ-RIPPZ*GIX+RIPPX*GIZ)*DM1 + & -(CIPZ*GIX-CIPX*GIZ)*DM2 + & +(RIPPZ*GIPX-RIPPX*GIPZ)*DM3)*TFTHE1 + TDZ(2)=((CIPX*GIPY-CIPY*GIPX-RIPPX*GIY+RIPPY*GIX)*DM1 + & -(CIPX*GIY-CIPY*GIX)*DM2 + & +(RIPPX*GIPY-RIPPY*GIPX)*DM3)*TFTHE1 +C SECOND ATOM BY THETA2 + TDX(2)=TDX(2)+ + & ((RIPPZ*GIPPY-RIPPY*GIPPZ)*DM4 + & -(GIPY*RIPPZ-GIPZ*RIPPY)*DM5)*TFTHE2 + TDY(2)=TDY(2)+ + & ((-RIPPZ*GIPPX+RIPPX*GIPPZ)*DM4 + & -(-GIPX*RIPPZ+GIPZ*RIPPX)*DM5)*TFTHE2 + TDZ(2)=TDZ(2)+ + & ((RIPPY*GIPPX-RIPPX*GIPPY)*DM4 + & -(GIPX*RIPPY-GIPY*RIPPX)*DM5)*TFTHE2 +C THIRD ATOM BY THETA1 + TDX(3)=((GIPY*RIZ-GIPZ*RIY-GIY*CIPPZ+GIZ*CIPPY)*DM1 + & -(GIY*RIZ-GIZ*RIY)*DM2 + & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM3) *TFTHE1 + TDY(3)=((GIPZ*RIX-GIPX*RIZ-GIZ*CIPPX+GIX*CIPPZ)*DM1 + & -(GIZ*RIX-GIX*RIZ)*DM2 + & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM3) *TFTHE1 + TDZ(3)=((GIPX*RIY-GIPY*RIX-GIX*CIPPY+GIY*CIPPX)*DM1 + & -(GIX*RIY-GIY*RIX)*DM2 + & -(CIPPX*GIPY-CIPPY*GIPX)*DM3) *TFTHE1 +C THIRD ATOM BY THETA2 + TDX(3)=TDX(3)+ + & ((CIPPY*GIPPZ-CIPPZ*GIPPY-RIP3Y*GIPZ+RIP3Z*GIPY)*DM4 + & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5 + & +(RIP3Y*GIPpZ-RIP3Z*GIPpY)*DM6) *TFTHE2 + TDY(3)=TDY(3)+ + & ((CIPPZ*GIPPX-CIPPX*GIPPZ-RIP3Z*GIPX+RIP3X*GIPZ)*DM4 + & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5 + & +(RIP3Z*GIPpX-RIP3X*GIPpZ)*DM6) *TFTHE2 + TDZ(3)=TDZ(3)+ + & ((CIPPX*GIPPY-CIPPY*GIPPX-RIP3X*GIPY+RIP3Y*GIPX)*DM4 + & -(CIPPX*GIPY-CIPPY*GIPX)*DM5 + & +(RIP3X*GIPpY-RIP3Y*GIPpX)*DM6) *TFTHE2 +C FOURTH ATOM BY THETA1 + TDX(4)=-((GIZ*RIPY-GIY*RIPZ)*DM1 + & -(GIPZ*RIPY-GIPY*RIPZ)*DM3) *TFTHE1 + TDY(4)=-((GIX*RIPZ-GIZ*RIPX)*DM1 + & -(GIPX*RIPZ-GIPZ*RIPX)*DM3) *TFTHE1 + TDZ(4)=-((GIY*RIPX-GIX*RIPY)*DM1 + & -(GIPY*RIPX-GIPX*RIPY)*DM3) *TFTHE1 +C FOURTH ATOM BY THETA2 + TDX(4)=TDX(4)+ + & ((GIPPY*RIPZ-GIPPZ*RIPY-GIPY*CIP3Z+GIPZ*CIP3Y)*DM4 + & -(GIPY*RIPZ-GIPZ*RIPY)*DM5 + & -(CIP3Y*GIPPZ-CIP3Z*GIPPY)*DM6)*TFTHE2 + TDY(4)=TDY(4)+ + & ((GIPPZ*RIPX-GIPPX*RIPZ-GIPZ*CIP3X+GIPX*CIP3Z)*DM4 + & -(GIPZ*RIPX-GIPX*RIPZ)*DM5 + & -(CIP3Z*GIPPX-CIP3X*GIPPZ)*DM6)*TFTHE2 + TDZ(4)=TDZ(4)+ + & ((GIPPX*RIPY-GIPPY*RIPX-GIPX*CIP3Y+GIPY*CIP3X)*DM4 + & -(GIPX*RIPY-GIPY*RIPX)*DM5 + & -(CIP3X*GIPPY-CIP3Y*GIPPX)*DM6)*TFTHE2 +C FIFTH ATOM BY THETA2 + TDX(5)=-((GIPZ*RIPPY-GIPY*RIPPZ)*DM4 + & -(GIPPZ*RIPPY-GIPPY*RIPPZ)*DM6)*TFTHE2 + TDY(5)=-((GIPX*RIPPZ-GIPZ*RIPPX)*DM4 + & -(GIPPX*RIPPZ-GIPPZ*RIPPX)*DM6)*TFTHE2 + TDZ(5)=-((GIPY*RIPPX-GIPX*RIPPY)*DM4 + & -(GIPPY*RIPPX-GIPPX*RIPPY)*DM6)*TFTHE2 +C !! END OF FORCE DIRECTION!!!! + DO II=1,5 + gdfat(1,iatom(II))=gdfat(1,iatom(II))+TDX(II) + gdfat(2,iatom(II))=gdfat(2,iatom(II))+TDY(II) + gdfat(3,iatom(II))=gdfat(3,iatom(II))+TDZ(II) + ENDDO +C energy calculation + enethe = enethe + ethe + ENDDO + + edfator = enephi + enethe + + RETURN + END + + subroutine edfan(edfanei) +C DFA neighboring CA restraint + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.DFA' + + integer i,j,imin + integer kshnum, n1atom + + double precision enenei,tmp_n + double precision pai,hpai + double precision jix,jiy,jiz,ndiff,snorm_nei + double precision t2dx(maxres),t2dy(maxres),t2dz(maxres) + double precision dr,dr2,half,ntmp,dtmp + + parameter(dr=0.25d0,dr2=0.50d0,half=0.50d0) + parameter(pai=3.14159265358979323846D0) + parameter(hpai=1.5707963267948966D0) + parameter(snorm_nei=0.886226925452758D0) + + edfanei = 0.0d0 + enenei = 0.0d0 + gdfan = 0.0d0 + +c print*, 's1:', s1(:) +c print*, 's2:', s2(:) + + do i=1, idfanei + + kshnum=kshell(i) + n1atom=ineilis(i)+ishiftca +C write(*,*) 'kshnum,n1atom:', kshnum, n1atom + + tmp_n=0.0d0 + ftmp=0.0d0 + dnei=0.0d0 + dist=0.0d0 + t1dx=0.0d0 + t1dy=0.0d0 + t1dz=0.0d0 + t2dx=0.0d0 + t2dy=0.0d0 + t2dz=0.0d0 + + do j = ishiftca+1, ilastca + + if (n1atom.eq.j) cycle + + jix=c(1,j)-c(1,n1atom) + jiy=c(2,j)-c(2,n1atom) + jiz=c(3,j)-c(3,n1atom) + dist=sqrt(jix*jix+jiy*jiy+jiz*jiz) + +c write(*,*) n1atom, j, dist + + if(kshnum.ne.1)then + if (dist.lt.s1(kshnum).and. + & dist.gt.s2(kshnum-1)) then + + tmp_n=tmp_n+1.0d0 + +c write(*,*) 'case1:',tmp_n + +cc t1dx=t1dx+0.0d0 +cc t1dy=t1dy+0.0d0 +cc t1dz=t1dz+0.0d0 + t2dx(j)=0.0d0 + t2dy(j)=0.0d0 + t2dz(j)=0.0d0 + + elseif(dist.ge.s1(kshnum).and. + & dist.le.s2(kshnum)) then + + dnei=(dist-s1(kshnum))/dr2*pai + tmp_n=tmp_n + half*(1+cos(dnei)) +c write(*,*) 'case2:',tmp_n + ftmp=-pai*sin(dnei)/dr2/dist/2.0d0 +c center atom + t1dx=t1dx+jix*ftmp + t1dy=t1dy+jiy*ftmp + t1dz=t1dz+jiz*ftmp +c neighbor atoms + t2dx(j)=-jix*ftmp + t2dy(j)=-jiy*ftmp + t2dz(j)=-jiz*ftmp +c + elseif(dist.ge.s1(kshnum-1).and. + & dist.le.s2(kshnum-1)) then + dnei=(dist-s1(kshnum-1))/dr2*pai + tmp_n=tmp_n + 1.0d0 - half*(1+cos(dnei)) +c write(*,*) 'case3:',tmp_n + ftmp = hpai*sin(dnei)/dr2/dist +c center atom + t1dx=t1dx+jix*ftmp + t1dy=t1dy+jiy*ftmp + t1dz=t1dz+jiz*ftmp +c neighbor atoms + t2dx(j)=-jix*ftmp + t2dy(j)=-jiy*ftmp + t2dz(j)=-jiz*ftmp + + endif + + elseif(kshnum.eq.1) then + + if(dist.lt.s1(kshnum))then + + tmp_n=tmp_n+1.0d0 +c write(*,*) 'case4:',tmp_n +cc t1dx=t1dx+0.0d0 +cc t1dy=t1dy+0.0d0 +cc t1dz=t1dz+0.0d0 + t2dx(j)=0.0d0 + t2dy(j)=0.0d0 + t2dz(j)=0.0d0 + + elseif(dist.ge.s1(kshnum).and. + & dist.le.s2(kshnum))then + + dnei=(dist-s1(kshnum))/dr2*pai + tmp_n=tmp_n + half*(1+cos(dnei)) +c write(*,*) 'case5:',tmp_n + ftmp = -hpai*sin(dnei)/dr2/dist +c center atom + t1dx=t1dx+jix*ftmp + t1dy=t1dy+jiy*ftmp + t1dz=t1dz+jiz*ftmp +c neighbor atoms + t2dx(j)=-jix*ftmp + t2dy(j)=-jiy*ftmp + t2dz(j)=-jiz*ftmp + + endif + endif + enddo + + scc=0.0d0 + enei=0.0d0 + tmp_fnei=0.0d0 + ndiff=0.0d0 + + do imin=1,ineinum(i) + + ndiff = tmp_n-fnei(i,imin) + dtmp = ndiff*ndiff + + if (dtmp.ge.15.0d0) then + ntmp = 0.0d0 + else +c ntmp = dfaexp( idint(dtmp*1000) + 1 ) + ntmp = exp(-dtmp) + end if + + enei=enei+sccnei(i,imin)*ntmp + tmp_fnei=tmp_fnei- + & sccnei(i,imin)*ntmp*ndiff*2.0d0 + scc=scc+sccnei(i,imin) + +c write(*,'(a,1x,2i8,f12.7,i8,3f12.7)')'NEI:',i,imin,tmp_n, +c & fnei(i,imin),sccnei(i,imin),enei,scc + enddo + + enei=-enei/scc*snorm_nei*nei_inc*wwnei + tmp_fnei=tmp_fnei/scc*snorm_nei*nei_inc*wwnei + +c if (abs(enei).lt.1.0d-20)then +c enei=0.0d0 +c endif +c if (abs(tmp_fnei).lt.1.0d-20) then +c tmp_fnei=0.0d0 +c endif + +c force calculation + t1dx=t1dx*tmp_fnei + t1dy=t1dy*tmp_fnei + t1dz=t1dz*tmp_fnei + + do j=ishiftca+1,ilastca + t2dx(j)=t2dx(j)*tmp_fnei + t2dy(j)=t2dy(j)*tmp_fnei + t2dz(j)=t2dz(j)*tmp_fnei + enddo + + gdfan(1,n1atom)=gdfan(1,n1atom)+t1dx + gdfan(2,n1atom)=gdfan(2,n1atom)+t1dy + gdfan(3,n1atom)=gdfan(3,n1atom)+t1dz + + do j=ishiftca+1,ilastca + gdfan(1,j)=gdfan(1,j)+t2dx(j) + gdfan(2,j)=gdfan(2,j)+t2dy(j) + gdfan(3,j)=gdfan(3,j)+t2dz(j) + enddo +c energy calculation + + enenei=enenei+enei + + enddo + + edfanei=enenei + + return + end + + subroutine edfab(edfabeta) + + implicit real*8 (a-h,o-z) + + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.DFA' + + real*8 PAI + parameter(PAI=3.14159265358979323846D0) + parameter (maxca=800) +C sheet variables + real*8 bx(maxres),by(maxres),bz(maxres) + real*8 vbet(maxres,maxres) + real*8 shetfx(maxres),shetfy(maxres),shetfz(maxres) + real*8 shefx(maxres,12),shefy(maxres,12),shefz(maxres,12) + real*8 vbeta,vbetp,vbetm + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + & c00,s00,ulnex,dnex + real*8 dp45,dm45,w_beta + + real*8 cph(maxca),cth(maxca) + real*8 atx(maxca),aty(maxca),atz(maxca) + real*8 atmx(maxca),atmy(maxca),atmz(maxca) + real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) + real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) + real*8 sth(maxca) + real*8 astx(maxca),asty(maxca),astz(maxca) + real*8 astmx(maxca),astmy(maxca),astmz(maxca) + real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) + real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) + + real*8 atxnum(maxca),atynum(maxca),atznum(maxca), + & astxnum(maxca),astynum(maxca),astznum(maxca), + & atmxnum(maxca),atmynum(maxca),atmznum(maxca), + & astmxnum(maxca),astmynum(maxca),astmznum(maxca), + & atmmxnum(maxca),atmmynum(maxca),atmmznum(maxca), + & astmmxnum(maxca),astmmynum(maxca),astmmznum(maxca), + & atm3xnum(maxca),atm3ynum(maxca),atm3znum(maxca), + & astm3xnum(maxca),astm3ynum(maxca),astm3znum(maxca), + & cth_orig(maxca),sth_orig(maxca) + + common /sheca/ bx,by,bz + common /shee/ vbeta,vbet,vbetp,vbetm + common /shetf/ shetfx,shetfy,shetfz + common /shef/ shefx, shefy, shefz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + & c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + + common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, + $ atmmz,atm3x,atm3y,atm3z + common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, + $ astmmz,astm3x,astm3y,astm3z + + common /coscos/ cph,cth + common /sinsin/ sth + +C End of sheet variables + + integer i,j + double precision enebet + + enebet=0.0d0 +c bx=0.0d0;by=0.0d0;bz=0.0d0 +c shetfx=0.0d0;shetfy=0.0d0;shetfz=0.0d0 + + gdfab=0.0d0 + + do i=ishiftca+1,ilastca + bx(i-ishiftca)=c(1,i) + by(i-ishiftca)=c(2,i) + bz(i-ishiftca)=c(3,i) + enddo + +c do i=1,ilastca-ishiftca +c read(99,*) bx(i),by(i),bz(i) +c enddo +c close(99) + + dca=0.25d0**2 + dshe=0.3d0**2 + ULHB=5.0D0 + ULDHB=5.0D0 + ULNEX=COS(60.0D0/180.0D0*PAI) + + DLHB=1.0D0 + DLDHB=1.0D0 + + DNEX=0.3D0**2 + + C00=COS((1.0D0+10.0D0/180.0D0)*PAI) + S00=SIN((1.0D0+10.0D0/180.0D0)*PAI) + + W_BETA=0.5D0 + DP45=W_BETA + DM45=W_BETA + +C END OF INITIALIZATION + + nca=ilastca-ishiftca + + call angvectors(nca) + call sheetforce(nca,wshet) + +c end of sheet energy and force + + do j=1,nca + shetfx(j)=shetfx(j)*beta_inc + shetfy(j)=shetfy(j)*beta_inc + shetfz(j)=shetfz(j)*beta_inc +c write(*,*)'SHETF:',shetfx(j),shetfy(j),shetfz(j) + enddo + + vbeta=vbeta*beta_inc + enebet=vbeta + edfabeta=enebet + + do j=1,nca + gdfab(1,j+ishiftca)=gdfab(1,j+ishiftca)-shetfx(j) + gdfab(2,j+ishiftca)=gdfab(2,j+ishiftca)-shetfy(j) + gdfab(3,j+ishiftca)=gdfab(3,j+ishiftca)-shetfz(j) + enddo + +#ifdef DEBUG1 + do j=1,nca + write(*,'(5x,i5,10x,3f10.5)') j,bx(j),by(j),bz(j) + enddo + + + gdfab=0 + dinc=0.001 + do j=1,nca + cth_orig(j)=cth(j) + sth_orig(j)=sth(j) + enddo + + do j=1,nca + + bx(j)=bx(j)+dinc + call angvectors(nca) + bx(j)=bx(j)-2*dinc + call angvectors(nca) + atxnum(j)=0.5*(cth(j)-cth_orig(j))/dinc + astxnum(j)=0.5*(sth(j)-sth_orig(j))/dinc + if (j.gt.1) then + atmxnum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc + astmxnum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc + endif + if (j.gt.2) then + atmmxnum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc + astmmxnum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc + endif + if (j.gt.3) then + atm3xnum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc + astm3xnum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc + endif + bx(j)=bx(j)+dinc + by(j)=by(j)+dinc + call angvectors(nca) + by(j)=by(j)-2*dinc + call angvectors(nca) + by(j)=by(j)+dinc + atynum(j)=0.5*(cth(j)-cth_orig(j))/dinc + astynum(j)=0.5*(sth(j)-sth_orig(j))/dinc + if (j.gt.1) then + atmynum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc + astmynum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc + endif + if (j.gt.2) then + atmmynum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc + astmmynum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc + endif + if (j.gt.3) then + atm3ynum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc + astm3ynum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc + endif + + bz(j)=bz(j)+dinc + call angvectors(nca) + bz(j)=bz(j)-2*dinc + call angvectors(nca) + bz(j)=bz(j)+dinc + + atznum(j)=0.5*(cth(j)-cth_orig(j))/dinc + astznum(j)=0.5*(sth(j)-sth_orig(j))/dinc + if (j.gt.1) then + atmznum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc + astmznum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc + endif + if (j.gt.2) then + atmmznum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc + astmmznum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc + endif + if (j.gt.3) then + atm3znum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc + astm3znum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc + endif + + enddo + + do i=1,nca + write (*,'(2i5,a2,6f10.5)') + & i,1,"x",atxnum(i),atx(i),atxnum(i)/atx(i), + & astxnum(i),astx(i),astxnum(i)/astx(i), + & i,1,"y",atynum(i),aty(i),atynum(i)/aty(i), + & astynum(i),asty(i),astynum(i)/asty(i), + & i,1,"z",atznum(i),atz(i),atznum(i)/atz(i), + & astznum(i),astz(i),astznum(i)/astz(i), + & i,2,"x",atmxnum(i),atmx(i),atmxnum(i)/atmx(i), + & astmxnum(i),astmx(i),astmxnum(i)/astmx(i), + & i,2,"y",atmynum(i),atmy(i),atmynum(i)/atmy(i), + & astmynum(i),astmy(i),astmynum(i)/astmy(i), + & i,2,"z",atmznum(i),atmz(i),atmznum(i)/atmz(i), + & astmznum(i),astmz(i),astmznum(i)/astmz(i), + & i,3,"x",atmmxnum(i),atmmx(i),atmmxnum(i)/atmmx(i), + & astmmxnum(i),astmmx(i),astmmxnum(i)/astmmx(i), + & i,3,"y",atmmynum(i),atmmy(i),atmmynum(i)/atmmy(i), + & astmmynum(i),astmmy(i),astmmynum(i)/astmmy(i), + & i,3,"z",atmmznum(i),atmmz(i),atmmznum(i)/atmmz(i), + & astmmznum(i),astmmz(i),astmmznum(i)/astmmz(i), + & i,4,"x",atm3xnum(i),atm3x(i),atm3xnum(i)/atm3x(i), + & astm3xnum(i),astm3x(i),astm3xnum(i)/astm3x(i), + & i,4,"y",atm3ynum(i),atm3y(i),atm3ynum(i)/atm3y(i), + & astm3ynum(i),astm3y(i),astm3ynum(i)/astm3y(i), + & i,4,"z",atm3znum(i),atm3z(i),atm3znum(i)/atm3z(i), + & astm3znum(i),astm3z(i),astm3znum(i)/astm3z(i), + & i,0," ",cth_orig(i),sth_orig(i) + enddo + + + gdfab=0 + dinc=0.001 + + do j=1,nca + + bx(j)=bx(j)+dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta1=vbeta*beta_inc + bx(j)=bx(j)-2*dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta2=vbeta*beta_inc + gdfab(1,j)=(vbeta2-vbeta1)/dinc/2 + bx(j)=bx(j)+dinc + + by(j)=by(j)+dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta1=vbeta*beta_inc + by(j)=by(j)-2*dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta2=vbeta*beta_inc + gdfab(2,j)=(vbeta2-vbeta1)/dinc/2 + by(j)=by(j)+dinc + + bz(j)=bz(j)+dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta1=vbeta*beta_inc + bz(j)=bz(j)-2*dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta2=vbeta*beta_inc + gdfab(3,j)=(vbeta2-vbeta1)/dinc/2 + bz(j)=bz(j)+dinc + + + enddo + + + call angvectors(nca) + call sheetforce(nca,wshet) + do j=1,nca + shetfx(j)=shetfx(j)*beta_inc + shetfy(j)=shetfy(j)*beta_inc + shetfz(j)=shetfz(j)*beta_inc + enddo + + + write(*,*) 'xyz analytical and numerical gradient' + do j=1,nca + write(*,'(5x,i5,10x,6f10.5)') j,-shetfx(j),-shetfy(j),-shetfz(j) + & ,(-gdfab(i,j),i=1,3) + enddo + + do j=1,nca + write(*,'(5x,i5,10x,3f10.2)') j,shetfx(j)/gdfab(1,j), + & shetfy(j)/gdfab(2,j), + & shetfz(j)/gdfab(3,j) + enddo + + stop +#endif + + return + end +C------------------------------------------------------------------------------- + subroutine angvectors(nca) +c implicit real*4(a-h,o-z) + implicit none + integer nca + integer maxca + parameter(maxca=800) + real*8 pai,zero + parameter(PAI=3.14159265358979323846D0,zero=0.0d0) + + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 apx(maxca),apy(maxca),apz(maxca) + real*8 apmx(maxca),apmy(maxca),apmz(maxca) + real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) + real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) + real*8 atx(maxca),aty(maxca),atz(maxca) + real*8 atmx(maxca),atmy(maxca),atmz(maxca) + real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) + real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) + real*8 astx(maxca),asty(maxca),astz(maxca) + real*8 astmx(maxca),astmy(maxca),astmz(maxca) + real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) + real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) + real*8 sth(maxca) + real*8 cph(maxca),cth(maxca) + real*8 ulcos(maxca) + real*8 p,c + integer i, ip, ipp, ip3, j + real*8 rx(maxca, maxca), ry(maxca, maxca), rz(maxca, maxca) + real*8 rix, riy, riz, ripx, ripy, ripz, rippx, rippy, rippz + real*8 gix, giy, giz, gipx, gipy, gipz, gippx, gippy, gippz + real*8 cix, ciy, ciz, cipx, cipy, cipz + real*8 gpcrp_x, gpcrp_y, gpcrp_z, d_gpcrp, gpcrp__g + real*8 d10, d11, d12, d13, d20, d21, d22, d23, d24 + real*8 d30, d31, d32, d33, d34, d35, d40, d41, d42, d43 + real*8 d_gcr, d_gcr3, d_gmcrim,d_gmcrim3,dgmmcrimm,d_gmmcrimm3 + real*8 dg, dg3, dg30, dgm, dgm3, dgmm, dgmm3, dgp, dri + real*8 dri3, drim, drim3, drimm, drip, dripp, g3gmm, g3rim + real*8 g3x, g3y, g3z, d_gmmcrimm, g3rim_,gcr__gm + real*8 gcr_x,gcr_y,gcr_z,ggm,ggp,gmcrim__gmm + real*8 gmcrim_x,gmcrim_y,gmcrim_z,gmmcrimm__gmmm + real*8 gmmcrimm_x,gmmcrimm_y,gmmcrimm_z,gmmgm,gmmr + real*8 gmmx,gmmy,gmmz,gmrp,gmx,gmy,gmz,gpx,gpy,gpz + real*8 grpp,gx,gy,gz + real*8 rim3x,rim3y,rim3z,rimmx,rimmy,rimmz,rimx,rimy,rimz + real*8 sd10,sd11,sd20,sd21,sd22,sd30,sd31,sd32,sd40,sd41 + integer inb,nmax,iselect + + common /sheca/ bx,by,bz + common /difvec/ rx, ry, rz + common /ulang/ ulcos + common /phys1/ inb,nmax,iselect + common /phys4/ p,c + common /kyori2/ dis + common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, + & apmmz,apm3x,apm3y,apm3z + common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, + & atmmz,atm3x,atm3y,atm3z + common /coscos/ cph,cth + common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, + & astmmz,astm3x,astm3y,astm3z + common /sinsin/ sth +C------------------------------------------------------------------------------- +c write(*,*) 'inside angvectors' +C initialize + p=0.1d0 + c=1.0d0 + inb=nca + cph=zero; cth=zero; sth=zero + apx=zero;apy=zero;apz=zero;apmx=zero;apmy=zero;apmz=zero + apmmx=zero;apmmy=zero;apmmz=zero;apm3x=zero;apm3y=zero;apm3z=zero + atx=zero;aty=zero;atz=zero;atmx=zero;atmy=zero;atmz=zero + atmmx=zero;atmmy=zero;atmmz=zero;atm3x=zero;atm3y=zero;atm3z=zero + astx=zero;asty=zero;astz=zero;astmx=zero;astmy=zero;astmz=zero + astmmx=zero;astmmy=zero;astmmz=zero;astm3x=zero;astm3y=zero + astm3z=zero +C end of initialize +C r[x,y,z] calc and distance calculation + rx=zero;ry=zero;rz=zero + + do i=1,inb + do j=1,inb + rx(i,j)=bx(j)-bx(i) + ry(i,j)=by(j)-by(i) + rz(i,j)=bz(j)-bz(i) + dis(i,j)=sqrt(rx(i,j)**2+ry(i,j)**2+rz(i,j)**2) +c write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) +c write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) +c write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) +c write(*,*) 'dis(i,j):',i,j,dis(i,j) + enddo + enddo +c end of r[x,y,z] calc +C cos calc + do i=1,inb-2 + ip=i+1 + ipp=i+2 + + if(dis(i,ip).ge.1.0e-8.and.dis(ip,ipp).ge.1.0e-8) then + ulcos(i)=rx(i,ip)*rx(ip,ipp)+ry(i,ip)*ry(ip,ipp) + $ +rz(i,ip)*rz(ip,ipp) + ulcos(i)=ulcos(i)/(dis(i,ip)*dis(ip,ipp)) + endif + enddo +c end of virtual bond angle +c write(*,*) 'inside angvectors1' +crc do i=1,inb-3 + do i=1,inb + ip=i+1 + ipp=i+2 + ip3=i+3 + rix=bx(ip)-bx(i) + riy=by(ip)-by(i) + riz=bz(ip)-bz(i) + ripx=bx(ipp)-bx(ip) + ripy=by(ipp)-by(ip) + ripz=bz(ipp)-bz(ip) + rippx=bx(ip3)-bx(ipp) + rippy=by(ip3)-by(ipp) + rippz=bz(ip3)-bz(ipp) + + gx=riy*ripz-riz*ripy + gy=riz*ripx-rix*ripz + gz=rix*ripy-riy*ripx + gpx=ripy*rippz-ripz*rippy + gpy=ripz*rippx-ripx*rippz + gpz=ripx*rippy-ripy*rippx + gpcrp_x=gpy*ripz-gpz*ripy + gpcrp_y=gpz*ripx-gpx*ripz + gpcrp_z=gpx*ripy-gpy*ripx + d_gpcrp=sqrt(gpcrp_x**2+gpcrp_y**2+gpcrp_z**2) + gpcrp__g=gx*gpy*ripz+gpx*ripy*gz+ripx*gpz*gy + & -gz*gpy*ripx-gpz*ripy*gx-ripz*gpx*gy + + if(i.ge.2) then + rimx=bx(i)-bx(i-1) + rimy=by(i)-by(i-1) + rimz=bz(i)-bz(i-1) + gmx=rimy*riz-rimz*riy + gmy=rimz*rix-rimx*riz + gmz=rimx*riy-rimy*rix + dgm=sqrt(gmx**2+gmy**2+gmz**2) + dgm3=dgm**3 + ggm=gmx*gx+gmy*gy+gmz*gz + gmrp=gmx*ripx+gmy*ripy+gmz*ripz + drim=dis(i-1,i) + drim3=drim**3 + gcr_x=gy*riz-gz*riy + gcr_y=gz*rix-gx*riz + gcr_z=gx*riy-gy*rix + d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) + d_gcr3=d_gcr**3 + gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy + & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy + endif +c write(*,*) 'inside angvectors2' + if(i.ge.3) then + rimmx=bx(i-1)-bx(i-2) + rimmy=by(i-1)-by(i-2) + rimmz=bz(i-1)-bz(i-2) + drimm=dis(i-2,i-1) + gmmx=rimmy*rimz-rimmz*rimy + gmmy=rimmz*rimx-rimmx*rimz + gmmz=rimmx*rimy-rimmy*rimx + dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) + dgmm3=dgmm**3 + gmmgm=gmmx*gmx+gmmy*gmy+gmmz*gmz + gmmr=gmmx*rix+gmmy*riy+gmmz*riz + gmcrim_x=gmy*rimz-gmz*rimy + gmcrim_y=gmz*rimx-gmx*rimz + gmcrim_z=gmx*rimy-gmy*rimx + d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) + d_gmcrim3=d_gmcrim**3 + gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy + & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy + endif + + if(i.ge.4) then + rim3x=bx(i-2)-bx(i-3) + rim3y=by(i-2)-by(i-3) + rim3z=bz(i-2)-bz(i-3) + g3x=rim3y*rimmz-rim3z*rimmy + g3y=rim3z*rimmx-rim3x*rimmz + g3z=rim3x*rimmy-rim3y*rimmx + dg30=sqrt(g3x**2+g3y**2+g3z**2) + g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz + g3rim_=g3x*rimx+g3y*rimy+g3z*rimz +cc********************************************************************** + gmmcrimm_x=gmmy*rimmz-gmmz*rimmy + gmmcrimm_y=gmmz*rimmx-gmmx*rimmz + gmmcrimm_z=gmmx*rimmy-gmmy*rimmx + d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) + d_gmmcrimm3=d_gmmcrimm**3 + gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y + & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y + endif + + dri=dis(i,i+1) + drip=dis(i+1,i+2) + dripp=dis(i+2,i+3) + dri3=dri**3 + dg=sqrt(gx**2+gy**2+gz**2) + dgp=sqrt(gpx**2+gpy**2+gpz**2) + dg3=dg**3 + + ggp=gx*gpx+gy*gpy+gz*gpz + grpp=gx*rippx+gy*rippy+gz*rippz + + if(dg.gt.0.0D0.and.dripp.gt.0.0D0.and.dgp.gt.0.0D0 + & .and.d_gpcrp.gt.0.0D0) then + cph(i)=grpp/dg/dripp + cth(i)=ggp/dg/dgp + sth(i)=gpcrp__g/d_gpcrp/dg + else +c + cph(i)=1.0D0 + cth(i)=1.0D0 + sth(i)=0.0D0 + endif + +c write(*,*) 'inside angvectors3' + + if(dgp.gt.0.0D0.and.dg3.gt.0.0D0 + & .and.dripp.gt.0.0D0.and.d_gpcrp.gt.0.0D0) then + d10=1.0D0/(dg*dgp) + d11=ggp/(dg3*dgp) + d12=1.0D0/(dg*dripp) + d13=grpp/(dg3*dripp) + sd10=1.0D0/(d_gpcrp*dg) + sd11=gpcrp__g/(d_gpcrp*dg3) + else + d10=0.0D0 + d11=0.0D0 + d12=0.0D0 + d13=0.0D0 + sd10=0.0D0 + sd11=0.0D0 + endif + + atx(i)=(ripz*gpy-ripy*gpz)*d10 + & -(gy*ripz-gz*ripy)*d11 + aty(i)=(ripx*gpz-ripz*gpx)*d10 + & -(gz*ripx-gx*ripz)*d11 + atz(i)=(ripy*gpx-ripx*gpy)*d10 + & -(gx*ripy-gy*ripx)*d11 + astx(i)=sd10*(-gpx*ripy**2+ripx*gpz*ripz + & +ripy*gpy*ripx-gpx*ripz**2) + & -sd11*(gy*ripz-gz*ripy) + asty(i)=sd10*(-gpy*ripz**2+gpx*ripy*ripx + & -gpy*ripx**2+gpz*ripy*ripz) + & -sd11*(-gx*ripz+gz*ripx) + astz(i)=sd10*(ripy*gpy*ripz-gpz*ripx**2 + & -gpz*ripy**2+ripz*gpx*ripx) + & -sd11*(gx*ripy-gy*ripx) + apx(i)=(ripz*rippy-ripy*rippz)*d12 + & -(gy*ripz-gz*ripy)*d13 + apy(i)=(ripx*rippz-ripz*rippx)*d12 + & -(gz*ripx-gx*ripz)*d13 + apz(i)=(ripy*rippx-ripx*rippy)*d12 + & -(gx*ripy-gy*ripx)*d13 + + if(i.ge.2) then + cix=bx(ip)-bx(i-1) + ciy=by(ip)-by(i-1) + ciz=bz(ip)-bz(i-1) + cipx=bx(ipp)-bx(i) + cipy=by(ipp)-by(i) + cipz=bz(ipp)-bz(i) + ripx=bx(ipp)-bx(ip) + ripy=by(ipp)-by(ip) + ripz=bz(ipp)-bz(ip) + if(dgm3.gt.0.0D0.and.dg3.gt.0.0D0.and.drip.gt.0.0D0 + & .and.d_gcr3.gt.0.0D0) then + d20=1.0D0/(dg*dgm) + d21=ggm/(dgm3*dg) + d22=ggm/(dgm*dg3) + d23=1.0D0/(dgm*drip) + d24=gmrp/(dgm3*drip) + sd20=1.0D0/(d_gcr*dgm) + sd21=gcr__gm/(d_gcr3*dgm) + sd22=gcr__gm/(d_gcr*dgm3) + else + d20=0.0D0 + d21=0.0D0 + d22=0.0D0 + d23=0.0D0 + d24=0.0D0 + sd20=0.0D0 + sd21=0.0D0 + sd22=0.0D0 + endif + atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 + & -(ciy*gmz-ciz*gmy)*d21 + & +(ripy*gz-ripz*gy)*d22 + atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 + & -(ciz*gmx-cix*gmz)*d21 + & +(ripz*gx-ripx*gz)*d22 + atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 + & -(cix*gmy-ciy*gmx)*d21 + & +(ripx*gy-ripy*gx)*d22 +cc********************************************************************** + astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy + & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix + & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) + & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) + & +gcr_z*(-ripz*rix+gy)) + & -sd22*(-gmy*ciz+gmz*ciy) + + astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix + & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz + & +riz*ripz*gmy) + & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) + & -gcr_z*(ripz*riy+gx)) + & -sd22*(gmx*ciz-gmz*cix) + + astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz + & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy + & -riz*gx*cix) + & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) + & +gcr_z*(ripy*riy+ripx*rix)) + & -sd22*(-gmx*ciy+gmy*cix) +cc********************************************************************** + apmx(i)=(ciy*ripz-ripy*ciz)*d23 + & -(ciy*gmz-ciz*gmy)*d24 + apmy(i)=(ciz*ripx-ripz*cix)*d23 + & -(ciz*gmx-cix*gmz)*d24 + apmz(i)=(cix*ripy-ripx*ciy)*d23 + & -(cix*gmy-ciy*gmx)*d24 + endif + + if(i.ge.3) then + if(dgm3.gt.0.0D0.and.dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 + & .and.d_gmcrim3.gt.0.0D0) then + d30=1.0D0/(dgm*dgmm) + d31=gmmgm/(dgm3*dgmm) + d32=gmmgm/(dgm*dgmm3) + d33=1.0D0/(dgmm*dri) + d34=gmmr/(dgmm3*dri) + d35=gmmr/(dgmm*dri3) + sd30=1.0D0/(d_gmcrim*dgmm) + sd31=gmcrim__gmm/(d_gmcrim3*dgmm) + sd32=gmcrim__gmm/(d_gmcrim*dgmm3) + else + d30=0.0D0 + d31=0.0D0 + d32=0.0D0 + d33=0.0D0 + d34=0.0D0 + d35=0.0D0 + sd30=0.0D0 + sd31=0.0D0 + sd32=0.0D0 + endif + +c write(*,*) 'inside angvectors4' + +cc********************************************************************** + atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 + & -(ciy*gmz-ciz*gmy)*d31 + & -(gmmy*rimmz-gmmz*rimmy)*d32 + atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 + & -(ciz*gmx-cix*gmz)*d31 + & -(gmmz*rimmx-gmmx*rimmz)*d32 + atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 + & -(cix*gmy-ciy*gmx)*d31 + & -(gmmx*rimmy-gmmy*rimmx)*d32 +cc********************************************************************** + astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy + & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz + & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy + & -ciy*rimy*gmmx-rimz*gmx*rimmz) + & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) + & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) + & -sd32*(gmmy*rimmz-rimmy*gmmz) + + astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz + & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy + & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx + & +gmz*rimy*rimmz-rimz*ciz*gmmy) + & -sd31*(gmcrim_x*(cix*rimy-gmz) + & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) + & -sd32*(-gmmx*rimmz+rimmx*gmmz) + + astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz + & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx + & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy + & +rimz*ciy*gmmy+rimz*gmx*rimmx) + & -sd31*(gmcrim_x*(cix*rimz+gmy) + & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) + & -sd32*(gmmx*rimmy-rimmx*gmmy) +c********************************************************************** + apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 + & -(gmmy*rimmz-gmmz*rimmy)*d34 + & +rix*d35 + apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 + & -(gmmz*rimmx-gmmx*rimmz)*d34 + & +riy*d35 + apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 + & -(gmmx*rimmy-gmmy*rimmx)*d34 + & +riz*d35 + endif + + if(i.ge.4) then + if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 + & .and.drim3.gt.0.0D0 + & .and.d_gmmcrimm3.gt.0.0D0) then + d40=1.0D0/(dg30*dgmm) + d41=g3gmm/(dg30*dgmm3) + d42=1.0D0/(dg30*drim) + d43=g3rim_/(dg30*drim3) + sd40=1.0D0/(dg30*d_gmmcrimm) + sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) + else + d40=0.0D0 + d41=0.0D0 + d42=0.0D0 + d43=0.0D0 + sd40=0.0D0 + sd41=0.0D0 + endif + atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 + & -(gmmy*rimmz-gmmz*rimmy)*d41 + atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 + & -(gmmz*rimmx-gmmx*rimmz)*d41 + atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 + & -(gmmx*rimmy-gmmy*rimmx)*d41 +cc********************************************************************** + astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y + & -g3z*rimmz*rimmx+rimmy**2*g3x) + & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) + & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) + + astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y + & -rimmx*rimmy*g3x+rimmz**2*g3y) + & -sd41*(-gmmcrimm_x*rimmx*rimmy + & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmy) + +c & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) + + astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z + & +g3z*rimmx**2-rimmz*rimmy*g3y) + & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz + & +gmmcrimm_z*(rimmy**2+rimmx**2)) +c********************************************************************** + apm3x(i)=g3x*d42-rimx*d43 + apm3y(i)=g3y*d42-rimy*d43 + apm3z(i)=g3z*d42-rimz*d43 + endif + enddo +c******************************************************************************* + +c write(*,*) 'inside angvectors5' + +c do i=inb-2,inb + do i=1,0 + rimx=bx(i)-bx(i-1) + rimy=by(i)-by(i-1) + rimz=bz(i)-bz(i-1) + rimmx=bx(i-1)-bx(i-2) + rimmy=by(i-1)-by(i-2) + rimmz=bz(i-1)-bz(i-2) + rim3x=bx(i-2)-bx(i-3) + rim3y=by(i-2)-by(i-3) + rim3z=bz(i-2)-bz(i-3) + gmmx=rimmy*rimz-rimmz*rimy + gmmy=rimmz*rimx-rimmx*rimz + gmmz=rimmx*rimy-rimmy*rimx + g3x=rim3y*rimmz-rim3z*rimmy + g3y=rim3z*rimmx-rim3x*rimmz + g3z=rim3x*rimmy-rim3y*rimmx + + dg30=sqrt(g3x**2+g3y**2+g3z**2) + g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz + dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) + dgmm3=dgmm**3 + drim=dis(i-1,i) + drimm=dis(i-2,i-1) + drim3=drim**3 + g3rim_=g3x*rimx+g3y*rimy+g3z*rimz +cc********************************************************************** + gmmcrimm_x=gmmy*rimmz-gmmz*rimmy + gmmcrimm_y=gmmz*rimmx-gmmx*rimmz + gmmcrimm_z=gmmx*rimmy-gmmy*rimmx + d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) + d_gmmcrimm3=d_gmmcrimm**3 + gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y + & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y + + if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 + & .and.drim3.gt.0.0D0 + & .and.d_gmmcrimm3.gt.0.0D0) then + d40=1.0D0/(dg30*dgmm) + d41=g3gmm/(dg30*dgmm3) + d42=1.0D0/(dg30*drim) + d43=g3rim_/(dg30*drim3) + sd40=1.0D0/(dg30*d_gmmcrimm) + sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) + else + d40=0.0D0 + d41=0.0D0 + d42=0.0D0 + d43=0.0D0 + sd40=0.0D0 + sd41=0.0D0 + endif + atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 + & -(gmmy*rimmz-gmmz*rimmy)*d41 + atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 + & -(gmmz*rimmx-gmmx*rimmz)*d41 + atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 + & -(gmmx*rimmy-gmmy*rimmx)*d41 +cc********************************************************************** + astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y + & -g3z*rimmz*rimmx+rimmy**2*g3x) + & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) + & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) + + astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y + & -rimmx*rimmy*g3x+rimmz**2*g3y) + & -sd41*(-gmmcrimm_x*rimmx*rimmy + & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) + + astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z + & +g3z*rimmx**2-rimmz*rimmy*g3y) + & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz + & +gmmcrimm_z*(rimmy**2+rimmx**2)) +cc********************************************************************** + apm3x(i)=g3x*d42-rimx*d43 + apm3y(i)=g3y*d42-rimy*d43 + apm3z(i)=g3z*d42-rimz*d43 + + if(i.le.inb-1) then + ip=i+1 + rix=bx(ip)-bx(i) + riy=by(ip)-by(i) + riz=bz(ip)-bz(i) + cix=bx(ip)-bx(i-1) + ciy=by(ip)-by(i-1) + ciz=bz(ip)-bz(i-1) + gmx=rimy*riz-rimz*riy + gmy=rimz*rix-rimx*riz + gmz=rimx*riy-rimy*rix + dgm=sqrt(gmx**2+gmy**2+gmz**2) + dgm3=dgm**3 + dri=dis(i,i+1) + dri3=dri**3 + gmmgm=gmmx*gmx+gmmy*gmy+gmmz+gmz + gmmr=gmmx*rix+gmmy*riy+gmmz*riz + gmcrim_x=gmy*rimz-gmz*rimy + gmcrim_y=gmz*rimx-gmx*rimz + gmcrim_z=gmx*rimy-gmy*rimx + d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) + d_gmcrim3=d_gmcrim**3 + gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy + & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy + + if(dgm3.gt.0.0D0.and. + & dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 + & .and.d_gmcrim3.gt.0.0D0) then + d30=1.0D0/(dgm*dgmm) + d31=gmmgm/(dgm3*dgmm) + d32=gmmgm/(dgm*dgmm3) + d33=1.0D0/(dgmm*dri) + d34=gmmr/(dgmm3*dri) + d35=gmmr/(dgmm*dri3) + sd30=1.0D0/(d_gmcrim*dgmm) + sd31=gmcrim__gmm/(d_gmcrim3*dgmm) + sd32=gmcrim__gmm/(d_gmcrim*dgmm3) + + else + d30=0.0D0 + d31=0.0D0 + d32=0.0D0 + d33=0.0D0 + d34=0.0D0 + d35=0.0D0 + sd30=0.0D0 + sd31=0.0D0 + sd32=0.0D0 + endif +cc********************************************************************** + atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 + & -(ciy*gmz-ciz*gmy)*d31 + & -(gmmy*rimmz-gmmz*rimmy)*d32 + atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 + & -(ciz*gmx-cix*gmz)*d31 + & -(gmmz*rimmx-gmmx*rimmz)*d32 + atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 + & -(cix*gmy-ciy*gmx)*d31 + & -(gmmx*rimmy-gmmy*rimmx)*d32 +cc********************************************************************** + astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy + & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz + & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy + & -ciy*rimy*gmmx-rimz*gmx*rimmz) + & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) + & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) + & -sd32*(gmmy*rimmz-rimmy*gmmz) + + astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz + & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy + & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx + & +gmz*rimy*rimmz-rimz*ciz*gmmy) + & -sd31*(gmcrim_x*(cix*rimy-gmz) + & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) + & -sd32*(-gmmx*rimmz+rimmx*gmmz) + + astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz + & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx + & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy + & +rimz*ciy*gmmy+rimz*gmx*rimmx) + & -sd31*(gmcrim_x*(cix*rimz+gmy) + & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) + & -sd32*(gmmx*rimmy-rimmx*gmmy) +cc********************************************************************** + apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 + & -(gmmy*rimmz-gmmz*rimmy)*d34 + & +rix*d35 + apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 + & -(gmmz*rimmx-gmmx*rimmz)*d34 + & +riy*d35 + apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 + & -(gmmx*rimmy-gmmy*rimmx)*d34 + & +riz*d35 + endif + +c write(*,*) 'inside angvectors6' + + if(i.eq.inb-2) then + ipp=i+2 + ripx=bx(ipp)-bx(ip) + ripy=by(ipp)-by(ip) + ripz=bz(ipp)-bz(ip) + cipx=bx(ipp)-bx(i) + cipy=by(ipp)-by(i) + cipz=bz(ipp)-bz(i) + gx=riy*ripz-riz*ripy + gy=riz*ripx-rix*ripz + gz=rix*ripy-riy*ripx + ggm=gmx*gx+gmy*gy+gmz*gz + gmrp=gmx*ripx+gmy*ripy+gmz*ripz + dg=sqrt(gx**2+gy**2+gz**2) + dg3=dg**3 + drip=dis(i+1,i+2) + gcr_x=gy*riz-gz*riy + gcr_y=gz*rix-gx*riz + gcr_z=gx*riy-gy*rix + d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) + d_gcr3=d_gcr**3 + gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy + & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy + if(dgm3.gt.0.0D0.and. + & dg3.gt.0.0D0.and.drip.gt.0.0D0.and.d_gcr3.gt.0.0D0 + & ) then + d20=1.0D0/(dg*dgm) + d21=ggm/(dgm3*dg) + d22=ggm/(dgm*dg3) + d23=1.0D0/(dgm*drip) + d24=gmrp/(dgm3*drip) + sd20=1.0D0/(d_gcr*dgm) + sd21=gcr__gm/(d_gcr3*dgm) + sd22=gcr__gm/(d_gcr*dgm3) + else + d20=0.0D0 + d21=0.0D0 + d22=0.0D0 + d23=0.0D0 + d24=0.0D0 + sd20=0.0D0 + sd21=0.0D0 + sd22=0.0D0 + endif + atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 + & -(ciy*gmz-ciz*gmy)*d21 + & +(ripy*gz-ripz*gy)*d22 + atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 + & -(ciz*gmx-cix*gmz)*d21 + & +(ripz*gx-ripx*gz)*d22 + atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 + & -(cix*gmy-ciy*gmx)*d21 + & +(ripx*gy-ripy*gx)*d22 +cc********************************************************************** + astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy + & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix + & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) + & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) + & +gcr_z*(-ripz*rix+gy)) + & -sd22*(-gmy*ciz+gmz*ciy) + + astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix + & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz + & +riz*ripz*gmy) + & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) + & -gcr_z*(ripz*riy+gx)) + & -sd22*(gmx*ciz-gmz*cix) + + astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz + & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy + & -riz*gx*cix) + & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) + & +gcr_z*(ripy*riy+ripx*rix)) + & -sd22*(-gmx*ciy+gmy*cix) +cc********************************************************************** +c + apmx(i)=(ciy*ripz-ripy*ciz)*d23 + & -(ciy*gmz-ciz*gmy)*d24 + apmy(i)=(ciz*ripx-ripz*cix)*d23 + & -(ciz*gmx-cix*gmz)*d24 + apmz(i)=(cix*ripy-ripx*ciy)*d23 + & -(cix*gmy-ciy*gmx)*d24 + + endif + enddo + + return + end +c END of angvectors +c------------------------------------------------------------------------------- +C--------------------------------------------------------------------------------- + subroutine sheetforce(nca,wshet) + implicit none +C JYLEE +c this should be matched with dfa.fcm + integer maxca + parameter(maxca=800) +cc********************************************************************** + integer nca + integer i,k + integer inb,nmax,iselect + +c real*8 dfaexp(15001) + + real*8 vbeta,vbetp,vbetm + real*8 shefx(maxca,12) + real*8 shefy(maxca,12),shefz(maxca,12) + real*8 shetfx(maxca),shetfy(maxca),shetfz(maxca) + real*8 vbet(maxca,maxca) + real*8 wshet(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + + common /sheca/ bx,by,bz + common /phys1/ inb,nmax,iselect + common /shef/ shefx,shefy,shefz + common /shee/ vbeta,vbet,vbetp,vbetm + common /shetf/ shetfx,shetfy,shetfz + + inb=nca + do i=1,inb + shetfx(i)=0.0D0 + shetfy(i)=0.0D0 + shetfz(i)=0.0D0 + enddo + + do k=1,12 + do i=1,inb + shefx(i,k)=0.0D0 + shefy(i,k)=0.0D0 + shefz(i,k)=0.0D0 + enddo + enddo + + call sheetene(nca,wshet) + call sheetforce1 + + 887 format(a,1x,i6,3x,f12.8) + 888 format(a,1x,i4,1x,i4,3x,f12.8) + 889 format(a,1x,i4,3x,f12.8) + !write(2,*) 'coord : ' + do i=1,inb + !write(2,887) 'bx:',i,bx(i) + !write(2,887) 'by:',i,by(i) + !write(2,887) 'bz:',i,bz(i) + enddo + !write(2,*) 'After sheetforce1' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + call sheetforce5 + + !write(2,*) 'After sheetforce5' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + call sheetforce6 + + !write(2,*) 'After sheetforce6' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + call sheetforce11 + + !write(2,*) 'After sheetforce11' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + call sheetforce12 + + !write(2,*) 'After sheetforce12' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + do i=1,inb + do k=1,12 + shetfx(i)=shetfx(i)+shefx(i,k) + shetfy(i)=shetfy(i)+shefy(i,k) + shetfz(i)=shetfz(i)+shefz(i,k) + enddo + enddo + !write(2,*) 'Beta Finished' + do i=1,inb + !write(2,889) 'shetfx : ',i,shetfx(i) + !write(2,889) 'shetfy : ',i,shetfy(i) + !write(2,889) 'shetfz : ',i,shetfz(i) + enddo + + return + end +C end sheetforce +c------------------------------------------------------------------------------- + subroutine sheetene(nca,wshet) + implicit none + integer maxca + parameter(maxca=800) + real*8 dfa_cutoff,dfa_cutoff_delta + parameter(dfa_cutoff=15.5d0) + parameter(dfa_cutoff_delta=0.5d0) +cc****************************************************************************** + +c real*8 dfaexp(15001) + real*8 dtmp1, dtmp2, dtmp3 + + real*8 vbet(maxca,maxca) + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 cph(maxca),cth(maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 ulcos(maxca) +cc********************************************************************** + real*8 astx(maxca),asty(maxca),astz(maxca) + real*8 astmx(maxca),astmy(maxca),astmz(maxca) + real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) + real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) + real*8 sth(maxca) + real*8 wshet(maxca,maxca) + real*8 dp45, dm45, w_beta + real*8 c00, s00, ulnex, dnex, dca,dlhb,ulhb,dshe,dldhb,uldhb + integer nca + integer i,ip,ipp,j,jp,jpp,inb,nmax,iselect + real*8 uum, uup + real*8 vbeta,vbetp,vbetm,y,y1,y2,yshe1,yshe2,yy1,yy2 + + real*8 shetfx(maxca),shetfy(maxca),shetfz(maxca) + common /shetf/ shetfx,shetfy,shetfz + + common /sheca/ bx,by,bz + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /coscos/ cph,cth + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + & c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shee/ vbeta,vbet,vbetp,vbetm + common /ulang/ ulcos +cc********************************************************************** + common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, + & astmmz,astm3x,astm3y,astm3z + common /sinsin/ sth + + real*8 r_pair_mat(maxca,maxca) + real*8 e_gcont,fprim_gcont,de_gcont +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m + common /beta_p/ r_pair_mat +C------------------------------------------------------------------------------- + r_pair_mat = 0.0d0 + do i=1,inb + do j=1,inb + r_pair_mat(i,j)=wshet(i,j) +c write(*,*) 'r_pair_mat :',i,j,r_pair_mat(i,j) + enddo + enddo +c stop +c + vbeta=0.0D0 + vbetp=0.0D0 + vbetm=0.0D0 + + do i=1,inb-7 + do j=i+4,inb-3 + + if (dis(i,j).lt.dfa_cutoff) then + call gcont(dis(i,j),dfa_cutoff-dfa_cutoff_delta,1.0D0, + & dfa_cutoff_delta,e_gcont,fprim_gcont) + + + ip=i+1 + ipp=i+2 + jp=j+1 + jpp=j+2 +cc********************************************************************** + y1=(cth(i)*c00+sth(i)*s00-1.0D0)**2 + & +(cth(j)*c00+sth(j)*s00-1.0D0)**2 + y1=-0.5d0*y1/dca + y2=(ulcos(i)-ulnex)**2+(ulcos(ip)-ulnex)**2 + & +(ulcos(j)-ulnex)**2+(ulcos(jp)-ulnex)**2 + y2=-0.5d0*y2/dnex + +cdebug y2=0 + + y=y1+y2 + +ci if(y.ge.-4) then +ci istrand(i,j)=1 +ci else +ci istrand(i,j)=0 +ci endif + +ci if(istrand(i,j).eq.1) then + + yy1=-0.5d0*(dis(ip,jp)-ulhb)**2/dlhb + yy2=-0.5d0*(dis(ipp,jpp)-ulhb)**2/dlhb + + + pin1(i,j)=(rx(ip,jp)*rx(ip,ipp)+ry(ip,jp)*ry(ip,ipp) + $ +rz(ip,jp)*rz(ip,ipp))/(dis(ip,jp)*dis(ip,ipp)) + pin2(i,j)=(rx(ip,jp)*rx(jp,jpp)+ry(ip,jp)*ry(jp,jpp) + $ +rz(ip,jp)*rz(jp,jpp))/(dis(ip,jp)*dis(jp,jpp)) + pin3(i,j)=(rx(ipp,jpp)*rx(ip,ipp)+ry(ipp,jpp)*ry(ip,ipp) + $ +rz(ipp,jpp)*rz(ip,ipp))/(dis(ipp,jpp)*dis(ip,ipp)) + pin4(i,j)=(rx(ipp,jpp)*rx(jp,jpp)+ry(ipp,jpp)*ry(jp,jpp) + $ +rz(ipp,jpp)*rz(jp,jpp))/(dis(ipp,jpp)*dis(jp,jpp)) + + yshe1=pin1(i,j)**2+pin2(i,j)**2 + yshe1=-0.5d0*yshe1/dshe + yshe2=pin3(i,j)**2+pin4(i,j)**2 + yshe2=-0.5d0*yshe2/dshe + +ci if((yshe1+yshe2).ge.-4) then +ci istrand_p(i,j)=1 +ci else +ci istrand_p(i,j)=0 +ci endif + + +C write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) +C write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) +C write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) +C write(*,*) 'dis(i,j):',i,j,dis(i,j) +C write(*,*) 'rx(ip,jp):',ip,jp,bx(ip),bx(jp),rx(ip,jp) +C write(*,*) 'rx(ip,ipp):',ip,ipp,bx(ip),bx(ipp),rx(ip,ipp) +C write(*,*) 'pin1:',pin1(i,j) +C write(*,*) 'pin2:',pin2(i,j) +C write(*,*) 'pin3:',pin3(i,j) +C write(*,*) 'pin4:',pin4(i,j) + +C write(*,*) 'y:',y +C write(*,*) 'yy1:',yy1 +C write(*,*) 'yy2:',yy2 +C write(*,*) 'yshe1:',yshe1 +C write(*,*) 'yshe2:',yshe2 +c + +ci if (istrand_p(i,j).eq.1) then + +cd yy1=0 +cd yy2=0 +cd yshe1=0 +cd yshe2=0 + dtmp1 = y+yy1+yshe1 + dtmp2 = y+yy2+yshe2 + dtmp3 = y+yy1+yy2+yshe1+yshe2 + +C write(*,*)'1', i,j,dtmp1,dtmp2,dtmp3 +C write(*,*)'2', y,yy1,yy2 +C write(*,*)'3', yshe1,yshe2 + +cc if (dtmp3.le.-35.0d0) then +c vbetap(i,j)=-dp45*exp(dtmp3) +cc vbetap(i,j)=0.0d0 +cc else +c vbetap(i,j)=-dp45*dfaexp(idint(-dtmp3*1000)+1) + vbetap(i,j)=-dp45*exp(dtmp3) +cc end if + +cc if (dtmp1.le.-35.0d0) then +c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1) +cc vbetap1(i,j)=0.0d0 +cc else +c vbetap1(i,j)=-r_pair_mat(i+1,j+1) +c $ *dfaexp(idint(-dtmp1*1000)+1) + vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1) +cc end if + +cc if (dtmp2.le.-35.0d0) then +C vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2) +cc vbetap2(i,j)=0.0d0 +cc else +c vbetap2(i,j)=-r_pair_mat(i+2,j+2) +c $ *dfaexp(idint(-dtmp2*1000)+1) + vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2) +cc end if + +c vbetap(i,j)=-dp45*exp(y+yy1+yy2+yshe1+yshe2) +c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(y+yy1+yshe1) +c vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(y+yy2+yshe2) + +! write(*,*) 'r_pair_mat>',i+1,j+1,r_pair_mat(i+1,j+1) +! write(*,*) 'r_pair_mat>',i+2,j+2,r_pair_mat(i+2,j+2) + +ci elseif (istrand_p(i,j).eq.0)then +ci vbetap(i,j)=0 +ci vbetap1(i,j)=0 +ci vbetap2(i,j)=0 +ci endif + + yy1=-0.5d0*(dis(ip,jpp)-ulhb)**2/dlhb + yy2=-0.5d0*(dis(ipp,jp)-ulhb)**2/dlhb + + pina1(i,j)=(rx(ip,jpp)*rx(ip,ipp)+ry(ip,jpp)*ry(ip,ipp) + $ +rz(ip,jpp)*rz(ip,ipp))/(dis(ip,jpp)*dis(ip,ipp)) + pina2(i,j)=(rx(ip,jpp)*rx(jp,jpp)+ry(ip,jpp)*ry(jp,jpp) + $ +rz(ip,jpp)*rz(jp,jpp))/(dis(ip,jpp)*dis(jp,jpp)) + pina3(i,j)=(rx(jp,ipp)*rx(ip,ipp)+ry(jp,ipp)*ry(ip,ipp) + $ +rz(jp,ipp)*rz(ip,ipp))/(dis(jp,ipp)*dis(ip,ipp)) + pina4(i,j)=(rx(jp,ipp)*rx(jp,jpp)+ry(jp,ipp)*ry(jp,jpp) + $ +rz(jp,ipp)*rz(jp,jpp))/(dis(jp,ipp)*dis(jp,jpp)) + + yshe1=pina1(i,j)**2+pina2(i,j)**2 + yshe1=-0.5d0*yshe1/dshe + yshe2=pina3(i,j)**2+pina4(i,j)**2 + yshe2=-0.5d0*yshe2/dshe + +ci if((yshe1+yshe2).ge.-4) then +ci istrand_m(i,j)=1 +ci else +ci istrand_m(i,j)=0 +ci endif + + +C write(*,*) 'pina1:',pina1(i,j) +C write(*,*) 'pina2:',pina2(i,j) +C write(*,*) 'pina3:',pina3(i,j) +C write(*,*) 'pina4:',pina4(i,j) +C write(*,*) 'yshe1:',yshe1 +C write(*,*) 'yshe2:',yshe2 +C write(*,*) 'dshe:',dshe + +ci if (istrand_m(i,j).eq.1) then + +cd yy1=0 +cd yy2=0 +cd yshe1=0 +cd yshe2=0 + + dtmp3=y+yy1+yy2+yshe1+yshe2 + dtmp1=y+yy1+yshe1 + dtmp2=y+yy2+yshe2 + +cc if(dtmp3 .le. -35.0d0) then +c vbetam(i,j)=-dm45*exp(dtmp3) +cc vbetam(i,j)=0.0d0 +cc else +c vbetam(i,j)=-dm45*dfaexp(idint(-dtmp3*1000)+1) + vbetam(i,j)=-dm45*exp(dtmp3) +cc end if + +cc if(dtmp1 .le. -35.0d0) then +c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1) +cc vbetam1(i,j)=0.0d0 +cc else +c vbetam1(i,j)=-r_pair_mat(i+1,j+2) +c $ *dfaexp(idint(-dtmp1*1000)+1) + vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1) +cc end if + +cc if(dtmp2.le.-35.0d0) then +c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2) +cc vbetam2(i,j)=0.0d0 +cc else +c vbetam2(i,j)=-r_pair_mat(i+2,j+1) +c $ *dfaexp(idint(-dtmp2*1000)+1) + vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2) +cc end if + +ci elseif (istrand_m(i,j).eq.0)then +ci vbetam(i,j)=0 +ci vbetam1(i,j)=0 +ci vbetam2(i,j)=0 +ci endif + + +c vbetam(i,j)=-dm45*exp(y+yy1+yy2+yshe1+yshe2) +c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(y+yy1+yshe1) +c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(y+yy2+yshe2) + +! write(*,*) 'r_pair_mat>',i+1,j+2,r_pair_mat(i+1,j+2) +! write(*,*) 'r_pair_mat>',i+2,j+1,r_pair_mat(i+2,j+1) + + uup = vbetap(i,j)+vbetap1(i,j)+vbetap2(i,j) + uum = vbetam(i,j)+vbetam1(i,j)+vbetam2(i,j) + +c write(*,*) 'uup,uum:', uup, uum + +c uup=vbetap1(i,j)+vbetap2(i,j) +c uum=vbetam1(i,j)+vbetam2(i,j) + + vbet(i,j)=uup+uum + vbetp=vbetp+uup + vbetm=vbetm+uum + vbeta=vbeta+vbet(i,j)*e_gcont + + + if (dis(i,j) .ge. dfa_cutoff-2*dfa_cutoff_delta) then +c gradient correction from gcont + de_gcont=vbet(i,j)*fprim_gcont/dis(i,j) + shetfx(i)=shetfx(i) + de_gcont*rx(i,j) + shetfy(i)=shetfy(i) + de_gcont*ry(i,j) + shetfz(i)=shetfz(i) + de_gcont*rz(i,j) + + shetfx(j)=shetfx(j) - de_gcont*rx(i,j) + shetfy(j)=shetfy(j) - de_gcont*ry(i,j) + shetfz(j)=shetfz(j) - de_gcont*rz(i,j) + +c energy correction from gcont + vbet(i,j)=vbet(i,j)*e_gcont + vbetap(i,j)=vbetap(i,j)*e_gcont + vbetap1(i,j)=vbetap1(i,j)*e_gcont + vbetap2(i,j)=vbetap2(i,j)*e_gcont + vbetam(i,j)=vbetam(i,j)*e_gcont + vbetam1(i,j)=vbetam1(i,j)*e_gcont + vbetam2(i,j)=vbetam2(i,j)*e_gcont + endif + + +ci elseif(istrand(i,j).eq.0)then +ci vbet(i,j)=0 +ci endif + +c write(*,*) 'uup,uum:',uup,uum +c write(*,*) 'vbetap(i,j):',vbetap(i,j) +c write(*,*) 'vbetap1(i,j):',vbetap1(i,j) +c write(*,*) 'vbetap2(i,j):',vbetap2(i,j) +c write(*,*) 'vbetam(i,j):',vbetam(i,j) +c write(*,*) 'vbetam1(i,j):',vbetam1(i,j) +c write(*,*) 'vbetam2(i,j):',vbetam2(i,j) +c write(*,*) 'uup:',uup +c write(*,*) 'uum:',uum +c write(*,*) 'vbetp:',vbetp +c write(*,*) 'vbetm:',vbetm +c write(*,*) 'vbet(i,j):',vbet(i,j) +c stop + + else + vbetap(i,j)=0 + vbetap1(i,j)=0 + vbetap2(i,j)=0 + vbetam(i,j)=0 + vbetam1(i,j)=0 + vbetam2(i,j)=0 + vbet(i,j)=0 + endif + enddo + enddo + +! do i=1,inb-7 +! do j=i+4,inb-3 +! write(*,*) 'I,J:', i,j +! write(*,*) 'vbetap(i,j):',vbetap(i,j) +! write(*,*) 'vbetap1(i,j):',vbetap1(i,j) +! write(*,*) 'vbetap2(i,j):',vbetap2(i,j) +! write(*,*) 'vbetam(i,j):',vbetam(i,j) +! write(*,*) 'vbetam1(i,j):',vbetam1(i,j) +! write(*,*) 'vbetam2(i,j):',vbetam2(i,j) +! write(*,*) 'vbet(i,j):',vbet(i,j) +! enddo +! enddo + + return + end +c------------------------------------------------------------------------------- + subroutine sheetforce1 + implicit none + integer maxca + parameter(maxca=800) + real*8 dfa_cutoff,dfa_cutoff_delta + parameter(dfa_cutoff=15.5d0) + parameter(dfa_cutoff_delta=0.5d0) +cc********************************************************************** + real*8 vbet(maxca,maxca) + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 cph(maxca),cth(maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12) + real*8 shefy(maxca,12),shefz(maxca,12) + real*8 atx(maxca),aty(maxca),atz(maxca) + real*8 atmx(maxca),atmy(maxca),atmz(maxca) + real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) + real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) + real*8 apx(maxca),apy(maxca),apz(maxca) + real*8 apmx(maxca),apmy(maxca),apmz(maxca) + real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) + real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) + real*8 ulcos(maxca) + real*8 astx(maxca),asty(maxca),astz(maxca) + real*8 astmx(maxca),astmy(maxca),astmz(maxca) + real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) + real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) + real*8 sth(maxca) + real*8 w_beta,dp45, dm45 + real*8 vbeta, vbetp, vbetm + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect + + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /coscos/ cph,cth + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, + $ atmmz,atm3x,atm3y,atm3z + common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, + $ apmmz,apm3x,apm3y,apm3z + common /shef/ shefx,shefy,shefz + common /shee/ vbeta,vbet,vbetp,vbetm + common /ulang/ ulcos +c c********************************************************************** + common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, + $ astmmz,astm3x,astm3y,astm3z + common /sinsin/ sth +C-------------------------------------------------------------------------------- +c local variables + integer i,j,im3,imm,im,ip,ipp,jm,jmm,jm3,jp,jpp + real*8 c1,v1,cc1,dmm,dmm__,fx,fy,fz,c2,v2,dmm1 + real*8 c3,v3,cc2,cc3,dmm3,dmm3__,c4,v4,c7,v7,cc7,c8,v8,cc8 + real*8 c9,v9,cc9,dmm9,dmm9__,c10,v10,dmm2,dmm1__,dmm2_1,dmm2_2 + real*8 dmm7,dmm8,dmm7__,dmm8_1,dmm8_2 + real*8 e_gcont,fprim_gcont +C-------------------------------------------------------------------------------- + do i=4,inb-4 + im3=i-3 + imm=i-2 + im=i-1 + c1=(cth(im3)*c00+sth(im3)*s00-1)/dca + v1=0.0D0 + do j=i+1,inb-3 + v1=v1+vbet(im3,j) + enddo + cc1=(ulcos(imm)-ulnex)/dnex + dmm=cc1/(dis(imm,im)*dis(im,i)) + dmm__=cc1*ulcos(imm)/dis(im,i)**2 + fx=rx(imm,im)*dmm-rx(im,i)*dmm__ + fy=ry(imm,im)*dmm-ry(im,i)*dmm__ + fz=rz(imm,im)*dmm-rz(im,i)*dmm__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atm3x(i)*c00+astm3x(i)*s00)*c1 + fy=fy+(atm3y(i)*c00+astm3y(i)*s00)*c1 + fz=fz+(atm3z(i)*c00+astm3z(i)*s00)*c1 + shefx(i,1)=fx*v1 + shefy(i,1)=fy*v1 + shefz(i,1)=fz*v1 + enddo + + do i=3,inb-5 + imm=i-2 + im=i-1 + ip=i+1 + c2=(cth(imm)*c00+sth(imm)*s00-1)/dca + v2=0.0D0 + do j=i+2,inb-3 + v2=v2+vbet(imm,j) + enddo + cc1=(ulcos(imm)-ulnex)/dnex + cc2=(ulcos(im)-ulnex)/dnex + dmm1=cc1/(dis(imm,im)*dis(im,i)) + dmm2=cc2/(dis(im,i)*dis(i,ip)) + dmm1__=cc1*ulcos(imm)/dis(im,i)**2 + dmm2_1=cc2*ulcos(im)/dis(im,i)**2 + dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 +cc********************************************************************** + fx=rx(imm,im)*dmm1-rx(im,i)*dmm1__+rx(i,ip)*dmm2-rx(im,i)*dmm2 + $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2 + fy=ry(imm,im)*dmm1-ry(im,i)*dmm1__+ry(i,ip)*dmm2-ry(im,i)*dmm2 + $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2 + fz=rz(imm,im)*dmm1-rz(im,i)*dmm1__+rz(i,ip)*dmm2-rz(im,i)*dmm2 + $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2 +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atmmx(i)*c00+astmmx(i)*s00)*c2 + fy=fy+(atmmy(i)*c00+astmmy(i)*s00)*c2 + fz=fz+(atmmz(i)*c00+astmmz(i)*s00)*c2 + shefx(i,2)=fx*v2 + shefy(i,2)=fy*v2 + shefz(i,2)=fz*v2 + enddo + do i=2,inb-6 + im=i-1 + ip=i+1 + ipp=i+2 + c3=(cth(im)*c00+sth(im)*s00-1)/dca + v3=0.0D0 + do j=i+3,inb-3 + v3=v3+vbet(im,j) + enddo + cc2=(ulcos(im)-ulnex)/dnex + cc3=(ulcos(i)-ulnex)/dnex + dmm2=cc2/(dis(im,i)*dis(i,ip)) + dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) + dmm2_1=cc2*ulcos(im)/dis(im,i)**2 + dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 + dmm3__=cc3*ulcos(i)/dis(i,ip)**2 + fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm2-rx(im,i)*dmm2 + $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2+rx(i,ip)*dmm3__ + fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm2-ry(im,i)*dmm2 + $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2+ry(i,ip)*dmm3__ + fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm2-rz(im,i)*dmm2 + $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2+rz(i,ip)*dmm3__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atmx(i)*c00+astmx(i)*s00)*c3 + fy=fy+(atmy(i)*c00+astmy(i)*s00)*c3 + fz=fz+(atmz(i)*c00+astmz(i)*s00)*c3 + shefx(i,3)=fx*v3 + shefy(i,3)=fy*v3 + shefz(i,3)=fz*v3 + enddo + do i=1,inb-7 + ip=i+1 + ipp=i+2 + c4=(cth(i)*c00+sth(i)*s00-1)/dca + v4=0.0D0 + do j=i+4,inb-3 + v4=v4+vbet(i,j) + enddo + cc3=(ulcos(i)-ulnex)/dnex + dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) + dmm3__=cc3*ulcos(i)/dis(i,ip)**2 + fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm3__ + fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm3__ + fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm3__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atx(i)*c00+astx(i)*s00)*c4 + fy=fy+(aty(i)*c00+asty(i)*s00)*c4 + fz=fz+(atz(i)*c00+astz(i)*s00)*c4 + shefx(i,4)=fx*v4 + shefy(i,4)=fy*v4 + shefz(i,4)=fz*v4 + enddo + do j=8,inb + jm3=j-3 + jmm=j-2 + jm=j-1 + c7=(cth(jm3)*c00+sth(jm3)*s00-1)/dca + v7=0.0D0 + do i=1,j-7 + v7=v7+vbet(i,jm3) + enddo + cc7=(ulcos(jmm)-ulnex)/dnex + dmm=cc7/(dis(jmm,jm)*dis(jm,j)) + dmm__=cc7*ulcos(jmm)/dis(jm,j)**2 + fx=rx(jmm,jm)*dmm-rx(jm,j)*dmm__ + fy=ry(jmm,jm)*dmm-ry(jm,j)*dmm__ + fz=rz(jmm,jm)*dmm-rz(jm,j)*dmm__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atm3x(j)*c00+astm3x(j)*s00)*c7 + fy=fy+(atm3y(j)*c00+astm3y(j)*s00)*c7 + fz=fz+(atm3z(j)*c00+astm3z(j)*s00)*c7 + shefx(j,7)=fx*v7 + shefy(j,7)=fy*v7 + shefz(j,7)=fz*v7 + enddo + do j=7,inb-1 + jm=j-1 + jmm=j-2 + jp=j+1 + c8=(cth(jmm)*c00+sth(jmm)*s00-1)/dca + v8=0.0D0 + do i=1,j-6 + v8=v8+vbet(i,jmm) + enddo + cc7=(ulcos(jmm)-ulnex)/dnex + cc8=(ulcos(jm)-ulnex)/dnex + dmm7=cc7/(dis(jmm,jm)*dis(jm,j)) + dmm8=cc8/(dis(jm,j)*dis(j,jp)) + dmm7__=cc7*ulcos(jmm)/dis(jm,j)**2 + dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 + dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 + fx=rx(jmm,jm)*dmm7+rx(j,jp)*dmm8-rx(jm,j)*dmm8 + $ -rx(jm,j)*dmm7__-rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2 + fy=ry(jmm,jm)*dmm7+ry(j,jp)*dmm8-ry(jm,j)*dmm8 + $ -ry(jm,j)*dmm7__-ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2 + fz=rz(jmm,jm)*dmm7+rz(j,jp)*dmm8-rz(jm,j)*dmm8 + $ -rz(jm,j)*dmm7__-rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2 +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atmmx(j)*c00+astmmx(j)*s00)*c8 + fy=fy+(atmmy(j)*c00+astmmy(j)*s00)*c8 + fz=fz+(atmmz(j)*c00+astmmz(j)*s00)*c8 + shefx(j,8)=fx*v8 + shefy(j,8)=fy*v8 + shefz(j,8)=fz*v8 + enddo + + do j=6,inb-2 + jm=j-1 + jp=j+1 + jpp=j+2 + c9=(cth(jm)*c00+sth(jm)*s00-1)/dca + v9=0.0D0 + do i=1,j-5 + v9=v9+vbet(i,jm) + enddo + cc8=(ulcos(jm)-ulnex)/dnex + cc9=(ulcos(j)-ulnex)/dnex + dmm8=cc8/(dis(jm,j)*dis(j,jp)) + dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) + dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 + dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 + dmm9__=cc9*ulcos(j)/dis(j,jp)**2 + fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm8-rx(jm,j)*dmm8 + $ -rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2+rx(j,jp)*dmm9__ + fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm8-ry(jm,j)*dmm8 + $ -ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2+ry(j,jp)*dmm9__ + fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm8-rz(jm,j)*dmm8 + $ -rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2+rz(j,jp)*dmm9__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atmx(j)*c00+astmx(j)*s00)*c9 + fy=fy+(atmy(j)*c00+astmy(j)*s00)*c9 + fz=fz+(atmz(j)*c00+astmz(j)*s00)*c9 + shefx(j,9)=fx*v9 + shefy(j,9)=fy*v9 + shefz(j,9)=fz*v9 + enddo + + do j=5,inb-3 + jp=j+1 + jpp=j+2 + c10=(cth(j)*c00+sth(j)*s00-1)/dca + v10=0.0D0 + do i=1,j-4 + v10=v10+vbet(i,j) + enddo + cc9=(ulcos(j)-ulnex)/dnex + dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) + dmm9__=cc9*ulcos(j)/dis(j,jp)**2 + fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm9__ + fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm9__ + fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm9__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atx(j)*c00+astx(j)*s00)*c10 + fy=fy+(aty(j)*c00+asty(j)*s00)*c10 + fz=fz+(atz(j)*c00+astz(j)*s00)*c10 + shefx(j,10)=fx*v10 + shefy(j,10)=fy*v10 + shefz(j,10)=fz*v10 + enddo + + return + end +c---------------------------------------------------------------------------- + subroutine sheetforce5 + implicit none + integer maxca + parameter(maxca=800) + real*8 dfa_cutoff,dfa_cutoff_delta + parameter(dfa_cutoff=15.5d0) + parameter(dfa_cutoff_delta=0.5d0) +cc********************************************************************** + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12),shefy(maxca,12) + real*8 shefz(maxca,12) + real*8 dp45,dm45,w_beta + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect +cc********************************************************************** + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shef/ shefx,shefy,shefz +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m +c******************************************************************************** +c local variables + integer i,imm,im,jp,jpp,j + real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z + real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z + real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z + real*8 y66x,y66y,y66z,yy6,yyy4,yyy5a,yyy5b + real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z + real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b + real*8 e_gcont,fprim_gcont +c******************************************************************************** + do i=3,inb-5 + imm=i-2 + im=i-1 + do j=i+2,inb-3 + + if (dis(imm,j).lt.dfa_cutoff) then + call gcont(dis(imm,j),dfa_cutoff-dfa_cutoff_delta,1.0D0, + & dfa_cutoff_delta,e_gcont,fprim_gcont) + + jp=j+1 + jpp=j+2 + +ci if(istrand(imm,j).eq.1 +ci & .and.(istrand_p(imm,j)+istrand_m(imm,j)).ge.1) then + + + yy1=-(dis(i,jpp)-ulhb)/dlhb + y1x=rx(jpp,i)/dis(i,jpp) + y1y=ry(jpp,i)/dis(i,jpp) + y1z=rz(jpp,i)/dis(i,jpp) + y11x=yy1*y1x + y11y=yy1*y1y + y11z=yy1*y1z + + yy33=1.0D0/(dis(im,jp)*dis(im,i)) + yyy3=pin1(imm,j)/(dis(im,i)**2) + yy3=-pin1(imm,j)/dshe + y3x=(yy33*rx(im,jp)-yyy3*rx(im,i))*yy3 + y3y=(yy33*ry(im,jp)-yyy3*ry(im,i))*yy3 + y3z=(yy33*rz(im,jp)-yyy3*rz(im,i))*yy3 + + yy44=1.0D0/(dis(i,jpp)*dis(im,i)) + yyy4a=pin3(imm,j)/(dis(i,jpp)**2) + yyy4b=pin3(imm,j)/(dis(im,i)**2) + yy4=-pin3(imm,j)/dshe + y4x=(yy44*(rx(i,jpp)-rx(im,i))+yyy4a*rx(i,jpp) + $ -yyy4b*rx(im,i))*yy4 + y4y=(yy44*(ry(i,jpp)-ry(im,i))+yyy4a*ry(i,jpp) + $ -yyy4b*ry(im,i))*yy4 + y4z=(yy44*(rz(i,jpp)-rz(im,i))+yyy4a*rz(i,jpp) + $ -yyy4b*rz(im,i))*yy4 + + + yy55=1.0D0/(dis(i,jpp)*dis(jp,jpp)) + yyy5=pin4(imm,j)/(dis(i,jpp)**2) + yy5=-pin4(imm,j)/dshe + y5x=(-yy55*rx(jp,jpp)+yyy5*rx(i,jpp))*yy5 + y5y=(-yy55*ry(jp,jpp)+yyy5*ry(i,jpp))*yy5 + y5z=(-yy55*rz(jp,jpp)+yyy5*rz(i,jpp))*yy5 + + sx=y11x+y3x+y4x+y5x + sy=y11y+y3y+y4y+y5y + sz=y11z+y3z+y4z+y5z + + sx1=y3x + sy1=y3y + sz1=y3z + sx2=y11x+y4x+y5x + sy2=y11y+y4y+y5y + sz2=y11z+y4z+y5z + + shefx(i,5)=shefx(i,5)-sx*vbetap(imm,j) + $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) + shefy(i,5)=shefy(i,5)-sy*vbetap(imm,j) + $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) + shefz(i,5)=shefz(i,5)-sz*vbetap(imm,j) + $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) + +! shefx(i,5)=shefx(i,5) +! $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) +! shefy(i,5)=shefy(i,5) +! $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) +! shefz(i,5)=shefz(i,5) +! $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) + + yy6=-(dis(i,jp)-uldhb)/dldhb + y6x=rx(jp,i)/dis(i,jp) + y6y=ry(jp,i)/dis(i,jp) + y6z=rz(jp,i)/dis(i,jp) + y66x=yy6*y6x + y66y=yy6*y6y + y66z=yy6*y6z + + yy88=1.0D0/(dis(im,jpp)*dis(im,i)) + yyy8=pina1(imm,j)/(dis(im,i)**2) + yy8=-pina1(imm,j)/dshe + y8x=(yy88*rx(im,jpp)-yyy8*rx(im,i))*yy8 + y8y=(yy88*ry(im,jpp)-yyy8*ry(im,i))*yy8 + y8z=(yy88*rz(im,jpp)-yyy8*rz(im,i))*yy8 + + yy99=1.0D0/(dis(jp,i)*dis(im,i)) + yyy9a=pina3(imm,j)/(dis(jp,i)**2) + yyy9b=pina3(imm,j)/(dis(im,i)**2) + yy9=-pina3(imm,j)/dshe + y9x=(yy99*(rx(jp,i)+rx(im,i))-yyy9a*rx(jp,i) + $ -yyy9b*rx(im,i))*yy9 + y9y=(yy99*(ry(jp,i)+ry(im,i))-yyy9a*ry(jp,i) + $ -yyy9b*ry(im,i))*yy9 + y9z=(yy99*(rz(jp,i)+rz(im,i))-yyy9a*rz(jp,i) + $ -yyy9b*rz(im,i))*yy9 + + yy1010=1.0D0/(dis(jp,i)*dis(jp,jpp)) + yyy10=pina4(imm,j)/(dis(jp,i)**2) + yy10=-pina4(imm,j)/dshe + y10x=(yy1010*rx(jp,jpp)-yyy10*rx(jp,i))*yy10 + y10y=(yy1010*ry(jp,jpp)-yyy10*ry(jp,i))*yy10 + y10z=(yy1010*rz(jp,jpp)-yyy10*rz(jp,i))*yy10 + + sx=y66x+y8x+y9x+y10x + sy=y66y+y8y+y9y+y10y + sz=y66z+y8z+y9z+y10z + + sx1=y8x + sy1=y8y + sz1=y8z + sx2=y66x+y9x+y10x + sy2=y66y+y9y+y10y + sz2=y66z+y9z+y10z + + shefx(i,5)=shefx(i,5)-sx*vbetam(imm,j) + $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) + shefy(i,5)=shefy(i,5)-sy*vbetam(imm,j) + $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) + shefz(i,5)=shefz(i,5)-sz*vbetam(imm,j) + $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) + +! shefx(i,5)=shefx(i,5) +! $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) +! shefy(i,5)=shefy(i,5) +! $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) +! shefz(i,5)=shefz(i,5) +! $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) + + endif +ci endif + + enddo + enddo + + return + end +c--------------------------------------------------------------------------c + subroutine sheetforce6 + implicit none + integer maxca + parameter(maxca=800) + real*8 dfa_cutoff,dfa_cutoff_delta + parameter(dfa_cutoff=15.5d0) + parameter(dfa_cutoff_delta=0.5d0) +cc********************************************************************** + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12),shefy(maxca,12) + real*8 shefz(maxca,12) + real*8 dp45,dm45,w_beta + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect +cc********************************************************************** + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shef/ shefx,shefy,shefz +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m +cc********************************************************************** +C local variables + integer i,imm,im,jp,jpp,j,ip + real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z + real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z + real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y + real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z + real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b,yyy4 + real*8 yyy3a,yyy3b,y66z,yy6,yyy5a,yyy5b + real*8 e_gcont,fprim_gcont +C******************************************************************************** + do i=2,inb-6 + ip=i+1 + im=i-1 + do j=i+3,inb-3 + + if (dis(im,j).lt.dfa_cutoff) then + call gcont(dis(im,j),dfa_cutoff-dfa_cutoff_delta,1.0D0, + & dfa_cutoff_delta,e_gcont,fprim_gcont) + + jp=j+1 + jpp=j+2 + +ci if(istrand(im,j).eq.1 +ci & .and.(istrand_p(im,j)+istrand_m(im,j)).ge.1) then + + + yy1=-(dis(i,jp)-ulhb)/dlhb + y1x=rx(jp,i)/dis(i,jp) + y1y=ry(jp,i)/dis(i,jp) + y1z=rz(jp,i)/dis(i,jp) + y11x=yy1*y1x + y11y=yy1*y1y + y11z=yy1*y1z + + yy33=1.0D0/(dis(i,jp)*dis(i,ip)) + yyy3a=pin1(im,j)/(dis(i,jp)**2) + yyy3b=pin1(im,j)/(dis(i,ip)**2) + yy3=-pin1(im,j)/dshe + y3x=(-yy33*(rx(i,ip)+rx(i,jp))+yyy3a*rx(i,jp) + $ +yyy3b*rx(i,ip))*yy3 + y3y=(-yy33*(ry(i,ip)+ry(i,jp))+yyy3a*ry(i,jp) + $ +yyy3b*ry(i,ip))*yy3 + y3z=(-yy33*(rz(i,ip)+rz(i,jp))+yyy3a*rz(i,jp) + $ +yyy3b*rz(i,ip))*yy3 + + yy44=1.0D0/(dis(i,jp)*dis(jp,jpp)) + yyy4=pin2(im,j)/(dis(i,jp)**2) + yy4=-pin2(im,j)/dshe + y4x=(-yy44*rx(jp,jpp)+yyy4*rx(i,jp))*yy4 + y4y=(-yy44*ry(jp,jpp)+yyy4*ry(i,jp))*yy4 + y4z=(-yy44*rz(jp,jpp)+yyy4*rz(i,jp))*yy4 + + yy55=1.0D0/(dis(ip,jpp)*dis(i,ip)) + yyy5=pin3(im,j)/(dis(i,ip)**2) + yy5=-pin3(im,j)/dshe + y5x=(-yy55*rx(ip,jpp)+yyy5*rx(i,ip))*yy5 + y5y=(-yy55*ry(ip,jpp)+yyy5*ry(i,ip))*yy5 + y5z=(-yy55*rz(ip,jpp)+yyy5*rz(i,ip))*yy5 + + sx=y11x+y3x+y4x+y5x + sy=y11y+y3y+y4y+y5y + sz=y11z+y3z+y4z+y5z + + sx1=y11x+y3x+y4x + sy1=y11y+y3y+y4y + sz1=y11z+y3z+y4z + sx2=y5x + sy2=y5y + sz2=y5z + + shefx(i,6)=shefx(i,6)-sx*vbetap(im,j) + $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) + shefy(i,6)=shefy(i,6)-sy*vbetap(im,j) + $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) + shefz(i,6)=shefz(i,6)-sz*vbetap(im,j) + $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) +! shefx(i,6)=shefx(i,6) +! $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) +! shefy(i,6)=shefy(i,6) +! $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) +! shefz(i,6)=shefz(i,6) +! $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) + + yy6=-(dis(jpp,i)-uldhb)/dldhb + y6x=rx(jpp,i)/dis(jpp,i) + y6y=ry(jpp,i)/dis(jpp,i) + y6z=rz(jpp,i)/dis(jpp,i) + y66x=yy6*y6x + y66y=yy6*y6y + y66z=yy6*y6z + + yy88=1.0D0/(dis(i,jpp)*dis(i,ip)) + yyy8a=pina1(im,j)/(dis(i,jpp)**2) + yyy8b=pina1(im,j)/(dis(i,ip)**2) + yy8=-pina1(im,j)/dshe + y8x=(-yy88*(rx(i,jpp)+rx(i,ip))+yyy8a*rx(i,jpp) + $ +yyy8b*rx(i,ip))*yy8 + y8y=(-yy88*(ry(i,jpp)+ry(i,ip))+yyy8a*ry(i,jpp) + $ +yyy8b*ry(i,ip))*yy8 + y8z=(-yy88*(rz(i,jpp)+rz(i,ip))+yyy8a*rz(i,jpp) + $ +yyy8b*rz(i,ip))*yy8 + + yy99=1.0D0/(dis(i,jpp)*dis(jp,jpp)) + yyy9=pina2(im,j)/(dis(i,jpp)**2) + yy9=-pina2(im,j)/dshe + y9x=(-yy99*rx(jp,jpp)+yyy9*rx(i,jpp))*yy9 + y9y=(-yy99*ry(jp,jpp)+yyy9*ry(i,jpp))*yy9 + y9z=(-yy99*rz(jp,jpp)+yyy9*rz(i,jpp))*yy9 + + yy1010=1.0D0/(dis(jp,ip)*dis(i,ip)) + yyy10=pina3(im,j)/(dis(i,ip)**2) + yy10=-pina3(im,j)/dshe + y10x=(-yy1010*rx(jp,ip)+yyy10*rx(i,ip))*yy10 + y10y=(-yy1010*ry(jp,ip)+yyy10*ry(i,ip))*yy10 + y10z=(-yy1010*rz(jp,ip)+yyy10*rz(i,ip))*yy10 + + sx=y66x+y8x+y9x+y10x + sy=y66y+y8y+y9y+y10y + sz=y66z+y8z+y9z+y10z + + sx1=y66x+y8x+y9x + sy1=y66y+y8y+y9y + sz1=y66z+y8z+y9z + sx2=y10x + sy2=y10y + sz2=y10z + + shefx(i,6)=shefx(i,6)-sx*vbetam(im,j) + $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) + shefy(i,6)=shefy(i,6)-sy*vbetam(im,j) + $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) + shefz(i,6)=shefz(i,6)-sz*vbetam(im,j) + $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) + +! shefx(i,6)=shefx(i,6) +! $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) +! shefy(i,6)=shefy(i,6) +! $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) +! shefz(i,6)=shefz(i,6) +! $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) + + endif +ci endif + + enddo + enddo + + return + end +c----------------------------------------------------------------------- + subroutine sheetforce11 + implicit none + integer maxca + parameter(maxca=800) + real*8 dfa_cutoff,dfa_cutoff_delta + parameter(dfa_cutoff=15.5d0) + parameter(dfa_cutoff_delta=0.5d0) +cc********************************************************************** + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12),shefy(maxca,12) + real*8 shefz(maxca,12) + real*8 dp45,dm45,w_beta + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect +cc********************************************************************** + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shef/ shefx,shefy,shefz +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m +C******************************************************************************** +C local variables + integer j,jm,jmm,ip,i,ipp + real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z + real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y + real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y + real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y + real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy4,yyy5a,yyy5b,yy6 + real*8 yyy9a,yyy9b,y5z,y66z,y9z,yyy8 + real*8 e_gcont,fprim_gcont +C******************************************************************************** + + do j=7,inb-1 + jm=j-1 + jmm=j-2 + do i=1,j-6 + + if (dis(i,jmm).lt.dfa_cutoff) then + call gcont(dis(i,jmm),dfa_cutoff-dfa_cutoff_delta,1.0D0, + & dfa_cutoff_delta,e_gcont,fprim_gcont) + + ip=i+1 + ipp=i+2 + +ci if(istrand(i,jmm).eq.1 +ci & .and.(istrand_p(i,jmm)+istrand_m(i,jmm)).ge.1) then + + + yy1=-(dis(ipp,j)-ulhb)/dlhb + y1x=rx(ipp,j)/dis(ipp,j) + y1y=ry(ipp,j)/dis(ipp,j) + y1z=rz(ipp,j)/dis(ipp,j) + y11x=yy1*y1x + y11y=yy1*y1y + y11z=yy1*y1z + + yy33=1.0D0/(dis(ip,jm)*dis(jm,j)) + yyy3=pin2(i,jmm)/(dis(jm,j)**2) + yy3=-pin2(i,jmm)/dshe + y3x=(yy33*rx(ip,jm)-yyy3*rx(jm,j))*yy3 + y3y=(yy33*ry(ip,jm)-yyy3*ry(jm,j))*yy3 + y3z=(yy33*rz(ip,jm)-yyy3*rz(jm,j))*yy3 + + yy44=1.0D0/(dis(ipp,j)*dis(ip,ipp)) + yyy4=pin3(i,jmm)/(dis(ipp,j)**2) + yy4=-pin3(i,jmm)/dshe + y4x=(yy44*rx(ip,ipp)-yyy4*rx(ipp,j))*yy4 + y4y=(yy44*ry(ip,ipp)-yyy4*ry(ipp,j))*yy4 + y4z=(yy44*rz(ip,ipp)-yyy4*rz(ipp,j))*yy4 + + yy55=1.0D0/(dis(ipp,j)*dis(jm,j)) + yyy5a=pin4(i,jmm)/(dis(ipp,j)**2) + yyy5b=pin4(i,jmm)/(dis(jm,j)**2) + yy5=-pin4(i,jmm)/dshe + y5x=(yy55*(rx(jm,j)+rx(ipp,j))-yyy5a*rx(ipp,j) + $ -yyy5b*rx(jm,j))*yy5 + y5y=(yy55*(ry(jm,j)+ry(ipp,j))-yyy5a*ry(ipp,j) + $ -yyy5b*ry(jm,j))*yy5 + y5z=(yy55*(rz(jm,j)+rz(ipp,j))-yyy5a*rz(ipp,j) + $ -yyy5b*rz(jm,j))*yy5 + + sx=y11x+y3x+y4x+y5x + sy=y11y+y3y+y4y+y5y + sz=y11z+y3z+y4z+y5z + + sx1=y3x + sy1=y3y + sz1=y3z + sx2=y11x+y4x+y5x + sy2=y11y+y4y+y5y + sz2=y11z+y4z+y5z + + shefx(j,11)=shefx(j,11)-sx*vbetap(i,jmm) + $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) + shefy(j,11)=shefy(j,11)-sy*vbetap(i,jmm) + $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) + shefz(j,11)=shefz(j,11)-sz*vbetap(i,jmm) + $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) + +! shefx(j,11)=shefx(j,11) +! $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) +! shefy(j,11)=shefy(j,11) +! $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) +! shefz(j,11)=shefz(j,11) +! $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) + + yy6=-(dis(ip,j)-uldhb)/dldhb + y6x=rx(ip,j)/dis(ip,j) + y6y=ry(ip,j)/dis(ip,j) + y6z=rz(ip,j)/dis(ip,j) + y66x=yy6*y6x + y66y=yy6*y6y + y66z=yy6*y6z + + yy88=1.0D0/(dis(ip,j)*dis(ip,ipp)) + yyy8=pina1(i,jmm)/(dis(ip,j)**2) + yy8=-pina1(i,jmm)/dshe + y8x=(yy88*rx(ip,ipp)-yyy8*rx(ip,j))*yy8 + y8y=(yy88*ry(ip,ipp)-yyy8*ry(ip,j))*yy8 + y8z=(yy88*rz(ip,ipp)-yyy8*rz(ip,j))*yy8 + + yy99=1.0D0/(dis(ip,j)*dis(jm,j)) + yyy9a=pina2(i,jmm)/(dis(ip,j)**2) + yyy9b=pina2(i,jmm)/(dis(jm,j)**2) + yy9=-pina2(i,jmm)/dshe + y9x=(yy99*(rx(jm,j)+rx(ip,j))-yyy9a*rx(ip,j) + $ -yyy9b*rx(jm,j))*yy9 + y9y=(yy99*(ry(jm,j)+ry(ip,j))-yyy9a*ry(ip,j) + $ -yyy9b*ry(jm,j))*yy9 + y9z=(yy99*(rz(jm,j)+rz(ip,j))-yyy9a*rz(ip,j) + $ -yyy9b*rz(jm,j))*yy9 + + yy1010=1.0D0/(dis(jm,ipp)*dis(jm,j)) + yyy10=pina4(i,jmm)/(dis(jm,j)**2) + yy10=-pina4(i,jmm)/dshe + y10x=(yy1010*rx(jm,ipp)-yyy10*rx(jm,j))*yy10 + y10y=(yy1010*ry(jm,ipp)-yyy10*ry(jm,j))*yy10 + y10z=(yy1010*rz(jm,ipp)-yyy10*rz(jm,j))*yy10 + + sx=y66x+y8x+y9x+y10x + sy=y66y+y8y+y9y+y10y + sz=y66z+y8z+y9z+y10z + + sx1=y66x+y8x+y9x + sy1=y66y+y8y+y9y + sz1=y66z+y8z+y9z + sx2=y10x + sy2=y10y + sz2=y10z + + shefx(j,11)=shefx(j,11)-sx*vbetam(i,jmm) + $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) + shefy(j,11)=shefy(j,11)-sy*vbetam(i,jmm) + $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) + shefz(j,11)=shefz(j,11)-sz*vbetam(i,jmm) + $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) + +! shefx(j,11)=shefx(j,11) +! $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) +! shefy(j,11)=shefy(j,11) +! $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) +! shefz(j,11)=shefz(j,11) +! $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) + + endif +ci endif + + enddo + enddo + + return + end +c----------------------------------------------------------------------- + subroutine sheetforce12 + implicit none + integer maxca + parameter(maxca=800) + real*8 dfa_cutoff,dfa_cutoff_delta + parameter(dfa_cutoff=15.5d0) + parameter(dfa_cutoff_delta=0.5d0) +cc********************************************************************** + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12),shefy(maxca,12) + real*8 shefz(maxca,12) + real*8 dp45,dm45,w_beta + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect +cc********************************************************************** + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shef/ shefx,shefy,shefz +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m +cc********************************************************************** +C local variables + integer j,jm,jmm,ip,i,ipp,jp + real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z + real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z + real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y,y66z + real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z + real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy10a,yyy10b,yy6,yyy8 + real*8 e_gcont,fprim_gcont +!c*************************************************************************c + do j=6,inb-2 + jp=j+1 + jm=j-1 + do i=1,j-5 + + if (dis(i,jm).lt.dfa_cutoff) then + call gcont(dis(i,jm),dfa_cutoff-dfa_cutoff_delta,1.0D0, + & dfa_cutoff_delta,e_gcont,fprim_gcont) + + ip=i+1 + ipp=i+2 + +ci if(istrand(i,jm).eq.1 +ci & .and.(istrand_p(i,jm)+istrand_m(i,jm)).ge.1) then + + + yy1=-(dis(ip,j)-ulhb)/dlhb + y1x=rx(ip,j)/dis(ip,j) + y1y=ry(ip,j)/dis(ip,j) + y1z=rz(ip,j)/dis(ip,j) + y11x=y1x*yy1 + y11y=y1y*yy1 + y11z=y1z*yy1 + + yy33=1.0D0/(dis(ip,j)*dis(ip,ipp)) + yyy3=pin1(i,jm)/(dis(ip,j)**2) + yy3=-pin1(i,jm)/dshe + y3x=(yy33*rx(ip,ipp)-yyy3*rx(ip,j))*yy3 + y3y=(yy33*ry(ip,ipp)-yyy3*ry(ip,j))*yy3 + y3z=(yy33*rz(ip,ipp)-yyy3*rz(ip,j))*yy3 + yy44=1.0D0/(dis(ip,j)*dis(j,jp)) + + yyy4a=pin2(i,jm)/(dis(ip,j)**2) + yyy4b=pin2(i,jm)/(dis(j,jp)**2) + yy4=-pin2(i,jm)/dshe + y4x=(yy44*(rx(j,jp)-rx(ip,j))-yyy4a*rx(ip,j) + $ +yyy4b*rx(j,jp))*yy4 + y4y=(yy44*(ry(j,jp)-ry(ip,j))-yyy4a*ry(ip,j) + $ +yyy4b*ry(j,jp))*yy4 + y4z=(yy44*(rz(j,jp)-rz(ip,j))-yyy4a*rz(ip,j) + $ +yyy4b*rz(j,jp))*yy4 + + yy55=1.0D0/(dis(ipp,jp)*dis(j,jp)) + yyy5=pin4(i,jm)/(dis(j,jp)**2) + yy5=-pin4(i,jm)/dshe + y5x=(-yy55*rx(ipp,jp)+yyy5*rx(j,jp))*yy5 + y5y=(-yy55*ry(ipp,jp)+yyy5*ry(j,jp))*yy5 + y5z=(-yy55*rz(ipp,jp)+yyy5*rz(j,jp))*yy5 + + sx=y11x+y3x+y4x+y5x + sy=y11y+y3y+y4y+y5y + sz=y11z+y3z+y4z+y5z + + sx1=y11x+y3x+y4x + sy1=y11y+y3y+y4y + sz1=y11z+y3z+y4z + sx2=y5x + sy2=y5y + sz2=y5z + + shefx(j,12)=shefx(j,12)-sx*vbetap(i,jm) + $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) + shefy(j,12)=shefy(j,12)-sy*vbetap(i,jm) + $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) + shefz(j,12)=shefz(j,12)-sz*vbetap(i,jm) + $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) + +! shefx(j,12)=shefx(j,12) +! $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) +! shefy(j,12)=shefy(j,12) +! $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) +! shefz(j,12)=shefz(j,12) +! $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) + + yy6=-(dis(ipp,j)-uldhb)/dldhb + y6x=rx(ipp,j)/dis(ipp,j) + y6y=ry(ipp,j)/dis(ipp,j) + y6z=rz(ipp,j)/dis(ipp,j) + y66x=yy6*y6x + y66y=yy6*y6y + y66z=yy6*y6z + + yy88=1.0D0/(dis(ip,jp)*dis(j,jp)) + yyy8=pina2(i,jm)/(dis(j,jp)**2) + yy8=-pina2(i,jm)/dshe + y8x=(-yy88*rx(ip,jp)+yyy8*rx(j,jp))*yy8 + y8y=(-yy88*ry(ip,jp)+yyy8*ry(j,jp))*yy8 + y8z=(-yy88*rz(ip,jp)+yyy8*rz(j,jp))*yy8 + + yy99=1.0D0/(dis(j,ipp)*dis(ip,ipp)) + yyy9=pina3(i,jm)/(dis(j,ipp)**2) + yy9=-pina3(i,jm)/dshe + y9x=(-yy99*rx(ip,ipp)+yyy9*rx(j,ipp))*yy9 + y9y=(-yy99*ry(ip,ipp)+yyy9*ry(j,ipp))*yy9 + y9z=(-yy99*rz(ip,ipp)+yyy9*rz(j,ipp))*yy9 + + yy1010=1.0D0/(dis(j,ipp)*dis(j,jp)) + yyy10a=pina4(i,jm)/(dis(j,ipp)**2) + yyy10b=pina4(i,jm)/(dis(j,jp)**2) + yy10=-pina4(i,jm)/dshe + y10x=(-yy1010*(rx(j,ipp)+rx(j,jp))+yyy10a*rx(j,ipp) + $ +yyy10b*rx(j,jp))*yy10 + y10y=(-yy1010*(ry(j,ipp)+ry(j,jp))+yyy10a*ry(j,ipp) + $ +yyy10b*ry(j,jp))*yy10 + y10z=(-yy1010*(rz(j,ipp)+rz(j,jp))+yyy10a*rz(j,ipp) + $ +yyy10b*rz(j,jp))*yy10 + + sx=y66x+y8x+y9x+y10x + sy=y66y+y8y+y9y+y10y + sz=y66z+y8z+y9z+y10z + + sx1=y8x + sy1=y8y + sz1=y8z + sx2=y66x+y9x+y10x + sy2=y66y+y9y+y10y + sz2=y66z+y9z+y10z + + shefx(j,12)=shefx(j,12)-sx*vbetam(i,jm) + $ -sx1*vbetam1(i,jm)-sx2*vbetam2(i,jm) + shefy(j,12)=shefy(j,12)-sy*vbetam(i,jm) + $ -sy1*vbetam1(i,jm)-sy2*vbetam2(i,jm) + shefz(j,12)=shefz(j,12)-sz*vbetam(i,jm) + $ -sz1*vbetam1(i,jm)-sz2*vbetam2(i,jm) + + endif + +ci endif + + ENDDO + ENDDO + + RETURN + END +C=============================================================================== diff --git a/source/cluster/wham/src-HCD/energy_p_new.F b/source/cluster/wham/src-HCD/energy_p_new.F new file mode 100644 index 0000000..5cc851c --- /dev/null +++ b/source/cluster/wham/src-HCD/energy_p_new.F @@ -0,0 +1,10724 @@ + subroutine etotal(energia,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + +#ifndef ISNAN + external proc_proc +#endif +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif + + include 'COMMON.IOUNITS' + double precision energia(0:max_ene),energia1(0:max_ene+1) + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.SHIELD' + include 'COMMON.CONTROL' + include 'COMMON.TORCNSTR' + include 'COMMON.SAXS' + double precision fact(6) +c write(iout, '(a,i2)')'Calling etotal ipot=',ipot +c call flush(iout) +cd print *,'nnt=',nnt,' nct=',nct +C +C Compute the side-chain and electrostatic interaction energy +C + goto (101,102,103,104,105) ipot +C Lennard-Jones potential. + 101 call elj(evdw,evdw_t) +cd print '(a)','Exit ELJ' + goto 106 +C Lennard-Jones-Kihara potential (shifted). + 102 call eljk(evdw,evdw_t) + goto 106 +C Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp(evdw,evdw_t) + goto 106 +C Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb(evdw,evdw_t) + goto 106 +C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv(evdw,evdw_t) +C +C Calculate electrostatic (H-bonding) energy of the main chain. +C + 106 continue +c write (iout,*) "Sidechain" + call flush(iout) + call vec_and_deriv + if (shield_mode.eq.1) then + call set_shield_fac + else if (shield_mode.eq.2) then + call set_shield_fac2 + endif + call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) +c write(iout,*) 'po eelec' +c call flush(iout) + +C Calculate excluded-volume interaction energy between peptide groups +C and side chains. +C + call escp(evdw2,evdw2_14) +c +c Calculate the bond-stretching energy +c + + call ebond(estr) +C write (iout,*) "estr",estr +C +C Calculate the disulfide-bridge and other energy and the contributions +C from other distance constraints. +cd print *,'Calling EHPB' + call edis(ehpb) +cd print *,'EHPB exitted succesfully.' +C +C Calculate the virtual-bond-angle energy. +C +C print *,'Bend energy finished.' + if (wang.gt.0d0) then + if (tor_mode.eq.0) then + call ebend(ebe) + else +C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the +C energy function + call ebend_kcc(ebe) + endif + else + ebe=0.0d0 + endif + ethetacnstr=0.0d0 + if (with_theta_constr) call etheta_constr(ethetacnstr) +c call ebend(ebe,ethetacnstr) +cd print *,'Bend energy finished.' +C +C Calculate the SC local energy. +C + call esc(escloc) +C print *,'SCLOC energy finished.' +C +C Calculate the virtual-bond torsional energy. +C + if (wtor.gt.0.0d0) then + if (tor_mode.eq.0) then + call etor(etors,fact(1)) + else +C etor kcc is Kubo cumulant clustered rigorous attemp to derive the +C energy function + call etor_kcc(etors,fact(1)) + endif + else + etors=0.0d0 + endif + edihcnstr=0.0d0 + if (ndih_constr.gt.0) call etor_constr(edihcnstr) +c print *,"Processor",myrank," computed Utor" +C +C 6/23/01 Calculate double-torsional energy +C + if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then + call etor_d(etors_d,fact(2)) + else + etors_d=0 + endif +c print *,"Processor",myrank," computed Utord" +C + if (wsccor.gt.0.0d0) then + call eback_sc_corr(esccor) + else + esccor=0.0d0 + endif + + if (wliptran.gt.0) then + call Eliptransfer(eliptran) + else + eliptran=0.0d0 + endif +#ifdef FOURBODY +C +C 12/1/95 Multi-body terms +C + n_corr=0 + n_corr1=0 + if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 + & .or. wturn6.gt.0.0d0) then +c write(iout,*)"calling multibody_eello" + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +c write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1 +c write (iout,*) ecorr,ecorr5,ecorr6,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) then +c write (iout,*) "Calling multibody_hbond" + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) + endif +#endif +c write (iout,*) "NSAXS",nsaxs + if (nsaxs.gt.0 .and. saxs_mode.eq.0) then + call e_saxs(Esaxs_constr) +c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr + else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then + call e_saxsC(Esaxs_constr) +c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr + else + Esaxs_constr = 0.0d0 + endif +c write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t + if (constr_homology.ge.1) then + call e_modeller(ehomology_constr) + else + ehomology_constr=0.0d0 + endif + +c write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr +#ifdef DFA +C BARTEK for dfa test! + if (wdfa_dist.gt.0) call edfad(edfadis) +c write(iout,*)'edfad is finished!', wdfa_dist,edfadis + if (wdfa_tor.gt.0) call edfat(edfator) +c write(iout,*)'edfat is finished!', wdfa_tor,edfator + if (wdfa_nei.gt.0) call edfan(edfanei) +c write(iout,*)'edfan is finished!', wdfa_nei,edfanei + if (wdfa_beta.gt.0) call edfab(edfabet) +c write(iout,*)'edfab is finished!', wdfa_beta,edfabet +#endif + +#ifdef SPLITELE + if (shield_mode.gt.0) then + etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2 + & +welec*fact(1)*ees + & +fact(1)*wvdwpp*evdw1 + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb + & +wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6 + & +wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet + else + etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees + & +wvdwpp*evdw1 + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet + endif +#else + if (shield_mode.gt.0) then + etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2 + & +welec*fact(1)*(ees+evdw1) + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet + else + etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2 + & +welec*fact(1)*(ees+evdw1) + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet + endif +#endif + energia(0)=etot + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(17)=evdw2_14 +#else + energia(2)=evdw2 + energia(17)=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(18)=estr + energia(19)=esccor + energia(20)=edihcnstr + energia(21)=evdw_t + energia(22)=eliptran + energia(24)=ethetacnstr + energia(26)=esaxs_constr + energia(27)=ehomology_constr + energia(28)=edfadis + energia(29)=edfator + energia(30)=edfanei + energia(31)=edfabet +c detecting NaNQ +#ifdef ISNAN +#ifdef AIX + if (isnan(etot).ne.0) energia(0)=1.0d+99 +#else + if (isnan(etot)) energia(0)=1.0d+99 +#endif +#else + i=0 +#ifdef WINPGI + idumm=proc_proc(etot,i) +#else + call proc_proc(etot,i) +#endif + if(i.eq.1)energia(0)=1.0d+99 +#endif +#ifdef MPL +c endif +#endif +#ifdef DEBUG + call enerprint(energia,fact) +#endif + if (calc_grad) then +C +C Sum up the components of the Cartesian gradient. +C +#ifdef SPLITELE + do i=1,nct + do j=1,3 + if (shield_mode.eq.0) then + gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+ + & wbond*gradb(j,i)+ + & wstrain*ghpbc(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(j,i) + 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*fact(2)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + else + gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i) + & +fact(1)*wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+ + & wbond*gradb(j,i)+ + & wstrain*ghpbc(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) + & +welec*gshieldc(j,i) + & +welec*gshieldc_loc(j,i) + & +wcorr*gshieldc_ec(j,i) + & +wcorr*gshieldc_loc_ec(j,i) + & +wturn3*gshieldc_t3(j,i) + & +wturn3*gshieldc_loc_t3(j,i) + & +wturn4*gshieldc_t4(j,i) + & +wturn4*gshieldc_loc_t4(j,i) + & +wel_loc*gshieldc_ll(j,i) + & +wel_loc*gshieldc_loc_ll(j,i)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(j,i) + gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i) + & +fact(1)*wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*fact(2)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + & +welec*gshieldx(j,i) + & +wcorr*gshieldx_ec(j,i) + & +wturn3*gshieldx_t3(j,i) + & +wturn4*gshieldx_t4(j,i) + & +wel_loc*gshieldx_ll(j,i) + + + endif + enddo +#else + do i=1,nct + do j=1,3 + if (shield_mode.eq.0) then + gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+ + & wbond*gradb(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(j,i) + 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*fact(1)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + else + gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+ + & fact(1)*wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+ + & wbond*gradb(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) + & +welec*gshieldc(j,i) + & +welec*gshieldc_loc(j,i) + & +wcorr*gshieldc_ec(j,i) + & +wcorr*gshieldc_loc_ec(j,i) + & +wturn3*gshieldc_t3(j,i) + & +wturn3*gshieldc_loc_t3(j,i) + & +wturn4*gshieldc_t4(j,i) + & +wturn4*gshieldc_loc_t4(j,i) + & +wel_loc*gshieldc_ll(j,i) + & +wel_loc*gshieldc_loc_ll(j,i)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(j,i) + gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+ + & fact(1)*wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*fact(1)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + & +welec*gshieldx(j,i) + & +wcorr*gshieldx_ec(j,i) + & +wturn3*gshieldx_t3(j,i) + & +wturn4*gshieldx_t4(j,i) + & +wel_loc*gshieldx_ll(j,i) + endif + enddo +#endif + enddo + + + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i) + & +wcorr5*fact(4)*g_corr5_loc(i) + & +wcorr6*fact(5)*g_corr6_loc(i) + & +wturn4*fact(3)*gel_loc_turn4(i) + & +wturn3*fact(2)*gel_loc_turn3(i) + & +wturn6*fact(5)*gel_loc_turn6(i) + & +wel_loc*fact(2)*gel_loc_loc(i) +c & +wsccor*fact(1)*gsccor_loc(i) +c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA + enddo + endif + if (dyn_ss) call dyn_set_nss + return + end +C------------------------------------------------------------------------ + subroutine enerprint(energia,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + double precision energia(0:max_ene),fact(6) + etot=energia(0) + evdw=energia(1)+fact(6)*energia(21) +#ifdef SCP14 + evdw2=energia(2)+energia(17) +#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) + esccor=energia(19) + edihcnstr=energia(20) + estr=energia(18) + ethetacnstr=energia(24) + eliptran=energia(22) + esaxs=energia(26) + ehomology_constr=energia(27) +C Bartek + edfadis = energia(28) + edfator = energia(29) + edfanei = energia(30) + edfabet = energia(31) +#ifdef SPLITELE + write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp, + & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1), + & etors_d,wtor_d*fact(2),ehpb,wstrain, +#ifdef FOURBODY + & ecorr,wcorr*fact(3), + & ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), +#endif + & eel_loc, + & wel_loc*fact(2),eello_turn3,wturn3*fact(2), + & eello_turn4,wturn4*fact(3), +#ifdef FOURBODY + & eello_turn6,wturn6*fact(5), +#endif + & esccor,wsccor*fact(1),edihcnstr, + & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, + & etube,wtube,esaxs,wsaxs,ehomology_constr, + & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, + & edfabet,wdfa_beta, + & etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ + & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, + & ' (SS bridges & dist. cnstr.)'/ +#ifdef FOURBODY + & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif + & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY + & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ + & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/ + & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/ + & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/ + & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/ + & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ + & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/ + & 'ETOT= ',1pE16.6,' (total)') + +#else + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1), + & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1), + & etors_d,wtor_d*fact(2),ehpb, +#ifdef FOURBODY + & wstrain,ecorr,wcorr*fact(3), + & ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), +#endif + & eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2), + & eello_turn4,wturn4*fact(3), +#ifdef FOURBODY + & eello_turn6,wturn6*fact(5), +#endif + & esccor,wsccor*fact(1),edihcnstr, + & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, + & etube,wtube,esaxs,wsaxs,ehomology_constr, + & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, + & edfabet,wdfa_beta, + & etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, + & ' (SS bridges & dist. restr.)'/ +#ifdef FOURBODY + & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif + & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY + & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ + & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/ + & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/ + & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/ + & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/ + & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ + & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/ + & 'ETOT= ',1pE16.6,' (total)') +#endif + return + end +C----------------------------------------------------------------------- + subroutine elj(evdw,evdw_t) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJ potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include "DIMENSIONS.COMPAR" + 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' +#ifdef FOURBODY + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + dimension gg(3) + integer icant + external icant +cd print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon +c ROZNICA z cluster +c do i=1,210 +c do j=1,2 +c eneps_temp(j,i)=0.0d0 +c enddo +c enddo +cROZNICA + + evdw=0.0D0 + evdw_t=0.0d0 + 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) +C Change 12/1/95 + num_conti=0 +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) +cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +cd & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=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 +C Change 12/1/95 to calculate four-body interactions + rij=xj*xj+yj*yj+zj*zj + rrij=1.0D0/rij + sqrij=dsqrt(rij) + sss1=sscale(sqrij) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(sqrij) +c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 + e1=fac*fac*aa + e2=fac*bb + evdwij=e1+e2 + ij=icant(itypi,itypj) +c ROZNICA z cluster +c eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij) +c eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij +c + +cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), +cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, +cd & (c(k,i),k=1,3),(c(k,j),k=1,3) + if (bb.gt.0.0d0) then + evdw=evdw+sss1*evdwij + else + evdw_t=evdw_t+sss1*evdwij + endif + if (calc_grad) then +C +C Calculate the components of the gradient in DC and X +C + fac=-rrij*(e1+evdwij)*sss1 + & +evdwij*sssgrad1/sqrij/expon + 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) + enddo + do k=i,j-1 + do l=1,3 + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo + enddo + endif +#ifdef FOURBODY +C +C 12/1/95, revised on 5/20/97 +C +C Calculate the contact function. The ith column of the array JCONT will +C contain the numbers of atoms that make contacts with the atom I (of numbers +C greater than I). The arrays FACONT and GACONT will contain the values of +C the contact function and its derivative. +C +C Uncomment next line, if the correlation interactions include EVDW explicitly. +c if (j.gt.i+1 .and. evdwij.le.0.0D0) then +C Uncomment next line, if the correlation interactions are contact function only + if (j.gt.i+1.and. eps0ij.gt.0.0D0) then + rij=dsqrt(rij) + sigij=sigma(itypi,itypj) + r0ij=rs0(itypi,itypj) +C +C Check whether the SC's are not too far to make a contact. +C + rcut=1.5d0*r0ij + call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) +C Add a new contact, if the SC's are close enough, but not too close (ri' + do k=1,3 + ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) + enddo + endif + do k=1,3 + gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) + enddo + kstart=min0(i+1,j) + kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) + do k=kstart,kend + do l=1,3 + gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) + enddo + enddo + endif ! calc_grad + enddo + enddo ! iint + 1225 continue + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time the factor EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C-------------------------------------------------------------------------- + subroutine edis(ehpb) +C +C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + dimension ggg(3),ggg_peak(3,1000) + ehpb=0.0D0 + ggg=0.0d0 +c 8/21/18 AL: added explicit restraints on reference coords +c write (iout,*) "restr_on_coord",restr_on_coord + if (restr_on_coord) then + + do i=nnt,nct + ecoor=0.0d0 + if (itype(i).eq.ntyp1) cycle + do j=1,3 + ecoor=ecoor+(c(j,i)-cref(j,i))**2 + ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i)) + enddo + if (itype(i).ne.10) then + do j=1,3 + ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2 + ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres)) + enddo + endif + if (energy_dec) write (iout,*) + & "i",i," bfac",bfac(i)," ecoor",ecoor + ehpb=ehpb+0.5d0*bfac(i)*ecoor + enddo + + endif +C write (iout,*) ,"link_end",link_end,constr_dist +cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr +c write(iout,*)'link_start=',link_start,' link_end=',link_end, +c & " constr_dist",constr_dist + if (link_end.eq.0.and.link_end_peak.eq.0) return + do i=link_start_peak,link_end_peak + ehpb_peak=0.0d0 +c print *,"i",i," link_end_peak",link_end_peak," ipeak", +c & ipeak(1,i),ipeak(2,i) + do ip=ipeak(1,i),ipeak(2,i) + ii=ihpb_peak(ip) + jj=jhpb_peak(ip) + dd=dist(ii,jj) + iip=ip-ipeak(1,i)+1 +C iii and jjj point to the residues for which the distance is assigned. +c if (ii.gt.nres) then +c iii=ii-nres +c jjj=jj-nres +c else +c iii=ii +c jjj=jj +c endif + if (ii.gt.nres) then + iii=ii-nres + else + iii=ii + endif + if (jj.gt.nres) then + jjj=jj-nres + else + jjj=jj + endif + aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip)) + aux=dexp(-scal_peak*aux) + ehpb_peak=ehpb_peak+aux + fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip), + & forcon_peak(ip))*aux/dd + do j=1,3 + ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii)) + enddo + if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)') + & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip), + & forcon_peak(ip),fordepth_peak(ip),ehpb_peak + enddo +c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak + ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak + do ip=ipeak(1,i),ipeak(2,i) + iip=ip-ipeak(1,i)+1 + do j=1,3 + ggg(j)=ggg_peak(j,iip)/ehpb_peak + enddo + ii=ihpb_peak(ip) + jj=jhpb_peak(ip) +C iii and jjj point to the residues for which the distance is assigned. +c if (ii.gt.nres) then +c iii=ii-nres +c jjj=jj-nres +c else +c iii=ii +c jjj=jj +c endif + if (ii.gt.nres) then + iii=ii-nres + else + iii=ii + endif + if (jj.gt.nres) then + jjj=jj-nres + else + jjj=jj + endif + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + enddo + endif + if (jjj.lt.jj) then + do j=1,3 + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + enddo + enddo + do i=link_start,link_end +C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a +C CA-CA distance used in regularization of structure. + ii=ihpb(i) + jj=jhpb(i) +C iii and jjj point to the residues for which the distance is assigned. +c if (ii.gt.nres) then +c iii=ii-nres +c jjj=jj-nres +c else +c iii=ii +c jjj=jj +c endif + if (ii.gt.nres) then + iii=ii-nres + else + iii=ii + endif + if (jj.gt.nres) then + jjj=jj-nres + else + jjj=jj + endif +c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, +c & dhpb(i),dhpb1(i),forcon(i) +C 24/11/03 AL: SS bridges handled separately because of introducing a specific +C distance and angle dependent SS bond potential. +C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. +C & iabs(itype(jjj)).eq.1) then +cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then +C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds + if (.not.dyn_ss .and. i.le.nss) then +C 15/02/13 CC dynamic SSbond - additional check + if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. + & iabs(itype(jjj)).eq.1) then + call ssbond_ene(iii,jjj,eij) + ehpb=ehpb+2*eij + endif +cd write (iout,*) "eij",eij +cd & ' waga=',waga,' fac=',fac +! else if (ii.gt.nres .and. jj.gt.nres) then + else +C Calculate the distance between the two points and its difference from the +C target distance. + dd=dist(ii,jj) + if (irestr_type(i).eq.11) then + ehpb=ehpb+fordepth(i)!**4.0d0 + & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + fac=fordepth(i)!**4.0d0 + & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd + if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)') + & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i), + & ehpb,irestr_type(i) + else if (irestr_type(i).eq.10) then +c AL 6//19/2018 cross-link restraints + xdis = 0.5d0*(dd/forcon(i))**2 + expdis = dexp(-xdis) +c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i) + aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i) +c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux, +c & " wboltzd",wboltzd + ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux) +c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i)) + fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i)) + & *expdis/(aux*forcon(i)**2) + if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)') + & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i), + & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i) + else if (irestr_type(i).eq.2) then +c Quartic restraints + ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)') + & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i), + & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd + else +c Quadratic restraints + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+0.5d0*waga*rdis*rdis + if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)') + & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i), + & 0.5d0*waga*rdis*rdis,irestr_type(i) +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif +c Calculate Cartesian gradient + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC distance, we need to calculate the contributions to the +C Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + enddo + endif + if (jjj.lt.jj) then + do j=1,3 + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + endif + enddo + return + end +C-------------------------------------------------------------------------- + subroutine ssbond_ene(i,j,eij) +C +C Calculate the distance and angle dependent SS-bond potential energy +C using a free-energy function derived based on RHF/6-31G** ab initio +C calculations of diethyl disulfide. +C +C A. Liwo and U. Kozlowska, 11/24/03 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + double precision erij(3),dcosom1(3),dcosom2(3),gg(3) + itypi=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) + itypj=iabs(itype(j)) + dscj_inv=dsc_inv(itypj) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + rij=1.0d0/rij + deltad=rij-d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) + & +akct*deltad*deltat12 + & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi +c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, +c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, +c & " deltat12",deltat12," eij",eij + ed=2*akcm*deltad+akct*deltat12 + pom1=akct*deltad + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + do k=1,3 + gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo + do k=1,3 + ghpbx(k,i)=ghpbx(k,i)-gg(k) + & +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv + ghpbx(k,j)=ghpbx(k,j)+gg(k) + & +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv + enddo +C +C Calculate the components of the gradient in DC and X +C + do k=i,j-1 + do l=1,3 + ghpbc(l,k)=ghpbc(l,k)+gg(l) + enddo + enddo + return + end +C-------------------------------------------------------------------------- + subroutine ebond(estr) +c +c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + double precision u(3),ud(3) + estr=0.0d0 + estr1=0.0d0 +c write (iout,*) "distchainmax",distchainmax + do i=nnt+1,nct + if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle +C estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) +C do j=1,3 +C gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) +C & *dc(j,i-1)/vbld(i) +C enddo +C if (energy_dec) write(iout,*) +C & "estr1",i,vbld(i),distchainmax, +C & gnmr1(vbld(i),-1.0d0,distchainmax) +C else + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then + diff = vbld(i)-vbldpDUM +C write(iout,*) i,diff + else + diff = vbld(i)-vbldp0 +c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff + endif + estr=estr+diff*diff + do j=1,3 + gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) + enddo +C endif +C write (iout,'(a7,i5,4f7.3)') +C & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff + enddo + estr=0.5d0*AKP*estr+estr1 +c +c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included +c + do i=nnt,nct + 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) +C write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, +C & AKSC(1,iti),AKSC(1,iti)*diff*diff + estr=estr+0.5d0*AKSC(1,iti)*diff*diff + do j=1,3 + gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) + enddo + else + do j=1,nbi + diff=vbld(i+nres)-vbldsc0(j,iti) + ud(j)=aksc(j,iti)*diff + u(j)=abond0(j,iti)+0.5d0*ud(j)*diff + enddo + uprod=u(1) + do j=2,nbi + uprod=uprod*u(j) + enddo + usum=0.0d0 + usumsqder=0.0d0 + do j=1,nbi + uprod1=1.0d0 + uprod2=1.0d0 + do k=1,nbi + if (k.ne.j) then + uprod1=uprod1*u(k) + uprod2=uprod2*u(k)*u(k) + endif + enddo + usum=usum+uprod1 + usumsqder=usumsqder+ud(j)*uprod2 + enddo +c write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti), +c & AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi) + estr=estr+uprod/usum + do j=1,3 + gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) + enddo + endif + endif + enddo + return + end +#ifdef CRYST_THETA +C-------------------------------------------------------------------------- + subroutine ebend(etheta,ethetacnstr) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + double precision y(2),z(2) + delta=0.02d0*pi +c time11=dexp(-2*time) +c time12=1.0d0 + etheta=0.0D0 +c write (iout,*) "nres",nres +c write (*,'(a,i2)') 'EBEND ICG=',icg +c write (iout,*) ithet_start,ithet_end + do i=ithet_start,ithet_end +C if (itype(i-1).eq.ntyp1) cycle + if (i.le.2) cycle + if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle +C Zero the energy function and its derivative at 0 or pi. + call splinthet(theta(i),0.5d0*delta,ss,ssd) + it=itype(i-1) + 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.eq.3) then + y(1)=0.0D0 + y(2)=0.0D0 + else + + if (i.gt.3 .and. itype(i-3).ne.ntyp1) then +#ifdef OSF + phii=phi(i) +c icrc=0 +c call proc_proc(phii,icrc) + if (icrc.eq.1) 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 + endif + if (i.lt.nres .and. itype(i+1).ne.ntyp1) then +#ifdef OSF + phii1=phi(i+1) +c icrc=0 +c call proc_proc(phii1,icrc) + if (icrc.eq.1) phii1=150.0 + phii1=pinorm(phii1) + z(1)=cos(phii1) +#else + phii1=phi(i+1) + z(1)=dcos(phii1) +#endif + z(2)=dsin(phii1) + else + z(1)=0.0D0 + z(2)=0.0D0 + endif +C Calculate the "mean" value of theta from the part of the distribution +C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). +C In following comments this theta will be referred to as t_c. + thet_pred_mean=0.0d0 + do k=1,2 + athetk=athet(k,it,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 +c write (iout,*) "thet_pred_mean",thet_pred_mean + dthett=thet_pred_mean*ssd + thet_pred_mean=thet_pred_mean*ss+a0thet(it) +c write (iout,*) "thet_pred_mean",thet_pred_mean +C 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 +c write (iout,'(a6,i5,0pf7.3,f7.3,i5)') +c & 'ebend',i,ethetai,theta(i),itype(i) +c write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i), +c & rad2deg*phii,rad2deg*phii1,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) +c 1215 continue + enddo + ethetacnstr=0.0d0 +C print *,ithetaconstr_start,ithetaconstr_end,"TU" + do i=1,ntheta_constr + itheta=itheta_constr(i) + thetiii=theta(itheta) + difi=pinorm(thetiii-theta_constr0(i)) + if (difi.gt.theta_drange(i)) then + difi=difi-theta_drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else + difi=0.0 + endif +C if (energy_dec) then +C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", +C & i,itheta,rad2deg*thetiii, +C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), +C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, +C & gloc(itheta+nphi-2,icg) +C endif + enddo +C Ufff.... We've done all this!!! + return + end +C--------------------------------------------------------------------------- + subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, + & E_tc) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it +C Calculate the contributions to both Gaussian lobes. +C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) +C The "polynomial part" of the "standard deviation" of this part of +C the distribution. + sig=polthet(3,it) + do j=2,0,-1 + sig=sig*thet_pred_mean+polthet(j,it) + enddo +C Derivative of the "interior part" of the "standard deviation of the" +C gamma-dependent Gaussian lobe in t_c. + sigtc=3*polthet(3,it) + do j=2,1,-1 + sigtc=sigtc*thet_pred_mean+j*polthet(j,it) + enddo + sigtc=sig*sigtc +C Set the parameters of both Gaussian lobes of the distribution. +C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) + fac=sig*sig+sigc0(it) + sigcsq=fac+fac + sigc=1.0D0/sigcsq +C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c + sigsqtc=-4.0D0*sigcsq*sigtc +c print *,i,sig,sigtc,sigsqtc +C Following variable (sigtc) is d[sigma(t_c)]/dt_c + sigtc=-sigtc/(fac*fac) +C Following variable is sigma(t_c)**(-2) + sigcsq=sigcsq*sigcsq + sig0i=sig0(it) + sig0inv=1.0D0/sig0i**2 + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i + term1=-0.5D0*sigcsq*delthec*delthec + term2=-0.5D0*sig0inv*delthe0*delthe0 +C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and +C NaNs in taking the logarithm. We extract the largest exponent which is added +C to the energy (this being the log of the distribution) at the end of energy +C term evaluation for this virtual-bond angle. + if (term1.gt.term2) then + termm=term1 + term2=dexp(term2-termm) + term1=1.0d0 + else + termm=term2 + term1=dexp(term1-termm) + term2=1.0d0 + endif +C The ratio between the gamma-independent and gamma-dependent lobes of +C the distribution is a Gaussian function of thet_pred_mean too. + diffak=gthet(2,it)-thet_pred_mean + ratak=diffak/gthet(3,it)**2 + ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) +C Let's differentiate it in thet_pred_mean NOW. + aktc=ak*ratak +C Now put together the distribution terms to make complete distribution. + termexp=term1+ak*term2 + termpre=sigc+ak*sig0i +C Contribution of the bending energy from this theta is just the -log of +C the sum of the contributions from the two lobes and the pre-exponential +C factor. Simple enough, isn't it? + ethetai=(-dlog(termexp)-termm+dlog(termpre)) +C NOW the derivatives!!! +C 6/6/97 Take into account the deformation. + E_theta=(delthec*sigcsq*term1 + & +ak*delthe0*sig0inv*term2)/termexp + E_tc=((sigtc+aktc*sig0i)/termpre + & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ + & aktc*term2)/termexp) + return + end +c----------------------------------------------------------------------------- + subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i +C "Thank you" to MAPLE (probably spared one day of hand-differentiation). + t3 = thetai-thet_pred_mean + t6 = t3**2 + t9 = term1 + t12 = t3*sigcsq + t14 = t12+t6*sigsqtc + t16 = 1.0d0 + t21 = thetai-theta0i + t23 = t21**2 + t26 = term2 + t27 = t21*t26 + t32 = termexp + t40 = t32**2 + E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 + & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 + & *(-t12*t9-ak*sig0inv*t27) + return + end +#else +C-------------------------------------------------------------------------- + subroutine ebend(etheta) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C ab initio-derived potentials from +c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.TORCNSTR' + double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), + & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), + & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), + & sinph1ph2(maxdouble,maxdouble) + logical lprn /.false./, lprn1 /.false./ + etheta=0.0D0 +c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) + do i=ithet_start,ithet_end +C if (i.eq.2) cycle +C if (itype(i-1).eq.ntyp1) cycle + if (i.le.2) cycle + if ((itype(i-1).eq.ntyp1).or.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 +cu if (i.eq.3) then +cu phii=0.0d0 +cu ityp1=nthetyp+1 +cu do k=1,nsingle +cu cosph1(k)=0.0d0 +cu sinph1(k)=0.0d0 +cu enddo +cu else + if (i.gt.3 .and. itype(i-3).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))) + do k=1,nsingle + cosph1(k)=dcos(k*phii) + sinph1(k)=dsin(k*phii) + enddo + else + phii=0.0d0 +c ityp1=nthetyp+1 + do k=1,nsingle + ityp1=ithetyp((itype(i-2))) + 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 +c ityp3=nthetyp+1 + ityp3=ithetyp((itype(i))) + do k=1,nsingle + cosph2(k)=0.0d0 + sinph2(k)=0.0d0 + enddo + endif +c write (iout,*) "i",i," ityp1",itype(i-2),ityp1, +c & " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3 +c call flush(iout) + 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 + if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') + & i,theta(i)*rad2deg,phii*rad2deg, + & phii1*rad2deg,ethetai + etheta=etheta+ethetai + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 +c gloc(nphi+i-2,icg)=wang*dethetai + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai + enddo + return + end +#endif +#ifdef CRYST_SC +c----------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), + & ddersc0(3),ddummy(3),xtemp(3),temp(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 +C write (iout,*) '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)) +c print *,'i=',i,' it=',it,' nlobit=',nlobit +C write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad + theti=theta(i+1)-pipol + x(1)=dtan(theti) + x(2)=alph(i) + x(3)=omeg(i) +c write (iout,*) "i",i," x",x(1),x(2),x(3) + + 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 +c escloci=esclocbi +c write (iout,*) escloci + else if (x(2).lt.delta) then + xtemp(1)=x(1) + xtemp(2)=delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=0.0d0 + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=0.0d0 + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + call splinthet(x(2),0.5d0*delta,ss,ssd) + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +C write (iout,*) 'i=',i, escloci + else + call enesc(x,escloci,dersc,ddummy,.false.) + endif + + escloc=escloc+escloci +C write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc + write (iout,'(a6,i5,0pf7.3)') + & 'escloc',i,escloci + + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ + & wscloc*dersc(1) + gloc(ialph(i,1),icg)=wscloc*dersc(2) + gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) + 1 continue + enddo + return + end +C--------------------------------------------------------------------------- + subroutine enesc(x,escloci,dersc,ddersc,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) + double precision contr(maxlob,-1:1) + logical mixed +c write (iout,*) 'it=',it,' nlobit=',nlobit + escloc_i=0.0D0 + do j=1,3 + dersc(j)=0.0D0 + if (mixed) ddersc(j)=0.0d0 + enddo + x3=x(3) + +C Because of periodicity of the dependence of the SC energy in omega we have +C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). +C To avoid underflows, first compute & store the exponents. + + do iii=-1,1 + + x(3)=x3+iii*dwapi + + do j=1,nlobit + do k=1,3 + z(k)=x(k)-censc(k,j,it) + enddo + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j,iii)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j,iii)*z(k) + enddo + contr(j,iii)=expfac + enddo ! j + + enddo ! iii + + x(3)=x3 +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1,-1) + do iii=-1,1 + do j=1,nlobit + if (emin.gt.contr(j,iii)) emin=contr(j,iii) + enddo + enddo + emin=0.5D0*emin +cd print *,'it=',it,' emin=',emin + +C Compute the contribution to SC energy and derivatives + do iii=-1,1 + + do j=1,nlobit + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) +cd print *,'j=',j,' expfac=',expfac + escloc_i=escloc_i+expfac + do k=1,3 + dersc(k)=dersc(k)+Ax(k,j,iii)*expfac + enddo + if (mixed) then + do k=1,3,2 + ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) + & +gaussc(k,2,j,it))*expfac + enddo + endif + enddo + + enddo ! iii + + dersc(1)=dersc(1)/cos(theti)**2 + ddersc(1)=ddersc(1)/cos(theti)**2 + ddersc(3)=ddersc(3) + + escloci=-(dlog(escloc_i)-emin) + do j=1,3 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) then + do j=1,3,2 + ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) + enddo + endif + return + end +C------------------------------------------------------------------------------ + subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob),dersc(3) + double precision contr(maxlob) + logical mixed + + escloc_i=0.0D0 + + do j=1,3 + dersc(j)=0.0D0 + enddo + + do j=1,nlobit + do k=1,2 + z(k)=x(k)-censc(k,j,it) + enddo + z(3)=dwapi + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j)*z(k) + enddo + contr(j)=expfac + enddo ! j + +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1) + do j=1,nlobit + if (emin.gt.contr(j)) emin=contr(j) + enddo + emin=0.5D0*emin + +C Compute the contribution to SC energy and derivatives + + dersc12=0.0d0 + do j=1,nlobit + expfac=dexp(bsc(j,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 +#else +c---------------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA derived from AM1 all-atom calculations. +C added by Urszula Kozlowska. 07/11/2007 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.SCROT' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.VECTORS' + double precision x_prime(3),y_prime(3),z_prime(3) + & , sumene,dsc_i,dp2_i,x(65), + & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, + & de_dxx,de_dyy,de_dzz,de_dt + double precision s1_t,s1_6_t,s2_t,s2_6_t + double precision + & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), + & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), + & dt_dCi(3),dt_dCi1(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 + do i=loc_start,loc_end + 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 +c +C Compute the axes of tghe local cartesian coordinates system; store in +c x_prime, y_prime and z_prime +c + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo +C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), +C & dc_norm(3,i+nres) + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo + do j = 1,3 + z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i))) + enddo +c write (2,*) "i",i +c write (2,*) "x_prime",(x_prime(j),j=1,3) +c write (2,*) "y_prime",(y_prime(j),j=1,3) +c write (2,*) "z_prime",(z_prime(j),j=1,3) +c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), +c & " xy",scalar(x_prime(1),y_prime(1)), +c & " xz",scalar(x_prime(1),z_prime(1)), +c & " yy",scalar(y_prime(1),y_prime(1)), +c & " yz",scalar(y_prime(1),z_prime(1)), +c & " zz",scalar(z_prime(1),z_prime(1)) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxtab(i)=xx + yytab(i)=yy + zztab(i)=zz +C +C Compute the energy of the ith side cbain +C +c write (2,*) "xx",xx," yy",yy," zz",zz + it=iabs(itype(i)) + do j = 1,65 + x(j) = sc_parmin(j,it) + enddo +#ifdef CHECK_COORD +Cc diagnostics - remove later + xx1 = dcos(alph(2)) + yy1 = dsin(alph(2))*dcos(omeg(2)) + zz1 = -dsign(1.0d0,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 +C," --- ", xx_w,yy_w,zz_w +c end diagnostics +#endif + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 + & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy + & + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 + & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy + & + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 + & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy + & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 + & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx + & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy + & +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 + & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy + & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 + & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx + & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy + & +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) + & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) +c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, +c & sumene4, +c & dscp1,dscp2,sumene +c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + escloc = escloc + sumene +c write (2,*) "escloc",escloc +c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i), +c & zz,xx,yy + if (.not. calc_grad) goto 1 +#ifdef DEBUG +C +C This section to check the numerical derivatives of the energy of ith side +C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert +C #define DEBUG in the code to turn it on. +C + write (2,*) "sumene =",sumene + aincr=1.0d-7 + xxsave=xx + xx=xx+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dxx_num=(sumenep-sumene)/aincr + xx=xxsave + write (2,*) "xx+ sumene from enesc=",sumenep + yysave=yy + yy=yy+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dyy_num=(sumenep-sumene)/aincr + yy=yysave + write (2,*) "yy+ sumene from enesc=",sumenep + zzsave=zz + zz=zz+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dzz_num=(sumenep-sumene)/aincr + zz=zzsave + write (2,*) "zz+ sumene from enesc=",sumenep + costsave=cost2tab(i+1) + sintsave=sint2tab(i+1) + cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) + sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dt_num=(sumenep-sumene)/aincr + write (2,*) " t+ sumene from enesc=",sumenep + cost2tab(i+1)=costsave + sint2tab(i+1)=sintsave +C End of diagnostics section. +#endif +C +C Compute the gradient of esc +C + pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 + pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 + pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 + pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 + pom_dx=dsc_i*dp2_i*cost2tab(i+1) + pom_dy=dsc_i*dp2_i*sint2tab(i+1) + pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) + pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) + pom1=(sumene3*sint2tab(i+1)+sumene1) + & *(pom_s1/dscp1+pom_s16*dscp1**4) + pom2=(sumene4*cost2tab(i+1)+sumene2) + & *(pom_s2/dscp2+pom_s26*dscp2**4) + sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy + sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 + & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) + & +x(40)*yy*zz + sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy + sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 + & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) + & +x(60)*yy*zz + de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) + & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) + & +(pom1+pom2)*pom_dx +#ifdef DEBUG + write(2,*), "de_dxx = ", de_dxx,de_dxx_num +#endif +C + sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz + sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 + & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) + & +x(40)*xx*zz + sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz + sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz + & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz + & +x(59)*zz**2 +x(60)*xx*zz + de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) + & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) + & +(pom1-pom2)*pom_dy +#ifdef DEBUG + write(2,*), "de_dyy = ", de_dyy,de_dyy_num +#endif +C + de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy + & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx + & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) + & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) + & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 + & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy + & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) + & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) +#ifdef DEBUG + write(2,*), "de_dzz = ", de_dzz,de_dzz_num +#endif +C + de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) + & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) + & +pom1*pom_dt1+pom2*pom_dt2 +#ifdef DEBUG + write(2,*), "de_dt = ", de_dt,de_dt_num +#endif +c +C + cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) + cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) + cosfac2xx=cosfac2*xx + sinfac2yy=sinfac2*yy + do k = 1,3 + dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* + & vbld_inv(i+1) + dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* + & vbld_inv(i) + pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) + pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) +c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, +c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) +c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), +c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) + dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx + dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx + dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy + dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy + dZZ_Ci1(k)=0.0d0 + dZZ_Ci(k)=0.0d0 + do j=1,3 + dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) + & *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)) +c + dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) + dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) + enddo + + do k=1,3 + dXX_Ctab(k,i)=dXX_Ci(k) + dXX_C1tab(k,i)=dXX_Ci1(k) + dYY_Ctab(k,i)=dYY_Ci(k) + dYY_C1tab(k,i)=dYY_Ci1(k) + dZZ_Ctab(k,i)=dZZ_Ci(k) + dZZ_C1tab(k,i)=dZZ_Ci1(k) + dXX_XYZtab(k,i)=dXX_XYZ(k) + dYY_XYZtab(k,i)=dYY_XYZ(k) + dZZ_XYZtab(k,i)=dZZ_XYZ(k) + enddo + + do k = 1,3 +c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", +c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) +c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", +c & dyy_ci(k)," dzz_ci",dzz_ci(k) +c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", +c & dt_dci(k) +c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", +c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) + gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) + & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) + gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) + & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) + gsclocx(k,i)= de_dxx*dxx_XYZ(k) + & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) + enddo +c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), +c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) + +C to check gradient call subroutine check_grad + + 1 continue + enddo + return + end +#endif +c------------------------------------------------------------------------------ + subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) +C +C This procedure calculates two-body contact function g(rij) and its derivative: +C +C eps0ij ! x < -1 +C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 +C 0 ! x > 1 +C +C where x=(rij-r0ij)/delta +C +C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy +C + implicit none + double precision rij,r0ij,eps0ij,fcont,fprimcont + double precision x,x2,x4,delta +c delta=0.02D0*r0ij +c delta=0.2D0*r0ij + x=(rij-r0ij)/delta + if (x.lt.-1.0D0) then + fcont=eps0ij + fprimcont=0.0D0 + else if (x.le.1.0D0) then + x2=x*x + x4=x2*x2 + fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) + fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta + else + fcont=0.0D0 + fprimcont=0.0D0 + endif + return + end +c------------------------------------------------------------------------------ + subroutine splinthet(theti,delta,ss,ssder) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + thetup=pi-delta + thetlow=delta + if (theti.gt.pipol) then + call gcont(theti,thetup,1.0d0,delta,ss,ssder) + else + call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) + ssder=-ssder + endif + return + end +c------------------------------------------------------------------------------ + subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) + implicit none + double precision x,x0,delta,f0,f1,fprim0,f,fprim + double precision ksi,ksi2,ksi3,a1,a2,a3 + a1=fprim0*delta/(f1-f0) + a2=3.0d0-2.0d0*a1 + a3=a1-2.0d0 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) + fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) + return + end +c------------------------------------------------------------------------------ + subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) + implicit none + double precision x,x0,delta,f0x,f1x,fprim0x,fx + double precision ksi,ksi2,ksi3,a1,a2,a3 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + a1=fprim0x*delta + a2=3*(f1x-f0x)-2*fprim0x*delta + a3=fprim0x*delta-2*(f1x-f0x) + fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 + return + end +C----------------------------------------------------------------------------- +#ifdef CRYST_TOR +C----------------------------------------------------------------------------- + subroutine etor(etors,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + 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 +C Proline-Proline pair is a special case... + if (itori.eq.3 .and. itori1.eq.3) then + if (phii.gt.-dwapi3) then + cosphi=dcos(3*phii) + fac=1.0D0/(1.0D0-cosphi) + etorsi=v1(1,3,3)*fac + etorsi=etorsi+etorsi + etors=etors+etorsi-v1(1,3,3) + 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) + 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) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + endif + 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*fact*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo + return + end +c------------------------------------------------------------------------------ +#else + subroutine etor(etors,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + if (i.le.2) cycle + if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle +C if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 +C & .or. itype(i).eq.ntyp1) cycle + if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215 + 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 +C 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 + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +C Lorentz terms +C v1 +C E = SUM ----------------------------------- - v1 +C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 +C + cosphi=dcos(0.5d0*phii) + sinphi=dsin(0.5d0*phii) + do j=1,nlor(itori,itori1,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 +c if (energy_dec) etors_ii=etors_ii+ +c & vl1ij*pom1 + pom=-pom*pom1*pom1 + gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom + enddo +C Subtract the constant term + etors=etors-v0(itori,itori1,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,1),j=1,6),(v2(j,itori,itori1,1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + 1215 continue + enddo + return + end +c---------------------------------------------------------------------------- + subroutine etor_d(etors_d,fact2) +C 6/23/01 Compute double torsional energy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors_d=0.0D0 + do i=iphi_start,iphi_end-1 + if (i.le.3) cycle +C if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 +C & .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or. + & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or. + & (itype(i+1).eq.ntyp1)) cycle + if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0) + & goto 1215 + 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 +C 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 + 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 + gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) + gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + enddo + enddo + gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1 + gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2 + 1215 continue + enddo + return + end +#endif +c--------------------------------------------------------------------------- +C The rigorous attempt to derive energy function + subroutine etor_kcc(etors,fact) + 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' + double precision c1(0:maxval_kcc),c2(0:maxval_kcc) + logical lprn +c double precision thybt1(maxtermkcc),thybt2(maxtermkcc) +C Set lprn=.true. for debugging + lprn=energy_dec +c lprn=.true. +C print *,"wchodze kcc" + if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode + etors=0.0D0 + do i=iphi_start,iphi_end +C ANY TWO ARE DUMMY ATOMS in row CYCLE +c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or. +c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or. +c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle + if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + glocig=0.0D0 + glocit1=0.0d0 + glocit2=0.0d0 +C to avoid multiple devision by 2 +c theti22=0.5d0*theta(i) +C theta 12 is the theta_1 /2 +C theta 22 is theta_2 /2 +c theti12=0.5d0*theta(i-1) +C and appropriate sinus function + sinthet1=dsin(theta(i-1)) + sinthet2=dsin(theta(i)) + costhet1=dcos(theta(i-1)) + costhet2=dcos(theta(i)) +C to speed up lets store its mutliplication + sint1t2=sinthet2*sinthet1 + sint1t2n=1.0d0 +C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma) +C +d_n*sin(n*gamma)) * +C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2))) +C we have two sum 1) Non-Chebyshev which is with n and gamma + nval=nterm_kcc_Tb(itori,itori1) + c1(0)=0.0d0 + c2(0)=0.0d0 + c1(1)=1.0d0 + c2(1)=1.0d0 + do j=2,nval + c1(j)=c1(j-1)*costhet1 + c2(j)=c2(j-1)*costhet2 + enddo + etori=0.0d0 + do j=1,nterm_kcc(itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + sint1t2n1=sint1t2n + sint1t2n=sint1t2n*sint1t2 + sumvalc=0.0d0 + gradvalct1=0.0d0 + gradvalct2=0.0d0 + do k=1,nval + do l=1,nval + sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l) + gradvalct1=gradvalct1+ + & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l) + gradvalct2=gradvalct2+ + & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1) + enddo + enddo + gradvalct1=-gradvalct1*sinthet1 + gradvalct2=-gradvalct2*sinthet2 + sumvals=0.0d0 + gradvalst1=0.0d0 + gradvalst2=0.0d0 + do k=1,nval + do l=1,nval + sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l) + gradvalst1=gradvalst1+ + & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l) + gradvalst2=gradvalst2+ + & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1) + enddo + enddo + gradvalst1=-gradvalst1*sinthet1 + gradvalst2=-gradvalst2*sinthet2 + etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi) +C glocig is the gradient local i site in gamma + glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi) +C now gradient over theta_1 + glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi) + & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi) + glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi) + & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi) + enddo ! j + etors=etors+etori +C derivative over gamma + gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig +C derivative over theta1 + gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1 +C now derivative over theta2 + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2 + if (lprn) + & write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1, + & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori + enddo + return + end +c--------------------------------------------------------------------------------------------- + subroutine etor_constr(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' +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 +c do i=1,ndih_constr +c write (iout,*) "idihconstr_start",idihconstr_start, +c & " idihconstr_end",idihconstr_end + if (raw_psipred) then + do i=idihconstr_start,idihconstr_end + itori=idih_constr(i) + phii=phi(itori) + gaudih_i=vpsipred(1,i) + gauder_i=0.0d0 + do j=1,2 + s = sdihed(j,i) + cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2 + dexpcos_i=dexp(-cos_i*cos_i) + gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i + gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) + & *cos_i*dexpcos_i/s**2 + enddo + edihcnstr=edihcnstr-wdihc*dlog(gaudih_i) + gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i + if (energy_dec) + & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') + & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i), + & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i), + & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg, + & -wdihc*dlog(gaudih_i) + enddo + else + 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(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + else + difi=0.0 + endif + enddo + endif + return + end +c---------------------------------------------------------------------------- +C The rigorous attempt to derive energy function + subroutine ebend_kcc(etheta) + + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + logical lprn + double precision thybt1(maxang_kcc) +C Set lprn=.true. for debugging + lprn=energy_dec +c lprn=.true. +C print *,"wchodze kcc" + if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode + etheta=0.0D0 + do i=ithet_start,ithet_end +c print *,i,itype(i-1),itype(i),itype(i-2) + if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle + iti=iabs(itortyp(itype(i-1))) + sinthet=dsin(theta(i)) + costhet=dcos(theta(i)) + do j=1,nbend_kcc_Tb(iti) + thybt1(j)=v1bend_chyb(j,iti) + enddo + sumth1thyb=v1bend_chyb(0,iti)+ + & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet) + if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg, + & sumth1thyb + ihelp=nbend_kcc_Tb(iti)-1 + gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet) + etheta=etheta+sumth1thyb +C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0) + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet + enddo + return + end +c------------------------------------------------------------------------------------- + subroutine etheta_constr(ethetacnstr) + + 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' + ethetacnstr=0.0d0 +C print *,ithetaconstr_start,ithetaconstr_end,"TU" + do i=ithetaconstr_start,ithetaconstr_end + itheta=itheta_constr(i) + thetiii=theta(itheta) + difi=pinorm(thetiii-theta_constr0(i)) + if (difi.gt.theta_drange(i)) then + difi=difi-theta_drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else + difi=0.0 + endif + if (energy_dec) then + write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", + & i,itheta,rad2deg*thetiii, + & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), + & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, + & gloc(itheta+nphi-2,icg) + endif + enddo + return + end +c------------------------------------------------------------------------------ +c------------------------------------------------------------------------------ + subroutine eback_sc_corr(esccor) +c 7/21/2007 Correlations between the backbone-local and side-chain-local +c conformational states; temporarily implemented as differences +c between UNRES torsional potentials (dependent on three types of +c residues) and the torsional potentials dependent on all 20 types +c of residues computed from AM1 energy surfaces of terminally-blocked +c amino-acid residues. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.SCCOR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. +c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor + esccor=0.0D0 + do i=itau_start,itau_end + 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)) + phii=phi(i) + do intertyp=1,3 !intertyp +cc Added 09 May 2012 (Adasko) +cc Intertyp means interaction type of backbone mainchain correlation: +c 1 = SC...Ca...Ca...Ca +c 2 = Ca...Ca...Ca...SC +c 3 = SC...Ca...Ca...SCi + gloci=0.0D0 + if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. + & (itype(i-1).eq.10).or.(itype(i-2).eq.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)) + esccor=esccor+v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +C write (iout,*)"EBACK_SC_COR",esccor,i +c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp, +c & nterm_sccor(isccori,isccori1),isccori,isccori1 +c 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,itori,itori1, + & (v1sccor(j,1,itori,itori1),j=1,6) + & ,(v2sccor(j,1,itori,itori1),j=1,6) +c gsccor_loc(i-3)=gloci + enddo !intertyp + enddo + return + end +#ifdef FOURBODY +c------------------------------------------------------------------------------ + subroutine multibody(ecorr) +C This subroutine calculates multi-body contributions to energy following +C the idea of Skolnick et al. If side chains I and J make a contact and +C at the same time side chains I+1 and J+1 make a contact, an extra +C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + double precision gx(3),gx1(3) + logical lprn + +C Set lprn=.true. for debugging + lprn=.false. + + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(i2,20(1x,i2,f10.5))') + & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) + enddo + endif + ecorr=0.0D0 + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo + do i=nnt,nct-2 + + DO ISHIFT = 3,4 + + i1=i+ishift + num_conti=num_cont(i) + num_conti1=num_cont(i1) + do jj=1,num_conti + j=jcont(jj,i) + do kk=1,num_conti1 + j1=jcont(kk,i1) + if (j1.eq.j+ishift .or. j1.eq.j-ishift) then +cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, +cd & ' ishift=',ishift +C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) + endif ! j1==j+-ishift + enddo ! kk + enddo ! jj + + ENDDO ! ISHIFT + + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function esccorr(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont(jj,i) + ekl=facont(kk,k) +cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl +C Calculate the multi-body contribution to energy. +C Calculate multi-body contributions to the gradient. +cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), +cd & k,l,(gacont(m,kk,k),m=1,3) + do m=1,3 + gx(m) =ekl*gacont(m,jj,i) + gx1(m)=eij*gacont(m,kk,k) + gradxorr(m,i)=gradxorr(m,i)-gx(m) + gradxorr(m,j)=gradxorr(m,j)+gx(m) + gradxorr(m,k)=gradxorr(m,k)-gx1(m) + gradxorr(m,l)=gradxorr(m,l)+gx1(m) + enddo + do m=i,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) + enddo + enddo + do m=k,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) + enddo + enddo + esccorr=-eij*ekl + return + end +c------------------------------------------------------------------------------ + subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + double precision gx(3),gx1(3) + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. + if (lprn) then + write (iout,'(a)') 'Contact function values:' + 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 + ecorr=0.0D0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the local-electrostatic correlation terms + do i=iatel_s,iatel_e+1 + 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) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1 .or. j1.eq.j-1) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) + n_corr=n_corr+1 + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, + & n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.CHAIN' + include 'COMMON.CONTROL' + include 'COMMON.SHIELD' + double precision gx(3),gx1(3) + integer num_cont_hb_old(maxres) + logical lprn,ldone + double precision eello4,eello5,eelo6,eello_turn6 + external eello4,eello5,eello6,eello_turn6 +C Set lprn=.true. for debugging + lprn=.false. + eturn6=0.0d0 + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,5f6.3))') + & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), + & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 + ecorr5=0.0d0 + ecorr6=0.0d0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the dipole-dipole interaction energies + if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then + do i=iatel_s,iatel_e+1 + num_conti=num_cont_hb(i) + do jj=1,num_conti + j=jcont_hb(jj,i) +#ifdef MOMENT + call dipole(i,j,jj) +#endif + enddo + enddo + endif +C Calculate the local-electrostatic correlation terms +c write (iout,*) "gradcorr5 in eello5 before loop" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) +c write (iout,*) "corr loop i",i + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + jp=iabs(j) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) + jp1=iabs(j1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk +c if (j1.eq.j+1 .or. j1.eq.j-1) then + if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 + & .or. j.lt.0 .and. j1.gt.0) .and. + & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + n_corr=n_corr+1 + sqd1=dsqrt(d_cont(jj,i)) + sqd2=dsqrt(d_cont(kk,i1)) + sred_geom = sqd1*sqd2 + IF (sred_geom.lt.cutoff_corr) THEN + call gcont(sred_geom,r0_corr,1.0D0,delt_corr, + & ekont,fprimcont) +cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, +cd & ' jj=',jj,' kk=',kk + fac_prim1=0.5d0*sqd2/sqd1*fprimcont + fac_prim2=0.5d0*sqd1/sqd2*fprimcont + do l=1,3 + g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) + g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) + enddo + n_corr1=n_corr1+1 +cd write (iout,*) 'sred_geom=',sred_geom, +cd & ' ekont=',ekont,' fprim=',fprimcont, +cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 +cd write (iout,*) "g_contij",g_contij +cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) +cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) + call calc_eello(i,jp,i+1,jp1,jj,kk) + if (wcorr4.gt.0.0d0) + & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) +CC & *fac_shield(i)**2*fac_shield(j)**2 + if (energy_dec.and.wcorr4.gt.0.0d0) + 1 write (iout,'(a6,4i5,0pf7.3)') + 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) +c write (iout,*) "gradcorr5 before eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + if (wcorr5.gt.0.0d0) + & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) +c write (iout,*) "gradcorr5 after eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + if (energy_dec.and.wcorr5.gt.0.0d0) + 1 write (iout,'(a6,4i5,0pf7.3)') + 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) +cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 +cd write(2,*)'ijkl',i,jp,i+1,jp1 + if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 + & .or. wturn6.eq.0.0d0))then +cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 + ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') + 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) +cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, +cd & 'ecorr6=',ecorr6 +cd write (iout,'(4e15.5)') sred_geom, +cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)), +cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)), +cd & dabs(eello6(i,jp,i+1,jp1,jj,kk)) + else if (wturn6.gt.0.0d0 + & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then +cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 + eturn6=eturn6+eello_turn6(i,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') + 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) +cd write (2,*) 'multibody_eello:eturn6',eturn6 + endif + ENDIF +1111 continue + endif + enddo ! kk + enddo ! jj + enddo ! i + do i=1,nres + num_cont_hb(i)=num_cont_hb_old(i) + enddo +c write (iout,*) "gradcorr5 in eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + return + end +c------------------------------------------------------------------------------ + double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.SHIELD' + include 'COMMON.CONTROL' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. +C print *,"wchodze",fac_shield(i),shield_mode + 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) +C* +C & fac_shield(i)**2*fac_shield(j)**2 +cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) +C Following 4 lines for diagnostics. +cd ees0pkl=0.0D0 +cd ees0pij=1.0D0 +cd ees0mkl=0.0D0 +cd ees0mij=1.0D0 +c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') +c & 'Contacts ',i,j, +c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l +c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, +c & 'gradcorr_long' +C Calculate the multi-body contribution to energy. +C ecorr=ecorr+ekont*ees +C Calculate multi-body contributions to the gradient. + coeffpees0pij=coeffp*ees0pij + coeffmees0mij=coeffm*ees0mij + coeffpees0pkl=coeffp*ees0pkl + coeffmees0mkl=coeffm*ees0mkl + do ll=1,3 +cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi + & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb1(ll,jj,i)) + gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi + & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb2(ll,jj,i)) +cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk + & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ + & coeffmees0mij*gacontm_hb1(ll,kk,k)) + gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk + & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ + & coeffmees0mij*gacontm_hb2(ll,kk,k)) + gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- + & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb3(ll,jj,i)) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij + gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- + & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ + & coeffmees0mij*gacontm_hb3(ll,kk,k)) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl +c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl + enddo +c write (iout,*) +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ +cgrad & ees*ekl*gacont_hbr(ll,jj,i)- +cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ +cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ +cgrad & ees*eij*gacont_hbr(ll,kk,k)- +cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ +cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) +cgrad enddo +cgrad enddo +c write (iout,*) "ehbcorr",ekont*ees +C print *,ekont,ees,i,k + ehbcorr=ekont*ees +C now gradient over shielding +C return + if (shield_mode.gt.0) then + j=ees0plist(jj,i) + l=ees0plist(kk,k) +C print *,i,j,fac_shield(i),fac_shield(j), +C &fac_shield(k),fac_shield(l) + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. + & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then + do ilist=1,ishield_list(i) + iresshield=shield_list(ilist,i) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + &+rlocshield + enddo + enddo + do ilist=1,ishield_list(j) + iresshield=shield_list(ilist,j) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + & +rlocshield + enddo + enddo + + do ilist=1,ishield_list(k) + iresshield=shield_list(ilist,k) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + & +rlocshield + enddo + enddo + do ilist=1,ishield_list(l) + iresshield=shield_list(ilist,l) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + & +rlocshield + enddo + enddo +C print *,gshieldx(m,iresshield) + do m=1,3 + gshieldc_ec(m,i)=gshieldc_ec(m,i)+ + & grad_shield(m,i)*ehbcorr/fac_shield(i) + gshieldc_ec(m,j)=gshieldc_ec(m,j)+ + & grad_shield(m,j)*ehbcorr/fac_shield(j) + gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+ + & grad_shield(m,i)*ehbcorr/fac_shield(i) + gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+ + & grad_shield(m,j)*ehbcorr/fac_shield(j) + + gshieldc_ec(m,k)=gshieldc_ec(m,k)+ + & grad_shield(m,k)*ehbcorr/fac_shield(k) + gshieldc_ec(m,l)=gshieldc_ec(m,l)+ + & grad_shield(m,l)*ehbcorr/fac_shield(l) + gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+ + & grad_shield(m,k)*ehbcorr/fac_shield(k) + gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+ + & grad_shield(m,l)*ehbcorr/fac_shield(l) + + enddo + endif + endif + return + end +#ifdef MOMENT +C--------------------------------------------------------------------------- + subroutine dipole(i,j,jj) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), + & auxmat(2,2) + iti1 = itortyp(itype(i+1)) + if (j.lt.nres-1) then + itj1 = itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + do iii=1,2 + dipi(iii,1)=Ub2(iii,i) + dipderi(iii)=Ub2der(iii,i) + dipi(iii,2)=b1(iii,i+1) + dipj(iii,1)=Ub2(iii,j) + dipderj(iii)=Ub2der(iii,j) + dipj(iii,2)=b1(iii,j+1) + enddo + kkk=0 + do iii=1,2 + call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) + do jjj=1,2 + kkk=kkk+1 + dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + do kkk=1,5 + do lll=1,3 + mmm=0 + do iii=1,2 + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), + & auxvec(1)) + do jjj=1,2 + mmm=mmm+1 + dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + enddo + enddo + call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) + call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) + do iii=1,2 + dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) + enddo + call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) + do iii=1,2 + dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) + enddo + return + end +#endif +C--------------------------------------------------------------------------- + subroutine calc_eello(i,j,k,l,jj,kk) +C +C This subroutine computes matrices and vectors needed to calculate +C the fourth-, fifth-, and sixth-order local-electrostatic terms. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), + & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) + logical lprn + common /kutas/ lprn +cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, +cd & ' jj=',jj,' kk=',kk +cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return +cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) +cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) + do iii=1,2 + do jjj=1,2 + aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) + aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) + enddo + enddo + call transpose2(aa1(1,1),aa1t(1,1)) + call transpose2(aa2(1,1),aa2t(1,1)) + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), + & aa1tder(1,1,lll,kkk)) + call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), + & aa2tder(1,1,lll,kkk)) + enddo + enddo + if (l.eq.j+1) then +C parallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itype2loc(itype(i)) + else + iti=nloctyp + endif + itk1=itype2loc(itype(k+1)) + itj=itype2loc(itype(j)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +C A1 kernel(j+1) A2T +cd do iii=1,2 +cd write (iout,'(3f10.5,5x,3f10.5)') +cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) +cd enddo + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), + & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + lprn=.false. + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), + & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants +cd lprn=.false. +cd if (lprn) then +cd write (2,*) 'In calc_eello6' +cd do iii=1,2 +cd write (2,*) 'iii=',iii +cd do kkk=1,5 +cd write (2,*) 'kkk=',kkk +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) +cd enddo +cd enddo +cd enddo +cd endif + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A1T kernel(i+1) A2 + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i),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,i),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,k+1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,k+1),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,j),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,j),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,l+1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i), + & 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,k+1), + & 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,j), + & 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,l+1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + else +C Antiparallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itype2loc(itype(i)) + else + iti=nloctyp + endif + itk1=itype2loc(itype(k+1)) + itl=itype2loc(itype(l)) + itj=itype2loc(itype(j)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif +C A2 kernel(j-1)T A1T + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), + & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), + & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A2T kernel(i+1)T A1 + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. + & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i),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,i),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,k+1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,k+1),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,j+1),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,l),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,j+1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i), + & 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,k+1), + & 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,l), + & 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,j+1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + endif + return + end +C--------------------------------------------------------------------------- + subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, + & KK,KKderg,AKA,AKAderg,AKAderx) + implicit none + integer nderg + logical transp + double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), + & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), + & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) + integer iii,kkk,lll + integer jjj,mmm + logical lprn + common /kutas/ lprn + call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) + do iii=1,nderg + call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, + & AKAderg(1,1,iii)) + enddo +cd if (lprn) write (2,*) 'In kernel' + do kkk=1,5 +cd if (lprn) write (2,*) 'kkk=',kkk + do lll=1,3 + call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=1' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) +cd enddo +cd endif + call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=2' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) +cd enddo +cd endif + enddo + enddo + return + end +C--------------------------------------------------------------------------- + double precision function eello4(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then +cd eello4=0.0d0 +cd return +cd endif +cd print *,'eello4:',i,j,k,l,jj,kk +cd write (2,*) 'i',i,' j',j,' k',k,' l',l +cd call checkint4(i,j,k,l,jj,kk,eel4_num) +cold eij=facont_hb(jj,i) +cold ekl=facont_hb(kk,k) +cold ekont=eij*ekl + eel4=-EAEA(1,1,1)-EAEA(2,2,1) + if (calc_grad) then +cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) + gcorr_loc(k-1)=gcorr_loc(k-1) + & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) + if (l.eq.j+1) then + gcorr_loc(l-1)=gcorr_loc(l-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + else + gcorr_loc(j-1)=gcorr_loc(j-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) + & -EAEAderx(2,2,lll,kkk,iii,1) +cd derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd gcorr_loc(l-1)=0.0d0 +cd gcorr_loc(j-1)=0.0d0 +cd gcorr_loc(k-1)=0.0d0 +cd eel4=1.0d0 +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l, +cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel4*g_contij(ll,1) +cgrad ggg2(ll)=eel4*g_contij(ll,2) + glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) + glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) +cgrad ghalf=0.5d0*ggg1(ll) + gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) + gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) + gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) + gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij +cgrad ghalf=0.5d0*ggg2(ll) + gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) + gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) + gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) + gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl + enddo +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,gcorr_loc(iii) +cd enddo + endif ! calc_grad + eello4=ekont*eel4 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello4',ekont*eel4 + return + end +C--------------------------------------------------------------------------- + double precision function eello5(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) + double precision ggg1(3),ggg2(3) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel chains C +C C +C o o o o C +C /l\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j| o |l1 | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C Antiparallel chains C +C C +C o o o o C +C /j\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j1| o |l | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C o denotes a local interaction, vertical lines an electrostatic interaction. C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then +cd eello5=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + itk=itype2loc(itype(k)) + itl=itype2loc(itype(l)) + itj=itype2loc(itype(j)) + eello5_1=0.0d0 + eello5_2=0.0d0 + eello5_3=0.0d0 + eello5_4=0.0d0 +cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, +cd & eel5_3_num,eel5_4_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l +cd goto 1111 +C Contribution from the graph I. +cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) +cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + if (l.eq.j+1) then + if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + else + if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + enddo + enddo + enddo + endif ! calc_grad +c goto 1112 +c1111 continue +C Contribution from graph II + call transpose2(EE(1,1,k),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,k)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + if (l.eq.j+1) then + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k)) + & -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,k)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + enddo + enddo + enddo + endif ! calc_grad +cd goto 1112 +cd1111 continue + if (l.eq.j+1) then +cd goto 1110 +C Parallel orientation +C Contribution from graph III + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) + call transpose2(EUgder(1,1,l),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + enddo + enddo + enddo +cd goto 1112 +C Contribution from graph IV +cd1110 continue + call transpose2(EE(1,1,l),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,l)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + enddo + enddo + enddo + endif ! calc_grad + else +C Antiparallel orientation +C Contribution from graph III +c goto 1110 + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) + call transpose2(EUgder(1,1,j),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + enddo + enddo + enddo + endif ! calc_grad +cd goto 1112 +C Contribution from graph IV +1110 continue + call transpose2(EE(1,1,j),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,j)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + enddo + enddo + enddo + endif ! calc_grad + endif +1112 continue + eel5=eello5_1+eello5_2+eello5_3+eello5_4 +cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then +cd write (2,*) 'ijkl',i,j,k,l +cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, +cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 +cd endif +cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num +cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num +cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num +cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num + if (calc_grad) then + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 +cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont +C 2/11/08 AL Gradients over DC's connecting interacting sites will be +C summed up outside the subrouine as for the other subroutines +C handling long-range interactions. The old code is commented out +C with "cgrad" to keep track of changes. + do ll=1,3 +cgrad ggg1(ll)=eel5*g_contij(ll,1) +cgrad ggg2(ll)=eel5*g_contij(ll,2) + gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) +c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') +c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), +c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), +c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont +c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') +c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), +c & gradcorr5ij, +c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl +cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) + gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) + gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) + gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) + gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij + gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij +cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) +cgrad ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2) + gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) + gradcorr5(ll,l)=gradcorr5(ll,l)+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 + endif ! calc_grad +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +c1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr5_loc(iii) +cd enddo + eello5=ekont*eel5 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello5',ekont*eel5 + return + end +c-------------------------------------------------------------------------- + double precision function eello6(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + eello6_1=0.0d0 + eello6_2=0.0d0 + eello6_3=0.0d0 + eello6_4=0.0d0 + eello6_5=0.0d0 + eello6_6=0.0d0 +cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, +cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + if (l.eq.j+1) then + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(j,i,l,k,2,.false.) + eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) + eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) + else + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(l,k,j,i,2,.true.) + eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + if (wturn6.eq.0.0d0 .or. j.ne.i+4) then + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) + else + eello6_5=0.0d0 + endif + eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) + endif +C If turn contributions are considered, they will be handled separately. + eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 +cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num +cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num +cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num +cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num +cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num +cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num +cd goto 1112 + if (calc_grad) then + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel6*g_contij(ll,1) +cgrad ggg2(ll)=eel6*g_contij(ll,2) +cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) + gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) + gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) + gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) + gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) + gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij + gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij +cgrad ghalf=0.5d0*ggg2(ll) +cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) +cd ghalf=0.0d0 + gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) + gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) + gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) + gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) + gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl + gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl + enddo + endif ! calc_grad +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + eello6=ekont*eel6 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello6',ekont*eel6 + return + end +c-------------------------------------------------------------------------- + double precision function eello6_graph1(i,j,k,l,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) + logical swap + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ /j\ C +C / \ / \ C +C /| o | | o |\ C +C \ j|/k\| / \ |/k\|l / C +C \ / \ / \ / \ / C +C o o o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + itk=itype2loc(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,k)-AEAb1(2,2,imat)*b1(2,k) + vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k) + s5=scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 + eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) + if (calc_grad) then + 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,k)-AEAb1derg(2,2,imat)*b1(2,k) + vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k) + 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,k) + & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k) + vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k) + & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k) + 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 + endif ! calc_grad + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph2(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + logical swap + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxvec2(2),auxmat1(2,2) + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C \ /l\ /j\ / C +C \ / \ / \ / C +C o| o | | o |o C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l +C AL 7/4/01 s1 would occur in the sixth-order moment, +C but not in a cluster cumulant +#ifdef MOMENT + s1=dip(1,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph2=-(s1+s2+s3+s4) +#else + eello6_graph2=-(s2+s3+s4) +#endif +c eello6_graph2=-s3 +C Derivatives in gamma(i-1) + if (calc_grad) then + if (i.gt.1) then +#ifdef MOMENT + s1=dipderg(1,jj,i)*dip(1,kk,k) +#endif + s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 +C Derivatives in gamma(j-1) or gamma(l-1) + if (j.gt.1) then +#ifdef MOMENT + s1=dipderg(3,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) + call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + endif +#endif + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) +c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 + endif +C Derivatives in gamma(l-1) or gamma(j-1) + if (l.gt.1) then +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(3,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + else + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + endif +#endif + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) +c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 + endif +C Cartesian derivatives. + if (lprn) then + write (2,*) 'In eello6_graph2' + do iii=1,2 + write (2,*) 'iii=',iii + do kkk=1,5 + write (2,*) 'kkk=',kkk + do jjj=1,2 + write (2,'(3(2f10.5),5x)') + & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) + enddo + enddo + enddo + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) + else + s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) + endif +#endif + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), + & auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), + & auxvec(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + enddo + enddo + enddo + endif ! calc_grad + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph3(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C j|/k\| / |/k\|l / C +C / \ / / \ / C +C / o / o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. + iti=itortyp(itype(i)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + itk=itype2loc(itype(k)) + itk1=itype2loc(itype(k+1)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +#ifdef MOMENT + s1=dip(4,jj,i)*dip(4,kk,k) +#endif + call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,k),auxvec(1)) + call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) + call transpose2(EE(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, +cd & "sum",-(s2+s3+s4) +#ifdef MOMENT + eello6_graph3=-(s1+s2+s3+s4) +#else + eello6_graph3=-(s2+s3+s4) +#endif +c eello6_graph3=-s4 +C Derivatives in gamma(k-1) + if (calc_grad) then + call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) + s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) +C Derivatives in gamma(l-1) + call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,k),auxvec(1)) + call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) + else + s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1), + & auxvec(1)) + s2=0.5d0*scalar2(b1(1,k),auxvec(1)) + call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1), + & auxvec(1)) + s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) + call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif +c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 + enddo + enddo + enddo + endif ! calc_grad + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxmat1(2,2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o \ o \ C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. +cd write (2,*) 'eello_graph4: wturn6',wturn6 + iti=itype2loc(itype(i)) + itj=itype2loc(itype(j)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + itk=itype2loc(itype(k)) + if (k.lt.nres-1) then + itk1=itype2loc(itype(k+1)) + else + itk1=nloctyp + endif + itl=itype2loc(itype(l)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l +cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, +cd & ' itl',itl,' itl1',itl1 +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dip(3,kk,k) + else + s1=dip(2,jj,j)*dip(2,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) + else + call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) + endif + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph4=-(s1+s2+s3+s4) +#else + eello6_graph4=-(s2+s3+s4) +#endif +C Derivatives in gamma(i-1) + if (calc_grad) then + 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,j+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) + endif + s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +cd write (2,*) 'turn6 derivatives' +#ifdef MOMENT + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif + endif + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderg(2,kk,k) + else + s1=dip(2,jj,j)*dipderg(4,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) + endif + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif + endif +C Derivatives in gamma(j-1) or gamma(l-1) + if (l.eq.j+1 .and. l.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) + else if (j.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then + gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) + endif + endif +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + if (imat.eq.1) then + s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) + else + s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) + endif + else + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) + else + s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) + endif + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), + & auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,j+1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec(1)) + else + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,l+1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,l),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 + endif ! calc_grad + return + end +c---------------------------------------------------------------------------- + double precision function eello_turn6(i,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), + & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), + & ggg1(3),ggg2(3) + double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), + & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) +C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to +C the respective energy moment and not to the cluster cumulant. + s1=0.0d0 + s8=0.0d0 + s13=0.0d0 +c + eello_turn6=0.0d0 + j=i+4 + k=i+1 + l=i+3 + iti=itype2loc(itype(i)) + itk=itype2loc(itype(k)) + itk1=itype2loc(itype(k+1)) + itl=itype2loc(itype(l)) + itj=itype2loc(itype(j)) +cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj +cd write (2,*) 'i',i,' k',k,' j',j,' l',l +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l +cd call checkint_turn6(i,jj,kk,eel_turn6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx_turn(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) +cd eello6_5=0.0d0 +cd write (2,*) 'eello6_5',eello6_5 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) + ss1=scalar2(Ub2(1,i+2),b1(1,l)) + s1 = (auxmat(1,1)+auxmat(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1)) + call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) + s2 = scalar2(b1(1,k),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,k+1),vtemp2(1)) + s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),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,k),vtemp4(1)) + s13 = (gtemp(1,1)+gtemp(2,2))*ss13 +#endif +c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 +c s1=0.0d0 +c s2=0.0d0 +c s8=0.0d0 +c s12=0.0d0 +c s13=0.0d0 + eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) +C Derivatives in gamma(i+2) + if (calc_grad) then + 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,l),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 + gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) +C Derivatives in gamma(i+3) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + ss1d=scalar2(Ub2der(1,i+2),b1(1,l)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d +#endif + call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1)) + call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,k),vtemp1d(1)) +#ifdef MOMENT + call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1)) + s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1)) +#endif + s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Derivatives in gamma(i+4) + call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +C s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) +#else + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) +#endif +C Derivatives in gamma(i+5) +#ifdef MOMENT + call transpose2(AEAderg(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1)) + call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,k),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,l),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,k),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Cartesian derivatives + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), + & vtemp1d(1)) + s2d = scalar2(b1(1,k),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,l),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), + & auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*(s1d+s2d) +#else + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*s2d +#endif +#ifdef MOMENT + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*(s8d+s12d) +#else + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*s12d +#endif + enddo + enddo + enddo +#ifdef MOMENT + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), + & achuj_tempd(1,1)) + call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d=(gtempd(1,1)+gtempd(2,2))*ss13 + derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), + & vtemp4d(1)) + ss13d = scalar2(b1(1,k),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d + derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d + enddo + enddo +#endif +cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', +cd & 16*eel_turn6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel_turn6*g_contij(ll,1) +cgrad ggg2(ll)=eel_turn6*g_contij(ll,2) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) + gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) + gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf + & +ekont*derx_turn(ll,2,1) + gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) + gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf + & +ekont*derx_turn(ll,4,1) + gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) + gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij + gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij +cgrad ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf + & +ekont*derx_turn(ll,2,2) + gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) + gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf + & +ekont*derx_turn(ll,4,2) + gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) + gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl + gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + endif ! calc_grad + eello_turn6=ekont*eel_turn6 +cd write (2,*) 'ekont',ekont +cd write (2,*) 'eel_turn6',ekont*eel_turn6 + return + end +#endif +crc------------------------------------------------- +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + subroutine Eliptransfer(eliptran) + 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.CALC' + include 'COMMON.CONTROL' + include 'COMMON.SPLITELE' + include 'COMMON.SBRIDGE' +C this is done by Adasko +C print *,"wchodze" +C structure of box: +C water +C--bordliptop-- buffore starts +C--bufliptop--- here true lipid starts +C lipid +C--buflipbot--- lipid ends buffore starts +C--bordlipbot--buffore ends + eliptran=0.0 + do i=1,nres +C do i=1,1 + if (itype(i).eq.ntyp1) cycle + + positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize)) + if (positi.le.0) positi=positi+boxzsize +C print *,i +C first for peptide groups +c for each residue check if it is in lipid or lipid water border area + if ((positi.gt.bordlipbot) + &.and.(positi.lt.bordliptop)) then +C the energy transfer exist + if (positi.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((positi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslip=sscalelip(fracinbuf) + ssgradlip=-sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*pepliptran + gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 + gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 +C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran + elseif (positi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) + sslip=sscalelip(fracinbuf) + ssgradlip=sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*pepliptran + gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 + gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 +C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran +C print *, "doing sscalefor top part" +C print *,i,sslip,fracinbuf,ssgradlip + else + eliptran=eliptran+pepliptran +C print *,"I am in true lipid" + endif +C else +C eliptran=elpitran+0.0 ! I am in water + endif + enddo +C print *, "nic nie bylo w lipidzie?" +C now multiply all by the peptide group transfer factor +C eliptran=eliptran*pepliptran +C now the same for side chains +CV do i=1,1 + do i=1,nres + if (itype(i).eq.ntyp1) cycle + positi=(mod(c(3,i+nres),boxzsize)) + if (positi.le.0) positi=positi+boxzsize +C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop +c for each residue check if it is in lipid or lipid water border area +C respos=mod(c(3,i+nres),boxzsize) +C print *,positi,bordlipbot,buflipbot + if ((positi.gt.bordlipbot) + & .and.(positi.lt.bordliptop)) then +C the energy transfer exist + if (positi.lt.buflipbot) then + fracinbuf=1.0d0- + & ((positi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslip=sscalelip(fracinbuf) + ssgradlip=-sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*liptranene(itype(i)) + gliptranx(3,i)=gliptranx(3,i) + &+ssgradlip*liptranene(itype(i)) + gliptranc(3,i-1)= gliptranc(3,i-1) + &+ssgradlip*liptranene(itype(i)) +C print *,"doing sccale for lower part" + elseif (positi.gt.bufliptop) then + fracinbuf=1.0d0- + &((bordliptop-positi)/lipbufthick) + sslip=sscalelip(fracinbuf) + ssgradlip=sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*liptranene(itype(i)) + gliptranx(3,i)=gliptranx(3,i) + &+ssgradlip*liptranene(itype(i)) + gliptranc(3,i-1)= gliptranc(3,i-1) + &+ssgradlip*liptranene(itype(i)) +C print *, "doing sscalefor top part",sslip,fracinbuf + else + eliptran=eliptran+liptranene(itype(i)) +C print *,"I am in true lipid" + endif + endif ! if in lipid or buffor +C else +C eliptran=elpitran+0.0 ! I am in water + enddo + return + end + + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + SUBROUTINE MATVEC2(A1,V1,V2) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),V1(2),V2(2) +c DO 1 I=1,2 +c VI=0.0 +c DO 3 K=1,2 +c 3 VI=VI+A1(I,K)*V1(K) +c Vaux(I)=VI +c 1 CONTINUE + + vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) + vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) + + v2(1)=vaux1 + v2(2)=vaux2 + END +C--------------------------------------- + SUBROUTINE MATMAT2(A1,A2,A3) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),A2(2,2),A3(2,2) +c DIMENSION AI3(2,2) +c DO J=1,2 +c A3IJ=0.0 +c DO K=1,2 +c A3IJ=A3IJ+A1(I,K)*A2(K,J) +c enddo +c A3(I,J)=A3IJ +c enddo +c enddo + + ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) + ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) + ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) + ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) + + A3(1,1)=AI3_11 + A3(2,1)=AI3_21 + A3(1,2)=AI3_12 + A3(2,2)=AI3_22 + END + +c------------------------------------------------------------------------- + double precision function scalar2(u,v) + implicit none + double precision u(2),v(2) + double precision sc + integer i + scalar2=u(1)*v(1)+u(2)*v(2) + return + end + +C----------------------------------------------------------------------------- + + subroutine transpose2(a,at) + implicit none + double precision a(2,2),at(2,2) + at(1,1)=a(1,1) + at(1,2)=a(2,1) + at(2,1)=a(1,2) + at(2,2)=a(2,2) + return + end +c-------------------------------------------------------------------------- + subroutine transpose(n,a,at) + implicit none + integer n,i,j + double precision a(n,n),at(n,n) + do i=1,n + do j=1,n + at(j,i)=a(i,j) + enddo + enddo + return + end +C--------------------------------------------------------------------------- + subroutine prodmat3(a1,a2,kk,transp,prod) + implicit none + integer i,j + double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) + logical transp +crc double precision auxmat(2,2),prod_(2,2) + + if (transp) then +crc call transpose2(kk(1,1),auxmat(1,1)) +crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) + + else +crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) + + endif +c call transpose2(a2(1,1),a2t(1,1)) + +crc print *,transp +crc print *,((prod_(i,j),i=1,2),j=1,2) +crc print *,((prod(i,j),i=1,2),j=1,2) + + return + end +C----------------------------------------------------------------------------- + double precision function scalar(u,v) + implicit none + double precision u(3),v(3) + double precision sc + integer i + sc=0.0d0 + do i=1,3 + sc=sc+u(i)*v(i) + enddo + scalar=sc + return + end +C----------------------------------------------------------------------- + double precision function sscale(r) + double precision r,gamm + include "COMMON.SPLITELE" + if(r.lt.r_cut-rlamb) then + sscale=1.0d0 + else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then + gamm=(r-(r_cut-rlamb))/rlamb + sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) + else + sscale=0d0 + endif + return + end +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + double precision function sscagrad(r) + double precision r,gamm + include "COMMON.SPLITELE" + if(r.lt.r_cut-rlamb) then + sscagrad=0.0d0 + else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then + gamm=(r-(r_cut-rlamb))/rlamb + sscagrad=gamm*(6*gamm-6.0d0)/rlamb + else + sscagrad=0.0d0 + endif + return + end +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + double precision function sscalelip(r) + double precision r,gamm + include "COMMON.SPLITELE" +C if(r.lt.r_cut-rlamb) then +C sscale=1.0d0 +C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then +C gamm=(r-(r_cut-rlamb))/rlamb + sscalelip=1.0d0+r*r*(2*r-3.0d0) +C else +C sscale=0d0 +C endif + return + end +C----------------------------------------------------------------------- + double precision function sscagradlip(r) + double precision r,gamm + include "COMMON.SPLITELE" +C if(r.lt.r_cut-rlamb) then +C sscagrad=0.0d0 +C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then +C gamm=(r-(r_cut-rlamb))/rlamb + sscagradlip=r*(6*r-6.0d0) +C else +C sscagrad=0.0d0 +C endif + return + end + +C----------------------------------------------------------------------- + subroutine set_shield_fac + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SHIELD' + include 'COMMON.INTERACT' +C this is the squar root 77 devided by 81 the epislion in lipid (in protein) + double precision div77_81/0.974996043d0/, + &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) + +C the vector between center of side_chain and peptide group + double precision pep_side(3),long,side_calf(3), + &pept_group(3),costhet_grad(3),cosphi_grad_long(3), + &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) +C the line belowe needs to be changed for FGPROC>1 + do i=1,nres-1 + if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle + ishield_list(i)=0 +Cif there two consequtive dummy atoms there is no peptide group between them +C the line below has to be changed for FGPROC>1 + VolumeTotal=0.0 + do k=1,nres + if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle + dist_pep_side=0.0 + dist_side_calf=0.0 + do j=1,3 +C first lets set vector conecting the ithe side-chain with kth side-chain + pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 +C pep_side(j)=2.0d0 +C and vector conecting the side-chain with its proper calfa + side_calf(j)=c(j,k+nres)-c(j,k) +C side_calf(j)=2.0d0 + pept_group(j)=c(j,i)-c(j,i+1) +C lets have their lenght + dist_pep_side=pep_side(j)**2+dist_pep_side + dist_side_calf=dist_side_calf+side_calf(j)**2 + dist_pept_group=dist_pept_group+pept_group(j)**2 + enddo + dist_pep_side=dsqrt(dist_pep_side) + dist_pept_group=dsqrt(dist_pept_group) + dist_side_calf=dsqrt(dist_side_calf) + do j=1,3 + pep_side_norm(j)=pep_side(j)/dist_pep_side + side_calf_norm(j)=dist_side_calf + enddo +C now sscale fraction + sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield +C print *,buff_shield,"buff" +C now sscale + if (sh_frac_dist.le.0.0) cycle +C If we reach here it means that this side chain reaches the shielding sphere +C Lets add him to the list for gradient + ishield_list(i)=ishield_list(i)+1 +C ishield_list is a list of non 0 side-chain that contribute to factor gradient +C this list is essential otherwise problem would be O3 + shield_list(ishield_list(i),i)=k +C Lets have the sscale value + if (sh_frac_dist.gt.1.0) then + scale_fac_dist=1.0d0 + do j=1,3 + sh_frac_dist_grad(j)=0.0d0 + enddo + else + scale_fac_dist=-sh_frac_dist*sh_frac_dist + & *(2.0*sh_frac_dist-3.0d0) + fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2) + & /dist_pep_side/buff_shield*0.5 +C remember for the final gradient multiply sh_frac_dist_grad(j) +C for side_chain by factor -2 ! + do j=1,3 + sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) +C print *,"jestem",scale_fac_dist,fac_help_scale, +C & sh_frac_dist_grad(j) + enddo + endif +C if ((i.eq.3).and.(k.eq.2)) then +C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist +C & ,"TU" +C endif + +C this is what is now we have the distance scaling now volume... + short=short_r_sidechain(itype(k)) + long=long_r_sidechain(itype(k)) + costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2) +C now costhet_grad +C costhet=0.0d0 + costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4 +C costhet_fac=0.0d0 + do j=1,3 + costhet_grad(j)=costhet_fac*pep_side(j) + enddo +C remember for the final gradient multiply costhet_grad(j) +C for side_chain by factor -2 ! +C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 +C pep_side0pept_group is vector multiplication + pep_side0pept_group=0.0 + do j=1,3 + pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) + enddo + cosalfa=(pep_side0pept_group/ + & (dist_pep_side*dist_side_calf)) + fac_alfa_sin=1.0-cosalfa**2 + fac_alfa_sin=dsqrt(fac_alfa_sin) + rkprim=fac_alfa_sin*(long-short)+short +C now costhet_grad + cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2) + cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4 + + do j=1,3 + cosphi_grad_long(j)=cosphi_fac*pep_side(j) + &+cosphi**3*0.5/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa/ + &((dist_pep_side*dist_side_calf))* + &((side_calf(j))-cosalfa* + &((pep_side(j)/dist_pep_side)*dist_side_calf)) + + cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa + &/((dist_pep_side*dist_side_calf))* + &(pep_side(j)- + &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) + enddo + + VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi) + & /VSolvSphere_div + & *wshield +C now the gradient... +C grad_shield is gradient of Calfa for peptide groups +C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist, +C & costhet,cosphi +C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group, +C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k) + do j=1,3 + grad_shield(j,i)=grad_shield(j,i) +C gradient po skalowaniu + & +(sh_frac_dist_grad(j) +C gradient po costhet + &-scale_fac_dist*costhet_grad(j)/(1.0-costhet) + &-scale_fac_dist*(cosphi_grad_long(j)) + &/(1.0-cosphi) )*div77_81 + &*VofOverlap +C grad_shield_side is Cbeta sidechain gradient + grad_shield_side(j,ishield_list(i),i)= + & (sh_frac_dist_grad(j)*(-2.0d0) + & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet) + & +scale_fac_dist*(cosphi_grad_long(j)) + & *2.0d0/(1.0-cosphi)) + & *div77_81*VofOverlap + + grad_shield_loc(j,ishield_list(i),i)= + & scale_fac_dist*cosphi_grad_loc(j) + & *2.0d0/(1.0-cosphi) + & *div77_81*VofOverlap + enddo + VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist + enddo + fac_shield(i)=VolumeTotal*div77_81+div4_81 +C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) + enddo + return + end +C-------------------------------------------------------------------------- +C first for shielding is setting of function of side-chains + subroutine set_shield_fac2 + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SHIELD' + include 'COMMON.INTERACT' +C this is the squar root 77 devided by 81 the epislion in lipid (in protein) + double precision div77_81/0.974996043d0/, + &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) + +C the vector between center of side_chain and peptide group + double precision pep_side(3),long,side_calf(3), + &pept_group(3),costhet_grad(3),cosphi_grad_long(3), + &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) +C the line belowe needs to be changed for FGPROC>1 + do i=1,nres-1 + if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle + ishield_list(i)=0 +Cif there two consequtive dummy atoms there is no peptide group between them +C the line below has to be changed for FGPROC>1 + VolumeTotal=0.0 + do k=1,nres + if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle + dist_pep_side=0.0 + dist_side_calf=0.0 + do j=1,3 +C first lets set vector conecting the ithe side-chain with kth side-chain + pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 +C pep_side(j)=2.0d0 +C and vector conecting the side-chain with its proper calfa + side_calf(j)=c(j,k+nres)-c(j,k) +C side_calf(j)=2.0d0 + pept_group(j)=c(j,i)-c(j,i+1) +C lets have their lenght + dist_pep_side=pep_side(j)**2+dist_pep_side + dist_side_calf=dist_side_calf+side_calf(j)**2 + dist_pept_group=dist_pept_group+pept_group(j)**2 + enddo + dist_pep_side=dsqrt(dist_pep_side) + dist_pept_group=dsqrt(dist_pept_group) + dist_side_calf=dsqrt(dist_side_calf) + do j=1,3 + pep_side_norm(j)=pep_side(j)/dist_pep_side + side_calf_norm(j)=dist_side_calf + enddo +C now sscale fraction + sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield +C print *,buff_shield,"buff" +C now sscale + if (sh_frac_dist.le.0.0) cycle +C If we reach here it means that this side chain reaches the shielding sphere +C Lets add him to the list for gradient + ishield_list(i)=ishield_list(i)+1 +C ishield_list is a list of non 0 side-chain that contribute to factor gradient +C this list is essential otherwise problem would be O3 + shield_list(ishield_list(i),i)=k +C Lets have the sscale value + if (sh_frac_dist.gt.1.0) then + scale_fac_dist=1.0d0 + do j=1,3 + sh_frac_dist_grad(j)=0.0d0 + enddo + else + scale_fac_dist=-sh_frac_dist*sh_frac_dist + & *(2.0d0*sh_frac_dist-3.0d0) + fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) + & /dist_pep_side/buff_shield*0.5d0 +C remember for the final gradient multiply sh_frac_dist_grad(j) +C for side_chain by factor -2 ! + do j=1,3 + sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) +C sh_frac_dist_grad(j)=0.0d0 +C scale_fac_dist=1.0d0 +C print *,"jestem",scale_fac_dist,fac_help_scale, +C & sh_frac_dist_grad(j) + enddo + endif +C this is what is now we have the distance scaling now volume... + short=short_r_sidechain(itype(k)) + long=long_r_sidechain(itype(k)) + costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2) + sinthet=short/dist_pep_side*costhet +C now costhet_grad +C costhet=0.6d0 +C sinthet=0.8 + costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4 +C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet +C & -short/dist_pep_side**2/costhet) +C costhet_fac=0.0d0 + do j=1,3 + costhet_grad(j)=costhet_fac*pep_side(j) + enddo +C remember for the final gradient multiply costhet_grad(j) +C for side_chain by factor -2 ! +C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 +C pep_side0pept_group is vector multiplication + pep_side0pept_group=0.0d0 + do j=1,3 + pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) + enddo + cosalfa=(pep_side0pept_group/ + & (dist_pep_side*dist_side_calf)) + fac_alfa_sin=1.0d0-cosalfa**2 + fac_alfa_sin=dsqrt(fac_alfa_sin) + rkprim=fac_alfa_sin*(long-short)+short +C rkprim=short + +C now costhet_grad + cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2) +C cosphi=0.6 + cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4 + sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ + & dist_pep_side**2) +C sinphi=0.8 + do j=1,3 + cosphi_grad_long(j)=cosphi_fac*pep_side(j) + &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa/ + &((dist_pep_side*dist_side_calf))* + &((side_calf(j))-cosalfa* + &((pep_side(j)/dist_pep_side)*dist_side_calf)) +C cosphi_grad_long(j)=0.0d0 + cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa + &/((dist_pep_side*dist_side_calf))* + &(pep_side(j)- + &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) +C cosphi_grad_loc(j)=0.0d0 + enddo +C print *,sinphi,sinthet + VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) + & /VSolvSphere_div +C & *wshield +C now the gradient... + do j=1,3 + grad_shield(j,i)=grad_shield(j,i) +C gradient po skalowaniu + & +(sh_frac_dist_grad(j)*VofOverlap +C gradient po costhet + & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* + &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( + & sinphi/sinthet*costhet*costhet_grad(j) + & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) + & )*wshield +C grad_shield_side is Cbeta sidechain gradient + grad_shield_side(j,ishield_list(i),i)= + & (sh_frac_dist_grad(j)*(-2.0d0) + & *VofOverlap + & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0* + &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( + & sinphi/sinthet*costhet*costhet_grad(j) + & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) + & )*wshield + + grad_shield_loc(j,ishield_list(i),i)= + & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0* + &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*( + & sinthet/sinphi*cosphi*cosphi_grad_loc(j) + & )) + & *wshield + enddo + VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist + enddo + fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield) +C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) +C write(2,*) "TU",rpp(1,1),short,long,buff_shield + enddo + return + end +C-------------------------------------------------------------------------- + double precision function tschebyshev(m,n,x,y) + implicit none + include "DIMENSIONS" + integer i,m,n + double precision x(n),y,yy(0:maxvar),aux +c Tschebyshev polynomial. Note that the first term is omitted +c m=0: the constant term is included +c m=1: the constant term is not included + yy(0)=1.0d0 + yy(1)=y + do i=2,n + yy(i)=2*yy(1)*yy(i-1)-yy(i-2) + enddo + aux=0.0d0 + do i=m,n + aux=aux+x(i)*yy(i) + enddo + tschebyshev=aux + return + end +C-------------------------------------------------------------------------- + double precision function gradtschebyshev(m,n,x,y) + implicit none + include "DIMENSIONS" + integer i,m,n + double precision x(n+1),y,yy(0:maxvar),aux +c Tschebyshev polynomial. Note that the first term is omitted +c m=0: the constant term is included +c m=1: the constant term is not included + yy(0)=1.0d0 + yy(1)=2.0d0*y + do i=2,n + yy(i)=2*y*yy(i-1)-yy(i-2) + enddo + aux=0.0d0 + do i=m,n + aux=aux+x(i+1)*yy(i)*(i+1) +C print *, x(i+1),yy(i),i + enddo + gradtschebyshev=aux + return + end +c---------------------------------------------------------------------------- + double precision function sscale2(r,r_cut,r0,rlamb) + implicit none + double precision r,gamm,r_cut,r0,rlamb,rr + rr = dabs(r-r0) +c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb +c write (2,*) "rr",rr + if(rr.lt.r_cut-rlamb) then + sscale2=1.0d0 + else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then + gamm=(rr-(r_cut-rlamb))/rlamb + sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0) + else + sscale2=0d0 + endif + return + end +C----------------------------------------------------------------------- + double precision function sscalgrad2(r,r_cut,r0,rlamb) + implicit none + double precision r,gamm,r_cut,r0,rlamb,rr + rr = dabs(r-r0) + if(rr.lt.r_cut-rlamb) then + sscalgrad2=0.0d0 + else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then + gamm=(rr-(r_cut-rlamb))/rlamb + if (r.ge.r0) then + sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb + else + sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb + endif + else + sscalgrad2=0.0d0 + endif + return + end +c---------------------------------------------------------------------------- + subroutine e_saxs(Esaxs_constr) + implicit none + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + include "COMMON.SETUP" + integer IERR +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.CONTROL' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.LANGEVIN' + include 'COMMON.SAXS' +c + double precision Esaxs_constr + integer i,iint,j,k,l + double precision PgradC(maxSAXS,3,maxres), + & PgradX(maxSAXS,3,maxres) +#ifdef MPI + double precision PgradC_(maxSAXS,3,maxres), + & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS) +#endif + double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC, + & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC, + & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1, + & auxX,auxX1,CACAgrad,Cnorm + double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2 + double precision dist + external dist +c SAXS restraint penalty function +#ifdef DEBUG + write(iout,*) "------- SAXS penalty function start -------" + write (iout,*) "nsaxs",nsaxs + write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e + write (iout,*) "Psaxs" + do i=1,nsaxs + write (iout,'(i5,e15.5)') i, Psaxs(i) + enddo +#endif + Esaxs_constr = 0.0d0 + do k=1,nsaxs + Pcalc(k)=0.0d0 + do j=1,nres + do l=1,3 + PgradC(k,l,j)=0.0d0 + PgradX(k,l,j)=0.0d0 + enddo + enddo + enddo + do i=iatsc_s,iatsc_e + if (itype(i).eq.ntyp1) cycle + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + if (itype(j).eq.ntyp1) cycle +#ifdef ALLSAXS + dijCACA=dist(i,j) + dijCASC=dist(i,j+nres) + dijSCCA=dist(i+nres,j) + dijSCSC=dist(i+nres,j+nres) + sigma2CACA=2.0d0/(pstok**2) + sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2) + sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2) + sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2) + do k=1,nsaxs + dk = distsaxs(k) + expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2) + if (itype(j).ne.10) then + expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2) + else + endif + expCASC = 0.0d0 + if (itype(i).ne.10) then + expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2) + else + expSCCA = 0.0d0 + endif + if (itype(i).ne.10 .and. itype(j).ne.10) then + expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2) + else + expSCSC = 0.0d0 + endif + Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC +#ifdef DEBUG + write(iout,*) "i j k Pcalc",i,j,Pcalc(k) +#endif + CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA + CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC + SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA + SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC + do l=1,3 +c CA CA + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux +c CA SC + if (itype(j).ne.10) then + aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + PgradX(k,l,j) = PgradX(k,l,j)+aux + endif +c SC CA + if (itype(i).ne.10) then + aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA + PgradX(k,l,i) = PgradX(k,l,i)-aux + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + endif +c SC SC + if (itype(i).ne.10 .and. itype(j).ne.10) then + aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + PgradX(k,l,i) = PgradX(k,l,i)-aux + PgradX(k,l,j) = PgradX(k,l,j)+aux + endif + enddo ! l + enddo ! k +#else + dijCACA=dist(i,j) + sigma2CACA=scal_rad**2*0.25d0/ + & (restok(itype(j))**2+restok(itype(i))**2) + + IF (saxs_cutoff.eq.0) THEN + do k=1,nsaxs + dk = distsaxs(k) + expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2) + Pcalc(k) = Pcalc(k)+expCACA + CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA + do l=1,3 + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + enddo ! l + enddo ! k + ELSE + rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA) + do k=1,nsaxs + dk = distsaxs(k) +c write (2,*) "ijk",i,j,k + sss2 = sscale2(dijCACA,rrr,dk,0.3d0) + if (sss2.eq.0.0d0) cycle + ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0) + expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2 + Pcalc(k) = Pcalc(k)+expCACA +#ifdef DEBUG + write(iout,*) "i j k Pcalc",i,j,Pcalc(k) +#endif + CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+ + & ssgrad2*expCACA/sss2 + do l=1,3 +c CA CA + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)+aux + PgradC(k,l,j) = PgradC(k,l,j)-aux + enddo ! l + enddo ! k + ENDIF +#endif + enddo ! j + enddo ! iint + enddo ! i +#ifdef MPI + if (nfgtasks.gt.1) then + call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION, + & MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do k=1,nsaxs + Pcalc(k) = Pcalc_(k) + enddo + endif + call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do i=1,nres + do l=1,3 + do k=1,nsaxs + PgradC(k,l,i) = PgradC_(k,l,i) + enddo + enddo + enddo + endif +#ifdef ALLSAXS + call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do i=1,nres + do l=1,3 + do k=1,nsaxs + PgradX(k,l,i) = PgradX_(k,l,i) + enddo + enddo + enddo + endif +#endif + endif +#endif +#ifdef MPI + if (fg_rank.eq.king) then +#endif + Cnorm = 0.0d0 + do k=1,nsaxs + Cnorm = Cnorm + Pcalc(k) + enddo + Esaxs_constr = dlog(Cnorm)-wsaxs0 + do k=1,nsaxs + if (Pcalc(k).gt.0.0d0) + & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k)) +#ifdef DEBUG + write (iout,*) "k",k," Esaxs_constr",Esaxs_constr +#endif + enddo +#ifdef DEBUG + write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr +#endif + do i=nnt,nct + do l=1,3 + auxC=0.0d0 + auxC1=0.0d0 + auxX=0.0d0 + auxX1=0.d0 + do k=1,nsaxs + if (Pcalc(k).gt.0) + & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k) + auxC1 = auxC1+PgradC(k,l,i) +#ifdef ALLSAXS + auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k) + auxX1 = auxX1+PgradX(k,l,i) +#endif + enddo + gsaxsC(l,i) = auxC - auxC1/Cnorm +#ifdef ALLSAXS + gsaxsX(l,i) = auxX - auxX1/Cnorm +#endif +c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm), +c * " gradX",wsaxs*(auxX - auxX1/Cnorm) + enddo + enddo +#ifdef MPI + endif +#endif + return + end +c---------------------------------------------------------------------------- + subroutine e_saxsC(Esaxs_constr) + implicit none + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + include "COMMON.SETUP" + integer IERR +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.CONTROL' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.LANGEVIN' + include 'COMMON.SAXS' +c + double precision Esaxs_constr + integer i,iint,j,k,l + double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc_,logPtot +#ifdef MPI + double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_ +#endif + double precision dk,dijCASPH,dijSCSPH, + & sigma2CA,sigma2SC,expCASPH,expSCSPH, + & CASPHgrad,SCSPHgrad,aux,auxC,auxC1, + & auxX,auxX1,Cnorm +c SAXS restraint penalty function +#ifdef DEBUG + write(iout,*) "------- SAXS penalty function start -------" + write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start, + & " isaxs_end",isaxs_end + write (iout,*) "nnt",nnt," ntc",nct + do i=nnt,nct + write(iout,'(a6,i5,3f10.5,5x,2f10.5)') + & "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i)) + enddo + do i=nnt,nct + write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3) + enddo +#endif + Esaxs_constr = 0.0d0 + logPtot=0.0d0 + do j=isaxs_start,isaxs_end + Pcalc_=0.0d0 + do i=1,nres + do l=1,3 + PgradC(l,i)=0.0d0 + PgradX(l,i)=0.0d0 + enddo + enddo + do i=nnt,nct + dijCASPH=0.0d0 + dijSCSPH=0.0d0 + do l=1,3 + dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2 + enddo + if (itype(i).ne.10) then + do l=1,3 + dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2 + enddo + endif + sigma2CA=2.0d0/pstok**2 + sigma2SC=4.0d0/restok(itype(i))**2 + expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH) + expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH) + Pcalc_ = Pcalc_+expCASPH+expSCSPH +#ifdef DEBUG + write(*,*) "processor i j Pcalc", + & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc_ +#endif + CASPHgrad = sigma2CA*expCASPH + SCSPHgrad = sigma2SC*expSCSPH + do l=1,3 + aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad + PgradX(l,i) = PgradX(l,i) + aux + PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux + enddo ! l + enddo ! i + do i=nnt,nct + do l=1,3 + gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc_ + gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc_ + enddo + enddo + logPtot = logPtot - dlog(Pcalc_) +c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc_), +c & " logPtot",logPtot + enddo ! j +#ifdef MPI + if (nfgtasks.gt.1) then +c write (iout,*) "logPtot before reduction",logPtot + call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION, + & MPI_SUM,king,FG_COMM,IERR) + logPtot = logPtot_ +c write (iout,*) "logPtot after reduction",logPtot + call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do i=1,nres + do l=1,3 + gsaxsC(l,i) = gsaxsC_(l,i) + enddo + enddo + endif + call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do i=1,nres + do l=1,3 + gsaxsX(l,i) = gsaxsX_(l,i) + enddo + enddo + endif + endif +#endif + Esaxs_constr = logPtot + return + end +C-------------------------------------------------------------------------- +c MODELLER restraint function + subroutine e_modeller(ehomology_constr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + integer nnn, i, j, k, ki, irec, l + integer katy, odleglosci, test7 + real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template) + real*8 distance(max_template),distancek(max_template), + & min_odl,godl(max_template),dih_diff(max_template) + +c +c FP - 30/10/2014 Temporary specifications for homology restraints +c + double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta, + & sgtheta + double precision, dimension (maxres) :: guscdiff,usc_diff + double precision, dimension (max_template) :: + & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3, + & theta_diff + + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'COMMON.HOMRESTR' + include 'COMMON.HOMOLOGY' + include 'COMMON.SETUP' + include 'COMMON.NAMES' + + do i=1,max_template + distancek(i)=9999999.9 + enddo + + odleg=0.0d0 + +c Pseudo-energy and gradient from homology restraints (MODELLER-like +c function) +C AL 5/2/14 - Introduce list of restraints +c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d +#ifdef DEBUG + write(iout,*) "------- dist restrs start -------" +#endif + do ii = link_start_homo,link_end_homo + i = ires_homo(ii) + j = jres_homo(ii) + dij=dist(i,j) +c write (iout,*) "dij(",i,j,") =",dij + nexl=0 + do k=1,constr_homology + if(.not.l_homo(k,ii)) then + nexl=nexl+1 + cycle + endif + distance(k)=odl(k,ii)-dij +c write (iout,*) "distance(",k,") =",distance(k) +c +c For Gaussian-type Urestr +c + distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument +c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii) +c write (iout,*) "distancek(",k,") =",distancek(k) +c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii) +c +c For Lorentzian-type Urestr +c + if (waga_dist.lt.0.0d0) then + sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii)) + distancek(k)=distance(k)**2/(sigma_odlir(k,ii)* + & (distance(k)**2+sigma_odlir(k,ii)**2)) + endif + enddo + +c min_odl=minval(distancek) + do kk=1,constr_homology + if(l_homo(kk,ii)) then + min_odl=distancek(kk) + exit + endif + enddo + do kk=1,constr_homology + if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl) + & min_odl=distancek(kk) + enddo +c write (iout,* )"min_odl",min_odl +#ifdef DEBUG + write (iout,*) "ij dij",i,j,dij + write (iout,*) "distance",(distance(k),k=1,constr_homology) + write (iout,*) "distancek",(distancek(k),k=1,constr_homology) + write (iout,* )"min_odl",min_odl +#endif +#ifdef OLDRESTR + odleg2=0.0d0 +#else + if (waga_dist.ge.0.0d0) then + odleg2=nexl + else + odleg2=0.0d0 + endif +#endif + do k=1,constr_homology +c Nie wiem po co to liczycie jeszcze raz! +c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/ +c & (2*(sigma_odl(i,j,k))**2)) + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + godl(k)=dexp(-distancek(k)+min_odl) + odleg2=odleg2+godl(k) +c +c For Lorentzian-type Urestr +c + else + odleg2=odleg2+distancek(k) + endif + +ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3, +ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=", +ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1), +ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k) + + enddo +c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents +c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps +#ifdef DEBUG + write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents + write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps +#endif + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + odleg=odleg-dLOG(odleg2/constr_homology)+min_odl +c +c For Lorentzian-type Urestr +c + else + odleg=odleg+odleg2/constr_homology + endif +c +#ifdef GRAD +c write (iout,*) "odleg",odleg ! sum of -ln-s +c Gradient +c +c For Gaussian-type Urestr +c + if (waga_dist.ge.0.0d0) sum_godl=odleg2 + sum_sgodl=0.0d0 + do k=1,constr_homology +c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) +c & *waga_dist)+min_odl +c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist +c + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c For Gaussian-type Urestr +c + sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd +c +c For Lorentzian-type Urestr +c + else + sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ + & sigma_odlir(k,ii)**2)**2) + endif + sum_sgodl=sum_sgodl+sgodl + +c sgodl2=sgodl2+sgodl +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1" +c write(iout,*) "constr_homology=",constr_homology +c write(iout,*) i, j, k, "TEST K" + enddo + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + grad_odl3=waga_homology(iset)*waga_dist + & *sum_sgodl/(sum_godl*dij) +c +c For Lorentzian-type Urestr +c + else +c Original grad expr modified by analogy w Gaussian-type Urestr grad +c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl + grad_odl3=-waga_homology(iset)*waga_dist* + & sum_sgodl/(constr_homology*dij) + endif +c +c grad_odl3=sum_sgodl/(sum_godl*dij) + + +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2" +c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2), +c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) + +ccc write(iout,*) godl, sgodl, grad_odl3 + +c grad_odl=grad_odl+grad_odl3 + + do jik=1,3 + ggodl=grad_odl3*(c(jik,i)-c(jik,j)) +ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1)) +ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) + ghpbc(jik,i)=ghpbc(jik,i)+ggodl + ghpbc(jik,j)=ghpbc(jik,j)-ggodl +ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) +c if (i.eq.25.and.j.eq.27) then +c write(iout,*) "jik",jik,"i",i,"j",j +c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl +c write(iout,*) "grad_odl3",grad_odl3 +c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j) +c write(iout,*) "ggodl",ggodl +c write(iout,*) "ghpbc(",jik,i,")", +c & ghpbc(jik,i),"ghpbc(",jik,j,")", +c & ghpbc(jik,j) +c endif + enddo +#endif +ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=", +ccc & dLOG(odleg2),"-odleg=", -odleg + + enddo ! ii-loop for dist +#ifdef DEBUG + write(iout,*) "------- dist restrs end -------" +c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or. +c & waga_d.eq.1.0d0) call sum_gradient +#endif +c Pseudo-energy and gradient from dihedral-angle restraints from +c homology templates +c write (iout,*) "End of distance loop" +c call flush(iout) + kat=0.0d0 +c write (iout,*) idihconstr_start_homo,idihconstr_end_homo +#ifdef DEBUG + write(iout,*) "------- dih restrs start -------" + do i=idihconstr_start_homo,idihconstr_end_homo + write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg) + enddo +#endif + do i=idihconstr_start_homo,idihconstr_end_homo + kat2=0.0d0 +c betai=beta(i,i+1,i+2,i+3) + betai = phi(i) +c write (iout,*) "betai =",betai + do k=1,constr_homology + dih_diff(k)=pinorm(dih(k,i)-betai) +c write (iout,*) "dih_diff(",k,") =",dih_diff(k) +c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)= +c & -(6.28318-dih_diff(i,k)) +c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)= +c & 6.28318+dih_diff(i,k) +#ifdef OLD_DIHED + kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument +#else + kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) +#endif +c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i) + gdih(k)=dexp(kat3) + kat2=kat2+gdih(k) +c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3) +c write(*,*)"" + enddo +c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps +c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps +#ifdef DEBUG + write (iout,*) "i",i," betai",betai," kat2",kat2 + write (iout,*) "gdih",(gdih(k),k=1,constr_homology) +#endif + if (kat2.le.1.0d-14) cycle + kat=kat-dLOG(kat2/constr_homology) +c write (iout,*) "kat",kat ! sum of -ln-s + +ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=", +ccc & dLOG(kat2), "-kat=", -kat + +#ifdef GRAD +c ---------------------------------------------------------------------- +c Gradient +c ---------------------------------------------------------------------- + + sum_gdih=kat2 + sum_sgdih=0.0d0 + do k=1,constr_homology +#ifdef OLD_DIHED + sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd +#else + sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) +#endif +c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle + sum_sgdih=sum_sgdih+sgdih + enddo +c grad_dih3=sum_sgdih/sum_gdih + grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih + +c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3 +ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) + gloc(i,icg)=gloc(i,icg)+grad_dih3 +c if (i.eq.25) then +c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg) +c endif +ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) +#endif + enddo ! i-loop for dih +#ifdef DEBUG + write(iout,*) "------- dih restrs end -------" +#endif + +c Pseudo-energy and gradient for theta angle restraints from +c homology templates +c FP 01/15 - inserted from econstr_local_test.F, loop structure +c adapted + +c +c For constr_homology reference structures (FP) +c +c Uconst_back_tot=0.0d0 + Eval=0.0d0 + Erot=0.0d0 +c Econstr_back legacy +#ifdef GRAD + do i=1,nres +c do i=ithet_start,ithet_end + dutheta(i)=0.0d0 +c enddo +c do i=loc_start,loc_end + do j=1,3 + duscdiff(j,i)=0.0d0 + duscdiffx(j,i)=0.0d0 + enddo + enddo +#endif +c +c do iref=1,nref +c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end +c write (iout,*) "waga_theta",waga_theta + if (waga_theta.gt.0.0d0) then +#ifdef DEBUG + write (iout,*) "usampl",usampl + write(iout,*) "------- theta restrs start -------" +c do i=ithet_start,ithet_end +c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg) +c enddo +#endif +c write (iout,*) "maxres",maxres,"nres",nres + + do i=ithet_start,ithet_end +c +c do i=1,nfrag_back +c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) +c +c Deviation of theta angles wrt constr_homology ref structures +c + utheta_i=0.0d0 ! argument of Gaussian for single k + gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures +c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop +c over residues in a fragment +c write (iout,*) "theta(",i,")=",theta(i) + do k=1,constr_homology +c +c dtheta_i=theta(j)-thetaref(j,iref) +c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing + theta_diff(k)=thetatpl(k,i)-theta(i) +c + utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument +c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta? + gtheta(k)=dexp(utheta_i) ! + min_utheta_i? + gutheta_i=gutheta_i+dexp(utheta_i) ! Sum of Gaussians (pk) +c Gradient for single Gaussian restraint in subr Econstr_back +c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) +c + enddo +c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps +c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps + +c +#ifdef GRAD +c Gradient for multiple Gaussian restraint + sum_gtheta=gutheta_i + sum_sgtheta=0.0d0 + do k=1,constr_homology +c New generalized expr for multiple Gaussian from Econstr_back + sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd +c +c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form? + sum_sgtheta=sum_sgtheta+sgtheta ! cum variable + enddo +c +c Final value of gradient using same var as in Econstr_back + dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta + & *waga_homology(iset) +c dutheta(i)=sum_sgtheta/sum_gtheta +c +c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight +#endif + Eval=Eval-dLOG(gutheta_i/constr_homology) +c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s +c Uconst_back=Uconst_back+utheta(i) + enddo ! (i-loop for theta) +#ifdef DEBUG + write(iout,*) "------- theta restrs end -------" +#endif + endif +c +c Deviation of local SC geometry +c +c Separation of two i-loops (instructed by AL - 11/3/2014) +c +c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end +c write (iout,*) "waga_d",waga_d + +#ifdef DEBUG + write(iout,*) "------- SC restrs start -------" + write (iout,*) "Initial duscdiff,duscdiffx" + do i=loc_start,loc_end + write (iout,*) i,(duscdiff(jik,i),jik=1,3), + & (duscdiffx(jik,i),jik=1,3) + enddo +#endif + do i=loc_start,loc_end + usc_diff_i=0.0d0 ! argument of Gaussian for single k + guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures +c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy +c write(iout,*) "xxtab, yytab, zztab" +c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i) + do k=1,constr_homology +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c Original sign inverted for calc of gradients (s. Econstr_back) + dyy=-yytpl(k,i)+yytab(i) ! ibid y + dzz=-zztpl(k,i)+zztab(i) ! ibid z +c write(iout,*) "dxx, dyy, dzz" +c write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz +c + usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument +c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d? +c uscdiffk(k)=usc_diff(i) + guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff + guscdiff(i)=guscdiff(i)+dexp(usc_diff_i) !Sum of Gaussians (pk) +c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), +c & xxref(j),yyref(j),zzref(j) + enddo +c +c Gradient +c +c Generalized expression for multiple Gaussian acc to that for a single +c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014) +c +c Original implementation +c sum_guscdiff=guscdiff(i) +c +c sum_sguscdiff=0.0d0 +c do k=1,constr_homology +c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d? +c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff +c sum_sguscdiff=sum_sguscdiff+sguscdiff +c enddo +c +c Implementation of new expressions for gradient (Jan. 2015) +c +c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !? +#ifdef GRAD + do k=1,constr_homology +c +c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong +c before. Now the drivatives should be correct +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c Original sign inverted for calc of gradients (s. Econstr_back) + dyy=-yytpl(k,i)+yytab(i) ! ibid y + dzz=-zztpl(k,i)+zztab(i) ! ibid z +c +c New implementation +c + sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong! + & sigma_d(k,i) ! for the grad wrt r' +c sum_sguscdiff=sum_sguscdiff+sum_guscdiff +c +c +c New implementation + sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff + do jik=1,3 + duscdiff(jik,i-1)=duscdiff(jik,i-1)+ + & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+ + & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i) + duscdiff(jik,i)=duscdiff(jik,i)+ + & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+ + & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i) + duscdiffx(jik,i)=duscdiffx(jik,i)+ + & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+ + & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i) +c +#ifdef DEBUG + write(iout,*) "jik",jik,"i",i + write(iout,*) "dxx, dyy, dzz" + write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz + write(iout,*) "guscdiff2(",k,")",guscdiff2(k) +c write(iout,*) "sum_sguscdiff",sum_sguscdiff +cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i) +c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i) +c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i) +c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i) +c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i) +c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i) +c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i) +c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i) +c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i) +c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1) +c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i) +c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i) +c endif +#endif + enddo + enddo +#endif +c +c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required? +c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ? +c +c write (iout,*) i," uscdiff",uscdiff(i) +c +c Put together deviations from local geometry + +c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ +c & wfrag_back(3,i,iset)*uscdiff(i) + Erot=Erot-dLOG(guscdiff(i)/constr_homology) +c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s +c Uconst_back=Uconst_back+usc_diff(i) +c +c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?) +c +c New implment: multiplied by sum_sguscdiff +c + + enddo ! (i-loop for dscdiff) + +c endif + +#ifdef DEBUG + write(iout,*) "------- SC restrs end -------" + write (iout,*) "------ After SC loop in e_modeller ------" + do i=loc_start,loc_end + write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3) + write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3) + enddo + if (waga_theta.eq.1.0d0) then + write (iout,*) "in e_modeller after SC restr end: dutheta" + do i=ithet_start,ithet_end + write (iout,*) i,dutheta(i) + enddo + endif + if (waga_d.eq.1.0d0) then + write (iout,*) "e_modeller after SC loop: duscdiff/x" + do i=1,nres + write (iout,*) i,(duscdiff(j,i),j=1,3) + write (iout,*) i,(duscdiffx(j,i),j=1,3) + enddo + endif +#endif + +c Total energy from homology restraints +#ifdef DEBUG + write (iout,*) "odleg",odleg," kat",kat + write (iout,*) "odleg",odleg," kat",kat + write (iout,*) "Eval",Eval," Erot",Erot + write (iout,*) "waga_homology(",iset,")",waga_homology(iset) + write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle + write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d +#endif +c +c Addition of energy of theta angle and SC local geom over constr_homologs ref strs +c +c ehomology_constr=odleg+kat +c +c For Lorentzian-type Urestr +c + + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c +c ehomology_constr=(waga_dist*odleg+waga_angle*kat+ +c & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) + ehomology_constr=waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot +c write (iout,*) "ehomology_constr=",ehomology_constr + else +c +c For Lorentzian-type Urestr +c +c ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ +c & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) + ehomology_constr=-waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot +c write (iout,*) "ehomology_constr=",ehomology_constr + endif +#ifdef DEBUG + write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat, + & "Eval",waga_theta,eval, + & "Erot",waga_d,Erot + write (iout,*) "ehomology_constr",ehomology_constr +#endif + return + + 748 format(a8,f12.3,a6,f12.3,a7,f12.3) + 747 format(a12,i4,i4,i4,f8.3,f8.3) + 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3) + 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3) + 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X, + & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3) + end diff --git a/source/cluster/wham/src-HCD/energy_p_new.F.safe b/source/cluster/wham/src-HCD/energy_p_new.F.safe new file mode 100644 index 0000000..a71e55b --- /dev/null +++ b/source/cluster/wham/src-HCD/energy_p_new.F.safe @@ -0,0 +1,9056 @@ + subroutine etotal(energia,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + +#ifndef ISNAN + external proc_proc +#endif +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif + + include 'COMMON.IOUNITS' + double precision energia(0:max_ene),energia1(0:max_ene+1) +#ifdef MPL + include 'COMMON.INFO' + external d_vadd + integer ready +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.SHIELD' + include 'COMMON.CONTROL' + double precision fact(6) +cd write(iout, '(a,i2)')'Calling etotal ipot=',ipot +cd print *,'nnt=',nnt,' nct=',nct +C +C Compute the side-chain and electrostatic interaction energy +C + goto (101,102,103,104,105) ipot +C Lennard-Jones potential. + 101 call elj(evdw,evdw_t) +cd print '(a)','Exit ELJ' + goto 106 +C Lennard-Jones-Kihara potential (shifted). + 102 call eljk(evdw,evdw_t) + goto 106 +C Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp(evdw,evdw_t) + goto 106 +C Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb(evdw,evdw_t) + goto 106 +C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv(evdw,evdw_t) +C +C Calculate electrostatic (H-bonding) energy of the main chain. +C + 106 continue +C write(iout,*) "shield_mode",shield_mode,ethetacnstr + if (shield_mode.eq.1) then + call set_shield_fac + else if (shield_mode.eq.2) then + call set_shield_fac2 + endif + call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) +C +C Calculate excluded-volume interaction energy between peptide groups +C and side chains. +C + call escp(evdw2,evdw2_14) +c +c Calculate the bond-stretching energy +c + call ebond(estr) +c write (iout,*) "estr",estr +C +C Calculate the disulfide-bridge and other energy and the contributions +C from other distance constraints. +cd print *,'Calling EHPB' + call edis(ehpb) +cd print *,'EHPB exitted succesfully.' +C +C Calculate the virtual-bond-angle energy. +C + call ebend(ebe,ethetacnstr) +cd print *,'Bend energy finished.' +C +C Calculate the SC local energy. +C + call esc(escloc) +cd print *,'SCLOC energy finished.' +C +C Calculate the virtual-bond torsional energy. +C +cd print *,'nterm=',nterm + call etor(etors,edihcnstr,fact(1)) +C +C 6/23/01 Calculate double-torsional energy +C + call etor_d(etors_d,fact(2)) +C +C 21/5/07 Calculate local sicdechain correlation energy +C + call eback_sc_corr(esccor) + + if (wliptran.gt.0) then + call Eliptransfer(eliptran) + endif + +C +C 12/1/95 Multi-body terms +C + n_corr=0 + n_corr1=0 + if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 + & .or. wturn6.gt.0.0d0) then +c print *,"calling multibody_eello" + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +c write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1 +c print *,ecorr,ecorr5,ecorr6,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) then + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) + endif + write (iout,*) "ft(6)",fact(6),wliptran,eliptran +#ifdef SPLITELE + if (shield_mode.gt.0) then + etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2 + & +welec*fact(1)*ees + & +fact(1)*wvdwpp*evdw1 + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran + else + etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees + & +wvdwpp*evdw1 + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran + endif +#else + if (shield_mode.gt.0) then + etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2 + & +welec*fact(1)*(ees+evdw1) + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran + else + etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2 + & +welec*fact(1)*(ees+evdw1) + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran + endif +#endif + + energia(0)=etot + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(17)=evdw2_14 +#else + energia(2)=evdw2 + energia(17)=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(18)=estr + energia(19)=esccor + energia(20)=edihcnstr + energia(21)=evdw_t + energia(24)=ethetacnstr + energia(22)=eliptran +c detecting NaNQ +#ifdef ISNAN +#ifdef AIX + if (isnan(etot).ne.0) energia(0)=1.0d+99 +#else + if (isnan(etot)) energia(0)=1.0d+99 +#endif +#else + i=0 +#ifdef WINPGI + idumm=proc_proc(etot,i) +#else + call proc_proc(etot,i) +#endif + if(i.eq.1)energia(0)=1.0d+99 +#endif +#ifdef MPL +c endif +#endif + if (calc_grad) then +C +C Sum up the components of the Cartesian gradient. +C +#ifdef SPLITELE + do i=1,nct + do j=1,3 + if (shield_mode.eq.0) then + gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+ + & wbond*gradb(j,i)+ + & wstrain*ghpbc(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) + 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*fact(2)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + else + gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i) + & +fact(1)*wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+ + & wbond*gradb(j,i)+ + & wstrain*ghpbc(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) + & +welec*gshieldc(j,i) + & +welec*gshieldc_loc(j,i) + & +wcorr*gshieldc_ec(j,i) + & +wcorr*gshieldc_loc_ec(j,i) + & +wturn3*gshieldc_t3(j,i) + & +wturn3*gshieldc_loc_t3(j,i) + & +wturn4*gshieldc_t4(j,i) + & +wturn4*gshieldc_loc_t4(j,i) + & +wel_loc*gshieldc_ll(j,i) + & +wel_loc*gshieldc_loc_ll(j,i) + + gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i) + & +fact(1)*wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*fact(2)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + & +welec*gshieldx(j,i) + & +wcorr*gshieldx_ec(j,i) + & +wturn3*gshieldx_t3(j,i) + & +wturn4*gshieldx_t4(j,i) + & +wel_loc*gshieldx_ll(j,i) + + + endif + enddo +#else + do i=1,nct + do j=1,3 + if (shield_mode.eq.0) then + gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+ + & wbond*gradb(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) + 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*fact(1)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + else + gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+ + & fact(1)*wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+ + & wbond*gradb(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) + gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+ + & fact(1)*wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*fact(1)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + endif + enddo +#endif + enddo + + + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i) + & +wcorr5*fact(4)*g_corr5_loc(i) + & +wcorr6*fact(5)*g_corr6_loc(i) + & +wturn4*fact(3)*gel_loc_turn4(i) + & +wturn3*fact(2)*gel_loc_turn3(i) + & +wturn6*fact(5)*gel_loc_turn6(i) + & +wel_loc*fact(2)*gel_loc_loc(i) +c & +wsccor*fact(1)*gsccor_loc(i) +c ROZNICA Z WHAMem + enddo + endif + if (dyn_ss) call dyn_set_nss + return + end +C------------------------------------------------------------------------ + subroutine enerprint(energia,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + double precision energia(0:max_ene),fact(6) + etot=energia(0) + evdw=energia(1)+fact(6)*energia(21) +#ifdef SCP14 + evdw2=energia(2)+energia(17) +#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) + esccor=energia(19) + edihcnstr=energia(20) + estr=energia(18) + ethetacnstr=energia(24) +#ifdef SPLITELE + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1, + & wvdwpp, + & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1), + & etors_d,wtor_d*fact(2),ehpb,wstrain, + & ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), + & eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2), + & eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5), + & esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,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 elec)'/ + & '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)'/ + & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'ETOT= ',1pE16.6,' (total)') +#else + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond, + & ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2, + & ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4), + & ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2), + & eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3), + & eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor, + & edihcnstr,ethetacnstr,ebr*nss,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)'/ + & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'ETOT= ',1pE16.6,' (total)') +#endif + return + end +C----------------------------------------------------------------------- + subroutine elj(evdw,evdw_t) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJ potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include "DIMENSIONS.COMPAR" + parameter (accur=1.0d-10) + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.TORSION' + include 'COMMON.SBRIDGE' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.CONTACTS' + dimension gg(3) + integer icant + external icant +cd print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon +c ROZNICA DODANE Z WHAM +c do i=1,210 +c do j=1,2 +c eneps_temp(j,i)=0.0d0 +c enddo +c enddo +cROZNICA + + evdw=0.0D0 + evdw_t=0.0d0 + 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) +C Change 12/1/95 + num_conti=0 +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) +cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +cd & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=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 +C Change 12/1/95 to calculate four-body interactions + rij=xj*xj+yj*yj+zj*zj + rrij=1.0D0/rij +c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 + e1=fac*fac*aa + e2=fac*bb + evdwij=e1+e2 + ij=icant(itypi,itypj) +c ROZNICA z WHAM +c eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij) +c eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij +c + +cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), +cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, +cd & (c(k,i),k=1,3),(c(k,j),k=1,3) + if (bb.gt.0.0d0) then + evdw=evdw+evdwij + else + evdw_t=evdw_t+evdwij + endif + if (calc_grad) then +C +C Calculate the components of the gradient in DC and X +C + fac=-rrij*(e1+evdwij) + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + enddo + do k=i,j-1 + do l=1,3 + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo + enddo + endif +C +C 12/1/95, revised on 5/20/97 +C +C Calculate the contact function. The ith column of the array JCONT will +C contain the numbers of atoms that make contacts with the atom I (of numbers +C greater than I). The arrays FACONT and GACONT will contain the values of +C the contact function and its derivative. +C +C Uncomment next line, if the correlation interactions include EVDW explicitly. +c if (j.gt.i+1 .and. evdwij.le.0.0D0) then +C Uncomment next line, if the correlation interactions are contact function only + if (j.gt.i+1.and. eps0ij.gt.0.0D0) then + rij=dsqrt(rij) + sigij=sigma(itypi,itypj) + r0ij=rs0(itypi,itypj) +C +C Check whether the SC's are not too far to make a contact. +C + rcut=1.5d0*r0ij + call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) +C Add a new contact, if the SC's are close enough, but not too close (ri' + do k=1,3 + ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) + enddo + endif + do k=1,3 + gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) + enddo + kstart=min0(i+1,j) + kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) + do k=kstart,kend + do l=1,3 + gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) + enddo + enddo + endif + enddo + enddo ! iint + 1225 continue + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time the factor EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C-------------------------------------------------------------------------- + subroutine edis(ehpb) +C +C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.CONTROL' + dimension ggg(3) + ehpb=0.0D0 +cd print *,'edis: nhpb=',nhpb,' fbr=',fbr +cd print *,'link_start=',link_start,' link_end=',link_end + if (link_end.eq.0) return + do i=link_start,link_end +C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a +C CA-CA distance used in regularization of structure. + ii=ihpb(i) + jj=jhpb(i) +C iii and jjj point to the residues for which the distance is assigned. + if (ii.gt.nres) then + iii=ii-nres + jjj=jj-nres + else + iii=ii + jjj=jj + endif +C 24/11/03 AL: SS bridges handled separately because of introducing a specific +C distance and angle dependent SS bond potential. +C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. +C & iabs(itype(jjj)).eq.1) then +C call ssbond_ene(iii,jjj,eij) +C ehpb=ehpb+2*eij +C else + if (.not.dyn_ss .and. i.le.nss) then + 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 + endif !ii.gt.neres + else if (ii.gt.nres .and. jj.gt.nres) then +c Restraints from contact prediction + dd=dist(ii,jj) + if (constr_dist.eq.11) then +C ehpb=ehpb+fordepth(i)**4.0d0 +C & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + ehpb=ehpb+fordepth(i)**4.0d0 + & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + fac=fordepth(i)**4.0d0 + & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd +C write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, +C & ehpb,fordepth(i),dd +C print *,"TUTU" +C write(iout,*) ehpb,"atu?" +C ehpb,"tu?" +C fac=fordepth(i)**4.0d0 +C & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd + else !constr_dist.eq.11 + if (dhpb1(i).gt.0.0d0) then + ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd +c write (iout,*) "beta nmr", +c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + else !dhpb(i).gt.0.00 + +C Calculate the distance between the two points and its difference from the +C target distance. + dd=dist(ii,jj) + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif !dhpb(i).gt.0 + endif +cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, +cd & ' waga=',waga,' fac=',fac + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC distance, we need to calculate the contributions to the +C Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + else !ii.gt.nres +C write(iout,*) "before" + dd=dist(ii,jj) +C write(iout,*) "after",dd + if (constr_dist.eq.11) then + ehpb=ehpb+fordepth(i)**4.0d0 + & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + fac=fordepth(i)**4.0d0 + & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd +C ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i)) +C fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd +C print *,ehpb,"tu?" +C write(iout,*) ehpb,"btu?", +C & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i) +C write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, +C & ehpb,fordepth(i),dd + else + if (dhpb1(i).gt.0.0d0) then + ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd +c write (iout,*) "alph nmr", +c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + else + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +c write (iout,*) "alpha reg",dd,waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif + endif + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC distance, we need to calculate the contributions to the +C Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + do j=iii,jjj-1 + do k=1,3 + ghpbc(k,j)=ghpbc(k,j)+ggg(k) + enddo + enddo + endif + enddo + if (constr_dist.ne.11) ehpb=0.5D0*ehpb + return + end +C-------------------------------------------------------------------------- + subroutine ssbond_ene(i,j,eij) +C +C Calculate the distance and angle dependent SS-bond potential energy +C using a free-energy function derived based on RHF/6-31G** ab initio +C calculations of diethyl disulfide. +C +C A. Liwo and U. Kozlowska, 11/24/03 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + double precision erij(3),dcosom1(3),dcosom2(3),gg(3) + itypi=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) + itypj=iabs(itype(j)) + dscj_inv=dsc_inv(itypj) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + rij=1.0d0/rij + deltad=rij-d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) + & +akct*deltad*deltat12 + & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi +c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, +c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, +c & " deltat12",deltat12," eij",eij + ed=2*akcm*deltad+akct*deltat12 + pom1=akct*deltad + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + do k=1,3 + gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo + do k=1,3 + ghpbx(k,i)=ghpbx(k,i)-gg(k) + & +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv + ghpbx(k,j)=ghpbx(k,j)+gg(k) + & +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv + enddo +C +C Calculate the components of the gradient in DC and X +C + do k=i,j-1 + do l=1,3 + ghpbc(l,k)=ghpbc(l,k)+gg(l) + enddo + enddo + return + end +C-------------------------------------------------------------------------- + subroutine ebond(estr) +c +c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + 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' + logical energy_dec /.false./ + double precision u(3),ud(3) + estr=0.0d0 + estr1=0.0d0 + do i=nnt+1,nct + if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle +C estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) +C do j=1,3 +C gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) +C & *dc(j,i-1)/vbld(i) +C enddo +C if (energy_dec) write(iout,*) +C & "estr1",i,vbld(i),distchainmax, +C & gnmr1(vbld(i),-1.0d0,distchainmax) +C else + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then + diff = vbld(i)-vbldpDUM + else + diff = vbld(i)-vbldp0 +c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff + endif + estr=estr+diff*diff + do j=1,3 + gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) + enddo +C endif +C write (iout,'(a7,i5,4f7.3)') +C & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff + enddo + estr=0.5d0*AKP*estr+estr1 +c +c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included +c + do i=nnt,nct + 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) +c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, +c & AKSC(1,iti),AKSC(1,iti)*diff*diff + estr=estr+0.5d0*AKSC(1,iti)*diff*diff + do j=1,3 + gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) + enddo + else + do j=1,nbi + diff=vbld(i+nres)-vbldsc0(j,iti) + ud(j)=aksc(j,iti)*diff + u(j)=abond0(j,iti)+0.5d0*ud(j)*diff + enddo + uprod=u(1) + do j=2,nbi + uprod=uprod*u(j) + enddo + usum=0.0d0 + usumsqder=0.0d0 + do j=1,nbi + uprod1=1.0d0 + uprod2=1.0d0 + do k=1,nbi + if (k.ne.j) then + uprod1=uprod1*u(k) + uprod2=uprod2*u(k)*u(k) + endif + enddo + usum=usum+uprod1 + usumsqder=usumsqder+ud(j)*uprod2 + enddo +c write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti), +c & AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi) + estr=estr+uprod/usum + do j=1,3 + gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) + enddo + endif + endif + enddo + return + end +#ifdef CRYST_THETA +C-------------------------------------------------------------------------- + subroutine ebend(etheta,ethetacnstr) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + 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.TORCNSTR' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + double precision y(2),z(2) + delta=0.02d0*pi +c time11=dexp(-2*time) +c time12=1.0d0 + etheta=0.0D0 +c write (iout,*) "nres",nres +c write (*,'(a,i2)') 'EBEND ICG=',icg +c write (iout,*) ithet_start,ithet_end + do i=ithet_start,ithet_end + if (i.le.2) cycle + if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle +C Zero the energy function and its derivative at 0 or pi. + call splinthet(theta(i),0.5d0*delta,ss,ssd) + it=itype(i-1) + 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.eq.3) then + y(1)=0.0D0 + y(2)=0.0D0 + else + if (i.gt.3 .and. itype(i-3).ne.ntyp1) then +#ifdef OSF + phii=phi(i) +c icrc=0 +c call proc_proc(phii,icrc) + if (icrc.eq.1) 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 + endif + if (i.lt.nres .and. itype(i+1).ne.ntyp1) then +#ifdef OSF + phii1=phi(i+1) +c icrc=0 +c call proc_proc(phii1,icrc) + if (icrc.eq.1) phii1=150.0 + phii1=pinorm(phii1) + z(1)=cos(phii1) +#else + phii1=phi(i+1) + z(1)=dcos(phii1) +#endif + z(2)=dsin(phii1) + else + z(1)=0.0D0 + z(2)=0.0D0 + endif +C Calculate the "mean" value of theta from the part of the distribution +C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). +C In following comments this theta will be referred to as t_c. + thet_pred_mean=0.0d0 + do k=1,2 + athetk=athet(k,it,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 +c write (iout,*) "thet_pred_mean",thet_pred_mean + dthett=thet_pred_mean*ssd + thet_pred_mean=thet_pred_mean*ss+a0thet(it) +c write (iout,*) "thet_pred_mean",thet_pred_mean +C 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 +c write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i), +c & rad2deg*phii,rad2deg*phii1,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) +c 1215 continue + enddo +C Ufff.... We've done all this!!! +C now constrains + ethetacnstr=0.0d0 +C print *,ithetaconstr_start,ithetaconstr_end,"TU" + do i=1,ntheta_constr + itheta=itheta_constr(i) + thetiii=theta(itheta) + difi=pinorm(thetiii-theta_constr0(i)) + if (difi.gt.theta_drange(i)) then + difi=difi-theta_drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else + difi=0.0 + endif +C if (energy_dec) then +C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", +C & i,itheta,rad2deg*thetiii, +C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), +C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, +C & gloc(itheta+nphi-2,icg) +C endif + enddo + return + end +C--------------------------------------------------------------------------- + subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, + & E_tc) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it +C Calculate the contributions to both Gaussian lobes. +C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) +C The "polynomial part" of the "standard deviation" of this part of +C the distribution. + sig=polthet(3,it) + do j=2,0,-1 + sig=sig*thet_pred_mean+polthet(j,it) + enddo +C Derivative of the "interior part" of the "standard deviation of the" +C gamma-dependent Gaussian lobe in t_c. + sigtc=3*polthet(3,it) + do j=2,1,-1 + sigtc=sigtc*thet_pred_mean+j*polthet(j,it) + enddo + sigtc=sig*sigtc +C Set the parameters of both Gaussian lobes of the distribution. +C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) + fac=sig*sig+sigc0(it) + sigcsq=fac+fac + sigc=1.0D0/sigcsq +C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c + sigsqtc=-4.0D0*sigcsq*sigtc +c print *,i,sig,sigtc,sigsqtc +C Following variable (sigtc) is d[sigma(t_c)]/dt_c + sigtc=-sigtc/(fac*fac) +C Following variable is sigma(t_c)**(-2) + sigcsq=sigcsq*sigcsq + sig0i=sig0(it) + sig0inv=1.0D0/sig0i**2 + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i + term1=-0.5D0*sigcsq*delthec*delthec + term2=-0.5D0*sig0inv*delthe0*delthe0 +C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and +C NaNs in taking the logarithm. We extract the largest exponent which is added +C to the energy (this being the log of the distribution) at the end of energy +C term evaluation for this virtual-bond angle. + if (term1.gt.term2) then + termm=term1 + term2=dexp(term2-termm) + term1=1.0d0 + else + termm=term2 + term1=dexp(term1-termm) + term2=1.0d0 + endif +C The ratio between the gamma-independent and gamma-dependent lobes of +C the distribution is a Gaussian function of thet_pred_mean too. + diffak=gthet(2,it)-thet_pred_mean + ratak=diffak/gthet(3,it)**2 + ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) +C Let's differentiate it in thet_pred_mean NOW. + aktc=ak*ratak +C Now put together the distribution terms to make complete distribution. + termexp=term1+ak*term2 + termpre=sigc+ak*sig0i +C Contribution of the bending energy from this theta is just the -log of +C the sum of the contributions from the two lobes and the pre-exponential +C factor. Simple enough, isn't it? + ethetai=(-dlog(termexp)-termm+dlog(termpre)) +C NOW the derivatives!!! +C 6/6/97 Take into account the deformation. + E_theta=(delthec*sigcsq*term1 + & +ak*delthe0*sig0inv*term2)/termexp + E_tc=((sigtc+aktc*sig0i)/termpre + & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ + & aktc*term2)/termexp) + return + end +c----------------------------------------------------------------------------- + subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i +C "Thank you" to MAPLE (probably spared one day of hand-differentiation). + t3 = thetai-thet_pred_mean + t6 = t3**2 + t9 = term1 + t12 = t3*sigcsq + t14 = t12+t6*sigsqtc + t16 = 1.0d0 + t21 = thetai-theta0i + t23 = t21**2 + t26 = term2 + t27 = t21*t26 + t32 = termexp + t40 = t32**2 + E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 + & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 + & *(-t12*t9-ak*sig0inv*t27) + return + end +#else +C-------------------------------------------------------------------------- + subroutine ebend(etheta,ethetacnstr) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C ab initio-derived potentials from +c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + 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.TORCNSTR' + double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), + & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), + & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), + & sinph1ph2(maxdouble,maxdouble) + logical lprn /.false./, lprn1 /.false./ + etheta=0.0D0 +c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) + do i=ithet_start,ithet_end + if (i.le.2) cycle + if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle +c if (itype(i-1).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.eq.3) then + phii=0.0d0 + ityp1=nthetyp+1 + do k=1,nsingle + cosph1(k)=0.0d0 + sinph1(k)=0.0d0 + enddo + else + if (i.gt.3 .and. itype(i-3).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))) + do k=1,nsingle + cosph1(k)=dcos(k*phii) + sinph1(k)=dsin(k*phii) + enddo + else + phii=0.0d0 +c ityp1=nthetyp+1 + do k=1,nsingle + ityp1=ithetyp((itype(i-2))) + cosph1(k)=0.0d0 + sinph1(k)=0.0d0 + enddo + endif + 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 +c ityp3=nthetyp+1 + ityp3=ithetyp((itype(i))) + do k=1,nsingle + cosph2(k)=0.0d0 + sinph2(k)=0.0d0 + enddo + endif +c write (iout,*) "i",i," ityp1",itype(i-2),ityp1, +c & " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3 +c call flush(iout) + 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 + if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') + & i,theta(i)*rad2deg,phii*rad2deg, + & phii1*rad2deg,ethetai + etheta=etheta+ethetai + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 +c gloc(nphi+i-2,icg)=wang*dethetai + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai + enddo +C now constrains + ethetacnstr=0.0d0 +C print *,ithetaconstr_start,ithetaconstr_end,"TU" + do i=1,ntheta_constr + itheta=itheta_constr(i) + thetiii=theta(itheta) + difi=pinorm(thetiii-theta_constr0(i)) + if (difi.gt.theta_drange(i)) then + difi=difi-theta_drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else + difi=0.0 + endif +C if (energy_dec) then +C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", +C & i,itheta,rad2deg*thetiii, +C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), +C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, +C & gloc(itheta+nphi-2,icg) +C endif + enddo + return + end +#endif +#ifdef CRYST_SC +c----------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + 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' + double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), + & ddersc0(3),ddummy(3),xtemp(3),temp(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 +c write (iout,'(a)') 'ESC' + do i=loc_start,loc_end + it=itype(i) + if (it.eq.ntyp1) cycle + if (it.eq.10) goto 1 + nlobit=nlob(iabs(it)) +c print *,'i=',i,' it=',it,' nlobit=',nlobit +c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad + theti=theta(i+1)-pipol + x(1)=dtan(theti) + x(2)=alph(i) + x(3)=omeg(i) +c write (iout,*) "i",i," x",x(1),x(2),x(3) + + if (x(2).gt.pi-delta) then + xtemp(1)=x(1) + xtemp(2)=pi-delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=pi + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=pi-delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=pi + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + call splinthet(x(2),0.5d0*delta,ss,ssd) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c escloci=esclocbi +c write (iout,*) escloci + else if (x(2).lt.delta) then + xtemp(1)=x(1) + xtemp(2)=delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=0.0d0 + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=0.0d0 + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + call splinthet(x(2),0.5d0*delta,ss,ssd) + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c write (iout,*) escloci + else + call enesc(x,escloci,dersc,ddummy,.false.) + endif + + escloc=escloc+escloci +c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc + + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ + & wscloc*dersc(1) + gloc(ialph(i,1),icg)=wscloc*dersc(2) + gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) + 1 continue + enddo + return + end +C--------------------------------------------------------------------------- + subroutine enesc(x,escloci,dersc,ddersc,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) + double precision contr(maxlob,-1:1) + logical mixed +c write (iout,*) 'it=',it,' nlobit=',nlobit + escloc_i=0.0D0 + do j=1,3 + dersc(j)=0.0D0 + if (mixed) ddersc(j)=0.0d0 + enddo + x3=x(3) + +C Because of periodicity of the dependence of the SC energy in omega we have +C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). +C To avoid underflows, first compute & store the exponents. + + do iii=-1,1 + + x(3)=x3+iii*dwapi + + do j=1,nlobit + do k=1,3 + z(k)=x(k)-censc(k,j,it) + enddo + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j,iii)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j,iii)*z(k) + enddo + contr(j,iii)=expfac + enddo ! j + + enddo ! iii + + x(3)=x3 +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1,-1) + do iii=-1,1 + do j=1,nlobit + if (emin.gt.contr(j,iii)) emin=contr(j,iii) + enddo + enddo + emin=0.5D0*emin +cd print *,'it=',it,' emin=',emin + +C Compute the contribution to SC energy and derivatives + do iii=-1,1 + + do j=1,nlobit + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) +cd print *,'j=',j,' expfac=',expfac + escloc_i=escloc_i+expfac + do k=1,3 + dersc(k)=dersc(k)+Ax(k,j,iii)*expfac + enddo + if (mixed) then + do k=1,3,2 + ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) + & +gaussc(k,2,j,it))*expfac + enddo + endif + enddo + + enddo ! iii + + dersc(1)=dersc(1)/cos(theti)**2 + ddersc(1)=ddersc(1)/cos(theti)**2 + ddersc(3)=ddersc(3) + + escloci=-(dlog(escloc_i)-emin) + do j=1,3 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) then + do j=1,3,2 + ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) + enddo + endif + return + end +C------------------------------------------------------------------------------ + subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob),dersc(3) + double precision contr(maxlob) + logical mixed + + escloc_i=0.0D0 + + do j=1,3 + dersc(j)=0.0D0 + enddo + + do j=1,nlobit + do k=1,2 + z(k)=x(k)-censc(k,j,it) + enddo + z(3)=dwapi + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j)*z(k) + enddo + contr(j)=expfac + enddo ! j + +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1) + do j=1,nlobit + if (emin.gt.contr(j)) emin=contr(j) + enddo + emin=0.5D0*emin + +C Compute the contribution to SC energy and derivatives + + dersc12=0.0d0 + do j=1,nlobit + expfac=dexp(bsc(j,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 +#else +c---------------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA derived from AM1 all-atom calculations. +C added by Urszula Kozlowska. 07/11/2007 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.SCROT' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.VECTORS' + double precision x_prime(3),y_prime(3),z_prime(3) + & , sumene,dsc_i,dp2_i,x(65), + & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, + & de_dxx,de_dyy,de_dzz,de_dt + double precision s1_t,s1_6_t,s2_t,s2_6_t + double precision + & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), + & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), + & dt_dCi(3),dt_dCi1(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 + do i=loc_start,loc_end + 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 +c +C Compute the axes of tghe local cartesian coordinates system; store in +c x_prime, y_prime and z_prime +c + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo +C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), +C & dc_norm(3,i+nres) + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo + do j = 1,3 + z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i))) + enddo +c write (2,*) "i",i +c write (2,*) "x_prime",(x_prime(j),j=1,3) +c write (2,*) "y_prime",(y_prime(j),j=1,3) +c write (2,*) "z_prime",(z_prime(j),j=1,3) +c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), +c & " xy",scalar(x_prime(1),y_prime(1)), +c & " xz",scalar(x_prime(1),z_prime(1)), +c & " yy",scalar(y_prime(1),y_prime(1)), +c & " yz",scalar(y_prime(1),z_prime(1)), +c & " zz",scalar(z_prime(1),z_prime(1)) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxtab(i)=xx + yytab(i)=yy + zztab(i)=zz +C +C Compute the energy of the ith side cbain +C +c write (2,*) "xx",xx," yy",yy," zz",zz + it=iabs(itype(i)) + do j = 1,65 + x(j) = sc_parmin(j,it) + enddo +#ifdef CHECK_COORD +Cc diagnostics - remove later + xx1 = dcos(alph(2)) + yy1 = dsin(alph(2))*dcos(omeg(2)) +c zz1 = -dsin(alph(2))*dsin(omeg(2)) + zz1 = -dsign(1.0d0,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 +C," --- ", xx_w,yy_w,zz_w +c end diagnostics +#endif + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 + & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy + & + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 + & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy + & + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 + & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy + & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 + & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx + & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy + & +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 + & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy + & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 + & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx + & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy + & +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) + & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) +c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, +c & sumene4, +c & dscp1,dscp2,sumene +c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + escloc = escloc + sumene +c write (2,*) "escloc",escloc + if (.not. calc_grad) goto 1 +#ifdef DEBUG +C +C This section to check the numerical derivatives of the energy of ith side +C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert +C #define DEBUG in the code to turn it on. +C + write (2,*) "sumene =",sumene + aincr=1.0d-7 + xxsave=xx + xx=xx+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dxx_num=(sumenep-sumene)/aincr + xx=xxsave + write (2,*) "xx+ sumene from enesc=",sumenep + yysave=yy + yy=yy+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dyy_num=(sumenep-sumene)/aincr + yy=yysave + write (2,*) "yy+ sumene from enesc=",sumenep + zzsave=zz + zz=zz+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dzz_num=(sumenep-sumene)/aincr + zz=zzsave + write (2,*) "zz+ sumene from enesc=",sumenep + costsave=cost2tab(i+1) + sintsave=sint2tab(i+1) + cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) + sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dt_num=(sumenep-sumene)/aincr + write (2,*) " t+ sumene from enesc=",sumenep + cost2tab(i+1)=costsave + sint2tab(i+1)=sintsave +C End of diagnostics section. +#endif +C +C Compute the gradient of esc +C + pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 + pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 + pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 + pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 + pom_dx=dsc_i*dp2_i*cost2tab(i+1) + pom_dy=dsc_i*dp2_i*sint2tab(i+1) + pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) + pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) + pom1=(sumene3*sint2tab(i+1)+sumene1) + & *(pom_s1/dscp1+pom_s16*dscp1**4) + pom2=(sumene4*cost2tab(i+1)+sumene2) + & *(pom_s2/dscp2+pom_s26*dscp2**4) + sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy + sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 + & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) + & +x(40)*yy*zz + sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy + sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 + & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) + & +x(60)*yy*zz + de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) + & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) + & +(pom1+pom2)*pom_dx +#ifdef DEBUG + write(2,*), "de_dxx = ", de_dxx,de_dxx_num +#endif +C + sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz + sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 + & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) + & +x(40)*xx*zz + sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz + sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz + & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz + & +x(59)*zz**2 +x(60)*xx*zz + de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) + & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) + & +(pom1-pom2)*pom_dy +#ifdef DEBUG + write(2,*), "de_dyy = ", de_dyy,de_dyy_num +#endif +C + de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy + & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx + & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) + & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) + & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 + & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy + & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) + & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) +#ifdef DEBUG + write(2,*), "de_dzz = ", de_dzz,de_dzz_num +#endif +C + de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) + & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) + & +pom1*pom_dt1+pom2*pom_dt2 +#ifdef DEBUG + write(2,*), "de_dt = ", de_dt,de_dt_num +#endif +c +C + cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) + cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) + cosfac2xx=cosfac2*xx + sinfac2yy=sinfac2*yy + do k = 1,3 + dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* + & vbld_inv(i+1) + dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* + & vbld_inv(i) + pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) + pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) +c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, +c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) +c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), +c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) + dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx + dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx + dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy + dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy + dZZ_Ci1(k)=0.0d0 + dZZ_Ci(k)=0.0d0 + do j=1,3 + dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) + & *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)) +c + dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) + dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) + enddo + + do k=1,3 + dXX_Ctab(k,i)=dXX_Ci(k) + dXX_C1tab(k,i)=dXX_Ci1(k) + dYY_Ctab(k,i)=dYY_Ci(k) + dYY_C1tab(k,i)=dYY_Ci1(k) + dZZ_Ctab(k,i)=dZZ_Ci(k) + dZZ_C1tab(k,i)=dZZ_Ci1(k) + dXX_XYZtab(k,i)=dXX_XYZ(k) + dYY_XYZtab(k,i)=dYY_XYZ(k) + dZZ_XYZtab(k,i)=dZZ_XYZ(k) + enddo + + do k = 1,3 +c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", +c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) +c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", +c & dyy_ci(k)," dzz_ci",dzz_ci(k) +c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", +c & dt_dci(k) +c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", +c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) + gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) + & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) + gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) + & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) + gsclocx(k,i)= de_dxx*dxx_XYZ(k) + & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) + enddo +c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), +c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) + +C to check gradient call subroutine check_grad + + 1 continue + enddo + return + end +#endif +c------------------------------------------------------------------------------ + subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) +C +C This procedure calculates two-body contact function g(rij) and its derivative: +C +C eps0ij ! x < -1 +C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 +C 0 ! x > 1 +C +C where x=(rij-r0ij)/delta +C +C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy +C + implicit none + double precision rij,r0ij,eps0ij,fcont,fprimcont + double precision x,x2,x4,delta +c delta=0.02D0*r0ij +c delta=0.2D0*r0ij + x=(rij-r0ij)/delta + if (x.lt.-1.0D0) then + fcont=eps0ij + fprimcont=0.0D0 + else if (x.le.1.0D0) then + x2=x*x + x4=x2*x2 + fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) + fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta + else + fcont=0.0D0 + fprimcont=0.0D0 + endif + return + end +c------------------------------------------------------------------------------ + subroutine splinthet(theti,delta,ss,ssder) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.VAR' + include 'COMMON.GEO' + thetup=pi-delta + thetlow=delta + if (theti.gt.pipol) then + call gcont(theti,thetup,1.0d0,delta,ss,ssder) + else + call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) + ssder=-ssder + endif + return + end +c------------------------------------------------------------------------------ + subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) + implicit none + double precision x,x0,delta,f0,f1,fprim0,f,fprim + double precision ksi,ksi2,ksi3,a1,a2,a3 + a1=fprim0*delta/(f1-f0) + a2=3.0d0-2.0d0*a1 + a3=a1-2.0d0 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) + fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) + return + end +c------------------------------------------------------------------------------ + subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) + implicit none + double precision x,x0,delta,f0x,f1x,fprim0x,fx + double precision ksi,ksi2,ksi3,a1,a2,a3 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + a1=fprim0x*delta + a2=3*(f1x-f0x)-2*fprim0x*delta + a3=fprim0x*delta-2*(f1x-f0x) + fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 + return + end +C----------------------------------------------------------------------------- +#ifdef CRYST_TOR +C----------------------------------------------------------------------------- + subroutine etor(etors,edihcnstr,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + 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 +C Proline-Proline pair is a special case... + if (itori.eq.3 .and. itori1.eq.3) then + if (phii.gt.-dwapi3) then + cosphi=dcos(3*phii) + fac=1.0D0/(1.0D0-cosphi) + etorsi=v1(1,3,3)*fac + etorsi=etorsi+etorsi + etors=etors+etorsi-v1(1,3,3) + 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) + 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) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + endif + 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*fact*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 + do i=1,ndih_constr + itori=idih_constr(i) + phii=phi(itori) + difi=phii-phi0(i) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + endif +! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, +! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +! write (iout,*) 'edihcnstr',edihcnstr + return + end +c------------------------------------------------------------------------------ +#else + subroutine etor(etors,edihcnstr,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + if (i.le.2) cycle + if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle + if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215 + 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 +C 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 + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +C Lorentz terms +C v1 +C E = SUM ----------------------------------- - v1 +C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 +C + cosphi=dcos(0.5d0*phii) + sinphi=dsin(0.5d0*phii) + do j=1,nlor(itori,itori1,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 + pom=-pom*pom1*pom1 + gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom + enddo +C Subtract the constant term + etors=etors-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,1),j=1,6),(v2(j,itori,itori1,1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + 1215 continue + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 + do i=1,ndih_constr + itori=idih_constr(i) + phii=phi(itori) + difi=pinorm(phii-phi0(i)) + edihi=0.0d0 + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + edihi=0.25d0*ftors(i)*difi**4 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + edihi=0.25d0*ftors(i)*difi**4 + else + difi=0.0d0 + endif +c write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi, +c & drange(i),edihi +! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, +! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +! write (iout,*) 'edihcnstr',edihcnstr + return + end +c---------------------------------------------------------------------------- + subroutine etor_d(etors_d,fact2) +C 6/23/01 Compute double torsional energy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors_d=0.0D0 + do i=iphi_start,iphi_end-1 + if (i.le.3) cycle + if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or. + & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or. + & (itype(i+1).eq.ntyp1)) cycle + if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0) + & goto 1215 + 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 +C 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 + 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 + gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) + gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + enddo + enddo + gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1 + gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2 + 1215 continue + enddo + return + end +#endif +c------------------------------------------------------------------------------ + subroutine eback_sc_corr(esccor) +c 7/21/2007 Correlations between the backbone-local and side-chain-local +c conformational states; temporarily implemented as differences +c between UNRES torsional potentials (dependent on three types of +c residues) and the torsional potentials dependent on all 20 types +c of residues computed from AM1 energy surfaces of terminally-blocked +c amino-acid residues. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.SCCOR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. +c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor + esccor=0.0D0 + do i=itau_start,itau_end + 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)) + phii=phi(i) + do intertyp=1,3 !intertyp +cc Added 09 May 2012 (Adasko) +cc Intertyp means interaction type of backbone mainchain correlation: +c 1 = SC...Ca...Ca...Ca +c 2 = Ca...Ca...Ca...SC +c 3 = SC...Ca...Ca...SCi + gloci=0.0D0 + if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. + & (itype(i-1).eq.10).or.(itype(i-2).eq.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)) + esccor=esccor+v1ij*cosphi+v2ij*sinphi +c gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +c write (iout,*) "EBACK_SC_COR",i,esccor,intertyp +c gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+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,itori,itori1, + & (v1sccor(j,1,itori,itori1),j=1,6), + & (v2sccor(j,1,itori,itori1),j=1,6) + gsccor_loc(i-3)=gloci + enddo !intertyp + enddo + return + end +c------------------------------------------------------------------------------ + subroutine multibody(ecorr) +C This subroutine calculates multi-body contributions to energy following +C the idea of Skolnick et al. If side chains I and J make a contact and +C at the same time side chains I+1 and J+1 make a contact, an extra +C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + +C Set lprn=.true. for debugging + lprn=.false. + + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(i2,20(1x,i2,f10.5))') + & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) + enddo + endif + ecorr=0.0D0 + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo + do i=nnt,nct-2 + + DO ISHIFT = 3,4 + + i1=i+ishift + num_conti=num_cont(i) + num_conti1=num_cont(i1) + do jj=1,num_conti + j=jcont(jj,i) + do kk=1,num_conti1 + j1=jcont(kk,i1) + if (j1.eq.j+ishift .or. j1.eq.j-ishift) then +cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, +cd & ' ishift=',ishift +C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) + endif ! j1==j+-ishift + enddo ! kk + enddo ! jj + + ENDDO ! ISHIFT + + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function esccorr(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont(jj,i) + ekl=facont(kk,k) +cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl +C Calculate the multi-body contribution to energy. +C Calculate multi-body contributions to the gradient. +cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), +cd & k,l,(gacont(m,kk,k),m=1,3) + do m=1,3 + gx(m) =ekl*gacont(m,jj,i) + gx1(m)=eij*gacont(m,kk,k) + gradxorr(m,i)=gradxorr(m,i)-gx(m) + gradxorr(m,j)=gradxorr(m,j)+gx(m) + gradxorr(m,k)=gradxorr(m,k)-gx1(m) + gradxorr(m,l)=gradxorr(m,l)+gx1(m) + enddo + do m=i,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) + enddo + enddo + do m=k,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) + enddo + enddo + esccorr=-eij*ekl + return + end +c------------------------------------------------------------------------------ +#ifdef MPL + subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + integer dimen1,dimen2,atom,indx + double precision buffer(dimen1,dimen2) + double precision zapas + common /contacts_hb/ zapas(3,20,maxres,7), + & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), + & num_cont_hb(maxres),jcont_hb(20,maxres) + num_kont=num_cont_hb(atom) + do i=1,num_kont + do k=1,7 + do j=1,3 + buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k) + enddo ! j + enddo ! k + buffer(i,indx+22)=facont_hb(i,atom) + buffer(i,indx+23)=ees0p(i,atom) + buffer(i,indx+24)=ees0m(i,atom) + buffer(i,indx+25)=dfloat(jcont_hb(i,atom)) + enddo ! i + buffer(1,indx+26)=dfloat(num_kont) + return + end +c------------------------------------------------------------------------------ + subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + integer dimen1,dimen2,atom,indx + double precision buffer(dimen1,dimen2) + double precision zapas + common /contacts_hb/ zapas(3,ntyp,maxres,7), + & facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres), + & num_cont_hb(maxres),jcont_hb(ntyp,maxres) + num_kont=buffer(1,indx+26) + num_kont_old=num_cont_hb(atom) + num_cont_hb(atom)=num_kont+num_kont_old + do i=1,num_kont + ii=i+num_kont_old + do k=1,7 + do j=1,3 + zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j) + enddo ! j + enddo ! k + facont_hb(ii,atom)=buffer(i,indx+22) + ees0p(ii,atom)=buffer(i,indx+23) + ees0m(ii,atom)=buffer(i,indx+24) + jcont_hb(ii,atom)=buffer(i,indx+25) + enddo ! i + return + end +c------------------------------------------------------------------------------ +#endif + subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' +#ifdef MPL + parameter (max_cont=maxconts) + parameter (max_dim=2*(8*3+2)) + parameter (msglen1=max_cont*max_dim*4) + parameter (msglen2=2*msglen1) + integer source,CorrelType,CorrelID,Error + double precision buffer(max_cont,max_dim) +#endif + double precision gx(3),gx1(3) + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. +#ifdef MPL + n_corr=0 + n_corr1=0 + if (fgProcs.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values:' + 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 +C Caution! Following code assumes that electrostatic interactions concerning +C a given atom are split among at most two processors! + CorrelType=477 + CorrelID=MyID+1 + ldone=.false. + do i=1,max_cont + do j=1,max_dim + buffer(i,j)=0.0D0 + enddo + enddo + mm=mod(MyRank,2) +cd write (iout,*) 'MyRank',MyRank,' mm',mm + if (mm) 20,20,10 + 10 continue +cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.gt.0) then +C Send correlation contributions to the preceding processor + msglen=msglen1 + nn=num_cont_hb(iatel_s) + call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) +cd write (iout,*) 'The BUFFER array:' +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26) +cd enddo + if (ielstart(iatel_s).gt.iatel_s+ispp) then + msglen=msglen2 + call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer) +C Clear the contacts of the atom passed to the neighboring processor + nn=num_cont_hb(iatel_s+1) +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26) +cd enddo + num_cont_hb(iatel_s)=0 + endif +cd write (iout,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen +cd write (*,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID) +cd write (iout,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID +cd write (*,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID + msglen=msglen1 + endif ! (MyRank.gt.0) + if (ldone) goto 30 + ldone=.true. + 20 continue +cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.lt.fgProcs-1) then +C Receive correlation contributions from the next processor + msglen=msglen1 + if (ielend(iatel_e).lt.nct-1) msglen=msglen2 +cd write (iout,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType +cd write (*,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + nbytes=-1 + do while (nbytes.le.0) + call mp_probe(MyID+1,CorrelType,nbytes) + enddo +cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes + call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes) +cd write (iout,*) 'Processor',MyID, +cd & ' has received correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' nbytes=',nbytes +cd write (iout,*) 'The received BUFFER array:' +cd do i=1,max_cont +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52) +cd enddo + if (msglen.eq.msglen1) then + call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer) + else if (msglen.eq.msglen2) then + call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) + call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) + else + write (iout,*) + & 'ERROR!!!! message length changed while processing correlations.' + write (*,*) + & 'ERROR!!!! message length changed while processing correlations.' + call mp_stopall(Error) + endif ! msglen.eq.msglen1 + endif ! MyRank.lt.fgProcs-1 + if (ldone) goto 30 + ldone=.true. + goto 10 + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + 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 + ecorr=0.0D0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the local-electrostatic correlation terms + do i=iatel_s,iatel_e+1 + 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) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1 .or. j1.eq.j-1) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) + n_corr=n_corr+1 + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, + & n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' +#ifdef MPL + parameter (max_cont=maxconts) + parameter (max_dim=2*(8*3+2)) + parameter (msglen1=max_cont*max_dim*4) + parameter (msglen2=2*msglen1) + integer source,CorrelType,CorrelID,Error + double precision buffer(max_cont,max_dim) +#endif + double precision gx(3),gx1(3) + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. + eturn6=0.0d0 +#ifdef MPL + n_corr=0 + n_corr1=0 + if (fgProcs.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values:' + 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 +C Caution! Following code assumes that electrostatic interactions concerning +C a given atom are split among at most two processors! + CorrelType=477 + CorrelID=MyID+1 + ldone=.false. + do i=1,max_cont + do j=1,max_dim + buffer(i,j)=0.0D0 + enddo + enddo + mm=mod(MyRank,2) +cd write (iout,*) 'MyRank',MyRank,' mm',mm + if (mm) 20,20,10 + 10 continue +cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.gt.0) then +C Send correlation contributions to the preceding processor + msglen=msglen1 + nn=num_cont_hb(iatel_s) + call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) +cd write (iout,*) 'The BUFFER array:' +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26) +cd enddo + if (ielstart(iatel_s).gt.iatel_s+ispp) then + msglen=msglen2 + call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer) +C Clear the contacts of the atom passed to the neighboring processor + nn=num_cont_hb(iatel_s+1) +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26) +cd enddo + num_cont_hb(iatel_s)=0 + endif +cd write (iout,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen +cd write (*,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID) +cd write (iout,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID +cd write (*,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID + msglen=msglen1 + endif ! (MyRank.gt.0) + if (ldone) goto 30 + ldone=.true. + 20 continue +cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.lt.fgProcs-1) then +C Receive correlation contributions from the next processor + msglen=msglen1 + if (ielend(iatel_e).lt.nct-1) msglen=msglen2 +cd write (iout,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType +cd write (*,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + nbytes=-1 + do while (nbytes.le.0) + call mp_probe(MyID+1,CorrelType,nbytes) + enddo +cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes + call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes) +cd write (iout,*) 'Processor',MyID, +cd & ' has received correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' nbytes=',nbytes +cd write (iout,*) 'The received BUFFER array:' +cd do i=1,max_cont +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52) +cd enddo + if (msglen.eq.msglen1) then + call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer) + else if (msglen.eq.msglen2) then + call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) + call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) + else + write (iout,*) + & 'ERROR!!!! message length changed while processing correlations.' + write (*,*) + & 'ERROR!!!! message length changed while processing correlations.' + call mp_stopall(Error) + endif ! msglen.eq.msglen1 + endif ! MyRank.lt.fgProcs-1 + if (ldone) goto 30 + ldone=.true. + goto 10 + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + 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 + ecorr=0.0D0 + ecorr5=0.0d0 + ecorr6=0.0d0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the dipole-dipole interaction energies + if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then + do i=iatel_s,iatel_e+1 + num_conti=num_cont_hb(i) + do jj=1,num_conti + j=jcont_hb(jj,i) + call dipole(i,j,jj) + enddo + enddo + endif +C Calculate the local-electrostatic correlation terms + do i=iatel_s,iatel_e+1 + 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) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) +c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1 .or. j1.eq.j-1) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + n_corr=n_corr+1 + sqd1=dsqrt(d_cont(jj,i)) + sqd2=dsqrt(d_cont(kk,i1)) + sred_geom = sqd1*sqd2 + IF (sred_geom.lt.cutoff_corr) THEN + call gcont(sred_geom,r0_corr,1.0D0,delt_corr, + & ekont,fprimcont) +c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + fac_prim1=0.5d0*sqd2/sqd1*fprimcont + fac_prim2=0.5d0*sqd1/sqd2*fprimcont + do l=1,3 + g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) + g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) + enddo + n_corr1=n_corr1+1 +cd write (iout,*) 'sred_geom=',sred_geom, +cd & ' ekont=',ekont,' fprim=',fprimcont + call calc_eello(i,j,i+1,j1,jj,kk) + if (wcorr4.gt.0.0d0) + & ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk) + if (wcorr5.gt.0.0d0) + & ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk) +c print *,"wcorr5",ecorr5 +cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 +cd write(2,*)'ijkl',i,j,i+1,j1 + if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3 + & .or. wturn6.eq.0.0d0))then +cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 + ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk) +cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, +cd & 'ecorr6=',ecorr6 +cd write (iout,'(4e15.5)') sred_geom, +cd & dabs(eello4(i,j,i+1,j1,jj,kk)), +cd & dabs(eello5(i,j,i+1,j1,jj,kk)), +cd & dabs(eello6(i,j,i+1,j1,jj,kk)) + else if (wturn6.gt.0.0d0 + & .and. (j.eq.i+4 .and. j1.eq.i+3)) then +cd write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1 + eturn6=eturn6+eello_turn6(i,jj,kk) +cd write (2,*) 'multibody_eello:eturn6',eturn6 + endif + ENDIF +1111 continue + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.SHIELD' + + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont_hb(jj,i) + ekl=facont_hb(kk,k) + ees0pij=ees0p(jj,i) + ees0pkl=ees0p(kk,k) + ees0mij=ees0m(jj,i) + ees0mkl=ees0m(kk,k) + ekont=eij*ekl + ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) +cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) +C Following 4 lines for diagnostics. +cd ees0pkl=0.0D0 +cd ees0pij=1.0D0 +cd ees0mkl=0.0D0 +cd ees0mij=1.0D0 +c write (iout,*)'Contacts have occurred for peptide groups',i,j, +c & ' and',k,l +c write (iout,*)'Contacts have occurred for peptide groups', +c & i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l +c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees +C Calculate the multi-body contribution to energy. + ecorr=ecorr+ekont*ees + if (calc_grad) then +C Calculate multi-body contributions to the gradient. + do ll=1,3 + ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,i)=gradcorr(ll,i)+ghalf + & -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+ + & coeffm*ees0mkl*gacontm_hb1(ll,jj,i)) + gradcorr(ll,j)=gradcorr(ll,j)+ghalf + & -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+ + & coeffm*ees0mkl*gacontm_hb2(ll,jj,i)) + ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,k)=gradcorr(ll,k)+ghalf + & -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+ + & coeffm*ees0mij*gacontm_hb1(ll,kk,k)) + gradcorr(ll,l)=gradcorr(ll,l)+ghalf + & -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+ + & coeffm*ees0mij*gacontm_hb2(ll,kk,k)) + enddo + do m=i+1,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ + & ees*ekl*gacont_hbr(ll,jj,i)- + & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ + & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ + & ees*eij*gacont_hbr(ll,kk,k)- + & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ + & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) + enddo + enddo + if (shield_mode.gt.0) then + j=ees0plist(jj,i) + l=ees0plist(kk,k) +C print *,i,j,fac_shield(i),fac_shield(j), +C &fac_shield(k),fac_shield(l) + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. + & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then + do ilist=1,ishield_list(i) + iresshield=shield_list(ilist,i) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + &+rlocshield + enddo + enddo + do ilist=1,ishield_list(j) + iresshield=shield_list(ilist,j) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + & +rlocshield + enddo + enddo + do ilist=1,ishield_list(k) + iresshield=shield_list(ilist,k) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + & +rlocshield + enddo + enddo + do ilist=1,ishield_list(l) + iresshield=shield_list(ilist,l) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + & +rlocshield + enddo + enddo +C print *,gshieldx(m,iresshield) + do m=1,3 + gshieldc_ec(m,i)=gshieldc_ec(m,i)+ + & grad_shield(m,i)*ehbcorr/fac_shield(i) + gshieldc_ec(m,j)=gshieldc_ec(m,j)+ + & grad_shield(m,j)*ehbcorr/fac_shield(j) + gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+ + & grad_shield(m,i)*ehbcorr/fac_shield(i) + gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+ + & grad_shield(m,j)*ehbcorr/fac_shield(j) + + gshieldc_ec(m,k)=gshieldc_ec(m,k)+ + & grad_shield(m,k)*ehbcorr/fac_shield(k) + gshieldc_ec(m,l)=gshieldc_ec(m,l)+ + & grad_shield(m,l)*ehbcorr/fac_shield(l) + gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+ + & grad_shield(m,k)*ehbcorr/fac_shield(k) + gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+ + & grad_shield(m,l)*ehbcorr/fac_shield(l) + + enddo + endif + endif + endif + ehbcorr=ekont*ees + return + end +C--------------------------------------------------------------------------- + subroutine dipole(i,j,jj) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), + & auxmat(2,2) + iti1 = itortyp(itype(i+1)) + if (j.lt.nres-1) then + if (itype(j).le.ntyp) then + itj1 = itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + 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 + if (.not.calc_grad) return + 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 +C--------------------------------------------------------------------------- + subroutine calc_eello(i,j,k,l,jj,kk) +C +C This subroutine computes matrices and vectors needed to calculate +C the fourth-, fifth-, and sixth-order local-electrostatic terms. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), + & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) + logical lprn + common /kutas/ lprn +cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, +cd & ' jj=',jj,' kk=',kk +cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return + do iii=1,2 + do jjj=1,2 + aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) + aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) + enddo + enddo + call transpose2(aa1(1,1),aa1t(1,1)) + call transpose2(aa2(1,1),aa2t(1,1)) + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), + & aa1tder(1,1,lll,kkk)) + call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), + & aa2tder(1,1,lll,kkk)) + enddo + enddo + if (l.eq.j+1) then +C parallel orientation of the two CA-CA-CA frames. +c if (i.gt.1) then + if (i.gt.1 .and. itype(i).le.ntyp) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itj=itortyp(itype(j)) +c if (l.lt.nres-1) then + if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +C A1 kernel(j+1) A2T +cd do iii=1,2 +cd write (iout,'(3f10.5,5x,3f10.5)') +cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) +cd enddo + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), + & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + lprn=.false. + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), + & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants +cd lprn=.false. +cd if (lprn) then +cd write (2,*) 'In calc_eello6' +cd do iii=1,2 +cd write (2,*) 'iii=',iii +cd do kkk=1,5 +cd write (2,*) 'kkk=',kkk +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) +cd enddo +cd enddo +cd enddo +cd endif + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A1T kernel(i+1) A2 + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti), + & AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i), + & AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), + & AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj), + & AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + else +C Antiparallel orientation of the two CA-CA-CA frames. +c if (i.gt.1) then + if (i.gt.1 .and. itype(i).le.ntyp) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) +c if (j.lt.nres-1) then + if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif +C A2 kernel(j-1)T A1T + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), + & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), + & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A2T kernel(i+1)T A1 + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. + & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti), + & AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i), + & AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), + & AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl), + & AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l), + & AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + endif + return + end +C--------------------------------------------------------------------------- + subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, + & KK,KKderg,AKA,AKAderg,AKAderx) + implicit none + integer nderg + logical transp + double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), + & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), + & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) + integer iii,kkk,lll + integer jjj,mmm + logical lprn + common /kutas/ lprn + call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) + do iii=1,nderg + call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, + & AKAderg(1,1,iii)) + enddo +cd if (lprn) write (2,*) 'In kernel' + do kkk=1,5 +cd if (lprn) write (2,*) 'kkk=',kkk + do lll=1,3 + call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=1' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) +cd enddo +cd endif + call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=2' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) +cd enddo +cd endif + enddo + enddo + return + end +C--------------------------------------------------------------------------- + double precision function eello4(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then +cd eello4=0.0d0 +cd return +cd endif +cd print *,'eello4:',i,j,k,l,jj,kk +cd write (2,*) 'i',i,' j',j,' k',k,' l',l +cd call checkint4(i,j,k,l,jj,kk,eel4_num) +cold eij=facont_hb(jj,i) +cold ekl=facont_hb(kk,k) +cold ekont=eij*ekl + eel4=-EAEA(1,1,1)-EAEA(2,2,1) + if (calc_grad) then +cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) + gcorr_loc(k-1)=gcorr_loc(k-1) + & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) + if (l.eq.j+1) then + gcorr_loc(l-1)=gcorr_loc(l-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + else + gcorr_loc(j-1)=gcorr_loc(j-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) + & -EAEAderx(2,2,lll,kkk,iii,1) +cd derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd gcorr_loc(l-1)=0.0d0 +cd gcorr_loc(j-1)=0.0d0 +cd gcorr_loc(k-1)=0.0d0 +cd eel4=1.0d0 +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l, +cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cold ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i) + ggg1(ll)=eel4*g_contij(ll,1) + ggg2(ll)=eel4*g_contij(ll,2) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1) + gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) + gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1) + gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) +cold ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k) + ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) + gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 +cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 +cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) + enddo + enddo +1112 continue + do m=i+2,j2 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,gcorr_loc(iii) +cd enddo + endif + eello4=ekont*eel4 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello4',ekont*eel4 + return + end +C--------------------------------------------------------------------------- + double precision function eello5(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) + double precision ggg1(3),ggg2(3) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel chains C +C C +C o o o o C +C /l\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j| o |l1 | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C Antiparallel chains C +C C +C o o o o C +C /j\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j1| o |l | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C o denotes a local interaction, vertical lines an electrostatic interaction. C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then +cd eello5=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + itk=itortyp(itype(k)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + eello5_1=0.0d0 + eello5_2=0.0d0 + eello5_3=0.0d0 + eello5_4=0.0d0 +cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, +cd & eel5_3_num,eel5_4_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l +cd goto 1111 +C Contribution from the graph I. +cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) +cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + if (l.eq.j+1) then + if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + else + if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + enddo + enddo + enddo +c goto 1112 + endif +c1111 continue +C Contribution from graph II + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + if (l.eq.j+1) then + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + else + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + enddo + enddo + enddo +cd goto 1112 + endif +cd1111 continue + if (l.eq.j+1) then +cd goto 1110 +C Parallel orientation +C Contribution from graph III + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) + call transpose2(EUgder(1,1,l),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + enddo + enddo + enddo +cd goto 1112 + endif +C Contribution from graph IV +cd1110 continue + call transpose2(EE(1,1,itl),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + enddo + enddo + enddo + endif + else +C Antiparallel orientation +C Contribution from graph III +c goto 1110 + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) + call transpose2(EUgder(1,1,j),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + enddo + enddo + enddo +cd goto 1112 + endif +C Contribution from graph IV +1110 continue + call transpose2(EE(1,1,itj),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + enddo + enddo + enddo + endif + endif +1112 continue + eel5=eello5_1+eello5_2+eello5_3+eello5_4 +cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then +cd write (2,*) 'ijkl',i,j,k,l +cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, +cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 +cd endif +cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num +cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num +cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num +cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num + if (calc_grad) then + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 +cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont + do ll=1,3 + ggg1(ll)=eel5*g_contij(ll,1) + ggg2(ll)=eel5*g_contij(ll,2) +cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1) + gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) + gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1) + gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) +cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) + ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) + gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) + gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) + gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) + enddo + enddo +c1112 continue + do m=i+2,j2 + do ll=1,3 + gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr5_loc(iii) +cd enddo + endif + eello5=ekont*eel5 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello5',ekont*eel5 + return + end +c-------------------------------------------------------------------------- + double precision function eello6(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + eello6_1=0.0d0 + eello6_2=0.0d0 + eello6_3=0.0d0 + eello6_4=0.0d0 + eello6_5=0.0d0 + eello6_6=0.0d0 +cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, +cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + if (l.eq.j+1) then + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(j,i,l,k,2,.false.) + eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) + eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) + else + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(l,k,j,i,2,.true.) + eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + if (wturn6.eq.0.0d0 .or. j.ne.i+4) then + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) + else + eello6_5=0.0d0 + endif + eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) + endif +C If turn contributions are considered, they will be handled separately. + eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 +cd write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num +cd write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num +cd write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num +cd write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num +cd write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num +cd write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num +cd goto 1112 + if (calc_grad) then + 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 + ggg1(ll)=eel6*g_contij(ll,1) + ggg2(ll)=eel6*g_contij(ll,2) +cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1) + gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) + gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1) + gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) + ghalf=0.5d0*ggg2(ll) +cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) +cd ghalf=0.0d0 + gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) + gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) + gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) + gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) + enddo + enddo +1112 continue + do m=i+2,j2 + do ll=1,3 + gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + endif + eello6=ekont*eel6 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello6',ekont*eel6 + return + end +c-------------------------------------------------------------------------- + double precision function eello6_graph1(i,j,k,l,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) + logical swap + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ /j\ C +C / \ / \ C +C /| o | | o |\ C +C \ j|/k\| / \ |/k\|l / C +C \ / \ / \ / \ / C +C o o o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + itk=itortyp(itype(k)) + s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) + vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 + eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) + if (.not. calc_grad) return + if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) + & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) + & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) + & +scalar2(vv(1),Dtobr2der(1,i))) + call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) + vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) + if (l.eq.j+1) then + g_corr6_loc(l-1)=g_corr6_loc(l-1) + & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) + & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1) + & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) + & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + endif + call transpose2(EUgCder(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) + & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) + & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) + do iii=1,2 + if (swap) then + ind=3-iii + else + ind=iii + endif + do kkk=1,5 + do lll=1,3 + s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) + & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) + vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) + & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) + derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph2(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + logical swap + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxvec2(2),auxmat1(2,2) + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C \ /l\ /j\ / C +C \ / \ / \ / C +C o| o | | o |o C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l +C AL 7/4/01 s1 would occur in the sixth-order moment, +C but not in a cluster cumulant +#ifdef MOMENT + s1=dip(1,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph2=-(s1+s2+s3+s4) +#else + eello6_graph2=-(s2+s3+s4) +#endif +c eello6_graph2=-s3 + if (.not. calc_grad) return +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + s1=dipderg(1,jj,i)*dip(1,kk,k) +#endif + s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 +C Derivatives in gamma(j-1) or gamma(l-1) + if (j.gt.1) then +#ifdef MOMENT + s1=dipderg(3,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) + call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + endif +#endif + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) +c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 + endif +C Derivatives in gamma(l-1) or gamma(j-1) + if (l.gt.1) then +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(3,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + else + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + endif +#endif + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) +c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 + endif +C Cartesian derivatives. + if (lprn) then + write (2,*) 'In eello6_graph2' + do iii=1,2 + write (2,*) 'iii=',iii + do kkk=1,5 + write (2,*) 'kkk=',kkk + do jjj=1,2 + write (2,'(3(2f10.5),5x)') + & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) + enddo + enddo + enddo + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) + else + s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) + endif +#endif + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), + & auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), + & auxvec(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph3(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C j|/k\| / |/k\|l / C +C / \ / / \ / C +C / o / o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. + iti=itortyp(itype(i)) +c if (j.lt.nres-1) then + if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) +c if (l.lt.nres-1) then + if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +#ifdef MOMENT + s1=dip(4,jj,i)*dip(4,kk,k) +#endif + call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph3=-(s1+s2+s3+s4) +#else + eello6_graph3=-(s2+s3+s4) +#endif +c eello6_graph3=-s4 + if (.not. calc_grad) return +C Derivatives in gamma(k-1) + call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) +C Derivatives in gamma(l-1) + call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) + else + s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), + & auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif +c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxmat1(2,2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o \ o \ C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. +cd write (2,*) 'eello_graph4: wturn6',wturn6 + iti=itortyp(itype(i)) + itj=itortyp(itype(j)) +c if (j.lt.nres-1) then + if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) +c if (k.lt.nres-1) then + if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then + itk1=itortyp(itype(k+1)) + else + itk1=ntortyp+1 + endif + itl=itortyp(itype(l)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l +cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, +cd & ' itl',itl,' itl1',itl1 +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dip(3,kk,k) + else + s1=dip(2,jj,j)*dip(2,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph4=-(s1+s2+s3+s4) +#else + eello6_graph4=-(s2+s3+s4) +#endif + if (.not. calc_grad) return +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + if (imat.eq.1) then + s1=dipderg(2,jj,i)*dip(3,kk,k) + else + s1=dipderg(4,jj,j)*dip(2,kk,l) + endif +#endif + s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +cd write (2,*) 'turn6 derivatives' +#ifdef MOMENT + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif + endif + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderg(2,kk,k) + else + s1=dip(2,jj,j)*dipderg(4,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif + endif +C Derivatives in gamma(j-1) or gamma(l-1) + if (l.eq.j+1 .and. l.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) + else if (j.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then + gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) + endif + endif +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + if (imat.eq.1) then + s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) + else + s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) + endif + else + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) + else + s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) + endif + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), + & auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,itj1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) + else + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,itl1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) + endif + call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (swap) then + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s1+s2+s4) +#else + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s2+s4) +#endif + derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 + else +#ifdef MOMENT + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) +#else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) +#endif + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + else +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (l.eq.j+1) then + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + endif + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello_turn6(i,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), + & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), + & ggg1(3),ggg2(3) + double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), + & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) +C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to +C the respective energy moment and not to the cluster cumulant. + eello_turn6=0.0d0 + j=i+4 + k=i+1 + l=i+3 + iti=itortyp(itype(i)) + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) +cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj +cd write (2,*) 'i',i,' k',k,' j',j,' l',l +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l +cd call checkint_turn6(i,jj,kk,eel_turn6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx_turn(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) +cd eello6_5=0.0d0 +cd write (2,*) 'eello6_5',eello6_5 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) + ss1=scalar2(Ub2(1,i+2),b1(1,itl)) + s1 = (auxmat(1,1)+auxmat(2,2))*ss1 +#else + s1 = 0.0d0 +#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)) +#else + s8=0.0d0 +#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 +#else + s13=0.0d0 +#endif +c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 +c s1=0.0d0 +c s2=0.0d0 +c s8=0.0d0 +c s12=0.0d0 +c s13=0.0d0 + eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) + if (calc_grad) then +C Derivatives in gamma(i+2) +#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)) +#else + s8d=0.0d0 +#endif + call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 + gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) +C Derivatives in gamma(i+3) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d +#else + s1d=0.0d0 +#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 +#else + s13d=0.0d0 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Derivatives in gamma(i+4) + call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#else + s13d = 0.0d0 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +C s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) +#else + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) +#endif +C Derivatives in gamma(i+5) +#ifdef MOMENT + call transpose2(AEAderg(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#else + s1d = 0.0d0 +#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)) +#else + s8d = 0.0d0 +#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 +#else + s13d = 0.0d0 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Cartesian derivatives + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#else + s1d = 0.0d0 +#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)) +#else + s8d = 0.0d0 +#endif + call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), + & auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*(s1d+s2d) +#else + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*s2d +#endif +#ifdef MOMENT + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*(s8d+s12d) +#else + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*s12d +#endif + enddo + enddo + enddo +#ifdef MOMENT + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), + & achuj_tempd(1,1)) + call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d=(gtempd(1,1)+gtempd(2,2))*ss13 + derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), + & vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d + derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d + enddo + enddo +#endif +cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', +cd & 16*eel_turn6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 + ggg1(ll)=eel_turn6*g_contij(ll,1) + ggg2(ll)=eel_turn6*g_contij(ll,2) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + 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) + ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf + & +ekont*derx_turn(ll,2,2) + gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) + gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf + & +ekont*derx_turn(ll,4,2) + gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) + enddo + enddo +1112 continue + do m=i+2,j2 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + endif + eello_turn6=ekont*eel_turn6 +cd write (2,*) 'ekont',ekont +cd write (2,*) 'eel_turn6',ekont*eel_turn6 + return + end +crc------------------------------------------------- + SUBROUTINE MATVEC2(A1,V1,V2) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),V1(2),V2(2) +c DO 1 I=1,2 +c VI=0.0 +c DO 3 K=1,2 +c 3 VI=VI+A1(I,K)*V1(K) +c Vaux(I)=VI +c 1 CONTINUE + + vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) + vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) + + v2(1)=vaux1 + v2(2)=vaux2 + END +C--------------------------------------- + SUBROUTINE MATMAT2(A1,A2,A3) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),A2(2,2),A3(2,2) +c DIMENSION AI3(2,2) +c DO J=1,2 +c A3IJ=0.0 +c DO K=1,2 +c A3IJ=A3IJ+A1(I,K)*A2(K,J) +c enddo +c A3(I,J)=A3IJ +c enddo +c enddo + + ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) + ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) + ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) + ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) + + A3(1,1)=AI3_11 + A3(2,1)=AI3_21 + A3(1,2)=AI3_12 + A3(2,2)=AI3_22 + END + +c------------------------------------------------------------------------- + double precision function scalar2(u,v) + implicit none + double precision u(2),v(2) + double precision sc + integer i + scalar2=u(1)*v(1)+u(2)*v(2) + return + end + +C----------------------------------------------------------------------------- + + subroutine transpose2(a,at) + implicit none + double precision a(2,2),at(2,2) + at(1,1)=a(1,1) + at(1,2)=a(2,1) + at(2,1)=a(1,2) + at(2,2)=a(2,2) + return + end +c-------------------------------------------------------------------------- + subroutine transpose(n,a,at) + implicit none + integer n,i,j + double precision a(n,n),at(n,n) + do i=1,n + do j=1,n + at(j,i)=a(i,j) + enddo + enddo + return + end +C--------------------------------------------------------------------------- + subroutine prodmat3(a1,a2,kk,transp,prod) + implicit none + integer i,j + double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) + logical transp +crc double precision auxmat(2,2),prod_(2,2) + + if (transp) then +crc call transpose2(kk(1,1),auxmat(1,1)) +crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) + + else +crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) + + endif +c call transpose2(a2(1,1),a2t(1,1)) + +crc print *,transp +crc print *,((prod_(i,j),i=1,2),j=1,2) +crc print *,((prod(i,j),i=1,2),j=1,2) + + return + end +C----------------------------------------------------------------------------- + double precision function scalar(u,v) + implicit none + double precision u(3),v(3) + double precision sc + integer i + sc=0.0d0 + do i=1,3 + sc=sc+u(i)*v(i) + enddo + scalar=sc + return + end +C----------------------------------------------------------------------- + double precision function sscale(r) + double precision r,gamm + include "COMMON.SPLITELE" + if(r.lt.r_cut-rlamb) then + sscale=1.0d0 + else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then + gamm=(r-(r_cut-rlamb))/rlamb + sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) + else + sscale=0d0 + endif + return + end +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + double precision function sscagrad(r) + double precision r,gamm + include "COMMON.SPLITELE" + if(r.lt.r_cut-rlamb) then + sscagrad=0.0d0 + else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then + gamm=(r-(r_cut-rlamb))/rlamb + sscagrad=gamm*(6*gamm-6.0d0)/rlamb + else + sscagrad=0.0d0 + endif + return + end +C----------------------------------------------------------------------- +C first for shielding is setting of function of side-chains + subroutine set_shield_fac2 + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SHIELD' + include 'COMMON.INTERACT' +C this is the squar root 77 devided by 81 the epislion in lipid (in protein) + double precision div77_81/0.974996043d0/, + &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) + +C the vector between center of side_chain and peptide group + double precision pep_side(3),long,side_calf(3), + &pept_group(3),costhet_grad(3),cosphi_grad_long(3), + &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) +C the line belowe needs to be changed for FGPROC>1 + do i=1,nres-1 + if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle + ishield_list(i)=0 +Cif there two consequtive dummy atoms there is no peptide group between them +C the line below has to be changed for FGPROC>1 + VolumeTotal=0.0 + do k=1,nres + if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle + dist_pep_side=0.0 + dist_side_calf=0.0 + do j=1,3 +C first lets set vector conecting the ithe side-chain with kth side-chain + pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 +C pep_side(j)=2.0d0 +C and vector conecting the side-chain with its proper calfa + side_calf(j)=c(j,k+nres)-c(j,k) +C side_calf(j)=2.0d0 + pept_group(j)=c(j,i)-c(j,i+1) +C lets have their lenght + dist_pep_side=pep_side(j)**2+dist_pep_side + dist_side_calf=dist_side_calf+side_calf(j)**2 + dist_pept_group=dist_pept_group+pept_group(j)**2 + enddo + dist_pep_side=dsqrt(dist_pep_side) + dist_pept_group=dsqrt(dist_pept_group) + dist_side_calf=dsqrt(dist_side_calf) + do j=1,3 + pep_side_norm(j)=pep_side(j)/dist_pep_side + side_calf_norm(j)=dist_side_calf + enddo +C now sscale fraction + sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield +C print *,buff_shield,"buff" +C now sscale + if (sh_frac_dist.le.0.0) cycle +C If we reach here it means that this side chain reaches the shielding sphere +C Lets add him to the list for gradient + ishield_list(i)=ishield_list(i)+1 +C ishield_list is a list of non 0 side-chain that contribute to factor gradient +C this list is essential otherwise problem would be O3 + shield_list(ishield_list(i),i)=k +C Lets have the sscale value + if (sh_frac_dist.gt.1.0) then + scale_fac_dist=1.0d0 + do j=1,3 + sh_frac_dist_grad(j)=0.0d0 + enddo + else + scale_fac_dist=-sh_frac_dist*sh_frac_dist + & *(2.0d0*sh_frac_dist-3.0d0) + fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) + & /dist_pep_side/buff_shield*0.5d0 +C remember for the final gradient multiply sh_frac_dist_grad(j) +C for side_chain by factor -2 ! + do j=1,3 + sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) +C sh_frac_dist_grad(j)=0.0d0 +C scale_fac_dist=1.0d0 +C print *,"jestem",scale_fac_dist,fac_help_scale, +C & sh_frac_dist_grad(j) + enddo + endif +C this is what is now we have the distance scaling now volume... + short=short_r_sidechain(itype(k)) + long=long_r_sidechain(itype(k)) + costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2) + sinthet=short/dist_pep_side*costhet +C now costhet_grad +C costhet=0.6d0 +C sinthet=0.8 + costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4 +C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet +C & -short/dist_pep_side**2/costhet) +C costhet_fac=0.0d0 + do j=1,3 + costhet_grad(j)=costhet_fac*pep_side(j) + enddo +C remember for the final gradient multiply costhet_grad(j) +C for side_chain by factor -2 ! +C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 +C pep_side0pept_group is vector multiplication + pep_side0pept_group=0.0d0 + do j=1,3 + pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) + enddo + cosalfa=(pep_side0pept_group/ + & (dist_pep_side*dist_side_calf)) + fac_alfa_sin=1.0d0-cosalfa**2 + fac_alfa_sin=dsqrt(fac_alfa_sin) + rkprim=fac_alfa_sin*(long-short)+short +C rkprim=short + +C now costhet_grad + cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2) +C cosphi=0.6 + cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4 + sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ + & dist_pep_side**2) +C sinphi=0.8 + do j=1,3 + cosphi_grad_long(j)=cosphi_fac*pep_side(j) + &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa/ + &((dist_pep_side*dist_side_calf))* + &((side_calf(j))-cosalfa* + &((pep_side(j)/dist_pep_side)*dist_side_calf)) +C cosphi_grad_long(j)=0.0d0 + cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa + &/((dist_pep_side*dist_side_calf))* + &(pep_side(j)- + &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) +C cosphi_grad_loc(j)=0.0d0 + enddo +C print *,sinphi,sinthet + VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) + & /VSolvSphere_div +C & *wshield +C now the gradient... + do j=1,3 + grad_shield(j,i)=grad_shield(j,i) +C gradient po skalowaniu + & +(sh_frac_dist_grad(j)*VofOverlap +C gradient po costhet + & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* + &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( + & sinphi/sinthet*costhet*costhet_grad(j) + & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) + & )*wshield +C grad_shield_side is Cbeta sidechain gradient + grad_shield_side(j,ishield_list(i),i)= + & (sh_frac_dist_grad(j)*-2.0d0 + & *VofOverlap + & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0* + &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( + & sinphi/sinthet*costhet*costhet_grad(j) + & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) + & )*wshield + + grad_shield_loc(j,ishield_list(i),i)= + & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0* + &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*( + & sinthet/sinphi*cosphi*cosphi_grad_loc(j) + & )) + & *wshield + enddo + VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist + enddo + fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield) +C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) + enddo + return + end +C first for shielding is setting of function of side-chains + subroutine set_shield_fac + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SHIELD' + include 'COMMON.INTERACT' +C this is the squar root 77 devided by 81 the epislion in lipid (in protein) + double precision div77_81/0.974996043d0/, + &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) + +C the vector between center of side_chain and peptide group + double precision pep_side(3),long,side_calf(3), + &pept_group(3),costhet_grad(3),cosphi_grad_long(3), + &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) +C the line belowe needs to be changed for FGPROC>1 + do i=1,nres-1 + if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle + ishield_list(i)=0 +Cif there two consequtive dummy atoms there is no peptide group between them +C the line below has to be changed for FGPROC>1 + VolumeTotal=0.0 + do k=1,nres + if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle + dist_pep_side=0.0 + dist_side_calf=0.0 + do j=1,3 +C first lets set vector conecting the ithe side-chain with kth side-chain + pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 +C pep_side(j)=2.0d0 +C and vector conecting the side-chain with its proper calfa + side_calf(j)=c(j,k+nres)-c(j,k) +C side_calf(j)=2.0d0 + pept_group(j)=c(j,i)-c(j,i+1) +C lets have their lenght + dist_pep_side=pep_side(j)**2+dist_pep_side + dist_side_calf=dist_side_calf+side_calf(j)**2 + dist_pept_group=dist_pept_group+pept_group(j)**2 + enddo + dist_pep_side=dsqrt(dist_pep_side) + dist_pept_group=dsqrt(dist_pept_group) + dist_side_calf=dsqrt(dist_side_calf) + do j=1,3 + pep_side_norm(j)=pep_side(j)/dist_pep_side + side_calf_norm(j)=dist_side_calf + enddo +C now sscale fraction + sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield +C print *,buff_shield,"buff" +C now sscale + if (sh_frac_dist.le.0.0) cycle +C If we reach here it means that this side chain reaches the shielding sphere +C Lets add him to the list for gradient + ishield_list(i)=ishield_list(i)+1 +C ishield_list is a list of non 0 side-chain that contribute to factor gradient +C this list is essential otherwise problem would be O3 + shield_list(ishield_list(i),i)=k +C Lets have the sscale value + if (sh_frac_dist.gt.1.0) then + scale_fac_dist=1.0d0 + do j=1,3 + sh_frac_dist_grad(j)=0.0d0 + enddo + else + scale_fac_dist=-sh_frac_dist*sh_frac_dist + & *(2.0*sh_frac_dist-3.0d0) + fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2) + & /dist_pep_side/buff_shield*0.5 +C remember for the final gradient multiply sh_frac_dist_grad(j) +C for side_chain by factor -2 ! + do j=1,3 + sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) +C print *,"jestem",scale_fac_dist,fac_help_scale, +C & sh_frac_dist_grad(j) + enddo + endif +C if ((i.eq.3).and.(k.eq.2)) then +C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist +C & ,"TU" +C endif + +C this is what is now we have the distance scaling now volume... + short=short_r_sidechain(itype(k)) + long=long_r_sidechain(itype(k)) + costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2) +C now costhet_grad +C costhet=0.0d0 + costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4 +C costhet_fac=0.0d0 + do j=1,3 + costhet_grad(j)=costhet_fac*pep_side(j) + enddo +C remember for the final gradient multiply costhet_grad(j) +C for side_chain by factor -2 ! +C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 +C pep_side0pept_group is vector multiplication + pep_side0pept_group=0.0 + do j=1,3 + pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) + enddo + cosalfa=(pep_side0pept_group/ + & (dist_pep_side*dist_side_calf)) + fac_alfa_sin=1.0-cosalfa**2 + fac_alfa_sin=dsqrt(fac_alfa_sin) + rkprim=fac_alfa_sin*(long-short)+short +C now costhet_grad + cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2) + cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4 + + do j=1,3 + cosphi_grad_long(j)=cosphi_fac*pep_side(j) + &+cosphi**3*0.5/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa/ + &((dist_pep_side*dist_side_calf))* + &((side_calf(j))-cosalfa* + &((pep_side(j)/dist_pep_side)*dist_side_calf)) + + cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa + &/((dist_pep_side*dist_side_calf))* + &(pep_side(j)- + &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) + enddo + + VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi) + & /VSolvSphere_div + & *wshield +C now the gradient... +C grad_shield is gradient of Calfa for peptide groups +C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist, +C & costhet,cosphi +C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group, +C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k) + do j=1,3 + grad_shield(j,i)=grad_shield(j,i) +C gradient po skalowaniu + & +(sh_frac_dist_grad(j) +C gradient po costhet + &-scale_fac_dist*costhet_grad(j)/(1.0-costhet) + &-scale_fac_dist*(cosphi_grad_long(j)) + &/(1.0-cosphi) )*div77_81 + &*VofOverlap +C grad_shield_side is Cbeta sidechain gradient + grad_shield_side(j,ishield_list(i),i)= + & (sh_frac_dist_grad(j)*-2.0d0 + & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet) + & +scale_fac_dist*(cosphi_grad_long(j)) + & *2.0d0/(1.0-cosphi)) + & *div77_81*VofOverlap + + grad_shield_loc(j,ishield_list(i),i)= + & scale_fac_dist*cosphi_grad_loc(j) + & *2.0d0/(1.0-cosphi) + & *div77_81*VofOverlap + enddo + VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist + enddo + fac_shield(i)=VolumeTotal*div77_81+div4_81 +C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) + enddo + return + end +C-------------------------------------------------------------------------- +C----------------------------------------------------------------------- + double precision function sscalelip(r) + double precision r,gamm + include "COMMON.SPLITELE" +C if(r.lt.r_cut-rlamb) then +C sscale=1.0d0 +C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then +C gamm=(r-(r_cut-rlamb))/rlamb + sscalelip=1.0d0+r*r*(2*r-3.0d0) +C else +C sscale=0d0 +C endif + return + end +C----------------------------------------------------------------------- + double precision function sscagradlip(r) + double precision r,gamm + include "COMMON.SPLITELE" +C if(r.lt.r_cut-rlamb) then +C sscagrad=0.0d0 +C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then +C gamm=(r-(r_cut-rlamb))/rlamb + sscagradlip=r*(6*r-6.0d0) +C else +C sscagrad=0.0d0 +C endif + return + end + +C----------------------------------------------------------------------- +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + subroutine Eliptransfer(eliptran) + 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.CALC' + include 'COMMON.CONTROL' + include 'COMMON.SPLITELE' + include 'COMMON.SBRIDGE' +C this is done by Adasko +C print *,"wchodze" +C structure of box: +C water +C--bordliptop-- buffore starts +C--bufliptop--- here true lipid starts +C lipid +C--buflipbot--- lipid ends buffore starts +C--bordlipbot--buffore ends + eliptran=0.0 + write(iout,*) "I am in?" + do i=1,nres +C do i=1,1 + if (itype(i).eq.ntyp1) cycle + + positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize)) + if (positi.le.0) positi=positi+boxzsize +C print *,i +C first for peptide groups +c for each residue check if it is in lipid or lipid water border area + if ((positi.gt.bordlipbot) + &.and.(positi.lt.bordliptop)) then +C the energy transfer exist + if (positi.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((positi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslip=sscalelip(fracinbuf) + ssgradlip=-sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*pepliptran + gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 + gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 +C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran + elseif (positi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) + sslip=sscalelip(fracinbuf) + ssgradlip=sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*pepliptran + gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 + gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 +C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran +C print *, "doing sscalefor top part" +C print *,i,sslip,fracinbuf,ssgradlip + else + eliptran=eliptran+pepliptran +C print *,"I am in true lipid" + endif +C else +C eliptran=elpitran+0.0 ! I am in water + endif + enddo +C print *, "nic nie bylo w lipidzie?" +C now multiply all by the peptide group transfer factor +C eliptran=eliptran*pepliptran +C now the same for side chains +CV do i=1,1 + do i=1,nres + if (itype(i).eq.ntyp1) cycle + positi=(mod(c(3,i+nres),boxzsize)) + if (positi.le.0) positi=positi+boxzsize +C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop +c for each residue check if it is in lipid or lipid water border area +C respos=mod(c(3,i+nres),boxzsize) +C print *,positi,bordlipbot,buflipbot + if ((positi.gt.bordlipbot) + & .and.(positi.lt.bordliptop)) then +C the energy transfer exist + if (positi.lt.buflipbot) then + fracinbuf=1.0d0- + & ((positi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslip=sscalelip(fracinbuf) + ssgradlip=-sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*liptranene(itype(i)) + gliptranx(3,i)=gliptranx(3,i) + &+ssgradlip*liptranene(itype(i)) + gliptranc(3,i-1)= gliptranc(3,i-1) + &+ssgradlip*liptranene(itype(i)) +C print *,"doing sccale for lower part" + elseif (positi.gt.bufliptop) then + fracinbuf=1.0d0- + &((bordliptop-positi)/lipbufthick) + sslip=sscalelip(fracinbuf) + ssgradlip=sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*liptranene(itype(i)) + gliptranx(3,i)=gliptranx(3,i) + &+ssgradlip*liptranene(itype(i)) + gliptranc(3,i-1)= gliptranc(3,i-1) + &+ssgradlip*liptranene(itype(i)) +C print *, "doing sscalefor top part",sslip,fracinbuf + else + eliptran=eliptran+liptranene(itype(i)) +C print *,"I am in true lipid" + endif + endif ! if in lipid or buffor +C else +C eliptran=elpitran+0.0 ! I am in water + enddo + return + end +C------------------------------------------------------------------------------------- diff --git a/source/cluster/wham/src-HCD/fitsq.f b/source/cluster/wham/src-HCD/fitsq.f new file mode 100644 index 0000000..17d92ee --- /dev/null +++ b/source/cluster/wham/src-HCD/fitsq.f @@ -0,0 +1,352 @@ + subroutine fitsq(rms,x,y,nn,t,b,non_conv) + implicit real*8 (a-h,o-z) + include 'COMMON.IOUNITS' +c x and y are the vectors of coordinates (dimensioned (3,n)) of the two +c structures to be superimposed. nn is 3*n, where n is the number of +c points. t and b are respectively the translation vector and the +c rotation matrix that transforms the second set of coordinates to the +c frame of the first set. +c eta = machine-specific variable + + dimension x(3*nn),y(3*nn),t(3) + dimension b(3,3),q(3,3),r(3,3),v(3),xav(3),yav(3),e(3),c(3,3) + logical non_conv + eta = z00100000 +c small=25.0*rmdcon(3) +c small=25.0*eta +c small=25.0*10.e-10 +c the following is a very lenient value for 'small' + small = 0.0001D0 + non_conv=.false. + fn=nn + do 10 i=1,3 + xav(i)=0.0D0 + yav(i)=0.0D0 + do 10 j=1,3 + 10 b(j,i)=0.0D0 + nc=0 +c + do 30 n=1,nn + do 20 i=1,3 +crc write(iout,*)'x = ',x(nc+i),' y = ',y(nc+i) + xav(i)=xav(i)+x(nc+i)/fn + 20 yav(i)=yav(i)+y(nc+i)/fn + 30 nc=nc+3 +c + do i=1,3 + t(i)=yav(i)-xav(i) + enddo + + rms=0.0d0 + do n=1,nn + do i=1,3 + rms=rms+(y(3*(n-1)+i)-x(3*(n-1)+i)-t(i))**2 + enddo + enddo + rms=dabs(rms/fn) + +c write(iout,*)'xav = ',(xav(j),j=1,3) +c write(iout,*)'yav = ',(yav(j),j=1,3) +c write(iout,*)'t = ',(t(j),j=1,3) +c write(iout,*)'rms=',rms + if (rms.lt.small) return + + + nc=0 + rms=0.0D0 + do 50 n=1,nn + do 40 i=1,3 + rms=rms+((x(nc+i)-xav(i))**2+(y(nc+i)-yav(i))**2)/fn + do 40 j=1,3 + b(j,i)=b(j,i)+(x(nc+i)-xav(i))*(y(nc+j)-yav(j))/fn + 40 c(j,i)=b(j,i) + 50 nc=nc+3 + call sivade(b,q,r,d,non_conv) + sn3=dsign(1.0d0,d) + do 120 i=1,3 + do 120 j=1,3 + 120 b(j,i)=-q(j,1)*r(i,1)-q(j,2)*r(i,2)-sn3*q(j,3)*r(i,3) + call mvvad(b,xav,yav,t) + do 130 i=1,3 + do 130 j=1,3 + rms=rms+2.0*c(j,i)*b(j,i) + 130 b(j,i)=-b(j,i) + if (dabs(rms).gt.small) go to 140 +* write (6,301) + return + 140 if (rms.gt.0.0d0) go to 150 +c write (iout,303) rms + rms=0.0d0 +* stop +c 150 write (iout,302) dsqrt(rms) + 150 continue + return + 301 format (5x,'rms deviation negligible') + 302 format (5x,'rms deviation ',f14.6) + 303 format (//,5x,'negative ms deviation - ',f14.6) + end + subroutine sivade(x,q,r,dt,non_conv) + implicit real*8(a-h,o-z) +c computes q,e and r such that q(t)xr = diag(e) + dimension x(3,3),q(3,3),r(3,3),e(3) + dimension h(3,3),p(3,3),u(3,3),d(3) + logical non_conv + eta = z00100000 + nit = 0 + small=25.0*10.e-10 +c small=25.0*eta +c small=2.0*rmdcon(3) + xnrm=0.0d0 + do 20 i=1,3 + do 10 j=1,3 + xnrm=xnrm+x(j,i)*x(j,i) + u(j,i)=0.0d0 + r(j,i)=0.0d0 + 10 h(j,i)=0.0d0 + u(i,i)=1.0 + 20 r(i,i)=1.0 + xnrm=dsqrt(xnrm) + do 110 n=1,2 + xmax=0.0d0 + do 30 j=n,3 + 30 if (dabs(x(j,n)).gt.xmax) xmax=dabs(x(j,n)) + a=0.0d0 + do 40 j=n,3 + h(j,n)=x(j,n)/xmax + 40 a=a+h(j,n)*h(j,n) + a=dsqrt(a) + den=a*(a+dabs(h(n,n))) + d(n)=1.0/den + h(n,n)=h(n,n)+dsign(a,h(n,n)) + do 70 i=n,3 + s=0.0d0 + do 50 j=n,3 + 50 s=s+h(j,n)*x(j,i) + s=d(n)*s + do 60 j=n,3 + 60 x(j,i)=x(j,i)-s*h(j,n) + 70 continue + if (n.gt.1) go to 110 + xmax=dmax1(dabs(x(1,2)),dabs(x(1,3))) + h(2,3)=x(1,2)/xmax + h(3,3)=x(1,3)/xmax + a=dsqrt(h(2,3)*h(2,3)+h(3,3)*h(3,3)) + den=a*(a+dabs(h(2,3))) + d(3)=1.0/den + h(2,3)=h(2,3)+sign(a,h(2,3)) + do 100 i=1,3 + s=0.0d0 + do 80 j=2,3 + 80 s=s+h(j,3)*x(i,j) + s=d(3)*s + do 90 j=2,3 + 90 x(i,j)=x(i,j)-s*h(j,3) + 100 continue + 110 continue + do 130 i=1,3 + do 120 j=1,3 + 120 p(j,i)=-d(1)*h(j,1)*h(i,1) + 130 p(i,i)=1.0+p(i,i) + do 140 i=2,3 + do 140 j=2,3 + u(j,i)=u(j,i)-d(2)*h(j,2)*h(i,2) + 140 r(j,i)=r(j,i)-d(3)*h(j,3)*h(i,3) + call mmmul(p,u,q) + 150 np=1 + nq=1 + nit=nit+1 + 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 + if (np.gt.npq) go to 230 + n0=0 + do 220 n=np,npq + nn=n+np-1 + 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 + 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 + 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 + 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 + 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 + 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 (1,501) (e(i),i=1,3) + return + 501 format (/,5x,'singular values - ',3e15.5) + end + subroutine givns(a,b,m,n) + implicit real*8 (a-h,o-z) + dimension a(3,3),b(3,3) + if (dabs(a(m,n)).lt.dabs(a(n,n))) go to 10 + t=a(n,n)/a(m,n) + s=1.0/dsqrt(1.0+t*t) + c=s*t + go to 20 + 10 t=a(m,n)/a(n,n) + c=1.0/dsqrt(1.0+t*t) + s=c*t + 20 do 30 j=1,3 + v=a(m,j) + w=a(n,j) + x=b(j,m) + y=b(j,n) + a(m,j)=c*v-s*w + a(n,j)=s*v+c*w + b(j,m)=c*x-s*y + 30 b(j,n)=s*x+c*y + return + end + subroutine switch(n,m,u,v,d) + implicit real*8 (a-h,o-z) + dimension u(3,3),v(3,3),d(3) + do 10 i=1,3 + tem=u(i,n) + u(i,n)=u(i,n-1) + u(i,n-1)=tem + if (m.eq.0) go to 10 + tem=v(i,n) + v(i,n)=v(i,n-1) + v(i,n-1)=tem + 10 continue + tem=d(n) + d(n)=d(n-1) + d(n-1)=tem + return + end + subroutine mvvad(b,xav,yav,t) + implicit real*8 (a-h,o-z) + dimension b(3,3),xav(3),yav(3),t(3) +c dimension a(3,3),b(3),c(3),d(3) +c do 10 j=1,3 +c d(j)=c(j) +c do 10 i=1,3 +c 10 d(j)=d(j)+a(j,i)*b(i) + do 10 j=1,3 + t(j)=yav(j) + do 10 i=1,3 + 10 t(j)=t(j)+b(j,i)*xav(i) + return + end + double precision function det (a,b,c) + implicit real*8 (a-h,o-z) + dimension a(3),b(3),c(3) + det=a(1)*(b(2)*c(3)-b(3)*c(2))+a(2)*(b(3)*c(1)-b(1)*c(3)) + 1 +a(3)*(b(1)*c(2)-b(2)*c(1)) + return + end + subroutine mmmul(a,b,c) + implicit real*8 (a-h,o-z) + dimension a(3,3),b(3,3),c(3,3) + do 10 i=1,3 + do 10 j=1,3 + c(i,j)=0.0d0 + do 10 k=1,3 + 10 c(i,j)=c(i,j)+a(i,k)*b(k,j) + return + end + subroutine matvec(uvec,tmat,pvec,nback) + implicit real*8 (a-h,o-z) + real*8 tmat(3,3),uvec(3,nback), pvec(3,nback) +c + do 2 j=1,nback + do 1 i=1,3 + uvec(i,j) = 0.0d0 + do 1 k=1,3 + 1 uvec(i,j)=uvec(i,j)+tmat(i,k)*pvec(k,j) + 2 continue + return + end diff --git a/source/cluster/wham/src-HCD/geomout.F b/source/cluster/wham/src-HCD/geomout.F new file mode 100644 index 0000000..4ef656f --- /dev/null +++ b/source/cluster/wham/src-HCD/geomout.F @@ -0,0 +1,201 @@ + subroutine pdbout(etot,rmsd,tytul) + 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*50 tytul + character*1 chainid(10) /'A','B','C','D','E','F','G','H','I','J'/ + dimension ica(maxres) + 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 +c------------------------------------------------------------------------------ + subroutine MOL2out(etot,tytul) +C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2 +C format. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.HEADER' + include 'COMMON.SBRIDGE' + character*32 tytul,fd + character*4 liczba + character*6 res_num,pom,ucase +#ifdef AIX + call fdate_(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,nct-nnt+1,0,0 + write (imol2,'(a)') 'SMALL' + write (imol2,'(a)') 'USER_CHARGES' + write (imol2,'(a)') '@ATOM' + do i=nnt,nct +c write (liczba,*) i + pom=ucase(restyp(itype(i))) +c res_num = pom(:3)//liczba(2:) + write (imol2,10) i-nnt+1,(c(j,i),j=1,3),i-nnt+1,pom,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 (liczba,'(i4)') i + pom = ucase(restyp(itype(i))) +c res_num = pom(:3)//liczba(2:) + write (imol2,30) i-nnt+1,pom,i-nnt+1,0 + enddo + 10 FORMAT (I7,' CA ',3F10.4,' C.3',I8,1X,A,F11.4,' ****') + 30 FORMAT (I7,1x,A,I14,' RESIDUE',I13,' **** ****') + return + end +c------------------------------------------------------------------------ + subroutine intout + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + write (iout,'(/a)') 'Geometry of the virtual chain.' + write (iout,'(6a)') ' Res ',' Theta',' Phi', + & ' Dsc',' Alpha',' Omega' + do i=1,nres + iti=itype(i) + write (iout,'(a3,i4,5f10.3)') restyp(iti),i,rad2deg*theta(i), + & rad2deg*phi(i),dsc(iti),rad2deg*alph(i),rad2deg*omeg(i) + enddo + return + end +c--------------------------------------------------------------------------- + subroutine briefout(it,klasa,ener,free,nss,ihpb,jhpb,plik) + 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' + dimension ihpb(maxss),jhpb(maxss) + character*80 plik +c print '(a,i5)',intname,igeom +#ifdef AIX + open (igeom,file=plik,position='append') +#else + open (igeom,file=plik,position='append') +#endif + IF (NSS.LT.9) THEN + 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) + write (igeom,'(a)') + WRITE (igeom,190) (IHPB(I),JHPB(I),I=9,NSS) + ENDIF + write (igeom,'(i10)') klasa +c IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) + WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) + WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES) +c if (nvar.gt.nphi+ntheta) then + write (igeom,200) (rad2deg*alph(i),i=2,nres-1) + write (igeom,200) (rad2deg*omeg(i),i=2,nres-1) +c endif + close(igeom) + 180 format (I5,2F12.3,I2,$,8(1X,2I3,$)) + 190 format (3X,11(1X,2I3,$)) + 200 format (8F10.4) + return + end +c--------------------------------------------------------------------------- + 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' + character*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 diff --git a/source/cluster/wham/src-HCD/gnmr1.f b/source/cluster/wham/src-HCD/gnmr1.f new file mode 100644 index 0000000..2357e6d --- /dev/null +++ b/source/cluster/wham/src-HCD/gnmr1.f @@ -0,0 +1,74 @@ + double precision function gnmr1(y,ymin,ymax) + implicit none + double precision y,ymin,ymax + double precision wykl /4.0d0/ + if (y.lt.ymin) then + gnmr1=(ymin-y)**wykl/wykl + else if (y.gt.ymax) then + gnmr1=(y-ymax)**wykl/wykl + else + gnmr1=0.0d0 + endif + return + end +c------------------------------------------------------------------------------ + double precision function gnmr1prim(y,ymin,ymax) + implicit none + double precision y,ymin,ymax + double precision wykl /4.0d0/ + if (y.lt.ymin) then + gnmr1prim=-(ymin-y)**(wykl-1) + else if (y.gt.ymax) then + gnmr1prim=(y-ymax)**(wykl-1) + else + gnmr1prim=0.0d0 + endif + return + end +c------------------------------------------------------------------------------ + double precision function harmonic(y,ymax) + implicit none + double precision y,ymax + double precision wykl /2.0d0/ + harmonic=(y-ymax)**wykl + return + end +c------------------------------------------------------------------------------- + double precision function harmonicprim(y,ymax) + double precision y,ymin,ymax + double precision wykl /2.0d0/ + harmonicprim=(y-ymax)*wykl + return + end +c--------------------------------------------------------------------------------- +c--------------------------------------------------------------------------------- + double precision function rlornmr1(y,ymin,ymax,sigma) + implicit none + double precision y,ymin,ymax,sigma + double precision wykl /4.0d0/ + if (y.lt.ymin) then + rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl) + else if (y.gt.ymax) then + rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl) + else + rlornmr1=0.0d0 + endif + return + end +c------------------------------------------------------------------------------ + double precision function rlornmr1prim(y,ymin,ymax,sigma) + implicit none + double precision y,ymin,ymax,sigma + double precision wykl /4.0d0/ + if (y.lt.ymin) then + rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ + & ((ymin-y)**wykl+sigma**wykl)**2 + else if (y.gt.ymax) then + rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ + & ((y-ymax)**wykl+sigma**wykl)**2 + else + rlornmr1prim=0.0d0 + endif + return + end + diff --git a/source/cluster/wham/src-HCD/hc.f b/source/cluster/wham/src-HCD/hc.f new file mode 100644 index 0000000..3d514a7 --- /dev/null +++ b/source/cluster/wham/src-HCD/hc.f @@ -0,0 +1,479 @@ +C*********************** Contents **************************************** +C* Sample driver program, VAX-11 Fortran; ********************************** +C* HC: O(n^2) time, O(n^2) space hierarchical clustering, Fortran 77 ******* +C* HCASS: determine cluster-memberships, Fortran 77. *********************** +C* HCDEN: draw upper part of dendrogram, VAX-11 Fortran. ******************* +C* Sample data set: last 36 lines. ***************************************** +C*************************************************************************** +C REAL DATA(18,16),CRIT(18),MEMBR(18) +C REAL CRITVAL(9) +C INTEGER IA(18),IB(18) +C INTEGER ICLASS(18,9),HVALS(9) +C INTEGER IORDER(9),HEIGHT(9) +C DIMENSION NN(18),DISNN(18) +C REAL D(153) +C LOGICAL FLAG(18) +C IN ABOVE, 18=N, 16=M, 9=LEV, 153=N(N-1)/2. +C +C +C OPEN(UNIT=21,STATUS='OLD',FILE='SPECTR.DAT') +C +C +C N = 18 +C M = 16 +C DO I=1,N +C READ(21,100)(DATA(I,J),J=1,M) +C ENDDO +C 100 FORMAT(8F7.1) +C +C +C LEN = (N*(N-1))/2 +C IOPT=1 +C CALL HC(N,M,LEN,IOPT,DATA,IA,IB,CRIT,MEMBR,NN,DISNN,FLAG,D) +C +C +C LEV = 9 +C CALL HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER,CRITVAL,HEIGHT) +C +C +C CALL HCDEN(LEV,IORDER,HEIGHT,CRITVAL) +C +C +C END +C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C +C C +C HIERARCHICAL CLUSTERING using (user-specified) criterion. C +C C +C Parameters: C +C C +Cremoved DATA(N,M) input data matrix, C +C DISS(LEN) dissimilarities in lower half diagonal C +C storage; LEN = N.N-1/2, C +C IOPT clustering criterion to be used, C +C IA, IB, CRIT history of agglomerations; dimensions C +C N, first N-1 locations only used, C +C MEMBR, NN, DISNN vectors of length N, used to store C +C cluster cardinalities, current nearest C +C neighbour, and the dissimilarity assoc. C +C with the latter. C +C FLAG boolean indicator of agglomerable obj./ C +C clusters. C +C C +C F. Murtagh, ESA/ESO/STECF, Garching, February 1986. C +C C +C------------------------------------------------------------C + SUBROUTINE HC(N,M,LEN,IOPT,IA,IB,CRIT,MEMBR,NN,DISNN, + X FLAG,DISS) + REAL MEMBR(N) + REAL DISS(LEN) + INTEGER IA(N),IB(N) + REAL CRIT(N) + DIMENSION NN(N),DISNN(N) + LOGICAL FLAG(N) + REAL INF + DATA INF/1.E+20/ +C +C Initializations +C + DO I=1,N + MEMBR(I)=1. + FLAG(I)=.TRUE. + ENDDO + NCL=N +C +C Construct dissimilarity matrix +C + DO I=1,N-1 + DO J=I+1,N + IND=IOFFSET(N,I,J) +cinput DISS(IND)=0. +cinput DO K=1,M +cinput DISS(IND)=DISS(IND)+(DATA(I,K)-DATA(J,K))**2 +cinput ENDDO + IF (IOPT.EQ.1) DISS(IND)=DISS(IND)/2. +C (Above is done for the case of the min. var. method +C where merging criteria are defined in terms of variances +C rather than distances.) + ENDDO + ENDDO +C +C Carry out an agglomeration - first create list of NNs +C + 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 +C + 400 CONTINUE +C 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 +C +C This allows an agglomeration to be carried out. +C + I2=MIN0(IM,JM) + J2=MAX0(IM,JM) + IA(N-NCL)=I2 + IB(N-NCL)=J2 + CRIT(N-NCL)=DMIN +C +C Update dissimilarities from new cluster. +C + 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) +C +C WARD'S MINIMUM VARIANCE METHOD - IOPT=1. +C + IF (IOPT.EQ.1) THEN + DISS(IND1)=(MEMBR(I2)+MEMBR(K))*DISS(IND1)+ + X (MEMBR(J2)+MEMBR(K))*DISS(IND2)- + X MEMBR(K)*XX + DISS(IND1)=DISS(IND1)/X + ENDIF +C +C SINGLE LINK METHOD - IOPT=2. +C + IF (IOPT.EQ.2) THEN + DISS(IND1)=MIN(DISS(IND1),DISS(IND2)) + ENDIF +C +C COMPLETE LINK METHOD - IOPT=3. +C + IF (IOPT.EQ.3) THEN + DISS(IND1)=MAX(DISS(IND1),DISS(IND2)) + ENDIF +C +C AVERAGE LINK (OR GROUP AVERAGE) METHOD - IOPT=4. +C + IF (IOPT.EQ.4) THEN + DISS(IND1)=(MEMBR(I2)*DISS(IND1)+MEMBR(J2)*DISS(IND2))/ + X (MEMBR(I2)+MEMBR(J2)) + ENDIF +C +C MCQUITTY'S METHOD - IOPT=5. +C + IF (IOPT.EQ.5) THEN + DISS(IND1)=0.5*DISS(IND1)+0.5*DISS(IND2) + ENDIF +C +C MEDIAN (GOWER'S) METHOD - IOPT=6. +C + IF (IOPT.EQ.6) THEN + DISS(IND1)=0.5*DISS(IND1)+0.5*DISS(IND2)-0.25*XX + ENDIF +C +C CENTROID METHOD - IOPT=7. +C + IF (IOPT.EQ.7) THEN + DISS(IND1)=(MEMBR(I2)*DISS(IND1)+MEMBR(J2)*DISS(IND2)- + X MEMBR(I2)*MEMBR(J2)*XX/(MEMBR(I2)+MEMBR(J2)))/ + X (MEMBR(I2)+MEMBR(J2)) + ENDIF +C + 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 +C +C Update list of NNs insofar as this is required. +C + 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 +C (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 +C +C Repeat previous steps until N-1 agglomerations carried out. +C + IF (NCL.GT.1) GOTO 400 +C +C + RETURN + END +C +C + FUNCTION IOFFSET(N,I,J) +C Map row I and column J of upper half diagonal symmetric matrix +C onto vector. + IOFFSET=J+(I-1)*N-(I*(I+1))/2 + RETURN + END +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C +C C +C Given a HIERARCHIC CLUSTERING, described as a sequence of C +C agglomerations, derive the assignments into clusters for the C +C top LEV-1 levels of the hierarchy. C +C Prepare also the required data for representing the C +C dendrogram of this top part of the hierarchy. C +C C +C Parameters: C +C C +C IA, IB, CRIT: vectors of dimension N defining the agglomer- C +C ations. C +C LEV: number of clusters in largest partition. C +C HVALS: vector of dim. LEV, used internally only. C +C ICLASS: array of cluster assignments; dim. N by LEV. C +C IORDER, CRITVAL, HEIGHT: vectors describing the dendrogram, C +C all of dim. LEV. C +C C +C F. Murtagh, ESA/ESO/STECF, Garching, February 1986. C +C C +C HISTORY C +C C +C Bounds bug fix, Oct. 1990, F. Murtagh. C +C Inserted line "IF (LOC.GT.LEV) GOTO 58" on line 48. This was C +C occassioned by incorrect termination of this loop when I C +C reached its (lower) extremity, i.e. N-LEV. Without the C +C /CHECK=(BOUNDS) option on VAX/VMS compilation, this inserted C +C statement was not necessary. C +C---------------------------------------------------------------C + SUBROUTINE HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER, + X CRITVAL,HEIGHT) + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + integer ICLASS(maxconf,maxconf-1) + INTEGER IA(N),IB(N),HVALS(LEV),IORDER(LEV), + X HEIGHT(LEV) + REAL CRIT(N),CRITVAL(LEV) +C +C Pick out the clusters which the N objects belong to, +C at levels N-2, N-3, ... N-LEV+1 of the hierarchy. +C The clusters are identified by the lowest seq. no. of +C their members. +C There are 2, 3, ... LEV clusters, respectively, for the +C above levels of the hierarchy. +C + 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 +C + 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 +C + 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 +C +c WRITE (iout,450) (j,j=2,LEV) + 450 FORMAT(4X,' SEQ NOS',8(i2,'CL'),10000(i3,'CL')) +c WRITE (iout,470) (' ---',j=2,LEV) + 470 FORMAT(4X,' -------',10000a4) + DO 500 I=1,N +c WRITE (iout,600) I,(ICLASS(I,J),J=1,LEV-1) + 600 FORMAT(I11,8I4,10000i5) + 500 CONTINUE +C +C Determine an ordering of the LEV clusters (at level LEV-1) +C for later representation of the dendrogram. +C These are stored in IORDER. +C Determine the associated ordering of the criterion values +C for the vertical lines in the dendrogram. +C The ordinal values of these criterion values may be used in +C preference, and these are stored in HEIGHT. +C Finally, note that the LEV clusters are renamed so that they +C have seq. nos. 1 to LEV. +C + 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 +C 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 +C + RETURN + END +C+++++++++++++++++++++++++++++++++++++++++++++++++C +C C +C Construct a DENDROGRAM of the top 8 levels of C +C a HIERARCHIC CLUSTERING. C +C C +C Parameters: C +C C +C IORDER, HEIGHT, CRITVAL: vectors of length LEV C +C defining the dendrogram. C +C These are: the ordering of objects C +C along the bottom of the dendrogram C +C (IORDER); the height of the vertical C +C above each object, in ordinal values C +C (HEIGHT); and in real values (CRITVAL).C +C C +C NOTE: these vectors MUST have been set up with C +C LEV = 9 in the prior call to routine C +C HCASS. +C C +C F. Murtagh, ESA/ESO/STECF, Garching, Feb. 1986.C +C C +C-------------------------------------------------C + SUBROUTINE HCDEN(LEV,IORDER,HEIGHT,CRITVAL) + include 'COMMON.IOUNITS' + CHARACTER*80 LINE + INTEGER IORDER(LEV),HEIGHT(LEV) + REAL CRITVAL(LEV) +c INTEGER OUT(3*LEV,3*LEV) +c INTEGER UP,ACROSS,BLANK + CHARACTER*1 OUT(3*LEV,3*LEV) + CHARACTER*1 UP,ACROSS,BLANK + DATA UP,ACROSS,BLANK/'|','-',' '/ +C +C + DO I=1,3*LEV + DO J=1,3*LEV + OUT(I,J)=BLANK + ENDDO + ENDDO +C +C + DO I=3,3*LEV,3 + I2=I/3 +C + J2=3*LEV+1-3*HEIGHT(I2) + DO J=3*LEV,J2,-1 + OUT(J,I)=UP + ENDDO +C + 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 +C + ENDDO +C +C + 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 +c WRITE(iout,200) CRITVAL(IDUM),(OUT(I,J),J=1,3*LEV) + IC=IC+3 + ELSE + LINE = ' ' +c 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) +c WRITE(iout,220)(IORDER(J),J=1,LEV) +c WRITE(iout,250) + 220 FORMAT(1H ,24X,9000I3) +c WRITE(iout,230) LEV + 230 FORMAT(1H ,13X,'CRITERION CLUSTERS 1 TO ',i3) +c WRITE(iout,240) LEV-1 + 240 FORMAT(1H ,13X,'VALUES. (TOP ',i3,' LEVELS OF HIERARCHY).') + 250 FORMAT(/) +C +C + RETURN + END diff --git a/source/cluster/wham/src-HCD/icant.f b/source/cluster/wham/src-HCD/icant.f new file mode 100644 index 0000000..ef794da --- /dev/null +++ b/source/cluster/wham/src-HCD/icant.f @@ -0,0 +1,9 @@ + 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 diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.CALC b/source/cluster/wham/src-HCD/include_unres/COMMON.CALC new file mode 100644 index 0000000..bf255c9 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.CALC @@ -0,0 +1,15 @@ + integer i,j,k,l + double precision erij,rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, + & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, + & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, + & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, + & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, + & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, + & dsci_inv,dscj_inv,gg,gg_lipi,gg_lipj + common /calc/ erij(3),rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, + & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, + & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, + & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, + & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, + & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, + & dsci_inv,dscj_inv,gg(3),gg_lipi(3),gg_lipj(3),i,j diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.CONTACTS b/source/cluster/wham/src-HCD/include_unres/COMMON.CONTACTS new file mode 100644 index 0000000..6129df3 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.CONTACTS @@ -0,0 +1,4 @@ +C Change 12/1/95 - common block CONTACTS1 included. + integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont + common /contacts/ ncont,ncont_ref,icont(2,maxcont), + & icont_ref(2,maxcont) diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.CONTACTS.org b/source/cluster/wham/src-HCD/include_unres/COMMON.CONTACTS.org new file mode 100644 index 0000000..ecfc97d --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.CONTACTS.org @@ -0,0 +1,77 @@ +C Change 12/1/95 - common block CONTACTS1 included. + integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont, + & num_cont_hb,jcont_hb + double precision facont,gacont,g_contij,ekont, + & gacontp_hb1,gacontp_hb2,gacontp_hb3,gacontm_hb1,gacontm_hb2, + & gacontm_hb3,gacont_hbr,grij_hb_cont,facont_hb,ees0p, + & ees0m,d_cont + common /contacts/ ncont,ncont_ref,icont(2,maxcont), + & icont_ref(2,maxcont) + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +C Interactions of pseudo-dipoles generated by loc-el interactions. + double precision dip,dipderg,dipderx + common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), + & dipderx(3,5,4,maxconts,maxres) +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,gmu,gUb2, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der, + & gtEUg + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres), + & gmu(2,maxres),gUb2(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres), + & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres), + & gtEUg(2,2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder, + & Ug2DtEUg,Ug2DtEUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),DtUg2EUgder(2,2,2,maxres), + & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres),muder(2,maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx,ADtEA1,ADtEA1derg,ADtEA1derx, + & EAEA, EAEAderg, EAEAderx + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.CONTACTS.safe b/source/cluster/wham/src-HCD/include_unres/COMMON.CONTACTS.safe new file mode 100644 index 0000000..d07a0f0 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.CONTACTS.safe @@ -0,0 +1,68 @@ +C Change 12/1/95 - common block CONTACTS1 included. + integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont + double precision facont,gacont + common /contacts/ ncont,ncont_ref,icont(2,maxcont), + & icont_ref(2,maxcont) + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +C Interactions of pseudo-dipoles generated by loc-el interactions. + double precision dip,dipderg,dipderx + common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), + & dipderx(3,5,4,maxconts,maxres) +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres), + & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),DtUg2EUgder(2,2,2,maxres), + & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres),muder(2,maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.CONTMAT b/source/cluster/wham/src-HCD/include_unres/COMMON.CONTMAT new file mode 100644 index 0000000..f0b6122 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.CONTMAT @@ -0,0 +1,26 @@ +C Change 12/1/95 - common block CONTACTS1 included. + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + double precision gacontp_hb1,gacontp_hb2,gacontp_hb3,gacont_hbr, + & gacontm_hb1,gacontm_hb2,gacontm_hb3,grij_hb_cont,facont_hb, + & ees0p,ees0m,d_cont + integer num_cont_hb,jcont_hb + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +c 7/25/08 Commented out; not needed when cumulants used +C Interactions of pseudo-dipoles generated by loc-el interactions. +c double precision dip,dipderg,dipderx +c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), +c & dipderx(3,5,4,maxconts,maxres) diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.CONTPAR b/source/cluster/wham/src-HCD/include_unres/COMMON.CONTPAR new file mode 100644 index 0000000..97a73eb --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.CONTPAR @@ -0,0 +1,3 @@ + double precision sig_comp,chi_comp,chip_comp,sc_cutoff + common /contpar/ sig_comp(ntyp,ntyp),chi_comp(ntyp,ntyp), + & chip_comp(ntyp,ntyp),sc_cutoff(ntyp,ntyp) diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.CORRMAT b/source/cluster/wham/src-HCD/include_unres/COMMON.CORRMAT new file mode 100644 index 0000000..5f154e0 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.CORRMAT @@ -0,0 +1,47 @@ +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,gmu,gUb2, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der, + & gtEug + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres), + & gmu(2,maxres),gUb2(2,maxres), + & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres), + & Dtobr2(2,maxres),Dtobr2der(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),gtEUg(2,2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder,Ug2DtEUg,Ug2DtEUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres), + & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont,EAEA,EAEAderg,EAEAderx, + & ADtEA1,AdTEA1derg,ADtEA1derx + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.DERIV b/source/cluster/wham/src-HCD/include_unres/COMMON.DERIV new file mode 100644 index 0000000..f1f5db5 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.DERIV @@ -0,0 +1,69 @@ + double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gelc_long + & gvdwpp,gel_loc,gel_loc_long,gvdwc_scpp,gliptranc,gliptranx, + & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gloc_x,dtheta,dphi,dalpha, + & domega,gscloc,gsclocx,gradcorr,gradcorr_long,gradcorr5_long, + & gradcorr6_long,gcorr6_turn_long,gvdwx,gshieldx,gradafm, + & gg_tube,gg_tube_SC, + & gshieldc, gshieldc_loc, gshieldx_ec, gshieldc_ec, + & gshieldc_loc_ec, gshieldx_t3,gshieldc_t3,gshieldc_loc_t3, + & gshieldx_t4, gshieldc_t4,gshieldc_loc_t4,gshieldx_ll, + & gelc_long,gvdwpp,gradxorr,gradcorr5,gradcorr6,gcorr3_turn, + & gcorr4_turn,gradb,gel_loc_loc,gel_loc_turn3,gel_loc_turn4, + & g_corr5_loc,g_corr6_loc,gsccorc,gsccorx,gsccor_loc,gcorr6_turn, + & gradbx,gel_loc_turn6,gcorr_loc, + & gshieldc_ll, gshieldc_loc_ll,gsaxsC,gsaxsX, + & gdfad,gdfat,gdfan,gdfab + integer nfl,icg + logical calc_grad + common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), + & gradx(3,-1:maxres,2),gradc(3,-1:maxres,2),gvdwx(3,-1:maxres), + & gvdwc(3,-1:maxres),gelc(3,-1:maxres),gelc_long(3,-1:maxres), + & gvdwpp(3,-1:maxres),gvdwc_scpp(3,-1:maxres), + & gliptranc(3,-1:maxres), + & gliptranx(3,-1:maxres), + & gshieldx(3,-1:maxres), gshieldc(3,-1:maxres), + & gshieldc_loc(3,-1:maxres), + & gshieldx_ec(3,-1:maxres), gshieldc_ec(3,-1:maxres), + & gshieldc_loc_ec(3,-1:maxres), + & gshieldx_t3(3,-1:maxres), gshieldc_t3(3,-1:maxres), + & gshieldc_loc_t3(3,-1:maxres), + & gshieldx_t4(3,-1:maxres), gshieldc_t4(3,-1:maxres), + & gshieldc_loc_t4(3,-1:maxres), + & gshieldx_ll(3,-1:maxres), gshieldc_ll(3,-1:maxres), + & gshieldc_loc_ll(3,-1:maxres), + & gradafm(3,-1:maxres),gg_tube(3,-1:maxres), + & gg_tube_sc(3,-1:maxres), + & gradx_scp(3,-1:maxres),gvdwc_scp(3,-1:maxres), + & ghpbx(3,-1:maxres), + & ghpbc(3,-1:maxres),gloc(maxvar,2),gradcorr(3,-1:maxres), + & gsaxsC(3,-1:maxres),gsaxsX(3,-1:maxres), + & gradcorr_long(3,-1:maxres),gradcorr5_long(3,-1:maxres), + & gradcorr6_long(3,-1:maxres),gcorr6_turn_long(3,-1:maxres), + & gradxorr(3,-1:maxres),gradcorr5(3,-1:maxres), + & gradcorr6(3,-1:maxres), + & gloc_x(maxvar,2),gel_loc(3,-1:maxres),gel_loc_long(3,-1:maxres), + & gcorr3_turn(3,-1:maxres), + & gcorr4_turn(3,-1:maxres),gcorr6_turn(3,-1:maxres), + & gradb(3,-1:maxres), + & gradbx(3,-1:maxres),gel_loc_loc(maxvar),gel_loc_turn3(maxvar), + & gel_loc_turn4(maxvar),gel_loc_turn6(maxvar), + & gcorr_loc(maxvar), + & g_corr5_loc(maxvar),g_corr6_loc(maxvar),gsccorc(3,-1:maxres), + & gsccorx(3,-1:maxres),gsccor_loc(-1:maxres), + & dtheta(3,2,-1:maxres), + & gscloc(3,-1:maxres),gsclocx(3,-1:maxres), + & dphi(3,3,-1:maxres),dalpha(3,3,-1:maxres),domega(3,3,-1:maxres), + & gdfad(3,maxres),gdfat(3,maxres),gdfan(3,maxres),gdfab(3,maxres), + & nfl, + & icg,calc_grad + double precision derx,derx_turn + common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2) + double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres), + & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres), + & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres), + & dZZ_XYZtab(3,maxres) + common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab, + & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab + integer igrad_start,igrad_end,jgrad_start(maxres), + & jgrad_end(maxres) + common /mpgrad/ igrad_start,igrad_end,jgrad_start,jgrad_end diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.DERIV.org b/source/cluster/wham/src-HCD/include_unres/COMMON.DERIV.org new file mode 100644 index 0000000..79f8630 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.DERIV.org @@ -0,0 +1,30 @@ + double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gvdwpp, + & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gvdwx,gradcorr,gradxorr, + & gradcorr5,gradcorr6,gel_loc,gcorr3_turn,gcorr4_turn,gcorr6_turn, + & gel_loc_loc,gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc, + & g_corr5_loc,g_corr6_loc,gradb,gradbx,gsccorc,gsccorx,gsccor_loc, + & gscloc,gsclocx + integer nfl,icg + logical calc_grad + common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), + & gradx(3,maxres,2),gradc(3,maxres,2),gvdwx(3,maxres), + & gvdwc(3,maxres),gelc(3,maxres),gvdwpp(3,maxres), + & gradx_scp(3,maxres), + & gvdwc_scp(3,maxres),ghpbx(3,maxres),ghpbc(3,maxres), + & gloc(maxvar,2),gradcorr(3,maxres),gradxorr(3,maxres), + & gradcorr5(3,maxres),gradcorr6(3,maxres), + & gel_loc(3,maxres),gcorr3_turn(3,maxres),gcorr4_turn(3,maxres), + & gcorr6_turn(3,maxres),gradb(3,maxres),gradbx(3,maxres), + & gel_loc_loc(maxvar),gel_loc_turn3(maxvar),gel_loc_turn4(maxvar), + & gel_loc_turn6(maxvar),gcorr_loc(maxvar), + & g_corr5_loc(maxvar),g_corr6_loc(maxvar),gsccorc(3,maxres), + & gsccorx(3,maxres),gsccor_loc(maxres), + & gscloc(3,maxres),gsclocx(3,maxres),nfl,icg,calc_grad + double precision derx,derx_turn + common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2) + double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres), + & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres), + & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres), + & dZZ_XYZtab(3,maxres) + common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab, + & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.FRAG b/source/cluster/wham/src-HCD/include_unres/COMMON.FRAG new file mode 100644 index 0000000..ee151f5 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.FRAG @@ -0,0 +1,5 @@ + integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0, + & nh310frag,h310frag + COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3), + & nh310frag,h310frag(2,maxres/2) + COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3) diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.GEO b/source/cluster/wham/src-HCD/include_unres/COMMON.GEO new file mode 100644 index 0000000..8cfbbde --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.GEO @@ -0,0 +1,2 @@ + double precision pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin + common /geo/ pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.HEADER b/source/cluster/wham/src-HCD/include_unres/COMMON.HEADER new file mode 100644 index 0000000..7154812 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.HEADER @@ -0,0 +1,2 @@ + character*80 titel + common /header/ titel diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.INTERACT b/source/cluster/wham/src-HCD/include_unres/COMMON.INTERACT new file mode 100644 index 0000000..1c0b8db --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.INTERACT @@ -0,0 +1,36 @@ + double precision aa_aq,bb_aq,augm,aad,bad,app,bpp,ael6,ael3, + & aa_lip,bb_lip + integer nnt,nct,nint_gr,istart,iend,itype,itel,itypro,ielstart, + & ielend,nscp_gr,iscpstart,iscpend,iatsc_s,iatsc_e,iatel_s, + & iatel_e,iatscp_s,iatscp_e,ispp,iscp,expon,expon2 + common /interact/aa_aq(ntyp,ntyp),bb_aq(ntyp,ntyp), + & augm(ntyp,ntyp),aa_lip(ntyp,ntyp),bb_lip(ntyp,ntyp), + & aad(ntyp,2),bad(ntyp,2),app(2,2),bpp(2,2),ael6(2,2),ael3(2,2), + & expon,expon2,nnt,nct,nint_gr(maxres),istart(maxres,maxint_gr), + & iend(maxres,maxint_gr),itype(maxres),itel(maxres),itypro, + & ielstart(maxres),ielend(maxres),nscp_gr(maxres), + & iscpstart(maxres,maxint_gr),iscpend(maxres,maxint_gr), + & iatsc_s,iatsc_e,iatel_s,iatel_e,iatscp_s,iatscp_e,ispp,iscp +C 12/1/95 Array EPS included in the COMMON block. + double precision eps,epslip,sigma,sigmaii,rs0,chi,chip,chip0, + & alp,signa0, + & sigii,sigma0,rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp, + & eps_orig + common /body/eps(ntyp,ntyp),epslip(ntyp,ntyp), + & sigma(ntyp,ntyp),sigmaii(ntyp,ntyp), + & rs0(ntyp,ntyp),chi(ntyp,ntyp),chip(ntyp),chip0(ntyp),alp(ntyp), + & sigma0(ntyp),sigii(ntyp),rr0(ntyp),r0(ntyp,ntyp),r0e(ntyp,ntyp), + & r0d(ntyp,2),rpp(2,2),epp(2,2),elpp6(2,2),elpp3(2,2), + & eps_scp(ntyp,2),rscp(ntyp,2),eps_orig(ntyp,ntyp) +c 12/5/03 modified 09/18/03 Bond stretching parameters. + double precision vbldp0,vbldsc0,akp,aksc,abond0,distchainmax + &,vbldpDUM + integer nbondterm + common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp, + & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp), + & distchainmax,nbondterm(ntyp) + &,vbldpDUM +C 01/29/15 Lipidic parameters + double precision pepliptran,liptranene + common /lipid/ pepliptran,liptranene(ntyp) + diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.LOCAL b/source/cluster/wham/src-HCD/include_unres/COMMON.LOCAL new file mode 100644 index 0000000..6bd5514 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.LOCAL @@ -0,0 +1,53 @@ + double precision a0thet,athet,bthet,polthet,gthet,theta0,sig0, + & sigc0,dsc,dsc_inv,bsc,censc,gaussc,dsc0,vbl,vblinv,vblinv2, + & vbl_cis,vbl0,vbld_inv + integer nlob,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, + & isaxs_start,isaxs_end + +C Parameters of the virtual-bond-angle probability distribution + common /thetas/ a0thet(-ntyp:ntyp),athet(2,-ntyp:ntyp,-1:1,-1:1) + & ,bthet(2,-ntyp:ntyp,-1:1,-1:1), + & polthet(0:3,-ntyp:ntyp),gthet(3,-ntyp:ntyp),theta0(-ntyp:ntyp), + &sig0(-ntyp:ntyp), sigc0(-ntyp:ntyp) +C Parameters of ab initio-derived potential of virtual-bond-angle bending + integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, + & ithetyp(-ntyp1:ntyp1),nntheterm + double precision aa0thet(-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & aathet(maxtheterm,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & bbthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ccthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ddthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & eethet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ffthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2), + & ggthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2) + common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet, + & ffthet, + & ggthet,ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle, + & ndouble,nntheterm +C Parameters of the side-chain probability distribution + common /sclocal/ dsc(ntyp1),dsc_inv(ntyp1),bsc(maxlob,ntyp), + & censc(3,maxlob,-ntyp:ntyp),gaussc(3,3,maxlob,-ntyp:ntyp), + & dsc0(ntyp1), + & nlob(ntyp1) +C Virtual-bond lenghts + common /peptbond/ vbl,vblinv,vblinv2,vbl_cis,vbl0 + common /indices/ loc_start,loc_end,ithet_start,ithet_end, + & iphi_start,iphi_end,iphid_start,iphid_end,ibond_start,ibond_end, + & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end, + & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start, + & iint_end,iphi1_start,iphi1_end,itau_start,itau_end, + & isaxs_start,isaxs_end +C Inverses of the actual virtual bond lengths + common /invlen/ vbld_inv(maxres2) diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.MINIM b/source/cluster/wham/src-HCD/include_unres/COMMON.MINIM new file mode 100644 index 0000000..b231b47 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.MINIM @@ -0,0 +1,3 @@ + double precision tolf,rtolf + integer maxfun,maxmin + common /minimm/ tolf,rtolf,maxfun,maxmin diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.SCCOR b/source/cluster/wham/src-HCD/include_unres/COMMON.SCCOR new file mode 100644 index 0000000..fffe09b --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.SCCOR @@ -0,0 +1,6 @@ +C Parameters of the SCCOR term + double precision v1sccor,v2sccor + integer nterm_sccor + common/torsion/v1sccor(maxterm_sccor,ntyp,ntyp), + & v2sccor(maxterm_sccor,ntyp,ntyp), + & nterm_sccor diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.SCROT b/source/cluster/wham/src-HCD/include_unres/COMMON.SCROT new file mode 100644 index 0000000..a352775 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.SCROT @@ -0,0 +1,3 @@ +C Parameters of the SC rotamers (local) term + double precision sc_parmin + common/scrot/sc_parmin(maxsccoef,ntyp) diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.SETUP b/source/cluster/wham/src-HCD/include_unres/COMMON.SETUP new file mode 100644 index 0000000..5039116 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.SETUP @@ -0,0 +1,21 @@ + integer king,idint,idreal,idchar,is_done + parameter (king=0,idint=1105,idreal=1729,idchar=1597,is_done=1) + integer me,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,nfgtasks,kolor, + & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1),CG_COMM,FG_COMM, + & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp(0:maxprocs-1), + & kolor1,key1,nfgtasks1,MyRank, + & max_gs_size + logical yourjob, finished, cgdone + common/setup/me,MyRank,cg_rank,fg_rank,fg_rank1,nodes,Nprocs, + & nfgtasks,nfgtasks1, + & max_gs_size,kolor,koniec,WhatsUp,ifinish,CG_COMM,FG_COMM, + & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp + integer MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, + & MPI_THET,MPI_GAM, + & MPI_ROTAT1(0:1),MPI_ROTAT2(0:1),MPI_ROTAT_OLD(0:1), + & MPI_PRECOMP11(0:1),MPI_PRECOMP12(0:1),MPI_PRECOMP22(0:1), + & MPI_PRECOMP23(0:1) + common /types/ MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, + & MPI_THET,MPI_GAM, + & MPI_ROTAT1,MPI_ROTAT2,MPI_ROTAT_OLD,MPI_PRECOMP11,MPI_PRECOMP12, + & MPI_PRECOMP22,MPI_PRECOMP23 diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.SPLITELE b/source/cluster/wham/src-HCD/include_unres/COMMON.SPLITELE new file mode 100644 index 0000000..a2f0447 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.SPLITELE @@ -0,0 +1,2 @@ + double precision r_cut,rlamb + common /splitele/ r_cut,rlamb diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.TIME1 b/source/cluster/wham/src-HCD/include_unres/COMMON.TIME1 new file mode 100644 index 0000000..f7f4849 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.TIME1 @@ -0,0 +1,13 @@ + DOUBLE PRECISION BATIME,TIMLIM,STIME,PREVTIM,SAFETY,RSTIME + INTEGER WhatsUp,ndelta + logical cutoffviol,cutoffeval,llocal + COMMON/TIME1/STIME,TIMLIM,BATIME,PREVTIM,SAFETY,RSTIME + COMMON/STOPTIM/WhatsUp,ndelta,cutoffviol,cutoffeval,llocal + double precision 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 + common /timing/ t_func,t_grad,t_fhel,t_fbet,t_ghel,t_gbet,t_viol, + & t_gviol,t_map,t_alamap,t_betamap, + & n_func,n_grad,n_fhel,n_fbet,n_ghel,n_gbet,n_viol,n_gviol, + & n_map,n_alamap,n_betamap diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.TORCNSTR b/source/cluster/wham/src-HCD/include_unres/COMMON.TORCNSTR new file mode 100644 index 0000000..8958b81 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.TORCNSTR @@ -0,0 +1,17 @@ + integer ndih_constr,idih_constr(maxdih_constr),ntheta_constr, + & itheta_constr(maxdih_constr) + integer ndih_nconstr,idih_nconstr(maxdih_constr) + integer idihconstr_start,idihconstr_end,ithetaconstr_start, + & ithetaconstr_end + logical raw_psipred + double precision phi0(maxdih_constr),drange(maxdih_constr), + & ftors(maxdih_constr),theta_constr0(maxdih_constr), + & theta_drange(maxdih_constr),for_thet_constr(maxdih_constr), + & vpsipred(3,maxdih_constr),sdihed(2,maxdih_constr), + & phibound(2,maxres),wdihc + common /torcnstr/ phi0,drange,ftors,theta_constr0,theta_drange, + & for_thet_constr,vpsipred,sdihed,phibound,wdihc, + & ndih_constr,idih_constr, + & ndih_nconstr,idih_nconstr,idihconstr_start,idihconstr_end, + & ntheta_constr,itheta_constr,ithetaconstr_start, + & ithetaconstr_end,raw_psipred diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.TORSION b/source/cluster/wham/src-HCD/include_unres/COMMON.TORSION new file mode 100644 index 0000000..cd576c8 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.TORSION @@ -0,0 +1,60 @@ +C Torsional constants of the rotation about virtual-bond dihedral angles + double precision v1,v2,vlor1,vlor2,vlor3,v0,v1_kcc,v2_kcc, + & v11_chyb,v21_chyb,v12_chyb,v22_chyb,v1bend_chyb + integer itortyp,ntortyp,nterm,nlor,nterm_old,nterm_kcc_Tb, + & nterm_kcc,itortyp_kcc,nbend_kcc_Tb + common/torsion/v0(-maxtor:maxtor,-maxtor:maxtor,2), + & v1(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & v2(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & vlor1(maxlor,-maxtor:maxtor,-maxtor:maxtor), + & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor), + & v1_kcc(maxval_kcc,maxval_kcc,maxtor_kcc, + & -maxtor:maxtor,-maxtor:maxtor), + & v2_kcc(maxval_kcc,maxval_kcc,maxtor_kcc, + & -maxtor:maxtor,-maxtor:maxtor), + & v1bend_chyb(0:maxang_kcc,-maxtor:maxtor), + & itortyp(-ntyp1:ntyp1),ntortyp, + & itortyp_kcc(-ntyp1:ntyp1), + & nterm(-maxtor:maxtor,-maxtor:maxtor,2), + & nlor(-maxtor:maxtor,-maxtor:maxtor,2), + & nterm_kcc_Tb(-maxtor:maxtor,-maxtor:maxtor), + & nterm_kcc(-maxtor:maxtor,-maxtor:maxtor), + & nbend_kcc_Tb(-maxtor:maxtor), + & nterm_old +C 6/23/01 - constants for double torsionals + double precision v1c,v1s,v2c,v2s + integer ntermd_1,ntermd_2 + common /torsiond/ + &v1c(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v1s(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v2c(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + &v2s(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + & ntermd_1(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + & ntermd_2(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) +C 9/18/99 - added Fourier coeffficients of the expansion of local energy +C surface + double precision b1,b2,cc,dd,ee,ctilde,dtilde,b2tilde,b1tilde, + & b,bnew1,bnew2,ccold,ddold,ccnew,ddnew,eenew,e0new,gtb1,gtb2, + & eeold,gtcc,gtdd,gtee, + & bnew1tor,bnew2tor,ccnewtor,ddnewtor,eenewtor,e0newtor + integer nloctyp,iloctyp(-ntyp1:ntyp1),itype2loc(-ntyp1:ntyp1) + logical SPLIT_FOURIERTOR + common/fourier/ b1(2,maxres),b2(2,maxres),b(13,-ntyp:ntyp), + & bnew1(3,2,-ntyp:ntyp),bnew2(3,2,-ntyp:ntyp), + & ccnew(3,2,-ntyp:ntyp),ddnew(3,2,-ntyp:ntyp), + & bnew1tor(3,2,-ntyp:ntyp),bnew2tor(3,2,-ntyp:ntyp), + & ccnewtor(3,2,-ntyp:ntyp),ddnewtor(3,2,-ntyp:ntyp), + & ccold(2,2,-ntyp:ntyp),ddold(2,2,-ntyp:ntyp), + & cc(2,2,maxres), + & dd(2,2,maxres),eeold(2,2,-ntyp:ntyp), + & e0new(3,-ntyp:ntyp),eenew(2,2,2,-ntyp:ntyp), + & e0newtor(3,-ntyp:ntyp),eenewtor(2,2,2,-ntyp:ntyp), + & ee(2,2,maxres), + & ctilde(2,2,maxres), + & dtilde(2,2,maxres),b1tilde(2,maxres), + & b2tilde(2,maxres), + & gtb1(2,maxres),gtb2(2,maxres),gtCC(2,2,maxres), + & gtDD(2,2,maxres),gtEE(2,2,maxres), + & nloctyp,iloctyp,itype2loc,SPLIT_FOURIERTOR diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.TORSION.org b/source/cluster/wham/src-HCD/include_unres/COMMON.TORSION.org new file mode 100644 index 0000000..55cc7f4 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.TORSION.org @@ -0,0 +1,25 @@ +C Torsional constants of the rotation about virtual-bond dihedral angles + double precision v1,v2,vlor1,vlor2,vlor3,v0 + integer itortyp,ntortyp,nterm,nlor,nterm_old + common/torsion/v0(maxtor,maxtor),v1(maxterm,maxtor,maxtor), + & v2(maxterm,maxtor,maxtor),vlor1(maxlor,maxtor,maxtor), + & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor), + & itortyp(ntyp),ntortyp,nterm(maxtor,maxtor), + & nlor(maxtor,maxtor),nterm_old +C 6/23/01 - constants for double torsionals + double precision v1c,v1s,v2c,v2s + integer ntermd_1,ntermd_2 + common /torsiond/ v1c(2,maxtermd_1,maxtor,maxtor,maxtor), + & v1s(2,maxtermd_1,maxtor,maxtor,maxtor), + & v2c(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor), + & v2s(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor), + & ntermd_1(maxtor,maxtor,maxtor),ntermd_2(maxtor,maxtor,maxtor) +C 9/18/99 - added Fourier coeffficients of the expansion of local energy +C surface + double precision b1,b2,cc,dd,ee,ctilde,dtilde,b1tilde + integer nloctyp + common/fourier/ b1(2,maxtor),b2(2,maxtor),cc(2,2,maxtor), + & dd(2,2,maxtor),ee(2,2,maxtor),ctilde(2,2,maxtor), + & dtilde(2,2,maxtor),b1tilde(2,maxtor),nloctyp + double precision b + common /fourier1/ b(13,maxtor) diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.VECTORS b/source/cluster/wham/src-HCD/include_unres/COMMON.VECTORS new file mode 100644 index 0000000..d880c24 --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.VECTORS @@ -0,0 +1,3 @@ + common /vectors/ uy(3,maxres),uz(3,maxres), + & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres) + diff --git a/source/cluster/wham/src-HCD/include_unres/COMMON.WEIGHTS b/source/cluster/wham/src-HCD/include_unres/COMMON.WEIGHTS new file mode 100644 index 0000000..86f8d7a --- /dev/null +++ b/source/cluster/wham/src-HCD/include_unres/COMMON.WEIGHTS @@ -0,0 +1,22 @@ + double precision ww,ww0,ww_low,ww_up,ww_orig,x_orig, + & epp_low,epp_up,rpp_low,rpp_up,elpp6_low,elpp6_up,elpp3_low, + & elpp3_up,b_low,b_up,epscp_low,epscp_up,rscp_low,rscp_up, + & x_up,x_low,xm,xm1,xm2,epss_low,epss_up,epsp_low,epsp_up + integer imask,mask_elec,mask_fourier,mod_fourier,mask_scp,indz,iw, + & nsingle_sc,npair_sc,ityp_ssc,ityp_psc + logical mod_other_params,mod_elec,mod_scp,mod_side + common /chujec/ ww(max_ene),ww0(max_ene),ww_low(max_ene), + & ww_up(max_ene),ww_orig(max_ene),x_orig(max_paropt), + & epp_low(2,2),epp_up(2,2),rpp_low(2,2),rpp_up(2,2), + & elpp6_low(2,2),elpp6_up(2,2),elpp3_low(2,2),elpp3_up(2,2), + & b_low(13,3),b_up(13,3),x_up(max_paropt),x_low(max_paropt), + & epscp_low(0:ntyp,2),epscp_up(0:ntyp,2),rscp_low(0:ntyp,2), + & rscp_up(0:ntyp,2),epss_low(ntyp),epss_up(ntyp),epsp_low(nntyp), + & epsp_up(nntyp), + & xm(max_paropt,0:maxprot),xm1(max_paropt,0:maxprot), + & xm2(max_paropt,0:maxprot), + & imask(max_ene),nsingle_sc,npair_sc,ityp_ssc(ntyp), + & ityp_psc(2,nntyp),mask_elec(2,2,4), + & mask_fourier(13,3), + & mask_scp(0:ntyp,2,2),mod_other_params,mod_fourier(0:3), + & mod_elec,mod_scp,mod_side,indz(maxbatch+1,maxprot),iw(max_ene) diff --git a/source/cluster/wham/src-HCD/initialize.f b/source/cluster/wham/src-HCD/initialize.f new file mode 100644 index 0000000..12ea156 --- /dev/null +++ b/source/cluster/wham/src-HCD/initialize.f @@ -0,0 +1,99 @@ + subroutine initialize +C +C Define constants and zero out tables. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.MINIM' + include 'COMMON.DERIV' +C +C The following is just to define auxiliary variables used in angle conversion +C + pi=4.0D0*datan(1.0D0) + dwapi=2.0D0*pi + dwapi3=pi/3.0D0 + pipol=0.5D0*pi + deg2rad=pi/180.0D0 + rad2deg=1.0D0/deg2rad + angmin=10.0D0*deg2rad +C Assign virtual-bond length + vbl=3.8D0 + vblinv=1.0D0/vbl + vblinv2=vblinv*vblinv +C +C Define I/O units. +C + inp= 1 + iout= 2 + ipdbin= 3 + ipdb= 7 + igeom= 8 + intin= 9 + istat= 17 + imol2= 18 + jplot= 19 + jstatin=10 + jstatout=11 +C +C Zero out tables. +C + do i=1,maxres2 + do j=1,3 + c(j,i)=0.0D0 + dc(j,i)=0.0D0 + enddo + enddo + do i=1,maxres + do j=1,3 + xloc(j,i)=0.0D0 + enddo + enddo +C Initialize the bridge arrays + ns=0 + nss=0 + nhpb=0 + do i=1,maxss + iss(i)=0 + enddo + do i=1,maxdim + dhpb(i)=0.0D0 + enddo + do i=1,maxres + ihpb(i)=0 + jhpb(i)=0 + enddo +C +C Initialize timing. +C + call set_timers + return + end +c------------------------------------------------------------------------- + block data chuj + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + data 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'/ + data 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'/ + data potname /'LJ','LJK','BP','GB','GBV'/ + data potname /'LJ','LJK','BP','GB','GBV'/ + end diff --git a/source/cluster/wham/src-HCD/initialize.f_org b/source/cluster/wham/src-HCD/initialize.f_org new file mode 100644 index 0000000..751c20e --- /dev/null +++ b/source/cluster/wham/src-HCD/initialize.f_org @@ -0,0 +1,92 @@ + subroutine initialize +C +C Define constants and zero out tables. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.MINIM' + include 'COMMON.DERIV' +C +C The following is just to define auxiliary variables used in angle conversion +C + pi=4.0D0*datan(1.0D0) + dwapi=2.0D0*pi + dwapi3=pi/3.0D0 + pipol=0.5D0*pi + deg2rad=pi/180.0D0 + rad2deg=1.0D0/deg2rad + angmin=10.0D0*deg2rad +C Assign virtual-bond length + vbl=3.8D0 + vblinv=1.0D0/vbl + vblinv2=vblinv*vblinv +C +C Define I/O units. +C + inp= 1 + iout= 2 + ipdbin= 3 + ipdb= 7 + igeom= 8 + intin= 9 + istat= 17 + imol2= 18 + jplot= 19 + jstatin=10 + jstatout=11 +C +C Zero out tables. +C + do i=1,maxres2 + do j=1,3 + c(j,i)=0.0D0 + dc(j,i)=0.0D0 + enddo + enddo + do i=1,maxres + do j=1,3 + xloc(j,i)=0.0D0 + enddo + enddo +C Initialize the bridge arrays + ns=0 + nss=0 + nhpb=0 + do i=1,maxss + iss(i)=0 + enddo + do i=1,maxdim + dhpb(i)=0.0D0 + enddo + do i=1,maxres + ihpb(i)=0 + jhpb(i)=0 + enddo +C +C Initialize timing. +C + call set_timers + return + end +c------------------------------------------------------------------------- + block data chuj + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + data restyp / + &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR', + &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/ + data onelet / + &'C','M','F','I','L','V','W','Y','A','G','T', + &'S','Q','N','E','D','H','R','K','P','X'/ + data potname /'LJ','LJK','BP','GB','GBV'/ + end diff --git a/source/cluster/wham/src-HCD/initialize_p.F b/source/cluster/wham/src-HCD/initialize_p.F new file mode 100644 index 0000000..87e4dde --- /dev/null +++ b/source/cluster/wham/src-HCD/initialize_p.F @@ -0,0 +1,551 @@ + subroutine initialize +C +C Define constants and zero out tables. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.MINIM' + include 'COMMON.DERIV' + include "COMMON.NAMES" + include "COMMON.TIME1" +C +C The following is just to define auxiliary variables used in angle conversion +C + pi=4.0D0*datan(1.0D0) + dwapi=2.0D0*pi + dwapi3=dwapi/3.0D0 + pipol=0.5D0*pi + deg2rad=pi/180.0D0 + rad2deg=1.0D0/deg2rad + angmin=10.0D0*deg2rad + Rgas = 1.987D-3 +C +C Define I/O units. +C + inp= 1 + iout= 2 + ipdbin= 3 + ipdb= 7 + imol2= 18 + jplot= 19 + jstatin=10 + imol2= 4 + igeom= 8 + intin= 9 + ithep= 11 + irotam=12 + itorp= 13 + itordp= 23 + ielep= 14 + isidep=15 + isidep1=22 + iscpp=25 + icbase=16 + ifourier=20 + istat= 17 + ibond=28 + isccor=29 + jrms=30 + iliptran=60 +C +C Set default weights of the energy terms. +C + wlong=1.0D0 + welec=1.0D0 + wtor =1.0D0 + wang =1.0D0 + wscloc=1.0D0 + wstrain=1.0D0 +C +C Zero out tables. +C + ndih_constr=0 + do i=1,maxres2 + do j=1,3 + c(j,i)=0.0D0 + dc(j,i)=0.0D0 + enddo + enddo + do i=1,maxres + do j=1,3 + xloc(j,i)=0.0D0 + enddo + enddo + do i=1,ntyp + do j=1,ntyp + aa_aq(i,j)=0.0D0 + bb_aq(i,j)=0.0D0 + aa_lip(i,j)=0.0D0 + bb_lip(i,j)=0.0D0 + augm(i,j)=0.0D0 + sigma(i,j)=0.0D0 + r0(i,j)=0.0D0 + chi(i,j)=0.0D0 + enddo + do j=1,2 + bad(i,j)=0.0D0 + enddo + chip(i)=0.0D0 + alp(i)=0.0D0 + sigma0(i)=0.0D0 + sigii(i)=0.0D0 + rr0(i)=0.0D0 + a0thet(i)=0.0D0 + do j=1,2 + do ichir1=-1,1 + do ichir2=-1,1 + athet(j,i,ichir1,ichir2)=0.0D0 + bthet(j,i,ichir1,ichir2)=0.0D0 + enddo + enddo + enddo + do j=0,3 + polthet(j,i)=0.0D0 + enddo + do j=1,3 + gthet(j,i)=0.0D0 + enddo + theta0(i)=0.0D0 + sig0(i)=0.0D0 + sigc0(i)=0.0D0 + do j=1,maxlob + bsc(j,i)=0.0D0 + do k=1,3 + censc(k,j,i)=0.0D0 + enddo + do k=1,3 + do l=1,3 + gaussc(l,k,j,i)=0.0D0 + enddo + enddo + nlob(i)=0 + enddo + enddo + nlob(ntyp1)=0 + dsc(ntyp1)=0.0D0 + do i=-maxtor,maxtor + itortyp(i)=0 + do iblock=1,2 + do j=-maxtor,maxtor + do k=1,maxterm + v1(k,j,i,iblock)=0.0D0 + v2(k,j,i,iblock)=0.0D0 + enddo + enddo + enddo + enddo + do iblock=1,2 + do i=-maxtor,maxtor + do j=-maxtor,maxtor + do k=-maxtor,maxtor + do l=1,maxtermd_1 + v1c(1,l,i,j,k,iblock)=0.0D0 + v1s(1,l,i,j,k,iblock)=0.0D0 + v1c(2,l,i,j,k,iblock)=0.0D0 + v1s(2,l,i,j,k,iblock)=0.0D0 + enddo !l + do l=1,maxtermd_2 + do m=1,maxtermd_2 + v2c(m,l,i,j,k,iblock)=0.0D0 + v2s(m,l,i,j,k,iblock)=0.0D0 + enddo !m + enddo !l + enddo !k + enddo !j + enddo !i + enddo !iblock + do i=1,maxres + itype(i)=0 + itel(i)=0 + enddo +C Initialize the bridge arrays + ns=0 + nss=0 + nhpb=0 + do i=1,maxss + iss(i)=0 + enddo + do i=1,maxss + dhpb(i)=0.0D0 + enddo + do i=1,maxss + ihpb(i)=0 + jhpb(i)=0 + enddo +C +C Initialize timing. +C + call set_timers +C +C Initialize variables used in minimization. +C +c maxfun=5000 +c maxit=2000 + maxfun=500 + maxit=200 + tolf=1.0D-2 + rtolf=5.0D-4 +C +C Initialize the variables responsible for the mode of gradient storage. +C + nfl=0 + icg=1 + do i=1,14 + do j=1,14 + if (print_order(i).eq.j) then + iw(print_order(i))=j + goto 1121 + endif + enddo +1121 continue + enddo + calc_grad=.false. +C Set timers and counters for the respective routines + t_func = 0.0d0 + t_grad = 0.0d0 + t_fhel = 0.0d0 + t_fbet = 0.0d0 + t_ghel = 0.0d0 + t_gbet = 0.0d0 + t_viol = 0.0d0 + t_gviol = 0.0d0 + n_func = 0 + n_grad = 0 + n_fhel = 0 + n_fbet = 0 + n_ghel = 0 + n_gbet = 0 + n_viol = 0 + n_gviol = 0 + n_map = 0 +#ifndef SPLITELE + nprint_ene=nprint_ene-1 +#endif + return + end +c------------------------------------------------------------------------- + block data nazwy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + data 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'/ + data 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'/ + data potname /'LJ','LJK','BP','GB','GBV'/ + data ename / + 1 "ESC-SC", + 2 "ESC-p", + 3 "Ep-p(el)", + 4 "ECORR4 ", + 5 "ECORR5 ", + 6 "ECORR6 ", + 7 "ECORR3 ", + 8 "ETURN3 ", + 9 "ETURN4 ", + @ "ETURN6 ", + 1 "Ebend", + 2 "ESCloc", + 3 "ETORS ", + 4 "ETORSD ", + 5 "Edist", + 6 "Epp(VDW)", + 7 "EVDW2_14", + 8 "Ebond", + 9 "ESCcor", + @ "EDIHC", + 1 "EVDW_T", + 2 "ELIPTRAN", + 3 "EAFM", + 4 "ETHETC", + 5 "ESHIELD", + 6 "ESAXS", + 7 "EHOMO", + 8 "EDFADIS", + 9 "EDFATOR", + @ "EDFANEI", + 1 "EDFABET"/ + data wname / +! 1 2 3 4 5 6 7 + & "WSC ","WSCP ","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", +! 8 9 10 11 12 13 14 + & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR ","WTORD", +! 15 16 17 18 19 20 21 + & "WHPB ","WVDWPP","WSCP14","WBOND","WSCCOR","WDIHC","WSC", +! 22 23 24 25 26 27 28 + & "WLIPTRAN","WAFM","WTHETC","WSHIELD","WSAXS","WHOMO","WDFAD", +! 29 30 31 + & "WDFAT","WDFAN","WDFAB"/ +#ifdef DFA +#if defined(SCP14) && defined(SPLITELE) + data nprint_ene /31/ + data print_order/1,2,18,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,28,29,30,31,22,23,25,20/ +#elif defined(SCP14) + data nprint_ene /30/ + data print_order/1,2,18,3,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,28,29,30,31,22,23,25,20,0/ +#elif defined(SPLITELE) + data nprint_ene /30/ + data print_order/1,2,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,28,29,30,31,22,23,25,20,0/ +#else + data nprint_ene /29/ + data print_order/1,2,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,28,29,30,31,22,23,25,20,2*0/ +#endif +#else +#if defined(SCP14) && defined(SPLITELE) + data nprint_ene /27/ + data print_order/1,2,18,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,22,23,25,20,4*0/ +#elif defined(SCP14) + data nprint_ene /26/ + data print_order/1,2,18,3,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,22,23,25,20,5*0/ +#elif defined(SPLITELE) + data nprint_ene /26/ + data print_order/1,2,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,22,23,25,20,5*0/ +#else + data nprint_ene /25/ + data print_order/1,2,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,22,23,25,20,6*0/ +#endif +#endif + end +c--------------------------------------------------------------------------- + subroutine init_int_table + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' + include "COMMON.TORCNSTR" + logical scheck,lprint + lprint=.false. + do i=1,maxres + nint_gr(i)=0 + nscp_gr(i)=0 + do j=1,maxint_gr + istart(i,1)=0 + iend(i,1)=0 + ielstart(i)=0 + ielend(i)=0 + iscpstart(i,1)=0 + iscpend(i,1)=0 + enddo + enddo + ind_scint=0 + ind_scint_old=0 +cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', +cd & (ihpb(i),jhpb(i),i=1,nss) + do i=nnt,nct-1 + scheck=.false. + if (dyn_ss) goto 10 + do ii=1,nss + if (ihpb(ii).eq.i+nres) then + scheck=.true. + jj=jhpb(ii)-nres + goto 10 + endif + enddo + 10 continue +cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj + if (scheck) then + if (jj.eq.i+1) then + nint_gr(i)=1 + istart(i,1)=i+2 + iend(i,1)=nct + else if (jj.eq.nct) then + nint_gr(i)=1 + istart(i,1)=i+1 + iend(i,1)=nct-1 + 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 + else + nint_gr(i)=1 + istart(i,1)=i+1 + iend(i,1)=nct + ind_scint=int_scint+nct-i + endif + enddo + 12 continue + iatsc_s=nnt + iatsc_e=nct-1 + 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 + iatel_s=nnt + iatel_e=nct-3 + do i=iatel_s,iatel_e + ielstart(i)=i+4 + ielend(i)=nct-1 + enddo + 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 +c iscp=3 + iscp=2 +C Partition the SC-p interaction array + 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 + if (lprint) then + write (iout,'(a)') 'SC-p interaction array:' + do i=iatscp_s,iatscp_e + write (iout,'(i3,2(2x,2i3))') + & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) + enddo + endif ! lprint +C Partition local interactions + loc_start=2 + loc_end=nres-1 + ithet_start=3 + ithet_end=nres + iturn3_start=nnt + iturn3_end=nct-3 + iturn4_start=nnt + iturn4_end=nct-4 + iphi_start=nnt+3 + iphi_end=nct + idihconstr_start=1 + idihconstr_end=ndih_constr + ithetaconstr_start=1 + ithetaconstr_end=ntheta_constr + itau_start=4 + itau_end=nres + isaxs_start=1 + isaxs_end=nsaxs + write (iout,*) "OSAXS_START",isaxs_start," ISAXS_END",isaxs_end + return + end +c--------------------------------------------------------------------------- + subroutine int_partition(int_index,lower_index,upper_index,atom, + & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + integer int_index,lower_index,upper_index,atom,at_start,at_end, + & first_atom,last_atom,int_gr,jat_start,jat_end + logical lprn + lprn=.false. + if (lprn) write (iout,*) 'int_index=',int_index + int_index_old=int_index + int_index=int_index+last_atom-first_atom+1 + if (lprn) + & write (iout,*) 'int_index=',int_index, + & ' int_index_old',int_index_old, + & ' lower_index=',lower_index, + & ' upper_index=',upper_index, + & ' atom=',atom,' first_atom=',first_atom, + & ' last_atom=',last_atom + if (int_index.ge.lower_index) then + int_gr=int_gr+1 + if (at_start.eq.0) then + at_start=atom + jat_start=first_atom-1+lower_index-int_index_old + else + jat_start=first_atom + endif + if (lprn) write (iout,*) 'jat_start',jat_start + if (int_index.ge.upper_index) then + at_end=atom + jat_end=first_atom-1+upper_index-int_index_old + return1 + else + jat_end=last_atom + endif + if (lprn) write (iout,*) 'jat_end',jat_end + endif + return + end +c------------------------------------------------------------------------------ + subroutine hpb_partition + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' + link_start=1 + link_end=nhpb + link_start_peak=1 + link_end_peak=npeak + write (iout,*) 'HPB_PARTITION', + & ' nhpb',nhpb,' link_start=',link_start, + & ' link_end',link_end,' link_start_peak',link_start_peak, + & ' link_end_peak',link_end_peak + return + end +c------------------------------------------------------------------------------ + subroutine homology_partition + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'COMMON.HOMOLOGY' + include 'COMMON.HOMRESTR' + include 'COMMON.INTERACT' +cd write(iout,*)"homology_partition: lim_odl=",lim_odl, +cd & " lim_dih",lim_dih + link_start_homo=1 + link_end_homo=lim_odl + idihconstr_start_homo=nnt+3 + idihconstr_end_homo=lim_dih+nnt-1+3 + write (iout,*) + & ' lim_odl',lim_odl,' link_start=',link_start_homo, + & ' link_end',link_end_homo,' lim_dih',lim_dih, + & ' idihconstr_start_homo',idihconstr_start_homo, + & ' idihconstr_end_homo',idihconstr_end_homo + return + end diff --git a/source/cluster/wham/src-HCD/int_from_cart1.f b/source/cluster/wham/src-HCD/int_from_cart1.f new file mode 100644 index 0000000..7d266de --- /dev/null +++ b/source/cluster/wham/src-HCD/int_from_cart1.f @@ -0,0 +1,63 @@ + subroutine int_from_cart1(lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.NAMES' + logical lprn + if (lprn) write (iout,'(/a)') 'Recalculated internal coordinates' + vbld(nres+1)=0.0d0 + vbld(2*nres)=0.0d0 + vbld_inv(nres+1)=0.0d0 + vbld_inv(2*nres)=0.0d0 + do i=2,nres + dnorm1=dist(i-1,i) + dnorm2=dist(i,i+1) + do j=1,3 + c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))/dnorm1 + & +(c(j,i+1)-c(j,i))/dnorm2) + enddo + be=0.0D0 + if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) + if (i.gt.2) tauangle(3,i+1)=beta(i+nres-1,i-1,i,i+nres) + if (i.gt.2) tauangle(1,i+1)=beta(i-1+nres,i-1,i,i+1) + if (i.gt.2) tauangle(2,i+1)=beta(i-2,i-1,i,i+nres) + omeg(i)=beta(nres+i,i,maxres2,i+1) + theta(i+1)=alpha(i-1,i,i+1) + alph(i)=alpha(nres+i,i,maxres2) + 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 + 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=1,nres + 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 + 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)) + return + end diff --git a/source/cluster/wham/src-HCD/intcor.f b/source/cluster/wham/src-HCD/intcor.f new file mode 100644 index 0000000..a3cd5d0 --- /dev/null +++ b/source/cluster/wham/src-HCD/intcor.f @@ -0,0 +1,91 @@ +C +C------------------------------------------------------------------------------ +C + double precision function alpha(i1,i2,i3) +c +c Calculates the planar angle between atoms (i1), (i2), and (i3). +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + x12=c(1,i1)-c(1,i2) + x23=c(1,i3)-c(1,i2) + y12=c(2,i1)-c(2,i2) + y23=c(2,i3)-c(2,i2) + z12=c(3,i1)-c(3,i2) + z23=c(3,i3)-c(3,i2) + vnorm=dsqrt(x12*x12+y12*y12+z12*z12) + wnorm=dsqrt(x23*x23+y23*y23+z23*z23) + scalar=(x12*x23+y12*y23+z12*z23)/(vnorm*wnorm) + alpha=arcos(scalar) + return + end +C +C------------------------------------------------------------------------------ +C + double precision function beta(i1,i2,i3,i4) +c +c Calculates the dihedral angle between atoms (i1), (i2), (i3) and (i4) +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + x12=c(1,i1)-c(1,i2) + x23=c(1,i3)-c(1,i2) + x34=c(1,i4)-c(1,i3) + y12=c(2,i1)-c(2,i2) + y23=c(2,i3)-c(2,i2) + y34=c(2,i4)-c(2,i3) + z12=c(3,i1)-c(3,i2) + z23=c(3,i3)-c(3,i2) + z34=c(3,i4)-c(3,i3) +cd print '(2i3,3f10.5)',i1,i2,x12,y12,z12 +cd print '(2i3,3f10.5)',i2,i3,x23,y23,z23 +cd print '(2i3,3f10.5)',i3,i4,x34,y34,z34 + wx=-y23*z34+y34*z23 + wy=x23*z34-z23*x34 + wz=-x23*y34+y23*x34 + wnorm=dsqrt(wx*wx+wy*wy+wz*wz) + vx=y12*z23-z12*y23 + vy=-x12*z23+z12*x23 + vz=x12*y23-y12*x23 + vnorm=dsqrt(vx*vx+vy*vy+vz*vz) + if (vnorm.gt.1.0D-13 .and. wnorm.gt.1.0D-13) then + scalar=(vx*wx+vy*wy+vz*wz)/(vnorm*wnorm) + if (dabs(scalar).gt.1.0D0) + &scalar=0.99999999999999D0*scalar/dabs(scalar) + angle=dacos(scalar) +cd print '(2i4,10f7.3)',i2,i3,vx,vy,vz,wx,wy,wz,vnorm,wnorm, +cd &scalar,angle + else + angle=pi + endif +c if (angle.le.0.0D0) angle=pi+angle + tx=vy*wz-vz*wy + ty=-vx*wz+vz*wx + tz=vx*wy-vy*wx + scalar=tx*x23+ty*y23+tz*z23 + if (scalar.lt.0.0D0) angle=-angle + beta=angle + return + end +C +C------------------------------------------------------------------------------ +C + function dist(i1,i2) +c +c Calculates the distance between atoms (i1) and (i2). +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + x12=c(1,i1)-c(1,i2) + y12=c(2,i1)-c(2,i2) + z12=c(3,i1)-c(3,i2) + dist=dsqrt(x12*x12+y12*y12+z12*z12) + return + end +C diff --git a/source/cluster/wham/src-HCD/iperm.f b/source/cluster/wham/src-HCD/iperm.f new file mode 100644 index 0000000..77ba7ed --- /dev/null +++ b/source/cluster/wham/src-HCD/iperm.f @@ -0,0 +1,15 @@ + integer function iperm(ires,ipermut) + implicit none + include "DIMENSIONS" + include "COMMON.CHAIN" + integer ipermut,ires,ii,iii + integer tperm + ii=ireschain(ires) + if (ii.eq.0) then + iperm=ires + else + iii=tabpermchain(ii,ipermut) + iperm=chain_border(1,iii)+ires-chain_border(1,ii) + endif + return + end diff --git a/source/cluster/wham/src-HCD/log b/source/cluster/wham/src-HCD/log new file mode 100644 index 0000000..61146b3 --- /dev/null +++ b/source/cluster/wham/src-HCD/log @@ -0,0 +1,24 @@ +gfortran -O -c -I. -Iinclude_unres -I/users/software/mpich2-1.0.7/include readpdb.f +cc -o compinfo compinfo.c +./compinfo | true +gfortran -O -c -I. -Iinclude_unres -I/users/software/mpich2-1.0.7/include cinfo.f +gfortran -O main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o setup_var.o read_ref_str.o gnmr1.o permut.o -L/users/software/mpich2-1.0.7/lib -lmpich -lpthread xdrf/libxdrf.a -o ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_NEWCORR.exe +readrtns.o: In function `molread_': +readrtns.F:(.text+0x498f): relocation truncated to fit: R_X86_64_PC32 against symbol `torcnstr_' defined in COMMON section in readrtns.o +readrtns.F:(.text+0x49c6): relocation truncated to fit: R_X86_64_PC32 against symbol `torcnstr_' defined in COMMON section in readrtns.o +readrtns.F:(.text+0x49e9): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o +readrtns.F:(.text+0x4a06): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o +readrtns.F:(.text+0x4a23): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o +readrtns.F:(.text+0x4a40): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o +readrtns.F:(.text+0x4ae2): relocation truncated to fit: R_X86_64_PC32 against symbol `torcnstr_' defined in COMMON section in readrtns.o +readrtns.F:(.text+0x4b40): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o +readrtns.F:(.text+0x4b5d): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o +readrtns.F:(.text+0x4b7a): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o +readrtns.F:(.text+0x4b97): additional relocation overflows omitted from the output +energy_p_new.o: In function `egb_': +energy_p_new.F:(.text+0xfc29): undefined reference to `dyn_ssbond_ene_' +energy_p_new.F:(.text+0xfca0): undefined reference to `triple_ssbond_ene_' +energy_p_new.o: In function `etotal_': +energy_p_new.F:(.text+0x118fd): undefined reference to `dyn_set_nss_' +collect2: ld returned 1 exit status +make: *** [NEWCORR] Error 1 diff --git a/source/cluster/wham/src-HCD/main_clust.F b/source/cluster/wham/src-HCD/main_clust.F new file mode 100644 index 0000000..2485ecb --- /dev/null +++ b/source/cluster/wham/src-HCD/main_clust.F @@ -0,0 +1,400 @@ +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,scount_buf + real*4 DISNN, diss_buf(maxdist) + 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, ijk, is,ie + 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 cinfo + call read_control + call parmread + call molread +c write (iout,*) "Main: refstr ",refstr + 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 + if (nclust.gt.0) then + PRINTANG(1)=.TRUE. + PRINTPDB(1)=outpdb + printmol2(1)=outmol2 + ncut=0 + else + 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 + endif + if (ncut.gt.0) then + 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 + else if (nclust.gt.0) then + write (iout,'("Number of clusters requested",i5)') nclust + else + if (me.eq.Master) + & write (iout,*) "ERROR: Either nclust or ncut must be >0" + stop + endif + 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,*) "Temperature",1.0d0/(beta_h(iT)*1.987D-3) +#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 +c if (mod(i,100).eq.0) print *,'Calculating RMS i=',i + 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() +c PRINT '(a)','End of distance computation' + + scount_buf=scount(me) + + do ijk=1, ndis + diss_buf(ijk)=diss(ijk) + enddo + + +#ifdef MPI + WRITE (iout,*) "Wchodze do call MPI_Gatherv" + call MPI_Gatherv(diss_buf(1),scount_buf,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) +c 3/3/16 AL: added explicit number of cluters + if (nclust.gt.0) then + is=nclust-1 + ie=nclust-1 + icut=1 + else + is=1 + ie=lev-1 + endif + do i=1,maxgr + licz(i)=0 + enddo + icut=1 + i=is + NGR=is+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 +c do i=1,lev-1 + do i=is,ie + 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 (nclust.gt.0.or.CRITVAL(IDUM).LT. RCUTOFF(ICUT)) THEN + if (nclust.le.0) + & 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(IERROR) +#endif + stop '********** Program terminated normally.' + 20 write (iout,*) "Error reading coordinates" +#ifdef MPI + call MPI_Finalize(IERROR) +#endif + stop + 30 write (iout,*) "Error reading reference structure" +#ifdef MPI + call MPI_Finalize(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' + integer ipermmin + double precision przes(3),obrot(3,3) + double precision rmscalc + integer icon,jcon,k,l +c write (iout,*) "DIFCONF: ICON",icon," JCON",jcon + do k=1,2*nres + do l=1,3 + cref(l,k)=allcart(l,k,icon) + c(l,k)=allcart(l,k,jcon) + enddo + enddo + difconf=rmscalc(c(1,1),cref(1,1),przes,obrot,ipermmin) + 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/wham/src-HCD/matmult.f b/source/cluster/wham/src-HCD/matmult.f new file mode 100644 index 0000000..2d2450e --- /dev/null +++ b/source/cluster/wham/src-HCD/matmult.f @@ -0,0 +1,17 @@ + SUBROUTINE MATMULT(A1,A2,A3) + include 'DIMENSIONS' + DIMENSION A1(3,3),A2(3,3),A3(3,3) + DIMENSION AI3(3,3) + DO 1 I=1,3 + DO 2 J=1,3 + A3IJ=0.0 + DO 3 K=1,3 + 3 A3IJ=A3IJ+A1(I,K)*A2(K,J) + AI3(I,J)=A3IJ + 2 CONTINUE + 1 CONTINUE + DO 4 I=1,3 + DO 4 J=1,3 + 4 A3(I,J)=AI3(I,J) + RETURN + END diff --git a/source/cluster/wham/src-HCD/misc.f b/source/cluster/wham/src-HCD/misc.f new file mode 100644 index 0000000..e189839 --- /dev/null +++ b/source/cluster/wham/src-HCD/misc.f @@ -0,0 +1,203 @@ +C $Date: 1994/10/12 17:24:21 $ +C $Revision: 2.5 $ +C +C +C + logical function find_arg(ipos,line,errflag) + parameter (maxlen=80) + character*80 line + character*1 empty /' '/,equal /'='/ + logical errflag +* This function returns .TRUE., if an argument follows keyword keywd; if so +* IPOS will point to the first non-blank character of the argument. Returns +* .FALSE., if no argument follows the keyword; in this case IPOS points +* to the first non-blank character of the next keyword. + do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + errflag=.false. + if (line(ipos:ipos).eq.equal) then + find_arg=.true. + ipos=ipos+1 + do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + if (ipos.gt.maxlen) errflag=.true. + else + find_arg=.false. + endif + return + end + logical function find_group(iunit,jout,key1) + character*(*) key1 + character*80 karta,ucase + integer ilen + external ilen + logical lcom + rewind (iunit) + karta=' ' + ll=ilen(key1) + do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta)) + read (iunit,'(a)',end=10) karta + enddo + write (jout,'(2a)') '> ',karta(1:78) + find_group=.true. + return + 10 find_group=.false. + return + end + logical function iblnk(charc) + character*1 charc + integer n + n = ichar(charc) + iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq. ' ') + return + end + integer function ilen(string) + character*(*) string + logical iblnk + + ilen = len(string) +1 if ( ilen .gt. 0 ) then + if ( iblnk( string(ilen:ilen) ) ) then + ilen = ilen - 1 + goto 1 + endif + endif + return + end + integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset) + character*16 keywd,keywdset(1:nkey,0:nkey) + character*16 ucase + do i=1,narg + if (ucase(keywd).eq.keywdset(i,ikey)) then +* Match found + in_keywd_set=i + return + endif + enddo +* No match to the allowed set of keywords if this point is reached. + in_keywd_set=0 + return + end + character*(*) function lcase(string) + integer i, k, idiff + character*(*) string + character*1 c + character*40 chtmp +c + i = len(lcase) + k = len(string) + if (i .lt. k) then + k = i + if (string(k+1:) .ne. ' ') then + chtmp = string + endif + endif + idiff = ichar('a') - ichar('A') + lcase = string + do 99 i = 1, k + c = string(i:i) + if (lge(c,'A') .and. lle(c,'Z')) then + lcase(i:i) = char(ichar(c) + idiff) + endif + 99 continue + return + end + logical function lcom(ipos,karta) + character*80 karta + character koment(2) /'!','#'/ + lcom=.false. + do i=1,2 + if (karta(ipos:ipos).eq.koment(i)) lcom=.true. + enddo + return + end + logical function lower_case(ch) + character*(*) ch + lower_case=(ch.ge.'a' .and. ch.le.'z') + return + end + subroutine mykey(line,keywd,ipos,blankline,errflag) +* This subroutine seeks a non-empty substring keywd in the string LINE. +* The substring begins with the first character different from blank and +* "=" encountered right to the pointer IPOS (inclusively) and terminates +* at the character left to the first blank or "=". When the subroutine is +* exited, the pointer IPOS is moved to the position of the terminator in LINE. +* The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains +* only separators or the maximum length of the data line (80) has been reached. +* The logical variable ERRFLAG is set at .TRUE. if the string +* consists only from a "=". + parameter (maxlen=80) + character*1 empty /' '/,equal /'='/,comma /','/ + character*(*) keywd + character*80 line + logical blankline,errflag,lcom + errflag=.false. + do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen)) + ipos=ipos+1 + enddo + if (ipos.gt.maxlen .or. lcom(ipos,line) ) then +* At this point the rest of the input line turned out to contain only blanks +* or to be commented out. + blankline=.true. + return + endif + blankline=.false. + istart=ipos +* Checks whether the current char is a separator. + do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal + & .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + iend=ipos-1 +* Error flag set to .true., if the length of the keyword was found less than 1. + if (iend.lt.istart) then + errflag=.true. + return + endif + keywd=line(istart:iend) + return + end + subroutine numstr(inum,numm) + character*10 huj /'0123456789'/ + character*(*) numm + inumm=inum + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(3:3)=huj(inum2+1:inum2+1) + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(2:2)=huj(inum2+1:inum2+1) + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(1:1)=huj(inum2+1:inum2+1) + return + end + character*(*) function ucase(string) + integer i, k, idiff + character*(*) string + character*1 c + character*40 chtmp +c + i = len(ucase) + k = len(string) + if (i .lt. k) then + k = i + if (string(k+1:) .ne. ' ') then + chtmp = string + endif + endif + idiff = ichar('a') - ichar('A') + ucase = string + do 99 i = 1, k + c = string(i:i) + if (lge(c,'a') .and. lle(c,'z')) then + ucase(i:i) = char(ichar(c) - idiff) + endif + 99 continue + return + end diff --git a/source/cluster/wham/src-HCD/noyes.f b/source/cluster/wham/src-HCD/noyes.f new file mode 100644 index 0000000..4cf326c --- /dev/null +++ b/source/cluster/wham/src-HCD/noyes.f @@ -0,0 +1,16 @@ + LOGICAL FUNCTION NOYES() + CHARACTER*1 ANSWER + 101 READ (*,'(A1)') ANSWER + IF ( (ANSWER.EQ.'y') .OR. (ANSWER.EQ.'Y') ) THEN + NOYES=.TRUE. + RETURN + ELSE IF ( (ANSWER.EQ.'n') .OR. (ANSWER.EQ.'N') ) THEN + NOYES=.FALSE. + RETURN + ELSE +* PRINT *,CHAR(7) + PRINT *,'Incorrect keyword. Enter Y or N - ' + GOTO 101 + ENDIF + END + diff --git a/source/cluster/wham/src-HCD/oligomer.f b/source/cluster/wham/src-HCD/oligomer.f new file mode 100644 index 0000000..122bce0 --- /dev/null +++ b/source/cluster/wham/src-HCD/oligomer.f @@ -0,0 +1,86 @@ + subroutine oligomer + implicit none + include "DIMENSIONS" + include "COMMON.CHAIN" + include "COMMON.INTERACT" + include "COMMON.IOUNITS" + integer nchain,i,ii,ipi,ipj,ipmin,j,jmin,k,ix,iy,iz, + & ixmin,iymin,izmin + logical newchain + integer ichain(2,20),iper(20),iaux + double precision dchain,dchainmin,cmchain(3,20) + nchain=1 + newchain=.false. + ichain(1,nchain)=1 + do i=2,nres + if (itype(i).eq.ntyp1) then + if (newchain) then + ichain(2,nchain)=i + nchain=nchain+1 + newchain=.false. + else + newchain=.true. + ichain(1,nchain)=i + endif + endif + enddo + ichain(2,nchain)=nres + write (iout,*) "Chains" + do i=1,nchain + write (iout,*) i,ichain(1,i),ichain(2,i) + enddo + cmchain=0.0d0 + do i=1,nchain + ii=0 + do j=ichain(1,i),ichain(2,i) + if (itype(j).eq.ntyp1) cycle + ii=ii+1 + do k=1,3 + cmchain(k,i)=cmchain(k,i)+c(k,j) + enddo + enddo + do k=1,3 + cmchain(k,i)=cmchain(k,i)/ii + enddo + enddo + do i=1,nchain + iper(i)=i + enddo + do i=1,nchain + dchainmin=1.0d10 + do j=i+1,nchain + ipi=iper(i) + ipj=iper(j) + do ix=-1,1 + do iy=-1,1 + do iz=-1,1 + dchain=(cmchain(1,ipj)-cmchain(1,ipi)+ix*boxxsize)**2+ + & (cmchain(2,ipj)-cmchain(2,ipi)+iy*boxysize)**2+ + & (cmchain(3,ipj)-cmchain(3,ipi)+iz*boxzsize)**2 + if (dchain.lt.dchainmin) then + dchainmin=dchain + ixmin=ix + iymin=iy + izmin=iz + jmin=j + endif + enddo + enddo + enddo + enddo + cmchain(1,jmin)=cmchain(1,jmin)+ixmin*boxxsize + cmchain(2,jmin)=cmchain(2,jmin)+iymin*boxysize + cmchain(3,jmin)=cmchain(3,jmin)+izmin*boxzsize + do k=ichain(1,jmin),ichain(2,jmin) + c(1,k)=c(1,k)+ixmin*boxxsize + c(2,k)=c(2,k)+iymin*boxysize + c(3,k)=c(3,k)+izmin*boxzsize + enddo + write (iout,*) "jmin",jmin," ixmin",ixmin," iymin",iymin, + & " izmin",izmin + iaux=iper(i+1) + iper(i+1)=iper(jmin) + iper(jmin)=iaux + enddo + return + end diff --git a/source/cluster/wham/src-HCD/parmread.F b/source/cluster/wham/src-HCD/parmread.F new file mode 100644 index 0000000..8895504 --- /dev/null +++ b/source/cluster/wham/src-HCD/parmread.F @@ -0,0 +1,1598 @@ + subroutine parmread +C +C Read the parameters of the probability distributions of the virtual-bond +C valence angles and the side chains and energy parameters. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + 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.SCCOR' + include 'COMMON.SCROT' + include 'COMMON.SHIELD' + include 'COMMON.CONTROL' + include 'COMMON.LANGEVIN' + + character*1 t1,t2,t3 + character*1 onelett(4) /"G","A","P","D"/ + character*1 toronelet(-2:2) /"p","a","G","A","P"/ + logical lprint + dimension blower(3,3,maxlob) + character*3 lancuch,ucase +C +C Body +C + write (iout,*) "PARMREAD tor_mode",tor_mode + call getenv("PRINT_PARM",lancuch) + lprint = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") + write (iout,*) "lprint ",lprint +C Set LPRINT=.TRUE. for debugging + dwa16=2.0d0**(1.0d0/6.0d0) + itypro=20 +C Assign virtual-bond length + vbl=3.8D0 + vblinv=1.0D0/vbl + vblinv2=vblinv*vblinv +#ifdef CRYST_BOND + read (ibond,*,end=121,err=121) vbldp0,vbldpdum,akp,mp,ip,pstok + do i=1,ntyp + nbondterm(i)=1 + read (ibond,*,end=121,err=121) 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,*,end=121,err=121) ijunk,vbldp0,vbldpdum,akp,rjunk, + & mp,ip,pstok + do i=1,ntyp + read (ibond,*,end=121,err=121) 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/)')"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 + read(iliptranpar,*,end=1161,err=1161) pepliptran + do i=1,ntyp + read(iliptranpar,*,end=1161,err=1161) liptranene(i) + enddo + close(iliptranpar) +#ifdef CRYST_THETA +C +C Read the parameters of the probability distribution/energy expression +C of the virtual-bond valence angles theta +C + do i=1,ntyp + read (ithep,*,end=111,err=111) a0thet(i),(athet(j,i,1,1),j=1,2), + & (bthet(j,i,1,1),j=1,2) + read (ithep,*,end=111,err=111) (polthet(j,i),j=0,3) + read (ithep,*,end=111,err=111) (gthet(j,i),j=1,3) + read (ithep,*,end=111,err=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 +c write (iout,'(a)') +c & 'Parameters of the virtual-bond valence angles:' +c write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:', +c & ' ATHETA0 ',' A1 ',' A2 ', +c & ' B1 ',' B2 ' +c do i=1,ntyp +c write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, +c & a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2) +c enddo +c write (iout,'(/a/9x,5a/79(1h-))') +c & 'Parameters of the expression for sigma(theta_c):', +c & ' ALPH0 ',' ALPH1 ',' ALPH2 ', +c & ' ALPH3 ',' SIGMA0C ' +c do i=1,ntyp +c write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, +c & (polthet(j,i),j=0,3),sigc0(i) +c enddo +c write (iout,'(/a/9x,5a/79(1h-))') +c & 'Parameters of the second gaussian:', +c & ' THETA0 ',' SIGMA0 ',' G1 ', +c & ' G2 ',' G3 ' +c do i=1,ntyp +c write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i), +c & sig0(i),(gthet(j,i),j=1,3) +c 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 + IF (tor_mode.eq.0) THEN +C +C Read the parameters of Utheta determined from ab initio surfaces +C Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +C + read (ithep,*,end=111,err=111) nthetyp,ntheterm,ntheterm2, + & ntheterm3,nsingle,ndouble + nntheterm=max0(ntheterm,ntheterm2,ntheterm3) + read (ithep,*,end=111,err=111) (ithetyp(i),i=1,ntyp1) + do i=-ntyp1,-1 + ithetyp(i)=-ithetyp(-i) + enddo + 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 +C write (iout,*) "KURWA1" + do iblock=1,2 + do i=0,nthetyp + do j=-nthetyp,nthetyp + do k=-nthetyp,nthetyp + read (ithep,'(6a)',end=111,err=111) res1 + write(iout,*) res1,i,j,k + read (ithep,*,end=111,err=111) aa0thet(i,j,k,iblock) + 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 +C write(iout,*) "KURWA1.1" +C +C For dummy ends assign glycine-type coefficients of theta-only terms; the +C coefficients of theta-and-gamma-dependent terms are zero. +C + do i=1,nthetyp + do j=1,nthetyp + do l=1,ntheterm + aathet(l,i,j,nthetyp+1,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 +C write(iout,*) "KURWA1.5" +C 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 + +C +C Control printout of the coefficients of virtual-bond-angle potentials +C + if (lprint) then + write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' + do 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 + enddo + enddo + enddo + enddo + enddo + enddo + call flush(iout) + endif + + ELSE + +C here will be the apropriate recalibrating for D-aminoacid + read (ithep,*,end=111,err=111) nthetyp + do i=-nthetyp+1,nthetyp-1 + read (ithep,*,end=111,err=111) nbend_kcc_Tb(i) + do j=0,nbend_kcc_Tb(i) + read (ithep,*,end=111,err=111) ijunk,v1bend_chyb(j,i) + enddo + enddo + if (lprint) then + write (iout,'(a)') + & "Parameters of the valence-only potentials" + do i=-nthetyp+1,nthetyp-1 + write (iout,'(2a)') "Type ",toronelet(i) + do k=0,nbend_kcc_Tb(i) + write(iout,'(i5,f15.5)') k,v1bend_chyb(k,i) + enddo + enddo + endif + + ENDIF ! TOR_MODE + + close(ithep) +#endif +C write(iout,*) 'KURWA2' +#ifdef CRYST_SC +C +C Read the parameters of the probability distribution/energy expression +C of the side chains. +C + do i=1,ntyp +cc 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,*,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) +C 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) +c write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi) +c write (iout,'(a,f10.4,4(16x,f10.4))') +c & 'Center ',(bsc(j,i),j=1,nlobi) +c 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) +c write (iout,'(a)') +c do j=1,nlobi +c ind=0 +c do k=1,3 +c do l=1,k +c ind=ind+1 +c blower(k,l,j)=gaussc(ind,j,i) +c enddo +c enddo +c 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 +C +C Read scrot parameters for potentials determined from all-atom AM1 calculations +C added by Urszula Kozlowska 07/11/2007 +C + do i=1,ntyp + read (irotam,*,end=112,err=112) + if (i.eq.10) then + read (irotam,*,end=112,err=112) + else + do j=1,65 + read(irotam,*,end=112,err=112) sc_parmin(j,i) + enddo + endif + enddo +#endif + close(irotam) +C +C 9/18/99 (AL) Read coefficients of the Fourier expansion of the local +C interaction energy of the Gly, Ala, and Pro prototypes. +C + read (ifourier,*,end=115,err=115) nloctyp + SPLIT_FOURIERTOR = nloctyp.lt.0 + nloctyp = iabs(nloctyp) +#ifdef NEWCORR + read (ifourier,*,end=115,err=115) (itype2loc(i),i=1,ntyp) + read (ifourier,*,end=115,err=115) (iloctyp(i),i=0,nloctyp-1) + itype2loc(ntyp1)=nloctyp + iloctyp(nloctyp)=ntyp1 + do i=1,ntyp1 + itype2loc(-i)=-itype2loc(i) + enddo +#else + iloctyp(0)=10 + iloctyp(1)=9 + iloctyp(2)=20 + iloctyp(3)=ntyp1 +#endif + do i=1,nloctyp + iloctyp(-i)=-iloctyp(i) + enddo +c write (iout,*) "itype2loc",(itype2loc(i),i=1,ntyp1) +c write (iout,*) "nloctyp",nloctyp, +c & " iloctyp",(iloctyp(i),i=0,nloctyp) +#ifdef NEWCORR + do i=0,nloctyp-1 +c write (iout,*) "NEWCORR",i + read (ifourier,*,end=115,err=115) + do ii=1,3 + do j=1,2 + read (ifourier,*,end=115,err=115) bnew1(ii,j,i) + enddo + enddo +c write (iout,*) "NEWCORR BNEW1" +c write (iout,*) ((bnew1(ii,j,i),ii=1,3),j=1,2) + do ii=1,3 + do j=1,2 + read (ifourier,*,end=115,err=115) bnew2(ii,j,i) + enddo + enddo +c write (iout,*) "NEWCORR BNEW2" +c write (iout,*) ((bnew2(ii,j,i),ii=1,3),j=1,2) + do kk=1,3 + read (ifourier,*,end=115,err=115) ccnew(kk,1,i) + read (ifourier,*,end=115,err=115) ccnew(kk,2,i) + enddo +c write (iout,*) "NEWCORR CCNEW" +c write (iout,*) ((ccnew(ii,j,i),ii=1,3),j=1,2) + do kk=1,3 + read (ifourier,*,end=115,err=115) ddnew(kk,1,i) + read (ifourier,*,end=115,err=115) ddnew(kk,2,i) + enddo +c write (iout,*) "NEWCORR DDNEW" +c write (iout,*) ((ddnew(ii,j,i),ii=1,3),j=1,2) + do ii=1,2 + do jj=1,2 + do kk=1,2 + read (ifourier,*,end=115,err=115) eenew(ii,jj,kk,i) + enddo + enddo + enddo +c write (iout,*) "NEWCORR EENEW1" +c write(iout,*)(((eenew(ii,jj,kk,i),kk=1,2),jj=1,2),ii=1,2) + do ii=1,3 + read (ifourier,*,end=115,err=115) e0new(ii,i) + enddo +c write (iout,*) (e0new(ii,i),ii=1,3) + enddo +c write (iout,*) "NEWCORR EENEW" + do i=0,nloctyp-1 + do ii=1,3 + ccnew(ii,1,i)=ccnew(ii,1,i)/2 + ccnew(ii,2,i)=ccnew(ii,2,i)/2 + ddnew(ii,1,i)=ddnew(ii,1,i)/2 + ddnew(ii,2,i)=ddnew(ii,2,i)/2 + enddo + enddo + do i=1,nloctyp-1 + do ii=1,3 + bnew1(ii,1,-i)= bnew1(ii,1,i) + bnew1(ii,2,-i)=-bnew1(ii,2,i) + bnew2(ii,1,-i)= bnew2(ii,1,i) + bnew2(ii,2,-i)=-bnew2(ii,2,i) + enddo + do ii=1,3 +c ccnew(ii,1,i)=ccnew(ii,1,i)/2 +c ccnew(ii,2,i)=ccnew(ii,2,i)/2 +c ddnew(ii,1,i)=ddnew(ii,1,i)/2 +c ddnew(ii,2,i)=ddnew(ii,2,i)/2 + ccnew(ii,1,-i)=ccnew(ii,1,i) + ccnew(ii,2,-i)=-ccnew(ii,2,i) + ddnew(ii,1,-i)=ddnew(ii,1,i) + ddnew(ii,2,-i)=-ddnew(ii,2,i) + enddo + e0new(1,-i)= e0new(1,i) + e0new(2,-i)=-e0new(2,i) + e0new(3,-i)=-e0new(3,i) + do kk=1,2 + eenew(kk,1,1,-i)= eenew(kk,1,1,i) + eenew(kk,1,2,-i)=-eenew(kk,1,2,i) + eenew(kk,2,1,-i)=-eenew(kk,2,1,i) + eenew(kk,2,2,-i)= eenew(kk,2,2,i) + enddo + enddo + if (lprint) then + write (iout,'(a)') "Coefficients of the multibody terms" + do i=-nloctyp+1,nloctyp-1 + write (iout,*) "Type: ",onelet(iloctyp(i)) + write (iout,*) "Coefficients of the expansion of B1" + do j=1,2 + write (iout,'(3hB1(,i1,1h),3f10.5)') j,(bnew1(k,j,i),k=1,3) + enddo + write (iout,*) "Coefficients of the expansion of B2" + do j=1,2 + write (iout,'(3hB2(,i1,1h),3f10.5)') j,(bnew2(k,j,i),k=1,3) + enddo + write (iout,*) "Coefficients of the expansion of C" + write (iout,'(3hC11,3f10.5)') (ccnew(j,1,i),j=1,3) + write (iout,'(3hC12,3f10.5)') (ccnew(j,2,i),j=1,3) + write (iout,*) "Coefficients of the expansion of D" + write (iout,'(3hD11,3f10.5)') (ddnew(j,1,i),j=1,3) + write (iout,'(3hD12,3f10.5)') (ddnew(j,2,i),j=1,3) + write (iout,*) "Coefficients of the expansion of E" + write (iout,'(2hE0,3f10.5)') (e0new(j,i),j=1,3) + do j=1,2 + do k=1,2 + write (iout,'(1hE,2i1,2f10.5)') j,k,(eenew(l,j,k,i),l=1,2) + enddo + enddo + enddo + endif + IF (SPLIT_FOURIERTOR) THEN + do i=0,nloctyp-1 +c write (iout,*) "NEWCORR TOR",i + read (ifourier,*,end=115,err=115) + do ii=1,3 + do j=1,2 + read (ifourier,*,end=115,err=115) bnew1tor(ii,j,i) + enddo + enddo +c write (iout,*) "NEWCORR BNEW1 TOR" +c write (iout,*) ((bnew1tor(ii,j,i),ii=1,3),j=1,2) + do ii=1,3 + do j=1,2 + read (ifourier,*,end=115,err=115) bnew2tor(ii,j,i) + enddo + enddo +c write (iout,*) "NEWCORR BNEW2 TOR" +c write (iout,*) ((bnew2tor(ii,j,i),ii=1,3),j=1,2) + do kk=1,3 + read (ifourier,*,end=115,err=115) ccnewtor(kk,1,i) + read (ifourier,*,end=115,err=115) ccnewtor(kk,2,i) + enddo +c write (iout,*) "NEWCORR CCNEW TOR" +c write (iout,*) ((ccnew(ii,j,i),ii=1,3),j=1,2) + do kk=1,3 + read (ifourier,*,end=115,err=115) ddnewtor(kk,1,i) + read (ifourier,*,end=115,err=115) ddnewtor(kk,2,i) + enddo +c write (iout,*) "NEWCORR DDNEW TOR" +c write (iout,*) ((ddnewtor(ii,j,i),ii=1,3),j=1,2) + do ii=1,2 + do jj=1,2 + do kk=1,2 + read (ifourier,*,end=115,err=115) eenewtor(ii,jj,kk,i) + enddo + enddo + enddo +c write (iout,*) "NEWCORR EENEW1 TOR" +c write(iout,*)(((eenewtor(ii,jj,kk,i),kk=1,2),jj=1,2),ii=1,2) + do ii=1,3 + read (ifourier,*,end=115,err=115) e0newtor(ii,i) + enddo +c write (iout,*) (e0newtor(ii,i),ii=1,3) + enddo +c write (iout,*) "NEWCORR EENEW TOR" + do i=0,nloctyp-1 + do ii=1,3 + ccnewtor(ii,1,i)=ccnewtor(ii,1,i)/2 + ccnewtor(ii,2,i)=ccnewtor(ii,2,i)/2 + ddnewtor(ii,1,i)=ddnewtor(ii,1,i)/2 + ddnewtor(ii,2,i)=ddnewtor(ii,2,i)/2 + enddo + enddo + do i=1,nloctyp-1 + do ii=1,3 + bnew1tor(ii,1,-i)= bnew1tor(ii,1,i) + bnew1tor(ii,2,-i)=-bnew1tor(ii,2,i) + bnew2tor(ii,1,-i)= bnew2tor(ii,1,i) + bnew2tor(ii,2,-i)=-bnew2tor(ii,2,i) + enddo + do ii=1,3 + ccnewtor(ii,1,-i)=ccnewtor(ii,1,i) + ccnewtor(ii,2,-i)=-ccnewtor(ii,2,i) + ddnewtor(ii,1,-i)=ddnewtor(ii,1,i) + ddnewtor(ii,2,-i)=-ddnewtor(ii,2,i) + enddo + e0newtor(1,-i)= e0newtor(1,i) + e0newtor(2,-i)=-e0newtor(2,i) + e0newtor(3,-i)=-e0newtor(3,i) + do kk=1,2 + eenewtor(kk,1,1,-i)= eenewtor(kk,1,1,i) + eenewtor(kk,1,2,-i)=-eenewtor(kk,1,2,i) + eenewtor(kk,2,1,-i)=-eenewtor(kk,2,1,i) + eenewtor(kk,2,2,-i)= eenewtor(kk,2,2,i) + enddo + enddo + if (lprint) then + write (iout,'(a)') + & "Single-body coefficients of the torsional potentials" + do i=-nloctyp+1,nloctyp-1 + write (iout,*) "Type: ",onelet(iloctyp(i)) + write (iout,*) "Coefficients of the expansion of B1tor" + do j=1,2 + write (iout,'(3hB1(,i1,1h),3f10.5)') + & j,(bnew1tor(k,j,i),k=1,3) + enddo + write (iout,*) "Coefficients of the expansion of B2tor" + do j=1,2 + write (iout,'(3hB2(,i1,1h),3f10.5)') + & j,(bnew2tor(k,j,i),k=1,3) + enddo + write (iout,*) "Coefficients of the expansion of Ctor" + write (iout,'(3hC11,3f10.5)') (ccnewtor(j,1,i),j=1,3) + write (iout,'(3hC12,3f10.5)') (ccnewtor(j,2,i),j=1,3) + write (iout,*) "Coefficients of the expansion of Dtor" + write (iout,'(3hD11,3f10.5)') (ddnewtor(j,1,i),j=1,3) + write (iout,'(3hD12,3f10.5)') (ddnewtor(j,2,i),j=1,3) + write (iout,*) "Coefficients of the expansion of Etor" + write (iout,'(2hE0,3f10.5)') (e0newtor(j,i),j=1,3) + do j=1,2 + do k=1,2 + write (iout,'(1hE,2i1,2f10.5)') + & j,k,(eenewtor(l,j,k,i),l=1,2) + enddo + enddo + enddo + endif + ELSE + do i=-nloctyp+1,nloctyp-1 + do ii=1,3 + do j=1,2 + bnew1tor(ii,j,i)=bnew1(ii,j,i) + enddo + enddo + do ii=1,3 + do j=1,2 + bnew2tor(ii,j,i)=bnew2(ii,j,i) + enddo + enddo + do ii=1,3 + ccnewtor(ii,1,i)=ccnew(ii,1,i) + ccnewtor(ii,2,i)=ccnew(ii,2,i) + ddnewtor(ii,1,i)=ddnew(ii,1,i) + ddnewtor(ii,2,i)=ddnew(ii,2,i) + enddo + enddo + ENDIF !SPLIT_FOURIER_TOR +#else + if (lprint) + & write (iout,*) "Coefficients of the expansion of Eloc(l1,l2)" + do i=0,nloctyp-1 + read (ifourier,*,end=115,err=115) + read (ifourier,*,end=115,err=115) (b(ii,i),ii=1,13) + if (lprint) then + write (iout,*) 'Type ',onelet(iloctyp(i)) + write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii,i),ii=1,13) + endif + if (i.gt.0) then + b(2,-i)= b(2,i) + b(3,-i)= b(3,i) + b(4,-i)=-b(4,i) + b(5,-i)=-b(5,i) + endif +c B1(1,i) = b(3) +c B1(2,i) = b(5) +c B1(1,-i) = b(3) +c B1(2,-i) = -b(5) +c b1(1,i)=0.0d0 +c b1(2,i)=0.0d0 +c B1tilde(1,i) = b(3) +c B1tilde(2,i) =-b(5) +c B1tilde(1,-i) =-b(3) +c B1tilde(2,-i) =b(5) +c b1tilde(1,i)=0.0d0 +c b1tilde(2,i)=0.0d0 +c B2(1,i) = b(2) +c B2(2,i) = b(4) +c B2(1,-i) =b(2) +c B2(2,-i) =-b(4) +cc B1tilde(1,i) = b(3,i) +cc B1tilde(2,i) =-b(5,i) +C B1tilde(1,-i) =-b(3,i) +C B1tilde(2,-i) =b(5,i) +cc b1tilde(1,i)=0.0d0 +cc b1tilde(2,i)=0.0d0 +cc B2(1,i) = b(2,i) +cc B2(2,i) = b(4,i) +C B2(1,-i) =b(2,i) +C B2(2,-i) =-b(4,i) + +c b2(1,i)=0.0d0 +c b2(2,i)=0.0d0 + CCold(1,1,i)= b(7,i) + CCold(2,2,i)=-b(7,i) + CCold(2,1,i)= b(9,i) + CCold(1,2,i)= b(9,i) + CCold(1,1,-i)= b(7,i) + CCold(2,2,-i)=-b(7,i) + CCold(2,1,-i)=-b(9,i) + CCold(1,2,-i)=-b(9,i) +c CC(1,1,i)=0.0d0 +c CC(2,2,i)=0.0d0 +c CC(2,1,i)=0.0d0 +c CC(1,2,i)=0.0d0 +c Ctilde(1,1,i)= CCold(1,1,i) +c Ctilde(1,2,i)= CCold(1,2,i) +c Ctilde(2,1,i)=-CCold(2,1,i) +c Ctilde(2,2,i)=-CCold(2,2,i) + +c Ctilde(1,1,i)=0.0d0 +c Ctilde(1,2,i)=0.0d0 +c Ctilde(2,1,i)=0.0d0 +c Ctilde(2,2,i)=0.0d0 + DDold(1,1,i)= b(6,i) + DDold(2,2,i)=-b(6,i) + DDold(2,1,i)= b(8,i) + DDold(1,2,i)= b(8,i) + DDold(1,1,-i)= b(6,i) + DDold(2,2,-i)=-b(6,i) + DDold(2,1,-i)=-b(8,i) + DDold(1,2,-i)=-b(8,i) +c DD(1,1,i)=0.0d0 +c DD(2,2,i)=0.0d0 +c DD(2,1,i)=0.0d0 +c DD(1,2,i)=0.0d0 +c Dtilde(1,1,i)= DD(1,1,i) +c Dtilde(1,2,i)= DD(1,2,i) +c Dtilde(2,1,i)=-DD(2,1,i) +c Dtilde(2,2,i)=-DD(2,2,i) + +c Dtilde(1,1,i)=0.0d0 +c Dtilde(1,2,i)=0.0d0 +c Dtilde(2,1,i)=0.0d0 +c Dtilde(2,2,i)=0.0d0 + EEold(1,1,i)= b(10,i)+b(11,i) + EEold(2,2,i)=-b(10,i)+b(11,i) + EEold(2,1,i)= b(12,i)-b(13,i) + EEold(1,2,i)= b(12,i)+b(13,i) + EEold(1,1,-i)= b(10,i)+b(11,i) + EEold(2,2,-i)=-b(10,i)+b(11,i) + EEold(2,1,-i)=-b(12,i)+b(13,i) + EEold(1,2,-i)=-b(12,i)-b(13,i) + write(iout,*) "TU DOCHODZE" + print *,"JESTEM" +c ee(1,1,i)=1.0d0 +c ee(2,2,i)=1.0d0 +c ee(2,1,i)=0.0d0 +c ee(1,2,i)=0.0d0 +c ee(2,1,i)=ee(1,2,i) + enddo + if (lprint) then + write (iout,*) + write (iout,*) + &"Coefficients of the cumulants (independent of valence angles)" + do i=-nloctyp+1,nloctyp-1 + write (iout,*) 'Type ',onelet(iloctyp(i)) + write (iout,*) 'B1' + write(iout,'(2f10.5)') B(3,i),B(5,i) + write (iout,*) 'B2' + write(iout,'(2f10.5)') B(2,i),B(4,i) + write (iout,*) 'CC' + do j=1,2 + write (iout,'(2f10.5)') CCold(j,1,i),CCold(j,2,i) + enddo + write(iout,*) 'DD' + do j=1,2 + write (iout,'(2f10.5)') DDold(j,1,i),DDold(j,2,i) + enddo + write(iout,*) 'EE' + do j=1,2 + write (iout,'(2f10.5)') EEold(j,1,i),EEold(j,2,i) + enddo + enddo + endif +#endif +C write (iout,*) 'KURWAKURWA' +#ifdef CRYST_TOR +C +C Read torsional parameters in old format +C + read (itorp,*,end=113,err=113) ntortyp,nterm_old + write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + do i=1,ntortyp + do j=1,ntortyp + read (itorp,'(a)',end=113,err=113) + do k=1,nterm_old + read (itorp,*,end=113,err=113) kk,v1(k,j,i),v2(k,j,i) + enddo + enddo + enddo + close (itorp) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do i=1,ntortyp + do j=1,ntortyp + write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) + write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) + enddo + enddo + endif +#else +C +C Read torsional parameters +C + IF (TOR_MODE.eq.0) THEN + + read (itorp,*,end=113,err=113) ntortyp + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + do i=1,ntyp1 + itype2loc(i)=itortyp(i) + enddo + write (iout,*) 'ntortyp',ntortyp + do iblock=1,2 + do i=-ntyp,-1 + itortyp(i)=-itortyp(-i) + enddo +c 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 + 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 i=1,ntortyp + do j=1,ntortyp + do iblock=1,2 + write (iout,*) 'ityp',i,' jtyp',j," block",iblock + 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 +C +C 6/23/01 Read parameters for double torsionals +C + 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 +c write (iout,*) "OK onelett", +c & 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)) +C 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) +c write(iout,*) "whcodze" , +c & 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)) +C 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 + + ELSE IF (TOR_MODE.eq.1) THEN + +C read valence-torsional parameters + read (itorp,*,end=113,err=113) ntortyp + nkcctyp=ntortyp + write (iout,*) "Valence-torsional parameters read in ntortyp", + & ntortyp + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + write (iout,*) "itortyp_kcc",(itortyp(i),i=1,ntyp) + do i=-ntyp,-1 + itortyp(i)=-itortyp(-i) + enddo + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 +C first we read the cos and sin gamma parameters + read (itorp,'(13x,a)',end=113,err=113) string + write (iout,*) i,j,string + read (itorp,*,end=113,err=113) + & nterm_kcc(j,i),nterm_kcc_Tb(j,i) +C read (itorkcc,*,end=121,err=121) nterm_kcc_Tb(j,i) + do k=1,nterm_kcc(j,i) + do l=1,nterm_kcc_Tb(j,i) + do ll=1,nterm_kcc_Tb(j,i) + read (itorp,*,end=113,err=113) ii,jj,kk, + & v1_kcc(ll,l,k,j,i),v2_kcc(ll,l,k,j,i) + enddo + enddo + enddo + enddo + enddo + + ELSE +c AL 4/8/16: Calculate coefficients from one-body parameters + ntortyp=nloctyp + do i=-ntyp1,ntyp1 + itortyp(i)=itype2loc(i) + enddo + write (iout,*) + &"Val-tor parameters calculated from cumulant coefficients ntortyp" + & ,ntortyp + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + nterm_kcc(j,i)=2 + nterm_kcc_Tb(j,i)=3 + do k=1,nterm_kcc_Tb(j,i) + do l=1,nterm_kcc_Tb(j,i) + v1_kcc(k,l,1,i,j)=bnew1tor(k,1,i)*bnew2tor(l,1,j) + & +bnew1tor(k,2,i)*bnew2tor(l,2,j) + v2_kcc(k,l,1,i,j)=bnew1tor(k,1,i)*bnew2tor(l,2,j) + & +bnew1tor(k,2,i)*bnew2tor(l,1,j) + enddo + enddo + do k=1,nterm_kcc_Tb(j,i) + do l=1,nterm_kcc_Tb(j,i) +#ifdef CORRCD + v1_kcc(k,l,2,i,j)=-(ccnewtor(k,1,i)*ddnewtor(l,1,j) + & -ccnewtor(k,2,i)*ddnewtor(l,2,j)) + v2_kcc(k,l,2,i,j)=-(ccnewtor(k,2,i)*ddnewtor(l,1,j) + & +ccnewtor(k,1,i)*ddnewtor(l,2,j)) +#else + v1_kcc(k,l,2,i,j)=-0.25*(ccnewtor(k,1,i)*ddnewtor(l,1,j) + & -ccnewtor(k,2,i)*ddnewtor(l,2,j)) + v2_kcc(k,l,2,i,j)=-0.25*(ccnewtor(k,2,i)*ddnewtor(l,1,j) + & +ccnewtor(k,1,i)*ddnewtor(l,2,j)) +#endif + enddo + enddo +cf(theta,gamma)=-(b21(theta)*b11(theta)+b12(theta)*b22(theta))*cos(gamma)-(b22(theta)*b11(theta)+b21(theta)*b12(theta))*sin(gamma)+(c11(theta)*d11(theta)-c12(theta)*d12(theta))*cos(2*gamma)+(c12(theta)*d11(theta)+c11(theta)*d12(theta))*sin(2*gamma) + enddo + enddo + + ENDIF ! TOR_MODE + + if (tor_mode.gt.0 .and. lprint) then +c Print valence-torsional parameters + write (iout,'(a)') + & "Parameters of the valence-torsional potentials" + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + write (iout,'(3a)') "Type ",toronelet(i),toronelet(j) + write (iout,'(3a5,2a15)') "itor","ival","jval","v_kcc","v2_kcc" + do k=1,nterm_kcc(j,i) + do l=1,nterm_kcc_Tb(j,i) + do ll=1,nterm_kcc_Tb(j,i) + write (iout,'(3i5,2f15.4)') + & k,l-1,ll-1,v1_kcc(ll,l,k,j,i),v2_kcc(ll,l,k,j,i) + enddo + enddo + enddo + enddo + enddo + endif + +#endif +C Read of Side-chain backbone correlation parameters +C Modified 11 May 2012 by Adasko +CCC +C + read (isccor,*,end=119,err=119) nsccortyp + read (isccor,*,end=119,err=119) (isccortyp(i),i=1,ntyp) + do i=-ntyp,-1 + isccortyp(i)=-isccortyp(-i) + enddo + iscprol=isccortyp(20) +c write (iout,*) 'ntortyp',ntortyp + maxinter=3 +cc maxinter is maximum interaction sites + do l=1,maxinter + do i=1,nsccortyp + do j=1,nsccortyp + read (isccor,*,end=119,err=119) + &nterm_sccor(i,j),nlor_sccor(i,j) +c write (iout,*) nterm_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) +c write (iout,*) nterm_sccor(i,j),nterm_sccor(-i,j), +c & 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) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants of SCCORR:' + do l=1,maxinter + 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 + enddo + endif +C +C Read electrostatic-interaction parameters +C + 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,*,end=116,err=116) ((epp(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((rpp(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((elpp6(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((elpp3(i,j),j=1,2),i=1,2) + close (ielep) + do i=1,2 + do j=1,2 + rri=rpp(i,j)**6 + app (i,j)=epp(i,j)*rri*rri + bpp (i,j)=-2.0D0*epp(i,j)*rri + ael6(i,j)=elpp6(i,j)*4.2D0**6 + ael3(i,j)=elpp3(i,j)*4.2D0**3 + if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j), + & ael6(i,j),ael3(i,j) + enddo + enddo +C +C Read side-chain interaction parameters. +C + read (isidep,*,end=117,err=117) ipot,expon + if (ipot.lt.1 .or. ipot.gt.5) then + write (iout,'(2a)') 'Error while reading SC interaction', + & 'potential file - unknown potential type.' + stop + endif + expon2=expon/2 + write(iout,'(/3a,2i3)') 'Potential is ',potname(ipot), + & ', exponents are ',expon,2*expon + goto (10,20,30,30,40) ipot +C----------------------- LJ potential --------------------------------- + 10 read (isidep,*,end=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 +C----------------------- LJK potential -------------------------------- + 20 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 +C---------------------- GB or BP potential ----------------------------- + 30 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) + do i=1,ntyp + read (isidep,*,end=117,err=117)(epslip(i,j),j=i,ntyp) +C write(iout,*) "WARNING!!",i,ntyp + if (lprint) write(iout,*) "epslip", i, (epslip(i,j),j=i,ntyp) +C do j=1,ntyp +C epslip(i,j)=epslip(i,j)+0.05d0 +C enddo + enddo +C For the GB potential convert sigma'**2 into chi' + if (ipot.eq.4) then + do i=1,ntyp + chip(i)=(chip(i)-1.0D0)/(chip(i)+1.0D0) + enddo + endif + if (lprint) then + write (iout,'(/a/)') 'Parameters of the BP potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,4a)') 'residue',' sigma ','s||/s_|_^2', + & ' chip ',' alph ' + write (iout,'(a3,6x,4f10.5)') (restyp(i),sigma0(i),sigii(i), + & chip(i),alp(i),i=1,ntyp) + endif + goto 50 +C--------------------- GBV potential ----------------------------------- + 40 read (isidep,*,end=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 + 50 continue + close (isidep) +C----------------------------------------------------------------------- +C Calculate the "working" parameters of SC interactions. + do i=2,ntyp + do j=1,i-1 + eps(i,j)=eps(j,i) + epslip(i,j)=epslip(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) + epsijlip=epslip(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_aq(i,j)=epsij*rrij*rrij + bb_aq(i,j)=-sigeps*epsij*rrij + aa_aq(j,i)=aa_aq(i,j) + bb_aq(j,i)=bb_aq(i,j) + sigeps=dsign(1.0D0,epsijlip) + epsijlip=dabs(epsijlip) + aa_lip(i,j)=epsijlip*rrij*rrij + bb_lip(i,j)=-sigeps*epsijlip*rrij + aa_lip(j,i)=aa_lip(i,j) + bb_lip(j,i)=bb_lip(i,j) + if (ipot.gt.2) then + sigt1sq=sigma0(i)**2 + sigt2sq=sigma0(j)**2 + sigii1=sigii(i) + sigii2=sigii(j) + ratsig1=sigt2sq/sigt1sq + ratsig2=1.0D0/ratsig1 + chi(i,j)=(sigii1-1.0D0)/(sigii1+ratsig1) + if (j.gt.i) chi(j,i)=(sigii2-1.0D0)/(sigii2+ratsig2) + rsum_max=dsqrt(sigii1*sigt1sq+sigii2*sigt2sq) + else + rsum_max=sigma(i,j) + endif +c if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then + sigmaii(i,j)=rsum_max + sigmaii(j,i)=rsum_max +c else +c sigmaii(i,j)=r0(i,j) +c sigmaii(j,i)=r0(i,j) +c endif +cd write (iout,*) i,j,r0(i,j),sigma(i,j),rsum_max + if ((ipot.eq.2 .or. ipot.eq.5) .and. r0(i,j).gt.rsum_max) then + r_augm=sigma(i,j)*(rrij-sigma(i,j))/rrij + augm(i,j)=epsij*r_augm**(2*expon) +c augm(i,j)=0.5D0**(2*expon)*aa(i,j) + augm(j,i)=augm(i,j) + else + augm(i,j)=0.0D0 + augm(j,i)=0.0D0 + endif + if (lprint) then + write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') + & restyp(i),restyp(j),aa_aq(i,j),bb_aq(i,j),augm(i,j), + & sigma(i,j),r0(i,j),chi(i,j),chi(j,i) + endif + enddo + enddo +C +C Define the SC-p interaction constants +C +#ifdef OLDSCP + do i=1,20 +C "Soft" SC-p repulsion (causes helices to be too flat, but facilitates +C helix formation) +c aad(i,1)=0.3D0*4.0D0**12 +C Following line for constants currently implemented +C "Hard" SC-p repulsion (gives correct turn spacing in helices) + aad(i,1)=1.5D0*4.0D0**12 +c aad(i,1)=0.17D0*5.6D0**12 + aad(i,2)=aad(i,1) +C "Soft" SC-p repulsion + bad(i,1)=0.0D0 +C Following line for constants currently implemented +c aad(i,1)=0.3D0*4.0D0**6 +C "Hard" SC-p repulsion + bad(i,1)=3.0D0*4.0D0**6 +c bad(i,1)=-2.0D0*0.17D0*5.6D0**6 + bad(i,2)=bad(i,1) +c aad(i,1)=0.0D0 +c aad(i,2)=0.0D0 +c bad(i,1)=1228.8D0 +c bad(i,2)=1228.8D0 + enddo +#else +C +C 8/9/01 Read the SC-p interaction constants from file +C + do i=1,ntyp + read (iscpp,*,end=118,err=118) (eps_scp(i,j),rscp(i,j),j=1,2) + enddo + do i=1,ntyp + aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12 + aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12 + bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6 + bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6 + enddo + + if (lprint) then + write (iout,*) "Parameters of SC-p interactions:" + do i=1,20 + write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1), + & eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) + enddo + endif +#endif +C +C Define the constants of the disulfide bridge +C +C ebr=-12.0D0 +c +c Old arbitrary potential - commented out. +c +c dbr= 4.20D0 +c fbr= 3.30D0 +c +c Constants of the disulfide-bond potential determined based on the RHF/6-31G** +c energy surface of diethyl disulfide. +c A. Liwo and U. Kozlowska, 11/24/03 +c +C D0CM = 3.78d0 +C AKCM = 15.1d0 +C AKTH = 11.0d0 +C AKCT = 12.0d0 +C V1SS =-1.08d0 +C V2SS = 7.61d0 +C V3SS = 13.7d0 + write (iout,*) dyn_ss,'dyndyn' + if (dyn_ss) then + ss_depth=ebr/wsc-0.25*eps(1,1) +C write(iout,*) akcm,whpb,wsc,'KURWA' + Ht=Ht/wsc-0.25*eps(1,1) + + akcm=akcm*whpb/wsc + akth=akth*whpb/wsc + akct=akct*whpb/wsc + v1ss=v1ss*whpb/wsc + v2ss=v2ss*whpb/wsc + v3ss=v3ss*whpb/wsc + else + ss_depth=ebr/whpb-0.25*eps(1,1)*wsc/whpb + endif + +C 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 +C endif + if (shield_mode.gt.0) then + pi=3.141592d0 +C VSolvSphere the volume of solving sphere +C print *,pi,"pi" +C rpp(1,1) is the energy r0 for peptide group contact and will be used for it +C there will be no distinction between proline peptide group and normal peptide +C group in case of shielding parameters + VSolvSphere=4.0/3.0*pi*rpp(1,1)**3 + VSolvSphere_div=VSolvSphere-4.0/3.0*pi*(rpp(1,1)/2.0)**3 + write (iout,*) VSolvSphere,VSolvSphere_div +C long axis of side chain + do i=1,ntyp + long_r_sidechain(i)=vbldsc0(1,i) + short_r_sidechain(i)=sigma0(i) + enddo + buff_shield=1.0d0 + 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 + 1161 write (iout,*) "Error reading electrostatic energy parameters.Lip" + 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" + goto 999 + 121 write (iout,*) "Error reading bond parameters" + 999 continue +#ifdef MPI + call MPI_Finalize(Ierror) +#endif + stop + end diff --git a/source/cluster/wham/src-HCD/permut.F b/source/cluster/wham/src-HCD/permut.F new file mode 100644 index 0000000..f81abd8 --- /dev/null +++ b/source/cluster/wham/src-HCD/permut.F @@ -0,0 +1,61 @@ + subroutine permut(isym,nperm,tabperm) +c integer maxperm,maxsym +c parameter (maxperm=3628800) +c parameter (maxsym=10) + include "DIMENSIONS" + integer n,a,tabperm + logical nextp + external nextp + dimension a(isym),tabperm(maxchain,maxperm) + n=isym + nperm=1 + if (n.eq.1) then + tabperm(1,1)=1 + return + endif + do i=2,n + nperm=nperm*i + enddo + kkk=0 + do i=1,n + a(i)=i + enddo + 10 continue +c print '(i3,2x,100i3)',kkk+1,(a(i),i=1,n) + kkk=kkk+1 + do i=1,n + tabperm(i,kkk)=a(i) + enddo + if(nextp(n,a)) go to 10 + return + end + + function nextp(n,a) + integer n,a,i,j,k,t + logical nextp + dimension a(n) + 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 diff --git a/source/cluster/wham/src-HCD/pinorm.f b/source/cluster/wham/src-HCD/pinorm.f new file mode 100644 index 0000000..91392bf --- /dev/null +++ b/source/cluster/wham/src-HCD/pinorm.f @@ -0,0 +1,17 @@ + double precision function pinorm(x) + implicit real*8 (a-h,o-z) +c +c this function takes an angle (in radians) and puts it in the range of +c -pi to +pi. +c + integer n + include 'COMMON.GEO' + n = x / dwapi + pinorm = x - n * dwapi + if ( pinorm .gt. pi ) then + pinorm = pinorm - dwapi + else if ( pinorm .lt. - pi ) then + pinorm = pinorm + dwapi + end if + return + end diff --git a/source/cluster/wham/src-HCD/printmat.f b/source/cluster/wham/src-HCD/printmat.f new file mode 100644 index 0000000..be2b38f --- /dev/null +++ b/source/cluster/wham/src-HCD/printmat.f @@ -0,0 +1,16 @@ + subroutine printmat(ldim,m,n,iout,key,a) + character*3 key(n) + double precision a(ldim,n) + do 1 i=1,n,8 + nlim=min0(i+7,n) + write (iout,1000) (key(k),k=i,nlim) + write (iout,1020) + 1000 format (/5x,8(6x,a3)) + 1020 format (/80(1h-)/) + do 2 j=1,n + write (iout,1010) key(j),(a(j,k),k=i,nlim) + 2 continue + 1 continue + 1010 format (a3,2x,8(f9.4)) + return + end diff --git a/source/cluster/wham/src-HCD/probabl.F b/source/cluster/wham/src-HCD/probabl.F new file mode 100644 index 0000000..a3a664b --- /dev/null +++ b/source/cluster/wham/src-HCD/probabl.F @@ -0,0 +1,302 @@ + subroutine probabl(ib,nlist,ncon,*) +! construct the conformational ensembles at REMD temperatures + implicit none + include "DIMENSIONS" + include "sizesclu.dat" +#ifdef MPI + include "mpif.h" + include "COMMON.MPI" + integer ierror,errcode,status(MPI_STATUS_SIZE) +#endif + include "COMMON.CONTROL" + include "COMMON.IOUNITS" + include "COMMON.FREE" + include "COMMON.FFIELD" + include "COMMON.INTERACT" + include "COMMON.SBRIDGE" + include "COMMON.CHAIN" + include "COMMON.CLUSTER" + real*4 csingle(3,maxres2) + double precision fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl, + & eprim,ebis,temper,kfac/2.4d0/,T0/300.0d0/ + double precision 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,esaxs,eliptran,ethetacnstr,ehomology_constr, + & edfadis,edfator,edfanei,edfabet + integer i,ii,ik,iproc,iscor,j,k,l,ib,nlist,ncon + double precision qfree,sumprob,eini,efree,rmsdev + character*80 bxname + character*2 licz1 + character*5 ctemper + integer ilen,ijk + external ilen + character*80 structure/'Structure'/ + real*4 Fdimless(maxconf), Fdimless_buf(maxconf) + double precision energia(0:max_ene), totfree_buf(0:maxconf), + & entfac_buf(maxconf) + double precision buffer(maxconf) + do i=1,ncon + list_conf(i)=i + enddo +c do i=1,ncon +c write (iout,*) i,list_conf(i) +c enddo +#ifdef MPI + write (iout,*) me," indstart",indstart(me)," indend",indend(me) + call daread_ccoords(indstart(me),indend(me)) +#endif +C write (iout,*) "ncon",ncon +C call flush(iout) + temper=1.0d0/(beta_h(ib)*1.987D-3) + 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 +c write (iout,*) 1.0d0/(beta_h(ib)*1.987D-3),ft +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 + +#ifdef MPI + do i=1,scount(me) + ii=i+indstart(me)-1 +#else + do i=1,ncon + ii=i +#endif +C write (iout,*) "i",i," ii",ii,"ib",ib,scount(me) +c call flush(iout) +c 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) +C write(iout,*) "coord",i,j,k,allcart(k,j,i),c(k,j), +C & c(k,j+nres),allcart(k,j+nres,i) + enddo + enddo +C write(iout,*) "out of j loop" +C call flush(iout) + do k=1,3 + c(k,nres+1)=c(k,1) + c(k,nres+nres)=c(k,nres) + enddo +C write(iout,*) "after nres+nres",nss_all(i) +C call flush(iout) + 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) + if (refstr) then + write (structure(9:),'(bz,i6.6)') i + call TMscore_sub(rmsdev,gdt_ts_tb(i), + & gdt_ha_tb(i),tmscore_tb(i),Structure,.false.) +#ifdef DEBUG + write (iout,*) rmsdev,gdt_ts_tb(i),gdt_ha_tb(i), + & tmscore_tb(i) +#endif + endif + totfree(i)=energia(0) + totfree_buf(i)=totfree(i) +c write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) +c write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) +c call pdbout(totfree(i),16,i) +c call flush(iout) +#ifdef DEBUG + write (iout,*) "conformation", i + call enerprint(energia(0),fT) +#endif + etot=energia(0) + Fdimless(i)=beta_h(ib)*etot+entfac(ii) + Fdimless_buf(i)=Fdimless(i) + totfree(i)=etot + totfree_buf(i)=totfree(i) +#ifdef DEBUG + write (iout,*) "fdim calc", i,ii,ib, + & 1.0d0/(1.987d-3*beta_h(ib)),totfree(i), + & entfac(ii),Fdimless(i) +#endif + enddo ! i + + do ijk=1,maxconf + entfac_buf(ijk)=entfac(ijk) + Fdimless_buf(ijk)=Fdimless(ijk) + enddo + do ijk=0,maxconf + totfree_buf(ijk)=totfree(ijk) + enddo + + +c scount_buf=scount(me) +c scount_buf2=scount(0) + +c entfac_buf(indstart(me)+1)=entfac(indstart(me)+1) + +#ifdef MPI +c WRITE (iout,*) "Wchodze do call MPI_Gatherv1 (Propabl)" + call MPI_Gatherv(Fdimless_buf(1),scount(me), + & MPI_REAL,Fdimless(1), + & scount(0),idispl(0),MPI_REAL,Master, + & MPI_COMM_WORLD, IERROR) +c WRITE (iout,*) "Wchodze do call MPI_Gatherv2 (Propabl)" + call MPI_Gatherv(totfree_buf(1),scount(me), + & MPI_DOUBLE_PRECISION,totfree(1), + & scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master, + & MPI_COMM_WORLD, IERROR) +c WRITE (iout,*) "Wchodze do call MPI_Gatherv3 (Propabl)" + call MPI_Gatherv(entfac_buf(indstart(me)+1),scount(me), + & MPI_DOUBLE_PRECISION,entfac(1), + & scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master, + & MPI_COMM_WORLD, IERROR) +c WRITE (iout,*) "Wychodze z call MPI_Gatherv (Propabl)" + if (refstr) then + do i=1,scount(me) + buffer(i)=gdt_ts_tb(i) + enddo + call MPI_Gatherv(buffer(1),scount(me),MPI_DOUBLE_PRECISION, + & gdt_ts_tb(1),scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master, + & MPI_COMM_WORLD,IERROR) + do i=1,scount(me) + buffer(i)=gdt_ha_tb(i) + enddo + call MPI_Gatherv(buffer(1),scount(me),MPI_DOUBLE_PRECISION, + & gdt_ha_tb(1),scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master, + & MPI_COMM_WORLD,IERROR) + do i=1,scount(me) + buffer(i)=tmscore_tb(i) + enddo + call MPI_Gatherv(buffer(1),scount(me),MPI_DOUBLE_PRECISION, + & tmscore_tb(1),scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master, + & MPI_COMM_WORLD,IERROR) + endif + if (me.eq.Master) then +c WRITE (iout,*) "me.eq.Master" +#endif +#ifdef DEBUG + write (iout,*) "The FDIMLESS array before sorting" + do i=1,ncon + write (iout,*) i,fdimless(i) + enddo +#endif +c WRITE (iout,*) "Wchodze do call mysort1" + call mysort1(ncon,Fdimless,list_conf) +c WRITE (iout,*) "Wychodze z call mysort1" +#ifdef DEBUG + write (iout,*) "The FDIMLESS array after sorting" + do i=1,ncon + write (iout,'(2i5,4f10.5)') i,list_conf(i),fdimless(i), + & gdt_ts_tb(i),gdt_ha_tb(i),tmscore_tb(i) + enddo +#endif +c WRITE (iout,*) "Wchodze do petli i=1,ncon totfree(i)=fdimless(i)" + do i=1,ncon + totfree(i)=fdimless(i) + enddo + qfree=0.0d0 + do i=1,ncon + qfree=qfree+exp(-fdimless(i)+fdimless(1)) +c write (iout,*) "fdimless", fdimless(i) + enddo +c write (iout,*) "qfree",qfree + 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 +c 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) +c do iproc=0,nprocs +c write (iout,*) "iproc",iproc," indstart",indstart(iproc), +c & " indend",indend(iproc) +c enddo + write (iout,*) "nlist",nlist +#endif + return + end +!-------------------------------------------------- + subroutine mysort1(n, x, ipermut) + implicit none + integer i,j,imax,ipm,n + real x(n) + integer ipermut(n) + real 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 diff --git a/source/cluster/wham/src-HCD/proc_proc.c b/source/cluster/wham/src-HCD/proc_proc.c new file mode 100644 index 0000000..f023520 --- /dev/null +++ b/source/cluster/wham/src-HCD/proc_proc.c @@ -0,0 +1,140 @@ +#include +#include +#include + +#ifdef CRAY +void PROC_PROC(long int *f, int *i) +#else +#ifdef LINUX +#ifdef PGI +void proc_proc_(long int *f, int *i) +#else +void proc_proc__(long int *f, int *i) +#endif +#endif +#ifdef SGI +void proc_proc_(long int *f, int *i) +#endif +#if defined(WIN) && !defined(WINIFL) +void _stdcall PROC_PROC(long int *f, int *i) +#endif +#ifdef WINIFL +void proc_proc(long int *f, int *i) +#endif +#if defined(AIX) || defined(WINPGI) +void proc_proc(long int *f, int *i) +#endif +#endif + +{ +static long int NaNQ; +static long int NaNQm; + +if(*i==-1) + { + NaNQ=*f; + NaNQm=0xffffffff; + return; + } +*i=0; +if(*f==NaNQ) + *i=1; +if(*f==NaNQm) + *i=1; +} + +#ifdef CRAY +void PROC_CONV(char *buf, int *i, int n) +#endif +#ifdef LINUX +void proc_conv__(char *buf, int *i, int n) +#endif +#ifdef SGI +void proc_conv_(char *buf, int *i, int n) +#endif +#if defined(AIX) || defined(WINPGI) +void proc_conv(char *buf, int *i, int n) +#endif +#ifdef WIN +void _stdcall PROC_CONV(char *buf, int *i, int n) +#endif +{ +int j; + +sscanf(buf,"%d",&j); +*i=j; +return; +} + +#ifdef CRAY +void PROC_CONV_R(char *buf, int *i, int n) +#endif +#ifdef LINUX +void proc_conv_r__(char *buf, int *i, int n) +#endif +#ifdef SGI +void proc_conv_r_(char *buf, int *i, int n) +#endif +#if defined(AIX) || defined(WINPGI) +void proc_conv_r(char *buf, int *i, int n) +#endif +#ifdef WIN +void _stdcall PROC_CONV_R(char *buf, int *i, int n) +#endif + +{ + +/* sprintf(buf,"%d",*i); */ + +return; +} + + +#ifndef IMSL +#ifdef CRAY +void DSVRGP(int *n, double *tab1, double *tab2, int *itab) +#endif +#ifdef LINUX +void dsvrgp__(int *n, double *tab1, double *tab2, int *itab) +#endif +#ifdef SGI +void dsvrgp_(int *n, double *tab1, double *tab2, int *itab) +#endif +#if defined(AIX) || defined(WINPGI) +void dsvrgp(int *n, double *tab1, double *tab2, int *itab) +#endif +#ifdef WIN +void _stdcall DSVRGP(int *n, double *tab1, double *tab2, int *itab) +#endif +{ +double t; +int i,j,k; + +if(tab1 != tab2) + { + for(i=0; i<*n; i++) + tab2[i]=tab1[i]; + } +k=0; +while(k<*n-1) + { + j=k; + t=tab2[k]; + for(i=k+1; i<*n; i++) + if(t>tab2[i]) + { + j=i; + t=tab2[i]; + } + if(j!=k) + { + tab2[j]=tab2[k]; + tab2[k]=t; + i=itab[j]; + itab[j]=itab[k]; + itab[k]=i; + } + k++; + } +} +#endif diff --git a/source/cluster/wham/src-HCD/read_constr_homology.F b/source/cluster/wham/src-HCD/read_constr_homology.F new file mode 100644 index 0000000..cac0d06 --- /dev/null +++ b/source/cluster/wham/src-HCD/read_constr_homology.F @@ -0,0 +1,717 @@ + subroutine read_constr_homology + + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.HOMRESTR' + include 'COMMON.HOMOLOGY' +c +c For new homol impl +c + include 'COMMON.VAR' +c include 'include_unres/COMMON.VAR' +c + +c double precision odl_temp,sigma_odl_temp,waga_theta,waga_d, +c & dist_cut +c common /przechowalnia/ odl_temp(maxres,maxres,max_template), +c & sigma_odl_temp(maxres,maxres,max_template) + character*2 kic2 + character*24 model_ki_dist, model_ki_angle + character*500 controlcard + integer ki, i, j, k, l, ii_in_use(maxdim),i_tmp,idomain_tmp + integer idomain(max_template,maxres) + logical lprn /.true./ + integer ilen + external ilen + logical liiflag +c +c FP - Nov. 2014 Temporary specifications for new vars +c + double precision rescore_tmp,x12,y12,z12,rescore2_tmp + & rescore3_tmp + double precision, dimension (max_template,maxres) :: rescore + double precision, dimension (max_template,maxres) :: rescore2 + double precision, dimension (max_template,maxres) :: rescore3 + character*24 tpl_k_rescore +c ----------------------------------------------------------------- +c Reading multiple PDB ref structures and calculation of retraints +c not using pre-computed ones stored in files model_ki_{dist,angle} +c FP (Nov., 2014) +c ----------------------------------------------------------------- +c +c +c Alternative: reading from input + call card_concat(controlcard) + call reada(controlcard,"HOMOL_DIST",waga_dist,1.0d0) + call reada(controlcard,"HOMOL_ANGLE",waga_angle,1.0d0) + call reada(controlcard,"HOMOL_THETA",waga_theta,1.0d0) ! new + call reada(controlcard,"HOMOL_SCD",waga_d,1.0d0) ! new + call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) ! for diff ways of calc sigma + call reada(controlcard,'DIST2_CUT',dist2_cut,9999.0d0) + call readi(controlcard,"HOMOL_NSET",homol_nset,1) + read2sigma=(index(controlcard,'READ2SIGMA').gt.0) + call readi(controlcard,"IHSET",ihset,1) + write (iout,*) "homol_nset ",homol_nset + if (homol_nset.gt.1)then + call card_concat(controlcard) + read(controlcard,*) (waga_homology(i),i=1,homol_nset) +c if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then +c write(iout,*) "iset homology_weight " +c do i=1,homol_nset +c write(iout,*) i,waga_homology(i) +c enddo +c endif + iset=mod(kolor,homol_nset)+1 + else + iset=1 + waga_homology(1)=1.0 + endif +c write(iout,*) "waga_homology(",iset,")",waga_homology(iset) + +cd write (iout,*) "nnt",nnt," nct",nct +cd call flush(iout) + + + lim_odl=0 + lim_dih=0 +c +c New +c + lim_theta=0 + lim_xx=0 +c +c Reading HM global scores (prob not required) +c + do i = nnt,nct + do k=1,constr_homology + idomain(k,i)=0 + enddo + enddo +c open (4,file="HMscore") +c do k=1,constr_homology +c read (4,*,end=521) hmscore_tmp +c hmscore(k)=hmscore_tmp ! Another transformation can be used +c write(*,*) "Model", k, ":", hmscore(k) +c enddo +c521 continue + + ii=0 + do i = nnt,nct-2 + do j=i+2,nct + ii=ii+1 + ii_in_use(ii)=0 + enddo + enddo +c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d + + if (read_homol_frag) then + call read_klapaucjusz + else + + do k=1,constr_homology + + read(inp,'(a)') pdbfile +c Next stament causes error upon compilation (?) +c if(me.eq.king.or. .not. out1file) +c write (iout,'(2a)') 'PDB data will be read from file ', +c & pdbfile(:ilen(pdbfile)) + write (iout,'(a,5x,a)') 'HOMOL: Opening PDB file', + & pdbfile(:ilen(pdbfile)) + open(ipdbin,file=pdbfile,status='old',err=33) + goto 34 + 33 write (iout,'(a,5x,a)') 'Error opening PDB file', + & pdbfile(:ilen(pdbfile)) + stop + 34 continue +c print *,'Begin reading pdb data' +c +c Files containing res sim or local scores (former containing sigmas) +c + + write(kic2,'(bz,i2.2)') k + + tpl_k_rescore="template"//kic2//".sco" + + unres_pdb=.false. + if (read2sigma) then + call readpdb_template(k) + else + call readpdb(out_template_coord) + endif + +c call readpdb + do i=1,2*nres + do j=1,3 + crefjlee(j,i)=c(j,i) + enddo + enddo +#ifdef DEBUG + do i=1,nres + write (iout,'(i5,3f8.3,5x,3f8.3)') i,(crefjlee(j,i),j=1,3), + & (crefjlee(j,i+nres),j=1,3) + enddo + write (iout,*) "read_constr_homology: after reading pdb file" + call flush(iout) +#endif + +c +c Distance restraints +c +c ... --> odl(k,ii) +C Copy the coordinates from reference coordinates (?) + do i=1,2*nres + do j=1,3 + c(j,i)=cref(j,i) +c write (iout,*) "c(",j,i,") =",c(j,i) + enddo + enddo +c +c From read_dist_constr (commented out 25/11/2014 <-> res sim) +c +c write(iout,*) "tpl_k_rescore - ",tpl_k_rescore + open (ientin,file=tpl_k_rescore,status='old') + if (nnt.gt.1) rescore(k,1)=0.0d0 + do irec=nnt,nct ! loop for reading res sim + if (read2sigma) then + read (ientin,*,end=1401) i_tmp,rescore2_tmp,rescore_tmp, + & rescore3_tmp,idomain_tmp + i_tmp=i_tmp+nnt-1 + idomain(k,i_tmp)=idomain_tmp + rescore(k,i_tmp)=rescore_tmp + rescore2(k,i_tmp)=rescore2_tmp + rescore3(k,i_tmp)=rescore3_tmp + write(iout,'(a7,i5,3f10.5,i5)') "rescore", + & i_tmp,rescore2_tmp,rescore_tmp, + & rescore3_tmp,idomain_tmp + else + idomain(k,irec)=1 + read (ientin,*,end=1401) rescore_tmp + +c rescore(k,irec)=rescore_tmp+1.0d0 ! to avoid 0 values + rescore(k,irec)=0.5d0*(rescore_tmp+0.5d0) ! alt transf to reduce scores +c write(iout,*) "rescore(",k,irec,") =",rescore(k,irec) + endif + enddo + 1401 continue + close (ientin) + if (waga_dist.ne.0.0d0) then + ii=0 + do i = nnt,nct-2 + do j=i+2,nct + + x12=c(1,i)-c(1,j) + y12=c(2,i)-c(2,j) + z12=c(3,i)-c(3,j) + distal=dsqrt(x12*x12+y12*y12+z12*z12) +c write (iout,*) k,i,j,distal,dist2_cut + + if (idomain(k,i).eq.idomain(k,j).and.idomain(k,i).ne.0 + & .and. distal.le.dist2_cut ) then + + ii=ii+1 + ii_in_use(ii)=1 + l_homo(k,ii)=.true. + +c write (iout,*) "k",k +c write (iout,*) "i",i," j",j," constr_homology", +c & constr_homology + ires_homo(ii)=i + jres_homo(ii)=j + odl(k,ii)=distal + if (read2sigma) then + sigma_odl(k,ii)=0 + do ik=i,j + sigma_odl(k,ii)=sigma_odl(k,ii)+rescore2(k,ik) + enddo + sigma_odl(k,ii)=sigma_odl(k,ii)/(j-i+1) + if (odl(k,ii).gt.dist_cut) sigma_odl(k,ii) = + & sigma_odl(k,ii)*dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0) + else + if (odl(k,ii).le.dist_cut) then + sigma_odl(k,ii)=rescore(k,i)+rescore(k,j) + else +#ifdef OLDSIGMA + sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))* + & dexp(0.5d0*(odl(k,ii)/dist_cut)**2) +#else + sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))* + & dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0) +#endif + endif + endif + sigma_odl(k,ii)=1.0d0/(sigma_odl(k,ii)*sigma_odl(k,ii)) + else + ii=ii+1 + l_homo(k,ii)=.false. + endif + enddo + enddo + lim_odl=ii + endif +c +c Theta, dihedral and SC retraints +c + if (waga_angle.gt.0.0d0) then +c open (ientin,file=tpl_k_sigma_dih,status='old') +c do irec=1,maxres-3 ! loop for reading sigma_dih +c read (ientin,*,end=1402) i,j,ki,l,sigma_dih(k,i+nnt-1) ! j,ki,l what for? +c if (i+nnt-1.gt.lim_dih) lim_dih=i+nnt-1 ! right? +c sigma_dih(k,i+nnt-1)=sigma_dih(k,i+nnt-1)* ! not inverse because of use of res. similarity +c & sigma_dih(k,i+nnt-1) +c enddo +c1402 continue +c close (ientin) + do i = nnt+3,nct + if (idomain(k,i).eq.0) then + sigma_dih(k,i)=0.0 + cycle + endif + dih(k,i)=phiref(i) ! right? +c read (ientin,*) sigma_dih(k,i) ! original variant +c write (iout,*) "dih(",k,i,") =",dih(k,i) +c write(iout,*) "rescore(",k,i,") =",rescore(k,i), +c & "rescore(",k,i-1,") =",rescore(k,i-1), +c & "rescore(",k,i-2,") =",rescore(k,i-2), +c & "rescore(",k,i-3,") =",rescore(k,i-3) + + sigma_dih(k,i)=(rescore(k,i)+rescore(k,i-1)+ + & rescore(k,i-2)+rescore(k,i-3))/4.0 +c if (read2sigma) sigma_dih(k,i)=sigma_dih(k,i)/4.0 +c write (iout,*) "Raw sigmas for dihedral angle restraints" +c write (iout,'(i5,10(2f8.2,4x))') i,sigma_dih(k,i) +c sigma_dih(k,i)=hmscore(k)*rescore(k,i)*rescore(k,i-1)* +c rescore(k,i-2)*rescore(k,i-3) ! right expression ? +c Instead of res sim other local measure of b/b str reliability possible + if (sigma_dih(k,i).ne.0) + & sigma_dih(k,i)=1.0d0/(sigma_dih(k,i)*sigma_dih(k,i)) +c sigma_dih(k,i)=sigma_dih(k,i)*sigma_dih(k,i) + enddo + lim_dih=nct-nnt-2 + endif + + if (waga_theta.gt.0.0d0) then +c open (ientin,file=tpl_k_sigma_theta,status='old') +c do irec=1,maxres-2 ! loop for reading sigma_theta, right bounds? +c read (ientin,*,end=1403) i,j,ki,sigma_theta(k,i+nnt-1) ! j,ki what for? +c sigma_theta(k,i+nnt-1)=sigma_theta(k,i+nnt-1)* ! not inverse because of use of res. similarity +c & sigma_theta(k,i+nnt-1) +c enddo +c1403 continue +c close (ientin) + + do i = nnt+2,nct ! right? without parallel. +c do i = i=1,nres ! alternative for bounds acc to readpdb? +c do i=ithet_start,ithet_end ! with FG parallel. + if (idomain(k,i).eq.0) then + sigma_theta(k,i)=0.0 + cycle + endif + thetatpl(k,i)=thetaref(i) +c write (iout,*) "thetatpl(",k,i,") =",thetatpl(k,i) +c write(iout,*) "rescore(",k,i,") =",rescore(k,i), +c & "rescore(",k,i-1,") =",rescore(k,i-1), +c & "rescore(",k,i-2,") =",rescore(k,i-2) +c read (ientin,*) sigma_theta(k,i) ! 1st variant + sigma_theta(k,i)=(rescore(k,i)+rescore(k,i-1)+ + & rescore(k,i-2))/3.0 +c if (read2sigma) sigma_theta(k,i)=sigma_theta(k,i)/3.0 + if (sigma_theta(k,i).ne.0) + & sigma_theta(k,i)=1.0d0/(sigma_theta(k,i)*sigma_theta(k,i)) + +c sigma_theta(k,i)=hmscore(k)*rescore(k,i)*rescore(k,i-1)* +c rescore(k,i-2) ! right expression ? +c sigma_theta(k,i)=sigma_theta(k,i)*sigma_theta(k,i) + enddo + endif + + if (waga_d.gt.0.0d0) then +c open (ientin,file=tpl_k_sigma_d,status='old') +c do irec=1,maxres-1 ! loop for reading sigma_theta, right bounds? +c read (ientin,*,end=1404) i,j,sigma_d(k,i+nnt-1) ! j,ki what for? +c sigma_d(k,i+nnt-1)=sigma_d(k,i+nnt-1)* ! not inverse because of use of res. similarity +c & sigma_d(k,i+nnt-1) +c enddo +c1404 continue + + do i = nnt,nct ! right? without parallel. +c do i=2,nres-1 ! alternative for bounds acc to readpdb? +c do i=loc_start,loc_end ! with FG parallel. + if (itype(i).eq.10) cycle + if (idomain(k,i).eq.0 ) then + sigma_d(k,i)=0.0 + cycle + endif + xxtpl(k,i)=xxref(i) + yytpl(k,i)=yyref(i) + zztpl(k,i)=zzref(i) +c write (iout,*) "xxtpl(",k,i,") =",xxtpl(k,i) +c write (iout,*) "yytpl(",k,i,") =",yytpl(k,i) +c write (iout,*) "zztpl(",k,i,") =",zztpl(k,i) +c write(iout,*) "rescore(",k,i,") =",rescore(k,i) +c sigma_d(k,i)=rescore(k,i) ! right expression ? + sigma_d(k,i)=rescore3(k,i) ! right expression ? + if (sigma_d(k,i).ne.0) + & sigma_d(k,i)=1.0d0/(sigma_d(k,i)*sigma_d(k,i)) + +c sigma_d(k,i)=hmscore(k)*rescore(k,i) ! right expression ? +c sigma_d(k,i)=sigma_d(k,i)*sigma_d(k,i) +c read (ientin,*) sigma_d(k,i) ! 1st variant + enddo + endif + enddo +c +c remove distance restraints not used in any model from the list +c shift data in all arrays +c + if (waga_dist.ne.0.0d0) then + ii=0 + liiflag=.true. + do i=nnt,nct-2 + do j=i+2,nct + ii=ii+1 + if (ii_in_use(ii).eq.0.and.liiflag) then + liiflag=.false. + iistart=ii + endif + if (ii_in_use(ii).ne.0.and..not.liiflag.or. + & .not.liiflag.and.ii.eq.lim_odl) then + if (ii.eq.lim_odl) then + iishift=ii-iistart+1 + else + iishift=ii-iistart + endif + liiflag=.true. + do ki=iistart,lim_odl-iishift + ires_homo(ki)=ires_homo(ki+iishift) + jres_homo(ki)=jres_homo(ki+iishift) + ii_in_use(ki)=ii_in_use(ki+iishift) + do k=1,constr_homology + odl(k,ki)=odl(k,ki+iishift) + sigma_odl(k,ki)=sigma_odl(k,ki+iishift) + l_homo(k,ki)=l_homo(k,ki+iishift) + enddo + enddo + ii=ii-iishift + lim_odl=lim_odl-iishift + endif + enddo + enddo + endif + + endif ! .not. klapaucjusz + + if (constr_homology.gt.0) call homology_partition + if (constr_homology.gt.0) call init_int_table +cd write (iout,*) "homology_partition: lim_theta= ",lim_theta, +cd & "lim_xx=",lim_xx +c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end +c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end +c +c Print restraints +c + if (.not.lprn) return +cd write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d +c if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then + write (iout,*) "Distance restraints from templates" + do ii=1,lim_odl + write(iout,'(3i5,100(2f8.2,1x,l1,4x))') + & ii,ires_homo(ii),jres_homo(ii), + & (odl(ki,ii),1.0d0/dsqrt(sigma_odl(ki,ii)),l_homo(ki,ii), + & ki=1,constr_homology) + enddo + write (iout,*) "Dihedral angle restraints from templates" + do i=nnt+3,nct + write (iout,'(i5,a4,100(2f8.2,4x))') i,restyp(itype(i)), + & (rad2deg*dih(ki,i), + & rad2deg/dsqrt(sigma_dih(ki,i)),ki=1,constr_homology) + enddo + write (iout,*) "Virtual-bond angle restraints from templates" + do i=nnt+2,nct + write (iout,'(i5,a4,100(2f8.2,4x))') i,restyp(itype(i)), + & (rad2deg*thetatpl(ki,i), + & rad2deg/dsqrt(sigma_theta(ki,i)),ki=1,constr_homology) + enddo + write (iout,*) "SC restraints from templates" + do i=nnt,nct + write(iout,'(i5,100(4f8.2,4x))') i, + & (xxtpl(ki,i),yytpl(ki,i),zztpl(ki,i), + & 1.0d0/dsqrt(sigma_d(ki,i)),ki=1,constr_homology) + enddo +c endif +c ----------------------------------------------------------------- + return + end +c---------------------------------------------------------------------- + subroutine read_klapaucjusz + + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.HOMOLOGY' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.HOMRESTR' + character*256 fragfile + integer ninclust(maxclust),inclust(max_template,maxclust), + & nresclust(maxclust),iresclust(maxres,maxclust) + + character*2 kic2 + character*24 model_ki_dist, model_ki_angle + character*500 controlcard + integer ki, i, j, k, l, ii_in_use(maxdim),i_tmp,idomain_tmp + integer idomain(max_template,maxres) + logical lprn /.true./ + integer ilen + external ilen + logical liiflag +c +c + double precision rescore_tmp,x12,y12,z12,rescore2_tmp + double precision, dimension (max_template,maxres) :: rescore + double precision, dimension (max_template,maxres) :: rescore2 + character*24 tpl_k_rescore + +c +c For new homol impl +c + include 'COMMON.VAR' +c + call getenv("FRAGFILE",fragfile) + write (iout,*) "read_klapaucjusz ",fragfile + open(ientin,file=fragfile,status="old",err=10) + read(ientin,*) constr_homology,nclust + l_homo = .false. + sigma_theta=0.0 + sigma_d=0.0 + sigma_dih=0.0 +c Read pdb files + do k=1,constr_homology + read(ientin,'(a)') pdbfile + write (iout,'(a,5x,a)') 'KLAPAUCJUSZ: Opening PDB file', + & pdbfile(:ilen(pdbfile)) + open(ipdbin,file=pdbfile,status='old',err=33) + goto 34 + 33 write (iout,'(a,5x,a)') 'Error opening PDB file', + & pdbfile(:ilen(pdbfile)) + stop + 34 continue + unres_pdb=.false. + call readpdb_template(k) +c do i=1,2*nres +c do j=1,3 +c chomo(j,i,k)=c(j,i) +c enddo +c enddo + do i=1,nres + rescore(k,i)=0.2d0 + rescore2(k,i)=1.0d0 + enddo + enddo +c Read clusters + do i=1,nclust + read(ientin,*) ninclust(i),nresclust(i) + read(ientin,*) (inclust(k,i),k=1,ninclust(i)) + read(ientin,*) (iresclust(k,i),k=1,nresclust(i)) + enddo +c +c Loop over clusters +c + do l=1,nclust + do ll = 1,ninclust(l) + + k = inclust(ll,l) + do i=1,nres + idomain(k,i)=0 + enddo + do i=1,nresclust(l) + if (nnt.gt.1) then + idomain(k,iresclust(i,l)+1) = 1 + else + idomain(k,iresclust(i,l)) = 1 + endif + enddo +c +c Distance restraints +c +c ... --> odl(k,ii) +C Copy the coordinates from reference coordinates (?) + do i=1,2*nres + do j=1,3 + c(j,i)=chomo(j,i,k) +c write (iout,*) "c(",j,i,") =",c(j,i) + enddo + enddo + call int_from_cart(.true.,.false.) + call sc_loc_geom(.false.) + do i=1,nres + thetaref(i)=theta(i) + phiref(i)=phi(i) + enddo + if (waga_dist.ne.0.0d0) then + ii=0 + do i = nnt,nct-2 + do j=i+2,nct + + x12=c(1,i)-c(1,j) + y12=c(2,i)-c(2,j) + z12=c(3,i)-c(3,j) + distal=dsqrt(x12*x12+y12*y12+z12*z12) +c write (iout,*) k,i,j,distal,dist2_cut + + if (idomain(k,i).eq.idomain(k,j).and.idomain(k,i).ne.0 + & .and. distal.le.dist2_cut ) then + + ii=ii+1 + ii_in_use(ii)=1 + l_homo(k,ii)=.true. + +c write (iout,*) "k",k +c write (iout,*) "i",i," j",j," constr_homology", +c & constr_homology + ires_homo(ii)=i + jres_homo(ii)=j + odl(k,ii)=distal + if (read2sigma) then + sigma_odl(k,ii)=0 + do ik=i,j + sigma_odl(k,ii)=sigma_odl(k,ii)+rescore2(k,ik) + enddo + sigma_odl(k,ii)=sigma_odl(k,ii)/(j-i+1) + if (odl(k,ii).gt.dist_cut) sigma_odl(k,ii) = + & sigma_odl(k,ii)*dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0) + else + if (odl(k,ii).le.dist_cut) then + sigma_odl(k,ii)=rescore(k,i)+rescore(k,j) + else +#ifdef OLDSIGMA + sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))* + & dexp(0.5d0*(odl(k,ii)/dist_cut)**2) +#else + sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))* + & dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0) +#endif + endif + endif + sigma_odl(k,ii)=1.0d0/(sigma_odl(k,ii)*sigma_odl(k,ii)) + else + ii=ii+1 +c l_homo(k,ii)=.false. + endif + enddo + enddo + lim_odl=ii + endif +c +c Theta, dihedral and SC retraints +c + if (waga_angle.gt.0.0d0) then + do i = nnt+3,nct + if (idomain(k,i).eq.0) then +c sigma_dih(k,i)=0.0 + cycle + endif + dih(k,i)=phiref(i) + sigma_dih(k,i)=(rescore(k,i)+rescore(k,i-1)+ + & rescore(k,i-2)+rescore(k,i-3))/4.0 +c write (iout,*) "k",k," l",l," i",i," rescore",rescore(k,i), +c & " sigma_dihed",sigma_dih(k,i) + if (sigma_dih(k,i).ne.0) + & sigma_dih(k,i)=1.0d0/(sigma_dih(k,i)*sigma_dih(k,i)) + enddo + lim_dih=nct-nnt-2 + endif + + if (waga_theta.gt.0.0d0) then + do i = nnt+2,nct + if (idomain(k,i).eq.0) then +c sigma_theta(k,i)=0.0 + cycle + endif + thetatpl(k,i)=thetaref(i) + sigma_theta(k,i)=(rescore(k,i)+rescore(k,i-1)+ + & rescore(k,i-2))/3.0 + if (sigma_theta(k,i).ne.0) + & sigma_theta(k,i)=1.0d0/(sigma_theta(k,i)*sigma_theta(k,i)) + enddo + endif + + if (waga_d.gt.0.0d0) then + do i = nnt,nct + if (itype(i).eq.10) cycle + if (idomain(k,i).eq.0 ) then +c sigma_d(k,i)=0.0 + cycle + endif + xxtpl(k,i)=xxref(i) + yytpl(k,i)=yyref(i) + zztpl(k,i)=zzref(i) + sigma_d(k,i)=rescore(k,i) + if (sigma_d(k,i).ne.0) + & sigma_d(k,i)=1.0d0/(sigma_d(k,i)*sigma_d(k,i)) + if (i-nnt+1.gt.lim_xx) lim_xx=i-nnt+1 + enddo + endif + enddo ! l + enddo ! ll +c +c remove distance restraints not used in any model from the list +c shift data in all arrays +c + if (waga_dist.ne.0.0d0) then + ii=0 + liiflag=.true. + do i=nnt,nct-2 + do j=i+2,nct + ii=ii+1 + if (ii_in_use(ii).eq.0.and.liiflag) then + liiflag=.false. + iistart=ii + endif + if (ii_in_use(ii).ne.0.and..not.liiflag.or. + & .not.liiflag.and.ii.eq.lim_odl) then + if (ii.eq.lim_odl) then + iishift=ii-iistart+1 + else + iishift=ii-iistart + endif + liiflag=.true. + do ki=iistart,lim_odl-iishift + ires_homo(ki)=ires_homo(ki+iishift) + jres_homo(ki)=jres_homo(ki+iishift) + ii_in_use(ki)=ii_in_use(ki+iishift) + do k=1,constr_homology + odl(k,ki)=odl(k,ki+iishift) + sigma_odl(k,ki)=sigma_odl(k,ki+iishift) + l_homo(k,ki)=l_homo(k,ki+iishift) + enddo + enddo + ii=ii-iishift + lim_odl=lim_odl-iishift + endif + enddo + enddo + endif +#ifdef DEBUG + write (iout,*) "ires_homo and jres_homo arrays, lim_odl",lim_odl + do i=1,lim_odl + write (iout,*) i,ires_homo(i),jres_homo(i) + enddo +#endif + return + 10 stop "Error in fragment file" + end diff --git a/source/cluster/wham/src-HCD/read_coords.F b/source/cluster/wham/src-HCD/read_coords.F new file mode 100644 index 0000000..facbc27 --- /dev/null +++ b/source/cluster/wham/src-HCD/read_coords.F @@ -0,0 +1,763 @@ + subroutine read_coords(ncon,*) + 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.CONTROL" + include "COMMON.CHAIN" + include "COMMON.INTERACT" + include "COMMON.IOUNITS" + include "COMMON.VAR" + include "COMMON.SBRIDGE" + include "COMMON.GEO" + include "COMMON.CLUSTER" + character*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*4 prec,reini,refree,rmsdev + integer nrec,nlines,iscor,lenrec,lenrec_in + double precision energ,t_acq,tcpu + integer ilen,iroof + external ilen,iroof + double precision rjunk + integer ntot_all(0:maxprocs-1) + logical lerr + double precision energia(0:max_ene),etot + real*4 csingle(3,maxres2+2) + integer Previous,Next + character*256 bprotfiles +c 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 +c Set the scratchfile names + write (liczba,'(bz,i3.3)') me +#endif +c 1/27/05 AL Change stored coordinates to single precision and don't store +c 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" + +#ifdef CHUJ + ICON=1 + 123 continue + if (from_cart .and. .not. from_bx .and. .not. from_cx) then + if (lefree) 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 (lefree) 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 +cold 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 +C +C CALCULATE DISTANCES +C + 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) +c Read conformations from binary DA files (one per batch) and write them to +c a binary DA scratchfile. + jj=0 + jjj=0 +#ifdef MPI + write (liczba,'(bz,i3.3)') me + IF (ME.EQ.MASTER) THEN +c Only the master reads the database; it'll send it to the other procs +c 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 + +C#define DEBUG +#ifdef DEBUG + write (iout,*) "Opening file ",intinname(:ilen(intinname)) + write (iout,*) "lenrec",lenrec_in + call flush(iout) +#endif +C#undef DEBUG +c write (iout,*) "maxconf",maxconf + i=0 + do while (.true.) + i=i+1 + if (i.gt.maxconf) then + write (iout,*) "Error: too many conformations ", + & "(",maxconf,") maximum." +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,errcode,ierror) +#endif + stop + endif +c write (iout,*) "i",i +c 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 + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j), iret) + call xdrfint(ixdrf, jdssb(j), iret) + idssb(j)=idssb(j)-nres + jdssb(j)=jdssb(j)-nres + else + call xdrfint_(ixdrf, ihpb(j), iret) + if (iret.eq.0) goto 101 + call xdrfint_(ixdrf, jhpb(j), iret) + if (iret.eq.0) goto 101 + endif + 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 +c write (iout,*) "calling xdrf3dfcoord" + call xdrf3dfcoord(ixdrf, csingle, itmp, prec, iret) +c write (iout,*) "iret",iret +c call flush(iout) + if (iret.eq.0) goto 101 + call xdrfint(ixdrf, nss, iret) +c write (iout,*) "iret",iret +c write (iout,*) "nss",nss + call flush(iout) + if (iret.eq.0) goto 101 + do k=1,nss + if (dyn_ss) then + call xdrfint(ixdrf, idssb(k), iret) + call xdrfint(ixdrf, jdssb(k), iret) + else + call xdrfint(ixdrf, ihpb(k), iret) + if (iret.eq.0) goto 101 + call xdrfint(ixdrf, jhpb(k), iret) + if (iret.eq.0) goto 101 + endif + 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 +#ifdef DEBUG + write (iout,*) "jj",jj+1," energy",energy(jj+1), + & " entfac",entfac(jj+1)," rmsd",rmstb(jj+1) +#endif + 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 +C#define DEBUG +#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 +C#undef DEBUG + 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 +c 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 +c close(icbase) + close(intin) + + write(iout,*)"A total of",ncon," conformations read." + +#ifdef MPI +c 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) + return1 + endif + return +#endif + 1111 write(iout,*) "Error opening coordinate file ", + & intinname(:ilen(intinname)) + call flush(iout) + return1 + end +c------------------------------------------------------------------------------ + subroutine add_new_cconf(jjj,jj,jj_old,icount,Next) + 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 + double precision 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) + & .and.(itype(j).ne.ntyp1)) 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 + & .and. itype(j).ne.ntyp1) 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) +c & 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 +c------------------------------------------------------------------------------ + subroutine store_cconf_from_file(jj,icount) + 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 +c 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 +c------------------------------------------------------------------------------ + subroutine write_and_send_cconf(icount,jj_old,jj,Next) + implicit none + include "DIMENSIONS" + include "sizesclu.dat" +#ifdef MPI + 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 +c Write the structures to a scratch file +#ifdef MPI +c 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*maxres2, + & MPI_REAL,Next,580,MPI_COMM_WORLD,IERROR) +#endif + call dawrite_ccoords(jj_old,jj,icbase) +#ifdef DEBUG + write (iout,*) "Processor",me," exit WRITE_AND_SEND_CONF" + call flush(iout) +#endif + return + end +c------------------------------------------------------------------------------ +#ifdef MPI + subroutine receive_and_pass_cconf(icount,jj_old,jj,Previous, + & Next) + 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,l,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*maxres2, + & MPI_REAL,Previous,580,MPI_COMM_WORLD,STATUS,IERROR) + call MPI_Send(allcart(1,1,1),3*icount*maxres2, + & 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 +#endif +c------------------------------------------------------------------------------ + subroutine daread_ccoords(istart_conf,iend_conf) + implicit none + include "DIMENSIONS" + include "sizesclu.dat" +#ifdef MPI + 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*16 form,acc + character*80 nam +c +c Read conformations off a DA scratchfile. +c +C#define DEBUG +#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 + if (dyn_ss) then + 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), +c & nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss), + & entfac(ii),rmstb(ii) + else + 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) + endif +#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 +C#undef DEBUG + enddo +c write (iout,*) "just before leave" + call flush(iout) + return + end +c------------------------------------------------------------------------------ + subroutine dawrite_ccoords(istart_conf,iend_conf,unit_out) + implicit none + include "DIMENSIONS" + include "sizesclu.dat" +#ifdef MPI + 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*16 form,acc + character*32 nam +c +c Write conformations to a DA scratchfile. +c +#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 + if (dyn_ss) then + 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), +c & nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss_all(ij)) + & entfac(ii),rmstb(ii) + else + 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) + endif +#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 diff --git a/source/cluster/wham/src-HCD/read_ref_str.F b/source/cluster/wham/src-HCD/read_ref_str.F new file mode 100644 index 0000000..5a50119 --- /dev/null +++ b/source/cluster/wham/src-HCD/read_ref_str.F @@ -0,0 +1,159 @@ + subroutine read_ref_structure(*) +C +C Read the reference structure from the PDB file or from a PDB file or in the form of the dihedral +C angles. +C + implicit none + include 'DIMENSIONS' + include 'sizesclu.dat' + 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.TIME1' + character*4 sequence(maxres) + integer rescode + double precision x(maxvar) + integer itype_pdb(maxres) + logical seq_comp + integer i,j,k,nres_pdb,iaux + double precision ddsc,dist + integer ilen + external ilen +C + nres0=nres +c 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.' + return1 + 34 continue + do i=1,nres + itype_pdb(i)=itype(i) + enddo + call readpdb(.true.) + do i=1,2*nres + do j=1,3 + cref_pdb(j,i)=c(j,i) + enddo + enddo + do i=1,nres + iaux=itype_pdb(i) + itype_pdb(i)=itype(i) + itype(i)=iaux + enddo + close (ipdbin) + 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_pdb(k,nres+j+i)=cref_pdb(k,nres_pdb+j) + enddo + enddo + do j=nnt+nsup-1,nnt,-1 + do k=1,3 + cref_pdb(k,j+i)=cref_pdb(k,j) + 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_pdb(k,j),k=1,3),(cref_pdb(k,j+nres),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.' + return1 + 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,'(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.' + return1 + 39 call chainbuild + nstart_sup=nnt + nstart_seq=nnt + nsup=nct-nnt+1 + do i=1,2*nres + do j=1,3 + cref_pdb(j,i)=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_pdb(j,i) + enddo + enddo + do i=1,nres + do j=1,3 + dc(j,nres+i)=cref_pdb(j,nres+i)-cref_pdb(j,i) + 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 +c write (iout,*) "i",i," dc_norm",(dc_norm(k,nres+i),k=1,3), +c " norm",dc_norm(1,nres+i)**2+dc_norm(2,nres+i)**2+ +c 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 + 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 diff --git a/source/cluster/wham/src-HCD/readpdb.F b/source/cluster/wham/src-HCD/readpdb.F new file mode 100644 index 0000000..dc6aa0a --- /dev/null +++ b/source/cluster/wham/src-HCD/readpdb.F @@ -0,0 +1,751 @@ + subroutine readpdb(lprint) +C Read the PDB file and convert the peptide geometry into virtual-chain +C geometry. + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.SBRIDGE' + character*3 seq,atom,res + character*80 card + double precision sccor(3,50) + integer i,j,iii,ibeg,ishift,ishift1,ity,ires,ires_old + double precision dcj + integer rescode,kkk,lll,icha,cou,kupa,iprzes + logical lprint + ibeg=1 + ishift1=0 + do + read (ipdbin,'(a80)',end=10) card + if (card(:3).eq.'END') then + goto 10 + else if (card(:3).eq.'TER') then +C End current chain +c ires_old=ires+1 + ires_old=ires+2 + itype(ires_old-1)=ntyp1 + itype(ires_old)=ntyp1 + ibeg=2 +c write (iout,*) "Chain ended",ires,ishift,ires_old + call sccenter(ires,iii,sccor) + endif +C Fish out the ATOM cards. + if (index(card(1:4),'ATOM').gt.0) then + read (card(14:16),'(a3)') atom + if (atom.eq.'CA' .or. atom.eq.'CH3') then +C Calculate the CM of the preceding residue. + if (ibeg.eq.0) then + call sccenter(ires,iii,sccor) + endif +C Start new residue. +c write (iout,'(a80)') card + read (card(23:26),*) ires + read (card(18:20),'(a3)') res + if (ibeg.eq.1) then + ishift=ires-1 + if (res.ne.'GLY' .and. res.ne. 'ACE') then + ishift=ishift-1 + itype(1)=ntyp1 + endif +c write (iout,*) "ires",ires," ibeg",ibeg," ishift",ishift + ibeg=0 + else if (ibeg.eq.2) then +c Start a new chain + ishift=-ires_old+ires-1 +c write (iout,*) "New chain started",ires,ishift + ibeg=0 + endif + ires=ires-ishift +c write (2,*) "ires",ires," ishift",ishift + if (res.eq.'ACE') then + ity=10 + else + itype(ires)=rescode(ires,res,0) + endif + read(card(31:54),'(3f8.3)') (c(j,ires),j=1,3) + read(card(61:66),*) bfac(ires) +c write (iout,'(2i3,2x,a,3f8.3,5x,f8.3)') +c & ires,itype(ires),res,(c(j,ires),j=1,3),bfac(ires) + iii=1 + do j=1,3 + sccor(j,iii)=c(j,ires) + enddo + else if (atom.ne.'O '.and.atom(1:1).ne.'H' .and. + & atom(1:1).ne.'Q' .and. atom(1:2).ne.'1H' .and. + & atom(1:2).ne.'2H' .and. atom(1:2).ne.'3H' .and. + & atom.ne.'N ' .and. atom.ne.'C ' .and. + & atom.ne.'OXT' ) then + iii=iii+1 +c write (iout,*) res,ires,iii,atom + read(card(31:54),'(3f8.3)') (sccor(j,iii),j=1,3) +c write (iout,'(3f8.3)') (sccor(j,iii),j=1,3) + endif + endif + enddo + 10 write (iout,'(a,i5)') ' Nres: ',ires +C Calculate dummy residue coordinates inside the "chain" of a multichain +C system + nres=ires + do i=2,nres-1 +c write (iout,*) i,itype(i) + + if (itype(i).eq.ntyp1) then + if (itype(i+1).eq.ntyp1) then +C 16/01/2014 by Adasko: Adding to dummy atoms in the chain +C first is connected prevous chain (itype(i+1).eq.ntyp1)=true +C second dummy atom is conected to next chain itype(i+1).eq.ntyp1=false +C if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the last dummy residue +C call refsys(i-3,i-2,i-1,e1,e2,e3,fail) +C if (fail) then +C e2(1)=0.0d0 +C e2(2)=1.0d0 +C e2(3)=0.0d0 +C endif !fail +C do j=1,3 +C c(j,i)=c(j,i-1)-1.9d0*e2(j) +C enddo +C else !unres_pdb + do j=1,3 + dcj=(c(j,i-2)-c(j,i-3))/2.0 + c(j,i)=c(j,i-1)+dcj + c(j,nres+i)=c(j,i) + enddo +C endif !unres_pdb + else !itype(i+1).eq.ntyp1 +C if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the first dummy residue +C call refsys(i+1,i+2,i+3,e1,e2,e3,fail) +C if (fail) then +C e2(1)=0.0d0 +C e2(2)=1.0d0 +C e2(3)=0.0d0 +C endif +C do j=1,3 +C c(j,i)=c(j,i+1)-1.9d0*e2(j) +C enddo +C else !unres_pdb + do j=1,3 + dcj=(c(j,i+3)-c(j,i+2))/2.0 + c(j,i)=c(j,i+1)-dcj + c(j,nres+i)=c(j,i) + enddo +C endif !unres_pdb + endif !itype(i+1).eq.ntyp1 + endif !itype.eq.ntyp1 + enddo +C Calculate the CM of the last side chain. + call sccenter(ires,iii,sccor) + nsup=nres + nstart_sup=1 + if (itype(nres).ne.10) then + nres=nres+1 + itype(nres)=ntyp1 + do j=1,3 + dcj=(c(j,nres-2)-c(j,nres-3))/2.0 + c(j,nres)=c(j,nres-1)+dcj + c(j,2*nres)=c(j,nres) + enddo + endif + do i=2,nres-1 + do j=1,3 + c(j,i+nres)=dc(j,i) + enddo + enddo + do j=1,3 + c(j,nres+1)=c(j,1) + c(j,2*nres)=c(j,nres) + enddo + if (itype(1).eq.ntyp1) then + nsup=nsup-1 + nstart_sup=2 + do j=1,3 + dcj=(c(j,4)-c(j,3))/2.0 + c(j,1)=c(j,2)-dcj + c(j,nres+1)=c(j,1) + enddo + endif +C Calculate internal coordinates. + if (lprint) then + write (iout,100) + do ires=1,nres + write (iout,'(2i3,2x,a,3f8.3,5x,3f8.3)') + & ires,itype(ires),restyp(itype(ires)),(c(j,ires),j=1,3), + & (c(j,nres+ires),j=1,3) + enddo + endif + call int_from_cart(.true.,.false.) + call flush(iout) + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=2,nres-1 + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo +c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3), +c & vbld_inv(i+nres) + enddo +c call chainbuild +C Copy the coordinates to reference coordinates + do i=1,nres + do j=1,3 + cref(j,i)=c(j,i) + cref(j,i+nres)=c(j,i+nres) + enddo + enddo + 100 format ('Residue alpha-carbon coordinates ', + & ' centroid coordinates'/ + 1 ' ', 6X,'X',7X,'Y',7X,'Z', + & 12X,'X',7X,'Y',7X,'Z') + 110 format (a,'(',i3,')',6f12.5) + + ishift_pdb=ishift + return + end +c--------------------------------------------------------------------------- + subroutine int_from_cart(lside,lprn) + implicit none + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + character*3 seq,atom,res + character*80 card + double precision sccor(3,50) + integer rescode + double precision dist,alpha,beta,di + integer i,j,iti + logical lside,lprn + if (lprn) then + write (iout,'(/a)') + & 'Internal coordinates calculated from crystal structure.' + if (lside) then + write (iout,'(8a)') ' Res ',' dvb',' Theta', + & ' Phi',' Dsc_id',' Dsc',' Alpha', + & ' Omega' + else + write (iout,'(4a)') ' Res ',' dvb',' Theta', + & ' Phi' + endif + endif + do i=2,nres + iti=itype(i) +c write (iout,*) i,i-1,(c(j,i),j=1,3),(c(j,i-1),j=1,3),dist(i,i-1) + if (itype(i-1).ne.ntyp1 .and. itype(i).ne.ntyp1 .and. + & (dist(i,i-1).lt.1.0D0 .or. dist(i,i-1).gt.6.0D0)) then + write (iout,'(a,i4)') 'Bad Cartesians for residue',i + stop + endif + vbld(i)=dist(i-1,i) + vbld_inv(i)=1.0d0/vbld(i) + theta(i+1)=alpha(i-1,i,i+1) + if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) + enddo +c if (itype(1).eq.ntyp1) then +c do j=1,3 +c c(j,1)=c(j,2)+(c(j,3)-c(j,4)) +c enddo +c endif +c if (itype(nres).eq.ntyp1) then +c do j=1,3 +c c(j,nres)=c(j,nres-1)+(c(j,nres-2)-c(j,nres-3)) +c enddo +c endif + if (lside) then + do i=2,nres-1 + do j=1,3 + c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) + enddo + iti=itype(i) + di=dist(i,nres+i) + vbld(i+nres)=di + if (itype(i).ne.10) then + vbld_inv(i+nres)=1.0d0/di + else + vbld_inv(i+nres)=0.0d0 + endif + if (iti.ne.10) then + alph(i)=alpha(nres+i,i,maxres2) + omeg(i)=beta(nres+i,i,maxres2,i+1) + endif + if (iti.ne.10) then + alph(i)=alpha(nres+i,i,maxres2) + omeg(i)=beta(nres+i,i,maxres2,i+1) + endif + if (lprn) + & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1), + & rad2deg*theta(i),rad2deg*phi(i),dsc(iti),di, + & rad2deg*alph(i),rad2deg*omeg(i) + enddo + else if (lprn) then + do i=2,nres + iti=itype(i) + write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1), + & rad2deg*theta(i),rad2deg*phi(i) + enddo + endif + return + end +c--------------------------------------------------------------------------- + subroutine sccenter(ires,nscat,sccor) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + integer ires,nscat,i,j + double precision sccor(3,50),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 +c--------------------------------------------------------------------------- + subroutine sc_loc_geom(lprn) + 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.SETUP' + double precision x_prime(3),y_prime(3),z_prime(3) + logical lprn + do i=1,nres-1 + do j=1,3 + dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i)) + enddo + enddo + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) 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. itype(i).ne.ntyp1) then +c +C Compute the axes of tghe local cartesian coordinates system; store in +c x_prime, y_prime and z_prime +c + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo +c write (iout,*) "x_prime",(x_prime(j),j=1,3) +c write (iout,*) "y_prime",(y_prime(j),j=1,3) + call vecpr(x_prime,y_prime,z_prime) +c write (iout,*) "z_prime",(z_prime(j),j=1,3) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxref(i)=xx + yyref(i)=yy + zzref(i)=zz + else + xxref(i)=0.0d0 + yyref(i)=0.0d0 + zzref(i)=0.0d0 + endif + enddo + if (lprn) then + write (iout,*) "xxref,yyref,zzref" + do i=2,nres + iti=itype(i) + write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i),yyref(i), + & zzref(i) + enddo + endif + return + end +c--------------------------------------------------------------------------- + subroutine bond_regular + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CALC' + include 'COMMON.INTERACT' + include 'COMMON.CHAIN' + do i=1,nres-1 + vbld(i+1)=vbl + vbld_inv(i+1)=1.0d0/vbld(i+1) + vbld(i+1+nres)=dsc(iabs(itype(i+1))) + vbld_inv(i+1+nres)=dsc_inv(iabs(itype(i+1))) +c print *,vbld(i+1),vbld(i+1+nres) + enddo + return + end +c--------------------------------------------------------------------------- + subroutine readpdb_template(k) +C Read the PDB file for read_constr_homology with read2sigma +C and convert the peptide geometry into virtual-chain geometry. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + integer i,j,ibeg,ishift1,ires,iii,ires_old,ishift,ity + logical lprn /.false./,fail + double precision e1(3),e2(3),e3(3) + double precision dcj,efree_temp + character*3 seq,res + character*5 atom + character*80 card + double precision sccor(3,20) + integer rescode,iterter(maxres) + do i=1,maxres + iterter(i)=0 + enddo + ibeg=1 + ishift1=0 + ishift=0 +c write (2,*) "UNRES_PDB",unres_pdb + ires=0 + ires_old=0 + iii=0 + lsecondary=.false. + nhfrag=0 + nbfrag=0 + do + read (ipdbin,'(a80)',end=10) card + if (card(:3).eq.'END') then + goto 10 + else if (card(:3).eq.'TER') then +C End current chain + ires_old=ires+2 + itype(ires_old-1)=ntyp1 + iterter(ires_old-1)=1 + itype(ires_old)=ntyp1 + iterter(ires_old)=1 + ibeg=2 +c 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 + endif +C Fish out the ATOM cards. + if (index(card(1:4),'ATOM').gt.0) then + read (card(12:16),*) atom +c write (iout,*) "! ",atom," !",ires +c if (atom.eq.'CA' .or. atom.eq.'CH3') then + read (card(23:26),*) ires + read (card(18:20),'(a3)') res +c write (iout,*) "ires",ires,ires-ishift+ishift1, +c & " ires_old",ires_old +c write (iout,*) "ishift",ishift," ishift1",ishift1 +c write (iout,*) "IRES",ires-ishift+ishift1,ires_old + if (ires-ishift+ishift1.ne.ires_old) then +C Calculate the CM of the preceding residue. + if (ibeg.eq.0) then + if (unres_pdb) then + do j=1,3 + dc(j,ires)=sccor(j,iii) + enddo + else + call sccenter(ires_old,iii,sccor) + endif + iii=0 + endif +C Start new residue. + if (res.eq.'Cl-' .or. res.eq.'Na+') then + ires=ires_old + cycle + else if (ibeg.eq.1) then +c 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 +c write (iout,*) "ishift",ishift," ires",ires, +c & " ires_old",ires_old +c write (iout,*) "ires",ires," ibeg",ibeg," ishift",ishift + ibeg=0 + else if (ibeg.eq.2) then +c Start a new chain + ishift=-ires_old+ires-1 + ires=ires_old+1 +c write (iout,*) "New chain started",ires,ishift + 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 +c write (iout,*) "ires_old",ires_old," ires",ires +c if (card(27:27).eq."A" .or. card(27:27).eq."B") then +c ishift1=ishift1+1 +c endif +c 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) +c write (iout,*) "backbone ",atom ,ires,res, (c(j,ires),j=1,3) +#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 + if (ishift.ne.0) then + ires_ca=ires+ishift-ishift1 + else + ires_ca=ires + endif +c 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 +c 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)') ' Nres: ',ires +C Calculate dummy residue coordinates inside the "chain" of a multichain +C system + nres=ires + do i=2,nres-1 +c write (iout,*) i,itype(i),itype(i+1) + if (itype(i).eq.ntyp1.and.iterter(i).eq.1) then + if (itype(i+1).eq.ntyp1.and.iterter(i+1).eq.1 ) then +C 16/01/2014 by Adasko: Adding to dummy atoms in the chain +C first is connected prevous chain (itype(i+1).eq.ntyp1)=true +C second dummy atom is conected to next chain itype(i+1).eq.ntyp1=false + if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the last dummy residue + call refsys(i-3,i-2,i-1,e1,e2,e3,fail) + if (fail) then + e2(1)=0.0d0 + e2(2)=1.0d0 + e2(3)=0.0d0 + endif !fail + do j=1,3 + c(j,i)=c(j,i-1)-1.9d0*e2(j) + enddo + else !unres_pdb + do j=1,3 + dcj=(c(j,i-2)-c(j,i-3))/2.0 + if (dcj.eq.0) dcj=1.23591524223 + c(j,i)=c(j,i-1)+dcj + c(j,nres+i)=c(j,i) + enddo + endif !unres_pdb + else !itype(i+1).eq.ntyp1 + if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the first dummy residue + call refsys(i+1,i+2,i+3,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,i)=c(j,i+1)-1.9d0*e2(j) + enddo + else !unres_pdb + do j=1,3 + dcj=(c(j,i+3)-c(j,i+2))/2.0 + if (dcj.eq.0) dcj=1.23591524223 + c(j,i)=c(j,i+1)-dcj + c(j,nres+i)=c(j,i) + enddo + endif !unres_pdb + endif !itype(i+1).eq.ntyp1 + endif !itype.eq.ntyp1 + enddo +C Calculate the CM of the last side chain. + if (unres_pdb) then + do j=1,3 + dc(j,ires)=sccor(j,iii) + enddo + else + call sccenter(ires,iii,sccor) + endif + nsup=nres + nstart_sup=1 + if (itype(nres).ne.10) then + nres=nres+1 + itype(nres)=ntyp1 + if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the last dummy residue + call refsys(nres-3,nres-2,nres-1,e1,e2,e3,fail) + if (fail) then + e2(1)=0.0d0 + e2(2)=1.0d0 + e2(3)=0.0d0 + endif + do j=1,3 + c(j,nres)=c(j,nres-1)-1.9d0*e2(j) + enddo + else + do j=1,3 + dcj=(c(j,nres-2)-c(j,nres-3))/2.0 + if (dcj.eq.0) dcj=1.23591524223 + c(j,nres)=c(j,nres-1)+dcj + c(j,2*nres)=c(j,nres) + enddo + endif + endif + do i=2,nres-1 + do j=1,3 + c(j,i+nres)=dc(j,i) + enddo + enddo + do j=1,3 + c(j,nres+1)=c(j,1) + c(j,2*nres)=c(j,nres) + enddo + if (itype(1).eq.ntyp1) then + nsup=nsup-1 + nstart_sup=2 + if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the first dummy residue + call refsys(2,3,4,e1,e2,e3,fail) + if (fail) then + e2(1)=0.0d0 + e2(2)=1.0d0 + e2(3)=0.0d0 + endif + do j=1,3 + c(j,1)=c(j,2)-1.9d0*e2(j) + enddo + else + do j=1,3 + dcj=(c(j,4)-c(j,3))/2.0 + c(j,1)=c(j,2)-dcj + c(j,nres+1)=c(j,1) + enddo + endif + endif +C Copy the coordinates to reference coordinates +c do i=1,2*nres +c do j=1,3 +c cref(j,i)=c(j,i) +c enddo +c enddo +C Calculate internal coordinates. + if (out_template_coord) 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 +C Calculate internal coordinates. +c call int_from_cart1(.false.) + call int_from_cart(.true.,.true.) + call sc_loc_geom(.true.) + do i=1,nres + thetaref(i)=theta(i) + phiref(i)=phi(i) + enddo + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=2,nres-1 + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo +c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3), +c & vbld_inv(i+nres) + enddo + do i=1,nres + do j=1,3 + cref(j,i)=c(j,i) + cref(j,i+nres)=c(j,i+nres) + enddo + enddo + do i=1,2*nres + do j=1,3 + chomo(j,i,k)=c(j,i) + enddo + enddo + + return + end + + diff --git a/source/cluster/wham/src-HCD/readpdb.f.safe b/source/cluster/wham/src-HCD/readpdb.f.safe new file mode 100644 index 0000000..6f478b5 --- /dev/null +++ b/source/cluster/wham/src-HCD/readpdb.f.safe @@ -0,0 +1,307 @@ + subroutine readpdb +C Read the PDB file and convert the peptide geometry into virtual-chain +C geometry. + implicit none + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.CONTROL' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.SBRIDGE' + character*3 seq,atom,res + character*80 card + double precision sccor(3,50) + integer i,j,iii,ibeg,ishift,ishift1,ity,ires,ires_old + double precision dcj + integer rescode,kkk,lll,icha,cou,kupa,iprzes + bfac=0.0d0 + ibeg=1 + ishift1=0 + do + read (ipdbin,'(a80)',end=10) card + if (card(:3).eq.'END') then + goto 10 + else if (card(:3).eq.'TER') then +C End current chain +c ires_old=ires+1 + ires_old=ires+2 + itype(ires_old-1)=ntyp1 + itype(ires_old)=ntyp1 + ibeg=2 +c write (iout,*) "Chain ended",ires,ishift,ires_old + call sccenter(ires,iii,sccor) + endif +C Fish out the ATOM cards. + if (index(card(1:4),'ATOM').gt.0) then + read (card(14:16),'(a3)') atom + if (atom.eq.'CA' .or. atom.eq.'CH3') then +C Calculate the CM of the preceding residue. + if (ibeg.eq.0) then + call sccenter(ires,iii,sccor) + endif +C Start new residue. +c write (iout,'(a80)') card + read (card(23:26),*) ires + read (card(18:20),'(a3)') res + if (ibeg.eq.1) then + ishift=ires-1 + if (res.ne.'GLY' .and. res.ne. 'ACE') then + ishift=ishift-1 + itype(1)=ntyp1 + endif +c write (iout,*) "ires",ires," ibeg",ibeg," ishift",ishift + ibeg=0 + else if (ibeg.eq.2) then +c Start a new chain + ishift=-ires_old+ires-1 +c write (iout,*) "New chain started",ires,ishift + ibeg=0 + endif + ires=ires-ishift +c write (2,*) "ires",ires," ishift",ishift + if (res.eq.'ACE') then + ity=10 + else + itype(ires)=rescode(ires,res,0) + endif + read(card(31:54),'(3f8.3)') (c(j,ires),j=1,3) + read(card(61:66),*) bfac(ires) + write (iout,'(2i3,2x,a,3f8.3)') + & ires,itype(ires),res,(c(j,ires),j=1,3) + iii=1 + do j=1,3 + sccor(j,iii)=c(j,ires) + enddo + else if (atom.ne.'O '.and.atom(1:1).ne.'H' .and. + & atom(1:1).ne.'Q' .and. atom(1:2).ne.'1H' .and. + & atom(1:2).ne.'2H' .and. atom(1:2).ne.'3H' .and. + & atom.ne.'N ' .and. atom.ne.'C ') then + iii=iii+1 + read(card(31:54),'(3f8.3)') (sccor(j,iii),j=1,3) + endif + endif + enddo + 10 write (iout,'(a,i5)') ' Nres: ',ires +C Calculate dummy residue coordinates inside the "chain" of a multichain +C system + nres=ires + do i=2,nres-1 +c write (iout,*) i,itype(i) + + if (itype(i).eq.ntyp1) then + if (itype(i+1).eq.ntyp1) then +C 16/01/2014 by Adasko: Adding to dummy atoms in the chain +C first is connected prevous chain (itype(i+1).eq.ntyp1)=true +C second dummy atom is conected to next chain itype(i+1).eq.ntyp1=false +C if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the last dummy residue +C call refsys(i-3,i-2,i-1,e1,e2,e3,fail) +C if (fail) then +C e2(1)=0.0d0 +C e2(2)=1.0d0 +C e2(3)=0.0d0 +C endif !fail +C do j=1,3 +C c(j,i)=c(j,i-1)-1.9d0*e2(j) +C enddo +C else !unres_pdb + do j=1,3 + dcj=(c(j,i-2)-c(j,i-3))/2.0 + c(j,i)=c(j,i-1)+dcj + c(j,nres+i)=c(j,i) + enddo +C endif !unres_pdb + else !itype(i+1).eq.ntyp1 +C if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the first dummy residue +C call refsys(i+1,i+2,i+3,e1,e2,e3,fail) +C if (fail) then +C e2(1)=0.0d0 +C e2(2)=1.0d0 +C e2(3)=0.0d0 +C endif +C do j=1,3 +C c(j,i)=c(j,i+1)-1.9d0*e2(j) +C enddo +C else !unres_pdb + do j=1,3 + dcj=(c(j,i+3)-c(j,i+2))/2.0 + c(j,i)=c(j,i+1)-dcj + c(j,nres+i)=c(j,i) + enddo +C endif !unres_pdb + endif !itype(i+1).eq.ntyp1 + endif !itype.eq.ntyp1 + enddo +C Calculate the CM of the last side chain. + call sccenter(ires,iii,sccor) + nsup=nres + nstart_sup=1 + if (itype(nres).ne.10) then + nres=nres+1 + itype(nres)=ntyp1 + do j=1,3 + dcj=(c(j,nres-2)-c(j,nres-3))/2.0 + c(j,nres)=c(j,nres-1)+dcj + c(j,2*nres)=c(j,nres) + enddo + endif + do i=2,nres-1 + do j=1,3 + c(j,i+nres)=dc(j,i) + enddo + enddo + do j=1,3 + c(j,nres+1)=c(j,1) + c(j,2*nres)=c(j,nres) + enddo + if (itype(1).eq.ntyp1) then + nsup=nsup-1 + nstart_sup=2 + do j=1,3 + dcj=(c(j,4)-c(j,3))/2.0 + c(j,1)=c(j,2)-dcj + c(j,nres+1)=c(j,1) + enddo + endif +C Calculate internal coordinates. + 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 + call int_from_cart(.true.,.false.) +c write (iout,*) "After int_from_cart" +c call flush(iout) + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=2,nres-1 + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo +c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3), +c & vbld_inv(i+nres) + enddo +c call chainbuild +C Copy the coordinates to reference coordinates + do i=1,2*nres + do j=1,3 + cref_pdb(j,i)=c(j,i) + enddo + enddo + do i=1,nres + write (iout,110) restyp(itype(i)),i,cref_pdb(1,i), + & cref_pdb(2,i),cref_pdb(3,i),cref_pdb(1,nres+i), + & cref_pdb(2,nres+i),cref_pdb(3,nres+i) + enddo + 100 format (//' alpha-carbon coordinates ', + & ' centroid coordinates'/ + 1 ' ', 6X,'X',11X,'Y',11X,'Z', + & 10X,'X',11X,'Y',11X,'Z') + 110 format (a,'(',i3,')',6f12.5) + ishift_pdb=ishift + return + end +c--------------------------------------------------------------------------- + subroutine int_from_cart(lside,lprn) + implicit none + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + character*3 seq,atom,res + character*80 card + double precision sccor(3,20) + integer rescode + double precision dist,alpha,beta,di + integer i,j,iti + logical lside,lprn + if (lprn) then + write (iout,'(/a)') + & 'Internal coordinates calculated from crystal structure.' + if (lside) then + write (iout,'(8a)') ' Res ',' dvb',' Theta', + & ' Phi',' Dsc_id',' Dsc',' Alpha', + & ' Omega' + else + write (iout,'(4a)') ' Res ',' dvb',' Theta', + & ' Phi' + endif + endif + do i=2,nres + iti=itype(i) +c write (iout,*) i,i-1,(c(j,i),j=1,3),(c(j,i-1),j=1,3),dist(i,i-1) + if (itype(i-1).ne.ntyp1 .and. itype(i).ne.ntyp1 .and. + & (dist(i,i-1).lt.1.0D0 .or. dist(i,i-1).gt.6.0D0)) then + write (iout,'(a,i4)') 'Bad Cartesians for residue',i + stop + endif + 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 + 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 + if (lside) then + do i=2,nres-1 + do j=1,3 + c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) + enddo + iti=itype(i) + di=dist(i,nres+i) + if (iti.ne.10) then + alph(i)=alpha(nres+i,i,maxres2) + omeg(i)=beta(nres+i,i,maxres2,i+1) + endif + if (lprn) + & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1), + & rad2deg*theta(i),rad2deg*phi(i),dsc(iti),di, + & rad2deg*alph(i),rad2deg*omeg(i) + enddo + else if (lprn) then + do i=2,nres + iti=itype(i) + write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1), + & rad2deg*theta(i),rad2deg*phi(i) + enddo + endif + return + end +c--------------------------------------------------------------------------- + subroutine sccenter(ires,nscat,sccor) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + integer ires,nscat,i,j + double precision sccor(3,20),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 diff --git a/source/cluster/wham/src-HCD/readrtns.F b/source/cluster/wham/src-HCD/readrtns.F new file mode 100644 index 0000000..a3229a6 --- /dev/null +++ b/source/cluster/wham/src-HCD/readrtns.F @@ -0,0 +1,1413 @@ + subroutine read_control +C +C Read molecular data +C + 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' + include "COMMON.SPLITELE" + include 'COMMON.SHIELD' + include 'COMMON.SAXS' + character*320 controlcard,ucase +#ifdef MPL + include 'COMMON.INFO' +#endif + integer i,i1,i2,it1,it2 + double precision pi + read (INP,'(a80)') titel + call card_concat(controlcard) + + energy_dec=(index(controlcard,'ENERGY_DEC').gt.0) + unres_pdb = index(controlcard,'UNRES_PDB') .gt. 0 + call readi(controlcard,'TORMODE',tor_mode,0) + call readi(controlcard,'NRES',nres,0) + call readi(controlcard,'RESCALE',rescale_mode,2) + call reada(controlcard,'DISTCHAINMAX',distchainmax,50.0d0) + write (iout,*) "DISTCHAINMAX",distchainmax +C Reading the dimensions of box in x,y,z coordinates + call reada(controlcard,'BOXX',boxxsize,100.0d0) + call reada(controlcard,'BOXY',boxysize,100.0d0) + call reada(controlcard,'BOXZ',boxzsize,100.0d0) +c Cutoff range for interactions + call reada(controlcard,"R_CUT",r_cut,25.0d0) + call reada(controlcard,"LAMBDA",rlamb,0.3d0) + write (iout,*) "Cutoff on interactions",r_cut + write (iout,*) "lambda",rlamb + call reada(controlcard,"LIPTHICK",lipthick,0.0d0) + call reada(controlcard,"LIPAQBUF",lipbufthick,0.0d0) + if (lipthick.gt.0.0d0) then + bordliptop=(boxzsize+lipthick)/2.0 + bordlipbot=bordliptop-lipthick +C endif + if ((bordliptop.gt.boxzsize).or.(bordlipbot.lt.0.0)) + & write(iout,*) "WARNING WRONG SIZE OF LIPIDIC PHASE" + buflipbot=bordlipbot+lipbufthick + bufliptop=bordliptop-lipbufthick + if ((lipbufthick*2.0d0).gt.lipthick) + &write(iout,*) "WARNING WRONG SIZE OF LIP AQ BUF" + endif + write(iout,*) "bordliptop=",bordliptop + write(iout,*) "bordlipbot=",bordlipbot + write(iout,*) "bufliptop=",bufliptop + write(iout,*) "buflipbot=",buflipbot +C Shielding mode + call readi(controlcard,'SHIELD',shield_mode,0) + write (iout,*) "SHIELD MODE",shield_mode + if (shield_mode.gt.0) then + pdbref=(index(controlcard,'PDBREF').gt.0) + if (index(controlcard,"CASC").gt.0) then + iz_sc=1 + else if (index(controlcard,"SCONLY").gt.0) then + iz_sc=2 + else + iz_sc=0 + endif + pi=3.141592d0 +C VSolvSphere the volume of solving sphere +C print *,pi,"pi" +C rpp(1,1) is the energy r0 for peptide group contact and will be used for it +C there will be no distinction between proline peptide group and normal peptide +C group in case of shielding parameters + VSolvSphere=4.0/3.0*pi*rpp(1,1)**3 + VSolvSphere_div=VSolvSphere-4.0/3.0*pi*(rpp(1,1)/2.0)**3 + write (iout,*) VSolvSphere,VSolvSphere_div +C long axis of side chain + do i=1,ntyp + long_r_sidechain(i)=vbldsc0(1,i) + short_r_sidechain(i)=sigma0(i) + enddo + buff_shield=1.0d0 + endif + call readi(controlcard,'PDBOUT',outpdb,0) + call readi(controlcard,'MOL2OUT',outmol2,0) + refstr=(index(controlcard,'REFSTR').gt.0) + pdbref=(index(controlcard,'PDBREF').gt.0) + refstr = refstr .or. pdbref + write (iout,*) "REFSTR",refstr," PDBREF",pdbref + iscode=index(controlcard,'ONE_LETTER') + tree=(index(controlcard,'MAKE_TREE').gt.0) + with_dihed_constr = index(controlcard,"WITH_DIHED_CONSTR").gt.0 + call readi(controlcard,'CONSTR_DIST',constr_dist,0) + write (iout,*) "with_dihed_constr ",with_dihed_constr, + & " CONSTR_DIST",constr_dist + with_theta_constr = index(controlcard,"WITH_THETA_CONSTR").gt.0 + write (iout,*) "with_theta_constr ",with_theta_constr + call flush(iout) + min_var=(index(controlcard,'MINVAR').gt.0) + plot_tree=(index(controlcard,'PLOT_TREE').gt.0) + punch_dist=(index(controlcard,'PUNCH_DIST').gt.0) + print_fittest=(index(controlcard,'PRINT_FITTEST').gt.0) + call readi(controlcard,'NCUT',ncut,0) + if (ncut.gt.0) then + call multreada(controlcard,'CUTOFF',rcutoff,ncut,-1.0d0) + nclust=0 + else + call readi(controlcard,'NCLUST',nclust,5) + endif + 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 readi(controlcard,'IOPT',iopt,2) + lefree = index(controlcard,"EFREE").gt.0 + call readi(controlcard,'NTEMP',nT,1) + write (iout,*) "nT",nT + 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 + call readi(controlcard,'CONSTR_DIST',constr_dist,0) + call readi(controlcard,'CONSTR_HOMOL',constr_homology,0) +c if (constr_homology) tole=dmax1(tole,1.5d0) + write (iout,*) "with_homology_constr ",with_dihed_constr, + & " CONSTR_HOMOLOGY",constr_homology + read_homol_frag = index(controlcard,"READ_HOMOL_FRAG").gt.0 + out_template_coord = index(controlcard,"OUT_TEMPLATE_COORD").gt.0 + out_template_restr = index(controlcard,"OUT_TEMPLATE_RESTR").gt.0 + write (iout,*) "out_template_coord ",OUT_TEMPLATE_COORD + call readi(controlcard,'NSAXS',nsaxs,0) + call readi(controlcard,'SAXS_MODE',saxs_mode,0) + call reada(controlcard,'SCAL_RAD',scal_rad,1.0d0) + call reada(controlcard,'SAXS_CUTOFF',saxs_cutoff,1.0d0) + write (iout,*) "Number of SAXS restraints",NSAXS," SAXS_MODE", + & SAXS_MODE," SCAL_RAD",scal_rad,"SAXS_CUTOFF",saxs_cutoff + if (min_var) iopt=1 + return + end +c-------------------------------------------------------------------------- + subroutine molread +C +C Read molecular data. +C + 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' + include 'COMMON.TORCNSTR' + include 'COMMON.SHIELD' + include 'COMMON.SAXS' +#ifdef MPL + include 'COMMON.INFO' +#endif + character*4 sequence(maxres) + character*800 weightcard,controlcard + integer rescode + double precision x(maxvar) + double precision phihel,phibet,sigmahel,sigmabet,sumv, + & secprob(3,maxres) + integer itype_pdb(maxres) + logical seq_comp + integer i,j,kkk,i1,i2,it1,it2,tperm,ii,iperm +C +C Body +C +C Read weights of the subsequent energy terms. + call card_concat(weightcard) + 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,'WSAXS',wsaxs,0.0D0) + call reada(weightcard,'SCAL14',scal14,0.4D0) + call reada(weightcard,'SCALSCP',scalscp,1.0d0) + call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) + call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) + if (index(weightcard,'SOFT').gt.0) ipot=6 + 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) + call reada(weightcard,'WSHIELD',wshield,1.0d0) + call reada(weightcard,'WDFAD',wdfa_dist,0.0d0) + call reada(weightcard,'WDFAT',wdfa_tor,0.0d0) + call reada(weightcard,'WDFAN',wdfa_nei,0.0d0) + call reada(weightcard,'WDFAB',wdfa_beta,0.0d0) + call reada(weightcard,'WLT',wliptran,0.0D0) + call reada(weightcard,"ATRISS",atriss,0.301D0) + call reada(weightcard,"BTRISS",btriss,0.021D0) + call reada(weightcard,"CTRISS",ctriss,1.001D0) + call reada(weightcard,"DTRISS",dtriss,1.001D0) + dyn_ss=(index(weightcard,'DYN_SS').gt.0) + do i=1,maxres + dyn_ss_mask(i)=.false. + enddo + do i=1,maxres-1 + do j=i+1,maxres + dyn_ssbond_ij(i,j)=1.0d300 + enddo + enddo + call reada(weightcard,"HT",Ht,0.0D0) + if (dyn_ss) then + ss_depth=ebr/wsc-0.25*eps(1,1) + Ht=Ht/wsc-0.25*eps(1,1) + akcm=akcm*wstrain/wsc + akth=akth*wstrain/wsc + akct=akct*wstrain/wsc + v1ss=v1ss*wstrain/wsc + v2ss=v2ss*wstrain/wsc + v3ss=v3ss*wstrain/wsc + else + ss_depth=ebr/wstrain-0.25*eps(1,1)*wsc/wstrain + endif + 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 + write (iout,*) "Parameters of the 'trisulfide' potential" + write (iout,*) "ATRISS=", atriss + write (iout,*) "BTRISS=", btriss + write (iout,*) "CTRISS=", ctriss + write (iout,*) "DTRISS=", dtriss + +C 12/1/95 Added weight for the multi-body term WCORR + call reada(weightcard,'WCORRH',wcorr,1.0D0) + if (wcorr4.gt.0.0d0) wcorr=wcorr4 + weights(1)=wsc + weights(2)=wscp + weights(3)=welec + weights(4)=wcorr + weights(5)=wcorr5 + weights(6)=wcorr6 + weights(7)=wel_loc + weights(8)=wturn3 + weights(9)=wturn4 + weights(10)=wturn6 + weights(11)=wang + weights(12)=wscloc + weights(13)=wtor + weights(14)=wtor_d + weights(15)=wstrain + weights(16)=wvdwpp + weights(17)=scal14 + weights(18)=wbond + weights(19)=wsccor + weights(28)=wdfa_dist + weights(29)=wdfa_tor + weights(30)=wdfa_nei + weights(31)=wdfa_beta + 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 +#ifdef DFA + write (iout,'(/a/)') "DFA pseudopotential parameters:" + write (iout,'(a,f10.6,a)') + & "WDFAD= ",wdfa_dist," (distance)", + & "WDFAT= ",wdfa_tor," (backbone angles)", + & "WDFAN= ",wdfa_nei," (neighbors)", + & "WDFAB= ",wdfa_beta," (beta structure)" +#endif + call flush(iout) +c print *,'indpdb=',indpdb,' pdbref=',pdbref + +C 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 +C Convert sequence to numeric code + do i=1,nres + itype(i)=rescode(i,sequence(i),iscode) + enddo +c print *,nres +c 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 + +c print *,'Call Read_Bridge.' + call read_bridge +C this fragment reads diheadral constrains + nnt=1 + nct=nres +c print *,'NNT=',NNT,' NCT=',NCT + call seq2chains(nres,itype,nchain,chain_length,chain_border, + & ireschain) + write(iout,*) "nres",nres," nchain",nchain + do i=1,nchain + write(iout,*)"chain",i,chain_length(i),chain_border(1,i), + & chain_border(2,i) + enddo + call chain_symmetry(nchain,nres,itype,chain_border, + & chain_length,npermchain,tabpermchain) + do i=1,nres + write(iout,*) i,(tperm(ireschain(i),ii,tabpermchain), + & ii=1,npermchain) + enddo + write(iout,*) "residue permutations" + do i=1,nres + write(iout,*) i,(iperm(i,ii),ii=1,npermchain) + enddo + 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 +#ifdef DFA + if (.not. (wdfa_dist.eq.0.0 .and. wdfa_tor.eq.0.0 .and. + & wdfa_nei.eq.0.0 .and. wdfa_beta.eq.0.0)) then + call init_dfa_vars + print*, 'init_dfa_vars finished!' + call read_dfa_info + print*, 'read_dfa_info finished!' + endif +#endif +C If the reference structure is not read set the superposition +C boundaries + nstart_sup=nnt + nstart_seq=nnt + nend_sup=nct + nsup=nct-nnt+1 + + if (with_dihed_constr) then + + read (inp,*) ndih_constr + if (ndih_constr.gt.0) then + raw_psipred=.false. +C read (inp,*) ftors +C write (iout,*) 'FTORS',ftors +C ftors is the force constant for torsional quartic constrains + read (inp,*) (idih_constr(i),phi0(i),drange(i),ftors(i), + & i=1,ndih_constr) + write (iout,*) + & 'There are',ndih_constr,' constraints on phi angles.' + do i=1,ndih_constr + write (iout,'(i5,3f8.3)') idih_constr(i),phi0(i),drange(i), + & ftors(i) + enddo + do i=1,ndih_constr + phi0(i)=deg2rad*phi0(i) + drange(i)=deg2rad*drange(i) + enddo + else if (ndih_constr.lt.0) then + raw_psipred=.true. + call card_concat(controlcard) + call reada(controlcard,"PHIHEL",phihel,50.0D0) + call reada(controlcard,"PHIBET",phibet,180.0D0) + call reada(controlcard,"SIGMAHEL",sigmahel,30.0d0) + call reada(controlcard,"SIGMABET",sigmabet,40.0d0) + call reada(controlcard,"WDIHC",wdihc,0.591d0) + write (iout,*) "Weight of the dihedral restraint term",wdihc + read(inp,'(9x,3f7.3)') + & (secprob(1,i),secprob(2,i),secprob(3,i),i=nnt,nct) + write (iout,*) "The secprob array" + do i=nnt,nct + write (iout,'(i5,3f8.3)') i,(secprob(j,i),j=1,3) + enddo + ndih_constr=0 + do i=nnt+3,nct + if (itype(i-3).ne.ntyp1 .and. itype(i-2).ne.ntyp1 + & .and. itype(i-1).ne.ntyp1 .and. itype(i).ne.ntyp1) then + ndih_constr=ndih_constr+1 + idih_constr(ndih_constr)=i + sumv=0.0d0 + do j=1,3 + vpsipred(j,ndih_constr)=secprob(j,i-1)*secprob(j,i-2) + sumv=sumv+vpsipred(j,ndih_constr) + enddo + do j=1,3 + vpsipred(j,ndih_constr)=vpsipred(j,ndih_constr)/sumv + enddo + phibound(1,ndih_constr)=phihel*deg2rad + phibound(2,ndih_constr)=phibet*deg2rad + sdihed(1,ndih_constr)=sigmahel*deg2rad + sdihed(2,ndih_constr)=sigmabet*deg2rad + endif + enddo + write (iout,*) + & 'There are',ndih_constr, + & ' bimodal restraints on gamma angles.' + do i=1,ndih_constr + write(iout,'(i5,1x,a4,i5,1h-,a4,i5,4f8.3,3f10.5)') i, + & restyp(itype(idih_constr(i)-2)),idih_constr(i)-2, + & restyp(itype(idih_constr(i)-1)),idih_constr(i)-1, + & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg, + & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg, + & (vpsipred(j,i),j=1,3) + enddo + + endif ! endif ndif_constr.gt.0 + endif ! with_dihed_constr + if (with_theta_constr) then +C with_theta_constr is keyword allowing for occurance of theta constrains + read (inp,*) ntheta_constr +C ntheta_constr is the number of theta constrains + if (ntheta_constr.gt.0) then +C read (inp,*) ftors + read (inp,*) (itheta_constr(i),theta_constr0(i), + & theta_drange(i),for_thet_constr(i), + & i=1,ntheta_constr) +C the above code reads from 1 to ntheta_constr +C itheta_constr(i) residue i for which is theta_constr +C theta_constr0 the global minimum value +C theta_drange is range for which there is no energy penalty +C for_thet_constr is the force constant for quartic energy penalty +C E=k*x**4 + write (iout,*) + & 'There are',ntheta_constr,' constraints on phi angles.' + do i=1,ntheta_constr + write (iout,'(i5,3f8.3)') itheta_constr(i),theta_constr0(i), + & theta_drange(i), + & for_thet_constr(i) + enddo +C endif + do i=1,ntheta_constr + theta_constr0(i)=deg2rad*theta_constr0(i) + theta_drange(i)=deg2rad*theta_drange(i) + enddo +C if(me.eq.king.or..not.out1file) +C & write (iout,*) 'FTORS',ftors +C do i=1,ntheta_constr +C ii = itheta_constr(i) +C thetabound(1,ii) = phi0(i)-drange(i) +C thetabound(2,ii) = phi0(i)+drange(i) +C enddo + endif ! ntheta_constr.gt.0 + endif! with_theta_constr + if (constr_homology.gt.0) then +c write (iout,*) "About to call read_constr_homology" +c call flush(iout) + call read_constr_homology +c write (iout,*) "Exit read_constr_homology" +c call flush(iout) + if (indpdb.gt.0 .or. pdbref) then + do i=1,2*nres + do j=1,3 + c(j,i)=crefjlee(j,i) + cref(j,i)=crefjlee(j,i) + enddo + enddo + endif +#ifdef DEBUG + write (iout,*) "Array C" + do i=1,nres + write (iout,'(i5,3f8.3,5x,3f8.3)') i,(c(j,i),j=1,3), + & (c(j,i+nres),j=1,3) + enddo + write (iout,*) "Array Cref" + do i=1,nres + write (iout,'(i5,3f8.3,5x,3f8.3)') i,(cref(j,i),j=1,3), + & (cref(j,i+nres),j=1,3) + enddo +#endif +#ifdef DEBUG + call int_from_cart1(.false.) + call sc_loc_geom(.false.) + do i=1,nres + thetaref(i)=theta(i) + phiref(i)=phi(i) + write (iout,*) i," phiref",phiref(i)," thetaref",thetaref(i) + enddo + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=2,nres-1 + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo + enddo +#endif + else + homol_nset=0 + endif + write (iout,*) "calling read_saxs_consrtr",nsaxs + if (nsaxs.gt.0) call read_saxs_constr + +c if (pdbref) then +c read(inp,'(a)') pdbfile +c write (iout,'(2a)') 'PDB data will be read from file ',pdbfile +c open(ipdbin,file=pdbfile,status='old',err=33) +c goto 34 +c 33 write (iout,'(a)') 'Error opening PDB file.' +c stop +c 34 continue +c print *,'Begin reading pdb data' +c call readpdb +c print *,'Finished reading pdb data' +c write (iout,'(a,i3,a,i3)')'nsup=',nsup,' nstart_sup=',nstart_sup +c do i=1,nres +c itype_pdb(i)=itype(i) +c enddo +c close (ipdbin) +c write (iout,'(a,i3)') 'nsup=',nsup +c nstart_seq=nnt +c if (nsup.le.(nct-nnt+1)) then +c do i=0,nct-nnt+1-nsup +c if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup),nsup)) then +c nstart_seq=nnt+i +c goto 111 +c endif +c enddo +c write (iout,'(a)') +c & 'Error - sequences to be superposed do not match.' +c stop +c else +c do i=0,nsup-(nct-nnt+1) +c if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),nct-nnt+1)) +c & then +c nstart_sup=nstart_sup+i +c nsup=nct-nnt+1 +c goto 111 +c endif +c enddo +c write (iout,'(a)') +c & 'Error - sequences to be superposed do not match.' +c endif +c 111 continue +c write (iout,*) 'nsup=',nsup,' nstart_sup=',nstart_sup, +c & ' nstart_seq=',nstart_seq +c endif + call init_int_table + call setup_var + if (ns.gt.0) then +C write (iout,'(/a,i3,a)') +C 'The chain contains',ns,' disulfide-bridging cysteines.' + write (iout,'(20i4)') (iss(i),i=1,ns) + if (dyn_ss) then + write(iout,*)"Running with dynamic disulfide-bond formation" + else + write (iout,'(/a/)') 'Pre-formed links are:' + do i=1,nss + i1=ihpb(i)-nres + i2=jhpb(i)-nres + it1=itype(i1) + it2=itype(i2) + write (iout,'(2a,i3,3a,i3,a,3f10.3)') + & restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')',dhpb(i), + & ebr,forcon(i) + enddo + write (iout,'(a)') + endif + endif + if (ns.gt.0.and.dyn_ss) then + do i=nss+1,nhpb + ihpb(i-nss)=ihpb(i) + jhpb(i-nss)=jhpb(i) + forcon(i-nss)=forcon(i) + dhpb(i-nss)=dhpb(i) + enddo + nhpb=nhpb-nss + nss=0 + call hpb_partition + do i=1,ns + dyn_ss_mask(iss(i))=.true. + enddo + endif +c Read distance restraints + if (constr_dist.gt.0) then + call read_dist_constr + call hpb_partition + endif + return + end +c----------------------------------------------------------------------------- + logical function seq_comp(itypea,itypeb,length) + implicit none + integer length,itypea(length),itypeb(length) + integer i + do i=1,length + if (itypea(i).ne.itypeb(i)) then + seq_comp=.false. + return + endif + enddo + seq_comp=.true. + return + end +c----------------------------------------------------------------------------- + subroutine read_bridge +C Read information about disulfide bridges. + implicit 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.TIME1' +#ifdef MPL + include 'COMMON.INFO' +#endif + integer i,j +C Read bridging residues. + read (inp,*) ns,(iss(i),i=1,ns) +c print *,'ns=',ns +C Check whether the specified bridging residues are cystines. + do i=1,ns + if (itype(iss(i)).ne.1) then + 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 MPL + call mp_stopall(error_msg) +#else + stop +#endif + endif + enddo +C Read preformed bridges. + if (ns.gt.0) then + read (inp,*) nss,(ihpb(i),jhpb(i),i=1,nss) + if (nss.gt.0) then + nhpb=nss +C Check if the residues involved in bridges are in the specified list of +C bridging residues. + do i=1,nss + do j=1,i-1 + if (ihpb(i).eq.ihpb(j).or.ihpb(i).eq.jhpb(j) + & .or.jhpb(i).eq.ihpb(j).or.jhpb(i).eq.jhpb(j)) then + write (iout,'(a,i3,a)') 'Disulfide pair',i, + & ' contains residues present in other pairs.' + write (*,'(a,i3,a)') 'Disulfide pair',i, + & ' contains residues present in other pairs.' +#ifdef MPL + call mp_stopall(error_msg) +#else + 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 +C dhpb(i)=dbr +C forcon(i)=fbr + enddo + do i=1,nss + ihpb(i)=ihpb(i)+nres + jhpb(i)=jhpb(i)+nres + enddo + endif + endif + return + end +c---------------------------------------------------------------------------- + subroutine read_angles(kanal,*) + implicit none + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + integer i,kanal + 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 + theta(i)=deg2rad*theta(i) + phi(i)=deg2rad*phi(i) + alph(i)=deg2rad*alph(i) + omeg(i)=deg2rad*omeg(i) + enddo + return + 10 return1 + end +c---------------------------------------------------------------------------- + subroutine reada(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch + double precision wartosc,default + integer ilen,iread + external ilen + iread=index(rekord,lancuch) + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*) wartosc + return + end +c---------------------------------------------------------------------------- + subroutine multreada(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + double precision tablica(dim),default + character*(*) rekord,lancuch + integer ilen,iread + external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch) + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end +c---------------------------------------------------------------------------- + subroutine readi(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch + integer wartosc,default + integer ilen,iread + external ilen + iread=index(rekord,lancuch) + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*) wartosc + return + end +C---------------------------------------------------------------------- + subroutine multreadi(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + integer tablica(dim),default + character*(*) rekord,lancuch + character*80 aux + integer ilen,iread + external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end + +c---------------------------------------------------------------------------- + subroutine card_concat(card) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + character*(*) card + character*80 karta,ucase + external ilen + read (inp,'(a)') karta + karta=ucase(karta) + card=' ' + do while (karta(80:80).eq.'&') + card=card(:ilen(card)+1)//karta(:79) + read (inp,'(a)') karta + karta=ucase(karta) + enddo + card=card(:ilen(card)+1)//karta + return + end +c---------------------------------------------------------------------------- + subroutine openunits + implicit none + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + character*3 liczba + include "COMMON.MPI" +#endif + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + integer lenpre,lenpot,ilen + external ilen + character*16 cformat,cprint + character*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) +C 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') +C 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') +#ifndef NEWCORR + call getenv('TORDPAR',tordname) + open (itordp,file=tordname,status='old') +#endif + 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") + call getenv('LIPTRANPAR',liptranname) + open (iliptranpar,file=liptranname,status='old') +#ifndef OLDSCP +C +C 8/9/01 In the newest version SCp interaction constants are read from a file +C Use -DOLDSCP to use hard-coded constants instead. +C + call getenv('SCPPAR',scpname) + open (iscpp,file=scpname,status='old') +#endif + return + end +c-------------------------------------------------------------------------- + subroutine read_dist_constr + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.SBRIDGE' + include 'COMMON.INTERACT' + integer ifrag_(2,100),ipair_(2,100) + double precision wfrag_(100),wpair_(100) + character*500 controlcard + logical lprn /.true./ + logical normalize,next + integer restr_type + double precision scal_bfac + double precision xlink(4,0:4) / +c a b c sigma + & 0.0d0,0.0d0,0.0d0,0.0d0, ! default, no xlink potential + & 0.00305218d0,9.46638d0,4.68901d0,4.74347d0, ! ZL + & 0.00214928d0,12.7517d0,0.00375009d0,6.13477d0, ! ADH + & 0.00184547d0,11.2678d0,0.00140292d0,7.00868d0, ! PDH + & 0.000161786d0,6.29273d0,4.40993d0,7.13956d0 / ! DSS + write (iout,*) "Calling read_dist_constr" +c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup +c call flush(iout) + next=.true. + + DO WHILE (next) + + call card_concat(controlcard) + next = index(controlcard,"NEXT").gt.0 + call readi(controlcard,"RESTR_TYPE",restr_type,constr_dist) + write (iout,*) "restr_type",restr_type + call readi(controlcard,"NFRAG",nfrag_,0) + 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 reada(controlcard,'SCAL_BFAC',scal_bfac,1.0d0) + if (restr_type.eq.10) + & call reada(controlcard,'WBOLTZD',wboltzd,0.591d0) + if (restr_type.eq.12) + & call reada(controlcard,'SCAL_PEAK',scal_peak,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) + normalize = index(controlcard,"NORMALIZE").gt.0 + write (iout,*) "WBOLTZD",wboltzd + write (iout,*) "SCAL_PEAK",scal_peak + 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 (nfrag_.gt.0 .or. restr_type.eq.4 .or. restr_type.eq.5) then + nres0=nres + read(inp,'(a)') pdbfile + write (iout,*) + & "Distance restraints will be constructed from structure ",pdbfile + open(ipdbin,file=pdbfile,status='old',err=11) + call readpdb(.true.) + nres=nres0 + close(ipdbin) + endif + do i=1,nfrag_ + if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup + if (ifrag_(2,i).gt.nstart_sup+nsup-1) + & ifrag_(2,i)=nstart_sup+nsup-1 +c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) +c call flush(iout) + if (wfrag_(i).eq.0.0d0) cycle + do j=ifrag_(1,i),ifrag_(2,i)-1 + do k=j+1,ifrag_(2,i) +c write (iout,*) "j",j," k",k + ddjk=dist(j,k) + if (restr_type.eq.1) then + nhpb=nhpb+1 + irestr_type(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 + irestr_type(nhpb)=1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i) + endif + else if (restr_type.eq.3) then + nhpb=nhpb+1 + irestr_type(nhpb)=1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) + endif + write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) + enddo + enddo + enddo + do i=1,npair_ + if (wpair_(i).eq.0.0d0) cycle + 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) + ddjk=dist(j,k) + if (restr_type.eq.1) then + nhpb=nhpb+1 + irestr_type(nhpb)=1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wpair_(i) + else if (constr_dist.eq.2) then + if (ddjk.le.dist_cut) then + nhpb=nhpb+1 + irestr_type(nhpb)=1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wpair_(i) + endif + else if (restr_type.eq.3) then + nhpb=nhpb+1 + irestr_type(nhpb)=1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wpair_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) + endif + write (iout,'(a,3i5,f8.2,f10.1)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) + enddo + enddo + enddo + +c print *,ndist_ + write (iout,*) "Distance restraints as read from input" + do i=1,ndist_ + if (restr_type.eq.12) then + read (inp,*) ihpb_peak(nhpb_peak+1),jhpb_peak(nhpb_peak+1), + & dhpb_peak(nhpb_peak+1),dhpb1_peak(nhpb_peak+1), + & ibecarb_peak(nhpb_peak+1),forcon_peak(nhpb_peak+1), + & fordepth_peak(nhpb_peak+1),npeak +c write(iout,*) ihpb_peak(nhpb_peak+1),jhpb_peak(nhpb_peak+1), +c & dhpb_peak(nhpb_peak+1),dhpb1_peak(nhpb_peak+1), +c & ibecarb_peak(nhpb_peak+1),forcon_peak(nhpb_peak+1), +c & fordepth_peak(nhpb_peak+1),npeak + if (forcon_peak(nhpb_peak+1).le.0.0d0.or. + & fordepth_peak(nhpb_peak+1).le.0.0d0)cycle + nhpb_peak=nhpb_peak+1 + irestr_type_peak(nhpb_peak)=12 + if (ipeak(1,npeak).eq.0) ipeak(1,npeak)=i + ipeak(2,npeak)=i + write (iout,'(a,5i5,2f8.2,2f10.5,i5)') "+dist.restr ", + & nhpb_peak,ihpb_peak(nhpb_peak),jhpb_peak(nhpb_peak), + & ibecarb_peak(nhpb_peak),npeak,dhpb_peak(nhpb_peak), + & dhpb1_peak(nhpb_peak),forcon_peak(nhpb_peak), + & fordepth_peak(nhpb_peak),irestr_type_peak(nhpb_peak) + if (ibecarb_peak(nhpb_peak).eq.3) then + jhpb_peak(nhpb_peak)=jhpb_peak(nhpb_peak)+nres + else if (ibecarb_peak(nhpb_peak).eq.2) then + ihpb_peak(nhpb_peak)=ihpb_peak(nhpb_peak)+nres + else if (ibecarb_peak(nhpb_peak).eq.1) then + ihpb_peak(nhpb_peak)=ihpb_peak(nhpb_peak)+nres + jhpb_peak(nhpb_peak)=jhpb_peak(nhpb_peak)+nres + endif + else if (restr_type.eq.11) then + read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(nhpb+1), + & dhpb1(nhpb+1),ibecarb(i),forcon(nhpb+1),fordepth(nhpb+1) +c fordepth(nhpb+1)=fordepth(nhpb+1)/forcon(nhpb+1) + if (forcon(nhpb+1).le.0.0d0.or.fordepth(nhpb+1).le.0.0d0)cycle + nhpb=nhpb+1 + irestr_type(nhpb)=11 + write (iout,'(a,4i5,2f8.2,2f10.5,i5)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb), + & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),irestr_type(nhpb) +c if (ibecarb(nhpb).gt.0) then +c ihpb(nhpb)=ihpb(nhpb)+nres +c jhpb(nhpb)=jhpb(nhpb)+nres +c endif + if (ibecarb(nhpb).eq.3) then + ihpb(nhpb)=ihpb(nhpb)+nres + else if (ibecarb(nhpb).eq.2) then + ihpb(nhpb)=ihpb(nhpb)+nres + else if (ibecarb(nhpb).eq.1) then + ihpb(nhpb)=ihpb(nhpb)+nres + jhpb(nhpb)=jhpb(nhpb)+nres + endif + else if (restr_type.eq.10) then +c Cross-lonk Markov-like potential + call card_concat(controlcard) + call readi(controlcard,"ILINK",ihpb(nhpb+1),0) + call readi(controlcard,"JLINK",jhpb(nhpb+1),0) + ibecarb(nhpb+1)=0 + if (index(controlcard,"BETA").gt.0) ibecarb(nhpb+1)=1 + if (ihpb(nhpb+1).eq.0 .or. jhpb(nhpb+1).eq.0) cycle + if (index(controlcard,"ZL").gt.0) then + link_type=1 + else if (index(controlcard,"ADH").gt.0) then + link_type=2 + else if (index(controlcard,"PDH").gt.0) then + link_type=3 + else if (index(controlcard,"DSS").gt.0) then + link_type=4 + else + link_type=0 + endif + call reada(controlcard,"AXLINK",dhpb(nhpb+1), + & xlink(1,link_type)) + call reada(controlcard,"BXLINK",dhpb1(nhpb+1), + & xlink(2,link_type)) + call reada(controlcard,"CXLINK",fordepth(nhpb+1), + & xlink(3,link_type)) + call reada(controlcard,"SIGMA",forcon(nhpb+1), + & xlink(4,link_type)) + call reada(controlcard,"SCORE",xlscore(nhpb+1),1.0d0) +c read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),ibecarb(nhpb+1), +c & dhpb(nhpb+1),dhpb1(nhpb+1),forcon(nhpb+1),fordepth(nhpb+1) + if (forcon(nhpb+1).le.0.0d0 .or. + & (dhpb(nhpb+1).eq.0 .and. dhpb1(nhpb+1).eq.0)) cycle + nhpb=nhpb+1 + irestr_type(nhpb)=10 +c if (ibecarb(nhpb).gt.0) then +c ihpb(nhpb)=ihpb(nhpb)+nres +c jhpb(nhpb)=jhpb(nhpb)+nres +c endif + if (ibecarb(nhpb).eq.3) then + jhpb(nhpb)=jhpb(nhpb)+nres + else if (ibecarb(nhpb).eq.2) then + ihpb(nhpb)=ihpb(nhpb)+nres + else if (ibecarb(nhpb).eq.1) then + ihpb(nhpb)=ihpb(nhpb)+nres + jhpb(nhpb)=jhpb(nhpb)+nres + endif + write (iout,'(a,4i5,2f8.2,3f10.5,i5)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb), + & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),xlscore(nhpb), + & irestr_type(nhpb) + else +C print *,"in else" + read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(nhpb+1), + & dhpb1(nhpb+1),ibecarb(nhpb+1),forcon(nhpb+1) + if (forcon(nhpb+1).gt.0.0d0) then + nhpb=nhpb+1 + if (dhpb1(nhpb).eq.0.0d0) then + irestr_type(nhpb)=1 + else + irestr_type(nhpb)=2 + endif +c if (ibecarb(nhpb).gt.0) then +c ihpb(nhpb)=ihpb(nhpb)+nres +c jhpb(nhpb)=jhpb(nhpb)+nres +c endif + if (ibecarb(nhpb).eq.3) then + jhpb(nhpb)=jhpb(nhpb)+nres + else if (ibecarb(nhpb).eq.2) then + ihpb(nhpb)=ihpb(nhpb)+nres + else if (ibecarb(nhpb).eq.1) then + ihpb(nhpb)=ihpb(nhpb)+nres + jhpb(nhpb)=jhpb(nhpb)+nres + endif + if (dhpb(nhpb).eq.0.0d0) + & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) + endif + write (iout,'(a,4i5,f8.2,f10.1)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(i),dhpb(nhpb),forcon(nhpb) + endif +C read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),forcon(nhpb+1) +C if (forcon(nhpb+1).gt.0.0d0) then +C nhpb=nhpb+1 +C dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) + enddo + + if (restr_type.eq.4) then + write (iout,*) "The BFAC array" + do i=nnt,nct + write (iout,'(i5,f10.5)') i,bfac(i) + enddo + do i=nnt,nct + if (itype(i).eq.ntyp1) cycle + do j=nnt,i-1 + if (itype(j).eq.ntyp1) cycle + if (itype(i).eq.10) then + iiend=0 + else + iiend=1 + endif + if (itype(j).eq.10) then + jjend=0 + else + jjend=1 + endif + kk=0 + do ii=0,iiend + do jj=0,jjend + nhpb=nhpb+1 + irestr_type(nhpb)=1 + forcon(nhpb)=scal_bfac**2/(bfac(i)**2+bfac(j)**2) + irestr_type(nhpb)=1 + ibecarb(nhpb)=kk + if (ibecarb(nhpb).gt.0) ibecarb(nhpb)=4-ibecarb(nhpb) + ihpb(nhpb)=i+nres*ii + jhpb(nhpb)=j+nres*jj + dhpb(nhpb)=dist(i+nres*ii,j+nres*jj) + write (iout,'(a,4i5,2f8.2,3f10.5,i5)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb), + & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),xlscore(nhpb), + & irestr_type(nhpb) + kk=kk+1 + enddo + enddo + enddo + enddo + endif + + if (restr_type.eq.5) then + restr_on_coord=.true. + do i=nnt,nct + if (itype(i).eq.ntyp1) cycle + bfac(i)=(scal_bfac/bfac(i))**2 + enddo + endif + + ENDDO ! next + + fordepthmax=0.0d0 + if (normalize) then + do i=nss+1,nhpb + if (irestr_type(i).eq.11.and.fordepth(i).gt.fordepthmax) + & fordepthmax=fordepth(i) + enddo + do i=nss+1,nhpb + if (irestr_type(i).eq.11) fordepth(i)=fordepth(i)/fordepthmax + enddo + endif + if (nhpb.gt.nss) then + write (iout,'(/a,i5,a/4a5,2a8,3a10,a5)') + & "The following",nhpb-nss, + & " distance restraints have been imposed:", + & " Nr"," res1"," res2"," beta"," d1"," d2"," k"," V", + & " score"," type" + do i=nss+1,nhpb + write (iout,'(4i5,2f8.2,3f10.5,i5)')i-nss,ihpb(i),jhpb(i), + & ibecarb(i),dhpb(i),dhpb1(i),forcon(i),fordepth(i),xlscore(i), + & irestr_type(i) + enddo + endif + call hpb_partition + call flush(iout) + return + 11 write (iout,*)"read_dist_restr: error reading reference structure" + stop + end +c------------------------------------------------------------------------------- + subroutine read_saxs_constr + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.SBRIDGE' + include 'COMMON.SAXS' + double precision cm(3) +c read(inp,*) nsaxs + write (iout,*) "Calling read_saxs nsaxs",nsaxs + call flush(iout) + if (saxs_mode.eq.0) then +c SAXS distance distribution + do i=1,nsaxs + read(inp,*) distsaxs(i),Psaxs(i) + enddo + Cnorm = 0.0d0 + do i=1,nsaxs + Cnorm = Cnorm + Psaxs(i) + enddo + write (iout,*) "Cnorm",Cnorm + do i=1,nsaxs + Psaxs(i)=Psaxs(i)/Cnorm + enddo + write (iout,*) "Normalized distance distribution from SAXS" + do i=1,nsaxs + write (iout,'(f8.2,e15.5)') distsaxs(i),Psaxs(i) + enddo + Wsaxs0=0.0d0 + do i=1,nsaxs + Wsaxs0=Wsaxs0-Psaxs(i)*dlog(Psaxs(i)) + enddo + write (iout,*) "Wsaxs0",Wsaxs0 + else +c SAXS "spheres". + do i=1,nsaxs + read (inp,'(30x,3f8.3)') (Csaxs(j,i),j=1,3) + enddo + do j=1,3 + cm(j)=0.0d0 + enddo + do i=1,nsaxs + do j=1,3 + cm(j)=cm(j)+Csaxs(j,i) + enddo + enddo + do j=1,3 + cm(j)=cm(j)/nsaxs + enddo + do i=1,nsaxs + do j=1,3 + Csaxs(j,i)=Csaxs(j,i)-cm(j) + enddo + enddo + write (iout,*) "SAXS sphere coordinates" + do i=1,nsaxs + write (iout,'(i5,3f10.5)') i,(Csaxs(j,i),j=1,3) + enddo + endif + return + end diff --git a/source/cluster/wham/src-HCD/refsys.f b/source/cluster/wham/src-HCD/refsys.f new file mode 100644 index 0000000..4b7b763 --- /dev/null +++ b/source/cluster/wham/src-HCD/refsys.f @@ -0,0 +1,70 @@ + subroutine refsys(i2,i3,i4,e1,e2,e3,fail) +c This subroutine calculates unit vectors of a local reference system +c defined by atoms (i2), (i3), and (i4). The x axis is the axis from + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include "COMMON.CHAIN" +c this subroutine calculates unity vectors of a local reference system +c defined by atoms (i2), (i3), and (i4). the x axis is the axis from +c atom (i3) to atom (i2), and the xy plane is the plane defined by atoms +c (i2), (i3), and (i4). z axis is directed according to the sign of the +c vector product (i3)-(i2) and (i3)-(i4). sets fail to .true. if atoms +c (i2) and (i3) or (i3) and (i4) coincide or atoms (i2), (i3), and (i4) +c form a linear fragment. returns vectors e1, e2, and e3. + logical fail + double precision e1(3),e2(3),e3(3) + double precision u(3),z(3) + double precision coinc/1.0D-13/,align /1.0D-13/ +c print *,'just initialize' + fail=.false. +c print *,fail + s1=0.0 + s2=0.0 + print *,s1,s2 + do 1 i=1,3 + print *, i2,i3,i4 + zi=c(i,i2)-c(i,i3) + ui=c(i,i4)-c(i,i3) + print *,zi,ui + s1=s1+zi*zi + s2=s2+ui*ui + z(i)=zi + 1 u(i)=ui + s1=sqrt(s1) + s2=sqrt(s2) + if (s1.gt.coinc) goto 2 + write (iout,1000) i2,i3,i1 + fail=.true. + return + 2 if (s2.gt.coinc) goto 4 + write(iout,1000) i3,i4,i1 + fail=.true. + return + print *,'two if pass' + 4 s1=1.0/s1 + s2=1.0/s2 + v1=z(2)*u(3)-z(3)*u(2) + v2=z(3)*u(1)-z(1)*u(3) + v3=z(1)*u(2)-z(2)*u(1) + anorm=sqrt(v1*v1+v2*v2+v3*v3) + if (anorm.gt.align) goto 6 + write (iout,1010) i2,i3,i4,i1 + fail=.true. + return + 6 anorm=1.0/anorm + e3(1)=v1*anorm + e3(2)=v2*anorm + e3(3)=v3*anorm + e1(1)=z(1)*s1 + e1(2)=z(2)*s1 + e1(3)=z(3)*s1 + e2(1)=e1(3)*e3(2)-e1(2)*e3(3) + e2(2)=e1(1)*e3(3)-e1(3)*e3(1) + e2(3)=e1(2)*e3(1)-e1(1)*e3(2) + 1000 format (/1x,' * * * Error - atoms',i4,' and',i4,' coincide.', + 1 'coordinates of atom',i4,' are set to zero.') + 1010 format (/1x,' * * * Error - atoms',2(i4,2h, ),i4,' form a linear', + 1 ' fragment. coordinates of atom',i4,' are set to zero.') + return + end diff --git a/source/cluster/wham/src-HCD/rescode.f b/source/cluster/wham/src-HCD/rescode.f new file mode 100644 index 0000000..fb68350 --- /dev/null +++ b/source/cluster/wham/src-HCD/rescode.f @@ -0,0 +1,31 @@ + integer function rescode(iseq,nam,itype) + include 'DIMENSIONS' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + character*3 nam,ucase + + if (itype.eq.0) then + + do i=-ntyp1,ntyp1 + if (ucase(nam).eq.restyp(i)) then + rescode=i + return + endif + enddo + + else + + do i=-ntyp1,ntyp1 + if (nam(1:1).eq.onelet(i)) then + rescode=i + return + endif + enddo + + endif + + write (iout,10) iseq,nam + stop + 10 format ('**** Error - residue',i4,' has an unresolved name ',a3) + end + diff --git a/source/cluster/wham/src-HCD/rmscalc.F b/source/cluster/wham/src-HCD/rmscalc.F new file mode 100644 index 0000000..6da72c9 --- /dev/null +++ b/source/cluster/wham/src-HCD/rmscalc.F @@ -0,0 +1,208 @@ + double precision function rmscalc(ccc,cccref,przes_min,obrot_min, + & ipermmin) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + double precision cccref(3,maxres2),creff(3,maxres2), + & ccc(3,maxres2),cc(3,maxres2) + double precision przes(3),obrot(3,3),przes_min(3),obrot_min(3,3) + logical non_conv + integer i,ii,j,ib,ichain,indchain,ichain1,ichain2, + & iperm,ipermmin + double precision rms,rmsmin +C Loop over chain permutations + rmsmin=1.0d10 + DO IPERM=1,NPERMCHAIN + ii=0 + if (iz_sc.lt.2) then + do ichain=1,nchain + indchain=tabpermchain(ichain,iperm) +#ifdef DEBUG + write (iout,*) "ichain",ichain," indchain",indchain + write (iout,*) "chain_border",chain_border(1,ichain), + & chain_border(2,ichain) + write (iout,*) "chain_length",chain_length(ichain) + write (iout,*) "nstart_sup",nstart_sup," nend_sup",nend_sup +#endif + do i=1,chain_length(ichain) +c do i=nstart_sup(ichain),nend_sup(ichain) + ichain1=chain_border(1,ichain)+i-1 + ichain2=chain_border(1,indchain)+i-1 + if (ichain1.lt.nstart_sup .or. ichain1.gt.nend_sup .or. + & ichain2.lt.nstart_sup .or. ichain2.gt.nend_sup) cycle + ii=ii+1 +#ifdef DEBUG + write (iout,*) "back",ii," ichain1",ichain1, + & " ichain2",ichain2," i",i,chain_border(1,ichain)+i-1 +#endif + do j=1,3 + cc(j,ii)=ccc(j,ichain2) + creff(j,ii)=cccref(j,ichain1) + enddo +#ifdef DEBUG + write (iout,'(3f10.5,5x,3f10.5)') + & (cc(j,ii),j=1,3),(creff(j,ii),j=1,3) +#endif + enddo + enddo + endif + if (iz_sc.gt.0) then + do ichain=1,nchain + indchain=tabpermchain(ichain,iperm) + do i=1,chain_length(ichain) +c do i=nstart_sup(ichain),nend_sup(ichain) + ichain1=chain_border(1,ichain)+i-1 + ichain2=chain_border(1,indchain)+i-1 + if (ichain1.lt.nstart_sup .or. ichain1.gt.nend_sup .or. + & ichain2.lt.nstart_sup .or. ichain2.gt.nend_sup) cycle + if (itype(ichain1).ne.10) then + ii=ii+1 +#ifdef DEBUG + write (iout,*) "side",ii," ichain1",ichain1, + & " ichain2",ichain2 +#endif + do j=1,3 + cc(j,ii)=ccc(j,ichain2+nres) + creff(j,ii)=cccref(j,ichain1+nres) + enddo +#ifdef DEBUG + write (iout,'(3f10.5,5x,3f10.5)') + & (cc(j,ii),j=1,3),(creff(j,ii),j=1,3) +#endif + endif + enddo + enddo + endif +c write (iout,*) "rmscalc: iprot",iprot," nsup",nsup(iprot)," ii",ii + call fitsq(rms,cc(1,1),creff(1,1),ii,przes,obrot,non_conv) + if (non_conv) then + write (iout,*) 'Error: FITSQ non-convergent' + rms=1.0d2 + else if (rms.lt.-1.0d-6) then + print *,'Error: rms^2 = ',rms + rms = 1.0d2 + else if (rms.ge.1.0d-6 .and. rms.lt.0) then + rmscalc=0.0d0 + else + rms = dsqrt(rms) + endif + if (rms.lt.rmsmin) then + rmsmin=rms + ipermmin=iperm + przes_min=przes + obrot_min=obrot + endif +#ifdef DEBUG + write (iout,*) "iperm",iperm," rms",rms +#endif + ENDDO + rmscalc=rmsmin +#ifdef DEBUG + write (iout,*) "ipermmin",ipermmin," rmsmin",rmsmin +#endif + return + end +c------------------------------------------------------------------------ + double precision function rmscalc_thet(ttheta,theta_reff, + & iperm) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + integer iperm,k,ichain,indchain,kchain1,kchain2,nnnn + double precision ttheta(maxres),theta_reff(maxres),rmsthet,dtheta + rmsthet = 0.0d0 + nnnn=0 + do ichain=1,nchain + indchain=tabpermchain(ichain,iperm) +c write (iout,*) "ichain",ichain," iperm",iperm, +c & " indchain",indchain + call flush(iout) + do k=3,chain_length(ichain) + kchain1=chain_border(1,ichain)+k-1 + kchain2=chain_border(1,indchain)+k-1 + nnnn=nnnn+1 + dtheta = ttheta(kchain2)-theta_reff(kchain1) +c write (iout,*) k,theta(k),theta_ref(k,iref,ib,iprot), +c & dtheta + rmsthet = rmsthet+dtheta*dtheta + enddo + enddo + nnnn=nnnn-1 + rmsthet=dsqrt(rmsthet/nnnn) +#ifdef DEBUG + write (iout,*) "nnnn",nnnn," rmsthet",rmsthet +#endif + rmscalc_thet=rmsthet + return + end +c------------------------------------------------------------------------ + double precision function rmscalc_phi(pphi,phi_reff,iperm) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + integer iperm,k,ichain,indchain,kchain1,kchain2,nnnn + double precision pphi(maxres),phi_reff(maxres),rmsphi,dphi + double precision pinorm + rmsphi = 0.0d0 + nnnn=0 + do ichain=1,nchain + indchain=tabpermchain(ichain,iperm) + do k=4,chain_length(ichain) + kchain1=chain_border(1,ichain)+k-1 + kchain2=chain_border(1,indchain)+k-1 + nnnn=nnnn+1 + dphi=pinorm(pphi(kchain2)-phi_reff(kchain1)) +c write (iout,*) k,phi(k),phi_ref(k,iref,ib,iprot), +c & pinorm(phi(k)-phi_ref(k,iref,ib,iprot)) + rmsphi = rmsphi + dphi*dphi + enddo + enddo + nnnn=nnnn-1 + rmsphi=dsqrt(rmsphi/nnnn) +#ifdef DEBUG + write (iout,*) "nnnn",nnnn," rmsphi",rmsphi +#endif + rmscalc_phi=rmsphi + return + end +c------------------------------------------------------------------------ + double precision function rmscalc_side(xxtabb,yytabb,zztabb, + & xxreff,yyreff,zzreff,iperm) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + integer iperm,k,ichain,indchain,kchain1,kchain2,nnnn + double precision xxtabb(maxres),yytabb(maxres),zztabb(maxres), + & xxreff(maxres),yyreff(maxres),zzreff(maxres),rmsside, + & dxref,dyref,dzref + rmsside = 0.0d0 + nnnn=0 + do ichain=1,nchain + indchain=tabpermchain(ichain,iperm) + do k=1,chain_length(ichain) + kchain1=chain_border(1,ichain)+k-1 + kchain2=chain_border(1,indchain)+k-1 + if (itype(kchain1).eq.ntyp1) cycle + nnnn=nnnn+1 + dxref = xxtabb(kchain2)-xxreff(kchain1) + dyref = yytabb(kchain2)-yyreff(kchain1) + dzref = zztabb(kchain2)-zzreff(kchain1) + rmsside = rmsside + dxref*dxref+dyref*dyref+dzref*dzref + enddo + enddo + rmsside=dsqrt(rmsside/nnnn) + rmscalc_side=rmsside + return + end diff --git a/source/cluster/wham/src-HCD/rmsnat.f b/source/cluster/wham/src-HCD/rmsnat.f new file mode 100644 index 0000000..b2718d6 --- /dev/null +++ b/source/cluster/wham/src-HCD/rmsnat.f @@ -0,0 +1,48 @@ + double precision function rmsnat(jcon) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + integer ipermmin + double precision przes(3),obrot(3,3) + rmsnat=rmscalc(c(1,1),cref_pdb(1,1),przes,obrot,ipermmin) + return + end +c----------------------------------------------------------------------------- + double precision function gyrate() + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.INTERACT' + include 'COMMON.CHAIN' + double precision cen(3),rg + + do j=1,3 + cen(j)=0.0d0 + enddo + + ii=0 + do i=nnt,nct + if (itype(i).eq.ntyp1) cycle + ii=ii+1 + do j=1,3 + cen(j)=cen(j)+c(j,i) + enddo + enddo + do j=1,3 + cen(j)=cen(j)/dble(ii) + enddo + rg = 0.0d0 + do i = nnt, nct + if (itype(i).eq.ntyp1) cycle + do j=1,3 + rg = rg + (c(j,i)-cen(j))**2 + enddo + end do + gyrate = dsqrt(rg/dble(ii)) + return + end diff --git a/source/cluster/wham/src-HCD/seq2chains.f b/source/cluster/wham/src-HCD/seq2chains.f new file mode 100644 index 0000000..cf38c87 --- /dev/null +++ b/source/cluster/wham/src-HCD/seq2chains.f @@ -0,0 +1,56 @@ + subroutine seq2chains(nres,itype,nchain,chain_length,chain_border, + & ireschain) +c +c Split the total UNRES sequence, which has dummy residues separating +c the chains, into separate chains. The length of chain ichain is +c contained in chain_length(ichain), the first and last non-dummy +c residues are in chain_border(1,ichain) and chain_border(2,ichain), +c respectively. The lengths pertain to non-dummy residues only. +c + implicit none + include 'DIMENSIONS' + integer nres,itype(nres),nchain,chain_length(nres), + & chain_border(2,nres),ireschain(nres) + integer ii,ichain,i,j + logical new_chain + ichain=1 + new_chain=.true. + chain_length(ichain)=0 + ii=1 + do while (ii.lt.nres) + if (itype(ii).eq.ntyp1) then + if (.not.new_chain) then + new_chain=.true. + chain_border(2,ichain)=ii-1 + ichain=ichain+1 + chain_border(1,ichain)=ii+1 + chain_length(ichain)=0 + endif + else + if (new_chain) then + chain_border(1,ichain)=ii + new_chain=.false. + endif + chain_length(ichain)=chain_length(ichain)+1 + endif + ii=ii+1 + enddo + if (itype(nres).eq.ntyp1) then + ii=ii-1 + else + chain_length(ichain)=chain_length(ichain)+1 + endif + if (chain_length(ichain).gt.0) then + chain_border(2,ichain)=ii + nchain=ichain + else + nchain=ichain-1 + endif + ireschain=0 + do i=1,nchain + do j=chain_border(1,i),chain_border(2,i) + ireschain(j)=i + enddo + enddo + return + end diff --git a/source/cluster/wham/src-HCD/setup_var.f b/source/cluster/wham/src-HCD/setup_var.f new file mode 100644 index 0000000..6937fc2 --- /dev/null +++ b/source/cluster/wham/src-HCD/setup_var.f @@ -0,0 +1,31 @@ + subroutine setup_var + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' +C Set up variable list. + ntheta=nres-2 + nphi=nres-3 + nvar=ntheta+nphi + nside=0 + do i=2,nres-1 + if (itype(i).ne.10) then + nside=nside+1 + ialph(i,1)=nvar+nside + ialph(nside,2)=i + endif + enddo + if (indphi.gt.0) then + nvar=nphi + else if (indback.gt.0) then + nvar=nphi+ntheta + else + nvar=nvar+2*nside + endif +cd write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1) + return + end diff --git a/source/cluster/wham/src-HCD/sizesclu.dat b/source/cluster/wham/src-HCD/sizesclu.dat new file mode 100644 index 0000000..7d0d666 --- /dev/null +++ b/source/cluster/wham/src-HCD/sizesclu.dat @@ -0,0 +1,37 @@ +****************************************************************** +* +* Array dimensions for the clustering programs: +* +* Max. number of conformations in the data set. +* + integer maxconf,maxstr_proc + PARAMETER (MAXCONF=8000) + parameter (maxstr_proc=maxconf/2) +* +* Max. number of "distances" between conformations. +* + integer MAXDIST + 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 maxgr + PARAMETER (MAXGR=maxstr_proc) +* +* Max. number of conformations in a cluster. Remark above applies also here. +* + integer maxingr + PARAMETER (MAXINGR=maxstr_proc) +* +* Max. number of cut-off values +* + integer max_cut + PARAMETER (MAX_CUT=5) +* +* Max. number of properties +* + integer maxprop + PARAMETER (MAXPROP=5) +* +******************************************************************* diff --git a/source/cluster/wham/src-HCD/srtclust.f b/source/cluster/wham/src-HCD/srtclust.f new file mode 100644 index 0000000..5d8b064 --- /dev/null +++ b/source/cluster/wham/src-HCD/srtclust.f @@ -0,0 +1,117 @@ + SUBROUTINE SRTCLUST(ICUT,NCON,IB) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.CLUSTER' + include 'COMMON.FREE' + include 'COMMON.IOUNITS' + double precision prob(maxgr) +c +c Compute free energies of clusters +c + 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 +c write (iout,*) "igr",igr," totfree",emin, +c & " totfree_gr",totfree_gr(igr) + totfree_gr(igr)=emin-dlog(totfree_gr(igr)) +c write (iout,*) igr," efree",totfree_gr(igr)/beta_h(ib) + enddo +C +C SORT CONFORMATIONS IN GROUPS ACC. TO ENERGY +C + 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 +C +C SORT GROUPS +C + 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 + 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) +c write (iout,*) icut,i,iass(i),iass_tot(i,icut) + enddo + endif + return + end +c---------------------------------------------------------------------- + SUBROUTINE WRITE_STATS(ICUT,NCON,IB) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + include 'COMMON.CLUSTER' + include 'COMMON.FREE' + include 'COMMON.IOUNITS' + double precision prob(maxgr) + write (iout, + & '("Free energies, probabilities and rmsds 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,'(/7x,4a20)') " RMSD","TMscore","GDT_TS","GDT_HA" + write(iout,'(a5,2x,a6,10a10)')"clust","efree","cl.ave.", + & "ave.str.", + & "cl.ave.","ave.str","cl.ave","ave.str.","cl.ave","ave.str.", + & "prob","sumprob" + do i=1,ngr + sumprob=sumprob+prob(i) + write (iout,'(i3,2x,f8.1,2f10.3,6f10.4,2f10.4)') + & i,totfree_gr(i)/beta_h(ib), + & rmsave(i),rms_closest(i),tmscore_ave(i),tmscore_closest(i), + & gdt_ts_ave(i),gdt_ts_closest(i),gdt_ha_ave(i), + & gdt_ha_closest(i),prob(i),sumprob + enddo + RETURN + END diff --git a/source/cluster/wham/src-HCD/ssMD.F b/source/cluster/wham/src-HCD/ssMD.F new file mode 100644 index 0000000..9c23fe0 --- /dev/null +++ b/source/cluster/wham/src-HCD/ssMD.F @@ -0,0 +1,2178 @@ +c---------------------------------------------------------------------------- + subroutine check_energies +c implicit none + +c Includes + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.SBRIDGE' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + +c External functions + double precision ran_number + external ran_number + +c Local variables + integer i,j,k,l,lmax,p,pmax + double precision rmin,rmax + double precision eij + + double precision d + double precision wi,rij,tj,pj + + +c return + + i=5 + j=14 + + d=dsc(1) + rmin=2.0D0 + rmax=12.0D0 + + lmax=10000 + pmax=1 + + do k=1,3 + c(k,i)=0.0D0 + c(k,j)=0.0D0 + c(k,nres+i)=0.0D0 + c(k,nres+j)=0.0D0 + enddo + + do l=1,lmax + +ct wi=ran_number(0.0D0,pi) +c wi=ran_number(0.0D0,pi/6.0D0) +c wi=0.0D0 +ct tj=ran_number(0.0D0,pi) +ct pj=ran_number(0.0D0,pi) +c pj=ran_number(0.0D0,pi/6.0D0) +c pj=0.0D0 + + do p=1,pmax +ct rij=ran_number(rmin,rmax) + + c(1,j)=d*sin(pj)*cos(tj) + c(2,j)=d*sin(pj)*sin(tj) + c(3,j)=d*cos(pj) + + c(3,nres+i)=-rij + + c(1,i)=d*sin(wi) + c(3,i)=-rij-d*cos(wi) + + do k=1,3 + dc(k,nres+i)=c(k,nres+i)-c(k,i) + dc_norm(k,nres+i)=dc(k,nres+i)/d + dc(k,nres+j)=c(k,nres+j)-c(k,j) + dc_norm(k,nres+j)=dc(k,nres+j)/d + enddo + + call dyn_ssbond_ene(i,j,eij) + enddo + enddo + + call exit(1) + + return + end + +C----------------------------------------------------------------------------- + + subroutine dyn_ssbond_ene(resi,resj,eij) +c implicit none + +c Includes + 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' + include 'COMMON.CALC' +#ifndef CLUST +#ifndef WHAM +C include 'COMMON.MD' +#endif +#endif + +c External functions + double precision h_base + external h_base + +c Input arguments + integer resi,resj + +c Output arguments + double precision eij + +c Local variables + logical havebond +c integer itypi,itypj,k,l + double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi + double precision sig0ij,ljd,sig,fac,e1,e2 + double precision dcosom1(3),dcosom2(3),ed + double precision pom1,pom2 + double precision ljA,ljB,ljXs + double precision d_ljB(1:3) + double precision ssA,ssB,ssC,ssXs + double precision ssxm,ljxm,ssm,ljm + double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3) + double precision f1,f2,h1,h2,hd1,hd2 + double precision omega,delta_inv,deltasq_inv,fac1,fac2 +c-------FIRST METHOD + double precision xm,d_xm(1:3) + integer xshift,yshift,zshift +c-------END FIRST METHOD +c-------SECOND METHOD +c$$$ double precision ss,d_ss(0:3),ljf,d_ljf(0:3) +c-------END SECOND METHOD + +c-------TESTING CODE + logical checkstop,transgrad + common /sschecks/ checkstop,transgrad + + integer icheck,nicheck,jcheck,njcheck + double precision echeck(-1:1),deps,ssx0,ljx0 +c-------END TESTING CODE + + + i=resi + j=resj + + itypi=itype(i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) + dsci_inv=vbld_inv(i+nres) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + xi=dmod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=dmod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=dmod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize +C define scaling factor for lipids + +C if (positi.le.0) positi=positi+boxzsize +C print *,i +C first for peptide groups +c for each residue check if it is in lipid or lipid water border area + if ((zi.gt.bordlipbot) + &.and.(zi.lt.bordliptop)) then +C the energy transfer exist + if (zi.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((positi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipi=sscalelip(fracinbuf) + ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick + elseif (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) + sslipi=sscalelip(fracinbuf) + ssgradlipi=sscagradlip(fracinbuf)/lipbufthick + else + sslipi=1.0d0 + ssgradlipi=0.0 + endif + else + sslipi=0.0d0 + ssgradlipi=0.0 + endif + + itypj=itype(j) + xj=c(1,nres+j) + yj=c(2,nres+j) + zj=c(3,nres+j) + xj=dmod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=dmod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=dmod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + if ((zj.gt.bordlipbot) + &.and.(zj.lt.bordliptop)) then +C the energy transfer exist + if (zj.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((positi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipj=sscalelip(fracinbuf) + ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick + elseif (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) + sslipj=sscalelip(fracinbuf) + ssgradlipj=sscagradlip(fracinbuf)/lipbufthick + else + sslipj=1.0d0 + ssgradlipj=0.0 + endif + else + sslipj=0.0d0 + ssgradlipj=0.0 + endif + aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +aa_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 + bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +bb_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 + + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + subchap=1 + endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif + + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + dscj_inv=vbld_inv(j+nres) + + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse +c The following are set in sc_angular +c erij(1)=xj*rij +c erij(2)=yj*rij +c erij(3)=zj*rij +c om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) +c om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) +c om12=dxi*dxj+dyi*dyj+dzi*dzj + call sc_angular + rij=1.0D0/rij ! Reset this so it makes sense + + sig0ij=sigma(itypi,itypj) + sig=sig0ij*dsqrt(1.0D0/sigsq) + + ljXs=sig-sig0ij + ljA=eps1*eps2rt**2*eps3rt**2 + ljB=ljA*bb + ljA=ljA*aa + ljxm=ljXs+(-2.0D0*aa/bb)**(1.0D0/6.0D0) + + ssXs=d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + ssA=akcm + ssB=akct*deltat12 + ssC=ss_depth + & +akth*(deltat1*deltat1+deltat2*deltat2) + & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi + ssxm=ssXs-0.5D0*ssB/ssA + +c-------TESTING CODE +c$$$c Some extra output +c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA +c$$$ ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) +c$$$ ssx0=ssB*ssB-4.0d0*ssA*ssC +c$$$ if (ssx0.gt.0.0d0) then +c$$$ ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA +c$$$ else +c$$$ ssx0=ssxm +c$$$ endif +c$$$ ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ", +c$$$ & ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12 +c$$$ return +c-------END TESTING CODE + +c-------TESTING CODE +c Stop and plot energy and derivative as a function of distance + if (checkstop) then + ssm=ssC-0.25D0*ssB*ssB/ssA + ljm=-0.25D0*ljB*bb/aa + if (ssm.lt.ljm .and. + & dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then + nicheck=1000 + njcheck=1 + deps=0.5d-7 + else + checkstop=.false. + endif + endif + if (.not.checkstop) then + nicheck=0 + njcheck=-1 + endif + + do icheck=0,nicheck + do jcheck=-1,njcheck + if (checkstop) rij=(ssxm-1.0d0)+ + & ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps +c-------END TESTING CODE + + if (rij.gt.ljxm) then + havebond=.false. + ljd=rij-ljXs + fac=(1.0D0/ljd)**expon + e1=fac*fac*aa + e2=fac*bb + eij=eps1*eps2rt*eps3rt*(e1+e2) +C write(iout,*) eij,'TU?1' + 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 +C write(iout,*) 'TU?2',ssc,ssd + ed=2*akcm*ssd+akct*deltat12 + pom1=akct*ssd + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + else + omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi + + d_ssxm(1)=0.5D0*akct/ssA + d_ssxm(2)=-d_ssxm(1) + d_ssxm(3)=0.0D0 + + d_ljxm(1)=sig0ij/sqrt(sigsq**3) + d_ljxm(2)=d_ljxm(1)*sigsq_om2 + d_ljxm(3)=d_ljxm(1)*sigsq_om12 + d_ljxm(1)=d_ljxm(1)*sigsq_om1 + +c-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE + xm=0.5d0*(ssxm+ljxm) + do k=1,3 + d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k)) + enddo + if (rij.lt.xm) then + havebond=.true. + ssm=ssC-0.25D0*ssB*ssB/ssA + d_ssm(1)=0.5D0*akct*ssB/ssA + d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) + d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) + d_ssm(3)=omega + f1=(rij-xm)/(ssxm-xm) + f2=(rij-ssxm)/(xm-ssxm) + h1=h_base(f1,hd1) + h2=h_base(f2,hd2) + eij=ssm*h1+Ht*h2 +C write(iout,*) eij,'TU?3' + 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/aa + d_ljm(1)=-0.5D0*bb/aa*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 +C write(iout,*) 'TU?4',ssA + delta_inv=1.0d0/(ljxm-xm) + deltasq_inv=delta_inv*delta_inv + fac=Ht*hd1-ljm*hd2 + fac1=deltasq_inv*fac*(ljxm-rij) + fac2=deltasq_inv*fac*(rij-xm) + ed=delta_inv*(ljm*hd2-Ht*hd1) + eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1) + eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2) + eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3) + endif +c-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE + +c-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE +c$$$ ssd=rij-ssXs +c$$$ ljd=rij-ljXs +c$$$ fac1=rij-ljxm +c$$$ fac2=rij-ssxm +c$$$ +c$$$ d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt) +c$$$ d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt) +c$$$ d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt) +c$$$ +c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA +c$$$ d_ssm(1)=0.5D0*akct*ssB/ssA +c$$$ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) +c$$$ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) +c$$$ d_ssm(3)=omega +c$$$ +c$$$ ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj) +c$$$ do k=1,3 +c$$$ d_ljm(k)=ljm*d_ljB(k) +c$$$ enddo +c$$$ ljm=ljm*ljB +c$$$ +c$$$ ss=ssA*ssd*ssd+ssB*ssd+ssC +c$$$ d_ss(0)=2.0d0*ssA*ssd+ssB +c$$$ d_ss(2)=akct*ssd +c$$$ d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega +c$$$ d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega +c$$$ d_ss(3)=omega +c$$$ +c$$$ ljf=bb(itypi,itypj)/aa(itypi,itypj) +c$$$ ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0) +c$$$ d_ljf(0)=ljf*2.0d0*ljB*fac1 +c$$$ do k=1,3 +c$$$ d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1- +c$$$ & 2.0d0*ljB*fac1*d_ljxm(k)) +c$$$ enddo +c$$$ ljf=ljm+ljf*ljB*fac1*fac1 +c$$$ +c$$$ f1=(rij-ljxm)/(ssxm-ljxm) +c$$$ f2=(rij-ssxm)/(ljxm-ssxm) +c$$$ h1=h_base(f1,hd1) +c$$$ h2=h_base(f2,hd2) +c$$$ eij=ss*h1+ljf*h2 +c$$$ delta_inv=1.0d0/(ljxm-ssxm) +c$$$ deltasq_inv=delta_inv*delta_inv +c$$$ fac=ljf*hd2-ss*hd1 +c$$$ ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac +c$$$ eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(1)-fac2*(d_ljxm(1))) +c$$$ eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(2)-fac2*(d_ljxm(2))) +c$$$ eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(3)-fac2*(d_ljxm(3))) +c$$$ +c$$$ havebond=.false. +c$$$ if (ed.gt.0.0d0) havebond=.true. +c-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE + + endif +C write(iout,*) 'havebond',havebond + if (havebond) then +#ifndef CLUST +#ifndef WHAM +c if (dyn_ssbond_ij(i,j).eq.1.0d300) then +c write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_E_FORM",totT,t_bath,i,j +c endif +#endif +#endif + dyn_ssbond_ij(i,j)=eij + else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then + dyn_ssbond_ij(i,j)=1.0d300 +#ifndef CLUST +#ifndef WHAM +c write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_E_BREAK",totT,t_bath,i,j +#endif +#endif + endif + +c-------TESTING CODE + if (checkstop) then + if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') + & "CHECKSTOP",rij,eij,ed + echeck(jcheck)=eij + endif + enddo + if (checkstop) then + write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps + endif + enddo + if (checkstop) then + transgrad=.true. + checkstop=.false. + endif +c-------END TESTING CODE + + do k=1,3 + dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij + dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij + enddo + do k=1,3 + gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + gvdwx(k,j)=gvdwx(k,j)+gg(k) + & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + enddo +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) +cgrad enddo +cgrad enddo + + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo + + return + end + +C----------------------------------------------------------------------------- + + double precision function h_base(x,deriv) +c A smooth function going 0->1 in range [0,1] +c It should NOT be called outside range [0,1], it will not work there. + implicit none + +c Input arguments + double precision x + +c Output arguments + double precision deriv + +c Local variables + double precision xsq + + +c Two parabolas put together. First derivative zero at extrema +c$$$ if (x.lt.0.5D0) then +c$$$ h_base=2.0D0*x*x +c$$$ deriv=4.0D0*x +c$$$ else +c$$$ deriv=1.0D0-x +c$$$ h_base=1.0D0-2.0D0*deriv*deriv +c$$$ deriv=4.0D0*deriv +c$$$ endif + +c Third degree polynomial. First derivative zero at extrema + h_base=x*x*(3.0d0-2.0d0*x) + deriv=6.0d0*x*(1.0d0-x) + +c Fifth degree polynomial. First and second derivatives zero at extrema +c$$$ xsq=x*x +c$$$ h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0) +c$$$ deriv=x-1.0d0 +c$$$ deriv=deriv*deriv +c$$$ deriv=30.0d0*xsq*deriv + + return + end + +c---------------------------------------------------------------------------- + + subroutine dyn_set_nss +c Adjust nss and other relevant variables based on dyn_ssbond_ij +c implicit none + +c Includes + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' +C include 'COMMON.SETUP' +#ifndef CLUST +#ifndef WHAM +C include 'COMMON.MD' +#endif +#endif + +c Local variables + double precision emin + integer i,j,imin + integer diff,allflag(maxdim),allnss, + & allihpb(maxdim),alljhpb(maxdim), + & newnss,newihpb(maxdim),newjhpb(maxdim) + logical found + integer i_newnss(1024),displ(0:1024) + integer g_newihpb(maxdim),g_newjhpb(maxdim),g_newnss + + allnss=0 + do i=1,nres-1 + do j=i+1,nres + if (dyn_ssbond_ij(i,j).lt.1.0d300) then + allnss=allnss+1 + allflag(allnss)=0 + allihpb(allnss)=i + alljhpb(allnss)=j + endif + enddo + enddo + +cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + + 1 emin=1.0d300 + do i=1,allnss + if (allflag(i).eq.0 .and. + & dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then + emin=dyn_ssbond_ij(allihpb(i),alljhpb(i)) + imin=i + endif + enddo + if (emin.lt.1.0d300) then + allflag(imin)=1 + do i=1,allnss + if (allflag(i).eq.0 .and. + & (allihpb(i).eq.allihpb(imin) .or. + & alljhpb(i).eq.allihpb(imin) .or. + & allihpb(i).eq.alljhpb(imin) .or. + & alljhpb(i).eq.alljhpb(imin))) then + allflag(i)=-1 + endif + enddo + goto 1 + endif + +cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + + newnss=0 + do i=1,allnss + if (allflag(i).eq.1) then + newnss=newnss+1 + newihpb(newnss)=allihpb(i) + newjhpb(newnss)=alljhpb(i) + endif + enddo + +#ifdef MPI + if (nfgtasks.gt.1)then + + call MPI_Reduce(newnss,g_newnss,1, + & MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) + call MPI_Gather(newnss,1,MPI_INTEGER, + & i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_newnss(i-1)+displ(i-1) + enddo + call MPI_Gatherv(newihpb,newnss,MPI_INTEGER, + & g_newihpb,i_newnss,displ,MPI_INTEGER, + & king,FG_COMM,IERR) + call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER, + & g_newjhpb,i_newnss,displ,MPI_INTEGER, + & king,FG_COMM,IERR) + if(fg_rank.eq.0) then +c print *,'g_newnss',g_newnss +c print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss) +c print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss) + newnss=g_newnss + do i=1,newnss + newihpb(i)=g_newihpb(i) + newjhpb(i)=g_newjhpb(i) + enddo + endif + endif +#endif + + diff=newnss-nss + +cmc write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss) + + do i=1,nss + found=.false. + do j=1,newnss + if (idssb(i).eq.newihpb(j) .and. + & jdssb(i).eq.newjhpb(j)) found=.true. + enddo +#ifndef CLUST +#ifndef WHAM +c if (.not.found.and.fg_rank.eq.0) +c & write(iout,'(a15,f12.2,f8.1,2i5)') +c & "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 +c if (.not.found.and.fg_rank.eq.0) +c & write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i) +#endif +#endif + enddo + + nss=newnss + do i=1,nss + idssb(i)=newihpb(i) + jdssb(i)=newjhpb(i) + enddo + + return + end + + +c$$$c----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax(i_in,j_in) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c Input arguments +c$$$ integer i_in,j_in +c$$$ +c$$$c Local variables +c$$$ integer i,iretcode,nfun_sc +c$$$ logical scfail +c$$$ double precision var(maxvar),e_sc,etot +c$$$ +c$$$ +c$$$ mask_r=.true. +c$$$ do i=nnt,nct +c$$$ mask_side(i)=0 +c$$$ enddo +c$$$ mask_side(i_in)=1 +c$$$ mask_side(j_in)=1 +c$$$ +c$$$c Minimize the two selected side-chains +c$$$ call overlap_sc(scfail) ! Better not fail! +c$$$ call minimize_sc(e_sc,var,iretcode,nfun_sc) +c$$$ +c$$$ mask_r=.false. +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c------------------------------------------------------------- +c$$$ +c$$$ subroutine minimize_sc(etot_sc,iretcode,nfun) +c$$$c Minimize side-chains only, starting from geom but without modifying +c$$$c bond lengths. +c$$$c If mask_r is already set, only the selected side-chains are minimized, +c$$$c otherwise all side-chains are minimized keeping the backbone frozen. +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.MINIM' +c$$$ integer icall +c$$$ common /srutu/ icall +c$$$ +c$$$c Output arguments +c$$$ double precision etot_sc +c$$$ integer iretcode,nfun +c$$$ +c$$$c External functions/subroutines +c$$$ external func_sc,grad_sc,fdum +c$$$ +c$$$c Local variables +c$$$ integer liv,lv +c$$$ parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +c$$$ integer iv(liv) +c$$$ double precision rdum(1) +c$$$ double precision d(maxvar),v(1:lv),x(maxvar),xx(maxvar) +c$$$ integer idum(1) +c$$$ integer i,nvar_restr +c$$$ +c$$$ +c$$$cmc start_minim=.true. +c$$$ call deflt(2,iv,liv,lv,v) +c$$$* 12 means fresh start, dont call deflt +c$$$ iv(1)=12 +c$$$* max num of fun calls +c$$$ if (maxfun.eq.0) maxfun=500 +c$$$ iv(17)=maxfun +c$$$* max num of iterations +c$$$ if (maxmin.eq.0) maxmin=1000 +c$$$ iv(18)=maxmin +c$$$* controls output +c$$$ iv(19)=1 +c$$$* selects output unit +c$$$ iv(21)=0 +c$$$c iv(21)=iout ! DEBUG +c$$$c iv(21)=8 ! DEBUG +c$$$* 1 means to print out result +c$$$ iv(22)=0 +c$$$c iv(22)=1 ! DEBUG +c$$$* 1 means to print out summary stats +c$$$ iv(23)=0 +c$$$c iv(23)=1 ! DEBUG +c$$$* 1 means to print initial x and d +c$$$ iv(24)=0 +c$$$c iv(24)=1 ! DEBUG +c$$$* min val for v(radfac) default is 0.1 +c$$$ v(24)=0.1D0 +c$$$* max val for v(radfac) default is 4.0 +c$$$ v(25)=2.0D0 +c$$$c v(25)=4.0D0 +c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +c$$$* the sumsl default is 0.1 +c$$$ v(26)=0.1D0 +c$$$* false conv if (act fnctn decrease) .lt. v(34) +c$$$* the sumsl default is 100*machep +c$$$ v(34)=v(34)/100.0D0 +c$$$* absolute convergence +c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4 +c$$$ v(31)=tolf +c$$$* relative convergence +c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-1 +c$$$ v(32)=rtolf +c$$$* controls initial step size +c$$$ v(35)=1.0D-1 +c$$$* large vals of d correspond to small components of step +c$$$ do i=1,nphi +c$$$ d(i)=1.0D-1 +c$$$ enddo +c$$$ do i=nphi+1,nvar +c$$$ d(i)=1.0D-1 +c$$$ enddo +c$$$ +c$$$ call geom_to_var(nvar,x) +c$$$ IF (mask_r) THEN +c$$$ do i=1,nres ! Just in case... +c$$$ mask_phi(i)=0 +c$$$ mask_theta(i)=0 +c$$$ enddo +c$$$ call x2xx(x,xx,nvar_restr) +c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc, +c$$$ & iv,liv,lv,v,idum,rdum,fdum) +c$$$ call xx2x(x,xx) +c$$$ ELSE +c$$$c When minimizing ALL side-chains, etotal_sc is a little +c$$$c faster if we don't set mask_r +c$$$ do i=1,nres +c$$$ mask_phi(i)=0 +c$$$ mask_theta(i)=0 +c$$$ mask_side(i)=1 +c$$$ enddo +c$$$ call x2xx(x,xx,nvar_restr) +c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc, +c$$$ & iv,liv,lv,v,idum,rdum,fdum) +c$$$ call xx2x(x,xx) +c$$$ ENDIF +c$$$ call var_to_geom(nvar,x) +c$$$ call chainbuild_sc +c$$$ etot_sc=v(10) +c$$$ iretcode=iv(1) +c$$$ nfun=iv(6) +c$$$ return +c$$$ end +c$$$ +c$$$C-------------------------------------------------------------------------- +c$$$ +c$$$ subroutine chainbuild_sc +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c Local variables +c$$$ integer i +c$$$ +c$$$ +c$$$ do i=nnt,nct +c$$$ if (.not.mask_r .or. mask_side(i).eq.1) then +c$$$ call locate_side_chain(i) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C-------------------------------------------------------------------------- +c$$$ +c$$$ subroutine func_sc(n,x,nf,f,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.MINIM' +c$$$ include 'COMMON.IOUNITS' +c$$$ +c$$$c Input arguments +c$$$ integer n +c$$$ double precision x(maxvar) +c$$$ double precision ufparm +c$$$ external ufparm +c$$$ +c$$$c Input/Output arguments +c$$$ integer nf +c$$$ integer uiparm(1) +c$$$ double precision urparm(1) +c$$$ +c$$$c Output arguments +c$$$ double precision f +c$$$ +c$$$c Local variables +c$$$ double precision energia(0:n_ene) +c$$$#ifdef OSF +c$$$c Variables used to intercept NaNs +c$$$ double precision x_sum +c$$$ integer i_NAN +c$$$#endif +c$$$ +c$$$ +c$$$ nfl=nf +c$$$ icg=mod(nf,2)+1 +c$$$ +c$$$#ifdef OSF +c$$$c Intercept NaNs in the coordinates, before calling etotal_sc +c$$$ x_sum=0.D0 +c$$$ do i_NAN=1,n +c$$$ x_sum=x_sum+x(i_NAN) +c$$$ enddo +c$$$c Calculate the energy only if the coordinates are ok +c$$$ if ((.not.(x_sum.lt.0.D0)) .and. (.not.(x_sum.ge.0.D0))) then +c$$$ write(iout,*)" *** func_restr_sc : Found NaN in coordinates" +c$$$ f=1.0D+77 +c$$$ nf=0 +c$$$ else +c$$$#endif +c$$$ +c$$$ call var_to_geom_restr(n,x) +c$$$ call zerograd +c$$$ call chainbuild_sc +c$$$ call etotal_sc(energia(0)) +c$$$ f=energia(0) +c$$$ if (energia(1).eq.1.0D20 .or. energia(0).eq.1.0D99) nf=0 +c$$$ +c$$$#ifdef OSF +c$$$ endif +c$$$#endif +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c------------------------------------------------------- +c$$$ +c$$$ subroutine grad_sc(n,x,nf,g,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.MINIM' +c$$$ +c$$$c Input arguments +c$$$ integer n +c$$$ double precision x(maxvar) +c$$$ double precision ufparm +c$$$ external ufparm +c$$$ +c$$$c Input/Output arguments +c$$$ integer nf +c$$$ integer uiparm(1) +c$$$ double precision urparm(1) +c$$$ +c$$$c Output arguments +c$$$ double precision g(maxvar) +c$$$ +c$$$c Local variables +c$$$ double precision f,gphii,gthetai,galphai,gomegai +c$$$ integer ig,ind,i,j,k,igall,ij +c$$$ +c$$$ +c$$$ icg=mod(nf,2)+1 +c$$$ if (nf-nfl+1) 20,30,40 +c$$$ 20 call func_sc(n,x,nf,f,uiparm,urparm,ufparm) +c$$$c write (iout,*) 'grad 20' +c$$$ if (nf.eq.0) return +c$$$ goto 40 +c$$$ 30 call var_to_geom_restr(n,x) +c$$$ call chainbuild_sc +c$$$C +c$$$C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +c$$$C +c$$$ 40 call cartder +c$$$C +c$$$C Convert the Cartesian gradient into internal-coordinate gradient. +c$$$C +c$$$ +c$$$ ig=0 +c$$$ ind=nres-2 +c$$$ do i=2,nres-2 +c$$$ IF (mask_phi(i+2).eq.1) THEN +c$$$ gphii=0.0D0 +c$$$ do j=i+1,nres-1 +c$$$ ind=ind+1 +c$$$ do k=1,3 +c$$$ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) +c$$$ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) +c$$$ enddo +c$$$ enddo +c$$$ ig=ig+1 +c$$$ g(ig)=gphii +c$$$ ELSE +c$$$ ind=ind+nres-1-i +c$$$ ENDIF +c$$$ enddo +c$$$ +c$$$ +c$$$ ind=0 +c$$$ do i=1,nres-2 +c$$$ IF (mask_theta(i+2).eq.1) THEN +c$$$ ig=ig+1 +c$$$ gthetai=0.0D0 +c$$$ do j=i+1,nres-1 +c$$$ ind=ind+1 +c$$$ do k=1,3 +c$$$ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) +c$$$ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) +c$$$ enddo +c$$$ enddo +c$$$ g(ig)=gthetai +c$$$ ELSE +c$$$ ind=ind+nres-1-i +c$$$ ENDIF +c$$$ enddo +c$$$ +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ ig=ig+1 +c$$$ galphai=0.0D0 +c$$$ do k=1,3 +c$$$ galphai=galphai+dxds(k,i)*gradx(k,i,icg) +c$$$ enddo +c$$$ g(ig)=galphai +c$$$ ENDIF +c$$$ endif +c$$$ enddo +c$$$ +c$$$ +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ ig=ig+1 +c$$$ gomegai=0.0D0 +c$$$ do k=1,3 +c$$$ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) +c$$$ enddo +c$$$ g(ig)=gomegai +c$$$ ENDIF +c$$$ endif +c$$$ enddo +c$$$ +c$$$C +c$$$C Add the components corresponding to local energy terms. +c$$$C +c$$$ +c$$$ ig=0 +c$$$ igall=0 +c$$$ do i=4,nres +c$$$ igall=igall+1 +c$$$ if (mask_phi(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ do i=3,nres +c$$$ igall=igall+1 +c$$$ if (mask_theta(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ do ij=1,2 +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ igall=igall+1 +c$$$ if (mask_side(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ endif +c$$$ enddo +c$$$ enddo +c$$$ +c$$$cd do i=1,ig +c$$$cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +c$$$cd enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine etotal_sc(energy_sc) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.FFIELD' +c$$$ +c$$$c Output arguments +c$$$ double precision energy_sc(0:n_ene) +c$$$ +c$$$c Local variables +c$$$ double precision evdw,escloc +c$$$ integer i,j +c$$$ +c$$$ +c$$$ do i=1,n_ene +c$$$ energy_sc(i)=0.0D0 +c$$$ enddo +c$$$ +c$$$ if (mask_r) then +c$$$ call egb_sc(evdw) +c$$$ call esc_sc(escloc) +c$$$ else +c$$$ call egb(evdw) +c$$$ call esc(escloc) +c$$$ endif +c$$$ +c$$$ if (evdw.eq.1.0D20) then +c$$$ energy_sc(0)=evdw +c$$$ else +c$$$ energy_sc(0)=wsc*evdw+wscloc*escloc +c$$$ endif +c$$$ energy_sc(1)=evdw +c$$$ energy_sc(12)=escloc +c$$$ +c$$$C +c$$$C Sum up the components of the Cartesian gradient. +c$$$C +c$$$ do i=1,nct +c$$$ do j=1,3 +c$$$ gradx(j,i,icg)=wsc*gvdwx(j,i) +c$$$ enddo +c$$$ enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine egb_sc(evdw) +c$$$C +c$$$C This subroutine calculates the interaction energy of nonbonded side chains +c$$$C assuming the Gay-Berne potential of interaction. +c$$$C +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.CALC' +c$$$ include 'COMMON.CONTROL' +c$$$ logical lprn +c$$$ evdw=0.0D0 +c$$$ energy_dec=.false. +c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon +c$$$ evdw=0.0D0 +c$$$ lprn=.false. +c$$$c if (icall.eq.0) lprn=.false. +c$$$ ind=0 +c$$$ do i=iatsc_s,iatsc_e +c$$$ itypi=itype(i) +c$$$ itypi1=itype(i+1) +c$$$ xi=c(1,nres+i) +c$$$ yi=c(2,nres+i) +c$$$ zi=c(3,nres+i) +c$$$ dxi=dc_norm(1,nres+i) +c$$$ dyi=dc_norm(2,nres+i) +c$$$ dzi=dc_norm(3,nres+i) +c$$$c dsci_inv=dsc_inv(itypi) +c$$$ dsci_inv=vbld_inv(i+nres) +c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +c$$$C +c$$$C Calculate SC interaction energy. +c$$$C +c$$$ do iint=1,nint_gr(i) +c$$$ do j=istart(i,iint),iend(i,iint) +c$$$ IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN +c$$$ ind=ind+1 +c$$$ itypj=itype(j) +c$$$c dscj_inv=dsc_inv(itypj) +c$$$ dscj_inv=vbld_inv(j+nres) +c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +c$$$c & 1.0d0/vbld(j+nres) +c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) +c$$$ sig0ij=sigma(itypi,itypj) +c$$$ chi1=chi(itypi,itypj) +c$$$ chi2=chi(itypj,itypi) +c$$$ chi12=chi1*chi2 +c$$$ chip1=chip(itypi) +c$$$ chip2=chip(itypj) +c$$$ chip12=chip1*chip2 +c$$$ alf1=alp(itypi) +c$$$ alf2=alp(itypj) +c$$$ alf12=0.5D0*(alf1+alf2) +c$$$C For diagnostics only!!! +c$$$c chi1=0.0D0 +c$$$c chi2=0.0D0 +c$$$c chi12=0.0D0 +c$$$c chip1=0.0D0 +c$$$c chip2=0.0D0 +c$$$c chip12=0.0D0 +c$$$c alf1=0.0D0 +c$$$c alf2=0.0D0 +c$$$c alf12=0.0D0 +c$$$ xj=c(1,nres+j)-xi +c$$$ yj=c(2,nres+j)-yi +c$$$ zj=c(3,nres+j)-zi +c$$$ dxj=dc_norm(1,nres+j) +c$$$ dyj=dc_norm(2,nres+j) +c$$$ dzj=dc_norm(3,nres+j) +c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi +c$$$c write (iout,*) "j",j," dc_norm", +c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) +c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +c$$$ rij=dsqrt(rrij) +c$$$C Calculate angle-dependent terms of energy and contributions to their +c$$$C derivatives. +c$$$ call sc_angular +c$$$ sigsq=1.0D0/sigsq +c$$$ sig=sig0ij*dsqrt(sigsq) +c$$$ rij_shift=1.0D0/rij-sig+sig0ij +c$$$c for diagnostics; uncomment +c$$$c rij_shift=1.2*sig0ij +c$$$C I hate to put IF's in the loops, but here don't have another choice!!!! +c$$$ if (rij_shift.le.0.0D0) then +c$$$ evdw=1.0D20 +c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$cd & restyp(itypi),i,restyp(itypj),j, +c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) +c$$$ return +c$$$ endif +c$$$ sigder=-sig*sigsq +c$$$c--------------------------------------------------------------- +c$$$ rij_shift=1.0D0/rij_shift +c$$$ fac=rij_shift**expon +c$$$ e1=fac*fac*aa(itypi,itypj) +c$$$ e2=fac*bb(itypi,itypj) +c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2) +c$$$ eps2der=evdwij*eps3rt +c$$$ eps3der=evdwij*eps2rt +c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 +c$$$ evdwij=evdwij*eps2rt*eps3rt +c$$$ evdw=evdw+evdwij +c$$$ if (lprn) then +c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$ & restyp(itypi),i,restyp(itypj),j, +c$$$ & epsi,sigm,chi1,chi2,chip1,chip2, +c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, +c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, +c$$$ & evdwij +c$$$ endif +c$$$ +c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)') +c$$$ & 'evdw',i,j,evdwij +c$$$ +c$$$C Calculate gradient components. +c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2 +c$$$ fac=-expon*(e1+evdwij)*rij_shift +c$$$ sigder=fac*sigder +c$$$ fac=rij*fac +c$$$c fac=0.0d0 +c$$$C Calculate the radial part of the gradient +c$$$ gg(1)=xj*fac +c$$$ gg(2)=yj*fac +c$$$ gg(3)=zj*fac +c$$$C Calculate angular part of the gradient. +c$$$ call sc_grad +c$$$ ENDIF +c$$$ enddo ! j +c$$$ enddo ! iint +c$$$ enddo ! i +c$$$ energy_dec=.false. +c$$$ return +c$$$ end +c$$$ +c$$$c----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine esc_sc(escloc) +c$$$C Calculate the local energy of a side chain and its derivatives in the +c$$$C corresponding virtual-bond valence angles THETA and the spherical angles +c$$$C ALPHA and OMEGA. +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.FFIELD' +c$$$ include 'COMMON.CONTROL' +c$$$ double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), +c$$$ & ddersc0(3),ddummy(3),xtemp(3),temp(3) +c$$$ common /sccalc/ time11,time12,time112,theti,it,nlobit +c$$$ delta=0.02d0*pi +c$$$ escloc=0.0D0 +c$$$c write (iout,'(a)') 'ESC' +c$$$ do i=loc_start,loc_end +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ it=itype(i) +c$$$ if (it.eq.10) goto 1 +c$$$ nlobit=nlob(it) +c$$$c print *,'i=',i,' it=',it,' nlobit=',nlobit +c$$$c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad +c$$$ theti=theta(i+1)-pipol +c$$$ x(1)=dtan(theti) +c$$$ x(2)=alph(i) +c$$$ x(3)=omeg(i) +c$$$ +c$$$ if (x(2).gt.pi-delta) then +c$$$ xtemp(1)=x(1) +c$$$ xtemp(2)=pi-delta +c$$$ xtemp(3)=x(3) +c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) +c$$$ xtemp(2)=pi +c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.) +c$$$ call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), +c$$$ & escloci,dersc(2)) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), +c$$$ & ddersc0(1),dersc(1)) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), +c$$$ & ddersc0(3),dersc(3)) +c$$$ xtemp(2)=pi-delta +c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) +c$$$ xtemp(2)=pi +c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) +c$$$ call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, +c$$$ & dersc0(2),esclocbi,dersc02) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), +c$$$ & dersc12,dersc01) +c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd) +c$$$ dersc0(1)=dersc01 +c$$$ dersc0(2)=dersc02 +c$$$ dersc0(3)=0.0d0 +c$$$ do k=1,3 +c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) +c$$$ enddo +c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c$$$c & esclocbi,ss,ssd +c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi +c$$$c escloci=esclocbi +c$$$c write (iout,*) escloci +c$$$ else if (x(2).lt.delta) then +c$$$ xtemp(1)=x(1) +c$$$ xtemp(2)=delta +c$$$ xtemp(3)=x(3) +c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) +c$$$ xtemp(2)=0.0d0 +c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.) +c$$$ call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), +c$$$ & escloci,dersc(2)) +c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), +c$$$ & ddersc0(1),dersc(1)) +c$$$ call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), +c$$$ & ddersc0(3),dersc(3)) +c$$$ xtemp(2)=delta +c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) +c$$$ xtemp(2)=0.0d0 +c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) +c$$$ call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, +c$$$ & dersc0(2),esclocbi,dersc02) +c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), +c$$$ & dersc12,dersc01) +c$$$ dersc0(1)=dersc01 +c$$$ dersc0(2)=dersc02 +c$$$ dersc0(3)=0.0d0 +c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd) +c$$$ do k=1,3 +c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) +c$$$ enddo +c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c$$$c & esclocbi,ss,ssd +c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi +c$$$c write (iout,*) escloci +c$$$ else +c$$$ call enesc(x,escloci,dersc,ddummy,.false.) +c$$$ endif +c$$$ +c$$$ escloc=escloc+escloci +c$$$ if (energy_dec) write (iout,'(a6,i,0pf7.3)') +c$$$ & 'escloc',i,escloci +c$$$c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc +c$$$ +c$$$ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ +c$$$ & wscloc*dersc(1) +c$$$ gloc(ialph(i,1),icg)=wscloc*dersc(2) +c$$$ gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) +c$$$ 1 continue +c$$$ ENDIF +c$$$ enddo +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine egb_ij(i_sc,j_sc,evdw) +c$$$C +c$$$C This subroutine calculates the interaction energy of nonbonded side chains +c$$$C assuming the Gay-Berne potential of interaction. +c$$$C +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.CALC' +c$$$ include 'COMMON.CONTROL' +c$$$ logical lprn +c$$$ evdw=0.0D0 +c$$$ energy_dec=.false. +c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon +c$$$ evdw=0.0D0 +c$$$ lprn=.false. +c$$$ ind=0 +c$$$c$$$ do i=iatsc_s,iatsc_e +c$$$ i=i_sc +c$$$ itypi=itype(i) +c$$$ itypi1=itype(i+1) +c$$$ xi=c(1,nres+i) +c$$$ yi=c(2,nres+i) +c$$$ zi=c(3,nres+i) +c$$$ dxi=dc_norm(1,nres+i) +c$$$ dyi=dc_norm(2,nres+i) +c$$$ dzi=dc_norm(3,nres+i) +c$$$c dsci_inv=dsc_inv(itypi) +c$$$ dsci_inv=vbld_inv(i+nres) +c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +c$$$C +c$$$C Calculate SC interaction energy. +c$$$C +c$$$c$$$ do iint=1,nint_gr(i) +c$$$c$$$ do j=istart(i,iint),iend(i,iint) +c$$$ j=j_sc +c$$$ ind=ind+1 +c$$$ itypj=itype(j) +c$$$c dscj_inv=dsc_inv(itypj) +c$$$ dscj_inv=vbld_inv(j+nres) +c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +c$$$c & 1.0d0/vbld(j+nres) +c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) +c$$$ sig0ij=sigma(itypi,itypj) +c$$$ chi1=chi(itypi,itypj) +c$$$ chi2=chi(itypj,itypi) +c$$$ chi12=chi1*chi2 +c$$$ chip1=chip(itypi) +c$$$ chip2=chip(itypj) +c$$$ chip12=chip1*chip2 +c$$$ alf1=alp(itypi) +c$$$ alf2=alp(itypj) +c$$$ alf12=0.5D0*(alf1+alf2) +c$$$C For diagnostics only!!! +c$$$c chi1=0.0D0 +c$$$c chi2=0.0D0 +c$$$c chi12=0.0D0 +c$$$c chip1=0.0D0 +c$$$c chip2=0.0D0 +c$$$c chip12=0.0D0 +c$$$c alf1=0.0D0 +c$$$c alf2=0.0D0 +c$$$c alf12=0.0D0 +c$$$ xj=c(1,nres+j)-xi +c$$$ yj=c(2,nres+j)-yi +c$$$ zj=c(3,nres+j)-zi +c$$$ dxj=dc_norm(1,nres+j) +c$$$ dyj=dc_norm(2,nres+j) +c$$$ dzj=dc_norm(3,nres+j) +c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi +c$$$c write (iout,*) "j",j," dc_norm", +c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) +c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +c$$$ rij=dsqrt(rrij) +c$$$C Calculate angle-dependent terms of energy and contributions to their +c$$$C derivatives. +c$$$ call sc_angular +c$$$ sigsq=1.0D0/sigsq +c$$$ sig=sig0ij*dsqrt(sigsq) +c$$$ rij_shift=1.0D0/rij-sig+sig0ij +c$$$c for diagnostics; uncomment +c$$$c rij_shift=1.2*sig0ij +c$$$C I hate to put IF's in the loops, but here don't have another choice!!!! +c$$$ if (rij_shift.le.0.0D0) then +c$$$ evdw=1.0D20 +c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$cd & restyp(itypi),i,restyp(itypj),j, +c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) +c$$$ return +c$$$ endif +c$$$ sigder=-sig*sigsq +c$$$c--------------------------------------------------------------- +c$$$ rij_shift=1.0D0/rij_shift +c$$$ fac=rij_shift**expon +c$$$ e1=fac*fac*aa(itypi,itypj) +c$$$ e2=fac*bb(itypi,itypj) +c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2) +c$$$ eps2der=evdwij*eps3rt +c$$$ eps3der=evdwij*eps2rt +c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 +c$$$ evdwij=evdwij*eps2rt*eps3rt +c$$$ evdw=evdw+evdwij +c$$$ if (lprn) then +c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$ & restyp(itypi),i,restyp(itypj),j, +c$$$ & epsi,sigm,chi1,chi2,chip1,chip2, +c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, +c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, +c$$$ & evdwij +c$$$ endif +c$$$ +c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)') +c$$$ & 'evdw',i,j,evdwij +c$$$ +c$$$C Calculate gradient components. +c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2 +c$$$ fac=-expon*(e1+evdwij)*rij_shift +c$$$ sigder=fac*sigder +c$$$ fac=rij*fac +c$$$c fac=0.0d0 +c$$$C Calculate the radial part of the gradient +c$$$ gg(1)=xj*fac +c$$$ gg(2)=yj*fac +c$$$ gg(3)=zj*fac +c$$$C Calculate angular part of the gradient. +c$$$ call sc_grad +c$$$c$$$ enddo ! j +c$$$c$$$ enddo ! iint +c$$$c$$$ enddo ! i +c$$$ energy_dec=.false. +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine perturb_side_chain(i,angle) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.IOUNITS' +c$$$ +c$$$c External functions +c$$$ external ran_number +c$$$ double precision ran_number +c$$$ +c$$$c Input arguments +c$$$ integer i +c$$$ double precision angle ! In degrees +c$$$ +c$$$c Local variables +c$$$ integer i_sc +c$$$ double precision rad_ang,rand_v(3),length,cost,sint +c$$$ +c$$$ +c$$$ i_sc=i+nres +c$$$ rad_ang=angle*deg2rad +c$$$ +c$$$ length=0.0 +c$$$ do while (length.lt.0.01) +c$$$ rand_v(1)=ran_number(0.01D0,1.0D0) +c$$$ rand_v(2)=ran_number(0.01D0,1.0D0) +c$$$ rand_v(3)=ran_number(0.01D0,1.0D0) +c$$$ length=rand_v(1)*rand_v(1)+rand_v(2)*rand_v(2)+ +c$$$ + rand_v(3)*rand_v(3) +c$$$ length=sqrt(length) +c$$$ rand_v(1)=rand_v(1)/length +c$$$ rand_v(2)=rand_v(2)/length +c$$$ rand_v(3)=rand_v(3)/length +c$$$ cost=rand_v(1)*dc_norm(1,i_sc)+rand_v(2)*dc_norm(2,i_sc)+ +c$$$ + rand_v(3)*dc_norm(3,i_sc) +c$$$ length=1.0D0-cost*cost +c$$$ if (length.lt.0.0D0) length=0.0D0 +c$$$ length=sqrt(length) +c$$$ rand_v(1)=rand_v(1)-cost*dc_norm(1,i_sc) +c$$$ rand_v(2)=rand_v(2)-cost*dc_norm(2,i_sc) +c$$$ rand_v(3)=rand_v(3)-cost*dc_norm(3,i_sc) +c$$$ enddo +c$$$ rand_v(1)=rand_v(1)/length +c$$$ rand_v(2)=rand_v(2)/length +c$$$ rand_v(3)=rand_v(3)/length +c$$$ +c$$$ cost=dcos(rad_ang) +c$$$ sint=dsin(rad_ang) +c$$$ dc(1,i_sc)=vbld(i_sc)*(dc_norm(1,i_sc)*cost+rand_v(1)*sint) +c$$$ dc(2,i_sc)=vbld(i_sc)*(dc_norm(2,i_sc)*cost+rand_v(2)*sint) +c$$$ dc(3,i_sc)=vbld(i_sc)*(dc_norm(3,i_sc)*cost+rand_v(3)*sint) +c$$$ dc_norm(1,i_sc)=dc(1,i_sc)*vbld_inv(i_sc) +c$$$ dc_norm(2,i_sc)=dc(2,i_sc)*vbld_inv(i_sc) +c$$$ dc_norm(3,i_sc)=dc(3,i_sc)*vbld_inv(i_sc) +c$$$ c(1,i_sc)=c(1,i)+dc(1,i_sc) +c$$$ c(2,i_sc)=c(2,i)+dc(2,i_sc) +c$$$ c(3,i_sc)=c(3,i)+dc(3,i_sc) +c$$$ +c$$$ call chainbuild_cart +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c---------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax3(i_in,j_in) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c External functions +c$$$ external ran_number +c$$$ double precision ran_number +c$$$ +c$$$c Input arguments +c$$$ integer i_in,j_in +c$$$ +c$$$c Local variables +c$$$ double precision energy_sc(0:n_ene),etot +c$$$ double precision org_dc(3),org_dc_norm(3),org_c(3) +c$$$ double precision ang_pert,rand_fact,exp_fact,beta +c$$$ integer n,i_pert,i +c$$$ logical notdone +c$$$ +c$$$ +c$$$ beta=1.0D0 +c$$$ +c$$$ mask_r=.true. +c$$$ do i=nnt,nct +c$$$ mask_side(i)=0 +c$$$ enddo +c$$$ mask_side(i_in)=1 +c$$$ mask_side(j_in)=1 +c$$$ +c$$$ call etotal_sc(energy_sc) +c$$$ etot=energy_sc(0) +c$$$c write(iout,'(a,3d15.5)')" SS_MC_START ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ +c$$$ notdone=.true. +c$$$ n=0 +c$$$ do while (notdone) +c$$$ if (mod(n,2).eq.0) then +c$$$ i_pert=i_in +c$$$ else +c$$$ i_pert=j_in +c$$$ endif +c$$$ n=n+1 +c$$$ +c$$$ do i=1,3 +c$$$ org_dc(i)=dc(i,i_pert+nres) +c$$$ org_dc_norm(i)=dc_norm(i,i_pert+nres) +c$$$ org_c(i)=c(i,i_pert+nres) +c$$$ enddo +c$$$ ang_pert=ran_number(0.0D0,3.0D0) +c$$$ call perturb_side_chain(i_pert,ang_pert) +c$$$ call etotal_sc(energy_sc) +c$$$ exp_fact=exp(beta*(etot-energy_sc(0))) +c$$$ rand_fact=ran_number(0.0D0,1.0D0) +c$$$ if (rand_fact.lt.exp_fact) then +c$$$c write(iout,'(a,3d15.5)')" SS_MC_ACCEPT ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ etot=energy_sc(0) +c$$$ else +c$$$c write(iout,'(a,3d15.5)')" SS_MC_REJECT ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ do i=1,3 +c$$$ dc(i,i_pert+nres)=org_dc(i) +c$$$ dc_norm(i,i_pert+nres)=org_dc_norm(i) +c$$$ c(i,i_pert+nres)=org_c(i) +c$$$ enddo +c$$$ endif +c$$$ +c$$$ if (n.eq.10000.or.etot.lt.30.0D0) notdone=.false. +c$$$ enddo +c$$$ +c$$$ mask_r=.false. +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c---------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax2(etot,iretcode,nfun,i_in,j_in) +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ integer liv,lv +c$$$ parameter (liv=60,lv=(77+maxres6*(maxres6+17)/2)) +c$$$********************************************************************* +c$$$* OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * +c$$$* the calling subprogram. * +c$$$* when d(i)=1.0, then v(35) is the length of the initial step, * +c$$$* calculated in the usual pythagorean way. * +c$$$* absolute convergence occurs when the function is within v(31) of * +c$$$* zero. unless you know the minimum value in advance, abs convg * +c$$$* is probably not useful. * +c$$$* relative convergence is when the model predicts that the function * +c$$$* will decrease by less than v(32)*abs(fun). * +c$$$********************************************************************* +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.MINIM' +c$$$ include 'COMMON.CHAIN' +c$$$ +c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist +c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar), +c$$$ + orig_ss_dist(maxres2,maxres2) +c$$$ +c$$$ double precision etot +c$$$ integer iretcode,nfun,i_in,j_in +c$$$ +c$$$ external dist +c$$$ double precision dist +c$$$ external ss_func,fdum +c$$$ double precision ss_func,fdum +c$$$ +c$$$ integer iv(liv),uiparm(2) +c$$$ double precision v(lv),x(maxres6),d(maxres6),rdum +c$$$ integer i,j,k +c$$$ +c$$$ +c$$$ call deflt(2,iv,liv,lv,v) +c$$$* 12 means fresh start, dont call deflt +c$$$ iv(1)=12 +c$$$* max num of fun calls +c$$$ if (maxfun.eq.0) maxfun=500 +c$$$ iv(17)=maxfun +c$$$* max num of iterations +c$$$ if (maxmin.eq.0) maxmin=1000 +c$$$ iv(18)=maxmin +c$$$* controls output +c$$$ iv(19)=2 +c$$$* selects output unit +c$$$c iv(21)=iout +c$$$ iv(21)=0 +c$$$* 1 means to print out result +c$$$ iv(22)=0 +c$$$* 1 means to print out summary stats +c$$$ iv(23)=0 +c$$$* 1 means to print initial x and d +c$$$ iv(24)=0 +c$$$* min val for v(radfac) default is 0.1 +c$$$ v(24)=0.1D0 +c$$$* max val for v(radfac) default is 4.0 +c$$$ v(25)=2.0D0 +c$$$c v(25)=4.0D0 +c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +c$$$* the sumsl default is 0.1 +c$$$ v(26)=0.1D0 +c$$$* false conv if (act fnctn decrease) .lt. v(34) +c$$$* the sumsl default is 100*machep +c$$$ v(34)=v(34)/100.0D0 +c$$$* absolute convergence +c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4 +c$$$ v(31)=tolf +c$$$ v(31)=1.0D-1 +c$$$* relative convergence +c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-4 +c$$$ v(32)=rtolf +c$$$ v(32)=1.0D-1 +c$$$* controls initial step size +c$$$ v(35)=1.0D-1 +c$$$* large vals of d correspond to small components of step +c$$$ do i=1,6*nres +c$$$ d(i)=1.0D0 +c$$$ enddo +c$$$ +c$$$ do i=0,2*nres +c$$$ do j=1,3 +c$$$ orig_ss_dc(j,i)=dc(j,i) +c$$$ enddo +c$$$ enddo +c$$$ call geom_to_var(nvar,orig_ss_var) +c$$$ +c$$$ do i=1,nres +c$$$ do j=i,nres +c$$$ orig_ss_dist(j,i)=dist(j,i) +c$$$ orig_ss_dist(j+nres,i)=dist(j+nres,i) +c$$$ orig_ss_dist(j,i+nres)=dist(j,i+nres) +c$$$ orig_ss_dist(j+nres,i+nres)=dist(j+nres,i+nres) +c$$$ enddo +c$$$ enddo +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ x(k)=dc(j,i) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ x(k)=dc(j,i+nres) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ +c$$$ uiparm(1)=i_in +c$$$ uiparm(2)=j_in +c$$$ call smsno(k,d,x,ss_func,iv,liv,lv,v,uiparm,rdum,fdum) +c$$$ etot=v(10) +c$$$ iretcode=iv(1) +c$$$ nfun=iv(6)+iv(30) +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i)=x(k) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i+nres)=x(k) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ call chainbuild_cart +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_func(n,x,nf,f,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.SBRIDGE' +c$$$ +c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist +c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar), +c$$$ + orig_ss_dist(maxres2,maxres2) +c$$$ +c$$$ integer n +c$$$ double precision x(maxres6) +c$$$ integer nf +c$$$ double precision f +c$$$ integer uiparm(2) +c$$$ real*8 urparm(1) +c$$$ external ufparm +c$$$ double precision ufparm +c$$$ +c$$$ external dist +c$$$ double precision dist +c$$$ +c$$$ integer i,j,k,ss_i,ss_j +c$$$ double precision tempf,var(maxvar) +c$$$ +c$$$ +c$$$ ss_i=uiparm(1) +c$$$ ss_j=uiparm(2) +c$$$ f=0.0D0 +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i)=x(k) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i+nres)=x(k) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ call chainbuild_cart +c$$$ +c$$$ call geom_to_var(nvar,var) +c$$$ +c$$$c Constraints on all angles +c$$$ do i=1,nvar +c$$$ tempf=var(i)-orig_ss_var(i) +c$$$ f=f+tempf*tempf +c$$$ enddo +c$$$ +c$$$c Constraints on all distances +c$$$ do i=1,nres-1 +c$$$ if (i.gt.1) then +c$$$ tempf=dist(i+nres,i)-orig_ss_dist(i+nres,i) +c$$$ f=f+tempf*tempf +c$$$ endif +c$$$ do j=i+1,nres +c$$$ tempf=dist(j,i)-orig_ss_dist(j,i) +c$$$ if (tempf.lt.0.0D0 .or. j.eq.i+1) f=f+tempf*tempf +c$$$ tempf=dist(j+nres,i)-orig_ss_dist(j+nres,i) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ tempf=dist(j,i+nres)-orig_ss_dist(j,i+nres) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ tempf=dist(j+nres,i+nres)-orig_ss_dist(j+nres,i+nres) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ enddo +c$$$ enddo +c$$$ +c$$$c Constraints for the relevant CYS-CYS +c$$$ tempf=dist(nres+ss_i,nres+ss_j)-8.0D0 +c$$$ f=f+tempf*tempf +c$$$CCCCCCCCCCCCCCCCC ADD SOME ANGULAR STUFF +c$$$ +c$$$c$$$ if (nf.ne.nfl) then +c$$$c$$$ write(iout,'(a,i10,2d15.5)')"IN DIST_FUNC (NF,F,DIST)",nf, +c$$$c$$$ + f,dist(5+nres,14+nres) +c$$$c$$$ endif +c$$$ +c$$$ nfl=nf +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$C----------------------------------------------------------------------------- + subroutine triple_ssbond_ene(resi,resj,resk,eij) + 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' + include 'COMMON.CALC' +#ifndef CLUST +#ifndef WHAM +C include 'COMMON.MD' +#endif +#endif + +c External functions + double precision h_base + external h_base + +c Input arguments + integer resi,resj,resk + +c Output arguments + double precision eij,eij1,eij2,eij3 + +c Local variables + logical havebond +c integer itypi,itypj,k,l + double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi + double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij + double precision xik,yik,zik,xjk,yjk,zjk + double precision sig0ij,ljd,sig,fac,e1,e2 + double precision dcosom1(3),dcosom2(3),ed + double precision pom1,pom2 + double precision ljA,ljB,ljXs + double precision d_ljB(1:3) + double precision ssA,ssB,ssC,ssXs + double precision ssxm,ljxm,ssm,ljm + double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3) + + i=resi + j=resj + k=resk +C write(iout,*) resi,resj,resk + 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) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + + itypj=itype(j) + xj=c(1,nres+j) + yj=c(2,nres+j) + zj=c(3,nres+j) + + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + dscj_inv=vbld_inv(j+nres) + itypk=itype(k) + xk=c(1,nres+k) + yk=c(2,nres+k) + zk=c(3,nres+k) + + dxk=dc_norm(1,nres+k) + dyk=dc_norm(2,nres+k) + dzk=dc_norm(3,nres+k) + dscj_inv=vbld_inv(k+nres) + xij=xj-xi + xik=xk-xi + xjk=xk-xj + yij=yj-yi + yik=yk-yi + yjk=yk-yj + zij=zj-zi + zik=zk-zi + zjk=zk-zj + rrij=(xij*xij+yij*yij+zij*zij) + rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse + rrik=(xik*xik+yik*yik+zik*zik) + rik=dsqrt(rrik) + rrjk=(xjk*xjk+yjk*yjk+zjk*zjk) + rjk=dsqrt(rrjk) +C there are three combination of distances for each trisulfide bonds +C The first case the ith atom is the center +C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first +C distance y is second distance the a,b,c,d are parameters derived for +C this problem d parameter was set as a penalty currenlty set to 1. + eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**2+ctriss) +C second case jth atom is center + eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**2+ctriss) +C the third case kth atom is the center + eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**2+ctriss) +C eij2=0.0 +C eij3=0.0 +C eij1=0.0 + eij=eij1+eij2+eij3 +C write(iout,*)i,j,k,eij +C The energy penalty calculated now time for the gradient part +C derivative over rij + fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+2.0*btriss*(rij+rik)) + &-eij2**2/dtriss*(2.0*atriss*(rij-rjk)+2.0*btriss*(rij+rjk)) + gg(1)=xij*fac/rij + gg(2)=yij*fac/rij + gg(3)=zij*fac/rij + do m=1,3 + gvdwx(m,i)=gvdwx(m,i)-gg(m) + gvdwx(m,j)=gvdwx(m,j)+gg(m) + enddo + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo +C now derivative over rik + fac=-eij1**2/dtriss*(-2.0*atriss*(rij-rik)+2.0*btriss*(rij+rik)) + &-eij3**2/dtriss*(2.0*atriss*(rik-rjk)+2.0*btriss*(rik+rjk)) + gg(1)=xik*fac/rik + gg(2)=yik*fac/rik + gg(3)=zik*fac/rik + do m=1,3 + gvdwx(m,i)=gvdwx(m,i)-gg(m) + gvdwx(m,k)=gvdwx(m,k)+gg(m) + enddo + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo +C now derivative over rjk + fac=-eij2**2/dtriss*(-2.0*atriss*(rij-rjk)+2.0*btriss*(rij+rjk))- + &eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+2.0*btriss*(rik+rjk)) + gg(1)=xjk*fac/rjk + gg(2)=yjk*fac/rjk + gg(3)=zjk*fac/rjk + do m=1,3 + gvdwx(m,j)=gvdwx(m,j)-gg(m) + gvdwx(m,k)=gvdwx(m,k)+gg(m) + enddo + do l=1,3 + gvdwc(l,j)=gvdwc(l,j)-gg(l) + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo + return + end diff --git a/source/cluster/wham/src-HCD/timing.F b/source/cluster/wham/src-HCD/timing.F new file mode 100644 index 0000000..b8bfdd4 --- /dev/null +++ b/source/cluster/wham/src-HCD/timing.F @@ -0,0 +1,180 @@ +C $Date: 1994/10/05 16:41:52 $ +C $Revision: 2.2 $ +C +C +C + subroutine set_timers +c + double precision tcpu ! function + include 'COMMON.TIME1' +C Diminish the assigned time limit a little so that there is some time to +C end a batch job +c timlim=batime-150.0 +C Calculate the initial time, if it is not zero (e.g. for the SUN). + stime=tcpu() + return + end + logical function stopx(nf) +C +C .................................................................. +C +C *****PURPOSE... +C THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION) +C FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT +C THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A +C DYNAMIC STOPX. +C +C *****ALGORITHM NOTES... +C AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED +C INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A +C FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT +C (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX. +C +C $$$ MODIFIED FOR USE AS THE TIMER ROUTINE. +C $$$ WHEN THE TIME LIMIT HAS BEEN +C $$$ REACHED STOPX IS SET TO .TRUE AND INITIATES (IN ITSUM) +C $$$ AND ORDERLY EXIT OUT OF SUMSL. IF ARRAYS IV AND V ARE +C $$$ SAVED, THE SUMSL ROUTINES CAN BE RESTARTED AT THE SAME +C $$$ POINT AT WHICH THEY WERE INTERRUPTED. +C +C .................................................................. +C + include 'DIMENSIONS' + integer nf + logical ovrtim + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' +#ifdef MPL + include 'COMMON.INFO' + integer Kwita + +cd print *,'Processor',MyID,' NF=',nf +#endif + if (ovrtim()) then +C Finish if time is up. + stopx = .true. +#ifdef MPL + else if (mod(nf,100).eq.0) then +C Other processors might have finished. Check this every 100th function +C evaluation. +cd print *,'Processor ',MyID,' is checking STOP: nf=',nf + call recv_stop_sig(Kwita) + if (Kwita.eq.-1) then + write (iout,'(a,i4,a,i5)') 'Processor', + & MyID,' has received STOP signal in STOPX; NF=',nf + write (*,'(a,i4,a,i5)') 'Processor', + & MyID,' has received STOP signal in STOPX; NF=',nf + stopx=.true. + else + stopx=.false. + endif +#endif + else + stopx = .false. + endif + return + end +C========================================================================= +C + logical function ovrtim() + double precision tcpu ! function + include 'COMMON.TIME1' +C Set a 100.0 secs. safety margin, so as to allow for the termination of +C a batch job. +c double safety /150.0D0/ + curtim= tcpu() +cd print *,'curtim=',curtim,' timlim=',timlim +C curtim is the current time in seconds. + ovrtim=(curtim .ge. timlim - safety ) + return + end +C========================================================================= +C + double precision function tcpu() + include 'COMMON.TIME1' +#ifdef ES9000 +**************************** +C Next definition for EAGLE (ibm-es9000) + real*8 micseconds + integer rcode + tcpu=cputime(micseconds,rcode) + tcpu=(micseconds/1.0E6) - stime +**************************** +#endif +#ifdef SUN +**************************** +C Next definitions for sun + integer seconds + call clock(seconds) + tcpu=seconds - stime +**************************** +#endif +#ifdef KSR +**************************** +C Next definitions for ksr +C this function uses the ksr timer ALL_SECONDS from the PMON library to +C return the elapsed time in seconds + tcpu= all_seconds() - stime +**************************** +#endif +#ifdef SGI +**************************** +C Next definitions for sgi + real timar(2), etime + seconds = etime(timar) +C usrsec = timar(1) +C syssec = timar(2) + tcpu=seconds - stime +**************************** +#endif +#ifdef CRAY +**************************** +C Next definitions for Cray +C call date(curdat) +C curdat=curdat(1:9) +C call clock(curtim) +C curtim=curtim(1:8) + cpusec = second() + tcpu=cpusec - stime +**************************** +#endif +#ifdef AIX +**************************** +C Next definitions for RS6000 + integer*4 i1,mclock + i1 = mclock() + tcpu = (i1+0.0D0)/100.0D0 +#endif +#ifdef LINUX +**************************** +C Next definitions for sgi + real timar(2), etime + seconds = etime(timar) +Cd print *,'seconds=',seconds,' stime=',stime +C usrsec = timar(1) +C syssec = timar(2) + tcpu=seconds - stime +**************************** +#endif + return + end +* + subroutine dajczas(rntime,hrtime,mintime,sectime) + include 'COMMON.IOUNITS' + real*8 rntime,hrtime,mintime,sectime + hrtime=rntime/3600.0D0 + hrtime=aint(hrtime) + mintime=aint((rntime-3600.0D0*hrtime)/60.0D0) + sectime=aint((rntime-3600.0D0*hrtime-60.0D0*mintime)+0.5D0) + if (sectime.eq.60.0D0) then + sectime=0.0D0 + mintime=mintime+1.0D0 + endif + ihr=hrtime + imn=mintime + isc=sectime + write (iout,328) ihr,imn,isc + 328 FORMAT(//'***** Computation time: ',I4 ,' hours ',I2 , + 1 ' minutes ', I2 ,' seconds *****') + return + end diff --git a/source/cluster/wham/src-HCD/track.F b/source/cluster/wham/src-HCD/track.F new file mode 100644 index 0000000..a8244e3 --- /dev/null +++ b/source/cluster/wham/src-HCD/track.F @@ -0,0 +1,277 @@ + 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) + IF (ICUT.GT.1) THEN +C 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) +C 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 +C------------------------------------------------------------------------------ + SUBROUTINE WRITRACK + 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) + DIMENSION IPART(MAXGR/5,MAXGR/5) +c do icut=2,ncut +c write (iout,'(a,f10.5)') 'Cut-off',rcutoff(icut) +c write (iout,'(16i5)') (iback(k,icut),k=1,ncur(icut)) +c enddo +C +C Print the partition history. +C + DO ICUT=2,NCUT + NCU=NCUR(ICUT) + NCUP=NCUR(ICUT-1) +cd 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 +cd print *,'i=',i + DO J=1,NCU + IF (IBACK(J,ICUT).EQ.I) THEN + NPART=NPART+1 + IPART(NPART,I)=J + ENDIF +cd 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 +C------------------------------------------------------------------------------ + SUBROUTINE PLOTREE + 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) + DIMENSION Y(MAXGR,MAX_CUT) + DIMENSION ITREE(MAXGR,MAX_CUT),IFIRST(MAXGR,MAX_CUT), + &ILAST(MAXGR,MAX_CUT),IFT(MAXGR),ILT(MAXGR),ITR(MAXGR) + CHARACTER*32 FD + external ilen +C +C Generate the image of the tree (tentatively for LaTeX picture environment). +C +C +C First untangle the branches of the tree +C + DO I=1,NCUR(1) + ITREE(I,1)=I + ENDDO + DO ICUT=NCUT,2,-1 +C +C Determine the order of families for the (icut)th partition. +C + 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 +cd print *,'i=',i,' ncup=',ncup,' ncu=',ncu,' npart=',npart + ENDDO ! ICUT +c diagnostic printout +cd do icut=1,ncut +cd write (iout,*) 'Cut-off',icut,' = ',rcutoff(icut) +cd write (iout,*) 'ITREE' +cd write (iout,*) (itree(i,icut),i=1,ncur(icut)) +cd write (iout,*) 'IFIRST, ILAST' +cd write (iout,*) (ifirst(i,icut),ilast(i,icut),i=1,ncur(icut)) +cd enddo +C +C Propagate the order of families from cut-off #2 to cut-off #n. +C + 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) +c write (iout,*) 'icut=',icut,' i=',i,' iti=',iti +C 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 +Cd write (iout,*) 'jf1=',jf1,' jl1=',jl1,' jf2=',jf2, +Cd & ' jl2=',jl2 +Cd write (iout,*) 'jr1=',jr1,' jr2=',jr2 +C Update IFIRST and ILAST. + ILAST(I,ICUT)=IFIRST(I,ICUT)+JR2-1 + IFIRST(I+1,ICUT)=ILAST(I,ICUT)+1 +C Update ITREE. + JF11=IFIRST(I,ICUT) +Cd write(iout,*) 'jf11=',jf11 + DO J=JF2,JL2 +Cd write (iout,*) j,JF11+J-JF2,ITR(J) + ITREE(JF11+J-JF2,ICUT+1)=ITR(J) + ENDDO +Cd write (iout,*) (ifirst(k,icut),ilast(k,icut),k=1,i) +Cd write (iout,*) (itree(k,icut+1),k=1,ilast(i,icut)) +C ENDIF ! (ITI.NE.I) + ENDDO ! I + ENDDO ! ICUT +c diagnostic printout +cd do icut=1,ncut +cd write (iout,*) 'Cut-off',icut,' = ',rcutoff(icut) +cd write (iout,*) 'ITREE' +cd write (iout,*) (itree(i,icut),i=1,ncur(icut)) +cd write (iout,*) 'IFIRST, ILAST' +cd write (iout,*) (ifirst(i,icut),ilast(i,icut),i=1,ncur(icut)) +cd enddo +C +C Generate the y-coordinates of the branches. +C + 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 +c diagnostic output +cd do icut=1,ncut +cd write(iout,*) 'Cut-off=',rcutoff(icut) +cd write(iout,'(8f10.3)') (y(j,icut),j=1,ncur(icut)) +cd enddo +C +C Generate LaTeX script for tree plot +C + 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 +cd print *,'icut=',icut,' xlen=',xlen,' deltx=',deltx, +cd & ' 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 diff --git a/source/cluster/wham/src-HCD/work_partition.F b/source/cluster/wham/src-HCD/work_partition.F new file mode 100644 index 0000000..f29b01f --- /dev/null +++ b/source/cluster/wham/src-HCD/work_partition.F @@ -0,0 +1,86 @@ +#ifdef MPI + subroutine work_partition(lprint,ncon_work) +c Split the conformations between processors + implicit none + include "DIMENSIONS" + include "sizesclu.dat" + include "mpif.h" + include "COMMON.IOUNITS" + include "COMMON.CLUSTER" + include "COMMON.MPI" + integer n,chunk,i,j,ii,remainder + integer kolor,key,ierror,errcode,ncon_work + logical lprint +C +C Divide conformations between processors; the first and +C the last conformation to handle by ith processor is stored in +C indstart(i) and indend(i), respectively. +C +C First try to assign equal number of conformations to each processor. +C + n=ncon_work + write (iout,*) "n=",n," nprocs=",nprocs + indstart(0)=1 + chunk = N/nprocs + scount(0) = chunk +c print *,"i",0," indstart",indstart(0)," scount", +c & scount(0) + do i=1,nprocs-1 + indstart(i)=chunk+indstart(i-1) + scount(i)=scount(i-1) +c print *,"i",i," indstart",indstart(i)," scount", +c & scount(i) + enddo +C +C Determine how many conformations remained yet unassigned. +C + remainder=N-(indstart(nprocs-1) + & +scount(nprocs-1)-1) +c print *,"remainder",remainder +C +C Assign the remainder conformations to consecutive processors, starting +C from the lowest rank; this continues until the list is exhausted. +C + 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,nprocs-1 + indstart(i) = indstart(i) + remainder + enddo + endif + + indstart(nprocs)=N+1 + scount(nprocs)=0 + + do i=0,NProcs + indend(i)=indstart(i)+scount(i)-1 + idispl(i)=indstart(i)-1 + enddo + + N=0 + do i=0,Nprocs-1 + N=N+indend(i)-indstart(i)+1 + enddo + +c print *,"N",n," NCON_WORK",ncon_work + if (N.ne.ncon_work) then + write (iout,*) "!!! Checksum error on processor",me, + & n,ncon_work + call flush(iout) + call MPI_Abort( MPI_COMM_WORLD, Ierror, Errcode ) + endif + + if (lprint) then + write (iout,*) "Partition of work between processors" +C do i=0,nprocs-1 +C write (iout,'(a,i5,a,i7,a,i7,a,i7)') +C & "Processor",i," indstart",indstart(i), +C & " indend",indend(i)," count",scount(i) +C enddo + endif +c write(iout,*) "just before leave" + return + end +#endif diff --git a/source/cluster/wham/src-HCD/wrtclust.f b/source/cluster/wham/src-HCD/wrtclust.f new file mode 100644 index 0000000..fa08111 --- /dev/null +++ b/source/cluster/wham/src-HCD/wrtclust.f @@ -0,0 +1,646 @@ + SUBROUTINE WRTCLUST(NCON,ICUT,PRINTANG,PRINTPDB,printmol2,ib) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizesclu.dat' + 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' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.TORCNSTR' + include 'COMMON.SAXS' + CHARACTER*64 prefixp,NUMM,MUMM,EXTEN,extmol + character*120 cfname + character*8 ctemper + DATA EXTEN /'.pdb'/,extmol /'.mol2'/,NUMM /'000'/,MUMM /'000'/ + external ilen + logical viol_nmr + integer ib,list_peak_viol(maxdim) + double precision Esaxs_all(maxgr),Pcalc_all(maxsaxs,maxgr) + + do i=1,64 + cfname(i:i)=" " + enddo +c print *,"calling WRTCLUST",ncon +c 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') +C +C PRINT OUT THE RESULTS OF CLUSTER ANALYSIS +C + 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) +cd print *,icut,printang(icut),printpdb(icut),printmol2(icut) +cd 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)) +c WRITE (iout,'(16F5.0)') (rad2deg*phiall(IND,icon),IND=4,nphi+3) +C 12/8/93 Estimation of "diameters" of the subsequent families. + ave_dim=0.0 + amax_dim=0.0 +c write (iout,*) "ecut",ecut + emin=totfree(nconf(igr,1)) + 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 +c write (iout,*) " ncon",ncon,"i",i," j",j," ii",ii," jj",jj, +c & " ind",ind," diss",diss(ind) +c call flush(iout) + curr_dist=dabs(diss(ind)+0.0d0) +c write(iout,'(i10,4i4,f12.4)') ind,ii,jj,list_conf(ii), +c & 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 + gdt_ts_ave(igr)=0.0d0 + gdt_ha_ave(igr)=0.0d0 + tmscore_ave(igr)=0.0d0 + qpart=0.0d0 + e1=totfree(nconf(igr,1)) + do i=1,licz(igr) + icon=nconf(igr,i) + boltz=dexp(-(totfree(icon)-e1)) + rmsave(igr)=rmsave(igr)+boltz*rmstb(icon) + gdt_ts_ave(igr)=gdt_ts_ave(igr)+boltz*gdt_ts_tb(icon) + gdt_ha_ave(igr)=gdt_ha_ave(igr)+boltz*gdt_ha_tb(icon) + tmscore_ave(igr)=tmscore_ave(igr)+boltz*tmscore_tb(icon) + qpart=qpart+boltz +c write (iout,'(2i5,10f10.5)') i,icon,boltz,rmstb(icon), +c & gdt_ts_tb(icon),gdt_ha_tb(icon),tmscore_tb(icon) + enddo +c write (iout,*) "qpart",qpart + rmsave(igr)=rmsave(igr)/qpart + gdt_ts_ave(igr)=gdt_ts_ave(igr)/qpart + gdt_ha_ave(igr)=gdt_ha_ave(igr)/qpart + tmscore_ave(igr)=tmscore_ave(igr)/qpart + write (iout,'(a,f5.2,a,3(a,f7.4))') "Cluster averages: RMSD", + & rmsave(igr)," A, ", + & "TMscore",tmscore_ave(igr), + & ", GDT_TS",gdt_ts_ave(igr),", GDT_HA", + & gdt_ha_ave(igr) + 19 CONTINUE + WRITE (iout,400) + WRITE (iout,500) (list_conf(I),IASS(I),I=1,NCON) +c print *,icut,printang(icut) + IF (PRINTANG(ICUT) .and. (lprint_cart .or. lprint_int)) then + emin=totfree_gr(1) +c 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 +c 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.) + call briefout(igr,iscore(icon),totfree(icon)/beta_h(ib), + & totfree_gr(igr),nss_all(icon),ihpb_all(1,icon), + & jhpb_all(1,icon),cfname) +c print '(a)','exit briefout' + endif + endif + enddo + close(igeom) + ENDIF + IF (PRINTPDB(ICUT).gt.0) THEN +c Write out a number of conformations from each family in PDB format and +c 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) +c 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) +c 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 +c write (iout,*) i,ncon_out,nconf(i,ncon_out), +c & totfree(nconf(i,ncon_out)),emin1,ecut + enddo +c 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 center + call pdbout(totfree(icon)/beta_h(ib),rmstb(icon),titel) + write (ipdb,'("TER")') + enddo + close(ipdb) +c 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 center + call pdbout(totfree_gr(i)/beta_h(ib),rmsave(i),titel) + write (ipdb,'("TER")') + if (print_fittest.and.(nsaxs.gt.0 .or. nhpb.gt.0 + & .or.npeak.gt.0)) then + call fittest_coord(i) + else + call closest_coord(i) + endif +c write (iout,*) "Calling rmsnat" + rms_closest(i) = rmsnat(i) + + write (iout,*) "Cluster",i + call TMscore_sub(rmsd,gdt_ts_closest(i),gdt_ha_closest(i), + & tmscore_closest(i),cfname,.true.) +c write (iout,*) "WRTCLUST: nsaxs",nsaxs," i",i + if (nsaxs.gt.0 .and. saxs_mode.eq.0) then + call e_saxs(Esaxs_constr) + Cnorm=0.0d0 + do j=1,nsaxs-1 + Cnorm=Cnorm+(distsaxs(j+1)-distsaxs(j))* + & (Pcalc(j+1)+Pcalc(j))/2 + enddo + do j=1,nsaxs + Pcalc_all(j,i)=Pcalc(j)/Cnorm + enddo +c write (iout,*) "Pcalc" +c write (iout,'(f6.2,f10.5)') (distsaxs(j),Pcalc(j),j=1,nsaxs) + Esaxs_all(i)=Esaxs_constr + write (iout,*) "Esaxs",Esaxs_constr + endif + nviolxlink=0 + if (link_start.gt.0) then + do j=link_start,link_end + if (irestr_type(j).eq.10 .or. irestr_type(j).eq. 11) then + dxlink=dist(ihpb(j),jhpb(j)) + if (dxlink.le.25.0d0) then + write (iout,'(a,i2,2i5,f8.2)') "XLINK-", + & irestr_type(j),ihpb(j),jhpb(j), + & dxlink + else + nviolxlink=nviolxlink+1 + write (iout,'(a,i2,2i5,f8.2,2h *)') "XLINK-", + & irestr_type(j),ihpb(j),jhpb(j), + & dxlink + endif + endif + enddo + if (nviolxlink.gt.0) + & write (iout,*) nviolxlink," crosslink violations." +c write (iout,*) "Family",i," rmsd",rmsd,"gdt_ts", +c & gdt_ts_closest(i)," gdt_ha",gdt_ha_closest(i), +c & "tmscore",tmscore_closest(i) + endif +c Determine # violated NMR restraints + if (link_end_peak.gt.0) then + nviolpeak=0 + write (NUMM,'(bz,i4.4)') i + cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper)) + & //"K_"//NUMM(:ilen(NUMM))//'.nmr' + open(jrms,file=cfname) + do j=link_start_peak,link_end_peak + viol_nmr=.true. + do ip=ipeak(1,j),ipeak(2,j) + ii=ihpb_peak(ip) + jj=jhpb_peak(ip) + dd=dist(ii,jj) +c iip=ip-ipeak(1,j)+1 +C iii and jjj point to the residues for which the distance is assigned. + if (ii.gt.nres) then + iii=ii-nres + jjj=jj-nres + iiib=1 + else + iii=ii + jjj=jj + iiib=0 + endif + if (dd.lt.dhpb1_peak(ip)) then + viol_nmr=.false. +c write (iout,*) j,iii,jjj,iiib + write (jrms,'(4i6)') j,iii,jjj,iiib + endif + enddo + if (viol_nmr) then + nviolpeak=nviolpeak+1 + list_peak_viol(nviolpeak)=j + endif + enddo + if (nviolpeak.gt.0) then + write (iout,'(a,i5,2h (f8.4,2h%))') + & "Number of violated NMR restraints:", + & nviolpeak,100*(nviolpeak+0.)/npeak + write (iout,'(a)')"List of violated restraints:" + write (iout,'(16i5)') (list_peak_viol(j),j=1,nviolpeak) + endif + close(jrms) + endif + if (.not.raw_psipred .and. idihconstr_end.gt.0) then + cfname=prefixp(:ilen(prefixp))//"_T" + & //ctemper(:ilen(ctemper)) + & //"K_"//NUMM(:ilen(NUMM))//'.angle' + open(jrms,file=cfname) + call int_from_cart1(.false.) + nangviol=0 + do j=idihconstr_start,idihconstr_end + itori=idih_constr(j) + phii=phi(itori) + difi=pinorm(phii-phi0(j)) + if (difi.gt.drange(j) .or. difi.lt.-drange(j)) + & nangviol=nangviol+1 + write (jrms,'(i5,3f10.3)') itori,phii*rad2deg, + & phi0(j)*rad2deg,rad2deg*drange(j) + enddo + write (iout,'(a,i5)')"Number of angle-restraint violations:" + & ,nangviol + close(jrms) + endif + call center + call pdbout(totfree_gr(i)/beta_h(ib),rms_closest(i),titel) + write (ipdb,'("TER")') + close (ipdb) + I=I+1 + ICON=NCONF(I,1) + emin1=totfree(icon) + ENDDO + ngr_print=i-1 + if (nsaxs.gt.0 .and. saxs_mode.eq.0) then + cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper)) + & //"K_"//'ave'//'.dist' + OPEN(99,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED') + write (99,'(5h# ,10f10.5)') + & (Esaxs_all(i)*wsaxs,i=1,ngr_print) + do j=1,nsaxs + write (99,'(f6.2,10f10.5)') distsaxs(j), + & (Pcalc_all(j,i),i=1,ngr_print) + enddo + close(99) + endif + ENDIF + IF (printmol2(icut).gt.0) THEN +c Write out a number of conformations from each family in PDB format and +c 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 + call WRITE_STATS(ICUT,NCON,IB) + 100 FORMAT (//'THERE ARE ',I4,' FAMILIES OF CONFORMATIONS') + 200 FORMAT (/'FAMILY ',I4,' WITH TOTAL FREE ENERGY',1pE15.5, + & ' CONTAINS ',I4,' CONFORMATION(S): ') +c 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 +c------------------------------------------------------------------------------ + subroutine ave_coord(igr) + 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 + double precision przes(3),obrot(3,3) + double precision xx(3,maxres2),csq(3,maxres2) + double precision eref + double precision rmscalc +c double precision rmscheck + integer i,ii,j,k,icon,jcon,igr,ipermmin + double precision rms,boltz,qpart,cwork(3,maxres2),cref1(3,maxres2) +c 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) +c write (iout,*) "k",k," jcon",jcon + do i=1,2*nres + do j=1,3 + cwork(j,i)=allcart(j,i,jcon) + enddo + enddo + rms=rmscalc(cwork(1,1),cref1(1,1),przes,obrot,ipermmin) +c write (iout,*) "rms",rms," ipermmin",ipermmin +c do i=1,3 +c write (iout,'(i3,f10.5,5x,3f10.5)')i,przes(i), +c & (obrot(i,j),j=1,3) +c enddo +c if (rms.lt.0.0) then +c print *,'error, rms^2 = ',rms,icon,jcon +c stop +c endif +c 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 +c write (iout,'(i5,2(3f10.5,5x))') i,(cwork(j,i),j=1,3), +c & (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 +c rms check +c rmscheck=0.0d0 +c do i=nnt,nct +c do j=1,3 +c rmscheck=rmscheck+(cwork(j,i)-cref1(j,i))**2 +c enddo +c enddo +c write (iout,*) "rmscheck",dsqrt(rmscheck/(nct-nnt+1)),rms + 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 +c 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 +c------------------------------------------------------------------------------ + subroutine fittest_coord(igr) + 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' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.SAXS' + logical non_conv + double precision przes(3),obrot(3,3) + double precision xx(3,maxres2),yy(3,maxres2) + integer i,ii,j,k,icon,jcon,jconmin,igr + double precision rms,rmsmin,cwork(3,maxres2) + double precision ehpb,Esaxs_constr,edihcnstr + rmsmin=1.0d10 + jconmin=nconf(igr,1) + DO K=1,LICZ(IGR) + jcon=nconf(igr,k) + do i=1,2*nres + do j=1,3 + c(j,i)=allcart(j,i,jcon) + enddo + enddo + call int_from_cart1(.false.) + esaxs_constr=0 + ehpb=0 + edihcnstr=0 + if (nsaxs.gt.0) call e_saxs(Esaxs_constr) + call edis(ehpb) + if (ndih_constr.gt.0) call etor_constr(edihcnstr) + rms=wsaxs*esaxs_constr+wstrain*ehpb+edihcnstr +c write (iout,*) "Esaxs_constr",esaxs_constr," Ehpb",ehpb, +c & " Edihcnstr",edihcnstr + if (rms.lt.rmsmin) then + jconmin=nconf(igr,k) + rmsmin=rms + endif + ENDDO ! K + write (iout,*) "fittest conformation",jconmin," penalty",rmsmin + do i=1,2*nres + do j=1,3 + c(j,i)=allcart(j,i,jconmin) + enddo + enddo + return + end +c------------------------------------------------------------------------------ + subroutine closest_coord(igr) + 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 + double precision przes(3),obrot(3,3) + integer i,ii,j,k,icon,jcon,jconmin,igr,ipermmin + double precision rms,rmsmin,cwork(3,maxres2) + double precision xx(3,maxres2),yy(3,maxres2) + double precision rmscalc + rmsmin=1.0d10 + jconmin=nconf(igr,1) + DO K=1,LICZ(IGR) + jcon=nconf(igr,k) + do i=1,2*nres + do j=1,3 + xx(j,i)=c(j,i) + yy(j,i)=allcart(j,i,jcon) + enddo + enddo + rms=rmscalc(xx(1,1),yy(1,1),przes,obrot,ipermmin) +c 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 +c write (iout,*) "rmsmin",rmsmin," rms",rms +c call flush(iout) + do i=1,2*nres + do j=1,3 + c(j,i)=allcart(j,i,jconmin) + enddo + enddo + return + end +c------------------------------------------------------------------------------ + subroutine center + 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' + double precision przes(3) + integer i,ii,j,k,icon,jcon,jconmin,igr + przes=0.0d0 + do j=1,3 + do i=1,nres + przes(j)=przes(j)+c(j,i) + enddo + enddo + do j=1,3 + przes(j)=przes(j)/nres + enddo + do i=1,2*nres + do j=1,3 + c(j,i)=c(j,i)-przes(j) + enddo + enddo + return + end diff --git a/source/cluster/wham/src-HCD/xdrf/Makefile b/source/cluster/wham/src-HCD/xdrf/Makefile new file mode 100644 index 0000000..02c29f6 --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/Makefile @@ -0,0 +1,27 @@ +# This make file is part of the xdrf package. +# +# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl +# +# 2006 modified by Cezary Czaplewski + +# Set C compiler and flags for ARCH +CC = gcc +CFLAGS = -O + +M4 = m4 +M4FILE = underscore.m4 + +libxdrf.a: libxdrf.o ftocstr.o + ar cr libxdrf.a $? + +clean: + rm -f libxdrf.o ftocstr.o libxdrf.a + +ftocstr.o: ftocstr.c + $(CC) $(CFLAGS) -c ftocstr.c + +libxdrf.o: libxdrf.m4 $(M4FILE) + $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c + $(CC) $(CFLAGS) -c libxdrf.c + rm -f libxdrf.c + diff --git a/source/cluster/wham/src-HCD/xdrf/Makefile_jubl b/source/cluster/wham/src-HCD/xdrf/Makefile_jubl new file mode 100644 index 0000000..8dc35cf --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/Makefile_jubl @@ -0,0 +1,31 @@ +# This make file is part of the xdrf package. +# +# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl +# +# 2006 modified by Cezary Czaplewski + +# Set C compiler and flags for ARCH +BGLSYS = /bgl/BlueLight/ppcfloor/bglsys + +CC = /usr/bin/blrts_xlc +CPPC = /usr/bin/blrts_xlc + +CFLAGS= -O2 -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 + +M4 = m4 +M4FILE = RS6K.m4 + +libxdrf.a: libxdrf.o ftocstr.o xdr_array.o xdr.o xdr_float.o xdr_stdio.o + ar cr libxdrf.a $? + +clean: + rm -f *.o libxdrf.a + +ftocstr.o: ftocstr.c + $(CC) $(CFLAGS) -c ftocstr.c + +libxdrf.o: libxdrf.m4 $(M4FILE) + $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c + $(CC) $(CFLAGS) -c libxdrf.c +# rm -f libxdrf.c + diff --git a/source/cluster/wham/src-HCD/xdrf/Makefile_linux b/source/cluster/wham/src-HCD/xdrf/Makefile_linux new file mode 100644 index 0000000..f03276e --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/Makefile_linux @@ -0,0 +1,27 @@ +# This make file is part of the xdrf package. +# +# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl +# +# 2006 modified by Cezary Czaplewski + +# Set C compiler and flags for ARCH +CC = cc +CFLAGS = -O + +M4 = m4 +M4FILE = underscore.m4 + +libxdrf.a: libxdrf.o ftocstr.o + ar cr libxdrf.a $? + +clean: + rm -f libxdrf.o ftocstr.o libxdrf.a + +ftocstr.o: ftocstr.c + $(CC) $(CFLAGS) -c ftocstr.c + +libxdrf.o: libxdrf.m4 $(M4FILE) + $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c + $(CC) $(CFLAGS) -c libxdrf.c + rm -f libxdrf.c + diff --git a/source/cluster/wham/src-HCD/xdrf/RS6K.m4 b/source/cluster/wham/src-HCD/xdrf/RS6K.m4 new file mode 100644 index 0000000..0331d97 --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/RS6K.m4 @@ -0,0 +1,20 @@ +divert(-1) +undefine(`len') +# +# do nothing special to FORTRAN function names +# +define(`FUNCTION',`$1') +# +# FORTRAN character strings are passed as follows: +# a pointer to the base of the string is passed in the normal +# argument list, and the length is passed by value as an extra +# argument, after all of the other arguments. +# +define(`ARGS',`($1`'undivert(1))') +define(`SAVE',`divert(1)$1`'divert(0)') +define(`STRING_ARG',`$1_ptr`'SAVE(`, $1_len')') +define(`STRING_ARG_DECL',`char * $1_ptr; int $1_len') +define(`STRING_LEN',`$1_len') +define(`STRING_PTR',`$1_ptr') +divert(0) + diff --git a/source/cluster/wham/src-HCD/xdrf/ftocstr.c b/source/cluster/wham/src-HCD/xdrf/ftocstr.c new file mode 100644 index 0000000..ed2113f --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/ftocstr.c @@ -0,0 +1,35 @@ + + +int ftocstr(ds, dl, ss, sl) + char *ds, *ss; /* dst, src ptrs */ + int dl; /* dst max len */ + int sl; /* src len */ +{ + char *p; + + for (p = ss + sl; --p >= ss && *p == ' '; ) ; + sl = p - ss + 1; + dl--; + ds[0] = 0; + if (sl > dl) + return 1; + while (sl--) + (*ds++ = *ss++); + *ds = '\0'; + return 0; +} + + +int ctofstr(ds, dl, ss) + char *ds; /* dest space */ + int dl; /* max dest length */ + char *ss; /* src string (0-term) */ +{ + while (dl && *ss) { + *ds++ = *ss++; + dl--; + } + while (dl--) + *ds++ = ' '; + return 0; +} diff --git a/source/cluster/wham/src-HCD/xdrf/libxdrf.m4 b/source/cluster/wham/src-HCD/xdrf/libxdrf.m4 new file mode 100644 index 0000000..a6da458 --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/libxdrf.m4 @@ -0,0 +1,1238 @@ +/*____________________________________________________________________________ + | + | libxdrf - portable fortran interface to xdr. some xdr routines + | are C routines for compressed coordinates + | + | version 1.1 + | + | This collection of routines is intended to write and read + | data in a portable way to a file, so data written on one type + | of machine can be read back on a different type. + | + | all fortran routines use an integer 'xdrid', which is an id to the + | current xdr file, and is set by xdrfopen. + | most routines have in integer 'ret' which is the return value. + | The value of 'ret' is zero on failure, and most of the time one + | on succes. + | + | There are three routines useful for C users: + | xdropen(), xdrclose(), xdr3dfcoord(). + | The first two replace xdrstdio_create and xdr_destroy, and *must* be + | used when you plan to use xdr3dfcoord(). (they are also a bit + | easier to interface). For writing data other than compressed coordinates + | you should use the standard C xdr routines (see xdr man page) + | + | xdrfopen(xdrid, filename, mode, ret) + | character *(*) filename + | character *(*) mode + | + | this will open the file with the given filename (string) + | and the given mode, it returns an id in xdrid, which is + | to be used in all other calls to xdrf routines. + | mode is 'w' to create, or update an file, for all other + | values of mode the file is opened for reading + | + | you need to call xdrfclose to flush the output and close + | the file. + | Note that you should not use xdrstdio_create, which comes with the + | standard xdr library + | + | xdrfclose(xdrid, ret) + | flush the data to the file, and closes the file; + | You should not use xdr_destroy (which comes standard with + | the xdr libraries. + | + | xdrfbool(xdrid, bp, ret) + | integer pb + | + | This filter produces values of either 1 or 0 + | + | xdrfchar(xdrid, cp, ret) + | character cp + | + | filter that translate between characters and their xdr representation + | Note that the characters in not compressed and occupies 4 bytes. + | + | xdrfdouble(xdrid, dp, ret) + | double dp + | + | read/write a double. + | + | xdrffloat(xdrid, fp, ret) + | float fp + | + | read/write a float. + | + | xdrfint(xdrid, ip, ret) + | integer ip + | + | read/write integer. + | + | xdrflong(xdrid, lp, ret) + | integer lp + | + | this routine has a possible portablility problem due to 64 bits longs. + | + | xdrfshort(xdrid, sp, ret) + | integer *2 sp + | + | xdrfstring(xdrid, sp, maxsize, ret) + | character *(*) + | integer maxsize + | + | read/write a string, with maximum length given by maxsize + | + | xdrfwrapstring(xdris, sp, ret) + | character *(*) + | + | read/write a string (it is the same as xdrfstring accept that it finds + | the stringlength itself. + | + | xdrfvector(xdrid, cp, size, xdrfproc, ret) + | character *(*) + | integer size + | external xdrfproc + | + | read/write an array pointed to by cp, with number of elements + | defined by 'size'. the routine 'xdrfproc' is the name + | of one of the above routines to read/write data (like xdrfdouble) + | In contrast with the c-version you don't need to specify the + | byte size of an element. + | xdrfstring is not allowed here (it is in the c version) + | + | xdrf3dfcoord(xdrid, fp, size, precision, ret) + | real (*) fp + | real precision + | integer size + | + | this is *NOT* a standard xdr routine. I named it this way, because + | it invites people to use the other xdr routines. + | It is introduced to store specifically 3d coordinates of molecules + | (as found in molecular dynamics) and it writes it in a compressed way. + | It starts by multiplying all numbers by precision and + | rounding the result to integer. effectively converting + | all floating point numbers to fixed point. + | it uses an algorithm for compression that is optimized for + | molecular data, but could be used for other 3d coordinates + | as well. There is subtantial overhead involved, so call this + | routine only if you have a large number of coordinates to read/write + | + | ________________________________________________________________________ + | + | Below are the routines to be used by C programmers. Use the 'normal' + | xdr routines to write integers, floats, etc (see man xdr) + | + | int xdropen(XDR *xdrs, const char *filename, const char *type) + | This will open the file with the given filename and the + | given mode. You should pass it an allocated XDR struct + | in xdrs, to be used in all other calls to xdr routines. + | Mode is 'w' to create, or update an file, and for all + | other values of mode the file is opened for reading. + | You need to call xdrclose to flush the output and close + | the file. + | + | Note that you should not use xdrstdio_create, which + | comes with the standard xdr library. + | + | int xdrclose(XDR *xdrs) + | Flush the data to the file, and close the file; + | You should not use xdr_destroy (which comes standard + | with the xdr libraries). + | + | int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) + | This is \fInot\fR a standard xdr routine. I named it this + | way, because it invites people to use the other xdr + | routines. + | + | (c) 1995 Frans van Hoesel, hoesel@chem.rug.nl +*/ + + +#include +#include +#include +/* #include +#include */ +#include "xdr.h" +#include +#include +#include "xdrf.h" + +int ftocstr(char *, int, char *, int); +int ctofstr(char *, int, char *); + +#define MAXID 20 +static FILE *xdrfiles[MAXID]; +static XDR *xdridptr[MAXID]; +static char xdrmodes[MAXID]; +static unsigned int cnt; + +typedef void (* FUNCTION(xdrfproc)) (int *, void *, int *); + +void +FUNCTION(xdrfbool) ARGS(`xdrid, pb, ret') +int *xdrid, *ret; +int *pb; +{ + *ret = xdr_bool(xdridptr[*xdrid], (bool_t *) pb); + cnt += sizeof(int); +} + +void +FUNCTION(xdrfchar) ARGS(`xdrid, cp, ret') +int *xdrid, *ret; +char *cp; +{ + *ret = xdr_char(xdridptr[*xdrid], cp); + cnt += sizeof(char); +} + +void +FUNCTION(xdrfdouble) ARGS(`xdrid, dp, ret') +int *xdrid, *ret; +double *dp; +{ + *ret = xdr_double(xdridptr[*xdrid], dp); + cnt += sizeof(double); +} + +void +FUNCTION(xdrffloat) ARGS(`xdrid, fp, ret') +int *xdrid, *ret; +float *fp; +{ + *ret = xdr_float(xdridptr[*xdrid], fp); + cnt += sizeof(float); +} + +void +FUNCTION(xdrfint) ARGS(`xdrid, ip, ret') +int *xdrid, *ret; +int *ip; +{ + *ret = xdr_int(xdridptr[*xdrid], ip); + cnt += sizeof(int); +} + +void +FUNCTION(xdrflong) ARGS(`xdrid, lp, ret') +int *xdrid, *ret; +long *lp; +{ + *ret = xdr_long(xdridptr[*xdrid], lp); + cnt += sizeof(long); +} + +void +FUNCTION(xdrfshort) ARGS(`xdrid, sp, ret') +int *xdrid, *ret; +short *sp; +{ + *ret = xdr_short(xdridptr[*xdrid], sp); + cnt += sizeof(sp); +} + +void +FUNCTION(xdrfuchar) ARGS(`xdrid, ucp, ret') +int *xdrid, *ret; +char *ucp; +{ + *ret = xdr_u_char(xdridptr[*xdrid], ucp); + cnt += sizeof(char); +} + +void +FUNCTION(xdrfulong) ARGS(`xdrid, ulp, ret') +int *xdrid, *ret; +unsigned long *ulp; +{ + *ret = xdr_u_long(xdridptr[*xdrid], ulp); + cnt += sizeof(unsigned long); +} + +void +FUNCTION(xdrfushort) ARGS(`xdrid, usp, ret') +int *xdrid, *ret; +unsigned short *usp; +{ + *ret = xdr_u_short(xdridptr[*xdrid], usp); + cnt += sizeof(unsigned short); +} + +void +FUNCTION(xdrf3dfcoord) ARGS(`xdrid, fp, size, precision, ret') +int *xdrid, *ret; +float *fp; +int *size; +float *precision; +{ + *ret = xdr3dfcoord(xdridptr[*xdrid], fp, size, precision); +} + +void +FUNCTION(xdrfstring) ARGS(`xdrid, STRING_ARG(sp), maxsize, ret') +int *xdrid, *ret; +STRING_ARG_DECL(sp); +int *maxsize; +{ + char *tsp; + + tsp = (char*) malloc(((STRING_LEN(sp)) + 1) * sizeof(char)); + if (tsp == NULL) { + *ret = -1; + return; + } + if (ftocstr(tsp, *maxsize+1, STRING_PTR(sp), STRING_LEN(sp))) { + *ret = -1; + free(tsp); + return; + } + *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int) *maxsize); + ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp); + cnt += *maxsize; + free(tsp); +} + +void +FUNCTION(xdrfwrapstring) ARGS(`xdrid, STRING_ARG(sp), ret') +int *xdrid, *ret; +STRING_ARG_DECL(sp); +{ + char *tsp; + int maxsize; + maxsize = (STRING_LEN(sp)) + 1; + tsp = (char*) malloc(maxsize * sizeof(char)); + if (tsp == NULL) { + *ret = -1; + return; + } + if (ftocstr(tsp, maxsize, STRING_PTR(sp), STRING_LEN(sp))) { + *ret = -1; + free(tsp); + return; + } + *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int)maxsize); + ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp); + cnt += maxsize; + free(tsp); +} + +void +FUNCTION(xdrfopaque) ARGS(`xdrid, cp, ccnt, ret') +int *xdrid, *ret; +caddr_t *cp; +int *ccnt; +{ + *ret = xdr_opaque(xdridptr[*xdrid], (caddr_t)*cp, (u_int)*ccnt); + cnt += *ccnt; +} + +void +FUNCTION(xdrfsetpos) ARGS(`xdrid, pos, ret') +int *xdrid, *ret; +int *pos; +{ + *ret = xdr_setpos(xdridptr[*xdrid], (u_int) *pos); +} + +void +FUNCTION(xdrf) ARGS(`xdrid, pos') +int *xdrid, *pos; +{ + *pos = xdr_getpos(xdridptr[*xdrid]); +} + +void +FUNCTION(xdrfvector) ARGS(`xdrid, cp, size, elproc, ret') +int *xdrid, *ret; +char *cp; +int *size; +FUNCTION(xdrfproc) elproc; +{ + int lcnt; + cnt = 0; + for (lcnt = 0; lcnt < *size; lcnt++) { + elproc(xdrid, (cp+cnt) , ret); + } +} + + +void +FUNCTION(xdrfclose) ARGS(`xdrid, ret') +int *xdrid; +int *ret; +{ + *ret = xdrclose(xdridptr[*xdrid]); + cnt = 0; +} + +void +FUNCTION(xdrfopen) ARGS(`xdrid, STRING_ARG(fp), STRING_ARG(mode), ret') +int *xdrid; +STRING_ARG_DECL(fp); +STRING_ARG_DECL(mode); +int *ret; +{ + char fname[512]; + char fmode[3]; + + if (ftocstr(fname, sizeof(fname), STRING_PTR(fp), STRING_LEN(fp))) { + *ret = 0; + } + if (ftocstr(fmode, sizeof(fmode), STRING_PTR(mode), + STRING_LEN(mode))) { + *ret = 0; + } + + *xdrid = xdropen(NULL, fname, fmode); + if (*xdrid == 0) + *ret = 0; + else + *ret = 1; +} + +/*___________________________________________________________________________ + | + | what follows are the C routines for opening, closing xdr streams + | and the routine to read/write compressed coordinates together + | with some routines to assist in this task (those are marked + | static and cannot be called from user programs) +*/ +#define MAXABS INT_MAX-2 + +#ifndef MIN +#define MIN(x,y) ((x) < (y) ? (x):(y)) +#endif +#ifndef MAX +#define MAX(x,y) ((x) > (y) ? (x):(y)) +#endif +#ifndef SQR +#define SQR(x) ((x)*(x)) +#endif +static int magicints[] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, + 8, 10, 12, 16, 20, 25, 32, 40, 50, 64, + 80, 101, 128, 161, 203, 256, 322, 406, 512, 645, + 812, 1024, 1290, 1625, 2048, 2580, 3250, 4096, 5060, 6501, + 8192, 10321, 13003, 16384, 20642, 26007, 32768, 41285, 52015, 65536, + 82570, 104031, 131072, 165140, 208063, 262144, 330280, 416127, 524287, 660561, + 832255, 1048576, 1321122, 1664510, 2097152, 2642245, 3329021, 4194304, 5284491, 6658042, + 8388607, 10568983, 13316085, 16777216 }; + +#define FIRSTIDX 9 +/* note that magicints[FIRSTIDX-1] == 0 */ +#define LASTIDX (sizeof(magicints) / sizeof(*magicints)) + + +/*__________________________________________________________________________ + | + | xdropen - open xdr file + | + | This versions differs from xdrstdio_create, because I need to know + | the state of the file (read or write) so I can use xdr3dfcoord + | in eigther read or write mode, and the file descriptor + | so I can close the file (something xdr_destroy doesn't do). + | +*/ + +int xdropen(XDR *xdrs, const char *filename, const char *type) { + static int init_done = 0; + enum xdr_op lmode; + const char *type1; + int xdrid; + + if (init_done == 0) { + for (xdrid = 1; xdrid < MAXID; xdrid++) { + xdridptr[xdrid] = NULL; + } + init_done = 1; + } + xdrid = 1; + while (xdrid < MAXID && xdridptr[xdrid] != NULL) { + xdrid++; + } + if (xdrid == MAXID) { + return 0; + } + if (*type == 'w' || *type == 'W') { + type = "w+"; + type1 = "w+"; + lmode = XDR_ENCODE; + } else if (*type == 'a' || *type == 'A') { + type = "w+"; + type1 = "a+"; + lmode = XDR_ENCODE; + } else { + type = "r"; + type1 = "r"; + lmode = XDR_DECODE; + } + xdrfiles[xdrid] = fopen(filename, type1); + if (xdrfiles[xdrid] == NULL) { + xdrs = NULL; + return 0; + } + xdrmodes[xdrid] = *type; + /* next test isn't usefull in the case of C language + * but is used for the Fortran interface + * (C users are expected to pass the address of an already allocated + * XDR staructure) + */ + if (xdrs == NULL) { + xdridptr[xdrid] = (XDR *) malloc(sizeof(XDR)); + xdrstdio_create(xdridptr[xdrid], xdrfiles[xdrid], lmode); + } else { + xdridptr[xdrid] = xdrs; + xdrstdio_create(xdrs, xdrfiles[xdrid], lmode); + } + return xdrid; +} + +/*_________________________________________________________________________ + | + | xdrclose - close a xdr file + | + | This will flush the xdr buffers, and destroy the xdr stream. + | It also closes the associated file descriptor (this is *not* + | done by xdr_destroy). + | +*/ + +int xdrclose(XDR *xdrs) { + int xdrid; + + if (xdrs == NULL) { + fprintf(stderr, "xdrclose: passed a NULL pointer\n"); + exit(1); + } + for (xdrid = 1; xdrid < MAXID; xdrid++) { + if (xdridptr[xdrid] == xdrs) { + + xdr_destroy(xdrs); + fclose(xdrfiles[xdrid]); + xdridptr[xdrid] = NULL; + return 1; + } + } + fprintf(stderr, "xdrclose: no such open xdr file\n"); + exit(1); + +} + +/*____________________________________________________________________________ + | + | sendbits - encode num into buf using the specified number of bits + | + | This routines appends the value of num to the bits already present in + | the array buf. You need to give it the number of bits to use and you + | better make sure that this number of bits is enough to hold the value + | Also num must be positive. + | +*/ + +static void sendbits(int buf[], int num_of_bits, int num) { + + unsigned int cnt, lastbyte; + int lastbits; + unsigned char * cbuf; + + cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf); + cnt = (unsigned int) buf[0]; + lastbits = buf[1]; + lastbyte =(unsigned int) buf[2]; + while (num_of_bits >= 8) { + lastbyte = (lastbyte << 8) | ((num >> (num_of_bits -8)) /* & 0xff*/); + cbuf[cnt++] = lastbyte >> lastbits; + num_of_bits -= 8; + } + if (num_of_bits > 0) { + lastbyte = (lastbyte << num_of_bits) | num; + lastbits += num_of_bits; + if (lastbits >= 8) { + lastbits -= 8; + cbuf[cnt++] = lastbyte >> lastbits; + } + } + buf[0] = cnt; + buf[1] = lastbits; + buf[2] = lastbyte; + if (lastbits>0) { + cbuf[cnt] = lastbyte << (8 - lastbits); + } +} + +/*_________________________________________________________________________ + | + | sizeofint - calculate bitsize of an integer + | + | return the number of bits needed to store an integer with given max size + | +*/ + +static int sizeofint(const int size) { + unsigned int num = 1; + int num_of_bits = 0; + + while (size >= num && num_of_bits < 32) { + num_of_bits++; + num <<= 1; + } + return num_of_bits; +} + +/*___________________________________________________________________________ + | + | sizeofints - calculate 'bitsize' of compressed ints + | + | given the number of small unsigned integers and the maximum value + | return the number of bits needed to read or write them with the + | routines receiveints and sendints. You need this parameter when + | calling these routines. Note that for many calls I can use + | the variable 'smallidx' which is exactly the number of bits, and + | So I don't need to call 'sizeofints for those calls. +*/ + +static int sizeofints( const int num_of_ints, unsigned int sizes[]) { + int i, num; + unsigned int num_of_bytes, num_of_bits, bytes[32], bytecnt, tmp; + num_of_bytes = 1; + bytes[0] = 1; + num_of_bits = 0; + for (i=0; i < num_of_ints; i++) { + tmp = 0; + for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) { + tmp = bytes[bytecnt] * sizes[i] + tmp; + bytes[bytecnt] = tmp & 0xff; + tmp >>= 8; + } + while (tmp != 0) { + bytes[bytecnt++] = tmp & 0xff; + tmp >>= 8; + } + num_of_bytes = bytecnt; + } + num = 1; + num_of_bytes--; + while (bytes[num_of_bytes] >= num) { + num_of_bits++; + num *= 2; + } + return num_of_bits + num_of_bytes * 8; + +} + +/*____________________________________________________________________________ + | + | sendints - send a small set of small integers in compressed format + | + | this routine is used internally by xdr3dfcoord, to send a set of + | small integers to the buffer. + | Multiplication with fixed (specified maximum ) sizes is used to get + | to one big, multibyte integer. Allthough the routine could be + | modified to handle sizes bigger than 16777216, or more than just + | a few integers, this is not done, because the gain in compression + | isn't worth the effort. Note that overflowing the multiplication + | or the byte buffer (32 bytes) is unchecked and causes bad results. + | + */ + +static void sendints(int buf[], const int num_of_ints, const int num_of_bits, + unsigned int sizes[], unsigned int nums[]) { + + int i; + unsigned int bytes[32], num_of_bytes, bytecnt, tmp; + + tmp = nums[0]; + num_of_bytes = 0; + do { + bytes[num_of_bytes++] = tmp & 0xff; + tmp >>= 8; + } while (tmp != 0); + + for (i = 1; i < num_of_ints; i++) { + if (nums[i] >= sizes[i]) { + fprintf(stderr,"major breakdown in sendints num %d doesn't " + "match size %d\n", nums[i], sizes[i]); + exit(1); + } + /* use one step multiply */ + tmp = nums[i]; + for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) { + tmp = bytes[bytecnt] * sizes[i] + tmp; + bytes[bytecnt] = tmp & 0xff; + tmp >>= 8; + } + while (tmp != 0) { + bytes[bytecnt++] = tmp & 0xff; + tmp >>= 8; + } + num_of_bytes = bytecnt; + } + if (num_of_bits >= num_of_bytes * 8) { + for (i = 0; i < num_of_bytes; i++) { + sendbits(buf, 8, bytes[i]); + } + sendbits(buf, num_of_bits - num_of_bytes * 8, 0); + } else { + for (i = 0; i < num_of_bytes-1; i++) { + sendbits(buf, 8, bytes[i]); + } + sendbits(buf, num_of_bits- (num_of_bytes -1) * 8, bytes[i]); + } +} + + +/*___________________________________________________________________________ + | + | receivebits - decode number from buf using specified number of bits + | + | extract the number of bits from the array buf and construct an integer + | from it. Return that value. + | +*/ + +static int receivebits(int buf[], int num_of_bits) { + + int cnt, num; + unsigned int lastbits, lastbyte; + unsigned char * cbuf; + int mask = (1 << num_of_bits) -1; + + cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf); + cnt = buf[0]; + lastbits = (unsigned int) buf[1]; + lastbyte = (unsigned int) buf[2]; + + num = 0; + while (num_of_bits >= 8) { + lastbyte = ( lastbyte << 8 ) | cbuf[cnt++]; + num |= (lastbyte >> lastbits) << (num_of_bits - 8); + num_of_bits -=8; + } + if (num_of_bits > 0) { + if (lastbits < num_of_bits) { + lastbits += 8; + lastbyte = (lastbyte << 8) | cbuf[cnt++]; + } + lastbits -= num_of_bits; + num |= (lastbyte >> lastbits) & ((1 << num_of_bits) -1); + } + num &= mask; + buf[0] = cnt; + buf[1] = lastbits; + buf[2] = lastbyte; + return num; +} + +/*____________________________________________________________________________ + | + | receiveints - decode 'small' integers from the buf array + | + | this routine is the inverse from sendints() and decodes the small integers + | written to buf by calculating the remainder and doing divisions with + | the given sizes[]. You need to specify the total number of bits to be + | used from buf in num_of_bits. + | +*/ + +static void receiveints(int buf[], const int num_of_ints, int num_of_bits, + unsigned int sizes[], int nums[]) { + int bytes[32]; + int i, j, num_of_bytes, p, num; + + bytes[1] = bytes[2] = bytes[3] = 0; + num_of_bytes = 0; + while (num_of_bits > 8) { + bytes[num_of_bytes++] = receivebits(buf, 8); + num_of_bits -= 8; + } + if (num_of_bits > 0) { + bytes[num_of_bytes++] = receivebits(buf, num_of_bits); + } + for (i = num_of_ints-1; i > 0; i--) { + num = 0; + for (j = num_of_bytes-1; j >=0; j--) { + num = (num << 8) | bytes[j]; + p = num / sizes[i]; + bytes[j] = p; + num = num - p * sizes[i]; + } + nums[i] = num; + } + nums[0] = bytes[0] | (bytes[1] << 8) | (bytes[2] << 16) | (bytes[3] << 24); +} + +/*____________________________________________________________________________ + | + | xdr3dfcoord - read or write compressed 3d coordinates to xdr file. + | + | this routine reads or writes (depending on how you opened the file with + | xdropen() ) a large number of 3d coordinates (stored in *fp). + | The number of coordinates triplets to write is given by *size. On + | read this number may be zero, in which case it reads as many as were written + | or it may specify the number if triplets to read (which should match the + | number written). + | Compression is achieved by first converting all floating numbers to integer + | using multiplication by *precision and rounding to the nearest integer. + | Then the minimum and maximum value are calculated to determine the range. + | The limited range of integers so found, is used to compress the coordinates. + | In addition the differences between succesive coordinates is calculated. + | If the difference happens to be 'small' then only the difference is saved, + | compressing the data even more. The notion of 'small' is changed dynamically + | and is enlarged or reduced whenever needed or possible. + | Extra compression is achieved in the case of GROMOS and coordinates of + | water molecules. GROMOS first writes out the Oxygen position, followed by + | the two hydrogens. In order to make the differences smaller (and thereby + | compression the data better) the order is changed into first one hydrogen + | then the oxygen, followed by the other hydrogen. This is rather special, but + | it shouldn't harm in the general case. + | + */ + +int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) { + + + static int *ip = NULL; + static int oldsize; + static int *buf; + + int minint[3], maxint[3], mindiff, *lip, diff; + int lint1, lint2, lint3, oldlint1, oldlint2, oldlint3, smallidx; + int minidx, maxidx; + unsigned sizeint[3], sizesmall[3], bitsizeint[3], size3, *luip; + int flag, k; + int small, smaller, larger, i, is_small, is_smaller, run, prevrun; + float *lfp, lf; + int tmp, *thiscoord, prevcoord[3]; + unsigned int tmpcoord[30]; + + int bufsize, xdrid, lsize; + unsigned int bitsize; + float inv_precision; + int errval = 1; + + /* find out if xdrs is opened for reading or for writing */ + xdrid = 0; + while (xdridptr[xdrid] != xdrs) { + xdrid++; + if (xdrid >= MAXID) { + fprintf(stderr, "xdr error. no open xdr stream\n"); + exit (1); + } + } + if (xdrmodes[xdrid] == 'w') { + + /* xdrs is open for writing */ + + if (xdr_int(xdrs, size) == 0) + return 0; + size3 = *size * 3; + /* when the number of coordinates is small, don't try to compress; just + * write them as floats using xdr_vector + */ + if (*size <= 9 ) { + return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp), + (xdrproc_t)xdr_float)); + } + + xdr_float(xdrs, precision); + if (ip == NULL) { + ip = (int *)malloc(size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)malloc(bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } else if (*size > oldsize) { + ip = (int *)realloc(ip, size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)realloc(buf, bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } + /* buf[0-2] are special and do not contain actual data */ + buf[0] = buf[1] = buf[2] = 0; + minint[0] = minint[1] = minint[2] = INT_MAX; + maxint[0] = maxint[1] = maxint[2] = INT_MIN; + prevrun = -1; + lfp = fp; + lip = ip; + mindiff = INT_MAX; + oldlint1 = oldlint2 = oldlint3 = 0; + while(lfp < fp + size3 ) { + /* find nearest integer */ + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint1 = lf; + if (lint1 < minint[0]) minint[0] = lint1; + if (lint1 > maxint[0]) maxint[0] = lint1; + *lip++ = lint1; + lfp++; + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint2 = lf; + if (lint2 < minint[1]) minint[1] = lint2; + if (lint2 > maxint[1]) maxint[1] = lint2; + *lip++ = lint2; + lfp++; + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint3 = lf; + if (lint3 < minint[2]) minint[2] = lint3; + if (lint3 > maxint[2]) maxint[2] = lint3; + *lip++ = lint3; + lfp++; + diff = abs(oldlint1-lint1)+abs(oldlint2-lint2)+abs(oldlint3-lint3); + if (diff < mindiff && lfp > fp + 3) + mindiff = diff; + oldlint1 = lint1; + oldlint2 = lint2; + oldlint3 = lint3; + } + xdr_int(xdrs, &(minint[0])); + xdr_int(xdrs, &(minint[1])); + xdr_int(xdrs, &(minint[2])); + + xdr_int(xdrs, &(maxint[0])); + xdr_int(xdrs, &(maxint[1])); + xdr_int(xdrs, &(maxint[2])); + + if ((float)maxint[0] - (float)minint[0] >= MAXABS || + (float)maxint[1] - (float)minint[1] >= MAXABS || + (float)maxint[2] - (float)minint[2] >= MAXABS) { + /* turning value in unsigned by subtracting minint + * would cause overflow + */ + errval = 0; + } + sizeint[0] = maxint[0] - minint[0]+1; + sizeint[1] = maxint[1] - minint[1]+1; + sizeint[2] = maxint[2] - minint[2]+1; + + /* check if one of the sizes is to big to be multiplied */ + if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) { + bitsizeint[0] = sizeofint(sizeint[0]); + bitsizeint[1] = sizeofint(sizeint[1]); + bitsizeint[2] = sizeofint(sizeint[2]); + bitsize = 0; /* flag the use of large sizes */ + } else { + bitsize = sizeofints(3, sizeint); + } + lip = ip; + luip = (unsigned int *) ip; + smallidx = FIRSTIDX; + while (smallidx < LASTIDX && magicints[smallidx] < mindiff) { + smallidx++; + } + xdr_int(xdrs, &smallidx); + maxidx = MIN(LASTIDX, smallidx + 8) ; + minidx = maxidx - 8; /* often this equal smallidx */ + smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2; + small = magicints[smallidx] / 2; + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx]; + larger = magicints[maxidx] / 2; + i = 0; + while (i < *size) { + is_small = 0; + thiscoord = (int *)(luip) + i * 3; + if (smallidx < maxidx && i >= 1 && + abs(thiscoord[0] - prevcoord[0]) < larger && + abs(thiscoord[1] - prevcoord[1]) < larger && + abs(thiscoord[2] - prevcoord[2]) < larger) { + is_smaller = 1; + } else if (smallidx > minidx) { + is_smaller = -1; + } else { + is_smaller = 0; + } + if (i + 1 < *size) { + if (abs(thiscoord[0] - thiscoord[3]) < small && + abs(thiscoord[1] - thiscoord[4]) < small && + abs(thiscoord[2] - thiscoord[5]) < small) { + /* interchange first with second atom for better + * compression of water molecules + */ + tmp = thiscoord[0]; thiscoord[0] = thiscoord[3]; + thiscoord[3] = tmp; + tmp = thiscoord[1]; thiscoord[1] = thiscoord[4]; + thiscoord[4] = tmp; + tmp = thiscoord[2]; thiscoord[2] = thiscoord[5]; + thiscoord[5] = tmp; + is_small = 1; + } + + } + tmpcoord[0] = thiscoord[0] - minint[0]; + tmpcoord[1] = thiscoord[1] - minint[1]; + tmpcoord[2] = thiscoord[2] - minint[2]; + if (bitsize == 0) { + sendbits(buf, bitsizeint[0], tmpcoord[0]); + sendbits(buf, bitsizeint[1], tmpcoord[1]); + sendbits(buf, bitsizeint[2], tmpcoord[2]); + } else { + sendints(buf, 3, bitsize, sizeint, tmpcoord); + } + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + thiscoord = thiscoord + 3; + i++; + + run = 0; + if (is_small == 0 && is_smaller == -1) + is_smaller = 0; + while (is_small && run < 8*3) { + if (is_smaller == -1 && ( + SQR(thiscoord[0] - prevcoord[0]) + + SQR(thiscoord[1] - prevcoord[1]) + + SQR(thiscoord[2] - prevcoord[2]) >= smaller * smaller)) { + is_smaller = 0; + } + + tmpcoord[run++] = thiscoord[0] - prevcoord[0] + small; + tmpcoord[run++] = thiscoord[1] - prevcoord[1] + small; + tmpcoord[run++] = thiscoord[2] - prevcoord[2] + small; + + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + + i++; + thiscoord = thiscoord + 3; + is_small = 0; + if (i < *size && + abs(thiscoord[0] - prevcoord[0]) < small && + abs(thiscoord[1] - prevcoord[1]) < small && + abs(thiscoord[2] - prevcoord[2]) < small) { + is_small = 1; + } + } + if (run != prevrun || is_smaller != 0) { + prevrun = run; + sendbits(buf, 1, 1); /* flag the change in run-length */ + sendbits(buf, 5, run+is_smaller+1); + } else { + sendbits(buf, 1, 0); /* flag the fact that runlength did not change */ + } + for (k=0; k < run; k+=3) { + sendints(buf, 3, smallidx, sizesmall, &tmpcoord[k]); + } + if (is_smaller != 0) { + smallidx += is_smaller; + if (is_smaller < 0) { + small = smaller; + smaller = magicints[smallidx-1] / 2; + } else { + smaller = small; + small = magicints[smallidx] / 2; + } + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx]; + } + } + if (buf[1] != 0) buf[0]++;; + xdr_int(xdrs, &(buf[0])); /* buf[0] holds the length in bytes */ + return errval * (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0])); + } else { + + /* xdrs is open for reading */ + + if (xdr_int(xdrs, &lsize) == 0) + return 0; + if (*size != 0 && lsize != *size) { + fprintf(stderr, "wrong number of coordinates in xdr3dfcoor; " + "%d arg vs %d in file", *size, lsize); + } + *size = lsize; + size3 = *size * 3; + if (*size <= 9) { + return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp), + (xdrproc_t)xdr_float)); + } + xdr_float(xdrs, precision); + if (ip == NULL) { + ip = (int *)malloc(size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)malloc(bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } else if (*size > oldsize) { + ip = (int *)realloc(ip, size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)realloc(buf, bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } + buf[0] = buf[1] = buf[2] = 0; + + xdr_int(xdrs, &(minint[0])); + xdr_int(xdrs, &(minint[1])); + xdr_int(xdrs, &(minint[2])); + + xdr_int(xdrs, &(maxint[0])); + xdr_int(xdrs, &(maxint[1])); + xdr_int(xdrs, &(maxint[2])); + + sizeint[0] = maxint[0] - minint[0]+1; + sizeint[1] = maxint[1] - minint[1]+1; + sizeint[2] = maxint[2] - minint[2]+1; + + /* check if one of the sizes is to big to be multiplied */ + if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) { + bitsizeint[0] = sizeofint(sizeint[0]); + bitsizeint[1] = sizeofint(sizeint[1]); + bitsizeint[2] = sizeofint(sizeint[2]); + bitsize = 0; /* flag the use of large sizes */ + } else { + bitsize = sizeofints(3, sizeint); + } + + xdr_int(xdrs, &smallidx); + maxidx = MIN(LASTIDX, smallidx + 8) ; + minidx = maxidx - 8; /* often this equal smallidx */ + smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2; + small = magicints[smallidx] / 2; + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ; + larger = magicints[maxidx]; + + /* buf[0] holds the length in bytes */ + + if (xdr_int(xdrs, &(buf[0])) == 0) + return 0; + if (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]) == 0) + return 0; + buf[0] = buf[1] = buf[2] = 0; + + lfp = fp; + inv_precision = 1.0 / * precision; + run = 0; + i = 0; + lip = ip; + while ( i < lsize ) { + thiscoord = (int *)(lip) + i * 3; + + if (bitsize == 0) { + thiscoord[0] = receivebits(buf, bitsizeint[0]); + thiscoord[1] = receivebits(buf, bitsizeint[1]); + thiscoord[2] = receivebits(buf, bitsizeint[2]); + } else { + receiveints(buf, 3, bitsize, sizeint, thiscoord); + } + + i++; + thiscoord[0] += minint[0]; + thiscoord[1] += minint[1]; + thiscoord[2] += minint[2]; + + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + + + flag = receivebits(buf, 1); + is_smaller = 0; + if (flag == 1) { + run = receivebits(buf, 5); + is_smaller = run % 3; + run -= is_smaller; + is_smaller--; + } + if (run > 0) { + thiscoord += 3; + for (k = 0; k < run; k+=3) { + receiveints(buf, 3, smallidx, sizesmall, thiscoord); + i++; + thiscoord[0] += prevcoord[0] - small; + thiscoord[1] += prevcoord[1] - small; + thiscoord[2] += prevcoord[2] - small; + if (k == 0) { + /* interchange first with second atom for better + * compression of water molecules + */ + tmp = thiscoord[0]; thiscoord[0] = prevcoord[0]; + prevcoord[0] = tmp; + tmp = thiscoord[1]; thiscoord[1] = prevcoord[1]; + prevcoord[1] = tmp; + tmp = thiscoord[2]; thiscoord[2] = prevcoord[2]; + prevcoord[2] = tmp; + *lfp++ = prevcoord[0] * inv_precision; + *lfp++ = prevcoord[1] * inv_precision; + *lfp++ = prevcoord[2] * inv_precision; + } else { + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + } + *lfp++ = thiscoord[0] * inv_precision; + *lfp++ = thiscoord[1] * inv_precision; + *lfp++ = thiscoord[2] * inv_precision; + } + } else { + *lfp++ = thiscoord[0] * inv_precision; + *lfp++ = thiscoord[1] * inv_precision; + *lfp++ = thiscoord[2] * inv_precision; + } + smallidx += is_smaller; + if (is_smaller < 0) { + small = smaller; + if (smallidx > FIRSTIDX) { + smaller = magicints[smallidx - 1] /2; + } else { + smaller = 0; + } + } else if (is_smaller > 0) { + smaller = small; + small = magicints[smallidx] / 2; + } + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ; + } + } + return 1; +} + + + diff --git a/source/cluster/wham/src-HCD/xdrf/types.h b/source/cluster/wham/src-HCD/xdrf/types.h new file mode 100644 index 0000000..871f3fd --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/types.h @@ -0,0 +1,99 @@ +/* + * Sun RPC is a product of Sun Microsystems, Inc. and is provided for + * unrestricted use provided that this legend is included on all tape + * media and as a part of the software program in whole or part. Users + * may copy or modify Sun RPC without charge, but are not authorized + * to license or distribute it to anyone else except as part of a product or + * program developed by the user. + * + * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE + * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR + * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. + * + * Sun RPC is provided with no support and without any obligation on the + * part of Sun Microsystems, Inc. to assist in its use, correction, + * modification or enhancement. + * + * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE + * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC + * OR ANY PART THEREOF. + * + * In no event will Sun Microsystems, Inc. be liable for any lost revenue + * or profits or other special, indirect and consequential damages, even if + * Sun has been advised of the possibility of such damages. + * + * Sun Microsystems, Inc. + * 2550 Garcia Avenue + * Mountain View, California 94043 + */ +/* fixincludes should not add extern "C" to this file */ +/* + * Rpc additions to + */ +#ifndef _RPC_TYPES_H +#define _RPC_TYPES_H 1 + +typedef int bool_t; +typedef int enum_t; +/* This needs to be changed to uint32_t in the future */ +typedef unsigned long rpcprog_t; +typedef unsigned long rpcvers_t; +typedef unsigned long rpcproc_t; +typedef unsigned long rpcprot_t; +typedef unsigned long rpcport_t; + +#define __dontcare__ -1 + +#ifndef FALSE +# define FALSE (0) +#endif + +#ifndef TRUE +# define TRUE (1) +#endif + +#ifndef NULL +# define NULL 0 +#endif + +#include /* For malloc decl. */ +#define mem_alloc(bsize) malloc(bsize) +/* + * XXX: This must not use the second argument, or code in xdr_array.c needs + * to be modified. + */ +#define mem_free(ptr, bsize) free(ptr) + +#ifndef makedev /* ie, we haven't already included it */ +#include +#endif + +#ifndef __u_char_defined +typedef __u_char u_char; +typedef __u_short u_short; +typedef __u_int u_int; +typedef __u_long u_long; +typedef __quad_t quad_t; +typedef __u_quad_t u_quad_t; +typedef __fsid_t fsid_t; +# define __u_char_defined +#endif +#ifndef __daddr_t_defined +typedef __daddr_t daddr_t; +typedef __caddr_t caddr_t; +# define __daddr_t_defined +#endif + +#include +#include + +#include + +#ifndef INADDR_LOOPBACK +#define INADDR_LOOPBACK (u_long)0x7F000001 +#endif +#ifndef MAXHOSTNAMELEN +#define MAXHOSTNAMELEN 64 +#endif + +#endif /* rpc/types.h */ diff --git a/source/cluster/wham/src-HCD/xdrf/underscore.m4 b/source/cluster/wham/src-HCD/xdrf/underscore.m4 new file mode 100644 index 0000000..4d620a0 --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/underscore.m4 @@ -0,0 +1,19 @@ +divert(-1) +undefine(`len') +# +# append an underscore to FORTRAN function names +# +define(`FUNCTION',`$1_') +# +# FORTRAN character strings are passed as follows: +# a pointer to the base of the string is passed in the normal +# argument list, and the length is passed by value as an extra +# argument, after all of the other arguments. +# +define(`ARGS',`($1`'undivert(1))') +define(`SAVE',`divert(1)$1`'divert(0)') +define(`STRING_ARG',`$1_ptr`'SAVE(`, $1_len')') +define(`STRING_ARG_DECL',`char * $1_ptr; int $1_len') +define(`STRING_LEN',`$1_len') +define(`STRING_PTR',`$1_ptr') +divert(0) diff --git a/source/cluster/wham/src-HCD/xdrf/xdr.c b/source/cluster/wham/src-HCD/xdrf/xdr.c new file mode 100644 index 0000000..33b8544 --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/xdr.c @@ -0,0 +1,752 @@ +# define INTUSE(name) name +# define INTDEF(name) +/* @(#)xdr.c 2.1 88/07/29 4.0 RPCSRC */ +/* + * Sun RPC is a product of Sun Microsystems, Inc. and is provided for + * unrestricted use provided that this legend is included on all tape + * media and as a part of the software program in whole or part. Users + * may copy or modify Sun RPC without charge, but are not authorized + * to license or distribute it to anyone else except as part of a product or + * program developed by the user. + * + * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE + * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR + * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. + * + * Sun RPC is provided with no support and without any obligation on the + * part of Sun Microsystems, Inc. to assist in its use, correction, + * modification or enhancement. + * + * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE + * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC + * OR ANY PART THEREOF. + * + * In no event will Sun Microsystems, Inc. be liable for any lost revenue + * or profits or other special, indirect and consequential damages, even if + * Sun has been advised of the possibility of such damages. + * + * Sun Microsystems, Inc. + * 2550 Garcia Avenue + * Mountain View, California 94043 + */ +#if !defined(lint) && defined(SCCSIDS) +static char sccsid[] = "@(#)xdr.c 1.35 87/08/12"; +#endif + +/* + * xdr.c, Generic XDR routines implementation. + * + * Copyright (C) 1986, Sun Microsystems, Inc. + * + * These are the "generic" xdr routines used to serialize and de-serialize + * most common data items. See xdr.h for more info on the interface to + * xdr. + */ + +#include +#include +#include +#include + +#include "types.h" +#include "xdr.h" + +#ifdef USE_IN_LIBIO +# include +#endif + +/* + * constants specific to the xdr "protocol" + */ +#define XDR_FALSE ((long) 0) +#define XDR_TRUE ((long) 1) +#define LASTUNSIGNED ((u_int) 0-1) + +/* + * for unit alignment + */ +static const char xdr_zero[BYTES_PER_XDR_UNIT] = {0, 0, 0, 0}; + +/* + * Free a data structure using XDR + * Not a filter, but a convenient utility nonetheless + */ +void +xdr_free (xdrproc_t proc, char *objp) +{ + XDR x; + + x.x_op = XDR_FREE; + (*proc) (&x, objp); +} + +/* + * XDR nothing + */ +bool_t +xdr_void (void) +{ + return TRUE; +} +INTDEF(xdr_void) + +/* + * XDR integers + */ +bool_t +xdr_int (XDR *xdrs, int *ip) +{ + +#if INT_MAX < LONG_MAX + long l; + + switch (xdrs->x_op) + { + case XDR_ENCODE: + l = (long) *ip; + return XDR_PUTLONG (xdrs, &l); + + case XDR_DECODE: + if (!XDR_GETLONG (xdrs, &l)) + { + return FALSE; + } + *ip = (int) l; + case XDR_FREE: + return TRUE; + } + return FALSE; +#elif INT_MAX == LONG_MAX + return INTUSE(xdr_long) (xdrs, (long *) ip); +#elif INT_MAX == SHRT_MAX + return INTUSE(xdr_short) (xdrs, (short *) ip); +#else +#error unexpected integer sizes in_xdr_int() +#endif +} +INTDEF(xdr_int) + +/* + * XDR unsigned integers + */ +bool_t +xdr_u_int (XDR *xdrs, u_int *up) +{ +#if UINT_MAX < ULONG_MAX + long l; + + switch (xdrs->x_op) + { + case XDR_ENCODE: + l = (u_long) * up; + return XDR_PUTLONG (xdrs, &l); + + case XDR_DECODE: + if (!XDR_GETLONG (xdrs, &l)) + { + return FALSE; + } + *up = (u_int) (u_long) l; + case XDR_FREE: + return TRUE; + } + return FALSE; +#elif UINT_MAX == ULONG_MAX + return INTUSE(xdr_u_long) (xdrs, (u_long *) up); +#elif UINT_MAX == USHRT_MAX + return INTUSE(xdr_short) (xdrs, (short *) up); +#else +#error unexpected integer sizes in_xdr_u_int() +#endif +} +INTDEF(xdr_u_int) + +/* + * XDR long integers + * The definition of xdr_long() is kept for backward + * compatibility. Instead xdr_int() should be used. + */ +bool_t +xdr_long (XDR *xdrs, long *lp) +{ + + if (xdrs->x_op == XDR_ENCODE + && (sizeof (int32_t) == sizeof (long) + || (int32_t) *lp == *lp)) + return XDR_PUTLONG (xdrs, lp); + + if (xdrs->x_op == XDR_DECODE) + return XDR_GETLONG (xdrs, lp); + + if (xdrs->x_op == XDR_FREE) + return TRUE; + + return FALSE; +} +INTDEF(xdr_long) + +/* + * XDR unsigned long integers + * The definition of xdr_u_long() is kept for backward + * compatibility. Instead xdr_u_int() should be used. + */ +bool_t +xdr_u_long (XDR *xdrs, u_long *ulp) +{ + switch (xdrs->x_op) + { + case XDR_DECODE: + { + long int tmp; + + if (XDR_GETLONG (xdrs, &tmp) == FALSE) + return FALSE; + + *ulp = (uint32_t) tmp; + return TRUE; + } + + case XDR_ENCODE: + if (sizeof (uint32_t) != sizeof (u_long) + && (uint32_t) *ulp != *ulp) + return FALSE; + + return XDR_PUTLONG (xdrs, (long *) ulp); + + case XDR_FREE: + return TRUE; + } + return FALSE; +} +INTDEF(xdr_u_long) + +/* + * XDR hyper integers + * same as xdr_u_hyper - open coded to save a proc call! + */ +bool_t +xdr_hyper (XDR *xdrs, quad_t *llp) +{ + long int t1, t2; + + if (xdrs->x_op == XDR_ENCODE) + { + t1 = (long) ((*llp) >> 32); + t2 = (long) (*llp); + return (XDR_PUTLONG(xdrs, &t1) && XDR_PUTLONG(xdrs, &t2)); + } + + if (xdrs->x_op == XDR_DECODE) + { + if (!XDR_GETLONG(xdrs, &t1) || !XDR_GETLONG(xdrs, &t2)) + return FALSE; + *llp = ((quad_t) t1) << 32; + *llp |= (uint32_t) t2; + return TRUE; + } + + if (xdrs->x_op == XDR_FREE) + return TRUE; + + return FALSE; +} +INTDEF(xdr_hyper) + + +/* + * XDR hyper integers + * same as xdr_hyper - open coded to save a proc call! + */ +bool_t +xdr_u_hyper (XDR *xdrs, u_quad_t *ullp) +{ + long int t1, t2; + + if (xdrs->x_op == XDR_ENCODE) + { + t1 = (unsigned long) ((*ullp) >> 32); + t2 = (unsigned long) (*ullp); + return (XDR_PUTLONG(xdrs, &t1) && XDR_PUTLONG(xdrs, &t2)); + } + + if (xdrs->x_op == XDR_DECODE) + { + if (!XDR_GETLONG(xdrs, &t1) || !XDR_GETLONG(xdrs, &t2)) + return FALSE; + *ullp = ((u_quad_t) t1) << 32; + *ullp |= (uint32_t) t2; + return TRUE; + } + + if (xdrs->x_op == XDR_FREE) + return TRUE; + + return FALSE; +} +INTDEF(xdr_u_hyper) + +bool_t +xdr_longlong_t (XDR *xdrs, quad_t *llp) +{ + return INTUSE(xdr_hyper) (xdrs, llp); +} + +bool_t +xdr_u_longlong_t (XDR *xdrs, u_quad_t *ullp) +{ + return INTUSE(xdr_u_hyper) (xdrs, ullp); +} + +/* + * XDR short integers + */ +bool_t +xdr_short (XDR *xdrs, short *sp) +{ + long l; + + switch (xdrs->x_op) + { + case XDR_ENCODE: + l = (long) *sp; + return XDR_PUTLONG (xdrs, &l); + + case XDR_DECODE: + if (!XDR_GETLONG (xdrs, &l)) + { + return FALSE; + } + *sp = (short) l; + return TRUE; + + case XDR_FREE: + return TRUE; + } + return FALSE; +} +INTDEF(xdr_short) + +/* + * XDR unsigned short integers + */ +bool_t +xdr_u_short (XDR *xdrs, u_short *usp) +{ + long l; + + switch (xdrs->x_op) + { + case XDR_ENCODE: + l = (u_long) * usp; + return XDR_PUTLONG (xdrs, &l); + + case XDR_DECODE: + if (!XDR_GETLONG (xdrs, &l)) + { + return FALSE; + } + *usp = (u_short) (u_long) l; + return TRUE; + + case XDR_FREE: + return TRUE; + } + return FALSE; +} +INTDEF(xdr_u_short) + + +/* + * XDR a char + */ +bool_t +xdr_char (XDR *xdrs, char *cp) +{ + int i; + + i = (*cp); + if (!INTUSE(xdr_int) (xdrs, &i)) + { + return FALSE; + } + *cp = i; + return TRUE; +} + +/* + * XDR an unsigned char + */ +bool_t +xdr_u_char (XDR *xdrs, u_char *cp) +{ + u_int u; + + u = (*cp); + if (!INTUSE(xdr_u_int) (xdrs, &u)) + { + return FALSE; + } + *cp = u; + return TRUE; +} + +/* + * XDR booleans + */ +bool_t +xdr_bool (XDR *xdrs, bool_t *bp) +{ + long lb; + + switch (xdrs->x_op) + { + case XDR_ENCODE: + lb = *bp ? XDR_TRUE : XDR_FALSE; + return XDR_PUTLONG (xdrs, &lb); + + case XDR_DECODE: + if (!XDR_GETLONG (xdrs, &lb)) + { + return FALSE; + } + *bp = (lb == XDR_FALSE) ? FALSE : TRUE; + return TRUE; + + case XDR_FREE: + return TRUE; + } + return FALSE; +} +INTDEF(xdr_bool) + +/* + * XDR enumerations + */ +bool_t +xdr_enum (XDR *xdrs, enum_t *ep) +{ + enum sizecheck + { + SIZEVAL + }; /* used to find the size of an enum */ + + /* + * enums are treated as ints + */ + if (sizeof (enum sizecheck) == 4) + { +#if INT_MAX < LONG_MAX + long l; + + switch (xdrs->x_op) + { + case XDR_ENCODE: + l = *ep; + return XDR_PUTLONG (xdrs, &l); + + case XDR_DECODE: + if (!XDR_GETLONG (xdrs, &l)) + { + return FALSE; + } + *ep = l; + case XDR_FREE: + return TRUE; + + } + return FALSE; +#else + return INTUSE(xdr_long) (xdrs, (long *) ep); +#endif + } + else if (sizeof (enum sizecheck) == sizeof (short)) + { + return INTUSE(xdr_short) (xdrs, (short *) ep); + } + else + { + return FALSE; + } +} +INTDEF(xdr_enum) + +/* + * XDR opaque data + * Allows the specification of a fixed size sequence of opaque bytes. + * cp points to the opaque object and cnt gives the byte length. + */ +bool_t +xdr_opaque (XDR *xdrs, caddr_t cp, u_int cnt) +{ + u_int rndup; + static char crud[BYTES_PER_XDR_UNIT]; + + /* + * if no data we are done + */ + if (cnt == 0) + return TRUE; + + /* + * round byte count to full xdr units + */ + rndup = cnt % BYTES_PER_XDR_UNIT; + if (rndup > 0) + rndup = BYTES_PER_XDR_UNIT - rndup; + + switch (xdrs->x_op) + { + case XDR_DECODE: + if (!XDR_GETBYTES (xdrs, cp, cnt)) + { + return FALSE; + } + if (rndup == 0) + return TRUE; + return XDR_GETBYTES (xdrs, (caddr_t)crud, rndup); + + case XDR_ENCODE: + if (!XDR_PUTBYTES (xdrs, cp, cnt)) + { + return FALSE; + } + if (rndup == 0) + return TRUE; + return XDR_PUTBYTES (xdrs, xdr_zero, rndup); + + case XDR_FREE: + return TRUE; + } + return FALSE; +} +INTDEF(xdr_opaque) + +/* + * XDR counted bytes + * *cpp is a pointer to the bytes, *sizep is the count. + * If *cpp is NULL maxsize bytes are allocated + */ +bool_t +xdr_bytes (xdrs, cpp, sizep, maxsize) + XDR *xdrs; + char **cpp; + u_int *sizep; + u_int maxsize; +{ + char *sp = *cpp; /* sp is the actual string pointer */ + u_int nodesize; + + /* + * first deal with the length since xdr bytes are counted + */ + if (!INTUSE(xdr_u_int) (xdrs, sizep)) + { + return FALSE; + } + nodesize = *sizep; + if ((nodesize > maxsize) && (xdrs->x_op != XDR_FREE)) + { + return FALSE; + } + + /* + * now deal with the actual bytes + */ + switch (xdrs->x_op) + { + case XDR_DECODE: + if (nodesize == 0) + { + return TRUE; + } + if (sp == NULL) + { + *cpp = sp = (char *) mem_alloc (nodesize); + } + if (sp == NULL) + { + fprintf (NULL, "%s", "xdr_bytes: out of memory\n"); + return FALSE; + } + /* fall into ... */ + + case XDR_ENCODE: + return INTUSE(xdr_opaque) (xdrs, sp, nodesize); + + case XDR_FREE: + if (sp != NULL) + { + mem_free (sp, nodesize); + *cpp = NULL; + } + return TRUE; + } + return FALSE; +} +INTDEF(xdr_bytes) + +/* + * Implemented here due to commonality of the object. + */ +bool_t +xdr_netobj (xdrs, np) + XDR *xdrs; + struct netobj *np; +{ + + return INTUSE(xdr_bytes) (xdrs, &np->n_bytes, &np->n_len, MAX_NETOBJ_SZ); +} +INTDEF(xdr_netobj) + +/* + * XDR a discriminated union + * Support routine for discriminated unions. + * You create an array of xdrdiscrim structures, terminated with + * an entry with a null procedure pointer. The routine gets + * the discriminant value and then searches the array of xdrdiscrims + * looking for that value. It calls the procedure given in the xdrdiscrim + * to handle the discriminant. If there is no specific routine a default + * routine may be called. + * If there is no specific or default routine an error is returned. + */ +bool_t +xdr_union (xdrs, dscmp, unp, choices, dfault) + XDR *xdrs; + enum_t *dscmp; /* enum to decide which arm to work on */ + char *unp; /* the union itself */ + const struct xdr_discrim *choices; /* [value, xdr proc] for each arm */ + xdrproc_t dfault; /* default xdr routine */ +{ + enum_t dscm; + + /* + * we deal with the discriminator; it's an enum + */ + if (!INTUSE(xdr_enum) (xdrs, dscmp)) + { + return FALSE; + } + dscm = *dscmp; + + /* + * search choices for a value that matches the discriminator. + * if we find one, execute the xdr routine for that value. + */ + for (; choices->proc != NULL_xdrproc_t; choices++) + { + if (choices->value == dscm) + return (*(choices->proc)) (xdrs, unp, LASTUNSIGNED); + } + + /* + * no match - execute the default xdr routine if there is one + */ + return ((dfault == NULL_xdrproc_t) ? FALSE : + (*dfault) (xdrs, unp, LASTUNSIGNED)); +} +INTDEF(xdr_union) + + +/* + * Non-portable xdr primitives. + * Care should be taken when moving these routines to new architectures. + */ + + +/* + * XDR null terminated ASCII strings + * xdr_string deals with "C strings" - arrays of bytes that are + * terminated by a NULL character. The parameter cpp references a + * pointer to storage; If the pointer is null, then the necessary + * storage is allocated. The last parameter is the max allowed length + * of the string as specified by a protocol. + */ +bool_t +xdr_string (xdrs, cpp, maxsize) + XDR *xdrs; + char **cpp; + u_int maxsize; +{ + char *sp = *cpp; /* sp is the actual string pointer */ + u_int size; + u_int nodesize; + + /* + * first deal with the length since xdr strings are counted-strings + */ + switch (xdrs->x_op) + { + case XDR_FREE: + if (sp == NULL) + { + return TRUE; /* already free */ + } + /* fall through... */ + case XDR_ENCODE: + if (sp == NULL) + return FALSE; + size = strlen (sp); + break; + case XDR_DECODE: + break; + } + if (!INTUSE(xdr_u_int) (xdrs, &size)) + { + return FALSE; + } + if (size > maxsize) + { + return FALSE; + } + nodesize = size + 1; + if (nodesize == 0) + { + /* This means an overflow. It a bug in the caller which + provided a too large maxsize but nevertheless catch it + here. */ + return FALSE; + } + + /* + * now deal with the actual bytes + */ + switch (xdrs->x_op) + { + case XDR_DECODE: + if (sp == NULL) + *cpp = sp = (char *) mem_alloc (nodesize); + if (sp == NULL) + { + fprintf (NULL, "%s", "xdr_string: out of memory\n"); + return FALSE; + } + sp[size] = 0; + /* fall into ... */ + + case XDR_ENCODE: + return INTUSE(xdr_opaque) (xdrs, sp, size); + + case XDR_FREE: + mem_free (sp, nodesize); + *cpp = NULL; + return TRUE; + } + return FALSE; +} +INTDEF(xdr_string) + +/* + * Wrapper for xdr_string that can be called directly from + * routines like clnt_call + */ +bool_t +xdr_wrapstring (xdrs, cpp) + XDR *xdrs; + char **cpp; +{ + if (INTUSE(xdr_string) (xdrs, cpp, LASTUNSIGNED)) + { + return TRUE; + } + return FALSE; +} diff --git a/source/cluster/wham/src-HCD/xdrf/xdr.h b/source/cluster/wham/src-HCD/xdrf/xdr.h new file mode 100644 index 0000000..2602ad9 --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/xdr.h @@ -0,0 +1,379 @@ +/* + * Sun RPC is a product of Sun Microsystems, Inc. and is provided for + * unrestricted use provided that this legend is included on all tape + * media and as a part of the software program in whole or part. Users + * may copy or modify Sun RPC without charge, but are not authorized + * to license or distribute it to anyone else except as part of a product or + * program developed by the user. + * + * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE + * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR + * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. + * + * Sun RPC is provided with no support and without any obligation on the + * part of Sun Microsystems, Inc. to assist in its use, correction, + * modification or enhancement. + * + * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE + * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC + * OR ANY PART THEREOF. + * + * In no event will Sun Microsystems, Inc. be liable for any lost revenue + * or profits or other special, indirect and consequential damages, even if + * Sun has been advised of the possibility of such damages. + * + * Sun Microsystems, Inc. + * 2550 Garcia Avenue + * Mountain View, California 94043 + */ + +/* + * xdr.h, External Data Representation Serialization Routines. + * + * Copyright (C) 1984, Sun Microsystems, Inc. + */ + +#ifndef _RPC_XDR_H +#define _RPC_XDR_H 1 + +#include +#include +#include "types.h" + +/* We need FILE. */ +#include + +__BEGIN_DECLS + +/* + * XDR provides a conventional way for converting between C data + * types and an external bit-string representation. Library supplied + * routines provide for the conversion on built-in C data types. These + * routines and utility routines defined here are used to help implement + * a type encode/decode routine for each user-defined type. + * + * Each data type provides a single procedure which takes two arguments: + * + * bool_t + * xdrproc(xdrs, argresp) + * XDR *xdrs; + * *argresp; + * + * xdrs is an instance of a XDR handle, to which or from which the data + * type is to be converted. argresp is a pointer to the structure to be + * converted. The XDR handle contains an operation field which indicates + * which of the operations (ENCODE, DECODE * or FREE) is to be performed. + * + * XDR_DECODE may allocate space if the pointer argresp is null. This + * data can be freed with the XDR_FREE operation. + * + * We write only one procedure per data type to make it easy + * to keep the encode and decode procedures for a data type consistent. + * In many cases the same code performs all operations on a user defined type, + * because all the hard work is done in the component type routines. + * decode as a series of calls on the nested data types. + */ + +/* + * Xdr operations. XDR_ENCODE causes the type to be encoded into the + * stream. XDR_DECODE causes the type to be extracted from the stream. + * XDR_FREE can be used to release the space allocated by an XDR_DECODE + * request. + */ +enum xdr_op { + XDR_ENCODE = 0, + XDR_DECODE = 1, + XDR_FREE = 2 +}; + +/* + * This is the number of bytes per unit of external data. + */ +#define BYTES_PER_XDR_UNIT (4) +/* + * This only works if the above is a power of 2. But it's defined to be + * 4 by the appropriate RFCs. So it will work. And it's normally quicker + * than the old routine. + */ +#if 1 +#define RNDUP(x) (((x) + BYTES_PER_XDR_UNIT - 1) & ~(BYTES_PER_XDR_UNIT - 1)) +#else /* this is the old routine */ +#define RNDUP(x) ((((x) + BYTES_PER_XDR_UNIT - 1) / BYTES_PER_XDR_UNIT) \ + * BYTES_PER_XDR_UNIT) +#endif + +/* + * The XDR handle. + * Contains operation which is being applied to the stream, + * an operations vector for the particular implementation (e.g. see xdr_mem.c), + * and two private fields for the use of the particular implementation. + */ +typedef struct XDR XDR; +struct XDR + { + enum xdr_op x_op; /* operation; fast additional param */ + struct xdr_ops + { + bool_t (*x_getlong) (XDR *__xdrs, long *__lp); + /* get a long from underlying stream */ + bool_t (*x_putlong) (XDR *__xdrs, __const long *__lp); + /* put a long to " */ + bool_t (*x_getbytes) (XDR *__xdrs, caddr_t __addr, u_int __len); + /* get some bytes from " */ + bool_t (*x_putbytes) (XDR *__xdrs, __const char *__addr, u_int __len); + /* put some bytes to " */ + u_int (*x_getpostn) (__const XDR *__xdrs); + /* returns bytes off from beginning */ + bool_t (*x_setpostn) (XDR *__xdrs, u_int __pos); + /* lets you reposition the stream */ + int32_t *(*x_inline) (XDR *__xdrs, u_int __len); + /* buf quick ptr to buffered data */ + void (*x_destroy) (XDR *__xdrs); + /* free privates of this xdr_stream */ + bool_t (*x_getint32) (XDR *__xdrs, int32_t *__ip); + /* get a int from underlying stream */ + bool_t (*x_putint32) (XDR *__xdrs, __const int32_t *__ip); + /* put a int to " */ + } + *x_ops; + caddr_t x_public; /* users' data */ + caddr_t x_private; /* pointer to private data */ + caddr_t x_base; /* private used for position info */ + u_int x_handy; /* extra private word */ + }; + +/* + * A xdrproc_t exists for each data type which is to be encoded or decoded. + * + * The second argument to the xdrproc_t is a pointer to an opaque pointer. + * The opaque pointer generally points to a structure of the data type + * to be decoded. If this pointer is 0, then the type routines should + * allocate dynamic storage of the appropriate size and return it. + * bool_t (*xdrproc_t)(XDR *, caddr_t *); + */ +typedef bool_t (*xdrproc_t) (XDR *, void *,...); + + +/* + * Operations defined on a XDR handle + * + * XDR *xdrs; + * int32_t *int32p; + * long *longp; + * caddr_t addr; + * u_int len; + * u_int pos; + */ +#define XDR_GETINT32(xdrs, int32p) \ + (*(xdrs)->x_ops->x_getint32)(xdrs, int32p) +#define xdr_getint32(xdrs, int32p) \ + (*(xdrs)->x_ops->x_getint32)(xdrs, int32p) + +#define XDR_PUTINT32(xdrs, int32p) \ + (*(xdrs)->x_ops->x_putint32)(xdrs, int32p) +#define xdr_putint32(xdrs, int32p) \ + (*(xdrs)->x_ops->x_putint32)(xdrs, int32p) + +#define XDR_GETLONG(xdrs, longp) \ + (*(xdrs)->x_ops->x_getlong)(xdrs, longp) +#define xdr_getlong(xdrs, longp) \ + (*(xdrs)->x_ops->x_getlong)(xdrs, longp) + +#define XDR_PUTLONG(xdrs, longp) \ + (*(xdrs)->x_ops->x_putlong)(xdrs, longp) +#define xdr_putlong(xdrs, longp) \ + (*(xdrs)->x_ops->x_putlong)(xdrs, longp) + +#define XDR_GETBYTES(xdrs, addr, len) \ + (*(xdrs)->x_ops->x_getbytes)(xdrs, addr, len) +#define xdr_getbytes(xdrs, addr, len) \ + (*(xdrs)->x_ops->x_getbytes)(xdrs, addr, len) + +#define XDR_PUTBYTES(xdrs, addr, len) \ + (*(xdrs)->x_ops->x_putbytes)(xdrs, addr, len) +#define xdr_putbytes(xdrs, addr, len) \ + (*(xdrs)->x_ops->x_putbytes)(xdrs, addr, len) + +#define XDR_GETPOS(xdrs) \ + (*(xdrs)->x_ops->x_getpostn)(xdrs) +#define xdr_getpos(xdrs) \ + (*(xdrs)->x_ops->x_getpostn)(xdrs) + +#define XDR_SETPOS(xdrs, pos) \ + (*(xdrs)->x_ops->x_setpostn)(xdrs, pos) +#define xdr_setpos(xdrs, pos) \ + (*(xdrs)->x_ops->x_setpostn)(xdrs, pos) + +#define XDR_INLINE(xdrs, len) \ + (*(xdrs)->x_ops->x_inline)(xdrs, len) +#define xdr_inline(xdrs, len) \ + (*(xdrs)->x_ops->x_inline)(xdrs, len) + +#define XDR_DESTROY(xdrs) \ + do { \ + if ((xdrs)->x_ops->x_destroy) \ + (*(xdrs)->x_ops->x_destroy)(xdrs); \ + } while (0) +#define xdr_destroy(xdrs) \ + do { \ + if ((xdrs)->x_ops->x_destroy) \ + (*(xdrs)->x_ops->x_destroy)(xdrs); \ + } while (0) + +/* + * Support struct for discriminated unions. + * You create an array of xdrdiscrim structures, terminated with + * a entry with a null procedure pointer. The xdr_union routine gets + * the discriminant value and then searches the array of structures + * for a matching value. If a match is found the associated xdr routine + * is called to handle that part of the union. If there is + * no match, then a default routine may be called. + * If there is no match and no default routine it is an error. + */ +#define NULL_xdrproc_t ((xdrproc_t)0) +struct xdr_discrim +{ + int value; + xdrproc_t proc; +}; + +/* + * Inline routines for fast encode/decode of primitive data types. + * Caveat emptor: these use single memory cycles to get the + * data from the underlying buffer, and will fail to operate + * properly if the data is not aligned. The standard way to use these + * is to say: + * if ((buf = XDR_INLINE(xdrs, count)) == NULL) + * return (FALSE); + * <<< macro calls >>> + * where ``count'' is the number of bytes of data occupied + * by the primitive data types. + * + * N.B. and frozen for all time: each data type here uses 4 bytes + * of external representation. + */ + +#define IXDR_GET_INT32(buf) ((int32_t)ntohl((uint32_t)*(buf)++)) +#define IXDR_PUT_INT32(buf, v) (*(buf)++ = (int32_t)htonl((uint32_t)(v))) +#define IXDR_GET_U_INT32(buf) ((uint32_t)IXDR_GET_INT32(buf)) +#define IXDR_PUT_U_INT32(buf, v) IXDR_PUT_INT32(buf, (int32_t)(v)) + +/* WARNING: The IXDR_*_LONG defines are removed by Sun for new platforms + * and shouldn't be used any longer. Code which use this defines or longs + * in the RPC code will not work on 64bit Solaris platforms ! + */ +#define IXDR_GET_LONG(buf) ((long)IXDR_GET_U_INT32(buf)) +#define IXDR_PUT_LONG(buf, v) ((long)IXDR_PUT_INT32(buf, (long)(v))) +#define IXDR_GET_U_LONG(buf) ((u_long)IXDR_GET_LONG(buf)) +#define IXDR_PUT_U_LONG(buf, v) IXDR_PUT_LONG(buf, (long)(v)) + + +#define IXDR_GET_BOOL(buf) ((bool_t)IXDR_GET_LONG(buf)) +#define IXDR_GET_ENUM(buf, t) ((t)IXDR_GET_LONG(buf)) +#define IXDR_GET_SHORT(buf) ((short)IXDR_GET_LONG(buf)) +#define IXDR_GET_U_SHORT(buf) ((u_short)IXDR_GET_LONG(buf)) + +#define IXDR_PUT_BOOL(buf, v) IXDR_PUT_LONG(buf, (long)(v)) +#define IXDR_PUT_ENUM(buf, v) IXDR_PUT_LONG(buf, (long)(v)) +#define IXDR_PUT_SHORT(buf, v) IXDR_PUT_LONG(buf, (long)(v)) +#define IXDR_PUT_U_SHORT(buf, v) IXDR_PUT_LONG(buf, (long)(v)) + +/* + * These are the "generic" xdr routines. + * None of these can have const applied because it's not possible to + * know whether the call is a read or a write to the passed parameter + * also, the XDR structure is always updated by some of these calls. + */ +extern bool_t xdr_void (void) __THROW; +extern bool_t xdr_short (XDR *__xdrs, short *__sp) __THROW; +extern bool_t xdr_u_short (XDR *__xdrs, u_short *__usp) __THROW; +extern bool_t xdr_int (XDR *__xdrs, int *__ip) __THROW; +extern bool_t xdr_u_int (XDR *__xdrs, u_int *__up) __THROW; +extern bool_t xdr_long (XDR *__xdrs, long *__lp) __THROW; +extern bool_t xdr_u_long (XDR *__xdrs, u_long *__ulp) __THROW; +extern bool_t xdr_hyper (XDR *__xdrs, quad_t *__llp) __THROW; +extern bool_t xdr_u_hyper (XDR *__xdrs, u_quad_t *__ullp) __THROW; +extern bool_t xdr_longlong_t (XDR *__xdrs, quad_t *__llp) __THROW; +extern bool_t xdr_u_longlong_t (XDR *__xdrs, u_quad_t *__ullp) __THROW; +extern bool_t xdr_int8_t (XDR *__xdrs, int8_t *__ip) __THROW; +extern bool_t xdr_uint8_t (XDR *__xdrs, uint8_t *__up) __THROW; +extern bool_t xdr_int16_t (XDR *__xdrs, int16_t *__ip) __THROW; +extern bool_t xdr_uint16_t (XDR *__xdrs, uint16_t *__up) __THROW; +extern bool_t xdr_int32_t (XDR *__xdrs, int32_t *__ip) __THROW; +extern bool_t xdr_uint32_t (XDR *__xdrs, uint32_t *__up) __THROW; +extern bool_t xdr_int64_t (XDR *__xdrs, int64_t *__ip) __THROW; +extern bool_t xdr_uint64_t (XDR *__xdrs, uint64_t *__up) __THROW; +extern bool_t xdr_quad_t (XDR *__xdrs, quad_t *__ip) __THROW; +extern bool_t xdr_u_quad_t (XDR *__xdrs, u_quad_t *__up) __THROW; +extern bool_t xdr_bool (XDR *__xdrs, bool_t *__bp) __THROW; +extern bool_t xdr_enum (XDR *__xdrs, enum_t *__ep) __THROW; +extern bool_t xdr_array (XDR * _xdrs, caddr_t *__addrp, u_int *__sizep, + u_int __maxsize, u_int __elsize, xdrproc_t __elproc) + __THROW; +extern bool_t xdr_bytes (XDR *__xdrs, char **__cpp, u_int *__sizep, + u_int __maxsize) __THROW; +extern bool_t xdr_opaque (XDR *__xdrs, caddr_t __cp, u_int __cnt) __THROW; +extern bool_t xdr_string (XDR *__xdrs, char **__cpp, u_int __maxsize) __THROW; +extern bool_t xdr_union (XDR *__xdrs, enum_t *__dscmp, char *__unp, + __const struct xdr_discrim *__choices, + xdrproc_t dfault) __THROW; +extern bool_t xdr_char (XDR *__xdrs, char *__cp) __THROW; +extern bool_t xdr_u_char (XDR *__xdrs, u_char *__cp) __THROW; +extern bool_t xdr_vector (XDR *__xdrs, char *__basep, u_int __nelem, + u_int __elemsize, xdrproc_t __xdr_elem) __THROW; +extern bool_t xdr_float (XDR *__xdrs, float *__fp) __THROW; +extern bool_t xdr_double (XDR *__xdrs, double *__dp) __THROW; +extern bool_t xdr_reference (XDR *__xdrs, caddr_t *__xpp, u_int __size, + xdrproc_t __proc) __THROW; +extern bool_t xdr_pointer (XDR *__xdrs, char **__objpp, + u_int __obj_size, xdrproc_t __xdr_obj) __THROW; +extern bool_t xdr_wrapstring (XDR *__xdrs, char **__cpp) __THROW; +extern u_long xdr_sizeof (xdrproc_t, void *) __THROW; + +/* + * Common opaque bytes objects used by many rpc protocols; + * declared here due to commonality. + */ +#define MAX_NETOBJ_SZ 1024 +struct netobj +{ + u_int n_len; + char *n_bytes; +}; +typedef struct netobj netobj; +extern bool_t xdr_netobj (XDR *__xdrs, struct netobj *__np) __THROW; + +/* + * These are the public routines for the various implementations of + * xdr streams. + */ + +/* XDR using memory buffers */ +extern void xdrmem_create (XDR *__xdrs, __const caddr_t __addr, + u_int __size, enum xdr_op __xop) __THROW; + +/* XDR using stdio library */ +extern void xdrstdio_create (XDR *__xdrs, FILE *__file, enum xdr_op __xop) + __THROW; + +/* XDR pseudo records for tcp */ +extern void xdrrec_create (XDR *__xdrs, u_int __sendsize, + u_int __recvsize, caddr_t __tcp_handle, + int (*__readit) (char *, char *, int), + int (*__writeit) (char *, char *, int)) __THROW; + +/* make end of xdr record */ +extern bool_t xdrrec_endofrecord (XDR *__xdrs, bool_t __sendnow) __THROW; + +/* move to beginning of next record */ +extern bool_t xdrrec_skiprecord (XDR *__xdrs) __THROW; + +/* true if no more input */ +extern bool_t xdrrec_eof (XDR *__xdrs) __THROW; + +/* free memory buffers for xdr */ +extern void xdr_free (xdrproc_t __proc, char *__objp) __THROW; + +__END_DECLS + +#endif /* rpc/xdr.h */ diff --git a/source/cluster/wham/src-HCD/xdrf/xdr_array.c b/source/cluster/wham/src-HCD/xdrf/xdr_array.c new file mode 100644 index 0000000..836405c --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/xdr_array.c @@ -0,0 +1,174 @@ +# define INTUSE(name) name +# define INTDEF(name) +/* @(#)xdr_array.c 2.1 88/07/29 4.0 RPCSRC */ +/* + * Sun RPC is a product of Sun Microsystems, Inc. and is provided for + * unrestricted use provided that this legend is included on all tape + * media and as a part of the software program in whole or part. Users + * may copy or modify Sun RPC without charge, but are not authorized + * to license or distribute it to anyone else except as part of a product or + * program developed by the user. + * + * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE + * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR + * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. + * + * Sun RPC is provided with no support and without any obligation on the + * part of Sun Microsystems, Inc. to assist in its use, correction, + * modification or enhancement. + * + * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE + * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC + * OR ANY PART THEREOF. + * + * In no event will Sun Microsystems, Inc. be liable for any lost revenue + * or profits or other special, indirect and consequential damages, even if + * Sun has been advised of the possibility of such damages. + * + * Sun Microsystems, Inc. + * 2550 Garcia Avenue + * Mountain View, California 94043 + */ +#if !defined(lint) && defined(SCCSIDS) +static char sccsid[] = "@(#)xdr_array.c 1.10 87/08/11 Copyr 1984 Sun Micro"; +#endif + +/* + * xdr_array.c, Generic XDR routines implementation. + * + * Copyright (C) 1984, Sun Microsystems, Inc. + * + * These are the "non-trivial" xdr primitives used to serialize and de-serialize + * arrays. See xdr.h for more info on the interface to xdr. + */ + +#include +#include +#include "types.h" +#include "xdr.h" +#include +#include + +#ifdef USE_IN_LIBIO +# include +#endif + +#define LASTUNSIGNED ((u_int)0-1) + + +/* + * XDR an array of arbitrary elements + * *addrp is a pointer to the array, *sizep is the number of elements. + * If addrp is NULL (*sizep * elsize) bytes are allocated. + * elsize is the size (in bytes) of each element, and elproc is the + * xdr procedure to call to handle each element of the array. + */ +bool_t +xdr_array (xdrs, addrp, sizep, maxsize, elsize, elproc) + XDR *xdrs; + caddr_t *addrp; /* array pointer */ + u_int *sizep; /* number of elements */ + u_int maxsize; /* max numberof elements */ + u_int elsize; /* size in bytes of each element */ + xdrproc_t elproc; /* xdr routine to handle each element */ +{ + u_int i; + caddr_t target = *addrp; + u_int c; /* the actual element count */ + bool_t stat = TRUE; + u_int nodesize; + + /* like strings, arrays are really counted arrays */ + if (!INTUSE(xdr_u_int) (xdrs, sizep)) + { + return FALSE; + } + c = *sizep; + /* + * XXX: Let the overflow possibly happen with XDR_FREE because mem_free() + * doesn't actually use its second argument anyway. + */ + if ((c > maxsize || c > UINT_MAX / elsize) && (xdrs->x_op != XDR_FREE)) + { + return FALSE; + } + nodesize = c * elsize; + + /* + * if we are deserializing, we may need to allocate an array. + * We also save time by checking for a null array if we are freeing. + */ + if (target == NULL) + switch (xdrs->x_op) + { + case XDR_DECODE: + if (c == 0) + return TRUE; + *addrp = target = mem_alloc (nodesize); + if (target == NULL) + { + fprintf (stderr, "%s", "xdr_array: out of memory\n"); + return FALSE; + } + __bzero (target, nodesize); + break; + + case XDR_FREE: + return TRUE; + default: + break; + } + + /* + * now we xdr each element of array + */ + for (i = 0; (i < c) && stat; i++) + { + stat = (*elproc) (xdrs, target, LASTUNSIGNED); + target += elsize; + } + + /* + * the array may need freeing + */ + if (xdrs->x_op == XDR_FREE) + { + mem_free (*addrp, nodesize); + *addrp = NULL; + } + return stat; +} +INTDEF(xdr_array) + +/* + * xdr_vector(): + * + * XDR a fixed length array. Unlike variable-length arrays, + * the storage of fixed length arrays is static and unfreeable. + * > basep: base of the array + * > size: size of the array + * > elemsize: size of each element + * > xdr_elem: routine to XDR each element + */ +bool_t +xdr_vector (xdrs, basep, nelem, elemsize, xdr_elem) + XDR *xdrs; + char *basep; + u_int nelem; + u_int elemsize; + xdrproc_t xdr_elem; +{ + u_int i; + char *elptr; + + elptr = basep; + for (i = 0; i < nelem; i++) + { + if (!(*xdr_elem) (xdrs, elptr, LASTUNSIGNED)) + { + return FALSE; + } + elptr += elemsize; + } + return TRUE; +} diff --git a/source/cluster/wham/src-HCD/xdrf/xdr_float.c b/source/cluster/wham/src-HCD/xdrf/xdr_float.c new file mode 100644 index 0000000..15d3c88 --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/xdr_float.c @@ -0,0 +1,307 @@ +/* @(#)xdr_float.c 2.1 88/07/29 4.0 RPCSRC */ +/* + * Sun RPC is a product of Sun Microsystems, Inc. and is provided for + * unrestricted use provided that this legend is included on all tape + * media and as a part of the software program in whole or part. Users + * may copy or modify Sun RPC without charge, but are not authorized + * to license or distribute it to anyone else except as part of a product or + * program developed by the user. + * + * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE + * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR + * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. + * + * Sun RPC is provided with no support and without any obligation on the + * part of Sun Microsystems, Inc. to assist in its use, correction, + * modification or enhancement. + * + * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE + * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC + * OR ANY PART THEREOF. + * + * In no event will Sun Microsystems, Inc. be liable for any lost revenue + * or profits or other special, indirect and consequential damages, even if + * Sun has been advised of the possibility of such damages. + * + * Sun Microsystems, Inc. + * 2550 Garcia Avenue + * Mountain View, California 94043 + */ +#if !defined(lint) && defined(SCCSIDS) +static char sccsid[] = "@(#)xdr_float.c 1.12 87/08/11 Copyr 1984 Sun Micro"; +#endif + +/* + * xdr_float.c, Generic XDR routines implementation. + * + * Copyright (C) 1984, Sun Microsystems, Inc. + * + * These are the "floating point" xdr routines used to (de)serialize + * most common data items. See xdr.h for more info on the interface to + * xdr. + */ + +#include +#include + +#include "types.h" +#include "xdr.h" + +/* + * NB: Not portable. + * This routine works on Suns (Sky / 68000's) and Vaxen. + */ + +#define LSW (__FLOAT_WORD_ORDER == __BIG_ENDIAN) + +#ifdef vax + +/* What IEEE single precision floating point looks like on a Vax */ +struct ieee_single { + unsigned int mantissa: 23; + unsigned int exp : 8; + unsigned int sign : 1; +}; + +/* Vax single precision floating point */ +struct vax_single { + unsigned int mantissa1 : 7; + unsigned int exp : 8; + unsigned int sign : 1; + unsigned int mantissa2 : 16; +}; + +#define VAX_SNG_BIAS 0x81 +#define IEEE_SNG_BIAS 0x7f + +static struct sgl_limits { + struct vax_single s; + struct ieee_single ieee; +} sgl_limits[2] = { + {{ 0x7f, 0xff, 0x0, 0xffff }, /* Max Vax */ + { 0x0, 0xff, 0x0 }}, /* Max IEEE */ + {{ 0x0, 0x0, 0x0, 0x0 }, /* Min Vax */ + { 0x0, 0x0, 0x0 }} /* Min IEEE */ +}; +#endif /* vax */ + +bool_t +xdr_float(xdrs, fp) + XDR *xdrs; + float *fp; +{ +#ifdef vax + struct ieee_single is; + struct vax_single vs, *vsp; + struct sgl_limits *lim; + int i; +#endif + switch (xdrs->x_op) { + + case XDR_ENCODE: +#ifdef vax + vs = *((struct vax_single *)fp); + for (i = 0, lim = sgl_limits; + i < sizeof(sgl_limits)/sizeof(struct sgl_limits); + i++, lim++) { + if ((vs.mantissa2 == lim->s.mantissa2) && + (vs.exp == lim->s.exp) && + (vs.mantissa1 == lim->s.mantissa1)) { + is = lim->ieee; + goto shipit; + } + } + is.exp = vs.exp - VAX_SNG_BIAS + IEEE_SNG_BIAS; + is.mantissa = (vs.mantissa1 << 16) | vs.mantissa2; + shipit: + is.sign = vs.sign; + return (XDR_PUTLONG(xdrs, (long *)&is)); +#else + if (sizeof(float) == sizeof(long)) + return (XDR_PUTLONG(xdrs, (long *)fp)); + else if (sizeof(float) == sizeof(int)) { + long tmp = *(int *)fp; + return (XDR_PUTLONG(xdrs, &tmp)); + } + break; +#endif + + case XDR_DECODE: +#ifdef vax + vsp = (struct vax_single *)fp; + if (!XDR_GETLONG(xdrs, (long *)&is)) + return (FALSE); + for (i = 0, lim = sgl_limits; + i < sizeof(sgl_limits)/sizeof(struct sgl_limits); + i++, lim++) { + if ((is.exp == lim->ieee.exp) && + (is.mantissa == lim->ieee.mantissa)) { + *vsp = lim->s; + goto doneit; + } + } + vsp->exp = is.exp - IEEE_SNG_BIAS + VAX_SNG_BIAS; + vsp->mantissa2 = is.mantissa; + vsp->mantissa1 = (is.mantissa >> 16); + doneit: + vsp->sign = is.sign; + return (TRUE); +#else + if (sizeof(float) == sizeof(long)) + return (XDR_GETLONG(xdrs, (long *)fp)); + else if (sizeof(float) == sizeof(int)) { + long tmp; + if (XDR_GETLONG(xdrs, &tmp)) { + *(int *)fp = tmp; + return (TRUE); + } + } + break; +#endif + + case XDR_FREE: + return (TRUE); + } + return (FALSE); +} + +/* + * This routine works on Suns (Sky / 68000's) and Vaxen. + */ + +#ifdef vax +/* What IEEE double precision floating point looks like on a Vax */ +struct ieee_double { + unsigned int mantissa1 : 20; + unsigned int exp : 11; + unsigned int sign : 1; + unsigned int mantissa2 : 32; +}; + +/* Vax double precision floating point */ +struct vax_double { + unsigned int mantissa1 : 7; + unsigned int exp : 8; + unsigned int sign : 1; + unsigned int mantissa2 : 16; + unsigned int mantissa3 : 16; + unsigned int mantissa4 : 16; +}; + +#define VAX_DBL_BIAS 0x81 +#define IEEE_DBL_BIAS 0x3ff +#define MASK(nbits) ((1 << nbits) - 1) + +static struct dbl_limits { + struct vax_double d; + struct ieee_double ieee; +} dbl_limits[2] = { + {{ 0x7f, 0xff, 0x0, 0xffff, 0xffff, 0xffff }, /* Max Vax */ + { 0x0, 0x7ff, 0x0, 0x0 }}, /* Max IEEE */ + {{ 0x0, 0x0, 0x0, 0x0, 0x0, 0x0}, /* Min Vax */ + { 0x0, 0x0, 0x0, 0x0 }} /* Min IEEE */ +}; + +#endif /* vax */ + + +bool_t +xdr_double(xdrs, dp) + XDR *xdrs; + double *dp; +{ +#ifdef vax + struct ieee_double id; + struct vax_double vd; + register struct dbl_limits *lim; + int i; +#endif + + switch (xdrs->x_op) { + + case XDR_ENCODE: +#ifdef vax + vd = *((struct vax_double *)dp); + for (i = 0, lim = dbl_limits; + i < sizeof(dbl_limits)/sizeof(struct dbl_limits); + i++, lim++) { + if ((vd.mantissa4 == lim->d.mantissa4) && + (vd.mantissa3 == lim->d.mantissa3) && + (vd.mantissa2 == lim->d.mantissa2) && + (vd.mantissa1 == lim->d.mantissa1) && + (vd.exp == lim->d.exp)) { + id = lim->ieee; + goto shipit; + } + } + id.exp = vd.exp - VAX_DBL_BIAS + IEEE_DBL_BIAS; + id.mantissa1 = (vd.mantissa1 << 13) | (vd.mantissa2 >> 3); + id.mantissa2 = ((vd.mantissa2 & MASK(3)) << 29) | + (vd.mantissa3 << 13) | + ((vd.mantissa4 >> 3) & MASK(13)); + shipit: + id.sign = vd.sign; + dp = (double *)&id; +#endif + if (2*sizeof(long) == sizeof(double)) { + long *lp = (long *)dp; + return (XDR_PUTLONG(xdrs, lp+!LSW) && + XDR_PUTLONG(xdrs, lp+LSW)); + } else if (2*sizeof(int) == sizeof(double)) { + int *ip = (int *)dp; + long tmp[2]; + tmp[0] = ip[!LSW]; + tmp[1] = ip[LSW]; + return (XDR_PUTLONG(xdrs, tmp) && + XDR_PUTLONG(xdrs, tmp+1)); + } + break; + + case XDR_DECODE: +#ifdef vax + lp = (long *)&id; + if (!XDR_GETLONG(xdrs, lp++) || !XDR_GETLONG(xdrs, lp)) + return (FALSE); + for (i = 0, lim = dbl_limits; + i < sizeof(dbl_limits)/sizeof(struct dbl_limits); + i++, lim++) { + if ((id.mantissa2 == lim->ieee.mantissa2) && + (id.mantissa1 == lim->ieee.mantissa1) && + (id.exp == lim->ieee.exp)) { + vd = lim->d; + goto doneit; + } + } + vd.exp = id.exp - IEEE_DBL_BIAS + VAX_DBL_BIAS; + vd.mantissa1 = (id.mantissa1 >> 13); + vd.mantissa2 = ((id.mantissa1 & MASK(13)) << 3) | + (id.mantissa2 >> 29); + vd.mantissa3 = (id.mantissa2 >> 13); + vd.mantissa4 = (id.mantissa2 << 3); + doneit: + vd.sign = id.sign; + *dp = *((double *)&vd); + return (TRUE); +#else + if (2*sizeof(long) == sizeof(double)) { + long *lp = (long *)dp; + return (XDR_GETLONG(xdrs, lp+!LSW) && + XDR_GETLONG(xdrs, lp+LSW)); + } else if (2*sizeof(int) == sizeof(double)) { + int *ip = (int *)dp; + long tmp[2]; + if (XDR_GETLONG(xdrs, tmp+!LSW) && + XDR_GETLONG(xdrs, tmp+LSW)) { + ip[0] = tmp[0]; + ip[1] = tmp[1]; + return (TRUE); + } + } + break; +#endif + + case XDR_FREE: + return (TRUE); + } + return (FALSE); +} diff --git a/source/cluster/wham/src-HCD/xdrf/xdr_stdio.c b/source/cluster/wham/src-HCD/xdrf/xdr_stdio.c new file mode 100644 index 0000000..12b1709 --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/xdr_stdio.c @@ -0,0 +1,196 @@ +/* + * Sun RPC is a product of Sun Microsystems, Inc. and is provided for + * unrestricted use provided that this legend is included on all tape + * media and as a part of the software program in whole or part. Users + * may copy or modify Sun RPC without charge, but are not authorized + * to license or distribute it to anyone else except as part of a product or + * program developed by the user. + * + * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE + * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR + * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. + * + * Sun RPC is provided with no support and without any obligation on the + * part of Sun Microsystems, Inc. to assist in its use, correction, + * modification or enhancement. + * + * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE + * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC + * OR ANY PART THEREOF. + * + * In no event will Sun Microsystems, Inc. be liable for any lost revenue + * or profits or other special, indirect and consequential damages, even if + * Sun has been advised of the possibility of such damages. + * + * Sun Microsystems, Inc. + * 2550 Garcia Avenue + * Mountain View, California 94043 + */ + +/* + * xdr_stdio.c, XDR implementation on standard i/o file. + * + * Copyright (C) 1984, Sun Microsystems, Inc. + * + * This set of routines implements a XDR on a stdio stream. + * XDR_ENCODE serializes onto the stream, XDR_DECODE de-serializes + * from the stream. + */ + +#include "types.h" +#include +#include "xdr.h" + +#ifdef USE_IN_LIBIO +# include +# define fflush(s) INTUSE(_IO_fflush) (s) +# define fread(p, m, n, s) INTUSE(_IO_fread) (p, m, n, s) +# define ftell(s) INTUSE(_IO_ftell) (s) +# define fwrite(p, m, n, s) INTUSE(_IO_fwrite) (p, m, n, s) +#endif + +static bool_t xdrstdio_getlong (XDR *, long *); +static bool_t xdrstdio_putlong (XDR *, const long *); +static bool_t xdrstdio_getbytes (XDR *, caddr_t, u_int); +static bool_t xdrstdio_putbytes (XDR *, const char *, u_int); +static u_int xdrstdio_getpos (const XDR *); +static bool_t xdrstdio_setpos (XDR *, u_int); +static int32_t *xdrstdio_inline (XDR *, u_int); +static void xdrstdio_destroy (XDR *); +static bool_t xdrstdio_getint32 (XDR *, int32_t *); +static bool_t xdrstdio_putint32 (XDR *, const int32_t *); + +/* + * Ops vector for stdio type XDR + */ +static const struct xdr_ops xdrstdio_ops = +{ + xdrstdio_getlong, /* deserialize a long int */ + xdrstdio_putlong, /* serialize a long int */ + xdrstdio_getbytes, /* deserialize counted bytes */ + xdrstdio_putbytes, /* serialize counted bytes */ + xdrstdio_getpos, /* get offset in the stream */ + xdrstdio_setpos, /* set offset in the stream */ + xdrstdio_inline, /* prime stream for inline macros */ + xdrstdio_destroy, /* destroy stream */ + xdrstdio_getint32, /* deserialize a int */ + xdrstdio_putint32 /* serialize a int */ +}; + +/* + * Initialize a stdio xdr stream. + * Sets the xdr stream handle xdrs for use on the stream file. + * Operation flag is set to op. + */ +void +xdrstdio_create (XDR *xdrs, FILE *file, enum xdr_op op) +{ + xdrs->x_op = op; + /* We have to add the const since the `struct xdr_ops' in `struct XDR' + is not `const'. */ + xdrs->x_ops = (struct xdr_ops *) &xdrstdio_ops; + xdrs->x_private = (caddr_t) file; + xdrs->x_handy = 0; + xdrs->x_base = 0; +} + +/* + * Destroy a stdio xdr stream. + * Cleans up the xdr stream handle xdrs previously set up by xdrstdio_create. + */ +static void +xdrstdio_destroy (XDR *xdrs) +{ + (void) fflush ((FILE *) xdrs->x_private); + /* xx should we close the file ?? */ +}; + +static bool_t +xdrstdio_getlong (XDR *xdrs, long *lp) +{ + u_int32_t mycopy; + + if (fread ((caddr_t) &mycopy, 4, 1, (FILE *) xdrs->x_private) != 1) + return FALSE; + *lp = (long) ntohl (mycopy); + return TRUE; +} + +static bool_t +xdrstdio_putlong (XDR *xdrs, const long *lp) +{ + int32_t mycopy = htonl ((u_int32_t) *lp); + + if (fwrite ((caddr_t) &mycopy, 4, 1, (FILE *) xdrs->x_private) != 1) + return FALSE; + return TRUE; +} + +static bool_t +xdrstdio_getbytes (XDR *xdrs, const caddr_t addr, u_int len) +{ + if ((len != 0) && (fread (addr, (int) len, 1, + (FILE *) xdrs->x_private) != 1)) + return FALSE; + return TRUE; +} + +static bool_t +xdrstdio_putbytes (XDR *xdrs, const char *addr, u_int len) +{ + if ((len != 0) && (fwrite (addr, (int) len, 1, + (FILE *) xdrs->x_private) != 1)) + return FALSE; + return TRUE; +} + +static u_int +xdrstdio_getpos (const XDR *xdrs) +{ + return (u_int) ftell ((FILE *) xdrs->x_private); +} + +static bool_t +xdrstdio_setpos (XDR *xdrs, u_int pos) +{ + return fseek ((FILE *) xdrs->x_private, (long) pos, 0) < 0 ? FALSE : TRUE; +} + +static int32_t * +xdrstdio_inline (XDR *xdrs, u_int len) +{ + /* + * Must do some work to implement this: must insure + * enough data in the underlying stdio buffer, + * that the buffer is aligned so that we can indirect through a + * long *, and stuff this pointer in xdrs->x_buf. Doing + * a fread or fwrite to a scratch buffer would defeat + * most of the gains to be had here and require storage + * management on this buffer, so we don't do this. + */ + return NULL; +} + +static bool_t +xdrstdio_getint32 (XDR *xdrs, int32_t *ip) +{ + int32_t mycopy; + + if (fread ((caddr_t) &mycopy, 4, 1, (FILE *) xdrs->x_private) != 1) + return FALSE; + *ip = ntohl (mycopy); + return TRUE; +} + +static bool_t +xdrstdio_putint32 (XDR *xdrs, const int32_t *ip) +{ + int32_t mycopy = htonl (*ip); + + ip = &mycopy; + if (fwrite ((caddr_t) ip, 4, 1, (FILE *) xdrs->x_private) != 1) + return FALSE; + return TRUE; +} + +/* libc_hidden_def (xdrstdio_create) */ diff --git a/source/cluster/wham/src-HCD/xdrf/xdrf.h b/source/cluster/wham/src-HCD/xdrf/xdrf.h new file mode 100644 index 0000000..dedf5a2 --- /dev/null +++ b/source/cluster/wham/src-HCD/xdrf/xdrf.h @@ -0,0 +1,10 @@ +/*_________________________________________________________________ + | + | xdrf.h - include file for C routines that want to use the + | functions below. +*/ + +int xdropen(XDR *xdrs, const char *filename, const char *type); +int xdrclose(XDR *xdrs) ; +int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) ; + diff --git a/source/unres/src-HCD-5D/MD_A-MTS.F b/source/unres/src-HCD-5D/MD_A-MTS.F index ca52aaa..08852ba 100644 --- a/source/unres/src-HCD-5D/MD_A-MTS.F +++ b/source/unres/src-HCD-5D/MD_A-MTS.F @@ -1256,7 +1256,6 @@ c write (iout,*) "friction accelerations" call fivediaginv_mult(dimen,fric_work, d_af_work) c write (iout,*) "stochastic acceleratios" call fivediaginv_mult(dimen,stochforcvec, d_as_work) -c write (iout,*) "Leaving sddir_precalc" #else call ginv_mult(fric_work, d_af_work) call ginv_mult(stochforcvec, d_as_work) @@ -1266,6 +1265,7 @@ c write (iout,*) "Leaving sddir_precalc" write (iout,'(3f10.5)') (d_af_work(i),i=1,dimen3) write (iout,*) "d_as_work" write (iout,'(3f10.5)') (d_as_work(i),i=1,dimen3) + write (iout,*) "Leaving sddir_precalc" #endif return end @@ -2187,7 +2187,7 @@ c----------------------------------------------------------- double precision xv,sigv,lowb,highb,vec_afm(3),Ek1,Ek2,Ek3,aux integer i,ii,j,k,l,ind double precision anorm_distr - logical lprn /.true./ + logical lprn /.false./ #ifdef FIVEDIAG integer ichain,n,innt,inct,ibeg,ierr double precision work(8*maxres6) @@ -2797,8 +2797,8 @@ c enddo dc(j,0)=dc_work(j) d_t(j,0)=d_t_work(j) enddo - ind=3 - do i=nnt,nct-1 + 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) diff --git a/source/unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos b/source/unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos index a7ea506..5485424 100644 --- a/source/unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos +++ b/source/unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos @@ -27,7 +27,7 @@ PP = /lib/cpp -P all: no_option - @echo "Specify force field: GAB, 4P or E0LL2Y" + @echo "Specify force field: GAB, 4P, E0LL2Y or NEWCORR" .SUFFIXES: .F .F.o: @@ -59,7 +59,7 @@ no_option: GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DFOURBODY -GAB: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_GAB-HCD.exe +GAB: BIN = ~/bin/unres_ifort_MPICH-okeanos_GAB-HCD.exe GAB: ${object} xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true @@ -68,7 +68,7 @@ GAB: ${object} xdrf/libxdrf.a 4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DFOURBODY -4P: BIN = ~/bin/unres-ms_KCC_ifort_MPICH-okeanos_4P-HCD.exe +4P: BIN = ~/bin/unres_ifort_MPICH-okeanos_4P-HCD.exe 4P: ${object} xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true @@ -77,7 +77,7 @@ GAB: ${object} xdrf/libxdrf.a E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ -DSPLITELE -DLANG0 -DFOURBODY -E0LL2Y: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_E0LL2Y-HCD.exe +E0LL2Y: BIN = ~/bin/unres_ifort_MPICH-okeanos_E0LL2Y-HCD.exe E0LL2Y: ${object} xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true @@ -86,7 +86,7 @@ E0LL2Y: ${object} xdrf/libxdrf.a NEWCORR: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD #-DFOURBODY #-DMYGAUSS #-DTIMING -NEWCORR: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_SC-HCD.exe +NEWCORR: BIN = ~/bin/unres_ifort_MPICH-okeanos_SC-HCD.exe NEWCORR: ${object} xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true @@ -95,7 +95,7 @@ NEWCORR: ${object} xdrf/libxdrf.a NEWCORR5D: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD -DFIVEDIAG -DLBFGS #-DMYGAUSS #-DTIMING -NEWCORR5D: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_SC-HCD5-40.exe +NEWCORR5D: BIN = ~/bin/unres_ifort_MPICH-okeanos_SC-HCD5.exe NEWCORR5D: ${object_lbfgs} ${object} fdisy.o fdiag.o machpd.o kinetic_CASC.o xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true @@ -104,7 +104,7 @@ NEWCORR5D: ${object_lbfgs} ${object} fdisy.o fdiag.o machpd.o kinetic_CASC.o xdr NEWCORR_DFA: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD -DDFA #-DMYGAUSS #-DTIMING -NEWCORR_DFA: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_SC-HCD-DFA.exe +NEWCORR_DFA: BIN = ~/bin/unres_ifort_MPICH-okeanos_SC-HCD-DFA.exe NEWCORR_DFA: ${object} dfa.o xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true @@ -113,7 +113,7 @@ NEWCORR_DFA: ${object} dfa.o xdrf/libxdrf.a NEWCORR5D_DFA: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD -DFIVEDIAG -DLBFGS -DDFA #-DMYGAUSS #-DTIMING -NEWCORR5D_DFA: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_SC-HCD5-DFA.exe +NEWCORR5D_DFA: BIN = ~/bin/unres_ifort_MPICH-okeanos_SC-HCD5-DFA.exe NEWCORR5D_DFA: ${object_lbfgs} ${object} dfa.o fdisy.o fdiag.o machpd.o kinetic_CASC.o xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true diff --git a/source/unres/src-HCD-5D/lagrangian_lesyng.F b/source/unres/src-HCD-5D/lagrangian_lesyng.F index f57a432..4230e10 100644 --- a/source/unres/src-HCD-5D/lagrangian_lesyng.F +++ b/source/unres/src-HCD-5D/lagrangian_lesyng.F @@ -895,6 +895,7 @@ c--------------------------------------------------------------------------- double precision forces(3*ndim),accel(3,0:maxres2),rs(ndim), & xsolv(ndim),d_a_vec(6*nres) integer i,j,ind,ichain,n,iposc,innt,inct,inct_prev + accel=0.0d0 do j=1,3 Compute accelerations in Calpha and SC do ichain=1,nchain @@ -919,7 +920,7 @@ Compute accelerations in Calpha and SC enddo enddo enddo -C Conevert d_a to virtual-bon-vector basis +C Convert d_a to virtual-bon-vector basis #ifdef DEBUG write (iout,*) "accel in CA-SC basis" do i=1,nres @@ -944,6 +945,7 @@ C Conevert d_a to virtual-bon-vector basis end if enddo accel(:,nres)=0.0d0 + accel(:,nct)=0.0d0 accel(:,2*nres)=0.0d0 if (nnt.gt.1) then accel(:,0)=accel(:,1) diff --git a/source/unres/src-HCD-5D/stochfric.F b/source/unres/src-HCD-5D/stochfric.F index dc0b088..b8069d9 100644 --- a/source/unres/src-HCD-5D/stochfric.F +++ b/source/unres/src-HCD-5D/stochfric.F @@ -79,19 +79,25 @@ c & " n",n," iposc",iposc,iposc+n-1 endif enddo #ifdef DEBUG - write (iout,*) "vvec ind",ind + write (iout,*) "vvec ind",ind," n",n write (iout,'(f10.5)') (vvec(i),i=iposc,ind) #endif c write (iout,*) "chain",i," ind",ind," n",n call fivediagmult(n,DMfric(iposc),DU1fric(iposc), - & DU2fric(iposc),vvec,rs) + & DU2fric(iposc),vvec(iposc),rs) +#ifdef DEBUG + write (iout,*) "rs" + write (iout,'(f10.5)') (rs(i),i=1,n) +#endif do i=iposc,iposc+n-1 - fric_work(3*(i-1)+j)=-rs(i) +c write (iout,*) "ichain",ichain," i",i," j",j, +c & "index",3*(i-1)+j,"rs",rs(i-iposc+1) + fric_work(3*(i-1)+j)=-rs(i-iposc+1) enddo enddo enddo #ifdef DEBUG - write (iout,*) "Vector fric_work" + write (iout,*) "Vector fric_work dimen3",dimen3 write (iout,'(3f10.5)') (fric_work(j),j=1,dimen3) #endif #else @@ -282,6 +288,9 @@ c----------------------------------------------------- #endif c Compute the stochastic forces acting on bodies. Store in force. do i=nnt,nct-1 +#ifdef FIVEDIAG + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle +#endif sig=stdforcp(i) lowb=-5*sig highb=5*sig @@ -417,7 +426,6 @@ c Compute the stochastic forces acting on virtual-bond vectors. ind=ind+3 endif enddo -#endif if (lprn) then write (iout,*) "stochforcvec" do i=1,3*dimen @@ -468,8 +476,8 @@ c Compute the stochastic forces acting on virtual-bond vectors. enddo ind=ind+3 enddo - endif +#endif return end c------------------------------------------------------------------ @@ -510,7 +518,7 @@ c save licznik integer IERROR integer i,j,k,l,ind,ind1,m,ii,iti,it,nzero,innt,inct integer ichain,nind - logical lprn /.false./ + logical lprn /.true./ double precision dtdi,gamvec(MAXRES2) common /syfek/ gamvec #ifndef FIVEDIAG @@ -542,8 +550,8 @@ C gamsc(ntyp1)=1.0d0 enddo if (surfarea) call sdarea(gamvec) if (lprn) then - write (iout,*) "Vector gamvec" - do i=1,dimen1 + write (iout,*) "Vector gamvec ii",ii + do i=1,ii write (iout,'(i5,f10.5)') i, gamvec(i) enddo endif diff --git a/source/unres/src_MD-M-SAXS/energy_p_new-sep_barrier.F b/source/unres/src_MD-M-SAXS/energy_p_new-sep_barrier.F index 1f00b2b..261c06c 100644 --- a/source/unres/src_MD-M-SAXS/energy_p_new-sep_barrier.F +++ b/source/unres/src_MD-M-SAXS/energy_p_new-sep_barrier.F @@ -1,5 +1,6 @@ C----------------------------------------------------------------------- double precision function sscalelip(r) + implicit none double precision r,gamm include "COMMON.SPLITELE" C if(r.lt.r_cut-rlamb) then @@ -14,6 +15,7 @@ C endif end C----------------------------------------------------------------------- double precision function sscagradlip(r) + implicit none double precision r,gamm include "COMMON.SPLITELE" C if(r.lt.r_cut-rlamb) then @@ -28,8 +30,9 @@ C endif end C----------------------------------------------------------------------- - double precision function sscale(r) - double precision r,gamm + double precision function sscale(r,r_cut) + implicit none + double precision r,r_cut,gamm include "COMMON.SPLITELE" if(r.lt.r_cut-rlamb) then sscale=1.0d0 @@ -42,9 +45,9 @@ C----------------------------------------------------------------------- return end C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - double precision function sscagrad(r) - double precision r,gamm + double precision function sscagrad(r,r_cut) + implicit none + double precision r,r_cut,gamm include "COMMON.SPLITELE" if(r.lt.r_cut-rlamb) then sscagrad=0.0d0 @@ -62,9 +65,8 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the LJ potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' - parameter (accur=1.0d-10) include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' @@ -75,14 +77,20 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) + include "COMMON.SPLITELE" +c include 'COMMON.CONTACTS' + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,num_conti,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & sigij,r0ij,rcut,sss1,sssgrad1,sqrij + double precision sscale,sscagrad c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -93,25 +101,33 @@ C cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), cd & 'iend=',iend(i,iint) do j=istart(i,iint),iend(i,iint) - itypj=itype(j) + 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 rij=xj*xj+yj*yj+zj*zj - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) + sqrij=dsqrt(rrij) + eps0ij=eps(itypi,itypj) + sss1=sscale(sqrij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(sqrij,r_cut_int) + sssgrad= + & sscagrad(sqrij/sigma(itypi,itypj),r_cut_respa) + sss=sscale(sqrij/sigma(itypi,itypj),r_cut_respa) if (sss.lt.1.0d0) then rrij=1.0D0/rij - eps0ij=eps(itypi,itypj) fac=rrij**expon2 e1=fac*fac*aa e2=fac*bb evdwij=e1+e2 - evdw=evdw+(1.0d0-sss)*evdwij + evdw=evdw+(1.0d0-sss)*sss1*evdwij C C Calculate the components of the gradient in DC and X C - fac=-rrij*(e1+evdwij)*(1.0d0-sss) + fac=-rrij*(e1+evdwij)*(1.0d0-sss)*sss1 + & +evdwij*(-sss1*sssgrad/sigma(itypi,itypj) + & +(1.0d0-sss)*sssgrad1)/sqrij gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -148,9 +164,8 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the LJ potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' - parameter (accur=1.0d-10) include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' @@ -161,14 +176,20 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) + include "COMMON.SPLITELE" +c include 'COMMON.CONTACTS' + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,num_conti,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & sigij,r0ij,rcut,sqrij,sss1,sssgrad1 + double precision sscale,sscagrad c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -181,15 +202,18 @@ C cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), cd & 'iend=',iend(i,iint) do j=istart(i,iint),iend(i,iint) - itypj=itype(j) + 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 C Change 12/1/95 to calculate four-body interactions rij=xj*xj+yj*yj+zj*zj - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) + sqrij=dsqrt(rij) + sss=sscale(sqrij/sigma(itypi,itypj),r_cut_respa) if (sss.gt.0.0d0) then + sssgrad= + & sscagrad(sqrij/sigma(itypi,itypj),r_cut_respa) rrij=1.0D0/rij eps0ij=eps(itypi,itypj) fac=rrij**expon2 @@ -200,7 +224,7 @@ C Change 12/1/95 to calculate four-body interactions C C Calculate the components of the gradient in DC and X C - fac=-rrij*(e1+evdwij)*sss + fac=-rrij*(e1+evdwij)*sss+evdwij*sssgrad/sqrij gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -237,7 +261,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the LJK potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -247,14 +271,20 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.NAMES' - dimension gg(3) + include "COMMON.SPLITELE" + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1 logical scheck + double precision sscale,sscagrad c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -263,7 +293,7 @@ C Calculate SC interaction energy. C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi @@ -273,8 +303,13 @@ C e_augm=augm(itypi,itypj)*fac_augm r_inv_ij=dsqrt(rrij) rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) + sss1=sscale(rij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(rij,r_cut_int) + sss=sscale(rij/sigma(itypi,itypj),r_cut_respa) if (sss.lt.1.0d0) then + sssgrad= + & sscagrad(rij/sigma(itypi,itypj),r_cut_respa) r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) fac=r_shift_inv**expon e1=fac*fac*aa @@ -287,12 +322,14 @@ cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+(1.0d0-sss)*evdwij + evdw=evdw+(1.0d0-sss)*sss1*evdwij C C Calculate the components of the gradient in DC and X C fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) - fac=fac*(1.0d0-sss) + fac=fac*(1.0d0-sss)*sss1 + & +evdwij*(-sss1*sssgrad/sigma(itypi,itypj) + & +(1.0d0-sss)*sssgrad1)*r_inv_ij gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -330,14 +367,20 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.NAMES' - dimension gg(3) + include "COMMON.SPLITELE" + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1 logical scheck + double precision sscale,sscagrad c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -346,7 +389,7 @@ C Calculate SC interaction energy. C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi @@ -356,7 +399,7 @@ C e_augm=augm(itypi,itypj)*fac_augm r_inv_ij=dsqrt(rrij) rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) + sss=sscale(rij/sigma(itypi,itypj),r_cut_respa) if (sss.gt.0.0d0) then r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) fac=r_shift_inv**expon @@ -375,6 +418,7 @@ C C Calculate the components of the gradient in DC and X C fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) + & +evdwij*sssgrad/sigma(itypi,itypj)*r_inv_ij fac=fac*sss gg(1)=xj*fac gg(2)=yj*fac @@ -403,7 +447,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Berne-Pechukas potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -414,7 +458,14 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' + include "COMMON.SPLITELE" + integer icall common /srutu/ icall + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi + double precision sss1,sssgrad1 + double precision sscale,sscagrad c double precision rrsave(maxdim) logical lprn evdw=0.0D0 @@ -427,9 +478,9 @@ c else c endif ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -444,7 +495,7 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle c dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) @@ -465,10 +516,13 @@ c dscj_inv=dsc_inv(itypj) 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))) - + sss1=sscale(1.0d0/rij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)),r_cut_respa) if (sss.lt.1.0d0) then - + sssgrad= + & sscagrad(1.0d0/(rij*sigmaii(itypi,itypj)),r_cut_respa) + sssgrad1=sscagrad(1.0d0/rij,r_cut_int) C Calculate the angle-dependent terms of energy & contributions to derivatives. call sc_angular C Calculate whole angle-dependent part of epsilon and contributions @@ -480,7 +534,7 @@ C to its derivatives eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*(1.0d0-sss) + evdw=evdw+evdwij*(1.0d0-sss)*sss1 if (lprn) then sigm=dabs(aa/bb)**(1.0D0/6.0D0) epsi=bb**2/aa @@ -496,13 +550,15 @@ C Calculate gradient components. fac=-expon*(e1+evdwij) sigder=fac/sigsq fac=rrij*fac + & +evdwij*(sss1*sssgrad/sigmaii(itypi,itypj) + & +(1.0d0-sss)*sssgrad1)*rij C Calculate radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac C Calculate the angular part of the gradient and sum add the contributions C to the appropriate components of the Cartesian gradient. - call sc_grad_scale(1.0d0-sss) + call sc_grad_scale((1.0d0-sss)*sss1) endif enddo ! j enddo ! iint @@ -527,7 +583,13 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' + include "COMMON.SPLITELE" + integer icall common /srutu/ icall + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi + double precision sscale,sscagrad c double precision rrsave(maxdim) logical lprn evdw=0.0D0 @@ -540,9 +602,9 @@ c else c endif ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -557,7 +619,7 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle c dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) @@ -578,7 +640,7 @@ c dscj_inv=dsc_inv(itypj) 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))) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)),r_cut_respa) if (sss.gt.0.0d0) then @@ -609,6 +671,7 @@ C Calculate gradient components. fac=-expon*(e1+evdwij) sigder=fac/sigsq fac=rrij*fac + & +evdwij*sssgrad/sigmaii(itypi,itypj)*rrij C Calculate radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac @@ -629,7 +692,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Gay-Berne potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -641,8 +704,17 @@ C include 'COMMON.IOUNITS' include 'COMMON.CALC' include 'COMMON.CONTROL' + include "COMMON.SPLITELE" logical lprn integer xshift,yshift,zshift + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi + double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij, + & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip + double precision dist,sscale,sscagrad,sscagradlip,sscalelip + double precision subchap,sss1,sssgrad1 evdw=0.0D0 ccccc energy_dec=.false. c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon @@ -651,9 +723,9 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon c if (icall.eq.0) lprn=.false. ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -676,7 +748,7 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle c dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) @@ -696,81 +768,81 @@ c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) xj=c(1,nres+j) yj=c(2,nres+j) zj=c(3,nres+j) - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - if ((zj.gt.bordlipbot) - &.and.(zj.lt.bordliptop)) then + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + if ((zj.gt.bordlipbot).and.(zj.lt.bordliptop)) then C the energy transfer exist - if (zj.lt.buflipbot) then + if (zj.lt.buflipbot) then C what fraction I am in - fracinbuf=1.0d0- - & ((positi-bordlipbot)/lipbufthick) + fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick) C lipbufthick is thickenes of lipid buffore - sslipj=sscalelip(fracinbuf) - ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick - elseif (zi.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) - sslipj=sscalelip(fracinbuf) - ssgradlipj=sscagradlip(fracinbuf)/lipbufthick - else - sslipj=1.0d0 - ssgradlipj=0.0 - endif - else - sslipj=0.0d0 - ssgradlipj=0.0 - endif - aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 - & +aa_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 - bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 - & +bb_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 - - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif - 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))) - sssgrad=sscagrad((1.0d0/rij)/sigmaii(itypi,itypj)) - if (sss.lt.1.0d0) then - + sslipj=sscalelip(fracinbuf) + ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick + else if (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick) + sslipj=sscalelip(fracinbuf) + ssgradlipj=sscagradlip(fracinbuf)/lipbufthick + else + sslipj=1.0d0 + ssgradlipj=0.0 + endif + else + sslipj=0.0d0 + ssgradlipj=0.0 + endif + aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +aa_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 + bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +bb_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + if (dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + subchap=1 + endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif + 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) + sss1=sscale(1.0d0/rij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)),r_cut_respa) + if (sss.lt.1.0d0) then C Calculate angle-dependent terms of energy and contributions to their C derivatives. + sssgrad= + & sscagrad((1.0d0/rij)/sigmaii(itypi,itypj),r_cut_respa) + sssgrad1=sscagrad(1.0d0/rij,r_cut_int) call sc_angular sigsq=1.0D0/sigsq sig=sig0ij*dsqrt(sigsq) @@ -797,7 +869,7 @@ c--------------------------------------------------------------- c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*(1.0d0-sss) + evdw=evdw+evdwij*(1.0d0-sss)*sss1 if (lprn) then sigm=dabs(aa/bb)**(1.0D0/6.0D0) epsi=bb**2/aa @@ -809,15 +881,16 @@ c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 & evdwij endif - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij + if (energy_dec) write (iout,'(a6,2i5,4f10.5)') + & 'evdw',i,j,rij,sss,sss1,evdwij C Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac - fac=fac+evdwij/(1.0-sss)*(-sssgrad)/sigmaii(itypi,itypj)*rij + fac=fac+evdwij*(-sss1*sssgrad/sigmaii(itypi,itypj) + & +(1.0d0-sss)*sssgrad1)*rij c fac=0.0d0 C Calculate the radial part of the gradient gg(1)=xj*fac @@ -826,7 +899,7 @@ C Calculate the radial part of the gradient gg_lipi(3)=ssgradlipi*evdwij gg_lipj(3)=ssgradlipj*evdwij C Calculate angular part of the gradient. - call sc_grad_scale(1.0d0-sss) + call sc_grad_scale((1.0d0-sss)*sss1) endif enddo ! j enddo ! iint @@ -841,7 +914,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Gay-Berne potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -853,8 +926,17 @@ C include 'COMMON.IOUNITS' include 'COMMON.CALC' include 'COMMON.CONTROL' + include "COMMON.SPLITELE" logical lprn integer xshift,yshift,zshift + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi + double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij, + & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip + double precision dist,sscale,sscagrad,sscagradlip,sscalelip + double precision subchap evdw=0.0D0 ccccc energy_dec=.false. c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon @@ -863,9 +945,9 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon c if (icall.eq.0) lprn=.false. ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -888,7 +970,7 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle c dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) @@ -908,76 +990,74 @@ c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) xj=c(1,nres+j) yj=c(2,nres+j) zj=c(3,nres+j) - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - if ((zj.gt.bordlipbot) - &.and.(zj.lt.bordliptop)) then + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + if ((zj.gt.bordlipbot).and.(zj.lt.bordliptop)) then C the energy transfer exist - if (zj.lt.buflipbot) then + if (zj.lt.buflipbot) then C what fraction I am in - fracinbuf=1.0d0- - & ((positi-bordlipbot)/lipbufthick) + fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick) C lipbufthick is thickenes of lipid buffore - sslipj=sscalelip(fracinbuf) - ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick - elseif (zi.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) - sslipj=sscalelip(fracinbuf) - ssgradlipj=sscagradlip(fracinbuf)/lipbufthick - else - sslipj=1.0d0 - ssgradlipj=0.0 - endif - else - sslipj=0.0d0 - ssgradlipj=0.0 - endif - aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 - & +aa_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 - bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 - & +bb_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif + sslipj=sscalelip(fracinbuf) + ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick + elseif (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick) + sslipj=sscalelip(fracinbuf) + ssgradlipj=sscagradlip(fracinbuf)/lipbufthick + else + sslipj=1.0d0 + ssgradlipj=0.0 + endif + else + sslipj=0.0d0 + ssgradlipj=0.0 + endif + aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +aa_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 + bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +bb_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + subchap=1 + endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif 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))) - sssgrad=sscagrad((1.0d0/rij)/sigmaii(itypi,itypj)) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)),r_cut_respa) + sssgrad=sscagrad((1.0d0/rij)/sigmaii(itypi,itypj),r_cut_respa) if (sss.gt.0.0d0) then C Calculate angle-dependent terms of energy and contributions to their @@ -1028,7 +1108,7 @@ C Calculate gradient components. fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac - fac=fac+evdwij/sss*sssgrad/sigmaii(itypi,itypj)*rij + fac=fac+evdwij*sssgrad/sigmaii(itypi,itypj)*rij c fac=0.0d0 C Calculate the radial part of the gradient gg(1)=xj*fac @@ -1063,8 +1143,18 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' + include "COMMON.SPLITELE" + integer icall common /srutu/ icall logical lprn + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij, + & xi,yi,zi,fac_augm,e_augm + double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij, + & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip + double precision dist,sscale,sscagrad,sscagradlip,sscalelip + double precision sss1,sssgrad1 evdw=0.0D0 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 @@ -1072,9 +1162,9 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon c if (icall.eq.0) lprn=.true. ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -1089,7 +1179,7 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle c dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) @@ -1113,9 +1203,13 @@ c dscj_inv=dsc_inv(itypj) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + sss1=sscale(1.0d0/rij,r_cut_int) + if (sss1.eq.0.0d0) cycle if (sss.lt.1.0d0) then + sssgrad= + & sscagrad((1.0d0/rij)/sigmaii(itypi,itypj),r_cut_respa) + sssgrad1=sscagrad(1.0d0/rij,r_cut_int) C Calculate angle-dependent terms of energy and contributions to their C derivatives. @@ -1140,7 +1234,7 @@ c--------------------------------------------------------------- fac_augm=rrij**expon e_augm=augm(itypi,itypj)*fac_augm evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+(evdwij+e_augm)*(1.0d0-sss) + evdw=evdw+(evdwij+e_augm)*sss1*(1.0d0-sss) if (lprn) then sigm=dabs(aa/bb)**(1.0D0/6.0D0) epsi=bb**2/aa @@ -1157,12 +1251,15 @@ C Calculate gradient components. fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac-2*expon*rrij*e_augm + fac=fac+(evdwij+e_augm)* + & (-sss1*sssgrad/sigmaii(itypi,itypj) + & +(1.0d0-sss)*sssgrad1)*rij C Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac C Calculate angular part of the gradient. - call sc_grad_scale(1.0d0-sss) + call sc_grad_scale((1.0d0-sss)*sss1) endif enddo ! j enddo ! iint @@ -1174,7 +1271,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Gay-Berne-Vorobjev potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -1185,8 +1282,18 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' + include "COMMON.SPLITELE" + integer icall common /srutu/ icall logical lprn + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij, + & xi,yi,zi,fac_augm,e_augm + double precision evdw + double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij, + & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip + double precision dist,sscale,sscagrad,sscagradlip,sscalelip evdw=0.0D0 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 @@ -1194,9 +1301,9 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon c if (icall.eq.0) lprn=.true. ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -1211,7 +1318,7 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle c dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) @@ -1235,7 +1342,7 @@ c dscj_inv=dsc_inv(itypj) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)),r_cut_respa) if (sss.gt.0.0d0) then @@ -1278,7 +1385,8 @@ C Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder - fac=rij*fac-2*expon*rrij*e_augm + fac=rij*fac-2*expon*rrij*e_augm+ + & (evdwij+e_augm)*sssgrad/sigmaii(itypi,itypj)*rij C Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac @@ -1298,6 +1406,7 @@ C---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.CALC' include 'COMMON.IOUNITS' + include "COMMON.SPLITELE" double precision dcosom1(3),dcosom2(3) double precision scalfac eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 @@ -1365,12 +1474,17 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' include 'COMMON.TIME1' include 'COMMON.SHIELD' + include "COMMON.SPLITELE" dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), @@ -1439,9 +1553,11 @@ cd enddo eello_turn3=0.0d0 eello_turn4=0.0d0 ind=0 +#ifdef FOURBODY do i=1,nres num_cont_hb(i)=0 enddo +#endif cd print '(a)','Enter EELEC' cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e do i=1,nres @@ -1478,7 +1594,9 @@ C & .or. itype(i+4).eq.ntyp1 num_conti=0 call eelecij_scale(i,i+2,ees,evdw1,eel_loc) if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo do i=iturn4_start,iturn4_end if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 @@ -1502,11 +1620,15 @@ C & .or. itype(i-1).eq.ntyp1 if (ymedi.lt.0) ymedi=ymedi+boxysize zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif 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) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i c c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 @@ -1531,8 +1653,10 @@ C & .or. itype(i-1).eq.ntyp1 if (ymedi.lt.0) ymedi=ymedi+boxysize zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize -c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) +c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif do j=ielstart(i),ielend(i) if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1 C & .or.itype(j+2).eq.ntyp1 @@ -1540,7 +1664,9 @@ C & .or.itype(j-1).eq.ntyp1 &) cycle call eelecij_scale(i,j,ees,evdw1,eel_loc) enddo ! j +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i c write (iout,*) "Number of loop steps in EELEC:",ind cd do i=1,nres @@ -1554,7 +1680,7 @@ cd print *,"Processor",fg_rank," t_eelecij",t_eelecij end C------------------------------------------------------------------------------- subroutine eelecij_scale(i,j,ees,evdw1,eel_loc) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -1567,21 +1693,48 @@ C------------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' include 'COMMON.TIME1' include 'COMMON.SHIELD' + include "COMMON.SPLITELE" integer xshift,yshift,zshift - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), + double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4), & gmuij2(4),gmuji2(4) + integer j1,j2,num_conti common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, & num_conti,j1,j2 + integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ind,itypi,itypj + integer ilist,iresshield + double precision rlocshield + double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp + double precision ees,evdw1,eel_loc,aaa,bbb,ael3i + double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj, + & rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4, + & evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa, + & ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der, + & a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij, + & ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp, + & ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp, + & ecosgp,ecosam,ecosbm,ecosgm,ghalf,geel_loc_ij,geel_loc_ji, + & dxi,dyi,dzi,a22,a23,a32,a33 + double precision dist_init,xmedi,ymedi,zmedi,xj_safe,yj_safe, + & zj_safe,xj_temp,yj_temp,zj_temp,dist_temp,dx_normi,dy_normi, + & dz_normi,aux + double precision sss1,sssgrad1 + double precision sscale,sscagrad + double precision scalar + c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions #ifdef MOMENT double precision scal_el /1.0d0/ @@ -1596,29 +1749,29 @@ C 13-go grudnia roku pamietnego... c time00=MPI_Wtime() cd write (iout,*) "eelecij",i,j C print *,"WCHODZE2" - 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 - yj=c(2,j)+0.5D0*dyj - zj=c(3,j)+0.5D0*dzj - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize + 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 + yj=c(2,j)+0.5D0*dyj + zj=c(3,j)+0.5D0*dzj + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 xj_safe=xj yj_safe=yj @@ -1638,89 +1791,102 @@ C print *,"WCHODZE2" zj_temp=zj isubchap=1 endif - enddo - enddo - enddo - if (isubchap.eq.1) then - xj=xj_temp-xmedi - yj=yj_temp-ymedi - zj=zj_temp-zmedi - else - xj=xj_safe-xmedi - yj=yj_safe-ymedi - zj=zj_safe-zmedi - endif + enddo + enddo + enddo + if (isubchap.eq.1) then + xj=xj_temp-xmedi + yj=yj_temp-ymedi + zj=zj_temp-zmedi + else + xj=xj_safe-xmedi + yj=yj_safe-ymedi + zj=zj_safe-zmedi + endif - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - rmij=1.0D0/rij + rij=xj*xj+yj*yj+zj*zj + rrmij=1.0D0/rij + rij=dsqrt(rij) + rmij=1.0D0/rij c For extracting the short-range part of Evdwpp - sss=sscale(rij/rpp(iteli,itelj)) - sssgrad=sscagrad(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 + sss1=sscale(rij,r_cut_int) + if (sss1.eq.0.0d0) return + sss=sscale(rij/rpp(iteli,itelj),r_cut_respa) + sssgrad=sscagrad(rij/rpp(iteli,itelj),r_cut_respa) + sssgrad1=sscagrad(rij,r_cut_int) + r3ij=rrmij*rmij + r6ij=r3ij*r3ij + cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj + cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij + cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij + fac=cosa-3.0D0*cosb*cosg + ev1=aaa*r6ij*r6ij c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - fac3=ael6i*r6ij - fac4=ael3i*r3ij - evdwij=ev1+ev2 - if (shield_mode.eq.0) then - fac_shield(i)=1.0 - fac_shield(j)=1.0 - endif - el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - el1=el1*fac_shield(i)**2*fac_shield(j)**2 - el2=el2*fac_shield(i)**2*fac_shield(j)**2 - eesij=el1+el2 + if (j.eq.i+2) ev1=scal_el*ev1 + ev2=bbb*r6ij + fac3=ael6i*r6ij + fac4=ael3i*r3ij + evdwij=ev1+ev2 + if (shield_mode.eq.0) then + fac_shield(i)=1.0 + fac_shield(j)=1.0 + endif + el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) + el2=fac4*fac + el1=el1*fac_shield(i)**2*fac_shield(j)**2 + el2=el2*fac_shield(i)**2*fac_shield(j)**2 + eesij=el1+el2 C 12/26/95 - for the evaluation of multi-body H-bonding interactions - ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) - ees=ees+eesij - evdw1=evdw1+evdwij*(1.0d0-sss) + ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) + ees=ees+eesij*sss1 + evdw1=evdw1+evdwij*(1.0d0-sss)*sss1 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, cd & xmedi,ymedi,zmedi,xj,yj,zj - if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss - write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij - endif + if (energy_dec) then + write (iout,'(a6,2i5,0pf7.3,2f7.3)') + & 'evdw1',i,j,evdwij,sss,sss1 + write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij + endif C C Calculate contributions to the Cartesian gradient. C #ifdef SPLITELE - facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss) - facel=-3*rrmij*(el1+eesij) - fac1=fac - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij + facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + facel=-3*rrmij*(el1+eesij)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + 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 - if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. + aux=facel+(sssgrad1*(1.0d0-sss)-sssgrad*sss1/rpp(iteli,itelj)) + & *eesij*rmij +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + ggg(1)=aux*xj + ggg(2)=aux*yj + ggg(3)=aux*zj +c ggg(1)=facel*xj +c ggg(2)=facel*yj +c ggg(3)=facel*zj + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. & (shield_mode.gt.0)) then C print *,i,j - do ilist=1,ishield_list(i) - iresshield=shield_list(ilist,i) - do k=1,3 - rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i) - & *2.0 + do ilist=1,ishield_list(i) + iresshield=shield_list(ilist,i) + do k=1,3 + rlocshield=grad_shield_side(k,ilist,i)*eesij*sss1 + & /fac_shield(i)*2.0*sss1 gshieldx(k,iresshield)=gshieldx(k,iresshield)+ & rlocshield - & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 + & +grad_shield_loc(k,ilist,i)*eesij*sss1/fac_shield(i)*2.0 + & *sss1 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield) C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i) @@ -1737,32 +1903,32 @@ C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i) C C enddo C endif - enddo enddo - do ilist=1,ishield_list(j) - iresshield=shield_list(ilist,j) - do k=1,3 + enddo + do ilist=1,ishield_list(j) + iresshield=shield_list(ilist,j) + do k=1,3 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) - & *2.0 + & *2.0*sss1 gshieldx(k,iresshield)=gshieldx(k,iresshield)+ - & rlocshield - & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 + & rlocshield + & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss1 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield - enddo enddo + enddo - do k=1,3 - gshieldc(k,i)=gshieldc(k,i)+ - & grad_shield(k,i)*eesij/fac_shield(i)*2.0 - gshieldc(k,j)=gshieldc(k,j)+ - & grad_shield(k,j)*eesij/fac_shield(j)*2.0 - gshieldc(k,i-1)=gshieldc(k,i-1)+ - & grad_shield(k,i)*eesij/fac_shield(i)*2.0 - gshieldc(k,j-1)=gshieldc(k,j-1)+ - & grad_shield(k,j)*eesij/fac_shield(j)*2.0 + do k=1,3 + gshieldc(k,i)=gshieldc(k,i)+ + & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss1 + gshieldc(k,j)=gshieldc(k,j)+ + & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss1 + gshieldc(k,i-1)=gshieldc(k,i-1)+ + & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss1 + gshieldc(k,j-1)=gshieldc(k,j-1)+ + & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss1 - enddo - endif + enddo + endif c do k=1,3 c ghalf=0.5D0*ggg(k) @@ -1770,10 +1936,12 @@ c gelc(k,i)=gelc(k,i)+ghalf c gelc(k,j)=gelc(k,j)+ghalf c enddo c 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gelc_long(k,j)=gelc_long(k,j)+ggg(k) - gelc_long(k,i)=gelc_long(k,i)-ggg(k) - enddo + 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 +c gelc_long(3,i)=gelc_long(3,i)+ +c ssgradlipi*eesij/2.0d0*lipscale**2*sss1 * * Loop over residues i+1 thru j-1. * @@ -1782,19 +1950,22 @@ cgrad do l=1,3 cgrad gelc(l,k)=gelc(l,k)+ggg(l) cgrad enddo cgrad enddo - ggg(1)=facvdw*xj-sssgrad*rmij*evdwij*xj/rpp(iteli,itelj) - ggg(2)=facvdw*yj-sssgrad*rmij*evdwij*yj/rpp(iteli,itelj) - ggg(3)=facvdw*zj-sssgrad*rmij*evdwij*zj/rpp(iteli,itelj) + facvdw=facvdw+ + & (-sss1*sssgrad/rpp(iteli,itelj)+(1.0d0-sss)*sssgrad1)*rmij*evdwij +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj c do k=1,3 c ghalf=0.5D0*ggg(k) c gvdwpp(k,i)=gvdwpp(k,i)+ghalf c gvdwpp(k,j)=gvdwpp(k,j)+ghalf c enddo c 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo + 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. * @@ -1804,29 +1975,40 @@ cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) cgrad enddo cgrad enddo #else - facvdw=ev1+evdwij*(1.0d0-sss) - facel=el1+eesij - fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij + facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + facel=-3*rrmij*(el1+eesij)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + +c facvdw=ev1+evdwij*(1.0d0-sss)*sss1 +c 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 + aux=fac+(sssgrad1*(1.0d0-sss)-sssgrad*sss1/rpp(iteli,itelj)) + & *eesij*rmij +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + ggg(1)=aux*xj + ggg(2)=aux*yj + ggg(3)=axu*zj +c ggg(1)=fac*xj +c ggg(2)=fac*yj +c ggg(3)=fac*zj c do k=1,3 c ghalf=0.5D0*ggg(k) c gelc(k,i)=gelc(k,i)+ghalf c gelc(k,j)=gelc(k,j)+ghalf c enddo c 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gelc_long(k,j)=gelc(k,j)+ggg(k) - gelc_long(k,i)=gelc(k,i)-ggg(k) - enddo + 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. * @@ -1839,33 +2021,36 @@ c 9/28/08 AL Gradient compotents will be summed only at the end C ggg(1)=facvdw*xj C ggg(2)=facvdw*yj C ggg(3)=facvdw*zj - ggg(1)=facvdw*xj-sssgrad*rmij*evdwij*xj/rpp(iteli,itelj) - ggg(2)=facvdw*yj-sssgrad*rmij*evdwij*yj/rpp(iteli,itelj) - ggg(3)=facvdw*zj-sssgrad*rmij*evdwij*zj/rpp(iteli,itelj) - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo + facvdw=facvdw + & (-sssgrad*sss1/rpp(iteli,itelj)+sssgrad1*(1.0d0-sss))*rmij*evdwij + 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 + ecosa=2.0D0*fac3*fac1+fac4 + fac4=-3.0D0*fac4 + fac3=-6.0D0*fac3 + ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) + ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) + do k=1,3 + dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) + dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) + enddo cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), cd & (dcosg(k),k=1,3) - do k=1,3 - ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))* - & fac_shield(i)**2*fac_shield(j)**2 + do k=1,3 + ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss1 + & *fac_shield(i)**2*fac_shield(j)**2 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) - enddo + enddo c do k=1,3 c ghalf=0.5D0*ggg(k) c gelc(k,i)=gelc(k,i)+ghalf @@ -1880,22 +2065,24 @@ cgrad do l=1,3 cgrad gelc(l,k)=gelc(l,k)+ggg(l) cgrad enddo cgrad enddo - do k=1,3 - gelc(k,i)=gelc(k,i) - & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)) - & *fac_shield(i)**2*fac_shield(j)**2 + 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))*sss1 + & *fac_shield(i)**2*fac_shield(j)**2 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) - 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)) - & *fac_shield(i)**2*fac_shield(j)**2 - 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 + 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))*sss1 + & *fac_shield(i)**2*fac_shield(j)**2 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + gelc_long(k,j)=gelc_long(k,j)+ggg(k) + gelc_long(k,i)=gelc_long(k,i)-ggg(k) + enddo + IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 + & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 + & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN C C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction C energy of a peptide unit is assumed in the form of a second-order @@ -1903,44 +2090,44 @@ C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms C are computed for EVERY pair of non-contiguous peptide groups. C - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - kkk=0 - do k=1,2 - do l=1,2 - kkk=kkk+1 - muij(kkk)=mu(k,i)*mu(l,j) + 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) #ifdef NEWCORR - gmuij1(kkk)=gtb1(k,i+1)*mu(l,j) + gmuij1(kkk)=gtb1(k,i+1)*mu(l,j) c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j) - gmuij2(kkk)=gUb2(k,i)*mu(l,j) - gmuji1(kkk)=mu(k,i)*gtb1(l,j+1) + gmuij2(kkk)=gUb2(k,i)*mu(l,j) + gmuji1(kkk)=mu(k,i)*gtb1(l,j+1) c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i) - gmuji2(kkk)=mu(k,i)*gUb2(l,j) + gmuji2(kkk)=mu(k,i)*gUb2(l,j) #endif - enddo - enddo + enddo + enddo cd write (iout,*) 'EELEC: i',i,' j',j cd write (iout,*) 'j',j,' j1',j1,' j2',j2 cd write(iout,*) 'muij',muij - ury=scalar(uy(1,i),erij) - urz=scalar(uz(1,i),erij) - vry=scalar(uy(1,j),erij) - vrz=scalar(uz(1,j),erij) - a22=scalar(uy(1,i),uy(1,j))-3*ury*vry - a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz - a32=scalar(uz(1,i),uy(1,j))-3*urz*vry - a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz - fac=dsqrt(-ael6i)*r3ij - a22=a22*fac - a23=a23*fac - a32=a32*fac - a33=a33*fac + ury=scalar(uy(1,i),erij) + urz=scalar(uz(1,i),erij) + vry=scalar(uy(1,j),erij) + vrz=scalar(uz(1,j),erij) + a22=scalar(uy(1,i),uy(1,j))-3*ury*vry + a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz + a32=scalar(uz(1,i),uy(1,j))-3*urz*vry + a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz + fac=dsqrt(-ael6i)*r3ij + a22=a22*fac + a23=a23*fac + a32=a32*fac + a33=a33*fac cd write (iout,'(4i5,4f10.5)') cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij @@ -1953,101 +2140,113 @@ cd write (iout,'(4f10.5)') ury,urz,vry,vrz cd write (iout,'(9f10.5/)') cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij C Derivatives of the elements of A in virtual-bond vectors - call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) - do k=1,3 - uryg(k,1)=scalar(erder(1,k),uy(1,i)) - uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) - uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) - urzg(k,1)=scalar(erder(1,k),uz(1,i)) - urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) - urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) - vryg(k,1)=scalar(erder(1,k),uy(1,j)) - vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) - vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) - vrzg(k,1)=scalar(erder(1,k),uz(1,j)) - vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) - vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) - enddo + call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) + do k=1,3 + uryg(k,1)=scalar(erder(1,k),uy(1,i)) + uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) + uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) + urzg(k,1)=scalar(erder(1,k),uz(1,i)) + urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) + urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) + vryg(k,1)=scalar(erder(1,k),uy(1,j)) + vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) + vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) + vrzg(k,1)=scalar(erder(1,k),uz(1,j)) + vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) + vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) + enddo C Compute radial contributions to the gradient - facr=-3.0d0*rrmij - a22der=a22*facr - a23der=a23*facr - a32der=a32*facr - a33der=a33*facr - agg(1,1)=a22der*xj - agg(2,1)=a22der*yj - agg(3,1)=a22der*zj - agg(1,2)=a23der*xj - agg(2,2)=a23der*yj - agg(3,2)=a23der*zj - agg(1,3)=a32der*xj - agg(2,3)=a32der*yj - agg(3,3)=a32der*zj - agg(1,4)=a33der*xj - agg(2,4)=a33der*yj - agg(3,4)=a33der*zj + facr=-3.0d0*rrmij + a22der=a22*facr + a23der=a23*facr + a32der=a32*facr + a33der=a33*facr + agg(1,1)=a22der*xj + agg(2,1)=a22der*yj + agg(3,1)=a22der*zj + agg(1,2)=a23der*xj + agg(2,2)=a23der*yj + agg(3,2)=a23der*zj + agg(1,3)=a32der*xj + agg(2,3)=a32der*yj + agg(3,3)=a32der*zj + agg(1,4)=a33der*xj + agg(2,4)=a33der*yj + agg(3,4)=a33der*zj C Add the contributions coming from er - fac3=-3.0d0*fac - do k=1,3 - agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) - agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) - agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) - agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) - enddo - do k=1,3 + fac3=-3.0d0*fac + do k=1,3 + agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) + agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) + agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) + agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) + enddo + do k=1,3 C Derivatives in DC(i) cgrad ghalf1=0.5d0*agg(k,1) cgrad ghalf2=0.5d0*agg(k,2) cgrad ghalf3=0.5d0*agg(k,3) cgrad ghalf4=0.5d0*agg(k,4) - aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) - & -3.0d0*uryg(k,2)*vry)!+ghalf1 - aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) - & -3.0d0*uryg(k,2)*vrz)!+ghalf2 - aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) - & -3.0d0*urzg(k,2)*vry)!+ghalf3 - aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) - & -3.0d0*urzg(k,2)*vrz)!+ghalf4 + aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) + & -3.0d0*uryg(k,2)*vry)!+ghalf1 + aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) + & -3.0d0*uryg(k,2)*vrz)!+ghalf2 + aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) + & -3.0d0*urzg(k,2)*vry)!+ghalf3 + aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) + & -3.0d0*urzg(k,2)*vrz)!+ghalf4 C Derivatives in DC(i+1) - aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) - & -3.0d0*uryg(k,3)*vry)!+agg(k,1) - aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) - & -3.0d0*uryg(k,3)*vrz)!+agg(k,2) - aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) - & -3.0d0*urzg(k,3)*vry)!+agg(k,3) - aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) - & -3.0d0*urzg(k,3)*vrz)!+agg(k,4) + aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) + & -3.0d0*uryg(k,3)*vry)!+agg(k,1) + aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) + & -3.0d0*uryg(k,3)*vrz)!+agg(k,2) + aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) + & -3.0d0*urzg(k,3)*vry)!+agg(k,3) + aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) + & -3.0d0*urzg(k,3)*vrz)!+agg(k,4) C Derivatives in DC(j) - aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) - & -3.0d0*vryg(k,2)*ury)!+ghalf1 - aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) - & -3.0d0*vrzg(k,2)*ury)!+ghalf2 - aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) - & -3.0d0*vryg(k,2)*urz)!+ghalf3 - aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) - & -3.0d0*vrzg(k,2)*urz)!+ghalf4 + aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) + & -3.0d0*vryg(k,2)*ury)!+ghalf1 + aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) + & -3.0d0*vrzg(k,2)*ury)!+ghalf2 + aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) + & -3.0d0*vryg(k,2)*urz)!+ghalf3 + aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) + & -3.0d0*vrzg(k,2)*urz)!+ghalf4 C Derivatives in DC(j+1) or DC(nres-1) - aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) - & -3.0d0*vryg(k,3)*ury) - aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) - & -3.0d0*vrzg(k,3)*ury) - aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) - & -3.0d0*vryg(k,3)*urz) - aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) - & -3.0d0*vrzg(k,3)*urz) + aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) + & -3.0d0*vryg(k,3)*ury) + aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) + & -3.0d0*vrzg(k,3)*ury) + aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) + & -3.0d0*vryg(k,3)*urz) + aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) + & -3.0d0*vrzg(k,3)*urz) cgrad if (j.eq.nres-1 .and. i.lt.j-2) then cgrad do l=1,4 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l) cgrad enddo cgrad endif + enddo + acipa(1,1)=a22 + acipa(1,2)=a23 + acipa(2,1)=a32 + acipa(2,2)=a33 + a22=-a22 + a23=-a23 + do l=1,2 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) enddo - acipa(1,1)=a22 - acipa(1,2)=a23 - acipa(2,1)=a32 - acipa(2,2)=a33 + enddo + if (j.lt.nres-1) then a22=-a22 - a23=-a23 - do l=1,2 + a32=-a32 + do l=1,3,2 do k=1,3 agg(k,l)=-agg(k,l) aggi(k,l)=-aggi(k,l) @@ -2056,56 +2255,44 @@ cgrad endif 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 + 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 - 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 + enddo + endif + ENDIF ! WCORR + IF (wel_loc.gt.0.0d0) THEN C Contribution to the local-electrostatic energy coming from the i-j pair - eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) - & +a33*muij(4) -cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij + eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) + & +a33*muij(4) +cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'eelloc',i,j,eel_loc_ij + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'eelloc',i,j,eel_loc_ij - if (shield_mode.eq.0) then - fac_shield(i)=1.0 - fac_shield(j)=1.0 -C else -C fac_shield(i)=0.4 -C fac_shield(j)=0.6 - endif - eel_loc_ij=eel_loc_ij - & *fac_shield(i)*fac_shield(j) - eel_loc=eel_loc+eel_loc_ij + if (shield_mode.eq.0) then + fac_shield(i)=1.0 + fac_shield(j)=1.0 +C else +C fac_shield(i)=0.4 +C fac_shield(j)=0.6 + endif + eel_loc_ij=eel_loc_ij + & *fac_shield(i)*fac_shield(j) + eel_loc=eel_loc+eel_loc_ij*sss1 - if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. & (shield_mode.gt.0)) then C print *,i,j @@ -2113,11 +2300,11 @@ C print *,i,j iresshield=shield_list(ilist,i) do k=1,3 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij - & /fac_shield(i) + & /fac_shield(i)*sss1 C & *2.0 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ & rlocshield - & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i) + & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)*sss1 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1) & +rlocshield enddo @@ -2126,11 +2313,11 @@ C & *2.0 iresshield=shield_list(ilist,j) do k=1,3 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij - & /fac_shield(j) + & /fac_shield(j)*sss1 C & *2.0 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ & rlocshield - & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j) + & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)*sss1 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1) & +rlocshield @@ -2139,41 +2326,41 @@ C & *2.0 do k=1,3 gshieldc_ll(k,i)=gshieldc_ll(k,i)+ - & grad_shield(k,i)*eel_loc_ij/fac_shield(i) + & grad_shield(k,i)*eel_loc_ij/fac_shield(i)*sss1 gshieldc_ll(k,j)=gshieldc_ll(k,j)+ - & grad_shield(k,j)*eel_loc_ij/fac_shield(j) + & grad_shield(k,j)*eel_loc_ij/fac_shield(j)*sss1 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ - & grad_shield(k,i)*eel_loc_ij/fac_shield(i) + & grad_shield(k,i)*eel_loc_ij/fac_shield(i)*sss1 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ - & grad_shield(k,j)*eel_loc_ij/fac_shield(j) - enddo - endif + & grad_shield(k,j)*eel_loc_ij/fac_shield(j)*sss1 + enddo + endif #ifdef NEWCORR - geel_loc_ij=(a22*gmuij1(1) + geel_loc_ij=(a22*gmuij1(1) & +a23*gmuij1(2) & +a32*gmuij1(3) & +a33*gmuij1(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss1 c write(iout,*) "derivative over thatai" c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3), c & a33*gmuij1(4) - gloc(nphi+i,icg)=gloc(nphi+i,icg)+ + gloc(nphi+i,icg)=gloc(nphi+i,icg)+ & geel_loc_ij*wel_loc c write(iout,*) "derivative over thatai-1" c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3), c & a33*gmuij2(4) - geel_loc_ij= + geel_loc_ij= & a22*gmuij2(1) & +a23*gmuij2(2) & +a32*gmuij2(3) & +a33*gmuij2(4) - gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ & geel_loc_ij*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss1 c Derivative over j residue - geel_loc_ji=a22*gmuji1(1) + geel_loc_ji=a22*gmuji1(1) & +a23*gmuji1(2) & +a32*gmuji1(3) & +a33*gmuji1(4) @@ -2183,9 +2370,9 @@ c & a33*gmuji1(4) gloc(nphi+j,icg)=gloc(nphi+j,icg)+ & geel_loc_ji*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss1 - geel_loc_ji= + geel_loc_ji= & +a22*gmuji2(1) & +a23*gmuji2(2) & +a32*gmuji2(3) @@ -2193,147 +2380,167 @@ c & a33*gmuji1(4) c write(iout,*) "derivative over thataj-1" c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3), c & a33*gmuji2(4) - gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+ - & geel_loc_ji*wel_loc - & *fac_shield(i)*fac_shield(j) + gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+ + & geel_loc_ji*wel_loc + & *fac_shield(i)*fac_shield(j)*sss1 #endif -cC Partial derivatives in virtual-bond dihedral angles gamma - if (i.gt.1) +cC Paral 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)) - & *fac_shield(i)*fac_shield(j) + & (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)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *fac_shield(i)*fac_shield(j) +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) - 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)) - & *fac_shield(i)*fac_shield(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)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *fac_shield(i)*fac_shield(j) +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) - do l=1,3 - ggg(l)=(agg(l,1)*muij(1)+ - & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + 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)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *fac_shield(i)*fac_shield(j) +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) - gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) - gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) -cgrad ghalf=0.5d0*ggg(l) -cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf -cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf - enddo + gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) + gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) +cgrad ghalf=0.5d0*ggg(l) +cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf +cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf + enddo cgrad do k=i+1,j2 cgrad do l=1,3 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l) cgrad enddo cgrad enddo C Remaining derivatives of eello - do l=1,3 - gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ - & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) +c gel_loc_long(3,j)=gel_loc_long(3,j)+ & +c ssgradlipj*eel_loc_ij/2.0d0*lipscale/ & +c ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut +c +c gel_loc_long(3,i)=gel_loc_long(3,i)+ & +c ssgradlipi*eel_loc_ij/2.0d0*lipscale/ & +c ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut - 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)) - & *fac_shield(i)*fac_shield(j) + 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)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) - 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)) - & *fac_shield(i)*fac_shield(j) + 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)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) - 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)) - & *fac_shield(i)*fac_shield(j) + 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)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) - enddo - ENDIF + 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)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + + enddo + ENDIF +#ifdef FOURBODY C Change 12/26/95 to calculate four-body contributions to H-bonding energy c if (j.gt.i+1 .and. num_conti.le.maxconts) then - if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 - & .and. num_conti.le.maxconts) then + if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 + & .and. num_conti.le.maxconts) then c write (iout,*) i,j," entered corr" C C Calculate the contact function. The ith column of the array JCONT will C contain the numbers of atoms that make contacts with the atom I (of numbers C greater than I). The arrays FACONT and GACONT will contain the values of C the contact function and its derivative. -c r0ij=1.02D0*rpp(iteli,itelj) -c r0ij=1.11D0*rpp(iteli,itelj) - r0ij=2.20D0*rpp(iteli,itelj) -c r0ij=1.55D0*rpp(iteli,itelj) - call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) - if (fcont.gt.0.0D0) then - num_conti=num_conti+1 - if (num_conti.gt.maxconts) then - write (iout,*) 'WARNING - max. # of contacts exceeded;', - & ' will skip next contacts for this conf.' - else - jcont_hb(num_conti,i)=j -cd write (iout,*) "i",i," j",j," num_conti",num_conti, -cd & " jcont_hb",jcont_hb(num_conti,i) - IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. - & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN +c r0ij=1.02D0*rpp(iteli,itelj) +c r0ij=1.11D0*rpp(iteli,itelj) + r0ij=2.20D0*rpp(iteli,itelj) +c r0ij=1.55D0*rpp(iteli,itelj) + call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) + if (fcont.gt.0.0D0) then + num_conti=num_conti+1 + if (num_conti.gt.maxconts) then + write (iout,*) 'WARNING - max. # of contacts exceeded;', + & ' will skip next contacts for this conf.' + else + jcont_hb(num_conti,i)=j +cd write (iout,*) "i",i," j",j," num_conti",num_conti, +cd " jcont_hb",jcont_hb(num_conti,i) + IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. + & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el C terms. - d_cont(num_conti,i)=rij + d_cont(num_conti,i)=rij cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij C --- Electrostatic-interaction matrix --- - a_chuj(1,1,num_conti,i)=a22 - a_chuj(1,2,num_conti,i)=a23 - a_chuj(2,1,num_conti,i)=a32 - a_chuj(2,2,num_conti,i)=a33 + a_chuj(1,1,num_conti,i)=a22 + a_chuj(1,2,num_conti,i)=a23 + a_chuj(2,1,num_conti,i)=a32 + a_chuj(2,2,num_conti,i)=a33 C --- Gradient of rij - do kkk=1,3 - grij_hb_cont(kkk,num_conti,i)=erij(kkk) - enddo - kkll=0 - do k=1,2 - do l=1,2 - kkll=kkll+1 - do m=1,3 - a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll) - a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll) - a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll) - a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll) - a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll) - enddo + 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 - ENDIF - IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN + enddo + ENDIF + IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN C Calculate contact energies - cosa4=4.0D0*cosa - wij=cosa-3.0D0*cosb*cosg - cosbg1=cosb+cosg - cosbg2=cosb-cosg -c fac3=dsqrt(-ael6i)/r0ij**3 - fac3=dsqrt(-ael6i)*r3ij -c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) - ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 - if (ees0tmp.gt.0) then - ees0pij=dsqrt(ees0tmp) - else - ees0pij=0 - endif -c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) - ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 - if (ees0tmp.gt.0) then - ees0mij=dsqrt(ees0tmp) - else - ees0mij=0 - endif -c ees0mij=0.0D0 - if (shield_mode.eq.0) then + cosa4=4.0D0*cosa + wij=cosa-3.0D0*cosb*cosg + cosbg1=cosb+cosg + cosbg2=cosb-cosg +c fac3=dsqrt(-ael6i)/r0ij**3 + fac3=dsqrt(-ael6i)*r3ij +c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) + ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 + if (ees0tmp.gt.0) then + ees0pij=dsqrt(ees0tmp) + else + ees0pij=0 + endif +c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) + ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 + if (ees0tmp.gt.0) then + ees0mij=dsqrt(ees0tmp) + else + ees0mij=0 + endif +c ees0mij=0.0D0 + if (shield_mode.eq.0) then fac_shield(i)=1.0d0 fac_shield(j)=1.0d0 - else + else ees0plist(num_conti,i)=j C fac_shield(i)=0.4d0 C fac_shield(j)=0.6d0 - endif - ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) - & *fac_shield(i)*fac_shield(j) - ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) - & *fac_shield(i)*fac_shield(j) + endif + ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) + & *fac_shield(i)*fac_shield(j)*sss1 + ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) + & *fac_shield(i)*fac_shield(j)*sss1 C Diagnostics. Comment out or remove after debugging! c ees0p(num_conti,i)=0.5D0*fac3*ees0pij @@ -2343,24 +2550,24 @@ C End diagnostics. c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont C Angular derivatives of the contact function - ees0pij1=fac3/ees0pij - ees0mij1=fac3/ees0mij - fac3p=-3.0D0*fac3*rrmij - ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) - ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) -c ees0mij1=0.0D0 - ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) - ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) - ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) - ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) - ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) - ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) - ecosap=ecosa1+ecosa2 - ecosbp=ecosb1+ecosb2 - ecosgp=ecosg1+ecosg2 - ecosam=ecosa1-ecosa2 - ecosbm=ecosb1-ecosb2 - ecosgm=ecosg1-ecosg2 + ees0pij1=fac3/ees0pij + ees0mij1=fac3/ees0mij + fac3p=-3.0D0*fac3*rrmij + ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) + ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) +c ees0mij1=0.0D0 + ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) + ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) + ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) + ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) + ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) + ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) + ecosap=ecosa1+ecosa2 + ecosbp=ecosb1+ecosb2 + ecosgp=ecosg1+ecosg2 + ecosam=ecosa1-ecosa2 + ecosbm=ecosb1-ecosb2 + ecosgm=ecosg1-ecosg2 C Diagnostics c ecosap=ecosa1 c ecosbp=ecosb1 @@ -2369,84 +2576,91 @@ c ecosam=0.0D0 c ecosbm=0.0D0 c ecosgm=0.0D0 C End diagnostics - facont_hb(num_conti,i)=fcont - fprimcont=fprimcont/rij + facont_hb(num_conti,i)=fcont + fprimcont=fprimcont/rij cd facont_hb(num_conti,i)=1.0D0 C Following line is for diagnostics. cd fprimcont=0.0D0 - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo - do k=1,3 - gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) - gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) - enddo - gggp(1)=gggp(1)+ees0pijp*xj - gggp(2)=gggp(2)+ees0pijp*yj - gggp(3)=gggp(3)+ees0pijp*zj - gggm(1)=gggm(1)+ees0mijp*xj - gggm(2)=gggm(2)+ees0mijp*yj - gggm(3)=gggm(3)+ees0mijp*zj + 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 + & +ees0p(num_conti,i)/sss1*rmij*xj*sssgrad1 + gggp(2)=gggp(2)+ees0pijp*yj + & +ees0p(num_conti,i)/sss1*rmij*yj*sssgrad1 + gggp(3)=gggp(3)+ees0pijp*zj + & +ees0p(num_conti,i)/sss1*rmij*zj*sssgrad1 + gggm(1)=gggm(1)+ees0mijp*xj + & +ees0m(num_conti,i)/sss1*rmij*xj*sssgrad1 + gggm(2)=gggm(2)+ees0mijp*yj + & +ees0m(num_conti,i)/sss1*rmij*yj*sssgrad1 + gggm(3)=gggm(3)+ees0mijp*zj + & +ees0m(num_conti,i)/sss1*rmij*zj*sssgrad1 C Derivatives due to the contact function - gacont_hbr(1,num_conti,i)=fprimcont*xj - gacont_hbr(2,num_conti,i)=fprimcont*yj - gacont_hbr(3,num_conti,i)=fprimcont*zj - do k=1,3 + gacont_hbr(1,num_conti,i)=fprimcont*xj + gacont_hbr(2,num_conti,i)=fprimcont*yj + gacont_hbr(3,num_conti,i)=fprimcont*zj + do k=1,3 c c 10/24/08 cgrad and ! comments indicate the parts of the code removed c following the change of gradient-summation algorithm. c cgrad ghalfp=0.5D0*gggp(k) cgrad ghalfm=0.5D0*gggm(k) - gacontp_hb1(k,num_conti,i)=!ghalfp - & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - & *fac_shield(i)*fac_shield(j) + 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) + & *sss1*fac_shield(i)*fac_shield(j) - 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) - & *fac_shield(i)*fac_shield(j) + 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) + & *sss1*fac_shield(i)*fac_shield(j) - gacontp_hb3(k,num_conti,i)=gggp(k) - & *fac_shield(i)*fac_shield(j) + gacontp_hb3(k,num_conti,i)=gggp(k) + & *sss1*fac_shield(i)*fac_shield(j) - 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) - & *fac_shield(i)*fac_shield(j) + 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) + & *sss1*fac_shield(i)*fac_shield(j) - 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) - & *fac_shield(i)*fac_shield(j) + 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) + & *sss1*fac_shield(i)*fac_shield(j) - gacontm_hb3(k,num_conti,i)=gggm(k) - & *fac_shield(i)*fac_shield(j) + gacontm_hb3(k,num_conti,i)=gggm(k) + & *sss1*fac_shield(i)*fac_shield(j) - 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 + ENDIF ! wcorr + endif ! num_conti.le.maxconts + endif ! fcont.gt.0 + endif ! j.gt.i+1 +#endif + 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 - 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 + enddo + endif + endif c t_eelecij=t_eelecij+MPI_Wtime()-time00 return end @@ -2455,7 +2669,7 @@ C----------------------------------------------------------------------- C C Compute Evdwpp C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.IOUNITS' @@ -2465,11 +2679,12 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' - dimension ggg(3) + include "COMMON.SPLITELE" + double precision ggg(3) integer xshift,yshift,zshift c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions #ifdef MOMENT @@ -2478,6 +2693,14 @@ c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions double precision scal_el /0.5d0/ #endif c write (iout,*) "evdwpp_short" + integer i,j,k,iteli,itelj,num_conti,ind,isubchap + double precision dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb + double precision xj,yj,zj,rij,rrmij,r3ij,r6ij,evdw1, + & dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, + & dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw + double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp, + & dist_temp, dist_init,sss_grad + double precision sscale,sscagrad evdw1=0.0D0 C print *,"WCHODZE" c write (iout,*) "iatel_s_vdw",iatel_s_vdw, @@ -2494,12 +2717,12 @@ c call flush(iout) xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi - xmedi=mod(xmedi,boxxsize) - if (xmedi.lt.0.0d0) xmedi=xmedi+boxxsize - ymedi=mod(ymedi,boxysize) - if (ymedi.lt.0.0d0) ymedi=ymedi+boxysize - zmedi=mod(zmedi,boxzsize) - if (zmedi.lt.0.0d0) zmedi=zmedi+boxzsize + xmedi=mod(xmedi,boxxsize) + if (xmedi.lt.0.0d0) xmedi=xmedi+boxxsize + ymedi=mod(ymedi,boxysize) + if (ymedi.lt.0.0d0) ymedi=ymedi+boxysize + zmedi=mod(zmedi,boxzsize) + if (zmedi.lt.0.0d0) zmedi=zmedi+boxzsize num_conti=0 c write (iout,*) 'i',i,' ielstart',ielstart_vdw(i), c & ' ielend',ielend_vdw(i) @@ -2527,44 +2750,44 @@ c call flush(iout) if (yj.lt.0) yj=yj+boxysize zj=mod(zj,boxzsize) if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - isubchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - isubchap=1 - endif - enddo - enddo - enddo - if (isubchap.eq.1) then - xj=xj_temp-xmedi - yj=yj_temp-ymedi - zj=zj_temp-zmedi - else - xj=xj_safe-xmedi - yj=yj_safe-ymedi - zj=zj_safe-zmedi - endif + dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + isubchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + isubchap=1 + endif + enddo + enddo + enddo + if (isubchap.eq.1) then + xj=xj_temp-xmedi + yj=yj_temp-ymedi + zj=zj_temp-zmedi + else + xj=xj_safe-xmedi + yj=yj_safe-ymedi + zj=zj_safe-zmedi + endif rij=xj*xj+yj*yj+zj*zj rrmij=1.0D0/rij rij=dsqrt(rij) c sss=sscale(rij/rpp(iteli,itelj)) c sssgrad=sscagrad(rij/rpp(iteli,itelj)) - sss=sscale(rij) - sssgrad=sscagrad(rij) + sss=sscale(rij/rpp(iteli,itelj),r_cut_respa) + sssgrad=sscagrad(rij/rpp(iteli,itelj),r_cut_respa) if (sss.gt.0.0d0) then rmij=1.0D0/rij r3ij=rrmij*rmij @@ -2584,9 +2807,9 @@ C C Calculate contributions to the Cartesian gradient. C facvdw=-6*rrmij*(ev1+evdwij)*sss - ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj/rpp(iteli,itelj) - ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj/rpp(iteli,itelj) - ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj/rpp(iteli,itelj) + ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj/rpp(iteli,itelj) + ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj/rpp(iteli,itelj) + ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj/rpp(iteli,itelj) C ggg(1)=facvdw*xj C ggg(2)=facvdw*yj C ggg(3)=facvdw*zj @@ -2617,10 +2840,18 @@ C include 'COMMON.FFIELD' include 'COMMON.IOUNITS' include 'COMMON.CONTROL' + include "COMMON.SPLITELE" logical lprint_short common /shortcheck/ lprint_short - dimension ggg(3) + double precision ggg(3) integer xshift,yshift,zshift + integer i,iint,j,k,iteli,itypj,subchap + double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1, + & fac,e1,e2,rij + double precision evdw2,evdw2_14,evdwij + double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp, + & dist_temp, dist_init + double precision sscale,sscagrad if (energy_dec) write (iout,*) "escp_long:",r_cut,rlamb evdw2=0.0D0 evdw2_14=0.0d0 @@ -2635,16 +2866,17 @@ c & ' iatscp_e=',iatscp_e 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)) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize + xi=mod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=mod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=mod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize + do iint=1,nscp_gr(i) do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle C Uncomment following three lines for SC-p interactions c xj=c(1,nres+j)-xi @@ -2662,14 +2894,14 @@ c corrected by AL zj=mod(zj,boxzsize) if (zj.lt.0) zj=zj+boxzsize c end correction - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 xj=xj_safe+xshift*boxxsize yj=yj_safe+yshift*boxysize zj=zj_safe+zshift*boxzsize @@ -2681,23 +2913,27 @@ c end correction zj_temp=zj subchap=1 endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - sssgrad=sscagrad(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) + sss1=sscale(1.0d0/(dsqrt(rrij)),r_cut_int) + if (sss1.eq.0) cycle + sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)),r_cut_respa) + sssgrad= + & sscagrad(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)),r_cut_respa) + sssgrad1=sscagrad(1.0d0/dsqrt(rrij),r_cut_int) if (energy_dec) write (iout,*) "rrij",1.0d0/dsqrt(rrij), & " rscp",rscp(itypj,iteli)," subchap",subchap," sss",sss if (sss.lt.1.0d0) then @@ -2707,18 +2943,19 @@ c end correction if (iabs(j-i) .le. 2) then e1=scal14*e1 e2=scal14*e2 - evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss) + evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss1 endif evdwij=e1+e2 - evdw2=evdw2+evdwij*(1.0d0-sss) + evdw2=evdw2+evdwij*(1.0d0-sss)*sss1 if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') & 'evdw2',i,j,sss,evdwij C C Calculate contributions to the gradient in the virtual-bond and SC vectors. C - fac=-(evdwij+e1)*rrij*(1.0d0-sss) - fac=fac-(evdwij)*sssgrad*dsqrt(rrij)/rscp(itypj,iteli) + fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss1 + fac=fac+evdwij*dsqrt(rrij)*(-sssgrad/rscp(itypj,iteli) + & +sssgrad1) ggg(1)=xj*fac ggg(2)=yj*fac ggg(3)=zj*fac @@ -2762,7 +2999,7 @@ C This subroutine calculates the excluded-volume interaction energy between C peptide-group centers and side chains and its gradient in virtual-bond and C side-chain vectors. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -2773,29 +3010,37 @@ C include 'COMMON.FFIELD' include 'COMMON.IOUNITS' include 'COMMON.CONTROL' + include "COMMON.SPLITELE" integer xshift,yshift,zshift logical lprint_short common /shortcheck/ lprint_short - dimension ggg(3) + integer i,iint,j,k,iteli,itypj,subchap + double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1, + & fac,e1,e2,rij + double precision evdw2,evdw2_14,evdwij + double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp, + & dist_temp, dist_init + double precision ggg(3) + double precision sscale,sscagrad evdw2=0.0D0 evdw2_14=0.0d0 cd print '(a)','Enter ESCP' c if (lprint_short) c & write (iout,*) 'ESCP_SHORT iatscp_s=',iatscp_s, c & ' iatscp_e=',iatscp_e - if (energy_dec) write (iout,*) "escp_short:",r_cut,rlamb + if (energy_dec) write (iout,*) "escp_short:",r_cut_int,rlamb 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)) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize + xi=mod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=mod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=mod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize c if (lprint_short) c & write (iout,*) "i",i," itype",itype(i),itype(i+1), @@ -2803,7 +3048,7 @@ c & " nscp_gr",nscp_gr(i) do iint=1,nscp_gr(i) do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) + itypj=iabs(itype(j)) c if (lprint_short) c & write (iout,*) "j",j," itypj",itypj if (itypj.eq.ntyp1) cycle @@ -2823,18 +3068,18 @@ c corrected by AL zj=mod(zj,boxzsize) if (zj.lt.0) zj=zj+boxzsize c end correction - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 c if (lprint_short) then c write (iout,*) i,j,xi,yi,zi,xj,yj,zj c write (iout,*) "dist_init",dsqrt(dist_init) c endif - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 xj=xj_safe+xshift*boxxsize yj=yj_safe+yshift*boxysize zj=zj_safe+zshift*boxzsize @@ -2846,24 +3091,25 @@ c endif zj_temp=zj subchap=1 endif - enddo - enddo - enddo + enddo + enddo + enddo c if (lprint_short) write (iout,*) "dist_temp",dsqrt(dist_temp) - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif rrij=1.0D0/(xj*xj+yj*yj+zj*zj) c sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) c sssgrad=sscagrad(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - sss=sscale(1.0d0/(dsqrt(rrij))) - sssgrad=sscagrad(1.0d0/(dsqrt(rrij))) + sss=sscale(1.0d0/(dsqrt(rrij*rscp(itypj,iteli))),r_cut_respa) + sssgrad=sscagrad(1.0d0/(dsqrt(rrij*rscp(itypj,iteli))), + & r_cut_respa) if (energy_dec) write (iout,*) "rrij",1.0d0/dsqrt(rrij), & " rscp",rscp(itypj,iteli)," subchap",subchap," sss",sss c if (lprint_short) write (iout,*) "rij",1.0/dsqrt(rrij), diff --git a/source/unres/src_MD-M-SAXS/energy_p_new_barrier.F b/source/unres/src_MD-M-SAXS/energy_p_new_barrier.F index b61d1e4..ce803bc 100644 --- a/source/unres/src_MD-M-SAXS/energy_p_new_barrier.F +++ b/source/unres/src_MD-M-SAXS/energy_p_new_barrier.F @@ -1,5 +1,5 @@ subroutine etotal(energia) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifndef ISNAN external proc_proc @@ -10,6 +10,8 @@ cMS$ATTRIBUTES C :: proc_proc #ifdef MPI include "mpif.h" double precision weights_(n_ene) + double precision time00 + integer ierror,ierr #endif include 'COMMON.SETUP' include 'COMMON.IOUNITS' @@ -21,11 +23,19 @@ cMS$ATTRIBUTES C :: proc_proc include 'COMMON.SBRIDGE' include 'COMMON.CHAIN' include 'COMMON.VAR' - include 'COMMON.MD' +c include 'COMMON.MD' + include 'COMMON.QRESTR' include 'COMMON.CONTROL' include 'COMMON.TIME1' include 'COMMON.SPLITELE' include 'COMMON.TORCNSTR' + include 'COMMON.SAXS' + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6, + & eliptran,Eafmforce,Etube, + & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet + integer n_corr,n_corr1 #ifdef MPI c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, c & " nfgtasks",nfgtasks @@ -58,6 +68,10 @@ C FG slaves as WEIGHTS array. weights_(21)=wsccor weights_(22)=wtube weights_(26)=wsaxs + weights_(28)=wdfa_dist + weights_(29)=wdfa_tor + weights_(30)=wdfa_nei + weights_(31)=wdfa_beta C FG Master broadcasts the WEIGHTS_ array call MPI_Bcast(weights_(1),n_ene, & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) @@ -86,11 +100,21 @@ C FG slaves receive the WEIGHTS array wsccor=weights(21) wtube=weights(22) wsaxs=weights(26) + wdfa_dist=weights_(28) + wdfa_tor=weights_(29) + wdfa_nei=weights_(30) + wdfa_beta=weights_(31) endif time_Bcast=time_Bcast+MPI_Wtime()-time00 time_Bcastw=time_Bcastw+MPI_Wtime()-time00 c call chainbuild_cart endif +#ifndef DFA + edfadis=0.0d0 + edfator=0.0d0 + edfanei=0.0d0 + edfabet=0.0d0 +#endif c print *,'Processor',myrank,' calling etotal ipot=',ipot c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct #else @@ -129,6 +153,32 @@ C C Calculate electrostatic (H-bonding) energy of the main chain. C 107 continue +#ifdef DFA +C BARTEK for dfa test! + if (wdfa_dist.gt.0) then + call edfad(edfadis) + else + edfadis=0 + endif +c print*, 'edfad is finished!', edfadis + if (wdfa_tor.gt.0) then + call edfat(edfator) + else + edfator=0 + endif +c print*, 'edfat is finished!', edfator + if (wdfa_nei.gt.0) then + call edfan(edfanei) + else + edfanei=0 + endif +c print*, 'edfan is finished!', edfanei + if (wdfa_beta.gt.0) then + call edfab(edfabet) + else + edfabet=0 + endif +#endif cmc cmc Sep-06: egb takes care of dynamic ss bonds too cmc @@ -249,6 +299,14 @@ C energy function edihcnstr=0.0d0 if (ndih_constr.gt.0) call etor_constr(edihcnstr) c print *,"Processor",myrank," computed Utor" + if (constr_homology.ge.1) then + call e_modeller(ehomology_constr) +c print *,'iset=',iset,'me=',me,ehomology_constr, +c & 'Processor',fg_rank,' CG group',kolor, +c & ' absolute rank',MyRank + else + ehomology_constr=0.0d0 + endif C C 6/23/01 Calculate double-torsional energy C @@ -266,6 +324,7 @@ C else esccor=0.0d0 endif +#ifdef FOURBODY C print *,"PRZED MULIt" c print *,"Processor",myrank," computed Usccorr" C @@ -294,6 +353,7 @@ c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr, c & n_corr1 c call flush(iout) endif +#endif c print *,"Processor",myrank," computed Ucorr" c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode if (nsaxs.gt.0 .and. saxs_mode.eq.0) then @@ -389,6 +449,11 @@ C energia(24)=ethetacnstr energia(25)=Etube energia(26)=Esaxs_constr + energia(27)=ehomology_constr + energia(28)=edfadis + energia(29)=edfator + energia(30)=edfanei + energia(31)=edfabet c write (iout,*) "esaxs_constr",energia(26) c Here are the energies showed per procesor if the are more processors c per molecule then we sum it up in sum_energy subroutine @@ -404,7 +469,7 @@ c print *," Processor",myrank," left SUM_ENERGY" end c------------------------------------------------------------------------------- subroutine sum_energy(energia,reduce) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifndef ISNAN external proc_proc @@ -414,6 +479,8 @@ cMS$ATTRIBUTES C :: proc_proc #endif #ifdef MPI include "mpif.h" + integer ierr + double precision time00 #endif include 'COMMON.SETUP' include 'COMMON.IOUNITS' @@ -427,6 +494,13 @@ cMS$ATTRIBUTES C :: proc_proc include 'COMMON.CONTROL' include 'COMMON.TIME1' logical reduce + integer i + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6, + & eliptran,Eafmforce,Etube, + & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet + double precision Uconst,etot #ifdef MPI if (nfgtasks.gt.1 .and. reduce) then #ifdef DEBUG @@ -487,6 +561,11 @@ cMS$ATTRIBUTES C :: proc_proc ethetacnstr=energia(24) Etube=energia(25) esaxs_constr=energia(26) + ehomology_constr=energia(27) + edfadis=energia(28) + edfator=energia(29) + edfanei=energia(30) + edfabet=energia(31) #ifdef SPLITELE etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 & +wang*ebe+wtor*etors+wscloc*escloc @@ -494,7 +573,9 @@ cMS$ATTRIBUTES C :: proc_proc & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce - & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr + & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet #else etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) & +wang*ebe+wtor*etors+wscloc*escloc @@ -503,7 +584,9 @@ cMS$ATTRIBUTES C :: proc_proc & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran & +Eafmforce - & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr + & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet #endif energia(0)=etot c detecting NaNQ @@ -529,7 +612,7 @@ c detecting NaNQ end c------------------------------------------------------------------------------- subroutine sum_gradient - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifndef ISNAN external proc_proc @@ -539,6 +622,8 @@ cMS$ATTRIBUTES C :: proc_proc #endif #ifdef MPI include 'mpif.h' + integer ierror,ierr + double precision time00,time01 #endif double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres), & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres) @@ -555,6 +640,16 @@ cMS$ATTRIBUTES C :: proc_proc include 'COMMON.TIME1' include 'COMMON.MAXGRAD' include 'COMMON.SCCOR' +c include 'COMMON.MD' + include 'COMMON.QRESTR' + integer i,j,k + double precision scalar + double precision 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,gsccorrc_norm,gscloc_norm,gvdwx_norm, + &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm, + &gsclocx_norm #ifdef TIMING time01=MPI_Wtime() #endif @@ -623,16 +718,13 @@ c enddo & wstrain*ghpbc(j,i) & +wliptran*gliptranc(j,i) & +gradafm(j,i) - & +welec*gshieldc(j,i) - & +wcorr*gshieldc_ec(j,i) - & +wturn3*gshieldc_t3(j,i) - & +wturn4*gshieldc_t4(j,i) - & +wel_loc*gshieldc_ll(j,i) + & +welec*gshieldc(j,i) + & +wcorr*gshieldc_ec(j,i) + & +wturn3*gshieldc_t3(j,i) + & +wturn4*gshieldc_t4(j,i) + & +wel_loc*gshieldc_ll(j,i) & +wtube*gg_tube(j,i) & +wsaxs*gsaxsc(j,i) - - - enddo enddo #else @@ -656,12 +748,18 @@ c enddo & +wel_loc*gshieldc_ll(j,i) & +wtube*gg_tube(j,i) & +wsaxs*gsaxsc(j,i) - - - enddo enddo #endif + do i=1,nct + do j=1,3 + gradbufc(j,i)=gradbufc(j,i)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(j,i) + enddo + enddo #ifdef DEBUG write (iout,*) "gradc from gradbufc" do i=1,nres @@ -875,6 +973,14 @@ C print *,gradafm(1,13),"AFM" enddo enddo + if (constr_homology.gt.0) then + do i=1,nct + do j=1,3 + gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i) + gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i) + enddo + enddo + endif #ifdef DEBUG write (iout,*) "gradc gradx gloc after adding" do i=1,nres @@ -984,13 +1090,13 @@ c gradcorr5_max=0.0d0 gradcorr6_max=0.0d0 gcorr6_turn_max=0.0d0 - gsccorc_max=0.0d0 + gsccorrc_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 + gsccorrx_max=0.0d0 gsclocx_max=0.0d0 do i=1,nct gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) @@ -1022,13 +1128,13 @@ c 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 + if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_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 + gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) + if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_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))) @@ -1054,9 +1160,9 @@ c 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, + & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max, & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max + & gsccorrx_max,gsclocx_max close(istat) if (gvdwc_max.gt.1.0d4) then write (iout,*) "gvdwc gvdwx gradb gradbx" @@ -1083,12 +1189,18 @@ c end c------------------------------------------------------------------------------- subroutine rescale_weights(t_bath) - implicit real*8 (a-h,o-z) + implicit none +#ifdef MPI + include 'mpif.h' + integer ierror +#endif include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.SBRIDGE' include 'COMMON.CONTROL' + double precision t_bath + double precision facT,facT2,facT3,facT4,facT5 double precision kfac /2.4d0/ double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/ c facT=temp0/t_bath @@ -1148,13 +1260,19 @@ c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb end C------------------------------------------------------------------------ subroutine enerprint(energia) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.SBRIDGE' - include 'COMMON.MD' + include 'COMMON.QRESTR' double precision energia(0:n_ene) + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6, + & eello_turn6, + & eliptran,Eafmforce,Etube, + & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot etot=energia(0) evdw=energia(1) evdw2=energia(2) @@ -1188,83 +1306,125 @@ C------------------------------------------------------------------------ ethetacnstr=energia(24) etube=energia(25) esaxs=energia(26) + ehomology_constr=energia(27) +C Bartek + edfadis = energia(28) + edfator = energia(29) + edfanei = energia(30) + edfabet = energia(31) #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, +#ifdef FOURBODY & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr, - & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, - & etube,wtube,esaxs,wsaxs, + & ecorr5,wcorr5,ecorr6,wcorr6, +#endif + & eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4, +#ifdef FOURBODY + & eello_turn6,wturn6, +#endif + & esccor,wsccor,edihcnstr, + & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce, + & etube,wtube,esaxs,wsaxs,ehomology_constr, + & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, + & edfabet,wdfa_beta, & etot 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & '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, + & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ + & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.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)'/ +#ifdef FOURBODY + & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif + & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY + & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST=',1pE16.6,' WEIGHT=',1pD16.6' (umbrella restraints)'/ - & 'ELT= ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/ + & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/ + & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/ & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/ - & 'ETUBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (tube confinment)'/ - & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/ + & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/ + & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ + & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/ & 'ETOT= ',1pE16.6,' (total)') #else write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, & estr,wbond,ebe,wang, & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, +#ifdef FOURBODY & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr, + & ecorr5,wcorr5,ecorr6,wcorr6, +#endif + & eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4, +#ifdef FOURBODY + & eello_turn6,wturn6, +#endif + & esccor,wsccor,edihcnstr, & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, - & etube,wtube,esaxs,wsaxs, + & etube,wtube,esaxs,wsaxs,ehomology_constr, + & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, + & edfabet,wdfa_beta, & etot 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, + & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, & ' (SS bridges & dist. restr.)'/ - & '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)'/ +#ifdef FOURBODY + & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif + & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY + & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST=',1pE16.6,' WEIGHT=',1pD16.6' (umbrella restraints)'/ - & 'ELT= ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/ + & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/ + & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/ & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/ - & 'ETUBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (tube confinment)'/ - & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/ + & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/ + & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ + & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/ & 'ETOT= ',1pE16.6,' (total)') #endif return @@ -1275,7 +1435,8 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the LJ potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none + double precision accur include 'DIMENSIONS' parameter (accur=1.0d-10) include 'COMMON.GEO' @@ -1288,8 +1449,18 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' + include 'COMMON.SPLITELE' +#ifdef FOURBODY include 'COMMON.CONTACTS' - dimension gg(3) + include 'COMMON.CONTMAT' +#endif + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,num_conti,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & sigij,r0ij,rcut,sqrij,sss1,sssgrad1 + double precision fcont,fprimcont + double precision sscale,sscagrad c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e @@ -1316,6 +1487,11 @@ cd & 'iend=',iend(i,iint) C Change 12/1/95 to calculate four-body interactions rij=xj*xj+yj*yj+zj*zj rrij=1.0D0/rij + sqrij=dsqrt(rij) + sss1=sscale(sqrij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(sqrij,r_cut_int) + c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj eps0ij=eps(itypi,itypj) fac=rrij**expon2 @@ -1329,11 +1505,12 @@ cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj), cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+evdwij + evdw=evdw+sss1*evdwij C C Calculate the components of the gradient in DC and X C fac=-rrij*(e1+evdwij) + & +evdwij*sssgrad1/sqrij gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -1349,6 +1526,7 @@ cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) cgrad enddo cgrad enddo C +#ifdef FOURBODY C 12/1/95, revised on 5/20/97 C C Calculate the contact function. The ith column of the array JCONT will @@ -1404,10 +1582,13 @@ cd write (iout,'(2i3,3f10.5)') cd & i,j,(gacont(kk,num_conti,i),kk=1,3) endif endif +#endif enddo ! j enddo ! iint C Change 12/1/95 +#ifdef FOURBODY num_cont(i)=num_conti +#endif enddo ! i do i=1,nct do j=1,3 @@ -1432,7 +1613,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the LJK potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -1442,8 +1623,14 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.NAMES' - dimension gg(3) + include 'COMMON.SPLITELE' + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1 logical scheck + double precision sscale,sscagrad c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e @@ -1468,6 +1655,9 @@ C e_augm=augm(itypi,itypj)*fac_augm r_inv_ij=dsqrt(rrij) rij=1.0D0/r_inv_ij + sss1=sscale(rij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(rij,r_cut_int) r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) fac=r_shift_inv**expon C have you changed here? @@ -1486,6 +1676,7 @@ C C Calculate the components of the gradient in DC and X C fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) + & +evdwij*sssgrad1*r_inv_ij gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -1517,7 +1708,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Berne-Pechukas potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -1528,7 +1719,14 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' + include 'COMMON.SPLITELE' + integer icall common /srutu/ icall + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi, + & sss1,sssgrad1 + double precision sscale,sscagrad c double precision rrsave(maxdim) logical lprn evdw=0.0D0 @@ -1594,6 +1792,9 @@ cd else cd rrij=rrsave(ind) cd endif rij=dsqrt(rrij) + sss1=sscale(1.0d0/rij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(1.0d0/rij,r_cut_int) C Calculate the angle-dependent terms of energy & contributions to derivatives. call sc_angular C Calculate whole angle-dependent part of epsilon and contributions @@ -1622,13 +1823,14 @@ C Calculate gradient components. fac=-expon*(e1+evdwij) sigder=fac/sigsq fac=rrij*fac + & +evdwij*sssgrad1*rij C Calculate radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac C Calculate the angular part of the gradient and sum add the contributions C to the appropriate components of the Cartesian gradient. - call sc_grad + call sc_grad_scale(sss1) enddo ! j enddo ! iint enddo ! i @@ -1641,7 +1843,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Gay-Berne potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -1656,8 +1858,14 @@ C include 'COMMON.SPLITELE' include 'COMMON.SBRIDGE' logical lprn - integer xshift,yshift,zshift - + integer xshift,yshift,zshift,subchap + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi + double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij, + & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip + double precision dist,sscale,sscagrad,sscagradlip,sscalelip evdw=0.0D0 ccccc energy_dec=.false. C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon @@ -1920,12 +2128,11 @@ c write (iout,*) "j",j," dc_norm", c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) - sss=sscale((1.0d0/rij)/sigma(itypi,itypj)) - sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj)) - + sss=sscale(1.0d0/rij,r_cut_int) c write (iout,'(a7,4f8.3)') c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb - if (sss.gt.0.0d0) then + if (sss.eq.0.0d0) cycle + sssgrad=sscagrad(1.0d0/rij,r_cut_int) C Calculate angle-dependent terms of energy and contributions to their C derivatives. call sc_angular @@ -1972,8 +2179,8 @@ c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 & evdwij endif - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij + if (energy_dec) write (iout,'(a,2i5,3f10.5)') + & 'r sss evdw',i,j,rij,sss,evdwij C Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 @@ -1982,13 +2189,13 @@ C Calculate gradient components. fac=rij*fac c print '(2i4,6f8.4)',i,j,sss,sssgrad* c & evdwij,fac,sigma(itypi,itypj),expon - fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij + fac=fac+evdwij*sssgrad*rij c fac=0.0d0 C Calculate the radial part of the gradient gg_lipi(3)=eps1*(eps2rt*eps2rt) - &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip* - & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj)) - &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))) + & *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip* + & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj)) + & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))) gg_lipj(3)=ssgradlipj*gg_lipi(3) gg_lipi(3)=gg_lipi(3)*ssgradlipi C gg_lipi(3)=0.0d0 @@ -1997,8 +2204,7 @@ C gg_lipj(3)=0.0d0 gg(2)=yj*fac gg(3)=zj*fac C Calculate angular part of the gradient. - call sc_grad - endif + call sc_grad_scale(sss) ENDIF ! dyn_ss enddo ! j enddo ! iint @@ -2016,7 +2222,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Gay-Berne-Vorobjev potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -2027,9 +2233,19 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' - integer xshift,yshift,zshift + include 'COMMON.SPLITELE' + integer xshift,yshift,zshift,subchap + integer icall common /srutu/ icall logical lprn + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij, + & xi,yi,zi,fac_augm,e_augm + double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij, + & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip,sssgrad1 + double precision dist,sscale,sscagrad,sscagradlip,sscalelip evdw=0.0D0 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 @@ -2188,6 +2404,9 @@ C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj dzj=dc_norm(3,nres+j) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) + sss=sscale(1.0d0/rij,r_cut_int) + if (sss.eq.0.0d0) cycle + sssgrad=sscagrad(1.0d0/rij,r_cut_int) C Calculate angle-dependent terms of energy and contributions to their C derivatives. call sc_angular @@ -2228,13 +2447,13 @@ C Calculate gradient components. fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac-2*expon*rrij*e_augm - fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij + fac=fac+(evdwij+e_augm)*sssgrad*rij C Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac C Calculate angular part of the gradient. - call sc_grad + call sc_grad_scale(sss) enddo ! j enddo ! iint enddo ! i @@ -2383,7 +2602,7 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' dimension gg(3) cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct evdw=0.0D0 @@ -2457,7 +2676,7 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -2538,8 +2757,8 @@ c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) zj=zj_safe-zmedi endif rij=xj*xj+yj*yj+zj*zj - sss=sscale(sqrt(rij)) - sssgrad=sscagrad(sqrt(rij)) + sss=sscale(sqrt(rij),r_cut_int) + sssgrad=sscagrad(sqrt(rij),r_cut_int) if (rij.lt.r0ijsq) then evdw1ij=0.25d0*(rij-r0ijsq)**2 fac=rij-r0ijsq @@ -2764,90 +2983,6 @@ c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1) #endif return end -C----------------------------------------------------------------------------- - subroutine check_vecgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.VECTORS' - dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres) - dimension uyt(3,maxres),uzt(3,maxres) - dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3) - double precision delta /1.0d-7/ - call vec_and_deriv -cd do i=1,nres -crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i) -crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i) -crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i) -cd write(iout,'(2i5,2(3f10.5,5x))') i,1, -cd & (dc_norm(if90,i),if90=1,3) -cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3) -cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3) -cd write(iout,'(a)') -cd enddo - do i=1,nres - do j=1,2 - do k=1,3 - do l=1,3 - uygradt(l,k,j,i)=uygrad(l,k,j,i) - uzgradt(l,k,j,i)=uzgrad(l,k,j,i) - enddo - enddo - enddo - enddo - call vec_and_deriv - do i=1,nres - do j=1,3 - uyt(j,i)=uy(j,i) - uzt(j,i)=uz(j,i) - enddo - enddo - do i=1,nres -cd write (iout,*) 'i=',i - do k=1,3 - erij(k)=dc_norm(k,i) - enddo - do j=1,3 - do k=1,3 - dc_norm(k,i)=erij(k) - enddo - dc_norm(j,i)=dc_norm(j,i)+delta -c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))) -c do k=1,3 -c dc_norm(k,i)=dc_norm(k,i)/fac -c enddo -c write (iout,*) (dc_norm(k,i),k=1,3) -c write (iout,*) (erij(k),k=1,3) - call vec_and_deriv - do k=1,3 - uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta - uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta - uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta - uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta - enddo -c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') -c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3), -c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3) - enddo - do k=1,3 - dc_norm(k,i)=erij(k) - enddo -cd do k=1,3 -cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') -cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3), -cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3) -cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') -cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3), -cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3) -cd write (iout,'(a)') -cd enddo - enddo - return - end C-------------------------------------------------------------------------- subroutine set_matrices implicit real*8 (a-h,o-z) @@ -2865,7 +3000,7 @@ C-------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -2881,18 +3016,26 @@ c write(iout,*) "itype2loc",itype2loc #else do i=3,nres+1 #endif - if (i.gt. nnt+2 .and. i.lt.nct+2) then + ii=ireschain(i-2) +c write (iout,*) "i",i,i-2," ii",ii + if (ii.eq.0) cycle + innt=chain_border(1,ii) + inct=chain_border(2,ii) +c write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct +c if (i.gt. nnt+2 .and. i.lt.nct+2) then + if (i.gt. innt+2 .and. i.lt.inct+2) then iti = itype2loc(itype(i-2)) else iti=nloctyp endif c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then - if (i.gt. nnt+1 .and. i.lt.nct+1) then + if (i.gt. innt+1 .and. i.lt.inct+1) then iti1 = itype2loc(itype(i-1)) else iti1=nloctyp endif -c write(iout,*),i +c write(iout,*),"i",i,i-2," iti",itype(i-2),iti, +c & " iti1",itype(i-1),iti1 #ifdef NEWCORR cost1=dcos(theta(i-1)) sint1=dsin(theta(i-1)) @@ -2958,7 +3101,8 @@ c b2tilde(2,i-2)=-b2(2,i-2) write (iout,*) 'theta=', theta(i-1) #endif #else - if (i.gt. nnt+2 .and. i.lt.nct+2) then + if (i.gt. innt+2 .and. i.lt.inct+2) then +c if (i.gt. nnt+2 .and. i.lt.nct+2) then iti = itype2loc(itype(i-2)) else iti=nloctyp @@ -3003,12 +3147,14 @@ c write(iout,*) 'b2=',(b2(k,i-2),k=1,2) #endif enddo + mu=0.0d0 #ifdef PARMAT do i=ivec_start+2,ivec_end+2 #else do i=3,nres+1 #endif - if (i .lt. nres+1) then +c if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle + if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then sin1=dsin(phi(i)) cos1=dcos(phi(i)) sintab(i-2)=sin1 @@ -3045,7 +3191,7 @@ c Ug2(2,1,i-2)=0.0d0 Ug2(2,2,i-2)=0.0d0 endif - if (i .gt. 3 .and. i .lt. nres+1) then + if (i .gt. 3) then obrot_der(1,i-2)=-sin1 obrot_der(2,i-2)= cos1 Ugder(1,1,i-2)= sin1 @@ -3075,7 +3221,8 @@ c Ug2der(2,2,i-2)=0.0d0 endif c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then - if (i.gt. nnt+2 .and. i.lt.nct+2) then +c if (i.gt. nnt+2 .and. i.lt.nct+2) then + if (i.gt.nnt+2 .and.i.lt.nct+2) then iti = itype2loc(itype(i-2)) else iti=nloctyp @@ -3104,6 +3251,7 @@ c & EE(1,2,iti),EE(2,2,i) c write(iout,*) "Macierz EUG", c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2), c & eug(2,2,i-2) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2)) @@ -3112,6 +3260,7 @@ c & eug(2,2,i-2) call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2)) call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2)) endif +#endif else do k=1,2 Ub2(k,i-2)=0.0d0 @@ -3156,6 +3305,7 @@ c mu(k,i-2)=Ub2(k,i-2) cd write (iout,*) 'mu1',mu1(:,i-2) cd write (iout,*) 'mu2',mu2(:,i-2) cd write (iout,*) 'mu',i-2,mu(:,i-2) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) & then call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2)) @@ -3174,7 +3324,9 @@ C Vectors and matrices dependent on a single virtual-bond dihedral. call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2)) call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2)) endif +#endif enddo +#ifdef FOURBODY C Matrices dependent on two consecutive virtual-bond dihedrals. C The order of matrices is from left to right. if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) @@ -3191,6 +3343,7 @@ c do i=max0(ivec_start,2),ivec_end call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i)) enddo endif +#endif #if defined(MPI) && defined(PARMAT) #ifdef DEBUG c if (fg_rank.eq.0) then @@ -3259,6 +3412,7 @@ c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1) call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1), & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0), & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1), @@ -3334,6 +3488,7 @@ c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1) & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0), & MPI_MAT2,FG_COMM1,IERR) endif +#endif #else c Passes matrix info through the ring isend=fg_rank1 @@ -3378,6 +3533,7 @@ c call flush(iout) & iprev,6600+irecv,FG_COMM,status,IERR) c write (iout,*) "Gather PRECOMP12" c call flush(iout) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1, @@ -3397,6 +3553,7 @@ c call flush(iout) & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1, & MPI_PRECOMP23(lenrecv), & iprev,9900+irecv,FG_COMM,status,IERR) +#endif c write (iout,*) "Gather PRECOMP23" c call flush(iout) endif @@ -3449,7 +3606,7 @@ cd enddo cd enddo return end -C-------------------------------------------------------------------------- +C----------------------------------------------------------------------------- subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) C C This subroutine calculates the average interaction energy and its gradient @@ -3472,7 +3629,11 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -3545,9 +3706,11 @@ cd enddo eello_turn3=0.0d0 eello_turn4=0.0d0 ind=0 +#ifdef FOURBODY do i=1,nres num_cont_hb(i)=0 enddo +#endif cd print '(a)','Enter EELEC' cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e do i=1,nres @@ -3597,7 +3760,9 @@ c end if num_conti=0 call eelecij(i,i+2,ees,evdw1,eel_loc) if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo do i=iturn4_start,iturn4_end if (i.lt.1) cycle @@ -3653,12 +3818,16 @@ c endif zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif c write(iout,*) "JESTEM W PETLI" call eelecij(i,i+3,ees,evdw1,eel_loc) if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) & call eturn4(i,eello_turn4) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i C Loop over all neighbouring boxes C do xshift=-1,1 @@ -3725,7 +3894,9 @@ c go to 166 c endif c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif C I TU KURWA do j=ielstart(i),ielend(i) C do j=16,17 @@ -3741,7 +3912,9 @@ c & .or.itype(j-1).eq.ntyp1 &) cycle call eelecij(i,j,ees,evdw1,eel_loc) enddo ! j +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i C enddo ! zshift C enddo ! yshift @@ -3759,7 +3932,7 @@ cd print *,"Processor",fg_rank," t_eelecij",t_eelecij end C------------------------------------------------------------------------------- subroutine eelecij(i,j,ees,evdw1,eel_loc) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -3772,21 +3945,44 @@ C------------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' include 'COMMON.TIME1' include 'COMMON.SPLITELE' include 'COMMON.SHIELD' - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), + double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4), & gmuij2(4),gmuji2(4) + double precision dxi,dyi,dzi + double precision dx_normi,dy_normi,dz_normi,aux + integer j1,j2,lll,num_conti common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, & num_conti,j1,j2 + integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield + double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp + double precision ees,evdw1,eel_loc,aaa,bbb,ael3i + double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj, + & rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4, + & evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa, + & ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der, + & a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij, + & ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp, + & ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp, + & ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield + double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji + double precision dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,xmedi,ymedi,zmedi + double precision sscale,sscagrad,scalar + c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions #ifdef MOMENT double precision scal_el /1.0d0/ @@ -3890,8 +4086,9 @@ C yj=yj-ymedi C zj=zj-zmedi rij=xj*xj+yj*yj+zj*zj - sss=sscale(sqrt(rij)) - sssgrad=sscagrad(sqrt(rij)) + sss=sscale(sqrt(rij),r_cut_int) + if (sss.eq.0.0d0) return + sssgrad=sscagrad(sqrt(rij),r_cut_int) c if (sss.gt.0.0d0) then rrmij=1.0D0/rij rij=dsqrt(rij) @@ -3926,7 +4123,7 @@ C fac_shield(j)=0.6 fac_shield(i)=1.0 fac_shield(j)=1.0 eesij=(el1+el2) - ees=ees+eesij + ees=ees+eesij*sss endif evdw1=evdw1+evdwij*sss cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') @@ -3935,11 +4132,10 @@ cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, cd & xmedi,ymedi,zmedi,xj,yj,zj if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)') - &'evdw1',i,j,evdwij - &,iteli,itelj,aaa,evdw1,sss - write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij, - &fac_shield(i),fac_shield(j) + write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)') + & 'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij + write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij, + & fac_shield(i),fac_shield(j) endif C @@ -3956,6 +4152,7 @@ C * * Radial derivatives. First process both termini of the fragment (i,j) * + aux=facel+sssgrad*eesij ggg(1)=facel*xj ggg(2)=facel*yj ggg(3)=facel*zj @@ -3992,10 +4189,10 @@ C endif iresshield=shield_list(ilist,j) do k=1,3 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) - & *2.0 + & *2.0*sss gshieldx(k,iresshield)=gshieldx(k,iresshield)+ & rlocshield - & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 + & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j) @@ -4018,13 +4215,13 @@ C endif do k=1,3 gshieldc(k,i)=gshieldc(k,i)+ - & grad_shield(k,i)*eesij/fac_shield(i)*2.0 + & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss gshieldc(k,j)=gshieldc(k,j)+ - & grad_shield(k,j)*eesij/fac_shield(j)*2.0 + & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss gshieldc(k,i-1)=gshieldc(k,i-1)+ - & grad_shield(k,i)*eesij/fac_shield(i)*2.0 + & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss gshieldc(k,j-1)=gshieldc(k,j-1)+ - & grad_shield(k,j)*eesij/fac_shield(j)*2.0 + & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss enddo endif @@ -4055,15 +4252,10 @@ cgrad do l=1,3 cgrad gelc(l,k)=gelc(l,k)+ggg(l) cgrad enddo cgrad enddo - if (sss.gt.0.0) then - ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj - ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj - ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj - else - ggg(1)=0.0 - ggg(2)=0.0 - ggg(3)=0.0 - endif + facvdw=facvdw+sssgrad*rmij*evdwij + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj c do k=1,3 c ghalf=0.5D0*ggg(k) c gvdwpp(k,i)=gvdwpp(k,i)+ghalf @@ -4084,10 +4276,11 @@ cgrad enddo cgrad enddo #else C MARYSIA - facvdw=(ev1+evdwij)*sss + facvdw=(ev1+evdwij) facel=(el1+eesij) fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) + fac=-3*rrmij*(facvdw+facvdw+facel)*sss + & +(evdwij+eesij)*sssgrad*rrmij erij(1)=xj*rmij erij(2)=yj*rmij erij(3)=zj*rmij @@ -4163,11 +4356,11 @@ C print *,"before22", gelc_long(1,i), gelc_long(1,j) 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)) + & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss & *fac_shield(i)**2*fac_shield(j)**2 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)) + & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss & *fac_shield(i)**2*fac_shield(j)**2 gelc_long(k,j)=gelc_long(k,j)+ggg(k) gelc_long(k,i)=gelc_long(k,i)-ggg(k) @@ -4403,7 +4596,7 @@ C fac_shield(i)=0.4 C fac_shield(j)=0.6 endif eel_loc_ij=eel_loc_ij - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') c & 'eelloc',i,j,eel_loc_ij C Now derivative over eel_loc @@ -4415,11 +4608,11 @@ C print *,i,j iresshield=shield_list(ilist,i) do k=1,3 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij - & /fac_shield(i) + & /fac_shield(i)*sss C & *2.0 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ & rlocshield - & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i) + & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)*sss gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1) & +rlocshield enddo @@ -4428,11 +4621,11 @@ C & *2.0 iresshield=shield_list(ilist,j) do k=1,3 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij - & /fac_shield(j) + & /fac_shield(j)*sss C & *2.0 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ & rlocshield - & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j) + & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)*sss gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1) & +rlocshield @@ -4441,13 +4634,13 @@ C & *2.0 do k=1,3 gshieldc_ll(k,i)=gshieldc_ll(k,i)+ - & grad_shield(k,i)*eel_loc_ij/fac_shield(i) + & grad_shield(k,i)*eel_loc_ij/fac_shield(i)*sss gshieldc_ll(k,j)=gshieldc_ll(k,j)+ - & grad_shield(k,j)*eel_loc_ij/fac_shield(j) + & grad_shield(k,j)*eel_loc_ij/fac_shield(j)*sss gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ - & grad_shield(k,i)*eel_loc_ij/fac_shield(i) + & grad_shield(k,i)*eel_loc_ij/fac_shield(i)*sss gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ - & grad_shield(k,j)*eel_loc_ij/fac_shield(j) + & grad_shield(k,j)*eel_loc_ij/fac_shield(j)*sss enddo endif @@ -4461,7 +4654,7 @@ C Calculate patrial derivative for theta angle & +a23*gmuij1(2) & +a32*gmuij1(3) & +a33*gmuij1(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss c write(iout,*) "derivative over thatai" c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3), c & a33*gmuij1(4) @@ -4477,7 +4670,7 @@ c & a33*gmuij2(4) & +a33*gmuij2(4) gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ & geel_loc_ij*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss c Derivative over j residue geel_loc_ji=a22*gmuji1(1) @@ -4490,7 +4683,7 @@ c & a33*gmuji1(4) gloc(nphi+j,icg)=gloc(nphi+j,icg)+ & geel_loc_ji*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss geel_loc_ji= & +a22*gmuji2(1) @@ -4502,7 +4695,7 @@ c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3), c & a33*gmuji2(4) gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+ & geel_loc_ji*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss #endif cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij @@ -4518,17 +4711,17 @@ C Partial derivatives in virtual-bond dihedral angles gamma & 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)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss 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)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) do l=1,3 ggg(l)=(agg(l,1)*muij(1)+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) cgrad ghalf=0.5d0*ggg(l) @@ -4544,24 +4737,25 @@ C Remaining derivatives of eello do l=1,3 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss 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)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss 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)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss 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)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss enddo ENDIF C Change 12/26/95 to calculate four-body contributions to H-bonding energy c if (j.gt.i+1 .and. num_conti.le.maxconts) then +#ifdef FOURBODY if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 & .and. num_conti.le.maxconts) then c write (iout,*) i,j," entered corr" @@ -4645,9 +4839,9 @@ C fac_shield(i)=0.4d0 C fac_shield(j)=0.6d0 endif ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss C Diagnostics. Comment out or remove after debugging! c ees0p(num_conti,i)=0.5D0*fac3*ees0pij c ees0m(num_conti,i)=0.5D0*fac3*ees0mij @@ -4696,11 +4890,17 @@ cd fprimcont=0.0D0 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) enddo gggp(1)=gggp(1)+ees0pijp*xj + & +ees0p(num_conti,i)/sss*rmij*xj*sssgrad gggp(2)=gggp(2)+ees0pijp*yj + & +ees0p(num_conti,i)/sss*rmij*yj*sssgrad gggp(3)=gggp(3)+ees0pijp*zj + & +ees0p(num_conti,i)/sss*rmij*zj*sssgrad gggm(1)=gggm(1)+ees0mijp*xj + & +ees0m(num_conti,i)/sss*rmij*xj*sssgrad gggm(2)=gggm(2)+ees0mijp*yj + & +ees0m(num_conti,i)/sss*rmij*yj*sssgrad gggm(3)=gggm(3)+ees0mijp*zj + & +ees0m(num_conti,i)/sss*rmij*zj*sssgrad C Derivatives due to the contact function gacont_hbr(1,num_conti,i)=fprimcont*xj gacont_hbr(2,num_conti,i)=fprimcont*yj @@ -4715,28 +4915,28 @@ cgrad ghalfm=0.5D0*gggm(k) gacontp_hb1(k,num_conti,i)=!ghalfp & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss 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) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontp_hb3(k,num_conti,i)=gggp(k) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss 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) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss 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) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontm_hb3(k,num_conti,i)=gggm(k) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss enddo C Diagnostics. Comment out or remove after debugging! @@ -4752,6 +4952,7 @@ cdiag enddo endif ! num_conti.le.maxconts endif ! fcont.gt.0 endif ! j.gt.i+1 +#endif if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then do k=1,4 do l=1,3 @@ -4784,7 +4985,7 @@ C Third- and fourth-order contributions from turns include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -4967,7 +5168,7 @@ C Third- and fourth-order contributions from turns include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -5516,7 +5717,7 @@ C This subroutine calculates the excluded-volume interaction energy between C peptide-group centers and side chains and its gradient in virtual-bond and C side-chain vectors. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -5529,7 +5730,14 @@ C include 'COMMON.CONTROL' include 'COMMON.SPLITELE' integer xshift,yshift,zshift - dimension ggg(3) + double precision ggg(3) + integer i,iint,j,k,iteli,itypj,subchap + double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1, + & fac,e1,e2,rij + double precision evdw2,evdw2_14,evdwij + double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp, + & dist_temp, dist_init + double precision sscale,sscagrad evdw2=0.0D0 evdw2_14=0.0d0 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla' @@ -5538,7 +5746,7 @@ cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e C do xshift=-1,1 C do yshift=-1,1 C do zshift=-1,1 - if (energy_dec) write (iout,*) "escp:",r_cut,rlamb + if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb do i=iatscp_s,iatscp_e if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle iteli=itel(i) @@ -5660,11 +5868,11 @@ CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE c print *,xj,yj,zj,'polozenie j' rrij=1.0D0/(xj*xj+yj*yj+zj*zj) c print *,rrij - sss=sscale(1.0d0/(dsqrt(rrij))) + sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int) c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz' c if (sss.eq.0) print *,'czasem jest OK' if (sss.le.0.0d0) cycle - sssgrad=sscagrad(1.0d0/(dsqrt(rrij))) + sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int) fac=rrij**expon2 e1=fac*fac*aad(itypj,iteli) e2=fac*bad(itypj,iteli) @@ -5675,8 +5883,9 @@ c if (sss.eq.0) print *,'czasem jest OK' endif evdwij=e1+e2 evdw2=evdw2+evdwij*sss - 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,3f7.3,2i3,3e11.3)') + & 'evdw2',i,j,1.0d0/dsqrt(rrij),sss, + & evdwij,iteli,itypj,fac,aad(itypj,iteli), & bad(itypj,iteli) C C Calculate contributions to the gradient in the virtual-bond and SC vectors. @@ -6091,6 +6300,12 @@ c estr=0.0d0 estr1=0.0d0 do i=ibondp_start,ibondp_end +c 3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are +c used +#ifdef FIVEDIAG + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle + diff = vbld(i)-vbldp0 +#else if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) c do j=1,3 @@ -6101,15 +6316,16 @@ c if (energy_dec) write(iout,*) c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax) c else C Checking if it involves dummy (NH3+ or COO-) group - if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then C YES vbldpDUM is the equlibrium length of spring for Dummy atom - diff = vbld(i)-vbldpDUM - if (energy_dec) write(iout,*) "dum_bond",i,diff - else -C NO vbldp0 is the equlibrium lenght of spring for peptide group - diff = vbld(i)-vbldp0 - endif - if (energy_dec) write (iout,'(a7,i5,4f7.3)') + diff = vbld(i)-vbldpDUM + if (energy_dec) write(iout,*) "dum_bond",i,diff + else +C NO vbldp0 is the equlibrium length of spring for peptide group + diff = vbld(i)-vbldp0 + endif +#endif + 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 @@ -7061,7 +7277,8 @@ c & sumene4, c & dscp1,dscp2,sumene c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) escloc = escloc + sumene -c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i) + if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it, + & " escloc",sumene,escloc,it,itype(i) c & ,zz,xx,yy c#define DEBUG #ifdef DEBUG @@ -7443,6 +7660,20 @@ c------------------------------------------------------------------------------ return end c---------------------------------------------------------------------------- +c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA + subroutine e_modeller(ehomology_constr) + ehomology_constr=0.0d0 + write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!" + return + end +C !!!!!!!! NIE CZYTANE !!!!!!!!!!! + +c------------------------------------------------------------------------------ + subroutine etor_d(etors_d) + etors_d=0.0d0 + return + end +c---------------------------------------------------------------------------- #else subroutine etor(etors) implicit real*8 (a-h,o-z) @@ -7813,6 +8044,637 @@ c do i=1,ndih_constr return end c---------------------------------------------------------------------------- +c MODELLER restraint function + subroutine e_modeller(ehomology_constr) + implicit none + include 'DIMENSIONS' + + double precision ehomology_constr + integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l + integer katy, odleglosci, test7 + real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template) + real*8 Eval,Erot + real*8 distance(max_template),distancek(max_template), + & min_odl,godl(max_template),dih_diff(max_template) + +c +c FP - 30/10/2014 Temporary specifications for homology restraints +c + double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta, + & sgtheta + double precision, dimension (maxres) :: guscdiff,usc_diff + double precision, dimension (max_template) :: + & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3, + & theta_diff + double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih, + & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz, + & betai,sum_sgodl,dij + double precision dist,pinorm +c + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' +c include 'COMMON.MD' + include 'COMMON.CONTROL' + include 'COMMON.HOMOLOGY' + include 'COMMON.QRESTR' +c +c From subroutine Econstr_back +c + include 'COMMON.NAMES' + include 'COMMON.TIME1' +c + + + do i=1,max_template + distancek(i)=9999999.9 + enddo + + + odleg=0.0d0 + +c Pseudo-energy and gradient from homology restraints (MODELLER-like +c function) +C AL 5/2/14 - Introduce list of restraints +c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d +#ifdef DEBUG + write(iout,*) "------- dist restrs start -------" +#endif + do ii = link_start_homo,link_end_homo + i = ires_homo(ii) + j = jres_homo(ii) + dij=dist(i,j) +c write (iout,*) "dij(",i,j,") =",dij + nexl=0 + do k=1,constr_homology +c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii) + if(.not.l_homo(k,ii)) then + nexl=nexl+1 + cycle + endif + distance(k)=odl(k,ii)-dij +c write (iout,*) "distance(",k,") =",distance(k) +c +c For Gaussian-type Urestr +c + distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument +c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii) +c write (iout,*) "distancek(",k,") =",distancek(k) +c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii) +c +c For Lorentzian-type Urestr +c + if (waga_dist.lt.0.0d0) then + sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii)) + distancek(k)=distance(k)**2/(sigma_odlir(k,ii)* + & (distance(k)**2+sigma_odlir(k,ii)**2)) + endif + enddo + +c min_odl=minval(distancek) + do kk=1,constr_homology + if(l_homo(kk,ii)) then + min_odl=distancek(kk) + exit + endif + enddo + do kk=1,constr_homology + if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl) + & min_odl=distancek(kk) + enddo + +c write (iout,* )"min_odl",min_odl +#ifdef DEBUG + write (iout,*) "ij dij",i,j,dij + write (iout,*) "distance",(distance(k),k=1,constr_homology) + write (iout,*) "distancek",(distancek(k),k=1,constr_homology) + write (iout,* )"min_odl",min_odl +#endif +#ifdef OLDRESTR + odleg2=0.0d0 +#else + if (waga_dist.ge.0.0d0) then + odleg2=nexl + else + odleg2=0.0d0 + endif +#endif + do k=1,constr_homology +c Nie wiem po co to liczycie jeszcze raz! +c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/ +c & (2*(sigma_odl(i,j,k))**2)) + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + godl(k)=dexp(-distancek(k)+min_odl) + odleg2=odleg2+godl(k) +c +c For Lorentzian-type Urestr +c + else + odleg2=odleg2+distancek(k) + endif + +ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3, +ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=", +ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1), +ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k) + + enddo +c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents +c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps +#ifdef DEBUG + write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents + write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps +#endif + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + odleg=odleg-dLOG(odleg2/constr_homology)+min_odl +c +c For Lorentzian-type Urestr +c + else + odleg=odleg+odleg2/constr_homology + endif +c +c write (iout,*) "odleg",odleg ! sum of -ln-s +c Gradient +c +c For Gaussian-type Urestr +c + if (waga_dist.ge.0.0d0) sum_godl=odleg2 + sum_sgodl=0.0d0 + do k=1,constr_homology +c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) +c & *waga_dist)+min_odl +c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist +c + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c For Gaussian-type Urestr +c + sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd +c +c For Lorentzian-type Urestr +c + else + sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ + & sigma_odlir(k,ii)**2)**2) + endif + sum_sgodl=sum_sgodl+sgodl + +c sgodl2=sgodl2+sgodl +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1" +c write(iout,*) "constr_homology=",constr_homology +c write(iout,*) i, j, k, "TEST K" + enddo + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + grad_odl3=waga_homology(iset)*waga_dist + & *sum_sgodl/(sum_godl*dij) +c +c For Lorentzian-type Urestr +c + else +c Original grad expr modified by analogy w Gaussian-type Urestr grad +c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl + grad_odl3=-waga_homology(iset)*waga_dist* + & sum_sgodl/(constr_homology*dij) + endif +c +c grad_odl3=sum_sgodl/(sum_godl*dij) + + +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2" +c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2), +c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) + +ccc write(iout,*) godl, sgodl, grad_odl3 + +c grad_odl=grad_odl+grad_odl3 + + do jik=1,3 + ggodl=grad_odl3*(c(jik,i)-c(jik,j)) +ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1)) +ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) + ghpbc(jik,i)=ghpbc(jik,i)+ggodl + ghpbc(jik,j)=ghpbc(jik,j)-ggodl +ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) +c if (i.eq.25.and.j.eq.27) then +c write(iout,*) "jik",jik,"i",i,"j",j +c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl +c write(iout,*) "grad_odl3",grad_odl3 +c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j) +c write(iout,*) "ggodl",ggodl +c write(iout,*) "ghpbc(",jik,i,")", +c & ghpbc(jik,i),"ghpbc(",jik,j,")", +c & ghpbc(jik,j) +c endif + enddo +ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=", +ccc & dLOG(odleg2),"-odleg=", -odleg + + enddo ! ii-loop for dist +#ifdef DEBUG + write(iout,*) "------- dist restrs end -------" +c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or. +c & waga_d.eq.1.0d0) call sum_gradient +#endif +c Pseudo-energy and gradient from dihedral-angle restraints from +c homology templates +c write (iout,*) "End of distance loop" +c call flush(iout) + kat=0.0d0 +c write (iout,*) idihconstr_start_homo,idihconstr_end_homo +#ifdef DEBUG + write(iout,*) "------- dih restrs start -------" + do i=idihconstr_start_homo,idihconstr_end_homo + write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg) + enddo +#endif + do i=idihconstr_start_homo,idihconstr_end_homo + kat2=0.0d0 +c betai=beta(i,i+1,i+2,i+3) + betai = phi(i) +c write (iout,*) "betai =",betai + do k=1,constr_homology + dih_diff(k)=pinorm(dih(k,i)-betai) +cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k) +cd & ,sigma_dih(k,i) +c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)= +c & -(6.28318-dih_diff(i,k)) +c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)= +c & 6.28318+dih_diff(i,k) +#ifdef OLD_DIHED + kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument +#else + kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument +#endif +c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i) + gdih(k)=dexp(kat3) + kat2=kat2+gdih(k) +c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3) +c write(*,*)"" + enddo +c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps +c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps +#ifdef DEBUG + write (iout,*) "i",i," betai",betai," kat2",kat2 + write (iout,*) "gdih",(gdih(k),k=1,constr_homology) +#endif + if (kat2.le.1.0d-14) cycle + kat=kat-dLOG(kat2/constr_homology) +c write (iout,*) "kat",kat ! sum of -ln-s + +ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=", +ccc & dLOG(kat2), "-kat=", -kat + +c ---------------------------------------------------------------------- +c Gradient +c ---------------------------------------------------------------------- + + sum_gdih=kat2 + sum_sgdih=0.0d0 + do k=1,constr_homology +#ifdef OLD_DIHED + sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd +#else + sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd +#endif +c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle + sum_sgdih=sum_sgdih+sgdih + enddo +c grad_dih3=sum_sgdih/sum_gdih + grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih + +c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3 +ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) + gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3 +c if (i.eq.25) then +c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg) +c endif +ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) + + enddo ! i-loop for dih +#ifdef DEBUG + write(iout,*) "------- dih restrs end -------" +#endif + +c Pseudo-energy and gradient for theta angle restraints from +c homology templates +c FP 01/15 - inserted from econstr_local_test.F, loop structure +c adapted + +c +c For constr_homology reference structures (FP) +c +c Uconst_back_tot=0.0d0 + Eval=0.0d0 + Erot=0.0d0 +c Econstr_back legacy + do i=1,nres +c do i=ithet_start,ithet_end + dutheta(i)=0.0d0 +c enddo +c do i=loc_start,loc_end + do j=1,3 + duscdiff(j,i)=0.0d0 + duscdiffx(j,i)=0.0d0 + enddo + enddo +c +c do iref=1,nref +c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end +c write (iout,*) "waga_theta",waga_theta + if (waga_theta.gt.0.0d0) then +#ifdef DEBUG + write (iout,*) "usampl",usampl + write(iout,*) "------- theta restrs start -------" +c do i=ithet_start,ithet_end +c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg) +c enddo +#endif +c write (iout,*) "maxres",maxres,"nres",nres + + do i=ithet_start,ithet_end +c +c do i=1,nfrag_back +c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) +c +c Deviation of theta angles wrt constr_homology ref structures +c + utheta_i=0.0d0 ! argument of Gaussian for single k + gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures +c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop +c over residues in a fragment +c write (iout,*) "theta(",i,")=",theta(i) + do k=1,constr_homology +c +c dtheta_i=theta(j)-thetaref(j,iref) +c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing + theta_diff(k)=thetatpl(k,i)-theta(i) +cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k) +cd & ,sigma_theta(k,i) + +c + utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument +c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta? + gtheta(k)=dexp(utheta_i) ! + min_utheta_i? + gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk) +c Gradient for single Gaussian restraint in subr Econstr_back +c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) +c + enddo +c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps +c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps + +c +c Gradient for multiple Gaussian restraint + sum_gtheta=gutheta_i + sum_sgtheta=0.0d0 + do k=1,constr_homology +c New generalized expr for multiple Gaussian from Econstr_back + sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd +c +c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form? + sum_sgtheta=sum_sgtheta+sgtheta ! cum variable + enddo +c Final value of gradient using same var as in Econstr_back + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg) + & +sum_sgtheta/sum_gtheta*waga_theta + & *waga_homology(iset) +c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta +c & *waga_homology(iset) +c dutheta(i)=sum_sgtheta/sum_gtheta +c +c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight + Eval=Eval-dLOG(gutheta_i/constr_homology) +c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s +c Uconst_back=Uconst_back+utheta(i) + enddo ! (i-loop for theta) +#ifdef DEBUG + write(iout,*) "------- theta restrs end -------" +#endif + endif +c +c Deviation of local SC geometry +c +c Separation of two i-loops (instructed by AL - 11/3/2014) +c +c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end +c write (iout,*) "waga_d",waga_d + +#ifdef DEBUG + write(iout,*) "------- SC restrs start -------" + write (iout,*) "Initial duscdiff,duscdiffx" + do i=loc_start,loc_end + write (iout,*) i,(duscdiff(jik,i),jik=1,3), + & (duscdiffx(jik,i),jik=1,3) + enddo +#endif + do i=loc_start,loc_end + usc_diff_i=0.0d0 ! argument of Gaussian for single k + guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures +c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy +c write(iout,*) "xxtab, yytab, zztab" +c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i) + do k=1,constr_homology +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c Original sign inverted for calc of gradients (s. Econstr_back) + dyy=-yytpl(k,i)+yytab(i) ! ibid y + dzz=-zztpl(k,i)+zztab(i) ! ibid z +c write(iout,*) "dxx, dyy, dzz" +cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i) +c + usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument +c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d? +c uscdiffk(k)=usc_diff(i) + guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff +c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i), +c & " guscdiff2",guscdiff2(k) + guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk) +c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), +c & xxref(j),yyref(j),zzref(j) + enddo +c +c Gradient +c +c Generalized expression for multiple Gaussian acc to that for a single +c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014) +c +c Original implementation +c sum_guscdiff=guscdiff(i) +c +c sum_sguscdiff=0.0d0 +c do k=1,constr_homology +c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d? +c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff +c sum_sguscdiff=sum_sguscdiff+sguscdiff +c enddo +c +c Implementation of new expressions for gradient (Jan. 2015) +c +c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !? + do k=1,constr_homology +c +c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong +c before. Now the drivatives should be correct +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c Original sign inverted for calc of gradients (s. Econstr_back) + dyy=-yytpl(k,i)+yytab(i) ! ibid y + dzz=-zztpl(k,i)+zztab(i) ! ibid z +c +c New implementation +c + sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong! + & sigma_d(k,i) ! for the grad wrt r' +c sum_sguscdiff=sum_sguscdiff+sum_guscdiff +c +c +c New implementation + sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff + do jik=1,3 + duscdiff(jik,i-1)=duscdiff(jik,i-1)+ + & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+ + & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i) + duscdiff(jik,i)=duscdiff(jik,i)+ + & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+ + & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i) + duscdiffx(jik,i)=duscdiffx(jik,i)+ + & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+ + & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i) +c +#ifdef DEBUG + write(iout,*) "jik",jik,"i",i + write(iout,*) "dxx, dyy, dzz" + write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz + write(iout,*) "guscdiff2(",k,")",guscdiff2(k) +c write(iout,*) "sum_sguscdiff",sum_sguscdiff +cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i) +c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i) +c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i) +c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i) +c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i) +c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i) +c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i) +c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i) +c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i) +c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1) +c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i) +c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i) +c endif +#endif + enddo + enddo +c +c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required? +c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ? +c +c write (iout,*) i," uscdiff",uscdiff(i) +c +c Put together deviations from local geometry + +c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ +c & wfrag_back(3,i,iset)*uscdiff(i) + Erot=Erot-dLOG(guscdiff(i)/constr_homology) +c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s +c Uconst_back=Uconst_back+usc_diff(i) +c +c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?) +c +c New implment: multiplied by sum_sguscdiff +c + + enddo ! (i-loop for dscdiff) + +c endif + +#ifdef DEBUG + write(iout,*) "------- SC restrs end -------" + write (iout,*) "------ After SC loop in e_modeller ------" + do i=loc_start,loc_end + write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3) + write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3) + enddo + if (waga_theta.eq.1.0d0) then + write (iout,*) "in e_modeller after SC restr end: dutheta" + do i=ithet_start,ithet_end + write (iout,*) i,dutheta(i) + enddo + endif + if (waga_d.eq.1.0d0) then + write (iout,*) "e_modeller after SC loop: duscdiff/x" + do i=1,nres + write (iout,*) i,(duscdiff(j,i),j=1,3) + write (iout,*) i,(duscdiffx(j,i),j=1,3) + enddo + endif +#endif + +c Total energy from homology restraints +#ifdef DEBUG + write (iout,*) "odleg",odleg," kat",kat +#endif +c +c Addition of energy of theta angle and SC local geom over constr_homologs ref strs +c +c ehomology_constr=odleg+kat +c +c For Lorentzian-type Urestr +c + + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + ehomology_constr=(waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) +c write (iout,*) "ehomology_constr=",ehomology_constr + else +c +c For Lorentzian-type Urestr +c + ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) +c write (iout,*) "ehomology_constr=",ehomology_constr + endif +#ifdef DEBUG + write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat, + & "Eval",waga_theta,eval, + & "Erot",waga_d,Erot + write (iout,*) "ehomology_constr",ehomology_constr +#endif + return +c +c FP 01/15 end +c + 748 format(a8,f12.3,a6,f12.3,a7,f12.3) + 747 format(a12,i4,i4,i4,f8.3,f8.3) + 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3) + 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3) + 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X, + & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3) + end +c---------------------------------------------------------------------------- C The rigorous attempt to derive energy function subroutine ebend_kcc(etheta) @@ -7981,6 +8843,7 @@ c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp return end +#ifdef FOURBODY c---------------------------------------------------------------------------- subroutine multibody(ecorr) C This subroutine calculates multi-body contributions to energy following @@ -7993,6 +8856,8 @@ C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision gx(3),gx1(3) logical lprn @@ -8047,6 +8912,8 @@ c------------------------------------------------------------------------------ include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.SHIELD' double precision gx(3),gx1(3) logical lprn @@ -8101,6 +8968,8 @@ C This subroutine calculates multi-body contributions to hydrogen-bonding include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.CONTROL' include 'COMMON.LOCAL' double precision gx(3),gx1(3),time00 @@ -8394,6 +9263,8 @@ c------------------------------------------------------------------------------ parameter (max_cont=maxconts) parameter (max_dim=26) include "COMMON.CONTACTS" + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision zapas(max_dim,maxconts,max_fg_procs), & zapas_recv(max_dim,maxconts,max_fg_procs) common /przechowalnia/ zapas @@ -8465,6 +9336,8 @@ C This subroutine calculates multi-body contributions to hydrogen-bonding include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.CHAIN' include 'COMMON.CONTROL' include 'COMMON.SHIELD' @@ -8835,6 +9708,8 @@ c------------------------------------------------------------------------------ parameter (max_cont=maxconts) parameter (max_dim=70) include "COMMON.CONTACTS" + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision zapas(max_dim,maxconts,max_fg_procs), & zapas_recv(max_dim,maxconts,max_fg_procs) common /przechowalnia/ zapas @@ -8888,6 +9763,8 @@ c------------------------------------------------------------------------------ include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.SHIELD' include 'COMMON.CONTROL' double precision gx(3),gx1(3) @@ -9063,6 +9940,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -9128,6 +10007,8 @@ C include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -9514,6 +10395,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -9635,6 +10518,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10039,6 +10924,8 @@ c-------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10179,6 +11066,8 @@ c-------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10283,6 +11172,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10468,6 +11359,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10583,6 +11476,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10827,6 +11722,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -11145,8 +12042,8 @@ cd write (2,*) 'ekont',ekont cd write (2,*) 'eel_turn6',ekont*eel_turn6 return end - C----------------------------------------------------------------------------- +#endif double precision function scalar(u,v) !DIR$ INLINEALWAYS scalar #ifndef OSF @@ -12220,8 +13117,18 @@ c---------------------------------------------------------------------------- include 'COMMON.INTERACT' include 'COMMON.VAR' include 'COMMON.IOUNITS' - include 'COMMON.MD' +c include 'COMMON.MD' +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif include 'COMMON.CONTROL' + include 'COMMON.SAXS' include 'COMMON.NAMES' include 'COMMON.TIME1' include 'COMMON.FFIELD' @@ -12530,8 +13437,18 @@ c---------------------------------------------------------------------------- include 'COMMON.INTERACT' include 'COMMON.VAR' include 'COMMON.IOUNITS' - include 'COMMON.MD' +c include 'COMMON.MD' +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif include 'COMMON.CONTROL' + include 'COMMON.SAXS' include 'COMMON.NAMES' include 'COMMON.TIME1' include 'COMMON.FFIELD' diff --git a/source/wham/src-HCD/CMakeLists.txt b/source/wham/src-HCD/CMakeLists.txt new file mode 100644 index 0000000..678a85f --- /dev/null +++ b/source/wham/src-HCD/CMakeLists.txt @@ -0,0 +1,329 @@ +# +# CMake project file for WHAM multichain version +# + +enable_language (Fortran) + +#================================ +# Set source file lists +#================================ +set(UNRES_WHAM_M_SRC0 + wham_multparm.F + bxread.F + xread.F + cxread.F + enecalc1.F + energy_p_new.F + initialize_p.F + molread_zs.F + openunits.F + readrtns.F + arcos.f + cartder.f + cartprint.f + chainbuild.F + geomout.F + gnmr1.f + icant.f + intcor.f + int_from_cart.f + make_ensemble1.F + matmult.f + misc.f + mygetenv.F + parmread.F + permut.F + pinorm.f + printmat.f + rescode.f + setup_var.f + slices.F + store_parm.F + timing.F + wham_calc1.F + readrtns_compar.F + read_dist_constr.F + readpdb.f + fitsq.f + contact.f + elecont.f + contfunc.f + cont_frag.f + conf_compar.F + match_contact.f + angnorm.f + odlodc.f + promienie.f + qwolynes.f + read_ref_str.F + rmscalc.f + secondary.f + proc_cont.f + define_pairs.f + mysort.f + ssMD.F +) + +set(UNRES_WHAM_M_PP_SRC + bxread.F + chainbuild.F + conf_compar.F + cxread.F + enecalc1.F + energy_p_new.F + geomout.F + initialize_p.F + make_ensemble1.F + molread_zs.F + mygetenv.F + openunits.F + parmread.F + permut.F + read_ref_str.F + read_dist_constr.F + readrtns_compar.F + readrtns.F + slices.F + store_parm.F + timing.F + wham_calc1.F + wham_multparm.F + xread.F + proc_proc.c +) + + +#================================================ +# Set comipiler flags for different sourcefiles +#================================================ +if (Fortran_COMPILER_NAME STREQUAL "ifort") + set(FFLAGS0 "-g -CB -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" ) +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + set(FFLAGS0 "-std=legacy -g -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" ) +else () + set(FFLAGS0 "-g -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" ) +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + + +#========================================= +# Add MPI compiler flags +#========================================= +if(UNRES_WITH_MPI) + set(FFLAGS0 "${FFLAGS0} -I${MPI_Fortran_INCLUDE_PATH}") +endif(UNRES_WITH_MPI) + +set_property(SOURCE ${UNRES_WHAM_M_SRC0} PROPERTY COMPILE_FLAGS ${FFLAGS0} ) + +#========================================= +# Settings for GAB force field +#========================================= +if(UNRES_MD_FF STREQUAL "GAB" ) + # set preprocesor flags + set(CPPFLAGS "PROCOR -DSPLITELE -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCCORPDB" ) + + +#========================================= +# Settings for E0LL2Y force field +#========================================= +elseif(UNRES_MD_FF STREQUAL "E0LL2Y") + # set preprocesor flags + set(CPPFLAGS "PROCOR -DSPLITELE -DSCCORPDB" ) +endif(UNRES_MD_FF STREQUAL "GAB") + +#========================================= +# Additional flags +#========================================= +set(CPPFLAGS "${CPPFLAGS} -DUNRES -DISNAN") + +#========================================= +# System specific flags +#========================================= +if(${CMAKE_SYSTEM_NAME} MATCHES "Linux") + set(CPPFLAGS "${CPPFLAGS} -DLINUX") +endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux") + +#========================================= +# Compiler specific flags +#========================================= + +if (Fortran_COMPILER_NAME STREQUAL "ifort") + # Add ifort preprocessor flags + set(CPPFLAGS "${CPPFLAGS} -DPGI") +elseif (Fortran_COMPILER_NAME STREQUAL "f95") + # Add new gfortran flags + set(CPPFLAGS "${CPPFLAGS} -DG77") +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + # Add old gfortran flags + set(CPPFLAGS "${CPPFLAGS} -DG77") +else (Fortran_COMPILER_NAME STREQUAL "ifort") + # Default preprocessor flags + set(CPPFLAGS "${CPPFLAGS} -DPGI") +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + +#========================================= +# Add MPI preprocessor flags +#========================================= +set(CPPFLAGS "${CPPFLAGS} -DMPI") + +#========================================= +# Add 64-bit specific preprocessor flags +#========================================= +if (architektura STREQUAL "64") + set(CPPFLAGS "${CPPFLAGS} -DAMD64") +endif (architektura STREQUAL "64") + +#========================================= +# Apply preprocesor flags to *.F files +#========================================= +set_property(SOURCE ${UNRES_WHAM_M_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) + + +#======================================== +# Setting binary name +#======================================== +set(UNRES_WHAM_M_BIN "wham_M_${Fortran_COMPILER_NAME}_${UNRES_MD_FF}.exe") + +#========================================= +# cinfo.f workaround for CMake +#========================================= +# get the current date +TODAY(DATE) +# generate cinfo.f + +set(CINFO "${CMAKE_CURRENT_BINARY_DIR}/cinfo.f") +FILE(WRITE ${CINFO} +"C CMake generated file + subroutine cinfo + include 'COMMON.IOUNITS' + write(iout,*)'++++ Compile info ++++' + write(iout,*)'Version ${UNRES_MAJOR}.${UNRES_MINOR} build ${UNRES_PATCH}' +") + +CINFO_FORMAT(${CINFO} "Compiled" "${DATE}" ) +CINFO_FORMAT(${CINFO} "Compiled by" "$ENV{USER}@$ENV{HOST}" ) +CINFO_FORMAT(${CINFO} "OS name:" "${CMAKE_SYSTEM_NAME}" ) +CINFO_FORMAT(${CINFO} "OS release:" "${CMAKE_SYSTEM}" ) +CINFO_FORMAT(${CINFO} "Fortran Compiler:" "${CMAKE_Fortran_COMPILER}" ) +CINFO_FORMAT(${CINFO} "MD Force field:" "${UNRES_MD_FF}" ) +CINFO_FORMAT(${CINFO} "CPPFLAGS =" "${CPPFLAGS}") + +FILE(APPEND ${CINFO} +" write(iout,*)'++++ End of compile info ++++' + return + end ") + +# set include paths +set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f PROPERTY COMPILE_FLAGS "${FFLAGS0} -I${CMAKE_CURRENT_SOURCE_DIR}" ) + +#========================================= +# Set full unres CSA sources +#========================================= +set(UNRES_WHAM_M_SRCS ${UNRES_WHAM_M_SRC0} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f proc_proc.c) + +#========================================= +# Build the binary +#========================================= +add_executable(UNRES_WHAM_M_BIN ${UNRES_WHAM_M_SRCS} ) +set_target_properties(UNRES_WHAM_M_BIN PROPERTIES OUTPUT_NAME ${UNRES_WHAM_M_BIN}) +set_property(TARGET UNRES_WHAM_M_BIN PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin ) +#add_dependencies (${UNRES_BIN} ${UNRES_XDRFLIB}) + +#========================================= +# Link libraries +#========================================= +# link MPI library (libmpich.a) +target_link_libraries( UNRES_WHAM_M_BIN ${MPI_Fortran_LIBRARIES} ) +# link libxdrf.a +target_link_libraries( UNRES_WHAM_M_BIN xdrf ) + + +#========================================= +# Install Path +#========================================= +install(TARGETS UNRES_WHAM_M_BIN DESTINATION ${CMAKE_INSTALL_PREFIX}/wham) + + +#========================================= +# TESTS +#========================================= + +#-- Copy all the data files from the test directory into the source directory +#SET(UNRES_TEST_FILES +# ala10.inp +# ) + +#FOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) +# SET (unres_test_dest "${CMAKE_CURRENT_BINARY_DIR}/${UNRES_TEST_FILE}") +# MESSAGE (STATUS " Copying ${UNRES_TEST_FILE} from ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} to ${unres_test_dest}") +# ADD_CUSTOM_COMMAND ( +# TARGET ${UNRES_BIN} +# POST_BUILD +# COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} ${unres_test_dest} +# ) +#ENDFOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) + +#========================================= +# Generate data test files +#========================================= +# test_single_ala.sh +#========================================= + +#FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh +#"#!/bin/sh +#export POT=GB +#export PREFIX=ala10 +#----------------------------------------------------------------------------- +#UNRES_BIN=./${UNRES_BIN} +#----------------------------------------------------------------------------- +#DD=${CMAKE_SOURCE_DIR}/PARAM +#export BONDPAR=$DD/bond.parm +#export THETPAR=$DD/thetaml.5parm +#export ROTPAR=$DD/scgauss.parm +#export TORPAR=$DD/torsion_631Gdp.parm +#export TORDPAR=$DD/torsion_double_631Gdp.parm +#export ELEPAR=$DD/electr_631Gdp.parm +#export SIDEPAR=$DD/sc_GB_opt.1gab_3S_qclass5no310-shan2-sc-16-10-8k +#export FOURIER=$DD/fourier_opt.parm.1igd_hc_iter3_3 +#export SCPPAR=$DD/scp.parm +#export SCCORPAR=$DD/rotcorr_AM1.parm +#export PATTERN=$DD/patterns.cart +#----------------------------------------------------------------------------- +#$UNRES_BIN +#") + +#========================================= +# ala10.inp +#========================================= + +#file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/ala10.inp +#"ala10 unblocked +#SEED=-1111333 MD ONE_LETTER rescale_mode=2 PDBOUT +#nstep=15000 ntwe=100 ntwx=1000 dt=0.1 lang=0 tbf t_bath=300 damax=1.0 & +#reset_moment=1000 reset_vel=1000 MDPDB +#WLONG=1.35279 WSCP=1.59304 WELEC=0.71534 WBOND=1.00000 WANG=1.13873 & +#WSCLOC=0.16258 WTOR=1.98599 WTORD=1.57069 WCORRH=0.42887 WCORR5=0.00000 & +#WCORR6=0.00000 WEL_LOC=0.16036 WTURN3=1.68722 WTURN4=0.66230 WTURN6=0.00000 & +#WVDWPP=0.11371 WHPB=1.00000 & +#CUTOFF=7.00000 WCORR4=0.00000 +#12 +#XAAAAAAAAAAX +# 0 +# 0 +# 90.0000 90.0000 90.0000 90.000 90.000 90.000 90.000 90.000 +# 90.0000 90.0000 +# 180.0000 180.0000 180.0000 180.000 180.000 180.000 180.000 180.000 +# 180.0000 +# 110.0000 110.0000 110.0000 100.000 110.000 100.000 110.000 110.000 +# 110.0000 110.0000 +# -120.0000 -120.0000 -120.000 -120.000 -120.000 -120.000 -120.000 -120.000 +# -120.0000 -120.0000 +#") + + +# Add tests + +#if(NOT UNRES_WITH_MPI) + +# add_test(NAME UNRES_MD_Ala10 COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh ) + +#endif(NOT UNRES_WITH_MPI) diff --git a/source/wham/src-HCD/COMMON.ALLPARM b/source/wham/src-HCD/COMMON.ALLPARM new file mode 100644 index 0000000..71d6784 --- /dev/null +++ b/source/wham/src-HCD/COMMON.ALLPARM @@ -0,0 +1,113 @@ + double precision ww_all(max_ene,max_parm), + & vbldp0_all(max_parm),akp_all(max_parm), + & vbldsc0_all(maxbondterm,ntyp,max_parm), + & aksc_all(maxbondterm,ntyp,max_parm), + & abond0_all(maxbondterm,ntyp,max_parm), + & a0thet_all(-ntyp:ntyp,max_parm), + & athet_all(2,-ntyp:ntyp,-1:1,-1:1,max_parm), + & bthet_all(2,-ntyp:ntyp,-1:1,-1:1,max_parm), + & polthet_all(0:3,-ntyp:ntyp,max_parm), + & gthet_all(3,-ntyp:ntyp,max_parm),theta0_all(-ntyp:ntyp,max_parm), + & sig0_all(-ntyp:ntyp,max_parm),sigc0_all(-ntyp:ntyp,max_parm), + & aa0thet_all(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,2,max_parm), + & aathet_all(maxtheterm,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm), + & bbthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm), + & ccthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,2,max_parm), + & ddthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,2,max_parm), + & eethet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,2,max_parm), + & ffthet_all1(maxdouble,maxdouble,maxtheterm3, + & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,max_parm), + & ggthet_all1(maxdouble,maxdouble,maxtheterm3, + & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,max_parm), + & ffthet_all2(maxdouble,maxdouble,maxtheterm3, + & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,max_parm), + & ggthet_all2(maxdouble,maxdouble,maxtheterm3, + & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,max_parm), + & dsc_all(ntyp1,max_parm),bsc_all(maxlob,ntyp,max_parm), + & censc_all(3,maxlob,-ntyp:ntyp,max_parm), + & gaussc_all(3,3,maxlob,-ntyp:ntyp,max_parm), + & dsc0_all(ntyp1,max_parm), + & sc_parmin_all(65,ntyp,max_parm), + & v0_all(-maxtor:maxtor,-maxtor:maxtor,2,max_parm), + & v1_all(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,max_parm), + & v2_all(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,max_parm), + & vlor1_all(maxlor,maxtor,maxtor,max_parm), + & vlor2_all(maxlor,maxtor,maxtor,max_parm), + & vlor3_all(maxlor,maxtor,maxtor,max_parm), + & v1c_all(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2,max_parm), + & v1s_all(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2,max_parm), + & v2c_all(maxtermd_2,maxtermd_2,-maxtor:maxtor, + & -maxtor:maxtor,-maxtor:maxtor,2,max_parm), + & v2s_all(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2,max_parm), + & b_all(5,-maxtor:maxtor,max_parm), + & ccold_all(2,2,-maxtor:maxtor,max_parm), + & ddold_all(2,2,-maxtor:maxtor,max_parm), + & eeold_all(2,2,-maxtor:maxtor,max_parm), + & bnew1_all(3,2,-maxtor:maxtor,max_parm), + & bnew2_all(3,2,-maxtor:maxtor,max_parm), + & ccnew_all(3,2,-maxtor:maxtor,max_parm), + & ddnew_all(3,2,-maxtor:maxtor,max_parm), + & eenew_all(2,2,2,-maxtor:maxtor,max_parm), + & e0new_all(2,-maxtor:maxtor,max_parm), + & app_all(2,2,max_parm),bpp_all(2,2,max_parm), + & ael6_all(2,2,max_parm),ael3_all(2,2,max_parm), + & aad_all(ntyp,2,max_parm),bad_all(ntyp,2,max_parm), + & aa_aq_all(ntyp,ntyp,max_parm),bb_aq_all(ntyp,ntyp,max_parm), + & aa_lip_all(ntyp,ntyp,max_parm),bb_lip_all(ntyp,ntyp,max_parm), + & augm_all(ntyp,ntyp,max_parm),eps_all(ntyp,ntyp,max_parm), + & epslip_all(ntyp,ntyp,max_parm), + & sigma_all(ntyp,ntyp,max_parm),r0_all(ntyp,ntyp,max_parm), + & chi_all(ntyp,ntyp,max_parm),chip_all(ntyp,max_parm), + & alp_all(ntyp,max_parm),ebr_all(max_parm),d0cm_all(max_parm), + & akcm_all(max_parm),akth_all(max_parm),akct_all(max_parm), + & v1ss_all(max_parm),v2ss_all(max_parm),v3ss_all(max_parm), + & v1sccor_all(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,max_parm), + & v2sccor_all(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,max_parm) + integer nlob_all(ntyp1,max_parm), + & nlor_all(-maxtor:maxtor,-maxtor:maxtor,2,max_parm), + & nterm_all(-maxtor:maxtor,-maxtor:maxtor,2,max_parm), + & ntermd1_all(-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2,max_parm), + & ntermd2_all(-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2,max_parm), + & nbondterm_all(ntyp,max_parm),nthetyp_all(max_parm), + & ithetyp_all(-ntyp1:ntyp1,max_parm),ntheterm_all(max_parm), + & ntheterm2_all(max_parm),ntheterm3_all(max_parm), + & nsingle_all(max_parm),ndouble_all(max_parm), + & nntheterm_all(max_parm), + &nterm_sccor_all(-ntyp:ntyp,-ntyp:ntyp,max_parm) + common /allparm/ ww_all,vbldp0_all,akp_all,vbldsc0_all,aksc_all, + & abond0_all,aa0thet_all,aathet_all,bbthet_all,ccthet_all, + & ddthet_all,eethet_all,ffthet_all1,ggthet_all1, + & ffthet_all2,ggthet_all2, + & a0thet_all,athet_all,bthet_all,polthet_all,gthet_all,theta0_all, + & sig0_all,sigc0_all,dsc_all,bsc_all,censc_all,gaussc_all,dsc0_all, + & sc_parmin_all, + & v0_all,v1_all,v2_all,vlor1_all,vlor2_all,vlor3_all,v1c_all, + & v1s_all,v2c_all,v2s_all,b_all,ccold_all,ddold_all,eeold_all, + & bnew1_all,bnew2_all,ccnew_all,ddnew_all,eenew_all,e0new_all, + & app_all,bpp_all,ael6_all, + & ael3_all,aad_all,bad_all,aa_aq_all,bb_aq_all,augm_all, + & aa_lip_all,bb_lip_all,epslip_all, + & eps_all,sigma_all,r0_all,chi_all,chip_all,alp_all,ebr_all, + & d0cm_all,akcm_all,akth_all,akct_all,v1ss_all,v2ss_all,v3ss_all, + & v1sccor_all,v2sccor_all,nbondterm_all, + & nlob_all,nlor_all,nterm_all,ntermd1_all,ntermd2_all, + & nthetyp_all,ithetyp_all,ntheterm_all,ntheterm2_all,ntheterm3_all, + & nsingle_all,ndouble_all,nntheterm_all,nterm_sccor_all diff --git a/source/wham/src-HCD/COMMON.CHAIN b/source/wham/src-HCD/COMMON.CHAIN new file mode 100644 index 0000000..7369baa --- /dev/null +++ b/source/wham/src-HCD/COMMON.CHAIN @@ -0,0 +1,20 @@ + integer nres,nres0,nsup,nstart_sup,nend_sup,nstart_seq, + & ishift_pdb,chain_length,chain_border,ichanres,tabpermchain, + & nchain ,npermchain,ireschain,iz_sc + double precision c,cref,crefjlee,dc,xloc,xrot,dc_norm,t,r,prod,rt, + & rmssing,anatemp,chomo + common /chain/ c(3,maxres2+2),dc(3,maxres2),xloc(3,maxres), + & xrot(3,maxres),dc_norm(3,maxres2),nres,nres0 + common /rotmat/ t(3,3,maxres),r(3,3,maxres),prod(3,3,maxres), + & rt(3,3,maxres) + common /refstruct/ cref(3,maxres2+2),crefjlee(3,maxres2+2), + & rmssing,anatemp,iz_sc,nsup, + & nstart_sup,nend_sup,chain_length(maxchain),npermchain, + & ireschain(maxres),tabpermchain(maxchain,maxperm), + & chain_border(2,maxchain),nchain,nstart_seq,ishift_pdb + double precision boxxsize,boxysize,boxzsize,enecut,sscut,sss, + & sssgrad, + & buflipbot, bufliptop,bordlipbot,bordliptop,lipbufthick,lipthick + common /box/ boxxsize,boxysize,boxzsize,enecut,sscut,sss,sssgrad, + & buflipbot, bufliptop,bordlipbot,bordliptop,lipbufthick,lipthick + common /chomo_models/ chomo(3,maxres2+2,max_template) diff --git a/source/wham/src-HCD/COMMON.COMPAR b/source/wham/src-HCD/COMMON.COMPAR new file mode 100644 index 0000000..eb59ea4 --- /dev/null +++ b/source/wham/src-HCD/COMMON.COMPAR @@ -0,0 +1,39 @@ + integer ifrag,nfrag,npiece,iclass,iscore,ishifft,ncont_nat,ibase, + & n_shift,ipiece,istruct,ielecont,isccont,irms,len_frag,isnfrag, + & nc_req_setf,iloc,iloc_single,list_frag,nlist_frag,nlevel + double precision rmsfrag,rmscutfrag,rmscut_base_low, + & rmscut_base_up, + & rmsup_lim,rmsupup_lim,rms_nat,rmsang,ang_cut,ang_cut1, + & frac_min,nc_fragm,qfrag,qnat + logical lgrp,lgrp_out,binary + 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 + double precision angcut_hel,angcut1_hel,angcut_bet,angcut1_bet, + & angcut_strand,angcut1_strand,frac_min_set,ncfrac_hel,ncfrac_bet, + & ncfrac_pair,frac_sec + common /compar/ rmsfrag(maxfrag,maxlevel), + & qfrag(maxfrag,2),rmscut_base_low, + & rmscut_base_up,rmsup_lim,rmsupup_lim, + & rmscutfrag(2,maxfrag,maxlevel), + & rms_nat,qnat,rmsang,ang_cut(maxfrag), + & ang_cut1(maxfrag), + & frac_min(maxfrag),nc_fragm(maxfrag,maxlevel), + & nc_req_setf(maxfrag,maxlevel), + & ncont_nat(2,maxfrag,maxlevel),nfrag(maxlevel), + & isnfrag(maxlevel+1), + & npiece(maxfrag,maxlevel),ifrag(2,maxpiece,maxfrag), + & ipiece(maxpiece,maxfrag,2:maxlevel),istruct(maxfrag), + & ielecont(maxfrag,maxlevel), + & isccont(maxfrag,maxlevel),irms(maxfrag,maxlevel), + & iloc(maxfrag), + & iclass(maxlevel*maxfrag,maxlevel), + & iscore,ishifft(maxfrag,maxlevel), + & len_frag(maxfrag,maxlevel),n_shift(2,maxfrag,maxlevel), + & nlevel,ibase,lgrp,lgrp_out,binary, + & nlist_frag(maxfrag),list_frag(maxres,maxfrag) + common /compar1/ angcut_hel,angcut1_hel,angcut_bet,angcut1_bet, + & angcut_strand,angcut1_strand,frac_min_set,ncfrac_hel,ncfrac_bet, + & ncfrac_pair,frac_sec,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 diff --git a/source/wham/src-HCD/COMMON.CONTACTS1 b/source/wham/src-HCD/COMMON.CONTACTS1 new file mode 100644 index 0000000..04affa9 --- /dev/null +++ b/source/wham/src-HCD/COMMON.CONTACTS1 @@ -0,0 +1,5 @@ + integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont, + & nsccont_frag_ref,isccont_frag_ref + common /contacts/ ncont,ncont_ref,icont(2,maxcont), + & icont_ref(2,maxcont),nsccont_frag_ref(mmaxfrag), + & isccont_frag_ref(2,maxcont,mmaxfrag) diff --git a/source/wham/src-HCD/COMMON.CONTROL b/source/wham/src-HCD/COMMON.CONTROL new file mode 100644 index 0000000..0c25c29 --- /dev/null +++ b/source/wham/src-HCD/COMMON.CONTROL @@ -0,0 +1,16 @@ + integer iscode,indpdb,outpdb,outmol2,icomparfunc,pdbint, + & ensembles,constr_dist,symetr,shield_mode,tor_mode, + & homol_nset,constr_homology + logical refstr,pdbref,punch_dist,print_rms,caonly,verbose, + & merge_helices,bxfile,cxfile,histfile,entfile,zscfile,unres_pdb, + & rmsrgymap,with_dihed_constr,check_conf,histout,with_theta_constr, + & energy_dec,adaptive,read2sigma,read_homol_frag, + & out_template_coord,out_template_restr + common /cntrl/ iscode,indpdb,refstr,pdbref,outpdb,outmol2, + & punch_dist,print_rms,caonly,verbose,icomparfunc,pdbint, + & merge_helices,bxfile,cxfile,histfile,entfile,zscfile,unres_pdb, + & rmsrgymap,ensembles,with_dihed_constr,constr_dist,check_conf, + & histout,with_theta_constr, + & constr_homology,homol_nset,read2sigma,read_homol_frag, + & out_template_coord,out_template_restr, + & symetr,tor_mode,shield_mode,energy_dec,adaptive diff --git a/source/wham/src-HCD/COMMON.CONTROL.org b/source/wham/src-HCD/COMMON.CONTROL.org new file mode 100644 index 0000000..7dc2298 --- /dev/null +++ b/source/wham/src-HCD/COMMON.CONTROL.org @@ -0,0 +1,9 @@ + integer iscode,indpdb,outpdb,outmol2,icomparfunc,pdbint, + & ensembles + logical refstr,pdbref,punch_dist,print_rms,caonly,verbose, + & merge_helices,bxfile,cxfile,histfile,entfile,zscfile, + & rmsrgymap + common /cntrl/ iscode,indpdb,refstr,pdbref,outpdb,outmol2, + & punch_dist,print_rms,caonly,verbose,icomparfunc,pdbint, + & merge_helices,bxfile,cxfile,histfile,entfile,zscfile,rmsrgymap, + & ensembles diff --git a/source/wham/src-HCD/COMMON.DFA b/source/wham/src-HCD/COMMON.DFA new file mode 100644 index 0000000..c6add4f --- /dev/null +++ b/source/wham/src-HCD/COMMON.DFA @@ -0,0 +1,101 @@ +C ======= +C COMMON.DFA +C ======= +C 2010/12/20 By Juyong Lee +C +c parameter +C [ 8 * ( Nres - 8 ) ] distance restraints +C [ 2 * ( Nres - 8 ) ] angle restraints +C [ Nres ] neighbor restraints +C Total : ~ 11 * Nres restraints +C +C + INTEGER IDFAMAX,IDFAMX2,IDFACMD,IDMAXMIN, MAXN + PARAMETER(IDFAMAX=4000,IDFAMX2=1000,IDFACMD=500,IDMAXMIN=500) + PARAMETER(MAXN=4) + real*8 wwdist,wwangle,wwnei + parameter(wwdist=1.0d0,wwangle=1.0d0,wwnei=1.0d0) + +C IDFAMAX - maximum number of DFA restraint including distance, angle and +C number of neighbors ( Max of assign statement ) +C IDFAMX2 - maximum number of atoms which are targets of restraints +C IDFACMD - maximum number of 'DFA' command call +C IDMAXMIN - Maximum number of minima of dist, angle and neighbor info. from fragments +C MAXN - Maximum Number of shell, currently 4 +C MAXRES - Maximum number of CAs + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc +C INTEGER +C DFANUM - Number of ALL DFA restrants +c IDFA[DIS, PHI, THE, NEI] - NUMBER of restraints +c IDISNUM - number of minima for a distance restraint +c IPHINUM - number of minima for a phi angle restraint +c ITHENUM - number of minima for a theta angle restraint +c INEINUM - number of minima for a number of neighbors restraint + +c IDISLIS - atom number of two atoms for distance restraint +c IPHILIS - atom numbers of four atoms for angle restraint +c ITHELIS - atom numbers of four atoms for angle restraint +c INEILIS - atom number of center of neighbor calculation +c JNEILIS - atom number of target of neighboring calculation +c JNEINUM - number of target atoms of neighboring term +C KSHELL - SHELL number + +C ishiftca - index shift for CA atoms in UNRES (1 if the 1st aa != GLY) +C ilastca - index of the last CA atom in UNRES (nres-1 if last aa != GLY) + +C old only for CHARMM +C STOAGDF - Store assign information ( How many assign within one command ) +C NMAP - mapping between dfanum and ndis, nphi, nthe, nnei + + INTEGER IDFADIS,IDFAPHI,IDFATHE,IDFANEI, + & IDISLIS,IPHILIS,ITHELIS,INEILIS, + & IDISNUM,IPHINUM,ITHENUM,INEINUM, + & FNEI,DFACMD, DFANUM, + & NCA,ICAIDX, + & STOAGDF, NMAP, IDFACAT, KDISNUM, KSHELL + & ishiftca,ilastca + COMMON /IDFA/ DFACMD, DFANUM, + & IDFADIS, IDFAPHI, IDFANEI, IDFATHE, + & IDISNUM(IDFAMAX), IPHINUM(IDFAMAX), + & ITHENUM(IDFAMAX), INEINUM(IDFAMAX), + & FNEI(IDFAMAX,IDMAXMIN), IDISLIS(2,IDFAMAX), + & IPHILIS(5,IDFAMAX), ITHELIS(5,IDFAMAX), + & INEILIS(IDFAMAX), + & KSHELL(IDFAMAX), + & IDFACAT(IDFACMD), + & KDISNUM(IDFAMAX), + & NCA, ICAIDX(MAXRES) + COMMON /IDFA2/ ishiftca,ilastca + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C REAL VARIABLES +C +c SCC[DIST, PHI, THE] - weight of each calculations +c FDIST - distance minima +C FPHI - phi minima +c FTHE - theta minima +C DFAEXP : calculate expential function in advance +C + REAL*8 SCCDIST, SCCPHI, SCCTHE, SCCNEI, FDIST, FPHI1, FPHI2, + & FTHE1, FTHE2, + & DIS_INC, PHI_INC, THE_INC, NEI_INC, BETA_INC, + & WSHET, EDFABET, + & CK, SCK, S1, S2 +c & ,DFAEXP + + COMMON /RDFA/ SCCDIST(IDFAMAX,IDMAXMIN),FDIST(IDFAMAX,IDMAXMIN), + & SCCPHI(IDFAMAX,IDMAXMIN), SCCTHE(IDFAMAX,IDMAXMIN), + & SCCNEI(IDFAMAX,IDMAXMIN), + & FPHI1(IDFAMAX,IDMAXMIN), FPHI2(IDFAMAX,IDMAXMIN), + & FTHE1(IDFAMAX,IDMAXMIN), FTHE2(IDFAMAX,IDMAXMIN), + & DIS_INC, PHI_INC, THE_INC, NEI_INC, BETA_INC, + & WSHET(MAXRES,MAXRES), EDFABET, + & CK(4),SCK(4),S1(4),S2(4) +c & ,DFAEXP(15001), + + DATA CK/1.0D0,1.58740105197D0,2.08008382305D0,2.51984209979D0/ + DATA SCK/1.0D0,1.25992104989D0,1.44224957031D0,1.58740105197D0/ + DATA S1/3.75D0,5.75D0,7.75D0,9.75D0/ + DATA S2/4.25D0,6.25D0,8.25D0,10.25D0/ diff --git a/source/wham/src-HCD/COMMON.ENEPS b/source/wham/src-HCD/COMMON.ENEPS new file mode 100644 index 0000000..eaf002e --- /dev/null +++ b/source/wham/src-HCD/COMMON.ENEPS @@ -0,0 +1,3 @@ + double precision eneps_temp(2,nntyp) + integer n_ene + common /weightder/ eneps_temp,n_ene diff --git a/source/wham/src-HCD/COMMON.ENERGIES b/source/wham/src-HCD/COMMON.ENERGIES new file mode 100644 index 0000000..2d40a95 --- /dev/null +++ b/source/wham/src-HCD/COMMON.ENERGIES @@ -0,0 +1,4 @@ + double precision potE(MaxStr_Proc,Max_Parm),entfac(MaxStr_Proc), + & q(MaxQ+2,MaxStr_Proc),enetb(max_ene,MaxStr_Proc,Max_Parm) + integer einicheck + common /energies/ potE,entfac,q,enetb,einicheck diff --git a/source/wham/src-HCD/COMMON.FREE b/source/wham/src-HCD/COMMON.FREE new file mode 100644 index 0000000..370dcfc --- /dev/null +++ b/source/wham/src-HCD/COMMON.FREE @@ -0,0 +1,12 @@ + integer nQ,nparmset,stot(maxslice),rescale_mode,iparmprint,myparm + logical hamil_rep,separate_parset + double precision Kh(MaxQ,MaxR,MaxT_h,max_parm), + & q0(MaxQ,MaxR,MaxT_h,max_parm),tole,delta,deltrms,deltrgy,fimin, + & f(maxR,maxT_h,max_parm),beta_h(MaxT_h,max_parm) + integer nR(maxT_h,max_parm),snk(MaxR,MaxT_h,max_parm,MaxSlice), + & nT_h(max_parm),maxit,totraj(maxR,max_parm),nRR(maxT_h,max_parm) + logical replica(max_parm),umbrella(max_parm),read_iset(max_parm) + common /wham/ Kh,q0,f,beta_h,delta,tole,deltrms,deltrgy,fimin, + & snk,nR, + & nRR,nT_h,nQ,stot,nparmset,maxit,rescale_mode,replica,umbrella, + & read_iset,totraj,hamil_rep,separate_parset,iparmprint,myparm diff --git a/source/wham/src-HCD/COMMON.HOMOLOGY b/source/wham/src-HCD/COMMON.HOMOLOGY new file mode 100644 index 0000000..03740bf --- /dev/null +++ b/source/wham/src-HCD/COMMON.HOMOLOGY @@ -0,0 +1,8 @@ + logical l_homo + integer iset,ihset + real*8 waga_homology + real*8 waga_dist, waga_angle, waga_theta, waga_d, dist_cut, + & dist2_cut + common /homol/ waga_homology(maxR), + & waga_dist,waga_angle,waga_theta,waga_d,dist_cut,dist2_cut, + & iset,ihset,l_homo(max_template,maxdim) diff --git a/source/wham/src-HCD/COMMON.HOMRESTR b/source/wham/src-HCD/COMMON.HOMRESTR new file mode 100644 index 0000000..95ea932 --- /dev/null +++ b/source/wham/src-HCD/COMMON.HOMRESTR @@ -0,0 +1,39 @@ + real*8 odl(max_template,maxdim),sigma_odl(max_template,maxdim), + & dih(max_template,maxres),sigma_dih(max_template,maxres), + & sigma_odlir(max_template,maxdim) +c +c Specification of new variables used in subroutine e_modeller +c modified by FP (Nov.,2014) + real*8 xxtpl(max_template,maxres),yytpl(max_template,maxres), + & zztpl(max_template,maxres),thetatpl(max_template,maxres), + & sigma_theta(max_template,maxres), + & sigma_d(max_template,maxres) +c + + integer ires_homo(maxdim),jres_homo(maxdim) + + double precision + & Ucdfrag,Ucdpair,dUdconst(3,0:MAXRES),Uconst, + & dUdxconst(3,0:MAXRES),dqwol(3,0:MAXRES),dxqwol(3,0:MAXRES), + & dutheta(maxres),dugamma(maxres), + & duscdiff(3,maxres), + & duscdiffx(3,maxres), + & uconst_back + integer lim_odl,lim_dih,link_start_homo,link_end_homo, + & idihconstr_start_homo,idihconstr_end_homo +c +c FP (30/10/2014) +c +c integer ithetaconstr_start_homo,ithetaconstr_end_homo +c + integer nresn,nyosh,nnos + common /back_constr/ uconst_back, + & dutheta,dugamma,duscdiff,duscdiffx + common /homrestr/ odl,dih,sigma_dih,sigma_odl, + & lim_odl,lim_dih,ires_homo,jres_homo,link_start_homo, + & link_end_homo,idihconstr_start_homo,idihconstr_end_homo, +c +c FP (30/10/2014,04/03/2015) +c + & xxtpl,yytpl,zztpl,thetatpl,sigma_theta,sigma_d,sigma_odlir +c diff --git a/source/wham/src-HCD/COMMON.IOUNITS b/source/wham/src-HCD/COMMON.IOUNITS new file mode 100644 index 0000000..188d55e --- /dev/null +++ b/source/wham/src-HCD/COMMON.IOUNITS @@ -0,0 +1,54 @@ +C----------------------------------------------------------------------- +C I/O units used by the program +C----------------------------------------------------------------------- +C 9/18/99 - unit ifourier and filename fouriername included to identify +C the file from which the coefficients of second-order Fourier expansion +C of the local-interaction energy are read. +C 8/9/01 - file for SCP interaction constants named scpname (unit iscpp) +C included. +C----------------------------------------------------------------------- +C General I/O units & files + integer inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,irotam, + & itorp,itordp,ifourier,ielep,isidep,iscpp,isccor,icbase, + & istat,ientin,ientout,isidep1,ibond,ihist,izsc,idistr, + & iliptranpar + common /iounits/ inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep, + & irotam,itorp,itordp,ifourier,ielep,isidep,iscpp,isccor, + & icbase,istat,ientin,ientout,isidep1,ibond,ihist,izsc, + & idistr,iliptranpar + character*256 outname,intname,pdbname,mol2name,statname,intinname, + & entname,restartname,prefix,scratchdir,sidepname,pdbfile, + & histname,zscname + common /fnames/ outname,intname,pdbname,mol2name,statname, + & intinname,entname,restartname,prefix,pot,scratchdir, + & sidepname,pdbfile,histname,zscname +C Parameter files + character*256 bondname,thetname,rotname,torname,tordname, + & fouriername,elename,sidename,scpname,sccorname,patname, + & liptranname + common /parfiles/ thetname,rotname,torname,tordname,bondname, + & fouriername,elename,sidename,scpname,sccorname,patname, + & liptranname + character*3 pot +C----------------------------------------------------------------------- +C INP - main input file +C IOUT - list file +C IGEOM - geometry output in the form of virtual-chain internal coordinates +C INTIN - geometry input (for multiple conformation processing) in int. coords. +C IPDB - Cartesian-coordinate output in PDB format +C IMOL2 - Cartesian-coordinate output in Tripos mol2 format +C IPDBIN - PDB input file +C ITHEP - virtual-bond torsional angle parametrs +C IROTAM - side-chain geometry and local-interaction parameters +C ITORP - torsional parameters +C ITORDP - double torsional parameters +C IFOURIER - coefficients of the expansion of local-interaction energy +C IELEP - electrostatic-interaction parameters +C ISIDEP - side-chain interaction parameters. +C ISCPP - SCp interaction parameters. +C IBOND - virtual-bond constant parameters and moments of inertia. +C ISCCOR - parameters of the potential of SCCOR term +C ICBASE - data base with Cartesian coords of known structures. +C ISTAT - energies and other conf. characteristics from an MCM run. +C IENTIN - entropy from preceding simulation(s) to be read in. +C----------------------------------------------------------------------- diff --git a/source/wham/src-HCD/COMMON.LANGEVIN b/source/wham/src-HCD/COMMON.LANGEVIN new file mode 100644 index 0000000..982bde9 --- /dev/null +++ b/source/wham/src-HCD/COMMON.LANGEVIN @@ -0,0 +1,8 @@ + double precision scal_fric,rwat,etawat,gamp, + & gamsc(ntyp1),stdfp,stdfsc(ntyp),stdforcp(MAXRES), + & stdforcsc(MAXRES),pstok,restok(ntyp+1),cPoise,Rb + common /langevin/ pstok,restok,gamp,gamsc, + & stdfp,stdfsc,stdforcp,stdforcsc,rwat,etawat,cPoise,Rb + double precision IP,ISC(ntyp+1),mp, + & msc(ntyp+1) + common /inertia/ IP,ISC,MP,MSC diff --git a/source/wham/src-HCD/COMMON.MPI b/source/wham/src-HCD/COMMON.MPI new file mode 100644 index 0000000..037c1c9 --- /dev/null +++ b/source/wham/src-HCD/COMMON.MPI @@ -0,0 +1,8 @@ + integer me, me1, Master, Master1, Nprocs, Nprocs1, Comm1, + & Indstart, Indend, scount, idispl, i2ii, WHAM_COMM + integer indstart_map,indend_map,idispl_map,scount_map + common /MPI_Data/ Nprocs, Master,Master1,Me,Comm1,Me1,Nprocs1, + & WHAM_COMM, + & Indstart(0:MaxProcs), + & Indend(0:MaxProcs), idispl(0:MaxProcs), + & scount(0:MaxProcs) diff --git a/source/wham/src-HCD/COMMON.OBCINKA b/source/wham/src-HCD/COMMON.OBCINKA new file mode 100644 index 0000000..e0d9c61 --- /dev/null +++ b/source/wham/src-HCD/COMMON.OBCINKA @@ -0,0 +1,3 @@ + real*8 time_start_collect(maxR,MaxT_h,Max_Parm), + & time_end_collect(maxR,MaxT_h,Max_Parm) + common /obcinka/ time_start_collect,time_end_collect diff --git a/source/wham/src-HCD/COMMON.PEPTCONT b/source/wham/src-HCD/COMMON.PEPTCONT new file mode 100644 index 0000000..59e05dd --- /dev/null +++ b/source/wham/src-HCD/COMMON.PEPTCONT @@ -0,0 +1,7 @@ + integer ncont_pept_ref,icont_pept_ref,ncont_frag_ref, + & icont_frag_ref,isec_ref + common /peptcont/ ncont_pept_ref, + & icont_pept_ref(2,maxcont), + & ncont_frag_ref(mmaxfrag), + & icont_frag_ref(2,maxcont,mmaxfrag), + & isec_ref(maxres) diff --git a/source/wham/src-HCD/COMMON.PMF b/source/wham/src-HCD/COMMON.PMF new file mode 100644 index 0000000..9997151 --- /dev/null +++ b/source/wham/src-HCD/COMMON.PMF @@ -0,0 +1,3 @@ + double precision PMFtab(0:maxHdim,maxT_h,maxR,max_parm),delta_q + integer tmin(0:maxT_h,maxR,max_parm),tmax(maxT_h,maxR,max_parm) + common /PMF/ PMFtab,delta_q,tmin,tmax diff --git a/source/wham/src-HCD/COMMON.PROT b/source/wham/src-HCD/COMMON.PROT new file mode 100644 index 0000000..054ec47 --- /dev/null +++ b/source/wham/src-HCD/COMMON.PROT @@ -0,0 +1,2 @@ + integer ntot(maxslice),isampl(max_parm),nslice + common /protein/ ntot,isampl,nslice diff --git a/source/wham/src-HCD/COMMON.PROTFILES b/source/wham/src-HCD/COMMON.PROTFILES new file mode 100644 index 0000000..3287326 --- /dev/null +++ b/source/wham/src-HCD/COMMON.PROTFILES @@ -0,0 +1,10 @@ + character*80 protfiles(maxfile_prot,2,MaxR,MaxT_h,Max_Parm), + & bprotfiles + integer nfile_bin(MaxR,MaxT_h,Max_Parm), + & nfile_asc(MaxR,MaxT_h,Max_Parm), + & nfile_cx(MaxR,MaxT_h,Max_Parm), + & rec_start(MaxR,MaxT_h,Max_Parm), + & rec_end(MaxR,MaxT_h,Max_Parm),lenrec,lenrec1,lenrec2 + common /protfil/ protfiles,bprotfiles, + & nfile_bin,nfile_asc,nfile_cx,rec_start,rec_end,lenrec,lenrec1, + & lenrec2 diff --git a/source/wham/src-HCD/COMMON.SAXS b/source/wham/src-HCD/COMMON.SAXS new file mode 100644 index 0000000..08fffa2 --- /dev/null +++ b/source/wham/src-HCD/COMMON.SAXS @@ -0,0 +1,7 @@ +! SAXS restraint parameters + integer nsaxs,saxs_mode + double precision Psaxs(maxsaxs),distsaxs(maxsaxs), + & CSAXS(3,maxsaxs),scal_rad,wsaxs0,saxs_cutoff + common /saxsretr/ Psaxs,distsaxs,csaxs,Wsaxs0,scal_rad, + & saxs_cutoff,nsaxs,saxs_mode + diff --git a/source/wham/src-HCD/COMMON.SHIELD b/source/wham/src-HCD/COMMON.SHIELD new file mode 100644 index 0000000..1f96c94 --- /dev/null +++ b/source/wham/src-HCD/COMMON.SHIELD @@ -0,0 +1,14 @@ + double precision VSolvSphere,VSolvSphere_div,long_r_sidechain, + & short_r_sidechain,fac_shield,grad_shield_side,grad_shield, + & buff_shield,wshield,grad_shield_loc + integer ishield_list,shield_list,ees0plist + common /shield/ VSolvSphere,VSolvSphere_div,buff_shield, + & long_r_sidechain(ntyp), + & short_r_sidechain(ntyp),fac_shield(maxres),wshield, + & grad_shield_side(3,maxcont,-1:maxres),grad_shield(3,-1:maxres), + & grad_shield_loc(3,maxcont,-1:maxres), + & ishield_list(maxres),shield_list(maxcont,maxres), + & ees0plist(maxcont,maxres) + + + diff --git a/source/wham/src-HCD/COMMON.SPLITELE b/source/wham/src-HCD/COMMON.SPLITELE new file mode 100644 index 0000000..a2f0447 --- /dev/null +++ b/source/wham/src-HCD/COMMON.SPLITELE @@ -0,0 +1,2 @@ + double precision r_cut,rlamb + common /splitele/ r_cut,rlamb diff --git a/source/wham/src-HCD/COMMON.VAR b/source/wham/src-HCD/COMMON.VAR new file mode 100644 index 0000000..5141f66 --- /dev/null +++ b/source/wham/src-HCD/COMMON.VAR @@ -0,0 +1,18 @@ +C Store the geometric variables in the following COMMON block. + integer ntheta,nphi,nside,nvar,ialph,ivar + double precision theta,phi,alph,omeg,vbld,vbld_ref, + & theta_ref,phi_ref,alph_ref,omeg_ref, + & costtab,sinttab,cost2tab,sint2tab,tauangle,omicron, + & xxtab,yytab,zztab, + & thetaref,phiref,xxref,yyref,zzref + common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), + & vbld(2*maxres),thetaref(maxres),phiref(maxres), + & costtab(maxres), sinttab(maxres), cost2tab(maxres), + & sint2tab(maxres),xxtab(maxres),yytab(maxres), + & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres), + & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar, + & omicron(2,maxres),tauangle(3,maxres) +C Angles from experimental structure + common /varref/ vbld_ref(maxres), + & theta_ref(maxres),phi_ref(maxres), + & alph_ref(maxres),omeg_ref(maxres) diff --git a/source/wham/src-HCD/DIMENSIONS b/source/wham/src-HCD/DIMENSIONS new file mode 100644 index 0000000..48e0adf --- /dev/null +++ b/source/wham/src-HCD/DIMENSIONS @@ -0,0 +1,164 @@ +******************************************************************************** +* Settings for the program of united-residue peptide simulation in real space * +* * +* ------- As of 6/23/01 ----------- * +* * +******************************************************************************** +c implicit real*8 (a-h,o-z) +C Max. number of processors. +c parameter (maxprocs=128) +C Max. number of fine-grain processors +c parameter (max_fg_procs=maxprocs) +C Max. number of coarse-grain processors +c parameter (max_cg_procs=maxprocs) +C Max. number of AA residues + integer maxres +c parameter (maxres=250) + parameter (maxres=1200) +c parameter (maxres=3300) +C Appr. max. number of interaction sites + integer maxres2 + parameter (maxres2=2*maxres) +c Max. number of chains + integer maxchain + parameter (maxchain=6) +C Max number of symetries + integer maxsym,maxperm + parameter (maxsym=maxchain,maxperm=720) +C Max. number of variables + integer maxvar + parameter (maxvar=4*maxres) +C Max. number of groups of interactions that a given SC is involved in + integer maxint_gr + parameter (maxint_gr=2) +C Max. number of derivatives of virtual-bond and side-chain vectors in theta +C or phi. + integer maxdim + parameter (maxdim=(maxres-1)*(maxres-2)/2) +c parameter (maxdim=10000) +C Max. number of SC contacts + integer maxcont + parameter (maxcont=12*maxres) +C Max. number of contacts per residue + integer maxconts + parameter (maxconts=maxres) +C Number of AA types (at present only natural AA's will be handled + integer ntyp,ntyp1 + parameter (ntyp=24,ntyp1=ntyp+1) + integer nntyp + parameter (nntyp=ntyp*(ntyp+1)/2) +C Max. number of types of dihedral angles & multiplicity of torsional barriers +C and the number of terms in double torsionals + integer maxtor,maxterm,maxlor,maxtermd_1,maxtermd_2,maxtor_kcc, + & maxval_kcc + parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) + parameter (maxtor_kcc=6,maxval_kcc=6) +c Max number of new valence-angle (only) terms + integer maxang_kcc + parameter (maxang_kcc=36) +c Max number of torsional terms in SCCOR + integer maxterm_sccor + parameter (maxterm_sccor=6) +C Max. number of residue types and parameters in expressions for +C virtual-bond angle bending potentials + integer maxthetyp,maxthetyp1,maxtheterm,maxtheterm2,maxtheterm3, + & maxsingle,maxdouble,mmaxtheterm + parameter (maxthetyp=3,maxthetyp1=maxthetyp+1,maxtheterm=20, + & maxtheterm2=6,maxtheterm3=4,maxsingle=6,maxdouble=4, + & mmaxtheterm=maxtheterm) +C Max. number of lobes in SC distribution + integer maxlob + parameter (maxlob=4) +C Max. number of S-S bridges + integer maxss + parameter (maxss=20) +C Max. number of dihedral angle constraints + integer maxdih_constr + parameter (maxdih_constr=maxres) +C Max. number of patterns in the pattern database + integer maxseq + parameter (maxseq=1000) +C Max. number of residues in a peptide in the database + integer maxres_base + parameter (maxres_base=1000) +C Max. number of threading attempts + integer maxthread + parameter (maxthread=2000) +C Max. number of move types in MCM + integer maxmovetype + parameter (maxmovetype=4) +C Max. number of stored confs. in MC/MCM simulation + integer maxsave + parameter (maxsave=2000) +C Max. number of conformations in Master's cache array + integer max_cache + parameter (max_cache=1000) +C Max. number of conformations in the pool + integer max_pool + parameter (max_pool=1000) +C Number of threads in deformation + integer max_thread,max_thread2 + parameter (max_thread=40,max_thread2=2*max_thread) +C Number of steps in DSM + integer max_step + parameter (max_step=1) +C Number of structures to compare at t=0 + integer max_threadss,max_threadss2 + parameter (max_threadss=80,max_threadss2=2*max_threadss) +C Maxmimum number of angles per residue + integer mxang + parameter (mxang=4) +C Maximum number of groups of angles + integer mxgr + parameter (mxgr=2*maxres) +C Maximum number of chains + integer mxch + parameter (mxch=1) +C Maximum number of generated conformations + integer mxio + parameter (mxio=1000) +C Maximum number of seed + integer max_seed + parameter (max_seed=100) +C Maximum number of structures for ZSCORE for each protein + integer maxzs + parameter (maxzs=2) +C Maximum number of structures stored for comparison for ZSCORE for each protein + integer maxzs1 + parameter (maxzs1=6) +C Maximum number of proteins for ZSCORE + integer maxprotzs + parameter (maxprotzs=1) +C Maximum number of conf in rmsdbank + integer maxrmsdb + parameter (maxrmsdb=110) +C Maximum number of bankt conformations + integer mxiot + parameter (mxiot=mxio) +c Maximum number of conformations in MCMF + integer maxstr_mcmf + parameter (maxstr_mcmf=800) +c Maximum number of families in MCMF + integer maxfam_p + parameter (maxfam_p=20) +c Maximum number of structures in family in MCMF + integer maxstr_fam + parameter (maxstr_fam=40) +C Maximum number of threads in MCMF + integer maxthread_mcmf + parameter (maxthread_mcmf=10) +C Maximum number of SC local term fitting function coefficiants + integer maxsccoef + parameter (maxsccoef=65) +C Maximum number of terms in SC bond-stretching potential + integer maxbondterm + parameter (maxbondterm=3) +C Maximum number of bins in SAXS restraints + integer MaxSAXS + parameter (MaxSAXS=1000) +C Maximum number of templates in homology-modeling restraints + integer max_template + parameter(max_template=50) +c Maximum number of clusters of templates containing same fragments + integer maxclust + parameter(maxclust=1000) diff --git a/source/wham/src-HCD/DIMENSIONS.COMPAR b/source/wham/src-HCD/DIMENSIONS.COMPAR new file mode 100644 index 0000000..911bd4e --- /dev/null +++ b/source/wham/src-HCD/DIMENSIONS.COMPAR @@ -0,0 +1,25 @@ +****************************************************************** +* +* 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 maxfrag,mmaxfrag + PARAMETER (MAXFRAG=30,MMAXFRAG=MAXFRAG*(MAXFRAG+1)/2) +* +* Max. number of pieces forming a substructure to be compared +* + integer maxpiece + PARAMETER (MAXPIECE=20) +* +******************************************************************* diff --git a/source/wham/src-HCD/DIMENSIONS.FREE b/source/wham/src-HCD/DIMENSIONS.FREE new file mode 100644 index 0000000..7a397d9 --- /dev/null +++ b/source/wham/src-HCD/DIMENSIONS.FREE @@ -0,0 +1,13 @@ + integer Max_Parm + integer MaxQ,MaxQ1 + integer MaxR,MaxT_h,maxHdim + integer MaxSlice + parameter (Max_Parm=5) + parameter (MaxQ=4,MaxQ1=MaxQ+2) + parameter(MaxR=8,MaxT_h=36) + parameter(MaxSlice=40) + parameter(maxHdim=200) + integer MaxN + parameter (MaxN=100) + integer MaxPrintConf + parameter (MaxPrintConf=1000) diff --git a/source/wham/src-HCD/DIMENSIONS.FREE.old b/source/wham/src-HCD/DIMENSIONS.FREE.old new file mode 100644 index 0000000..e579dd1 --- /dev/null +++ b/source/wham/src-HCD/DIMENSIONS.FREE.old @@ -0,0 +1,12 @@ + integer Max_Parm + integer MaxQ,MaxQ1 + integer MaxR,MaxT_h + integer MaxSlice + parameter (Max_Parm=6) + parameter (MaxQ=5,MaxQ1=MaxQ+2) + parameter(MaxR=1,MaxT_h=32) + parameter(MaxSlice=40) + integer MaxN + parameter (MaxN=100) + integer MaxPrintConf + parameter (MaxPrintConf=1000) diff --git a/source/wham/src-HCD/DIMENSIONS.ZSCOPT b/source/wham/src-HCD/DIMENSIONS.ZSCOPT new file mode 100644 index 0000000..2948e3c --- /dev/null +++ b/source/wham/src-HCD/DIMENSIONS.ZSCOPT @@ -0,0 +1,40 @@ + integer maxstr,max_ene,maxprot,maxclass,maxfile_prot,maxobj, + & maxstr_proc, maxclass1 +c Maximum number of structures in the database, energy components, proteins, +c and structural classes +c#ifdef JUBL + parameter (maxstr=200000,max_ene=31,maxprot=7,maxclass=10) + parameter (maxclass1=10) +c Maximum number of structures to be dealt with by one processor + parameter (maxstr_proc=20000) +c Maximum number of temperatures + integer maxT + parameter (maxT=10) +c Maximum number of batches + integer maxbatch + parameter (maxbatch=1) +c Maximum number of energy/Zscore gaps for a single protein + integer maxgap + parameter (maxgap=2*maxclass1) +c Maximum number of the components of the target function + parameter (maxobj=maxgap*maxprot*maxT) +c Maximum number of files with energies/coordinates + parameter (maxfile_prot=100) +c Maximum number of grid points in energy map evaluation + integer max_x,max_y,max_minim + parameter (max_x=200,max_y=200,max_minim=1000) +c Maximum number of processors + integer MaxProcs + parameter (MaxProcs = 128) +c Maximum number of optimizable parameters + integer max_paropt + parameter (max_paropt=500) +c Maximum number of fragments +c integer maxfrag +c parameter (maxfrag=0) +c Maximum number of sublevels + integer maxlev + parameter (maxlev=maxclass) +c Maximum number of grid points in temperature + integer MaxGridT + parameter (MaxGridT=2000) diff --git a/source/wham/src-HCD/Makefile b/source/wham/src-HCD/Makefile new file mode 120000 index 0000000..ee054bf --- /dev/null +++ b/source/wham/src-HCD/Makefile @@ -0,0 +1 @@ +Makefile_MPICH_ifort-okeanos \ No newline at end of file diff --git a/source/wham/src-HCD/Makefile-okeanos b/source/wham/src-HCD/Makefile-okeanos new file mode 100644 index 0000000..c610b7a --- /dev/null +++ b/source/wham/src-HCD/Makefile-okeanos @@ -0,0 +1,107 @@ +# +FC= ftn +OPT = -O3 -hfp3 + +FFLAGS = -c ${OPT} -I. -Iinclude_unres +FFLAGS1 = -c -g -Rb +FFLAGS2 = -c -g -O0 +FFLAGSE = ${FFLAGS} + +BIN = ~/bin +LIBS = xdrf/libxdrf.a + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + gnmr1.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + permut.o \ + pinorm.o \ + printmat.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o \ + ssMD.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +all: no_option + @echo "Specify force field: GAB, 4P or E0LL2Y" + +no_option: + +GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM +GAB: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham_MPI-GAB.exe + +4P: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM +4P: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham_MPI-4P.exe + +E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -DWHAM +E0LL2Y: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham_MPI-E0LL2Y.exe + +NEWCORR: CPPFLAGS = -DMPI -DCRAY -DUNRES -DSPLITELE -DPROCOR -DNEWCORR -DPGI -DISNAN -DAMD64 -DWHAM +NEWCORR: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham_MPI-NEWCORR.exe + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + diff --git a/source/wham/src-HCD/Makefile_MPICH_ifort b/source/wham/src-HCD/Makefile_MPICH_ifort new file mode 100644 index 0000000..9a83c35 --- /dev/null +++ b/source/wham/src-HCD/Makefile_MPICH_ifort @@ -0,0 +1,104 @@ +INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh +BIN = ../../../bin/wham +FC= ifort +OPT = -mcmodel=medium -O3 -ip -w +#OPT = -mcmodel=medium -g -CB +FFLAGS = ${OPT} -c -I. -I./include_unres -I$(INSTALL_DIR)/include +LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpmpich xdrf/libxdrf.a + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + gnmr1.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + permut.o \ + pinorm.o \ + printmat.o \ + proc_proc.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o \ + ssMD.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +all: no_option + @echo "Specify force field: GAB, 4P or E0LL2Y" + +no_option: + +GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM +GAB: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham_ifort_MPICH_GAB.exe + +4P: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM +4P: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham_ifort_MPICH_4P.exe + +E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -DWHAM +E0LL2Y: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham_ifort_MPICH_E0LL2Y.exe + +NEWCORR: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DNEWCORR -DPGI -DISNAN -DAMD64 -DWHAM +NEWCORR: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham_ifort_MPICH_NEWCORR.exe + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + diff --git a/source/wham/src-HCD/Makefile_MPICH_ifort-okeanos b/source/wham/src-HCD/Makefile_MPICH_ifort-okeanos new file mode 100644 index 0000000..01955ff --- /dev/null +++ b/source/wham/src-HCD/Makefile_MPICH_ifort-okeanos @@ -0,0 +1,146 @@ +BIN = ~/bin +FC = ftn +OPT = -mcmodel=medium -shared-intel -O3 -dynamic +#OPT = -O3 -intel-static -mcmodel=medium +#OPT = -O3 -ip -w +#OPT = -g -CB -mcmodel=medium -shared-intel -dynamic +FFLAGS = ${OPT} -c -I. -I./include_unres -I$(INSTALL_DIR)/include +LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf/libxdrf.a + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + gnmr1.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + read_constr_homology.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + refsys.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + permut.o \ + seq2chains.o \ + chain_symmetry.o \ + iperm.o \ + pinorm.o \ + printmat.o \ + proc_proc.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o \ + PMFprocess.o \ + ssMD.o \ + oligomer.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +all: no_option + @echo "Specify force field: GAB, 4P, E0LL2Y or NEWCORR" + +no_option: + +GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DFOURBODY -DWHAM +GAB: ${objects} ${objects_compar} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -o ${BIN}/wham_ifort_MPICH-okeanos_GAB-HCD.exe + +GAB_DFA: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DFOURBODY -DWHAM -DDFA +GAB_DFA: ${objects} ${objects_compar} dfa.o xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} dfa.o cinfo.o \ + ${LIBS} -o ${BIN}/wham_ifort_MPICH-okeanos_GAB-HCD-DFA.exe + +4P: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DFOURBODY -DWHAM +4P: ${objects} ${objects_compar} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -o ${BIN}/wham_ifort_MPICH-okeanos_4P-HCD.exe + +4P_DFA: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DFOURBODY -DWHAM -DDFA +4P_DFA: ${objects} ${objects_compar} dfa.o xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} dfa.o cinfo.o \ + ${LIBS} -o ${BIN}/wham_ifort_MPICH-okeanos_4P-HCD-DFA.exe + +E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DFOURBODY -DAMD64 -DWHAM +E0LL2Y: ${objects} ${objects_compar} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -o ${BIN}/wham_ifort_MPICH-okeanos_E0LL2Y-HCD.exe + +E0LL2Y_DFA: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DFOURBODY -DAMD64 -DWHAM -DDFA +E0LL2Y_DFA: ${objects} ${objects_compar} dfa.o xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} dfa.o cinfo.o \ + ${LIBS} -o ${BIN}/wham_ifort_MPICH-okeanos_E0LL2Y-HCD-DFA.exe + +NEWCORR: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DNEWCORR -DCORRCD -DFOURBODY -DPGI -DISNAN -DAMD64 -DWHAM +NEWCORR: ${objects} ${objects_compar} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -o ${BIN}/wham_ifort_MPICH-okeanos_SC-HCD.exe + +NEWCORR_DFA: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DNEWCORR -DCORRCD -DDFA -DPGI -DISNAN -DAMD64 -DWHAM -DDFA +NEWCORR_DFA: ${objects} ${objects_compar} dfa.o xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} dfa.o cinfo.o \ + ${LIBS} -o ${BIN}/wham_ifort_MPICH-okeanos_SC-HCD-DFA-D.exe + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + diff --git a/source/wham/src-HCD/Makefile_MPICH_ifort-prometheus b/source/wham/src-HCD/Makefile_MPICH_ifort-prometheus new file mode 100644 index 0000000..6e98b37 --- /dev/null +++ b/source/wham/src-HCD/Makefile_MPICH_ifort-prometheus @@ -0,0 +1,118 @@ +BIN = ~/unres/bin + +FC = mpif90 -fc=ifort + +OPT = -O3 -ip -mcmodel=medium -shared-intel +#OPT = -O3 +OPT = -g -CA -CB -mcmodel=medium -shared-intel + +FFLAGS = -c ${OPT} -Iinclude_unres +FFLAGS1 = -c -g -CA -CB -mcmodel=medium -shared-intel +#FFLAGS = ${FFLAGS1} +FFLAGS2 = -c -g -O0 -mcmodel=medium -shared-intel +FFLAGSE = -c -O3 -ipo -mcmodel=medium -shared-intel +#FFLAGSE = ${FFLAGS} + + +#LIBS = -L$(INSTALL_DIR)/lib -lmpi xdrf/libxdrf.a +LIBS = -lmpi xdrf/libxdrf.a +#/opt/cray/mpt/7.3.2/gni/mpich-intel/15.0/lib/libmpich.a + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + gnmr1.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + permut.o \ + pinorm.o \ + printmat.o \ + proc_proc.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o \ + PMFprocess.o \ + ssMD.o \ + oligomer.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +all: no_option + @echo "Specify force field: GAB, 4P or E0LL2Y" + +no_option: + +GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM +GAB: ${objects} ${objects_compar} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_GAB-SAXS.exe + +4P: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM +4P: ${objects} ${objects_compar} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_4P-SAXS.exe + +E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -DWHAM +E0LL2Y: ${objects} ${objects_compar} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_E0LL2Y-SAXS.exe + +NEWCORR: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DNEWCORR -DCORRCD -DPGI -DISNAN -DAMD64 -DWHAM +NEWCORR: ${objects} ${objects_compar} xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_NEWCORR-SAXS-NMRAMB.exe + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + diff --git a/source/wham/src-HCD/Makefile_MPICH_pgi b/source/wham/src-HCD/Makefile_MPICH_pgi new file mode 100644 index 0000000..6dbee82 --- /dev/null +++ b/source/wham/src-HCD/Makefile_MPICH_pgi @@ -0,0 +1,96 @@ +INSTALL_DIR = /users/software/mpich-1.2.7p1_pgi_9.0_64bit_ssh +CC = cc +FC = pgf90 +#OPT = -mcmodel=medium -Mlarge_arrays -fast -pc 64 -tp amd64 -C -g +OPT = -mcmodel=medium -Mlarge_arrays -tp amd64 +#FFLAGS = ${OPT} -g -c -I. -I./include_unres -I$(INSTALL_DIR)/include +FFLAGS = ${OPT} -c -C -g -I. -I./include_unres -I$(INSTALL_DIR)/include +#FFLAGS = ${OPT} -c -I. -I./include_unres -I$(INSTALL_DIR)/include +LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpmpich xdrf/libxdrf.a + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + gnmr1.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + pinorm.o \ + printmat.o \ + proc_proc.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +all: no_option + @echo "Specify force field: GAB, 4P or E0LL2Y" + +no_option: + +GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM +GAB: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham-mult_pgf90_MPICH_GAB.exe + +4P: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM +4P: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham-mult_pgf90_MPICH_4P.exe + +E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -DWHAM +E0LL2Y: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham-mult_pgf90_MPICH_E0LL2Y.exe + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + diff --git a/source/wham/src-HCD/PMFprocess.F b/source/wham/src-HCD/PMFprocess.F new file mode 100644 index 0000000..ff2b43d --- /dev/null +++ b/source/wham/src-HCD/PMFprocess.F @@ -0,0 +1,124 @@ + subroutine PMFread(*) +c Read the PMFs from wham + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.FREE' + include 'COMMON.IOUNITS' + include 'COMMON.FREE' + include 'COMMON.PMF' + integer i,iumb,iiset,j,t,nbin,iparm,nRmax + double precision beta_h_temp,qtemp,htemp + read(inp,*,err=10,end=10) delta_q + write(iout,*) "delta_q",delta_q + + do iparm = 1, nparmset + + write(iout,*) "PMFread: iparm",iparm," nT",nT_h(iparm), + & " nR",nR(:nT_h(iparm),iparm) +c print *,(beta_h(i),i=1,nT(iparm)) + do j=1,nT_h(iparm) + do iumb=1,nR(j,iparm) + read (inp,*,end=10,err=10) iiset,beta_h_temp,nbin + write (iout,*) iiset,beta_h_temp,nbin + if (iiset.ne.iumb) then + write(iout,*) "Error: inconsistency in US windows", + & iiset,iumb + return1 + endif + beta_h_temp=1.0d0/(0.001987*beta_h_temp) + if (dabs(beta_h_temp-beta_h(j,iparm)).gt.1.0d-6) then + write (iout,*) + & "Error replica temperatures do not match PMF temperatures" + write (iout,*) 1.0d0/(0.001987*beta_h_temp), + & 1.0d0/(0.001987*beta_h(j,iparm)) + stop + endif + do i=1,nbin + read (inp,*,end=10,err=10) qtemp,htemp + t = int(qtemp/delta_q+1.0d-4) + write (iout,*) qtemp,t,htemp + if (i.eq.1) tmin(j,iumb,iparm)=t + if (i.eq.nbin) tmax(j,iumb,iparm)=t + PMFtab(t,j,iumb,iparm)=dlog(htemp)/beta_h_temp + enddo ! i + enddo ! iumb + enddo ! j + + nRmax=nR(1,iparm) + do i=2,nT_h(iparm) + if (nR(i,iparm).gt.nRmax) nRmax=nR(i,iparm) + enddo + do iumb=1,nR(j,iparm) + write (iout,*)"Input PMFs, restraint",iumb, + & " q0",q0(1,iumb,:nT_h(iparm),iparm) + write (iout,'(5x,20f10.1)') (1.0d0/(0.001987*beta_h(j,iparm)), + & j=1,nT_h(iparm)) + do i=0,int(1.0/delta_q) + write (iout,'(f5.2,$)') i*delta_q + do j=1,nT_h(iparm) + if (i.lt.tmin(j,iumb,iparm).or.i.gt.tmax(j,iumb,iparm)) then + write (iout,'(" ------",$)') + else + write (iout,'(f10.3$)') PMFtab(i,j,iumb,iparm) + endif + enddo + write (iout,*) + enddo ! i + enddo ! iumb + + enddo ! iparm + return + 10 return1 + end +c------------------------------------------------------------------------ + subroutine PMF_energy(q,irep,iset,iparm,ePMF,ePMF_q) +c Calculate the energy and derivative in q due to the biasing PMF +c Caution! Only ONE q is handled, no multi-D q-restraints available! + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.FREE' + include 'COMMON.IOUNITS' + include 'COMMON.FREE' + include 'COMMON.PMF' + integer i,iqmin,iqmax,irep,iset,iparm + double precision q,qmin,qmax,ePMF,ePMF_q +c Determine the location of the q + iqmin=tmin(irep,iset,iparm) + iqmax=tmax(irep,iset,iparm) + qmin=iqmin*delta_q + qmax=iqmax*delta_q +#ifdef DEBUG + write (iout,*) "PMF_energy q",q," qmin",qmin," qmax",qmax, + & " irep",irep," iset",iset +#endif + if (q.le.qmin) then + ePMF_q=(PMFtab(iqmin+1,irep,iset,iparm)- + & PMFtab(iqmin,irep,iset,iparm))/delta_q + ePMF=PMFtab(iqmin,irep,iset,iparm)+ePMF_q*(q-qmin) +#ifdef DEBUG + write (iout,*) "q<=qmin ePMF",ePMF," ePMF_q",ePMF_q +#endif + else if (q.ge.qmax) then + ePMF_q=(PMFtab(iqmax,irep,iset,iparm)- + & PMFtab(iqmax-1,irep,iset,iparm))/delta_q + ePMF=PMFtab(iqmax,irep,iset,iparm)+ePMF_q*(q-qmax) +#ifdef DEBUG + write (iout,*) "q>=qmax ePMF",ePMF," ePMF_q",ePMF_q +#endif + else + do i=iqmin+1,iqmax + qmax=i*delta_q + if (q.ge.qmin .and. q.le.qmax) then + ePMF_q=(PMFtab(i,irep,iset,iparm)- + & PMFtab(i-1,irep,iset,iparm))/delta_q + ePMF=PMFtab(i-1,irep,iset,iparm)+ePMF_q*(q-qmin) +#ifdef DEBUG + write (iout,*) "qmin zvwNQ>dGGss&pr3tbI(2Z{Rk|XQ9bj75hJoZE+f3lyb*HZ99LaAcv5DnW!_0%_8?R> z(h=}JI;OBU79eYwcH<2{zUMOyKS8VUnhj5zoxa|I+6eR@MJ!wbkOhl$Sq3n|;dw0Z zjNw^ch|fjOF6Q})(?F@;V#QCzkcdlrIewM7^e6o5%nOvB*TJ*AkxT~<2MixI2)K6G z@X^QdV}_48j-Ln@XL%qlKdr0vt zT8Jn=Q5=ifly!>NTI@Zo_)(lw*`Rnyufg6{#XVY}DE*3Oa|oATU0(aG$n6JvAv55I z%xn$#IThi8{nQNTQaVQZ?3D@@i8M_#mvKH}x75Pv+W7|gIVbb6C!9Y};pfzai|NoD zE~P_9I8yl=67al3msclD8$Pu9AHF=43_Tn0>vq7(anzQtL=whAw0x7Rd;zk%oRL|( z{Ty?gF=bzM;vB2R9Q=Z*bmmVo2XtYMt^R4|$g5XxlN3mPs5V?S;KyFUPn{9#2p6Dk%!atV`dibm2HXjPx=nEKJ_N?w zxY`_!h}w>DnP2cKWcTA|M0gHE5|s7_Q{7AR3b(4;{^R zlB)Lz*`Y$TFs<_)Y8jT(=wUi7v8R%6(0a!}xgXsM$8fiP>@%E9W4Y)?oCM5Cbz*NM zu{DzD_m`gwmscm^;ZS8_Q+1*zoE=FNh9k-AzNk#R7D*r`A_342J7)*s4%6tp@h%SPu&~TnQ1#%!F=_nM^TylC!;y}OM5Uw zo3g$DDKYS7W)or0pjeo3L%l(jPQQ2n= z^h1SqMsUH9%06pUpV0$_p(Ghel}DuV3sXtYD(1+URH~kF>4Tc=j6e0^&BILRlhw3PsA?~_hyv=DO#vXFh8VT66)`nWpJQ*K@-edOX1LSlV2Ise zW(8NbkOf_@D9kXYbH{}m^; zP36+fk;MmJKG?zg(4& zjTU#(5Vc#oP|E3Py_DM_VfSL8CdtbQ;v2~x4zfB0%dskH+g2s*zF(EJy&2zEH(dhl zp+cKIY4U6h88v8YSQ*vf{5eQlbCTg>BrLNU+g{Z-AwAc;d~n^es=mQEunP#GpO)se zhk*qT8(;g_C8qnaLXnVl28lwJz(zr?lC!tzOqM3L3Y=N3RSBCVc(cF)GEJ(I)t6wa z4DnqJ;>tz`5r6q6T=SSBJyH%i6W+ae;gOE+(=fJFF#gZ>(C2Nm;0{wO20?N5YVXVJ0YY(;z+!W(Z z7}kZRy=uD0yp>oN(hR0+?07JqFx0~KDk%=Zd2$Xn@|2_>$6G_`k4(U%#;G zR=WRIuV9AlRdOY5(}Q=`={H#R?Le)0J7DjuNvs1&$Gxql{Ae>}DQcNBWwC^JbGQIG z=>-UKvVkMPY02C#$j5G6F;z3Fwq(BOrY zrgwQOhUE1I$xqnMCfl7SlCax4F5z|>*ZD>Sqd!2W_Ra@6q^!IS>Eo%dQtPYjty|Ms zktX92I54o=sKrjf6}&ghk7T`vOY*1}%6;F;VD)1zvCr8XIaL4G`z5w~>F1BwF6n-I z=qsa0GWSiGis*12t|H0!d}JE);)q^`VwA7)DD7P_926?F2sPeIQDZUG?Cmef@%D$> z1W^*^irj=E-P_5b=PW?J`)Qsynx>$DZ_r(g6!3%ff7%3a{0?zCMij9p~wa$}dV zaAa_Ff$1|ix*^aCBXB<0XZ~QHd1NFtrtV>h-q>pF7fp}D0CGy&KOyoO$zjIun@Uq#WBY=+i`qMy zi)MO7-SLI-#<@7>$8IEsNvcyq3;-uYJMI9W4v$t$e+=uroftF<$T8+_;dL(NXW! z*LSqfonPPG-Ev`lcl&~-&Tg-0VP|t=ywR(_u)U+WwWG5!-qqOj7cKFki@c(_-Q8YC zXH#Rm1=7te^~Rj~a5P#}TvXzri}{N>&<%?$fI0OGTe{JW)-`#u*SWBLUVZDr#`!J7 zU7spSoPLH;Q+ho6v*Xd^3x{DBc?(-w;lV{susGh<5^sc|=2+i2w|zl-yd8e*ZlbYt z)O%emUGce{3!2Hb&FxJzC^!=u06G^z8lZIn27_Z)OiZKDEWMkvg2) z*?bGs#}~H5o7(EVq6MAtmZERWzWV&`IK1r@HMh)NG!K)rpv5a{X|sO9)U4j+$tA%76A zU{2o~Nq;uW&vy7Y;(UHBAI1J<=U7nh@Y7J2WYwoQEm$f)v_~nX++0H7(d)S_DDqgYIHn?8#u`#5 z@$)XtInMVfE^&3x;S|qxd#(K+E53~V@VVkoF&{w_f+F*>ocUOXlbtfIaSo?`*RcEq z#l_D>4mWyuTvHuRdc@Du98U6*H?B}z)+zs;NjeY6y0}WoOP-7>F7er*xX8~_yoBvv zq&aM*a+~6khwspw^(h+B>OSs^r5gU*mA)G11@(jT_i z`;n55vi{YYv;M~wFJL|IIGn~RpXBE@IzcH` z+`Gy0ixoe_d3Czt*(^UxagR6fTE(-Ow=3Sy`)^$F#nv3}yNdTR|DNJe=JwCO2FJ_h zdp}n4cd`86D!zpqtW`Y4{0YTBWxihVe&!n$-^F~3;-9h~UQ;~6cJ5Jp3(LQ+_#x*1 zsd$9r@QC7~=LAa1C=w?tS$@3Y4MxiI&QiRFd4b|7w&ya%_p=}7XwLF;72m~t9&?KS zGw>t%woA#2{ol^OdmV1p9X|&p98T+H75iaj27bTdt66@v!znKnhpNxwX|PIu&uA9%j19Zt`!A^cEjaJU&4>z}817xND0IkUjK6<)@B3xlrPBv%}r{oZSw0^Y-c4MqPS6%6d6lamm}~DZZG;Rie1~`BKFt zKg?9Tm-Wn1yp4HO@fzlhir>ZjMu(euxzCQXTk$UDy$+|imHjBGxa>!(9ZvciSkGGK zG{01pdHI==Px1ZCOG=)%U2m6?-_PMNgQgfF7mg16s>J%?U-&DF3mprgUbJo8?anWypt#txh`HD=aek|k|CH^&L-8`UC#gBx zbFbnBEdQY9EdPk&lK&r9TzLoBc$DqDQ}G7of2DW<^S@JkE$e?$ z@qXs(6)$Byn-#BN{;J|-%=ai>%>01j8@S)2inp=+i9FAAndWN?`}q{b*D^m-@eRxi z72m@BmMFf9<;xXc$Gk@IXIM{EbCz#Vd>6~NDPE8=Vd8ZuF7qYvE`I1@`CD0@;@rL8 z{(+;%tfR?R|2>KyqKhaGDc;5Rt4}-J?1L#I?meG@Z+AHDgZ(^@I~`7X7PFo`8TbK* zlb&6y=Oc%co?g~-#Ni~LV)>CL;{=8LM%%J={{Wgz1QJ1-Vp2gF>{?i*Ja?_ z9Zp-i?E5<%{cb-0*pYYdw@)04#wfbqYUVVLG+zZ>B;|S6Xr40IYf!w5`HhN4n8y{5 zGQUmn2IeaiFJ->U;U<3W^GtbIar;j!Jnw0T)3`!Bu8j^SJs#`Xs(2prH#6{kis!TZ z2Z|RkKjLt*Cy(tp(I+DY-#-*H&(l0*#JqgwG>>%8BKJ{WbL7W^-^KUaGn70pXK#*@ zU&--K6uL;|bDCdT*D_yMJKVh= zyWZg>FW=3ZGw=?@<-2*e!^v-w4{v2o`GNGyck}N%-2HC8($Pcm^4)xu!)dQzO1->-`TCWd}rUMxO``SPjUIqKA<_jfBRB#Sr?;nFc=h?FB+G8&mF6{ zd}kc*aPqV8vo+^^ut@Pjw4pN9;neRk_RloMkETf4^R7@_zV}rrF5kJXayZ#ZdkK{~ z#pUk-nlxv7IvsA}li%Zg+u>xt=wG6^68Xz84QDE`L|> znc{2MpZH%5Op!R3zoQtf_){!DR`CG)d7R?%{cD2awJaabz|V6y#iz{gMVj+Ey42w& z-dKNy;$h~q6z^dEO~nhD#}tn=2W|88uE_xJ~I9#f@P_9amh=Y9q#UfyEE_+r&_}(Zt0bV z_;aGe-TUMchr9Z}<8Zp~5YeR6bVvC4P=5`5M+gmJ`18Tf_QKXHN6w-rwdc zF8(jbz%Ot(jZ41QU&dVe&Brw=-%#?hF6JnC`QCkl=4}6b#S5%@Z@JPh_gD8i^5n}; z*`W_9zL?(|tW*5c$+m-M9qvAdZe>pXbmKXdfq&s}@{z>nC{l_-Oy-=<&t^{gsj0|c z>~Oc=?>c%Y56g4eGR5UNbcNzwDKtV^rMSHJcv$hfQbyc+O!1Y>f2sIt<{K1W%lt*f zm*>I#4ktgz^Wb5{<#{lhl%h!7%JXTV!%5Go6iIpB6y~yyWL_>; zT=tQOqlc=i`T6b!#aA)EQR$KO*sbK(viyCD%lCyx6qolrPbi+p>+4yE(|FgV@C)U6 zhf`Jb>{ML73;a%Td5?5R@qF(0bHznINJgN@yvTd|(-oKZLT4*p!1~WqT;%hOcKT1f z2A}l_J)^k%LkanNRFRkeaB49D6yd$R&Wmla7ytO*A zMyB!CchqcI$%19<9^w2nCa32AXQTGohW<0GNNHNqR>%&wEWrse{wuHarEK2E^3%jt zbpQ1KrHxiHbSmxjC9>5m^#7`9M%VwR?dkttqxO3I(te9lF8&uA= +#include +#include +#include +#include + +main() +{ +FILE *in, *in1, *out; +int i,j,k,iv1,iv2,iv3; +char *p1,buf[500],buf1[500],buf2[100],buf3[100]; +struct utsname Name; +time_t Tp; + +in=fopen("cinfo.f","r"); +out=fopen("cinfo.f.new","w"); +if (fgets(buf,498,in) != NULL) + fprintf(out,"C DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C\n"); +if (fgets(buf,498,in) != NULL) + sscanf(&buf[1],"%d %d %d",&iv1,&iv2,&iv3); +iv3++; +fprintf(out,"C %d %d %d\n",iv1,iv2,iv3); +fprintf(out," subroutine cinfo\n"); +fprintf(out," include 'COMMON.IOUNITS'\n"); +fprintf(out," write(iout,*)'++++ Compile info ++++'\n"); +fprintf(out," write(iout,*)'Version %d.%-d build %d'\n",iv1,iv2,iv3); +uname(&Name); +time(&Tp); +system("whoami > tmptmp"); +in1=fopen("tmptmp","r"); +if (fscanf(in1,"%s",buf1) != EOF) +{ +p1=ctime(&Tp); +p1[strlen(p1)-1]='\0'; +fprintf(out," write(iout,*)'compiled %s'\n",p1); +fprintf(out," write(iout,*)'compiled by %s@%s'\n",buf1,Name.nodename); +fprintf(out," write(iout,*)'OS name: %s '\n",Name.sysname); +fprintf(out," write(iout,*)'OS release: %s '\n",Name.release); +fprintf(out," write(iout,*)'OS version:',\n"); +fprintf(out," & ' %s '\n",Name.version); +fprintf(out," write(iout,*)'flags:'\n"); +} +system("rm tmptmp"); +fclose(in1); +in1=fopen("Makefile","r"); +while(fgets(buf,498,in1) != NULL) + { + if((p1=strchr(buf,'=')) != NULL && buf[0] != '#') + { + buf[strlen(buf)-1]='\0'; + if(strlen(buf) > 49) + { + buf[47]='\0'; + strcat(buf,"..."); + } + else + { + while(buf[strlen(buf)-1]=='\\') + { + strcat(buf,"\\"); + fprintf(out," write(iout,*)'%s'\n",buf); + if (fgets(buf,498,in1) != NULL) + buf[strlen(buf)-1]='\0'; + if(strlen(buf) > 49) + { + buf[47]='\0'; + strcat(buf,"..."); + } + } + } + + fprintf(out," write(iout,*)'%s'\n",buf); + } + } +fprintf(out," write(iout,*)'++++ End of compile info ++++'\n"); +fprintf(out," return\n"); +fprintf(out," end\n"); +fclose(out); +fclose(in1); +fclose(in); +system("mv cinfo.f.new cinfo.f"); +} diff --git a/source/wham/src-HCD/conf_compar.F b/source/wham/src-HCD/conf_compar.F new file mode 100644 index 0000000..a23c753 --- /dev/null +++ b/source/wham/src-HCD/conf_compar.F @@ -0,0 +1,403 @@ + subroutine conf_compar(jcon,lprn,print_class) + implicit real*8 (a-h,o-z) +#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),ipermmin + integer isecstr(maxres) + integer itemp(maxfrag) + character*4 liczba + double precision Epot +c print *,"Enter conf_compar",jcon + if (lprn) then + write (iout,*) "phi_ref theta_ref" + do i=1,nres + write (iout,"(i5,2f8.3)") i,theta_ref(i),phi_ref(i) + enddo + endif + rms_nat=rmsnat(jcon,ipermmin) + qnat=qwolynes(0,0,ipermmin) + call angnorm12(rmsang,ipermmin) +c Level 1: check secondary and supersecondary structure + call elecont(lprn,ncont,icont,nnt,nct,ipermmin) + 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,ipermmin) + 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_frag(0,1,j,jcon,ipermmin,lprn) +c Compare electrostatic contacts in the current conf with that in the native +c structure. + if (lprn) write (iout,*) + & "Comparing electrostatic contact map and local structure" + call flush(iout) + ncnat=ncont_frag_ref(ind) +c write (iout,*) "before match_contact:",nc_fragm(j,1), +c & nc_req_setf(j,1) +c call flush(iout) + call match_secondary(j,isecstr,nsec_match,ipermmin,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),ipermmin,.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),ipermmin,.true.,lprn) + else if (iloc(j).gt.0) then +c 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),ipermmin,.true.,lprn) +c 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,ipermmin) + if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 + if (lprn) write (iout,*) "ishift",ishif," nc_match",nc_match +c 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_frag(-ishiff,1,j,jcon,ipermmin,lprn) +c write(iout,*)"jcon,i,j,ishiff",jcon,i,j,-ishiff, +c & " 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_frag(ishiff,1,j,jcon,ipermmin,lprn) +c write (iout,*) "jcon,1,j,ishiff",jcon,1,j,ishiff, +c & " rms",rms + endif + if (lprn) write (iout,*) "rms",rmsfrag(j,1) + enddo +c write (iout,*) "After loop: rms",rms, +c & " rmscut",rmscutfrag(1,j,1) +c 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 +c write (iout,*) "iclass_rms",iclass_rms + endif +c write (iout,*) "ishif",ishif + if (iabs(ishifft_rms).gt.iabs(ishif)) ishif=ishifft_rms + else + iclass_rms=1 + endif +c write (iout,*) "ishif",ishif," iclass",iclass(j,1), +c & " 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 +c write (iout,*) "iclass",iclass(j,1) + enddo +c 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 +c 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,ipermmin,.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,ipermmin,.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,ipermmin) + if (lprn) write (iout,*) + & "Comparing rms: fragments", + & (ipiece(k,j,i),k=1,npiece(j,i)) + rmsfrag(j,i)=rmscalc_frag(0,i,j,jcon,ipermmin,lprn) + if (lprn) write (iout,*) "ij",i,j,"rmsfrag",rmsfrag(j,i), + & " irma",irms(j,i) + if (irms(j,i).gt.0) then + iclass_rms=0 + ishifft_rms=0 + if (lprn) write (iout,*) "rms",rmsfrag(j,i) +c write (iout,*) "i",i," j",j," rmsfrag",rmsfrag(j,i), +c & " 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_frag(-ishif,i,j,jcon,ipermmin,lprn) +c 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_frag(ishif,i,j,jcon,ipermmin,lprn) +c 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 +C 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 +c write (iout,*) "i",i," j",j," idig",idig," iex",iex, +c & " 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 +c write (iout,*) "i",i," j",j," idig",idig," iex",iex, +c & " 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 +c write (iout,*) "i",i," j",j," idig",idig," iex",iex, +c & " 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 diff --git a/source/wham/src-HCD/cont_frag.f b/source/wham/src-HCD/cont_frag.f new file mode 100644 index 0000000..63a7717 --- /dev/null +++ b/source/wham/src-HCD/cont_frag.f @@ -0,0 +1,99 @@ + subroutine contacts_between_fragments(lprint,is,ncont,icont, + & ncont_interfrag,icont_interfrag) + 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 +c 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 +c write (iout,*) "i",i,(ifrag(1,k,i),ifrag(2,k,i) +c & ,k=1,npiece(i,1)) +c write (iout,*) "j",j,(ifrag(1,k,j),ifrag(2,k,j) +c & ,k=1,npiece(j,1)) +c 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 +c write(iout,*) "k",k," ic1",ic1," ic2",ic2," OK1",OK1, +c & " OK2",OK2 + if (OK1.and.OK2) then + nc=nc+1 + icont_interfrag(1,nc,ind)=ic1 + icont_interfrag(2,nc,ind)=ic2 +c write (iout,*) "nc",nc," ic1",ic1," ic2",ic2 + endif + enddo + ncont_interfrag(ind)=nc +c do k=1,ncont_interfrag(ind) +c i1=icont_interfrag(1,k,ind) +c i2=icont_interfrag(2,k,ind) +c it1=itype(i1) +c it2=itype(i2) +c write (iout,'(i3,2x,a,i4,2x,a,i4)') +c & i,restyp(it1),i1,restyp(it2),i2 +c 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 diff --git a/source/wham/src-HCD/contact.f b/source/wham/src-HCD/contact.f new file mode 100644 index 0000000..bccbadb --- /dev/null +++ b/source/wham/src-HCD/contact.f @@ -0,0 +1,176 @@ + subroutine contact(lprint,ncont,icont,ist,ien,ipermmin) + 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*8 csc,dist + real*8 cscore(maxcont),omt1(maxcont),omt2(maxcont),omt12(maxcont), + & ddsc(maxcont),ddla(maxcont),ddlb(maxcont) + integer ncont,icont(2,maxcont) + real*8 u,v,a(3),b(3),dla,dlb + logical lprint + integer iperm,ipermmin,ii,jj + 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)) + ii = iperm(i,ipermmin) + if (iti.le.0 .or. iti.gt.ntyp) cycle + do j=i+kkk,ien + jj = iperm(j,ipermmin) + itj=iabs(itype(j)) + if (itj.le.0 .or. itj.gt.ntyp) cycle + itypi=iti + itypj=itj + xj = c(1,nres+jj)-c(1,nres+ii) + yj = c(2,nres+jj)-c(2,nres+ii) + zj = c(3,nres+jj)-c(3,nres+ii) + dxi = dc_norm(1,nres+ii) + dyi = dc_norm(2,nres+ii) + dzi = dc_norm(3,nres+ii) + dxj = dc_norm(1,nres+jj) + dyj = dc_norm(2,nres+jj) + dzj = dc_norm(3,nres+jj) + do k=1,3 + a(k)=dc(k,nres+ii) + b(k)=dc(k,nres+jj) + enddo +c 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 +c write(iout,*) "i",i," j",j," dla",dla,dsc(iti), +c & " dlb",dlb,dsc(itj)," csc",csc,sc_cutoff(iti,itj), +c & dxi,dyi,dzi,dxi**2+dyi**2+dzi**2, +c & dxj,dyj,dzj,dxj**2+dyj**2+dzj**2,om1,om2,om12, +c & xj,yj,zj +c write(iout,*)'egb',itypi,itypj,chi1,chi2,chip1,chip2, +c & sig0ij,rij,rrij,om1,om2,om12,chiom1,chiom2,chiom12, +c & chipom1,chipom2,chipom12,sig,eps2rt,rij_shift,e2,evdw, +c & 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 +c---------------------------------------------------------------------------- + double precision function contact_fract(ncont,ncont_ref, + & icont,icont_ref) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + integer i,j,nmatch + integer ncont,ncont_ref,icont(2,maxcont),icont_ref(2,maxcont) + nmatch=0 +c print *,'ncont=',ncont,' ncont_ref=',ncont_ref +c write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) +c write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) +c write (iout,'(20i4)') (icont(1,i),i=1,ncont) +c write (iout,'(20i4)') (icont(2,i),i=1,ncont) + do i=1,ncont + do j=1,ncont_ref + if (icont(1,i).eq.icont_ref(1,j) .and. + & icont(2,i).eq.icont_ref(2,j)) nmatch=nmatch+1 + enddo + enddo +c print *,' nmatch=',nmatch +c contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) + contact_fract=dfloat(nmatch)/dfloat(ncont_ref) + return + end +c------------------------------------------------------------------------------ + subroutine pept_cont(lprint,ncont,icont) + 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 + real*8 dist + real*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 diff --git a/source/wham/src-HCD/contfunc.f b/source/wham/src-HCD/contfunc.f new file mode 100644 index 0000000..7aed575 --- /dev/null +++ b/source/wham/src-HCD/contfunc.f @@ -0,0 +1,96 @@ + subroutine contfunc(cscore,itypi,itypj) +C +C This subroutine calculates the contact function based on +C the Gay-Berne potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTPAR' + include 'COMMON.CALC' + integer expon /6/ +C + 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) +C 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 +c print *,'egb',itypi,itypj,chi1,chi2,chip1,chip2, +c & sig0ij, +c & rij,rrij,om1,om2,om12 +C Calculate eps1(om12) + faceps1=1.0D0-om12*chiom12 + faceps1_inv=1.0D0/faceps1 + eps1=dsqrt(faceps1_inv) +C Following variable is eps1*deps1/dom12 + eps1_om12=faceps1_inv*chiom12 +C 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 +C Calculate eps2 and its derivatives in om1, om2, and om12. + chipom1=chip1*om1 + chipom2=chip2*om2 + chipom12=chip12*om12 + facp=1.0D0-om12*chipom12 + facp_inv=1.0D0/facp + facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12 +C 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 +c------------------------------------------------------------------------------ + subroutine scdist(cscore,itypi,itypj) +C +C This subroutine calculates the contact distance +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTPAR' + include 'COMMON.CALC' +C + chi1=chi_comp(itypi,itypj) + chi2=chi_comp(itypj,itypi) + chi12=chi1*chi2 + rrij=xj*xj+yj*yj+zj*zj + rij=dsqrt(rrij) +C 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 diff --git a/source/wham/src-HCD/cxread.F b/source/wham/src-HCD/cxread.F new file mode 100644 index 0000000..cd29176 --- /dev/null +++ b/source/wham/src-HCD/cxread.F @@ -0,0 +1,340 @@ + subroutine cxread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm,*) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + integer MaxTraj + 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*64 nazwa,bprotfile_temp + real*4 rtime,rpotE,ruconst,rt_bath,rprop(maxQ) + double precision time + integer iret,itmp,itraj,ntraj + real xoord(3,maxres2+2),prec + integer nstep(0:MaxTraj-1) + integer ilen + external ilen + integer ii,jj(maxslice),kk(maxslice),ll(maxslice),mm(maxslice) + integer is(MaxSlice),ie(MaxSlice),nrec_slice + double precision ts(MaxSlice),te(MaxSlice),time_slice + integer slice + logical conf_check + write (iout,*) "cxread" + call flush(iout) + call set_slices(is,ie,ts,te,iR,ib,iparm) + write (iout,*) "after set_slices" + call flush(iout) + 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) return1 + + islice1=1 + call opentmp(islice1,ientout,bprotfile_temp) +c print *,"bumbum" + do while (iret.gt.0) + +#if (defined(AIX) && !defined(JUBL)) + call xdrffloat_(ixdrf, rtime, iret) +c print *,"rtime",rtime," iret",iret + call xdrffloat_(ixdrf, rpotE, iret) +c write (iout,*) "rpotE",rpotE," iret",iret +c call flush(iout) + call xdrffloat_(ixdrf, ruconst, iret) + call xdrffloat_(ixdrf, rt_bath, iret) + call xdrfint_(ixdrf, nss, iret) + do j=1,nss + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j), iret) + call xdrfint(ixdrf, jdssb(j), iret) + idssb(j)=idssb(j)-nres + jdssb(j)=jdssb(j)-nres + else + call xdrfint_(ixdrf, ihpb(j), iret) + call xdrfint_(ixdrf, jhpb(j), iret) + endif + 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) +c write (iout,*) "rpotE",rpotE," iret",iret +c call flush(iout) + call xdrffloat(ixdrf, ruconst, iret) + call xdrffloat(ixdrf, rt_bath, iret) + call xdrfint(ixdrf, nss, iret) +c write (iout,*) "ruconst",ruconst," rt_bath",rt_bath," nss",nss +c call flush(iout) + do j=1,nss + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j), iret) + call xdrfint(ixdrf, jdssb(j), iret) + else + call xdrfint(ixdrf, ihpb(j), iret) + call xdrfint(ixdrf, jhpb(j), iret) + endif + enddo + call xdrfint(ixdrf, nprop, iret) +c write (iout,*) "nprop",nprop + 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)) +#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 +c rprop(2)=dsqrt(rprop(2)) +c 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,itmp) +#endif + 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 +c write (iout,*) "calling slice" +c call flush(iout) + islice=slice(nstep(itraj),time,is,ie,ts,te) +c write (iout,*) "islice",islice +c call flush(iout) + + 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 +c Box shift + call oligomer + do i=1,nres + do j=1,3 + xoord(j,i)=c(j,i) + enddo + enddo + do i=1,nct-nnt+1 + do j=1,3 + xoord(j,i+nres)=c(j,i+nres+nnt-1) + enddo + enddo +c end change + + 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 +#ifdef DEBUG + write (iout,*) "islice",islice," ii",ii," kk",kk(islice), + & " mm",mm(islice) + write (iout,*) "itraj",itraj," nstep",nstep(itraj), + & " isampl",isampl(iparm) + call flush(iout) +#endif + if (mod(nstep(itraj),isampl(iparm)).eq.0 .and. + & conf_check(ll(islice)+1,1)) then + if (replica(iparm)) then + if (rt_bath.eq.0.0d0) then + write (iout,*) "ERROR: zero temperature", + & islice,kk(islice),mm(islice) + call flush(iout) + endif + 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) +c exit +c 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 + write (iout,*) "nss",nss + write (iout,*) (ihpb(k),jhpb(k),k=1,nss) +c if (replica(iparm)) then +c write (iout,*) "TEMP",1.0d0/(rt_bath*1.987D-3) +c write (iout,*) "TEMP list" +c write (iout,*) +c & (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) +c endif +c write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ +c write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss",nss +c write (iout,*) "length",nres*4+(nct-nnt+1)*4+4+2*nss*4 + call flush(iout) +#endif + if (islice.ne.islice1) then +c write (iout,*) "islice",islice," islice1",islice1 + close(ientout) +c write (iout,*) "Closing file ", +c & bprotfile_temp(:ilen(bprotfile_temp)) + call opentmp(islice,ientout,bprotfile_temp) +c write (iout,*) "Opening file ", +c & 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" + call intout + 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) +c 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) + return + end diff --git a/source/wham/src-HCD/cxread.F.org b/source/wham/src-HCD/cxread.F.org new file mode 100644 index 0000000..80bc1a0 --- /dev/null +++ b/source/wham/src-HCD/cxread.F.org @@ -0,0 +1,248 @@ + subroutine cxread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm,*) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + integer MaxTraj + 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*64 nazwa,bprotfile_temp + real*4 rtime,rpotE,ruconst,rt_bath,rprop(maxQ) + double precision time + integer iret,itmp,itraj,ntraj + real xoord(3,maxres2+2),prec + integer nstep(0:MaxTraj-1) + integer ilen + external ilen + integer ii,jj(maxslice),kk(maxslice),ll(maxslice),mm(maxslice) + integer is(MaxSlice),ie(MaxSlice),nrec_slice + double precision ts(MaxSlice),te(MaxSlice),time_slice + integer slice + call set_slices(is,ie,ts,te,iR,ib,iparm) + + 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) return1 + + islice1=1 + call opentmp(islice1,ientout,bprotfile_temp) +c print *,"bumbum" + do while (iret.gt.0) + +#if (defined(AIX) && !defined(JUBL)) + call xdrffloat_(ixdrf, rtime, iret) +c print *,"rtime",rtime," iret",iret + call xdrffloat_(ixdrf, rpotE, iret) +c write (iout,*) "rpotE",rpotE," iret",iret + 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) + do i=1,nprop + call xdrffloat_(ixdrf, rprop(i), iret) + enddo +#else + call xdrffloat(ixdrf, rtime, iret) + call xdrffloat(ixdrf, rpotE, iret) +c write (iout,*) "rpotE",rpotE," iret",iret + 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) +c write (iout,*) "nprop",nprop + call flush(iout) + do i=1,nprop + call xdrffloat(ixdrf, rprop(i), iret) + enddo +#endif + if (iret.eq.0) exit + itraj=mod(it,totraj(iR,iparm)) +#ifdef DEBUG + write (iout,*) "ii",ii," itraj",itraj +#endif + call flush(iout) + it=it+1 + if (itraj.gt.ntraj) ntraj=itraj + nstep(itraj)=nstep(itraj)+1 +#ifdef DEBUG + write (iout,*) rtime,rpotE,rt_bath,nss, + & (ihpb(j),jhpb(j),j=1,nss),(rprop(j),j=1,nprop) + 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,itmp) +#endif + 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 +c write (iout,*) "calling slice" +c call flush(iout) + islice=slice(nstep(itraj),time,is,ie,ts,te) +c write (iout,*) "islice",islice +c call flush(iout) + + 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 + 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) + endif + else + iib = ib + endif + + efree=0.0d0 + jj(islice)=jj(islice)+1 + snk(iR,iib,iparm,islice)=snk(iR,iib,iparm,islice)+1 + 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 +c if (replica(iparm)) then +c write (iout,*) "TEMP",1.0d0/(rt_bath*1.987D-3) +c write (iout,*) "TEMP list" +c write (iout,*) +c & (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) +c endif + write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ +c write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss",nss +c write (iout,*) "length",nres*4+(nct-nnt+1)*4+4+2*nss*4 + call flush(iout) +#endif + if (islice.ne.islice1) then +c write (iout,*) "islice",islice," islice1",islice1 + close(ientout) +c write (iout,*) "Closing file ", +c & bprotfile_temp(:ilen(bprotfile_temp)) + call opentmp(islice,ientout,bprotfile_temp) +c write (iout,*) "Opening file ", +c & bprotfile_temp(:ilen(bprotfile_temp)) + islice1=islice + endif + 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 +#ifdef DEBUG + 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 + 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) +c write (iout,'(8f10.5)') (rprop(j),j=1,nQ) + write (iout,'(16i5)') iscor + call flush(iout) +#endif + endif + endif + + enddo + 112 continue + 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) + return + end diff --git a/source/wham/src-HCD/define_pairs.f b/source/wham/src-HCD/define_pairs.f new file mode 100644 index 0000000..00866a8 --- /dev/null +++ b/source/wham/src-HCD/define_pairs.f @@ -0,0 +1,120 @@ + subroutine define_pairs + 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' + 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 diff --git a/source/wham/src-HCD/dfa.F b/source/wham/src-HCD/dfa.F new file mode 100644 index 0000000..0ca5045 --- /dev/null +++ b/source/wham/src-HCD/dfa.F @@ -0,0 +1,3549 @@ + subroutine init_dfa_vars + + include 'DIMENSIONS' + include 'COMMON.INTERACT' + include 'COMMON.DFA' + + integer ii + +C Number of restraints + idisnum = 0 + iphinum = 0 + ithenum = 0 + ineinum = 0 + + idislis = 0 + iphilis = 0 + ithelis = 0 + ineilis = 0 + jneilis = 0 + jneinum = 0 + kshell = 0 + fnei = 0 +C For beta + nca = 0 + icaidx = 0 + +C real variables +CC WEIGHTS for each min + sccdist = 0.0d0 + fdist = 0.0d0 + sccphi = 0.0d0 + sccthe = 0.0d0 + sccnei = 0.0d0 + fphi1 = 0.0d0 + fphi2 = 0.0d0 + fthe1 = 0.0d0 + fthe2 = 0.0d0 +C energies + edfatot = 0.0d0 + edfadis = 0.0d0 + edfaphi = 0.0d0 + edfathe = 0.0d0 + edfanei = 0.0d0 + edfabet = 0.0d0 +C weights for each E term +C these should be identical with + dis_inc = 0.0d0 + phi_inc = 0.0d0 + the_inc = 0.0d0 + nei_inc = 0.0d0 + beta_inc = 0.0d0 + wshet = 0.0d0 +C precalculate exp table! +c dfaexp = 0.0d0 +c do ii = 1, 15001 +c dfaexp(ii) = exp(-ii*0.001d0 + 0.0005d0) +c end do + + ishiftca=nnt-1 + ilastca=nct + + print *,'ishiftca=',ishiftca,'ilastca=',ilastca + + return + end + + + subroutine read_dfa_info +C +C read fragment informations +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DFA' + include 'COMMON.FFIELD' + + +C NOTE THAT FILENAMES are FIXED, CURRENTLY!! +C THIS SHOULD BE MODIFIED!! + + character*320 buffer + integer iodfa + parameter(iodfa=89) + + integer i, j, nval + integer ica1, ica2,ica3,ica4,ica5 + integer ishell, inca, itmp,iitmp + double precision wtmp +C +C READ DISTANCE +C + open(iodfa, file = 'dist_dfa.dat', status = 'old', err=33) + goto 34 + 33 write(iout,'(a)') 'Error opening dist_dfa.dat file' + stop + 34 continue + write(iout,'(a)') 'dist_dfa.dat is opened!' +C read title + read(iodfa, '(a)') buffer +C read number of restraints + read(iodfa, *) IDFADIS + read(iodfa, *) dis_inc + do i=1, idfadis + read(iodfa, '(i10,1x,i10,1x,i10)') ica1, ica2, nval + + idisnum(i)=nval + idislis(1,i)=ica1 + idislis(2,i)=ica2 + + do j=1, nval + read(iodfa,*) tmp + fdist(i,j) = tmp + enddo + + do j=1, nval + read(iodfa,*) tmp + sccdist(i,j) = tmp + enddo + + enddo + close(iodfa) + +C READ ANGLE RESTRAINTS +C PHI RESTRAINTS + open(iodfa, file='phi_dfa.dat',status='old',err=35) + goto 36 + 35 write(iout,'(a)') 'Error opening dist_dfa.dat file' + stop + + 36 continue + write(iout,'(a)') 'phi_dfa.dat is opened!' + +C READ TITLE + read(iodfa, '(a)') buffer +C READ NUMBER OF RESTRAINTS + READ(iodfa, *) IDFAPHI + read(iodfa,*) phi_inc + do i=1, idfaphi + read(iodfa,'(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval + + iphinum(i)=nval + + iphilis(1,i)=ica1 + iphilis(2,i)=ica2 + iphilis(3,i)=ica3 + iphilis(4,i)=ica4 + iphilis(5,i)=ica5 + + do j=1, nval + read(iodfa,*) tmp1,tmp2 + fphi1(i,j) = tmp1 + fphi2(i,j) = tmp2 + enddo + + do j=1, nval + read(iodfa,*) tmp + sccphi(i,j) = tmp + enddo + + enddo + close(iodfa) + +C THETA RESTRAINTS + open(iodfa, file='theta_dfa.dat',status='old',err=41) + goto 42 + 41 write(iout,'(a)') 'Error opening dist_dfa.dat file' + stop + 42 continue + write(iout,'(a)') 'theta_dfa.dat is opened!' +C READ TITLE + read(iodfa, '(a)') buffer +C READ NUMBER OF RESTRAINTS + READ(iodfa, *) IDFATHE + read(iodfa,*) the_inc + + do i=1, idfathe + read(iodfa, '(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval + + ithenum(i)=nval + + ithelis(1,i)=ica1 + ithelis(2,i)=ica2 + ithelis(3,i)=ica3 + ithelis(4,i)=ica4 + ithelis(5,i)=ica5 + + do j=1, nval + read(iodfa,*) tmp1,tmp2 + fthe1(i,j) = tmp1 + fthe2(i,j) = tmp2 + enddo + + do j=1, nval + read(iodfa,*) tmp + sccthe(i,j) = tmp + enddo + + enddo + close(iodfa) +C END of READING ANGLE RESTRAINT! + +C NUMBER OF NEIGHBOR CAs + open(iodfa,file='nei_dfa.dat',status='old',err=37) + goto 38 + 37 write(iout,'(a)') 'Error opening nei_dfa.dat file' + stop + 38 continue + write(iout,'(a)') 'nei_dfa.dat is opened!' +C READ TITLE + read(iodfa, '(a)') buffer +C READ NUMBER OF RESTRAINTS + READ(iodfa, *) idfanei + read(iodfa,*) nei_inc + + do i=1, idfanei + read(iodfa,'(2(i10,1x),i10)')ica1,ishell,nval + + ineilis(i)=ica1 + kshell(i)=ishell + ineinum(i)=nval + + do j=1, nval + read(iodfa,*) inca + fnei(i,j) = inca +C write(*,*) 'READ NEI:',i,j,fnei(i,j) + enddo + + do j=1, nval + read(iodfa,*) tmp + sccnei(i,j) = tmp + enddo + + enddo + close(iodfa) +C END OF NEIGHBORING CA + +C READ BETA RESTRAINT + if (wdfa_beta.eq.0.0) return + open(iodfa, file='beta_dfa.dat',status='old',err=39) + goto 40 + 39 write(iout,'(a)') 'Error opening beta_dfa.dat file' + stop + 40 continue + write(iout,'(a)') 'beta_dfa.dat is opened!' + + read(iodfa,'(a)') buffer + read(iodfa,*) itmp + read(iodfa,*) beta_inc + + do i=1,itmp + read(iodfa,*) ica1, iitmp + do j=1,itmp + read(iodfa,*) wtmp + wshet(i,j) = wtmp +c write(*,*) 'BETA:',i,j,wtmp,wshet(i,j) + enddo + enddo + + close(iodfa) +C END OF BETA RESTRAINT + + return + END + + subroutine edfad(edfadis) + + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.DFA' + + double precision edfadis + integer i, iatm1, iatm2,idiff + double precision ckk, sckk,dist,texp + double precision jix,jiy,jiz,ep,fp,scc + + edfadis=0 + gdfad=0.0d0 + + do i=1, idfadis + + iatm1=idislis(1,i)+ishiftca + iatm2=idislis(2,i)+ishiftca + idiff = abs(iatm1-iatm2) + + JIX=c(1,iatm2)-c(1,iatm1) + JIY=c(2,iatm2)-c(2,iatm1) + JIZ=c(3,iatm2)-c(3,iatm1) + DIST=SQRT(JIX*JIX+JIY*JIY+JIZ*JIZ) + + ckk=ck(idiff) + sckk=sck(idiff) + + scc = 0.0d0 + ep = 0.0d0 + fp = 0.0d0 + + do j=1,idisnum(i) + + dd = dist-fdist(i,j) + dtmp = dd*dd/ckk + if (dtmp.ge.15.0d0) then + texp = 0.0d0 + else +c texp = dfaexp( idint(dtmp*1000)+1 )/sckk + texp = exp(-dtmp)/sckk + endif + + ep=ep+sccdist(i,j)*texp + fp=fp+sccdist(i,j)*texp*dd*2.0d0/ckk + scc=scc+sccdist(i,j) +C write(*,'(2i8,6f12.5)') i, j, dist, +C & fdist(i,j), ep, fp, sccdist(i,j), scc + + enddo + + ep = -ep/scc + fp = fp/scc + + +c IF(ABS(EP).lt.1.0d-20)THEN +c EP=0.0D0 +c ENDIF +c IF (ABS(FP).lt.1.0d-20) THEN +c FP=0.0D0 +c ENDIF + + edfadis=edfadis+ep*dis_inc*wwdist + + gdfad(1,iatm1) = gdfad(1,iatm1)-jix/dist*fp*dis_inc*wwdist + gdfad(2,iatm1) = gdfad(2,iatm1)-jiy/dist*fp*dis_inc*wwdist + gdfad(3,iatm1) = gdfad(3,iatm1)-jiz/dist*fp*dis_inc*wwdist + + gdfad(1,iatm2) = gdfad(1,iatm2)+jix/dist*fp*dis_inc*wwdist + gdfad(2,iatm2) = gdfad(2,iatm2)+jiy/dist*fp*dis_inc*wwdist + gdfad(3,iatm2) = gdfad(3,iatm2)+jiz/dist*fp*dis_inc*wwdist + + enddo + + return + end + + subroutine edfat(edfator) +C DFA torsion angle + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.DFA' + + integer i,j,ii,iii + integer iatom(5) + double precision aphi(2),athe(2),tdx(5),tdy(5),tdz(5) + double precision cwidth, cwidth2 + PARAMETER(CWIDTH=0.1D0,CWIDTH2=0.2D0,PAI=3.14159265358979323846D0) + parameter (TENM20=1.0d-20) + + edfator= 0.0d0 + enephi = 0.0d0 + enethe = 0.0d0 + gdfat(:,:) = 0.0d0 + +C START OF PHI ANGLE + do i=1, idfaphi + + aphi = 0.0d0 + do iii=1,5 + iatom(iii)=iphilis(iii,i)+ishiftca + enddo + +C ANGLE VECTOR CALCULTION + RIX=C(1,IATOM(2))-C(1,IATOM(1)) + RIY=C(2,IATOM(2))-C(2,IATOM(1)) + RIZ=C(3,IATOM(2))-C(3,IATOM(1)) + + RIPX=C(1,IATOM(3))-C(1,IATOM(2)) + RIPY=C(2,IATOM(3))-C(2,IATOM(2)) + RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) + + RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) + RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) + RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) + + RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) + RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) + RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) + + GIX=RIY*RIPZ-RIZ*RIPY + GIY=RIZ*RIPX-RIX*RIPZ + GIZ=RIX*RIPY-RIY*RIPX + + GIPX=RIPY*RIPPZ-RIPZ*RIPPY + GIPY=RIPZ*RIPPX-RIPX*RIPPZ + GIPZ=RIPX*RIPPY-RIPY*RIPPX + + CIPX=C(1,IATOM(3))-C(1,IATOM(1)) + CIPY=C(2,IATOM(3))-C(2,IATOM(1)) + CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) + + CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) + CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) + CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) + + CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) + CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) + CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) + + DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) + DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) + DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) + DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) + +C END OF ANGLE VECTOR CALCULTION + + TDOT=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ + APHI(1)=TDOT/(DGI*DRIPP) + TDOT=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z + APHI(2)=TDOT/(DGIP*DRIP3) + + ephi = 0.0d0 + tfphi1=0.0d0 + tfphi2=0.0d0 + scc=0.0d0 + + do j=1, iphinum(i) + DDPS1=APHI(1)-FPHI1(i,j) + DDPS2=APHI(2)-FPHI2(i,j) + + DTMP = (DDPS1**2+DDPS2**2)/CWIDTH2 + + if (dtmp.ge.15.0d0) then + ps_tmp = 0.0d0 + else +c ps_tmp = dfaexp(idint(dtmp*1000)+1) + ps_tmp = exp(-dtmp) + endif + + ephi=ephi+sccphi(i,j)*ps_tmp + + tfphi1=tfphi1+sccphi(i,j)*ddps1/cwidth*ps_tmp + tfphi2=tfphi2+sccphi(i,j)*ddps2/cwidth*ps_tmp + + scc=scc+sccphi(i,j) +c write(*,'(2i8,8f12.6)')i,j,aphi(1),fphi1(i,j), +c & aphi(2),fphi2(i,j),tfphi1,tfphi2,ephi,sccphi(i,j) + ENDDO + + ephi=-ephi/scc*phi_inc*wwangle + tfphi1=tfphi1/scc*phi_inc*wwangle + tfphi2=tfphi2/scc*phi_inc*wwangle + + IF (ABS(EPHI).LT.1d-20) THEN + EPHI=0.0D0 + ENDIF + IF (ABS(TFPHI1).LT.1d-20) THEN + TFPHI1=0.0D0 + ENDIF + IF (ABS(TFPHI2).LT.1d-20) THEN + TFPHI2=0.0D0 + ENDIF + +C FORCE DIRECTION CALCULATION + TDX(1:5)=0.0D0 + TDY(1:5)=0.0D0 + TDZ(1:5)=0.0D0 + + DM1=1.0d0/(DGI*DRIPP) + + GIRPP=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ + DM2=GIRPP/(DGI**3*DRIPP) + DM3=GIRPP/(DGI*DRIPP**3) + + DM4=1.0d0/(DGIP*DRIP3) + + GIRP3=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z + DM5=GIRP3/(DGIP**3*DRIP3) + DM6=GIRP3/(DGIP*DRIP3**3) +C FIRST ATOM BY PHI1 + TDX(1)=(RIPZ*RIPPY-RIPY*RIPPZ)*DM1 + & +( GIZ* RIPY- GIY* RIPZ)*DM2 + TDY(1)=(RIPX*RIPPZ-RIPZ*RIPPX)*DM1 + & +( GIX* RIPZ- GIZ* RIPX)*DM2 + TDZ(1)=(RIPY*RIPPX-RIPX*RIPPY)*DM1 + & +( GIY* RIPX- GIX* RIPY)*DM2 + TDX(1)=TDX(1)*TFPHI1 + TDY(1)=TDY(1)*TFPHI1 + TDZ(1)=TDZ(1)*TFPHI1 +C SECOND ATOM BY PHI1 + TDX(2)=(CIPY*RIPPZ-CIPZ*RIPPY)*DM1 + & -(CIPY*GIZ-CIPZ*GIY)*DM2 + TDY(2)=(CIPZ*RIPPX-CIPX*RIPPZ)*DM1 + & -(CIPZ*GIX-CIPX*GIZ)*DM2 + TDZ(2)=(CIPX*RIPPY-CIPY*RIPPX)*DM1 + & -(CIPX*GIY-CIPY*GIX)*DM2 + TDX(2)=TDX(2)*TFPHI1 + TDY(2)=TDY(2)*TFPHI1 + TDZ(2)=TDZ(2)*TFPHI1 +C SECOND ATOM BY PHI2 + TDX(2)=TDX(2)+ + & ((RIPPZ*RIP3Y-RIPPY*RIP3Z)*DM4 + & +( GIPZ*RIPPY- GIPY*RIPPZ)*DM5)*TFPHI2 + TDY(2)=TDY(2)+ + & ((RIPPX*RIP3Z-RIPPZ*RIP3X)*DM4 + & +( GIPX*RIPPZ- GIPZ*RIPPX)*DM5)*TFPHI2 + TDZ(2)=TDZ(2)+ + & ((RIPPY*RIP3X-RIPPX*RIP3Y)*DM4 + & +( GIPY*RIPPX- GIPX*RIPPY)*DM5)*TFPHI2 +C THIRD ATOM BY PHI1 + TDX(3)=(-GIX+RIPPY*RIZ-RIPPZ*RIY)*DM1 + & -(GIY*RIZ-RIY*GIZ)*DM2+RIPPX*DM3 + TDY(3)=(-GIY+RIPPZ*RIX-RIPPX*RIZ)*DM1 + & -(GIZ*RIX-RIZ*GIX)*DM2+RIPPY*DM3 + TDZ(3)=(-GIZ+RIPPX*RIY-RIPPY*RIX)*DM1 + & -(GIX*RIY-RIX*GIY)*DM2+RIPPZ*DM3 + TDX(3)=TDX(3)*TFPHI1 + TDY(3)=TDY(3)*TFPHI1 + TDZ(3)=TDZ(3)*TFPHI1 +C THIRD ATOM BY PHI2 + TDX(3)=TDX(3)+ + & ((CIPPY*RIP3Z-CIPPZ*RIP3Y)*DM4 + & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5)*TFPHI2 + TDY(3)=TDY(3)+ + & ((CIPPZ*RIP3X-CIPPX*RIP3Z)*DM4 + & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5)*TFPHI2 + TDZ(3)=TDZ(3)+ + & ((CIPPX*RIP3Y-CIPPY*RIP3X)*DM4 + & -(CIPPX*GIPY-CIPPY*GIPX)*DM5)*TFPHI2 +C FOURTH ATOM BY PHI1 + TDX(4)=(GIX*DM1-RIPPX*DM3)*TFPHI1 + TDY(4)=(GIY*DM1-RIPPY*DM3)*TFPHI1 + TDZ(4)=(GIZ*DM1-RIPPZ*DM3)*TFPHI1 +C FOURTH ATOM BY PHI2 + TDX(4)=TDX(4)+ + & ((-GIPX+RIP3Y*RIPZ-RIP3Z*RIPY)*DM4 + & -( GIPY*RIPZ-RIPY*GIPZ)*DM5 + & + RIP3X*DM6)*TFPHI2 + TDY(4)=TDY(4)+ + & ((-GIPY+RIP3Z*RIPX-RIP3X*RIPZ)*DM4 + & -( GIPZ*RIPX-RIPZ*GIPX)*DM5 + & + RIP3Y*DM6)*TFPHI2 + TDZ(4)=TDZ(4)+ + & ((-GIPZ+RIP3X*RIPY-RIP3Y*RIPX)*DM4 + & -( GIPX*RIPY-RIPX*GIPY)*DM5 + & + RIP3Z*DM6)*TFPHI2 +C FIFTH ATOM BY PHI2 + TDX(5)=(GIPX*DM4-RIP3X*DM6)*TFPHI2 + TDY(5)=(GIPY*DM4-RIP3Y*DM6)*TFPHI2 + TDZ(5)=(GIPZ*DM4-RIP3Z*DM6)*TFPHI2 +C END OF FORCE DIRECTION +c force calcuation + DO II=1,5 + gdfat(1,IATOM(II))=gdfat(1,IATOM(II))+TDX(II) + gdfat(2,IATOM(II))=gdfat(2,IATOM(II))+TDY(II) + gdfat(3,IATOM(II))=gdfat(3,IATOM(II))+TDZ(II) + ENDDO +c energy calculation + enephi = enephi + ephi +c end of single assignment statement + ENDDO +C END OF PHI RESTRAINT + +C START OF THETA ANGLE + do i=1, idfathe + + athe = 0.0d0 + do iii=1,5 + iatom(iii)=ithelis(iii,i)+ishiftca + enddo + + +C ANGLE VECTOR CALCULTION + RIX=C(1,IATOM(2))-C(1,IATOM(1)) + RIY=C(2,IATOM(2))-C(2,IATOM(1)) + RIZ=C(3,IATOM(2))-C(3,IATOM(1)) + + RIPX=C(1,IATOM(3))-C(1,IATOM(2)) + RIPY=C(2,IATOM(3))-C(2,IATOM(2)) + RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) + + RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) + RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) + RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) + + RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) + RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) + RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) + + GIX=RIY*RIPZ-RIZ*RIPY + GIY=RIZ*RIPX-RIX*RIPZ + GIZ=RIX*RIPY-RIY*RIPX + + GIPX=RIPY*RIPPZ-RIPZ*RIPPY + GIPY=RIPZ*RIPPX-RIPX*RIPPZ + GIPZ=RIPX*RIPPY-RIPY*RIPPX + + GIPPX=RIPPY*RIP3Z-RIPPZ*RIP3Y + GIPPY=RIPPZ*RIP3X-RIPPX*RIP3Z + GIPPZ=RIPPX*RIP3Y-RIPPY*RIP3X + + CIPX=C(1,IATOM(3))-C(1,IATOM(1)) + CIPY=C(2,IATOM(3))-C(2,IATOM(1)) + CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) + + CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) + CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) + CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) + + CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) + CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) + CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) + + DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) + DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) + DGIPP=SQRT(GIPPX*GIPPX+GIPPY*GIPPY+GIPPZ*GIPPZ) + DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) + DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) +C END OF ANGLE VECTOR CALCULTION + + TDOT=GIX*GIPX+GIY*GIPY+GIZ*GIPZ + ATHE(1)=TDOT/(DGI*DGIP) + TDOT=GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ + ATHE(2)=TDOT/(DGIP*DGIPP) + + ETHE=0.0D0 + TFTHE1=0.0D0 + TFTHE2=0.0D0 + SCC=0.0D0 + TH_TMP=0.0d0 + + do j=1,ithenum(i) + ddth1=athe(1)-fthe1(i,j) !cos(the1)-cos(the1_ref) + ddth2=athe(2)-fthe2(i,j) !cos(the2)-cos(the2_ref) + dtmp= (ddth1**2+ddth2**2)/cwidth2 + if ( dtmp .ge. 15.0d0) then + th_tmp = 0.0d0 + else +c th_tmp = dfaexp ( idint(dtmp*1000)+1 ) + th_tmp = exp(-dtmp) + end if + + ethe=ethe+sccthe(i,j)*th_tmp + + tfthe1=tfthe1+sccthe(i,j)*ddth1/cwidth*th_tmp !-dv/dcos(the1) + tfthe2=tfthe2+sccthe(i,j)*ddth2/cwidth*th_tmp !-dv/dcos(the2) + scc=scc+sccthe(i,j) +c write(2,'(2i8,8f12.6)')i,j,athe(1),fthe1(i,j), +c & athe(2),fthe2(i,j),tfthe1,tfthe2,ethe,sccthe(i,j) + enddo + + ethe=-ethe/scc*the_inc*wwangle + tfthe1=tfthe1/scc*the_inc*wwangle + tfthe2=tfthe2/scc*the_inc*wwangle + + IF (ABS(ETHE).LT.TENM20) THEN + ETHE=0.0D0 + ENDIF + IF (ABS(TFTHE1).LT.TENM20) THEN + TFTHE1=0.0D0 + ENDIF + IF (ABS(TFTHE2).LT.TENM20) THEN + TFTHE2=0.0D0 + ENDIF + + TDX(1:5)=0.0D0 + TDY(1:5)=0.0D0 + TDZ(1:5)=0.0D0 + + DM1=1.0d0/(DGI*DGIP) + DM2=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI**3*DGIP) + DM3=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI*DGIP**3) + + DM4=1.0d0/(DGIP*DGIPP) + DM5=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP**3*DGIPP) + DM6=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP*DGIPP**3) + +C FIRST ATOM BY THETA1 + TDX(1)=((RIPZ*GIPY-RIPY*GIPZ)*DM1 + & -(GIY*RIPZ-GIZ*RIPY)*DM2)*TFTHE1 + TDY(1)=((-RIPZ*GIPX+RIPX*GIPZ)*DM1 + & -(-GIX*RIPZ+GIZ*RIPX)*DM2)*TFTHE1 + TDZ(1)=((RIPY*GIPX-RIPX*GIPY)*DM1 + & -(GIX*RIPY-GIY*RIPX)*DM2)*TFTHE1 +C SECOND ATOM BY THETA1 + TDX(2)=((CIPY*GIPZ-CIPZ*GIPY-RIPPY*GIZ+RIPPZ*GIY)*DM1 + & -(CIPY*GIZ-CIPZ*GIY)*DM2 + & +(RIPPY*GIPZ-RIPPZ*GIPY)*DM3)*TFTHE1 + TDY(2)=((CIPZ*GIPX-CIPX*GIPZ-RIPPZ*GIX+RIPPX*GIZ)*DM1 + & -(CIPZ*GIX-CIPX*GIZ)*DM2 + & +(RIPPZ*GIPX-RIPPX*GIPZ)*DM3)*TFTHE1 + TDZ(2)=((CIPX*GIPY-CIPY*GIPX-RIPPX*GIY+RIPPY*GIX)*DM1 + & -(CIPX*GIY-CIPY*GIX)*DM2 + & +(RIPPX*GIPY-RIPPY*GIPX)*DM3)*TFTHE1 +C SECOND ATOM BY THETA2 + TDX(2)=TDX(2)+ + & ((RIPPZ*GIPPY-RIPPY*GIPPZ)*DM4 + & -(GIPY*RIPPZ-GIPZ*RIPPY)*DM5)*TFTHE2 + TDY(2)=TDY(2)+ + & ((-RIPPZ*GIPPX+RIPPX*GIPPZ)*DM4 + & -(-GIPX*RIPPZ+GIPZ*RIPPX)*DM5)*TFTHE2 + TDZ(2)=TDZ(2)+ + & ((RIPPY*GIPPX-RIPPX*GIPPY)*DM4 + & -(GIPX*RIPPY-GIPY*RIPPX)*DM5)*TFTHE2 +C THIRD ATOM BY THETA1 + TDX(3)=((GIPY*RIZ-GIPZ*RIY-GIY*CIPPZ+GIZ*CIPPY)*DM1 + & -(GIY*RIZ-GIZ*RIY)*DM2 + & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM3) *TFTHE1 + TDY(3)=((GIPZ*RIX-GIPX*RIZ-GIZ*CIPPX+GIX*CIPPZ)*DM1 + & -(GIZ*RIX-GIX*RIZ)*DM2 + & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM3) *TFTHE1 + TDZ(3)=((GIPX*RIY-GIPY*RIX-GIX*CIPPY+GIY*CIPPX)*DM1 + & -(GIX*RIY-GIY*RIX)*DM2 + & -(CIPPX*GIPY-CIPPY*GIPX)*DM3) *TFTHE1 +C THIRD ATOM BY THETA2 + TDX(3)=TDX(3)+ + & ((CIPPY*GIPPZ-CIPPZ*GIPPY-RIP3Y*GIPZ+RIP3Z*GIPY)*DM4 + & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5 + & +(RIP3Y*GIPpZ-RIP3Z*GIPpY)*DM6) *TFTHE2 + TDY(3)=TDY(3)+ + & ((CIPPZ*GIPPX-CIPPX*GIPPZ-RIP3Z*GIPX+RIP3X*GIPZ)*DM4 + & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5 + & +(RIP3Z*GIPpX-RIP3X*GIPpZ)*DM6) *TFTHE2 + TDZ(3)=TDZ(3)+ + & ((CIPPX*GIPPY-CIPPY*GIPPX-RIP3X*GIPY+RIP3Y*GIPX)*DM4 + & -(CIPPX*GIPY-CIPPY*GIPX)*DM5 + & +(RIP3X*GIPpY-RIP3Y*GIPpX)*DM6) *TFTHE2 +C FOURTH ATOM BY THETA1 + TDX(4)=-((GIZ*RIPY-GIY*RIPZ)*DM1 + & -(GIPZ*RIPY-GIPY*RIPZ)*DM3) *TFTHE1 + TDY(4)=-((GIX*RIPZ-GIZ*RIPX)*DM1 + & -(GIPX*RIPZ-GIPZ*RIPX)*DM3) *TFTHE1 + TDZ(4)=-((GIY*RIPX-GIX*RIPY)*DM1 + & -(GIPY*RIPX-GIPX*RIPY)*DM3) *TFTHE1 +C FOURTH ATOM BY THETA2 + TDX(4)=TDX(4)+ + & ((GIPPY*RIPZ-GIPPZ*RIPY-GIPY*CIP3Z+GIPZ*CIP3Y)*DM4 + & -(GIPY*RIPZ-GIPZ*RIPY)*DM5 + & -(CIP3Y*GIPPZ-CIP3Z*GIPPY)*DM6)*TFTHE2 + TDY(4)=TDY(4)+ + & ((GIPPZ*RIPX-GIPPX*RIPZ-GIPZ*CIP3X+GIPX*CIP3Z)*DM4 + & -(GIPZ*RIPX-GIPX*RIPZ)*DM5 + & -(CIP3Z*GIPPX-CIP3X*GIPPZ)*DM6)*TFTHE2 + TDZ(4)=TDZ(4)+ + & ((GIPPX*RIPY-GIPPY*RIPX-GIPX*CIP3Y+GIPY*CIP3X)*DM4 + & -(GIPX*RIPY-GIPY*RIPX)*DM5 + & -(CIP3X*GIPPY-CIP3Y*GIPPX)*DM6)*TFTHE2 +C FIFTH ATOM BY THETA2 + TDX(5)=-((GIPZ*RIPPY-GIPY*RIPPZ)*DM4 + & -(GIPPZ*RIPPY-GIPPY*RIPPZ)*DM6)*TFTHE2 + TDY(5)=-((GIPX*RIPPZ-GIPZ*RIPPX)*DM4 + & -(GIPPX*RIPPZ-GIPPZ*RIPPX)*DM6)*TFTHE2 + TDZ(5)=-((GIPY*RIPPX-GIPX*RIPPY)*DM4 + & -(GIPPY*RIPPX-GIPPX*RIPPY)*DM6)*TFTHE2 +C !! END OF FORCE DIRECTION!!!! + DO II=1,5 + gdfat(1,iatom(II))=gdfat(1,iatom(II))+TDX(II) + gdfat(2,iatom(II))=gdfat(2,iatom(II))+TDY(II) + gdfat(3,iatom(II))=gdfat(3,iatom(II))+TDZ(II) + ENDDO +C energy calculation + enethe = enethe + ethe + ENDDO + + edfator = enephi + enethe + + RETURN + END + + subroutine edfan(edfanei) +C DFA neighboring CA restraint + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.DFA' + + integer i,j,imin + integer kshnum, n1atom + + double precision enenei,tmp_n + double precision pai,hpai + double precision jix,jiy,jiz,ndiff,snorm_nei + double precision t2dx(maxres),t2dy(maxres),t2dz(maxres) + double precision dr,dr2,half,ntmp,dtmp + + parameter(dr=0.25d0,dr2=0.50d0,half=0.50d0) + parameter(pai=3.14159265358979323846D0) + parameter(hpai=1.5707963267948966D0) + parameter(snorm_nei=0.886226925452758D0) + + edfanei = 0.0d0 + enenei = 0.0d0 + gdfan = 0.0d0 + +c print*, 's1:', s1(:) +c print*, 's2:', s2(:) + + do i=1, idfanei + + kshnum=kshell(i) + n1atom=ineilis(i)+ishiftca +C write(*,*) 'kshnum,n1atom:', kshnum, n1atom + + tmp_n=0.0d0 + ftmp=0.0d0 + dnei=0.0d0 + dist=0.0d0 + t1dx=0.0d0 + t1dy=0.0d0 + t1dz=0.0d0 + t2dx=0.0d0 + t2dy=0.0d0 + t2dz=0.0d0 + + do j = ishiftca+1, ilastca + + if (n1atom.eq.j) cycle + + jix=c(1,j)-c(1,n1atom) + jiy=c(2,j)-c(2,n1atom) + jiz=c(3,j)-c(3,n1atom) + dist=sqrt(jix*jix+jiy*jiy+jiz*jiz) + +c write(*,*) n1atom, j, dist + + if(kshnum.ne.1)then + if (dist.lt.s1(kshnum).and. + & dist.gt.s2(kshnum-1)) then + + tmp_n=tmp_n+1.0d0 + +c write(*,*) 'case1:',tmp_n + +cc t1dx=t1dx+0.0d0 +cc t1dy=t1dy+0.0d0 +cc t1dz=t1dz+0.0d0 + t2dx(j)=0.0d0 + t2dy(j)=0.0d0 + t2dz(j)=0.0d0 + + elseif(dist.ge.s1(kshnum).and. + & dist.le.s2(kshnum)) then + + dnei=(dist-s1(kshnum))/dr2*pai + tmp_n=tmp_n + half*(1+cos(dnei)) +c write(*,*) 'case2:',tmp_n + ftmp=-pai*sin(dnei)/dr2/dist/2.0d0 +c center atom + t1dx=t1dx+jix*ftmp + t1dy=t1dy+jiy*ftmp + t1dz=t1dz+jiz*ftmp +c neighbor atoms + t2dx(j)=-jix*ftmp + t2dy(j)=-jiy*ftmp + t2dz(j)=-jiz*ftmp +c + elseif(dist.ge.s1(kshnum-1).and. + & dist.le.s2(kshnum-1)) then + dnei=(dist-s1(kshnum-1))/dr2*pai + tmp_n=tmp_n + 1.0d0 - half*(1+cos(dnei)) +c write(*,*) 'case3:',tmp_n + ftmp = hpai*sin(dnei)/dr2/dist +c center atom + t1dx=t1dx+jix*ftmp + t1dy=t1dy+jiy*ftmp + t1dz=t1dz+jiz*ftmp +c neighbor atoms + t2dx(j)=-jix*ftmp + t2dy(j)=-jiy*ftmp + t2dz(j)=-jiz*ftmp + + endif + + elseif(kshnum.eq.1) then + + if(dist.lt.s1(kshnum))then + + tmp_n=tmp_n+1.0d0 +c write(*,*) 'case4:',tmp_n +cc t1dx=t1dx+0.0d0 +cc t1dy=t1dy+0.0d0 +cc t1dz=t1dz+0.0d0 + t2dx(j)=0.0d0 + t2dy(j)=0.0d0 + t2dz(j)=0.0d0 + + elseif(dist.ge.s1(kshnum).and. + & dist.le.s2(kshnum))then + + dnei=(dist-s1(kshnum))/dr2*pai + tmp_n=tmp_n + half*(1+cos(dnei)) +c write(*,*) 'case5:',tmp_n + ftmp = -hpai*sin(dnei)/dr2/dist +c center atom + t1dx=t1dx+jix*ftmp + t1dy=t1dy+jiy*ftmp + t1dz=t1dz+jiz*ftmp +c neighbor atoms + t2dx(j)=-jix*ftmp + t2dy(j)=-jiy*ftmp + t2dz(j)=-jiz*ftmp + + endif + endif + enddo + + scc=0.0d0 + enei=0.0d0 + tmp_fnei=0.0d0 + ndiff=0.0d0 + + do imin=1,ineinum(i) + + ndiff = tmp_n-fnei(i,imin) + dtmp = ndiff*ndiff + + if (dtmp.ge.15.0d0) then + ntmp = 0.0d0 + else +c ntmp = dfaexp( idint(dtmp*1000) + 1 ) + ntmp = exp(-dtmp) + end if + + enei=enei+sccnei(i,imin)*ntmp + tmp_fnei=tmp_fnei- + & sccnei(i,imin)*ntmp*ndiff*2.0d0 + scc=scc+sccnei(i,imin) + +c write(*,'(a,1x,2i8,f12.7,i8,3f12.7)')'NEI:',i,imin,tmp_n, +c & fnei(i,imin),sccnei(i,imin),enei,scc + enddo + + enei=-enei/scc*snorm_nei*nei_inc*wwnei + tmp_fnei=tmp_fnei/scc*snorm_nei*nei_inc*wwnei + +c if (abs(enei).lt.1.0d-20)then +c enei=0.0d0 +c endif +c if (abs(tmp_fnei).lt.1.0d-20) then +c tmp_fnei=0.0d0 +c endif + +c force calculation + t1dx=t1dx*tmp_fnei + t1dy=t1dy*tmp_fnei + t1dz=t1dz*tmp_fnei + + do j=ishiftca+1,ilastca + t2dx(j)=t2dx(j)*tmp_fnei + t2dy(j)=t2dy(j)*tmp_fnei + t2dz(j)=t2dz(j)*tmp_fnei + enddo + + gdfan(1,n1atom)=gdfan(1,n1atom)+t1dx + gdfan(2,n1atom)=gdfan(2,n1atom)+t1dy + gdfan(3,n1atom)=gdfan(3,n1atom)+t1dz + + do j=ishiftca+1,ilastca + gdfan(1,j)=gdfan(1,j)+t2dx(j) + gdfan(2,j)=gdfan(2,j)+t2dy(j) + gdfan(3,j)=gdfan(3,j)+t2dz(j) + enddo +c energy calculation + + enenei=enenei+enei + + enddo + + edfanei=enenei + + return + end + + subroutine edfab(edfabeta) + + implicit real*8 (a-h,o-z) + + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.DFA' + + real*8 PAI + parameter(PAI=3.14159265358979323846D0) + parameter (maxca=800) +C sheet variables + real*8 bx(maxres),by(maxres),bz(maxres) + real*8 vbet(maxres,maxres) + real*8 shetfx(maxres),shetfy(maxres),shetfz(maxres) + real*8 shefx(maxres,12),shefy(maxres,12),shefz(maxres,12) + real*8 vbeta,vbetp,vbetm + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + & c00,s00,ulnex,dnex + real*8 dp45,dm45,w_beta + + real*8 cph(maxca),cth(maxca) + real*8 atx(maxca),aty(maxca),atz(maxca) + real*8 atmx(maxca),atmy(maxca),atmz(maxca) + real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) + real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) + real*8 sth(maxca) + real*8 astx(maxca),asty(maxca),astz(maxca) + real*8 astmx(maxca),astmy(maxca),astmz(maxca) + real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) + real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) + + real*8 atxnum(maxca),atynum(maxca),atznum(maxca), + & astxnum(maxca),astynum(maxca),astznum(maxca), + & atmxnum(maxca),atmynum(maxca),atmznum(maxca), + & astmxnum(maxca),astmynum(maxca),astmznum(maxca), + & atmmxnum(maxca),atmmynum(maxca),atmmznum(maxca), + & astmmxnum(maxca),astmmynum(maxca),astmmznum(maxca), + & atm3xnum(maxca),atm3ynum(maxca),atm3znum(maxca), + & astm3xnum(maxca),astm3ynum(maxca),astm3znum(maxca), + & cth_orig(maxca),sth_orig(maxca) + + common /sheca/ bx,by,bz + common /shee/ vbeta,vbet,vbetp,vbetm + common /shetf/ shetfx,shetfy,shetfz + common /shef/ shefx, shefy, shefz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + & c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + + common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, + $ atmmz,atm3x,atm3y,atm3z + common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, + $ astmmz,astm3x,astm3y,astm3z + + common /coscos/ cph,cth + common /sinsin/ sth + +C End of sheet variables + + integer i,j + double precision enebet + + enebet=0.0d0 +c bx=0.0d0;by=0.0d0;bz=0.0d0 +c shetfx=0.0d0;shetfy=0.0d0;shetfz=0.0d0 + + gdfab=0.0d0 + + do i=ishiftca+1,ilastca + bx(i-ishiftca)=c(1,i) + by(i-ishiftca)=c(2,i) + bz(i-ishiftca)=c(3,i) + enddo + +c do i=1,ilastca-ishiftca +c read(99,*) bx(i),by(i),bz(i) +c enddo +c close(99) + + dca=0.25d0**2 + dshe=0.3d0**2 + ULHB=5.0D0 + ULDHB=5.0D0 + ULNEX=COS(60.0D0/180.0D0*PAI) + + DLHB=1.0D0 + DLDHB=1.0D0 + + DNEX=0.3D0**2 + + C00=COS((1.0D0+10.0D0/180.0D0)*PAI) + S00=SIN((1.0D0+10.0D0/180.0D0)*PAI) + + W_BETA=0.5D0 + DP45=W_BETA + DM45=W_BETA + +C END OF INITIALIZATION + + nca=ilastca-ishiftca + + call angvectors(nca) + call sheetforce(nca,wshet) + +c end of sheet energy and force + + do j=1,nca + shetfx(j)=shetfx(j)*beta_inc + shetfy(j)=shetfy(j)*beta_inc + shetfz(j)=shetfz(j)*beta_inc +c write(*,*)'SHETF:',shetfx(j),shetfy(j),shetfz(j) + enddo + + vbeta=vbeta*beta_inc + enebet=vbeta + edfabeta=enebet + + do j=1,nca + gdfab(1,j+ishiftca)=gdfab(1,j+ishiftca)-shetfx(j) + gdfab(2,j+ishiftca)=gdfab(2,j+ishiftca)-shetfy(j) + gdfab(3,j+ishiftca)=gdfab(3,j+ishiftca)-shetfz(j) + enddo + +#ifdef DEBUG1 + do j=1,nca + write(*,'(5x,i5,10x,3f10.5)') j,bx(j),by(j),bz(j) + enddo + + + gdfab=0 + dinc=0.001 + do j=1,nca + cth_orig(j)=cth(j) + sth_orig(j)=sth(j) + enddo + + do j=1,nca + + bx(j)=bx(j)+dinc + call angvectors(nca) + bx(j)=bx(j)-2*dinc + call angvectors(nca) + atxnum(j)=0.5*(cth(j)-cth_orig(j))/dinc + astxnum(j)=0.5*(sth(j)-sth_orig(j))/dinc + if (j.gt.1) then + atmxnum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc + astmxnum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc + endif + if (j.gt.2) then + atmmxnum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc + astmmxnum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc + endif + if (j.gt.3) then + atm3xnum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc + astm3xnum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc + endif + bx(j)=bx(j)+dinc + by(j)=by(j)+dinc + call angvectors(nca) + by(j)=by(j)-2*dinc + call angvectors(nca) + by(j)=by(j)+dinc + atynum(j)=0.5*(cth(j)-cth_orig(j))/dinc + astynum(j)=0.5*(sth(j)-sth_orig(j))/dinc + if (j.gt.1) then + atmynum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc + astmynum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc + endif + if (j.gt.2) then + atmmynum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc + astmmynum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc + endif + if (j.gt.3) then + atm3ynum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc + astm3ynum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc + endif + + bz(j)=bz(j)+dinc + call angvectors(nca) + bz(j)=bz(j)-2*dinc + call angvectors(nca) + bz(j)=bz(j)+dinc + + atznum(j)=0.5*(cth(j)-cth_orig(j))/dinc + astznum(j)=0.5*(sth(j)-sth_orig(j))/dinc + if (j.gt.1) then + atmznum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc + astmznum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc + endif + if (j.gt.2) then + atmmznum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc + astmmznum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc + endif + if (j.gt.3) then + atm3znum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc + astm3znum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc + endif + + enddo + + do i=1,nca + write (*,'(2i5,a2,6f10.5)') + & i,1,"x",atxnum(i),atx(i),atxnum(i)/atx(i), + & astxnum(i),astx(i),astxnum(i)/astx(i), + & i,1,"y",atynum(i),aty(i),atynum(i)/aty(i), + & astynum(i),asty(i),astynum(i)/asty(i), + & i,1,"z",atznum(i),atz(i),atznum(i)/atz(i), + & astznum(i),astz(i),astznum(i)/astz(i), + & i,2,"x",atmxnum(i),atmx(i),atmxnum(i)/atmx(i), + & astmxnum(i),astmx(i),astmxnum(i)/astmx(i), + & i,2,"y",atmynum(i),atmy(i),atmynum(i)/atmy(i), + & astmynum(i),astmy(i),astmynum(i)/astmy(i), + & i,2,"z",atmznum(i),atmz(i),atmznum(i)/atmz(i), + & astmznum(i),astmz(i),astmznum(i)/astmz(i), + & i,3,"x",atmmxnum(i),atmmx(i),atmmxnum(i)/atmmx(i), + & astmmxnum(i),astmmx(i),astmmxnum(i)/astmmx(i), + & i,3,"y",atmmynum(i),atmmy(i),atmmynum(i)/atmmy(i), + & astmmynum(i),astmmy(i),astmmynum(i)/astmmy(i), + & i,3,"z",atmmznum(i),atmmz(i),atmmznum(i)/atmmz(i), + & astmmznum(i),astmmz(i),astmmznum(i)/astmmz(i), + & i,4,"x",atm3xnum(i),atm3x(i),atm3xnum(i)/atm3x(i), + & astm3xnum(i),astm3x(i),astm3xnum(i)/astm3x(i), + & i,4,"y",atm3ynum(i),atm3y(i),atm3ynum(i)/atm3y(i), + & astm3ynum(i),astm3y(i),astm3ynum(i)/astm3y(i), + & i,4,"z",atm3znum(i),atm3z(i),atm3znum(i)/atm3z(i), + & astm3znum(i),astm3z(i),astm3znum(i)/astm3z(i), + & i,0," ",cth_orig(i),sth_orig(i) + enddo + + + gdfab=0 + dinc=0.001 + + do j=1,nca + + bx(j)=bx(j)+dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta1=vbeta*beta_inc + bx(j)=bx(j)-2*dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta2=vbeta*beta_inc + gdfab(1,j)=(vbeta2-vbeta1)/dinc/2 + bx(j)=bx(j)+dinc + + by(j)=by(j)+dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta1=vbeta*beta_inc + by(j)=by(j)-2*dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta2=vbeta*beta_inc + gdfab(2,j)=(vbeta2-vbeta1)/dinc/2 + by(j)=by(j)+dinc + + bz(j)=bz(j)+dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta1=vbeta*beta_inc + bz(j)=bz(j)-2*dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta2=vbeta*beta_inc + gdfab(3,j)=(vbeta2-vbeta1)/dinc/2 + bz(j)=bz(j)+dinc + + + enddo + + + call angvectors(nca) + call sheetforce(nca,wshet) + do j=1,nca + shetfx(j)=shetfx(j)*beta_inc + shetfy(j)=shetfy(j)*beta_inc + shetfz(j)=shetfz(j)*beta_inc + enddo + + + write(*,*) 'xyz analytical and numerical gradient' + do j=1,nca + write(*,'(5x,i5,10x,6f10.5)') j,-shetfx(j),-shetfy(j),-shetfz(j) + & ,(-gdfab(i,j),i=1,3) + enddo + + do j=1,nca + write(*,'(5x,i5,10x,3f10.2)') j,shetfx(j)/gdfab(1,j), + & shetfy(j)/gdfab(2,j), + & shetfz(j)/gdfab(3,j) + enddo + + stop +#endif + + return + end +C------------------------------------------------------------------------------- + subroutine angvectors(nca) +c implicit real*4(a-h,o-z) + implicit none + integer nca + integer maxca + parameter(maxca=800) + real*8 pai,zero + parameter(PAI=3.14159265358979323846D0,zero=0.0d0) + + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 apx(maxca),apy(maxca),apz(maxca) + real*8 apmx(maxca),apmy(maxca),apmz(maxca) + real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) + real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) + real*8 atx(maxca),aty(maxca),atz(maxca) + real*8 atmx(maxca),atmy(maxca),atmz(maxca) + real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) + real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) + real*8 astx(maxca),asty(maxca),astz(maxca) + real*8 astmx(maxca),astmy(maxca),astmz(maxca) + real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) + real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) + real*8 sth(maxca) + real*8 cph(maxca),cth(maxca) + real*8 ulcos(maxca) + real*8 p,c + integer i, ip, ipp, ip3, j + real*8 rx(maxca, maxca), ry(maxca, maxca), rz(maxca, maxca) + real*8 rix, riy, riz, ripx, ripy, ripz, rippx, rippy, rippz + real*8 gix, giy, giz, gipx, gipy, gipz, gippx, gippy, gippz + real*8 cix, ciy, ciz, cipx, cipy, cipz + real*8 gpcrp_x, gpcrp_y, gpcrp_z, d_gpcrp, gpcrp__g + real*8 d10, d11, d12, d13, d20, d21, d22, d23, d24 + real*8 d30, d31, d32, d33, d34, d35, d40, d41, d42, d43 + real*8 d_gcr, d_gcr3, d_gmcrim,d_gmcrim3,dgmmcrimm,d_gmmcrimm3 + real*8 dg, dg3, dg30, dgm, dgm3, dgmm, dgmm3, dgp, dri + real*8 dri3, drim, drim3, drimm, drip, dripp, g3gmm, g3rim + real*8 g3x, g3y, g3z, d_gmmcrimm, g3rim_,gcr__gm + real*8 gcr_x,gcr_y,gcr_z,ggm,ggp,gmcrim__gmm + real*8 gmcrim_x,gmcrim_y,gmcrim_z,gmmcrimm__gmmm + real*8 gmmcrimm_x,gmmcrimm_y,gmmcrimm_z,gmmgm,gmmr + real*8 gmmx,gmmy,gmmz,gmrp,gmx,gmy,gmz,gpx,gpy,gpz + real*8 grpp,gx,gy,gz + real*8 rim3x,rim3y,rim3z,rimmx,rimmy,rimmz,rimx,rimy,rimz + real*8 sd10,sd11,sd20,sd21,sd22,sd30,sd31,sd32,sd40,sd41 + integer inb,nmax,iselect + + common /sheca/ bx,by,bz + common /difvec/ rx, ry, rz + common /ulang/ ulcos + common /phys1/ inb,nmax,iselect + common /phys4/ p,c + common /kyori2/ dis + common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, + & apmmz,apm3x,apm3y,apm3z + common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, + & atmmz,atm3x,atm3y,atm3z + common /coscos/ cph,cth + common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, + & astmmz,astm3x,astm3y,astm3z + common /sinsin/ sth +C------------------------------------------------------------------------------- +c write(*,*) 'inside angvectors' +C initialize + p=0.1d0 + c=1.0d0 + inb=nca + cph=zero; cth=zero; sth=zero + apx=zero;apy=zero;apz=zero;apmx=zero;apmy=zero;apmz=zero + apmmx=zero;apmmy=zero;apmmz=zero;apm3x=zero;apm3y=zero;apm3z=zero + atx=zero;aty=zero;atz=zero;atmx=zero;atmy=zero;atmz=zero + atmmx=zero;atmmy=zero;atmmz=zero;atm3x=zero;atm3y=zero;atm3z=zero + astx=zero;asty=zero;astz=zero;astmx=zero;astmy=zero;astmz=zero + astmmx=zero;astmmy=zero;astmmz=zero;astm3x=zero;astm3y=zero + astm3z=zero +C end of initialize +C r[x,y,z] calc and distance calculation + rx=zero;ry=zero;rz=zero + + do i=1,inb + do j=1,inb + rx(i,j)=bx(j)-bx(i) + ry(i,j)=by(j)-by(i) + rz(i,j)=bz(j)-bz(i) + dis(i,j)=sqrt(rx(i,j)**2+ry(i,j)**2+rz(i,j)**2) +c write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) +c write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) +c write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) +c write(*,*) 'dis(i,j):',i,j,dis(i,j) + enddo + enddo +c end of r[x,y,z] calc +C cos calc + do i=1,inb-2 + ip=i+1 + ipp=i+2 + + if(dis(i,ip).ge.1.0e-8.and.dis(ip,ipp).ge.1.0e-8) then + ulcos(i)=rx(i,ip)*rx(ip,ipp)+ry(i,ip)*ry(ip,ipp) + $ +rz(i,ip)*rz(ip,ipp) + ulcos(i)=ulcos(i)/(dis(i,ip)*dis(ip,ipp)) + endif + enddo +c end of virtual bond angle +c write(*,*) 'inside angvectors1' +crc do i=1,inb-3 + do i=1,inb + ip=i+1 + ipp=i+2 + ip3=i+3 + rix=bx(ip)-bx(i) + riy=by(ip)-by(i) + riz=bz(ip)-bz(i) + ripx=bx(ipp)-bx(ip) + ripy=by(ipp)-by(ip) + ripz=bz(ipp)-bz(ip) + rippx=bx(ip3)-bx(ipp) + rippy=by(ip3)-by(ipp) + rippz=bz(ip3)-bz(ipp) + + gx=riy*ripz-riz*ripy + gy=riz*ripx-rix*ripz + gz=rix*ripy-riy*ripx + gpx=ripy*rippz-ripz*rippy + gpy=ripz*rippx-ripx*rippz + gpz=ripx*rippy-ripy*rippx + gpcrp_x=gpy*ripz-gpz*ripy + gpcrp_y=gpz*ripx-gpx*ripz + gpcrp_z=gpx*ripy-gpy*ripx + d_gpcrp=sqrt(gpcrp_x**2+gpcrp_y**2+gpcrp_z**2) + gpcrp__g=gx*gpy*ripz+gpx*ripy*gz+ripx*gpz*gy + & -gz*gpy*ripx-gpz*ripy*gx-ripz*gpx*gy + + if(i.ge.2) then + rimx=bx(i)-bx(i-1) + rimy=by(i)-by(i-1) + rimz=bz(i)-bz(i-1) + gmx=rimy*riz-rimz*riy + gmy=rimz*rix-rimx*riz + gmz=rimx*riy-rimy*rix + dgm=sqrt(gmx**2+gmy**2+gmz**2) + dgm3=dgm**3 + ggm=gmx*gx+gmy*gy+gmz*gz + gmrp=gmx*ripx+gmy*ripy+gmz*ripz + drim=dis(i-1,i) + drim3=drim**3 + gcr_x=gy*riz-gz*riy + gcr_y=gz*rix-gx*riz + gcr_z=gx*riy-gy*rix + d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) + d_gcr3=d_gcr**3 + gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy + & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy + endif +c write(*,*) 'inside angvectors2' + if(i.ge.3) then + rimmx=bx(i-1)-bx(i-2) + rimmy=by(i-1)-by(i-2) + rimmz=bz(i-1)-bz(i-2) + drimm=dis(i-2,i-1) + gmmx=rimmy*rimz-rimmz*rimy + gmmy=rimmz*rimx-rimmx*rimz + gmmz=rimmx*rimy-rimmy*rimx + dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) + dgmm3=dgmm**3 + gmmgm=gmmx*gmx+gmmy*gmy+gmmz*gmz + gmmr=gmmx*rix+gmmy*riy+gmmz*riz + gmcrim_x=gmy*rimz-gmz*rimy + gmcrim_y=gmz*rimx-gmx*rimz + gmcrim_z=gmx*rimy-gmy*rimx + d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) + d_gmcrim3=d_gmcrim**3 + gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy + & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy + endif + + if(i.ge.4) then + rim3x=bx(i-2)-bx(i-3) + rim3y=by(i-2)-by(i-3) + rim3z=bz(i-2)-bz(i-3) + g3x=rim3y*rimmz-rim3z*rimmy + g3y=rim3z*rimmx-rim3x*rimmz + g3z=rim3x*rimmy-rim3y*rimmx + dg30=sqrt(g3x**2+g3y**2+g3z**2) + g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz + g3rim_=g3x*rimx+g3y*rimy+g3z*rimz +cc********************************************************************** + gmmcrimm_x=gmmy*rimmz-gmmz*rimmy + gmmcrimm_y=gmmz*rimmx-gmmx*rimmz + gmmcrimm_z=gmmx*rimmy-gmmy*rimmx + d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) + d_gmmcrimm3=d_gmmcrimm**3 + gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y + & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y + endif + + dri=dis(i,i+1) + drip=dis(i+1,i+2) + dripp=dis(i+2,i+3) + dri3=dri**3 + dg=sqrt(gx**2+gy**2+gz**2) + dgp=sqrt(gpx**2+gpy**2+gpz**2) + dg3=dg**3 + + ggp=gx*gpx+gy*gpy+gz*gpz + grpp=gx*rippx+gy*rippy+gz*rippz + + if(dg.gt.0.0D0.and.dripp.gt.0.0D0.and.dgp.gt.0.0D0 + & .and.d_gpcrp.gt.0.0D0) then + cph(i)=grpp/dg/dripp + cth(i)=ggp/dg/dgp + sth(i)=gpcrp__g/d_gpcrp/dg + else +c + cph(i)=1.0D0 + cth(i)=1.0D0 + sth(i)=0.0D0 + endif + +c write(*,*) 'inside angvectors3' + + if(dgp.gt.0.0D0.and.dg3.gt.0.0D0 + & .and.dripp.gt.0.0D0.and.d_gpcrp.gt.0.0D0) then + d10=1.0D0/(dg*dgp) + d11=ggp/(dg3*dgp) + d12=1.0D0/(dg*dripp) + d13=grpp/(dg3*dripp) + sd10=1.0D0/(d_gpcrp*dg) + sd11=gpcrp__g/(d_gpcrp*dg3) + else + d10=0.0D0 + d11=0.0D0 + d12=0.0D0 + d13=0.0D0 + sd10=0.0D0 + sd11=0.0D0 + endif + + atx(i)=(ripz*gpy-ripy*gpz)*d10 + & -(gy*ripz-gz*ripy)*d11 + aty(i)=(ripx*gpz-ripz*gpx)*d10 + & -(gz*ripx-gx*ripz)*d11 + atz(i)=(ripy*gpx-ripx*gpy)*d10 + & -(gx*ripy-gy*ripx)*d11 + astx(i)=sd10*(-gpx*ripy**2+ripx*gpz*ripz + & +ripy*gpy*ripx-gpx*ripz**2) + & -sd11*(gy*ripz-gz*ripy) + asty(i)=sd10*(-gpy*ripz**2+gpx*ripy*ripx + & -gpy*ripx**2+gpz*ripy*ripz) + & -sd11*(-gx*ripz+gz*ripx) + astz(i)=sd10*(ripy*gpy*ripz-gpz*ripx**2 + & -gpz*ripy**2+ripz*gpx*ripx) + & -sd11*(gx*ripy-gy*ripx) + apx(i)=(ripz*rippy-ripy*rippz)*d12 + & -(gy*ripz-gz*ripy)*d13 + apy(i)=(ripx*rippz-ripz*rippx)*d12 + & -(gz*ripx-gx*ripz)*d13 + apz(i)=(ripy*rippx-ripx*rippy)*d12 + & -(gx*ripy-gy*ripx)*d13 + + if(i.ge.2) then + cix=bx(ip)-bx(i-1) + ciy=by(ip)-by(i-1) + ciz=bz(ip)-bz(i-1) + cipx=bx(ipp)-bx(i) + cipy=by(ipp)-by(i) + cipz=bz(ipp)-bz(i) + ripx=bx(ipp)-bx(ip) + ripy=by(ipp)-by(ip) + ripz=bz(ipp)-bz(ip) + if(dgm3.gt.0.0D0.and.dg3.gt.0.0D0.and.drip.gt.0.0D0 + & .and.d_gcr3.gt.0.0D0) then + d20=1.0D0/(dg*dgm) + d21=ggm/(dgm3*dg) + d22=ggm/(dgm*dg3) + d23=1.0D0/(dgm*drip) + d24=gmrp/(dgm3*drip) + sd20=1.0D0/(d_gcr*dgm) + sd21=gcr__gm/(d_gcr3*dgm) + sd22=gcr__gm/(d_gcr*dgm3) + else + d20=0.0D0 + d21=0.0D0 + d22=0.0D0 + d23=0.0D0 + d24=0.0D0 + sd20=0.0D0 + sd21=0.0D0 + sd22=0.0D0 + endif + atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 + & -(ciy*gmz-ciz*gmy)*d21 + & +(ripy*gz-ripz*gy)*d22 + atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 + & -(ciz*gmx-cix*gmz)*d21 + & +(ripz*gx-ripx*gz)*d22 + atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 + & -(cix*gmy-ciy*gmx)*d21 + & +(ripx*gy-ripy*gx)*d22 +cc********************************************************************** + astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy + & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix + & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) + & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) + & +gcr_z*(-ripz*rix+gy)) + & -sd22*(-gmy*ciz+gmz*ciy) + + astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix + & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz + & +riz*ripz*gmy) + & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) + & -gcr_z*(ripz*riy+gx)) + & -sd22*(gmx*ciz-gmz*cix) + + astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz + & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy + & -riz*gx*cix) + & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) + & +gcr_z*(ripy*riy+ripx*rix)) + & -sd22*(-gmx*ciy+gmy*cix) +cc********************************************************************** + apmx(i)=(ciy*ripz-ripy*ciz)*d23 + & -(ciy*gmz-ciz*gmy)*d24 + apmy(i)=(ciz*ripx-ripz*cix)*d23 + & -(ciz*gmx-cix*gmz)*d24 + apmz(i)=(cix*ripy-ripx*ciy)*d23 + & -(cix*gmy-ciy*gmx)*d24 + endif + + if(i.ge.3) then + if(dgm3.gt.0.0D0.and.dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 + & .and.d_gmcrim3.gt.0.0D0) then + d30=1.0D0/(dgm*dgmm) + d31=gmmgm/(dgm3*dgmm) + d32=gmmgm/(dgm*dgmm3) + d33=1.0D0/(dgmm*dri) + d34=gmmr/(dgmm3*dri) + d35=gmmr/(dgmm*dri3) + sd30=1.0D0/(d_gmcrim*dgmm) + sd31=gmcrim__gmm/(d_gmcrim3*dgmm) + sd32=gmcrim__gmm/(d_gmcrim*dgmm3) + else + d30=0.0D0 + d31=0.0D0 + d32=0.0D0 + d33=0.0D0 + d34=0.0D0 + d35=0.0D0 + sd30=0.0D0 + sd31=0.0D0 + sd32=0.0D0 + endif + +c write(*,*) 'inside angvectors4' + +cc********************************************************************** + atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 + & -(ciy*gmz-ciz*gmy)*d31 + & -(gmmy*rimmz-gmmz*rimmy)*d32 + atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 + & -(ciz*gmx-cix*gmz)*d31 + & -(gmmz*rimmx-gmmx*rimmz)*d32 + atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 + & -(cix*gmy-ciy*gmx)*d31 + & -(gmmx*rimmy-gmmy*rimmx)*d32 +cc********************************************************************** + astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy + & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz + & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy + & -ciy*rimy*gmmx-rimz*gmx*rimmz) + & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) + & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) + & -sd32*(gmmy*rimmz-rimmy*gmmz) + + astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz + & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy + & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx + & +gmz*rimy*rimmz-rimz*ciz*gmmy) + & -sd31*(gmcrim_x*(cix*rimy-gmz) + & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) + & -sd32*(-gmmx*rimmz+rimmx*gmmz) + + astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz + & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx + & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy + & +rimz*ciy*gmmy+rimz*gmx*rimmx) + & -sd31*(gmcrim_x*(cix*rimz+gmy) + & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) + & -sd32*(gmmx*rimmy-rimmx*gmmy) +c********************************************************************** + apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 + & -(gmmy*rimmz-gmmz*rimmy)*d34 + & +rix*d35 + apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 + & -(gmmz*rimmx-gmmx*rimmz)*d34 + & +riy*d35 + apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 + & -(gmmx*rimmy-gmmy*rimmx)*d34 + & +riz*d35 + endif + + if(i.ge.4) then + if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 + & .and.drim3.gt.0.0D0 + & .and.d_gmmcrimm3.gt.0.0D0) then + d40=1.0D0/(dg30*dgmm) + d41=g3gmm/(dg30*dgmm3) + d42=1.0D0/(dg30*drim) + d43=g3rim_/(dg30*drim3) + sd40=1.0D0/(dg30*d_gmmcrimm) + sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) + else + d40=0.0D0 + d41=0.0D0 + d42=0.0D0 + d43=0.0D0 + sd40=0.0D0 + sd41=0.0D0 + endif + atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 + & -(gmmy*rimmz-gmmz*rimmy)*d41 + atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 + & -(gmmz*rimmx-gmmx*rimmz)*d41 + atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 + & -(gmmx*rimmy-gmmy*rimmx)*d41 +cc********************************************************************** + astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y + & -g3z*rimmz*rimmx+rimmy**2*g3x) + & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) + & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) + + astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y + & -rimmx*rimmy*g3x+rimmz**2*g3y) + & -sd41*(-gmmcrimm_x*rimmx*rimmy + & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmy) + +c & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) + + astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z + & +g3z*rimmx**2-rimmz*rimmy*g3y) + & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz + & +gmmcrimm_z*(rimmy**2+rimmx**2)) +c********************************************************************** + apm3x(i)=g3x*d42-rimx*d43 + apm3y(i)=g3y*d42-rimy*d43 + apm3z(i)=g3z*d42-rimz*d43 + endif + enddo +c******************************************************************************* + +c write(*,*) 'inside angvectors5' + +c do i=inb-2,inb + do i=1,0 + rimx=bx(i)-bx(i-1) + rimy=by(i)-by(i-1) + rimz=bz(i)-bz(i-1) + rimmx=bx(i-1)-bx(i-2) + rimmy=by(i-1)-by(i-2) + rimmz=bz(i-1)-bz(i-2) + rim3x=bx(i-2)-bx(i-3) + rim3y=by(i-2)-by(i-3) + rim3z=bz(i-2)-bz(i-3) + gmmx=rimmy*rimz-rimmz*rimy + gmmy=rimmz*rimx-rimmx*rimz + gmmz=rimmx*rimy-rimmy*rimx + g3x=rim3y*rimmz-rim3z*rimmy + g3y=rim3z*rimmx-rim3x*rimmz + g3z=rim3x*rimmy-rim3y*rimmx + + dg30=sqrt(g3x**2+g3y**2+g3z**2) + g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz + dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) + dgmm3=dgmm**3 + drim=dis(i-1,i) + drimm=dis(i-2,i-1) + drim3=drim**3 + g3rim_=g3x*rimx+g3y*rimy+g3z*rimz +cc********************************************************************** + gmmcrimm_x=gmmy*rimmz-gmmz*rimmy + gmmcrimm_y=gmmz*rimmx-gmmx*rimmz + gmmcrimm_z=gmmx*rimmy-gmmy*rimmx + d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) + d_gmmcrimm3=d_gmmcrimm**3 + gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y + & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y + + if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 + & .and.drim3.gt.0.0D0 + & .and.d_gmmcrimm3.gt.0.0D0) then + d40=1.0D0/(dg30*dgmm) + d41=g3gmm/(dg30*dgmm3) + d42=1.0D0/(dg30*drim) + d43=g3rim_/(dg30*drim3) + sd40=1.0D0/(dg30*d_gmmcrimm) + sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) + else + d40=0.0D0 + d41=0.0D0 + d42=0.0D0 + d43=0.0D0 + sd40=0.0D0 + sd41=0.0D0 + endif + atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 + & -(gmmy*rimmz-gmmz*rimmy)*d41 + atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 + & -(gmmz*rimmx-gmmx*rimmz)*d41 + atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 + & -(gmmx*rimmy-gmmy*rimmx)*d41 +cc********************************************************************** + astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y + & -g3z*rimmz*rimmx+rimmy**2*g3x) + & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) + & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) + + astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y + & -rimmx*rimmy*g3x+rimmz**2*g3y) + & -sd41*(-gmmcrimm_x*rimmx*rimmy + & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) + + astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z + & +g3z*rimmx**2-rimmz*rimmy*g3y) + & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz + & +gmmcrimm_z*(rimmy**2+rimmx**2)) +cc********************************************************************** + apm3x(i)=g3x*d42-rimx*d43 + apm3y(i)=g3y*d42-rimy*d43 + apm3z(i)=g3z*d42-rimz*d43 + + if(i.le.inb-1) then + ip=i+1 + rix=bx(ip)-bx(i) + riy=by(ip)-by(i) + riz=bz(ip)-bz(i) + cix=bx(ip)-bx(i-1) + ciy=by(ip)-by(i-1) + ciz=bz(ip)-bz(i-1) + gmx=rimy*riz-rimz*riy + gmy=rimz*rix-rimx*riz + gmz=rimx*riy-rimy*rix + dgm=sqrt(gmx**2+gmy**2+gmz**2) + dgm3=dgm**3 + dri=dis(i,i+1) + dri3=dri**3 + gmmgm=gmmx*gmx+gmmy*gmy+gmmz+gmz + gmmr=gmmx*rix+gmmy*riy+gmmz*riz + gmcrim_x=gmy*rimz-gmz*rimy + gmcrim_y=gmz*rimx-gmx*rimz + gmcrim_z=gmx*rimy-gmy*rimx + d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) + d_gmcrim3=d_gmcrim**3 + gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy + & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy + + if(dgm3.gt.0.0D0.and. + & dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 + & .and.d_gmcrim3.gt.0.0D0) then + d30=1.0D0/(dgm*dgmm) + d31=gmmgm/(dgm3*dgmm) + d32=gmmgm/(dgm*dgmm3) + d33=1.0D0/(dgmm*dri) + d34=gmmr/(dgmm3*dri) + d35=gmmr/(dgmm*dri3) + sd30=1.0D0/(d_gmcrim*dgmm) + sd31=gmcrim__gmm/(d_gmcrim3*dgmm) + sd32=gmcrim__gmm/(d_gmcrim*dgmm3) + + else + d30=0.0D0 + d31=0.0D0 + d32=0.0D0 + d33=0.0D0 + d34=0.0D0 + d35=0.0D0 + sd30=0.0D0 + sd31=0.0D0 + sd32=0.0D0 + endif +cc********************************************************************** + atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 + & -(ciy*gmz-ciz*gmy)*d31 + & -(gmmy*rimmz-gmmz*rimmy)*d32 + atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 + & -(ciz*gmx-cix*gmz)*d31 + & -(gmmz*rimmx-gmmx*rimmz)*d32 + atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 + & -(cix*gmy-ciy*gmx)*d31 + & -(gmmx*rimmy-gmmy*rimmx)*d32 +cc********************************************************************** + astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy + & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz + & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy + & -ciy*rimy*gmmx-rimz*gmx*rimmz) + & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) + & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) + & -sd32*(gmmy*rimmz-rimmy*gmmz) + + astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz + & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy + & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx + & +gmz*rimy*rimmz-rimz*ciz*gmmy) + & -sd31*(gmcrim_x*(cix*rimy-gmz) + & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) + & -sd32*(-gmmx*rimmz+rimmx*gmmz) + + astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz + & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx + & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy + & +rimz*ciy*gmmy+rimz*gmx*rimmx) + & -sd31*(gmcrim_x*(cix*rimz+gmy) + & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) + & -sd32*(gmmx*rimmy-rimmx*gmmy) +cc********************************************************************** + apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 + & -(gmmy*rimmz-gmmz*rimmy)*d34 + & +rix*d35 + apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 + & -(gmmz*rimmx-gmmx*rimmz)*d34 + & +riy*d35 + apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 + & -(gmmx*rimmy-gmmy*rimmx)*d34 + & +riz*d35 + endif + +c write(*,*) 'inside angvectors6' + + if(i.eq.inb-2) then + ipp=i+2 + ripx=bx(ipp)-bx(ip) + ripy=by(ipp)-by(ip) + ripz=bz(ipp)-bz(ip) + cipx=bx(ipp)-bx(i) + cipy=by(ipp)-by(i) + cipz=bz(ipp)-bz(i) + gx=riy*ripz-riz*ripy + gy=riz*ripx-rix*ripz + gz=rix*ripy-riy*ripx + ggm=gmx*gx+gmy*gy+gmz*gz + gmrp=gmx*ripx+gmy*ripy+gmz*ripz + dg=sqrt(gx**2+gy**2+gz**2) + dg3=dg**3 + drip=dis(i+1,i+2) + gcr_x=gy*riz-gz*riy + gcr_y=gz*rix-gx*riz + gcr_z=gx*riy-gy*rix + d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) + d_gcr3=d_gcr**3 + gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy + & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy + if(dgm3.gt.0.0D0.and. + & dg3.gt.0.0D0.and.drip.gt.0.0D0.and.d_gcr3.gt.0.0D0 + & ) then + d20=1.0D0/(dg*dgm) + d21=ggm/(dgm3*dg) + d22=ggm/(dgm*dg3) + d23=1.0D0/(dgm*drip) + d24=gmrp/(dgm3*drip) + sd20=1.0D0/(d_gcr*dgm) + sd21=gcr__gm/(d_gcr3*dgm) + sd22=gcr__gm/(d_gcr*dgm3) + else + d20=0.0D0 + d21=0.0D0 + d22=0.0D0 + d23=0.0D0 + d24=0.0D0 + sd20=0.0D0 + sd21=0.0D0 + sd22=0.0D0 + endif + atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 + & -(ciy*gmz-ciz*gmy)*d21 + & +(ripy*gz-ripz*gy)*d22 + atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 + & -(ciz*gmx-cix*gmz)*d21 + & +(ripz*gx-ripx*gz)*d22 + atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 + & -(cix*gmy-ciy*gmx)*d21 + & +(ripx*gy-ripy*gx)*d22 +cc********************************************************************** + astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy + & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix + & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) + & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) + & +gcr_z*(-ripz*rix+gy)) + & -sd22*(-gmy*ciz+gmz*ciy) + + astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix + & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz + & +riz*ripz*gmy) + & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) + & -gcr_z*(ripz*riy+gx)) + & -sd22*(gmx*ciz-gmz*cix) + + astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz + & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy + & -riz*gx*cix) + & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) + & +gcr_z*(ripy*riy+ripx*rix)) + & -sd22*(-gmx*ciy+gmy*cix) +cc********************************************************************** +c + apmx(i)=(ciy*ripz-ripy*ciz)*d23 + & -(ciy*gmz-ciz*gmy)*d24 + apmy(i)=(ciz*ripx-ripz*cix)*d23 + & -(ciz*gmx-cix*gmz)*d24 + apmz(i)=(cix*ripy-ripx*ciy)*d23 + & -(cix*gmy-ciy*gmx)*d24 + + endif + enddo + + return + end +c END of angvectors +c------------------------------------------------------------------------------- +C--------------------------------------------------------------------------------- + subroutine sheetforce(nca,wshet) + implicit none +C JYLEE +c this should be matched with dfa.fcm + integer maxca + parameter(maxca=800) +cc********************************************************************** + integer nca + integer i,k + integer inb,nmax,iselect + +c real*8 dfaexp(15001) + + real*8 vbeta,vbetp,vbetm + real*8 shefx(maxca,12) + real*8 shefy(maxca,12),shefz(maxca,12) + real*8 shetfx(maxca),shetfy(maxca),shetfz(maxca) + real*8 vbet(maxca,maxca) + real*8 wshet(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + + common /sheca/ bx,by,bz + common /phys1/ inb,nmax,iselect + common /shef/ shefx,shefy,shefz + common /shee/ vbeta,vbet,vbetp,vbetm + common /shetf/ shetfx,shetfy,shetfz + + inb=nca + do i=1,inb + shetfx(i)=0.0D0 + shetfy(i)=0.0D0 + shetfz(i)=0.0D0 + enddo + + do k=1,12 + do i=1,inb + shefx(i,k)=0.0D0 + shefy(i,k)=0.0D0 + shefz(i,k)=0.0D0 + enddo + enddo + + call sheetene(nca,wshet) + call sheetforce1 + + 887 format(a,1x,i6,3x,f12.8) + 888 format(a,1x,i4,1x,i4,3x,f12.8) + 889 format(a,1x,i4,3x,f12.8) + !write(2,*) 'coord : ' + do i=1,inb + !write(2,887) 'bx:',i,bx(i) + !write(2,887) 'by:',i,by(i) + !write(2,887) 'bz:',i,bz(i) + enddo + !write(2,*) 'After sheetforce1' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + call sheetforce5 + + !write(2,*) 'After sheetforce5' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + call sheetforce6 + + !write(2,*) 'After sheetforce6' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + call sheetforce11 + + !write(2,*) 'After sheetforce11' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + call sheetforce12 + + !write(2,*) 'After sheetforce12' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + do i=1,inb + do k=1,12 + shetfx(i)=shetfx(i)+shefx(i,k) + shetfy(i)=shetfy(i)+shefy(i,k) + shetfz(i)=shetfz(i)+shefz(i,k) + enddo + enddo + !write(2,*) 'Beta Finished' + do i=1,inb + !write(2,889) 'shetfx : ',i,shetfx(i) + !write(2,889) 'shetfy : ',i,shetfy(i) + !write(2,889) 'shetfz : ',i,shetfz(i) + enddo + + return + end +C end sheetforce +c------------------------------------------------------------------------------- + subroutine sheetene(nca,wshet) + implicit none + integer maxca + parameter(maxca=800) + real*8 dfa_cutoff,dfa_cutoff_delta + parameter(dfa_cutoff=15.5d0) + parameter(dfa_cutoff_delta=0.5d0) +cc****************************************************************************** + +c real*8 dfaexp(15001) + real*8 dtmp1, dtmp2, dtmp3 + + real*8 vbet(maxca,maxca) + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 cph(maxca),cth(maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 ulcos(maxca) +cc********************************************************************** + real*8 astx(maxca),asty(maxca),astz(maxca) + real*8 astmx(maxca),astmy(maxca),astmz(maxca) + real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) + real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) + real*8 sth(maxca) + real*8 wshet(maxca,maxca) + real*8 dp45, dm45, w_beta + real*8 c00, s00, ulnex, dnex, dca,dlhb,ulhb,dshe,dldhb,uldhb + integer nca + integer i,ip,ipp,j,jp,jpp,inb,nmax,iselect + real*8 uum, uup + real*8 vbeta,vbetp,vbetm,y,y1,y2,yshe1,yshe2,yy1,yy2 + + real*8 shetfx(maxca),shetfy(maxca),shetfz(maxca) + common /shetf/ shetfx,shetfy,shetfz + + common /sheca/ bx,by,bz + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /coscos/ cph,cth + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + & c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shee/ vbeta,vbet,vbetp,vbetm + common /ulang/ ulcos +cc********************************************************************** + common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, + & astmmz,astm3x,astm3y,astm3z + common /sinsin/ sth + + real*8 r_pair_mat(maxca,maxca) + real*8 e_gcont,fprim_gcont,de_gcont +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m + common /beta_p/ r_pair_mat +C------------------------------------------------------------------------------- + r_pair_mat = 0.0d0 + do i=1,inb + do j=1,inb + r_pair_mat(i,j)=wshet(i,j) +c write(*,*) 'r_pair_mat :',i,j,r_pair_mat(i,j) + enddo + enddo +c stop +c + vbeta=0.0D0 + vbetp=0.0D0 + vbetm=0.0D0 + + do i=1,inb-7 + do j=i+4,inb-3 + + if (dis(i,j).lt.dfa_cutoff) then + call gcont(dis(i,j),dfa_cutoff-dfa_cutoff_delta,1.0D0, + & dfa_cutoff_delta,e_gcont,fprim_gcont) + + + ip=i+1 + ipp=i+2 + jp=j+1 + jpp=j+2 +cc********************************************************************** + y1=(cth(i)*c00+sth(i)*s00-1.0D0)**2 + & +(cth(j)*c00+sth(j)*s00-1.0D0)**2 + y1=-0.5d0*y1/dca + y2=(ulcos(i)-ulnex)**2+(ulcos(ip)-ulnex)**2 + & +(ulcos(j)-ulnex)**2+(ulcos(jp)-ulnex)**2 + y2=-0.5d0*y2/dnex + +cdebug y2=0 + + y=y1+y2 + +ci if(y.ge.-4) then +ci istrand(i,j)=1 +ci else +ci istrand(i,j)=0 +ci endif + +ci if(istrand(i,j).eq.1) then + + yy1=-0.5d0*(dis(ip,jp)-ulhb)**2/dlhb + yy2=-0.5d0*(dis(ipp,jpp)-ulhb)**2/dlhb + + + pin1(i,j)=(rx(ip,jp)*rx(ip,ipp)+ry(ip,jp)*ry(ip,ipp) + $ +rz(ip,jp)*rz(ip,ipp))/(dis(ip,jp)*dis(ip,ipp)) + pin2(i,j)=(rx(ip,jp)*rx(jp,jpp)+ry(ip,jp)*ry(jp,jpp) + $ +rz(ip,jp)*rz(jp,jpp))/(dis(ip,jp)*dis(jp,jpp)) + pin3(i,j)=(rx(ipp,jpp)*rx(ip,ipp)+ry(ipp,jpp)*ry(ip,ipp) + $ +rz(ipp,jpp)*rz(ip,ipp))/(dis(ipp,jpp)*dis(ip,ipp)) + pin4(i,j)=(rx(ipp,jpp)*rx(jp,jpp)+ry(ipp,jpp)*ry(jp,jpp) + $ +rz(ipp,jpp)*rz(jp,jpp))/(dis(ipp,jpp)*dis(jp,jpp)) + + yshe1=pin1(i,j)**2+pin2(i,j)**2 + yshe1=-0.5d0*yshe1/dshe + yshe2=pin3(i,j)**2+pin4(i,j)**2 + yshe2=-0.5d0*yshe2/dshe + +ci if((yshe1+yshe2).ge.-4) then +ci istrand_p(i,j)=1 +ci else +ci istrand_p(i,j)=0 +ci endif + + +C write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) +C write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) +C write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) +C write(*,*) 'dis(i,j):',i,j,dis(i,j) +C write(*,*) 'rx(ip,jp):',ip,jp,bx(ip),bx(jp),rx(ip,jp) +C write(*,*) 'rx(ip,ipp):',ip,ipp,bx(ip),bx(ipp),rx(ip,ipp) +C write(*,*) 'pin1:',pin1(i,j) +C write(*,*) 'pin2:',pin2(i,j) +C write(*,*) 'pin3:',pin3(i,j) +C write(*,*) 'pin4:',pin4(i,j) + +C write(*,*) 'y:',y +C write(*,*) 'yy1:',yy1 +C write(*,*) 'yy2:',yy2 +C write(*,*) 'yshe1:',yshe1 +C write(*,*) 'yshe2:',yshe2 +c + +ci if (istrand_p(i,j).eq.1) then + +cd yy1=0 +cd yy2=0 +cd yshe1=0 +cd yshe2=0 + dtmp1 = y+yy1+yshe1 + dtmp2 = y+yy2+yshe2 + dtmp3 = y+yy1+yy2+yshe1+yshe2 + +C write(*,*)'1', i,j,dtmp1,dtmp2,dtmp3 +C write(*,*)'2', y,yy1,yy2 +C write(*,*)'3', yshe1,yshe2 + +cc if (dtmp3.le.-35.0d0) then +c vbetap(i,j)=-dp45*exp(dtmp3) +cc vbetap(i,j)=0.0d0 +cc else +c vbetap(i,j)=-dp45*dfaexp(idint(-dtmp3*1000)+1) + vbetap(i,j)=-dp45*exp(dtmp3) +cc end if + +cc if (dtmp1.le.-35.0d0) then +c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1) +cc vbetap1(i,j)=0.0d0 +cc else +c vbetap1(i,j)=-r_pair_mat(i+1,j+1) +c $ *dfaexp(idint(-dtmp1*1000)+1) + vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1) +cc end if + +cc if (dtmp2.le.-35.0d0) then +C vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2) +cc vbetap2(i,j)=0.0d0 +cc else +c vbetap2(i,j)=-r_pair_mat(i+2,j+2) +c $ *dfaexp(idint(-dtmp2*1000)+1) + vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2) +cc end if + +c vbetap(i,j)=-dp45*exp(y+yy1+yy2+yshe1+yshe2) +c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(y+yy1+yshe1) +c vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(y+yy2+yshe2) + +! write(*,*) 'r_pair_mat>',i+1,j+1,r_pair_mat(i+1,j+1) +! write(*,*) 'r_pair_mat>',i+2,j+2,r_pair_mat(i+2,j+2) + +ci elseif (istrand_p(i,j).eq.0)then +ci vbetap(i,j)=0 +ci vbetap1(i,j)=0 +ci vbetap2(i,j)=0 +ci endif + + yy1=-0.5d0*(dis(ip,jpp)-ulhb)**2/dlhb + yy2=-0.5d0*(dis(ipp,jp)-ulhb)**2/dlhb + + pina1(i,j)=(rx(ip,jpp)*rx(ip,ipp)+ry(ip,jpp)*ry(ip,ipp) + $ +rz(ip,jpp)*rz(ip,ipp))/(dis(ip,jpp)*dis(ip,ipp)) + pina2(i,j)=(rx(ip,jpp)*rx(jp,jpp)+ry(ip,jpp)*ry(jp,jpp) + $ +rz(ip,jpp)*rz(jp,jpp))/(dis(ip,jpp)*dis(jp,jpp)) + pina3(i,j)=(rx(jp,ipp)*rx(ip,ipp)+ry(jp,ipp)*ry(ip,ipp) + $ +rz(jp,ipp)*rz(ip,ipp))/(dis(jp,ipp)*dis(ip,ipp)) + pina4(i,j)=(rx(jp,ipp)*rx(jp,jpp)+ry(jp,ipp)*ry(jp,jpp) + $ +rz(jp,ipp)*rz(jp,jpp))/(dis(jp,ipp)*dis(jp,jpp)) + + yshe1=pina1(i,j)**2+pina2(i,j)**2 + yshe1=-0.5d0*yshe1/dshe + yshe2=pina3(i,j)**2+pina4(i,j)**2 + yshe2=-0.5d0*yshe2/dshe + +ci if((yshe1+yshe2).ge.-4) then +ci istrand_m(i,j)=1 +ci else +ci istrand_m(i,j)=0 +ci endif + + +C write(*,*) 'pina1:',pina1(i,j) +C write(*,*) 'pina2:',pina2(i,j) +C write(*,*) 'pina3:',pina3(i,j) +C write(*,*) 'pina4:',pina4(i,j) +C write(*,*) 'yshe1:',yshe1 +C write(*,*) 'yshe2:',yshe2 +C write(*,*) 'dshe:',dshe + +ci if (istrand_m(i,j).eq.1) then + +cd yy1=0 +cd yy2=0 +cd yshe1=0 +cd yshe2=0 + + dtmp3=y+yy1+yy2+yshe1+yshe2 + dtmp1=y+yy1+yshe1 + dtmp2=y+yy2+yshe2 + +cc if(dtmp3 .le. -35.0d0) then +c vbetam(i,j)=-dm45*exp(dtmp3) +cc vbetam(i,j)=0.0d0 +cc else +c vbetam(i,j)=-dm45*dfaexp(idint(-dtmp3*1000)+1) + vbetam(i,j)=-dm45*exp(dtmp3) +cc end if + +cc if(dtmp1 .le. -35.0d0) then +c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1) +cc vbetam1(i,j)=0.0d0 +cc else +c vbetam1(i,j)=-r_pair_mat(i+1,j+2) +c $ *dfaexp(idint(-dtmp1*1000)+1) + vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1) +cc end if + +cc if(dtmp2.le.-35.0d0) then +c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2) +cc vbetam2(i,j)=0.0d0 +cc else +c vbetam2(i,j)=-r_pair_mat(i+2,j+1) +c $ *dfaexp(idint(-dtmp2*1000)+1) + vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2) +cc end if + +ci elseif (istrand_m(i,j).eq.0)then +ci vbetam(i,j)=0 +ci vbetam1(i,j)=0 +ci vbetam2(i,j)=0 +ci endif + + +c vbetam(i,j)=-dm45*exp(y+yy1+yy2+yshe1+yshe2) +c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(y+yy1+yshe1) +c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(y+yy2+yshe2) + +! write(*,*) 'r_pair_mat>',i+1,j+2,r_pair_mat(i+1,j+2) +! write(*,*) 'r_pair_mat>',i+2,j+1,r_pair_mat(i+2,j+1) + + uup = vbetap(i,j)+vbetap1(i,j)+vbetap2(i,j) + uum = vbetam(i,j)+vbetam1(i,j)+vbetam2(i,j) + +c write(*,*) 'uup,uum:', uup, uum + +c uup=vbetap1(i,j)+vbetap2(i,j) +c uum=vbetam1(i,j)+vbetam2(i,j) + + vbet(i,j)=uup+uum + vbetp=vbetp+uup + vbetm=vbetm+uum + vbeta=vbeta+vbet(i,j)*e_gcont + + + if (dis(i,j) .ge. dfa_cutoff-2*dfa_cutoff_delta) then +c gradient correction from gcont + de_gcont=vbet(i,j)*fprim_gcont/dis(i,j) + shetfx(i)=shetfx(i) + de_gcont*rx(i,j) + shetfy(i)=shetfy(i) + de_gcont*ry(i,j) + shetfz(i)=shetfz(i) + de_gcont*rz(i,j) + + shetfx(j)=shetfx(j) - de_gcont*rx(i,j) + shetfy(j)=shetfy(j) - de_gcont*ry(i,j) + shetfz(j)=shetfz(j) - de_gcont*rz(i,j) + +c energy correction from gcont + vbet(i,j)=vbet(i,j)*e_gcont + vbetap(i,j)=vbetap(i,j)*e_gcont + vbetap1(i,j)=vbetap1(i,j)*e_gcont + vbetap2(i,j)=vbetap2(i,j)*e_gcont + vbetam(i,j)=vbetam(i,j)*e_gcont + vbetam1(i,j)=vbetam1(i,j)*e_gcont + vbetam2(i,j)=vbetam2(i,j)*e_gcont + endif + + +ci elseif(istrand(i,j).eq.0)then +ci vbet(i,j)=0 +ci endif + +c write(*,*) 'uup,uum:',uup,uum +c write(*,*) 'vbetap(i,j):',vbetap(i,j) +c write(*,*) 'vbetap1(i,j):',vbetap1(i,j) +c write(*,*) 'vbetap2(i,j):',vbetap2(i,j) +c write(*,*) 'vbetam(i,j):',vbetam(i,j) +c write(*,*) 'vbetam1(i,j):',vbetam1(i,j) +c write(*,*) 'vbetam2(i,j):',vbetam2(i,j) +c write(*,*) 'uup:',uup +c write(*,*) 'uum:',uum +c write(*,*) 'vbetp:',vbetp +c write(*,*) 'vbetm:',vbetm +c write(*,*) 'vbet(i,j):',vbet(i,j) +c stop + + else + vbetap(i,j)=0 + vbetap1(i,j)=0 + vbetap2(i,j)=0 + vbetam(i,j)=0 + vbetam1(i,j)=0 + vbetam2(i,j)=0 + vbet(i,j)=0 + endif + enddo + enddo + +! do i=1,inb-7 +! do j=i+4,inb-3 +! write(*,*) 'I,J:', i,j +! write(*,*) 'vbetap(i,j):',vbetap(i,j) +! write(*,*) 'vbetap1(i,j):',vbetap1(i,j) +! write(*,*) 'vbetap2(i,j):',vbetap2(i,j) +! write(*,*) 'vbetam(i,j):',vbetam(i,j) +! write(*,*) 'vbetam1(i,j):',vbetam1(i,j) +! write(*,*) 'vbetam2(i,j):',vbetam2(i,j) +! write(*,*) 'vbet(i,j):',vbet(i,j) +! enddo +! enddo + + return + end +c------------------------------------------------------------------------------- + subroutine sheetforce1 + implicit none + integer maxca + parameter(maxca=800) + real*8 dfa_cutoff,dfa_cutoff_delta + parameter(dfa_cutoff=15.5d0) + parameter(dfa_cutoff_delta=0.5d0) +cc********************************************************************** + real*8 vbet(maxca,maxca) + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 cph(maxca),cth(maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12) + real*8 shefy(maxca,12),shefz(maxca,12) + real*8 atx(maxca),aty(maxca),atz(maxca) + real*8 atmx(maxca),atmy(maxca),atmz(maxca) + real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) + real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) + real*8 apx(maxca),apy(maxca),apz(maxca) + real*8 apmx(maxca),apmy(maxca),apmz(maxca) + real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) + real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) + real*8 ulcos(maxca) + real*8 astx(maxca),asty(maxca),astz(maxca) + real*8 astmx(maxca),astmy(maxca),astmz(maxca) + real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) + real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) + real*8 sth(maxca) + real*8 w_beta,dp45, dm45 + real*8 vbeta, vbetp, vbetm + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect + + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /coscos/ cph,cth + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, + $ atmmz,atm3x,atm3y,atm3z + common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, + $ apmmz,apm3x,apm3y,apm3z + common /shef/ shefx,shefy,shefz + common /shee/ vbeta,vbet,vbetp,vbetm + common /ulang/ ulcos +c c********************************************************************** + common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, + $ astmmz,astm3x,astm3y,astm3z + common /sinsin/ sth +C-------------------------------------------------------------------------------- +c local variables + integer i,j,im3,imm,im,ip,ipp,jm,jmm,jm3,jp,jpp + real*8 c1,v1,cc1,dmm,dmm__,fx,fy,fz,c2,v2,dmm1 + real*8 c3,v3,cc2,cc3,dmm3,dmm3__,c4,v4,c7,v7,cc7,c8,v8,cc8 + real*8 c9,v9,cc9,dmm9,dmm9__,c10,v10,dmm2,dmm1__,dmm2_1,dmm2_2 + real*8 dmm7,dmm8,dmm7__,dmm8_1,dmm8_2 + real*8 e_gcont,fprim_gcont +C-------------------------------------------------------------------------------- + do i=4,inb-4 + im3=i-3 + imm=i-2 + im=i-1 + c1=(cth(im3)*c00+sth(im3)*s00-1)/dca + v1=0.0D0 + do j=i+1,inb-3 + v1=v1+vbet(im3,j) + enddo + cc1=(ulcos(imm)-ulnex)/dnex + dmm=cc1/(dis(imm,im)*dis(im,i)) + dmm__=cc1*ulcos(imm)/dis(im,i)**2 + fx=rx(imm,im)*dmm-rx(im,i)*dmm__ + fy=ry(imm,im)*dmm-ry(im,i)*dmm__ + fz=rz(imm,im)*dmm-rz(im,i)*dmm__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atm3x(i)*c00+astm3x(i)*s00)*c1 + fy=fy+(atm3y(i)*c00+astm3y(i)*s00)*c1 + fz=fz+(atm3z(i)*c00+astm3z(i)*s00)*c1 + shefx(i,1)=fx*v1 + shefy(i,1)=fy*v1 + shefz(i,1)=fz*v1 + enddo + + do i=3,inb-5 + imm=i-2 + im=i-1 + ip=i+1 + c2=(cth(imm)*c00+sth(imm)*s00-1)/dca + v2=0.0D0 + do j=i+2,inb-3 + v2=v2+vbet(imm,j) + enddo + cc1=(ulcos(imm)-ulnex)/dnex + cc2=(ulcos(im)-ulnex)/dnex + dmm1=cc1/(dis(imm,im)*dis(im,i)) + dmm2=cc2/(dis(im,i)*dis(i,ip)) + dmm1__=cc1*ulcos(imm)/dis(im,i)**2 + dmm2_1=cc2*ulcos(im)/dis(im,i)**2 + dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 +cc********************************************************************** + fx=rx(imm,im)*dmm1-rx(im,i)*dmm1__+rx(i,ip)*dmm2-rx(im,i)*dmm2 + $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2 + fy=ry(imm,im)*dmm1-ry(im,i)*dmm1__+ry(i,ip)*dmm2-ry(im,i)*dmm2 + $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2 + fz=rz(imm,im)*dmm1-rz(im,i)*dmm1__+rz(i,ip)*dmm2-rz(im,i)*dmm2 + $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2 +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atmmx(i)*c00+astmmx(i)*s00)*c2 + fy=fy+(atmmy(i)*c00+astmmy(i)*s00)*c2 + fz=fz+(atmmz(i)*c00+astmmz(i)*s00)*c2 + shefx(i,2)=fx*v2 + shefy(i,2)=fy*v2 + shefz(i,2)=fz*v2 + enddo + do i=2,inb-6 + im=i-1 + ip=i+1 + ipp=i+2 + c3=(cth(im)*c00+sth(im)*s00-1)/dca + v3=0.0D0 + do j=i+3,inb-3 + v3=v3+vbet(im,j) + enddo + cc2=(ulcos(im)-ulnex)/dnex + cc3=(ulcos(i)-ulnex)/dnex + dmm2=cc2/(dis(im,i)*dis(i,ip)) + dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) + dmm2_1=cc2*ulcos(im)/dis(im,i)**2 + dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 + dmm3__=cc3*ulcos(i)/dis(i,ip)**2 + fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm2-rx(im,i)*dmm2 + $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2+rx(i,ip)*dmm3__ + fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm2-ry(im,i)*dmm2 + $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2+ry(i,ip)*dmm3__ + fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm2-rz(im,i)*dmm2 + $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2+rz(i,ip)*dmm3__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atmx(i)*c00+astmx(i)*s00)*c3 + fy=fy+(atmy(i)*c00+astmy(i)*s00)*c3 + fz=fz+(atmz(i)*c00+astmz(i)*s00)*c3 + shefx(i,3)=fx*v3 + shefy(i,3)=fy*v3 + shefz(i,3)=fz*v3 + enddo + do i=1,inb-7 + ip=i+1 + ipp=i+2 + c4=(cth(i)*c00+sth(i)*s00-1)/dca + v4=0.0D0 + do j=i+4,inb-3 + v4=v4+vbet(i,j) + enddo + cc3=(ulcos(i)-ulnex)/dnex + dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) + dmm3__=cc3*ulcos(i)/dis(i,ip)**2 + fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm3__ + fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm3__ + fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm3__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atx(i)*c00+astx(i)*s00)*c4 + fy=fy+(aty(i)*c00+asty(i)*s00)*c4 + fz=fz+(atz(i)*c00+astz(i)*s00)*c4 + shefx(i,4)=fx*v4 + shefy(i,4)=fy*v4 + shefz(i,4)=fz*v4 + enddo + do j=8,inb + jm3=j-3 + jmm=j-2 + jm=j-1 + c7=(cth(jm3)*c00+sth(jm3)*s00-1)/dca + v7=0.0D0 + do i=1,j-7 + v7=v7+vbet(i,jm3) + enddo + cc7=(ulcos(jmm)-ulnex)/dnex + dmm=cc7/(dis(jmm,jm)*dis(jm,j)) + dmm__=cc7*ulcos(jmm)/dis(jm,j)**2 + fx=rx(jmm,jm)*dmm-rx(jm,j)*dmm__ + fy=ry(jmm,jm)*dmm-ry(jm,j)*dmm__ + fz=rz(jmm,jm)*dmm-rz(jm,j)*dmm__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atm3x(j)*c00+astm3x(j)*s00)*c7 + fy=fy+(atm3y(j)*c00+astm3y(j)*s00)*c7 + fz=fz+(atm3z(j)*c00+astm3z(j)*s00)*c7 + shefx(j,7)=fx*v7 + shefy(j,7)=fy*v7 + shefz(j,7)=fz*v7 + enddo + do j=7,inb-1 + jm=j-1 + jmm=j-2 + jp=j+1 + c8=(cth(jmm)*c00+sth(jmm)*s00-1)/dca + v8=0.0D0 + do i=1,j-6 + v8=v8+vbet(i,jmm) + enddo + cc7=(ulcos(jmm)-ulnex)/dnex + cc8=(ulcos(jm)-ulnex)/dnex + dmm7=cc7/(dis(jmm,jm)*dis(jm,j)) + dmm8=cc8/(dis(jm,j)*dis(j,jp)) + dmm7__=cc7*ulcos(jmm)/dis(jm,j)**2 + dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 + dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 + fx=rx(jmm,jm)*dmm7+rx(j,jp)*dmm8-rx(jm,j)*dmm8 + $ -rx(jm,j)*dmm7__-rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2 + fy=ry(jmm,jm)*dmm7+ry(j,jp)*dmm8-ry(jm,j)*dmm8 + $ -ry(jm,j)*dmm7__-ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2 + fz=rz(jmm,jm)*dmm7+rz(j,jp)*dmm8-rz(jm,j)*dmm8 + $ -rz(jm,j)*dmm7__-rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2 +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atmmx(j)*c00+astmmx(j)*s00)*c8 + fy=fy+(atmmy(j)*c00+astmmy(j)*s00)*c8 + fz=fz+(atmmz(j)*c00+astmmz(j)*s00)*c8 + shefx(j,8)=fx*v8 + shefy(j,8)=fy*v8 + shefz(j,8)=fz*v8 + enddo + + do j=6,inb-2 + jm=j-1 + jp=j+1 + jpp=j+2 + c9=(cth(jm)*c00+sth(jm)*s00-1)/dca + v9=0.0D0 + do i=1,j-5 + v9=v9+vbet(i,jm) + enddo + cc8=(ulcos(jm)-ulnex)/dnex + cc9=(ulcos(j)-ulnex)/dnex + dmm8=cc8/(dis(jm,j)*dis(j,jp)) + dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) + dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 + dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 + dmm9__=cc9*ulcos(j)/dis(j,jp)**2 + fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm8-rx(jm,j)*dmm8 + $ -rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2+rx(j,jp)*dmm9__ + fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm8-ry(jm,j)*dmm8 + $ -ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2+ry(j,jp)*dmm9__ + fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm8-rz(jm,j)*dmm8 + $ -rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2+rz(j,jp)*dmm9__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atmx(j)*c00+astmx(j)*s00)*c9 + fy=fy+(atmy(j)*c00+astmy(j)*s00)*c9 + fz=fz+(atmz(j)*c00+astmz(j)*s00)*c9 + shefx(j,9)=fx*v9 + shefy(j,9)=fy*v9 + shefz(j,9)=fz*v9 + enddo + + do j=5,inb-3 + jp=j+1 + jpp=j+2 + c10=(cth(j)*c00+sth(j)*s00-1)/dca + v10=0.0D0 + do i=1,j-4 + v10=v10+vbet(i,j) + enddo + cc9=(ulcos(j)-ulnex)/dnex + dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) + dmm9__=cc9*ulcos(j)/dis(j,jp)**2 + fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm9__ + fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm9__ + fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm9__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atx(j)*c00+astx(j)*s00)*c10 + fy=fy+(aty(j)*c00+asty(j)*s00)*c10 + fz=fz+(atz(j)*c00+astz(j)*s00)*c10 + shefx(j,10)=fx*v10 + shefy(j,10)=fy*v10 + shefz(j,10)=fz*v10 + enddo + + return + end +c---------------------------------------------------------------------------- + subroutine sheetforce5 + implicit none + integer maxca + parameter(maxca=800) + real*8 dfa_cutoff,dfa_cutoff_delta + parameter(dfa_cutoff=15.5d0) + parameter(dfa_cutoff_delta=0.5d0) +cc********************************************************************** + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12),shefy(maxca,12) + real*8 shefz(maxca,12) + real*8 dp45,dm45,w_beta + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect +cc********************************************************************** + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shef/ shefx,shefy,shefz +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m +c******************************************************************************** +c local variables + integer i,imm,im,jp,jpp,j + real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z + real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z + real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z + real*8 y66x,y66y,y66z,yy6,yyy4,yyy5a,yyy5b + real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z + real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b + real*8 e_gcont,fprim_gcont +c******************************************************************************** + do i=3,inb-5 + imm=i-2 + im=i-1 + do j=i+2,inb-3 + + if (dis(imm,j).lt.dfa_cutoff) then + call gcont(dis(imm,j),dfa_cutoff-dfa_cutoff_delta,1.0D0, + & dfa_cutoff_delta,e_gcont,fprim_gcont) + + jp=j+1 + jpp=j+2 + +ci if(istrand(imm,j).eq.1 +ci & .and.(istrand_p(imm,j)+istrand_m(imm,j)).ge.1) then + + + yy1=-(dis(i,jpp)-ulhb)/dlhb + y1x=rx(jpp,i)/dis(i,jpp) + y1y=ry(jpp,i)/dis(i,jpp) + y1z=rz(jpp,i)/dis(i,jpp) + y11x=yy1*y1x + y11y=yy1*y1y + y11z=yy1*y1z + + yy33=1.0D0/(dis(im,jp)*dis(im,i)) + yyy3=pin1(imm,j)/(dis(im,i)**2) + yy3=-pin1(imm,j)/dshe + y3x=(yy33*rx(im,jp)-yyy3*rx(im,i))*yy3 + y3y=(yy33*ry(im,jp)-yyy3*ry(im,i))*yy3 + y3z=(yy33*rz(im,jp)-yyy3*rz(im,i))*yy3 + + yy44=1.0D0/(dis(i,jpp)*dis(im,i)) + yyy4a=pin3(imm,j)/(dis(i,jpp)**2) + yyy4b=pin3(imm,j)/(dis(im,i)**2) + yy4=-pin3(imm,j)/dshe + y4x=(yy44*(rx(i,jpp)-rx(im,i))+yyy4a*rx(i,jpp) + $ -yyy4b*rx(im,i))*yy4 + y4y=(yy44*(ry(i,jpp)-ry(im,i))+yyy4a*ry(i,jpp) + $ -yyy4b*ry(im,i))*yy4 + y4z=(yy44*(rz(i,jpp)-rz(im,i))+yyy4a*rz(i,jpp) + $ -yyy4b*rz(im,i))*yy4 + + + yy55=1.0D0/(dis(i,jpp)*dis(jp,jpp)) + yyy5=pin4(imm,j)/(dis(i,jpp)**2) + yy5=-pin4(imm,j)/dshe + y5x=(-yy55*rx(jp,jpp)+yyy5*rx(i,jpp))*yy5 + y5y=(-yy55*ry(jp,jpp)+yyy5*ry(i,jpp))*yy5 + y5z=(-yy55*rz(jp,jpp)+yyy5*rz(i,jpp))*yy5 + + sx=y11x+y3x+y4x+y5x + sy=y11y+y3y+y4y+y5y + sz=y11z+y3z+y4z+y5z + + sx1=y3x + sy1=y3y + sz1=y3z + sx2=y11x+y4x+y5x + sy2=y11y+y4y+y5y + sz2=y11z+y4z+y5z + + shefx(i,5)=shefx(i,5)-sx*vbetap(imm,j) + $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) + shefy(i,5)=shefy(i,5)-sy*vbetap(imm,j) + $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) + shefz(i,5)=shefz(i,5)-sz*vbetap(imm,j) + $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) + +! shefx(i,5)=shefx(i,5) +! $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) +! shefy(i,5)=shefy(i,5) +! $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) +! shefz(i,5)=shefz(i,5) +! $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) + + yy6=-(dis(i,jp)-uldhb)/dldhb + y6x=rx(jp,i)/dis(i,jp) + y6y=ry(jp,i)/dis(i,jp) + y6z=rz(jp,i)/dis(i,jp) + y66x=yy6*y6x + y66y=yy6*y6y + y66z=yy6*y6z + + yy88=1.0D0/(dis(im,jpp)*dis(im,i)) + yyy8=pina1(imm,j)/(dis(im,i)**2) + yy8=-pina1(imm,j)/dshe + y8x=(yy88*rx(im,jpp)-yyy8*rx(im,i))*yy8 + y8y=(yy88*ry(im,jpp)-yyy8*ry(im,i))*yy8 + y8z=(yy88*rz(im,jpp)-yyy8*rz(im,i))*yy8 + + yy99=1.0D0/(dis(jp,i)*dis(im,i)) + yyy9a=pina3(imm,j)/(dis(jp,i)**2) + yyy9b=pina3(imm,j)/(dis(im,i)**2) + yy9=-pina3(imm,j)/dshe + y9x=(yy99*(rx(jp,i)+rx(im,i))-yyy9a*rx(jp,i) + $ -yyy9b*rx(im,i))*yy9 + y9y=(yy99*(ry(jp,i)+ry(im,i))-yyy9a*ry(jp,i) + $ -yyy9b*ry(im,i))*yy9 + y9z=(yy99*(rz(jp,i)+rz(im,i))-yyy9a*rz(jp,i) + $ -yyy9b*rz(im,i))*yy9 + + yy1010=1.0D0/(dis(jp,i)*dis(jp,jpp)) + yyy10=pina4(imm,j)/(dis(jp,i)**2) + yy10=-pina4(imm,j)/dshe + y10x=(yy1010*rx(jp,jpp)-yyy10*rx(jp,i))*yy10 + y10y=(yy1010*ry(jp,jpp)-yyy10*ry(jp,i))*yy10 + y10z=(yy1010*rz(jp,jpp)-yyy10*rz(jp,i))*yy10 + + sx=y66x+y8x+y9x+y10x + sy=y66y+y8y+y9y+y10y + sz=y66z+y8z+y9z+y10z + + sx1=y8x + sy1=y8y + sz1=y8z + sx2=y66x+y9x+y10x + sy2=y66y+y9y+y10y + sz2=y66z+y9z+y10z + + shefx(i,5)=shefx(i,5)-sx*vbetam(imm,j) + $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) + shefy(i,5)=shefy(i,5)-sy*vbetam(imm,j) + $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) + shefz(i,5)=shefz(i,5)-sz*vbetam(imm,j) + $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) + +! shefx(i,5)=shefx(i,5) +! $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) +! shefy(i,5)=shefy(i,5) +! $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) +! shefz(i,5)=shefz(i,5) +! $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) + + endif +ci endif + + enddo + enddo + + return + end +c--------------------------------------------------------------------------c + subroutine sheetforce6 + implicit none + integer maxca + parameter(maxca=800) + real*8 dfa_cutoff,dfa_cutoff_delta + parameter(dfa_cutoff=15.5d0) + parameter(dfa_cutoff_delta=0.5d0) +cc********************************************************************** + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12),shefy(maxca,12) + real*8 shefz(maxca,12) + real*8 dp45,dm45,w_beta + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect +cc********************************************************************** + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shef/ shefx,shefy,shefz +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m +cc********************************************************************** +C local variables + integer i,imm,im,jp,jpp,j,ip + real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z + real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z + real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y + real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z + real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b,yyy4 + real*8 yyy3a,yyy3b,y66z,yy6,yyy5a,yyy5b + real*8 e_gcont,fprim_gcont +C******************************************************************************** + do i=2,inb-6 + ip=i+1 + im=i-1 + do j=i+3,inb-3 + + if (dis(im,j).lt.dfa_cutoff) then + call gcont(dis(im,j),dfa_cutoff-dfa_cutoff_delta,1.0D0, + & dfa_cutoff_delta,e_gcont,fprim_gcont) + + jp=j+1 + jpp=j+2 + +ci if(istrand(im,j).eq.1 +ci & .and.(istrand_p(im,j)+istrand_m(im,j)).ge.1) then + + + yy1=-(dis(i,jp)-ulhb)/dlhb + y1x=rx(jp,i)/dis(i,jp) + y1y=ry(jp,i)/dis(i,jp) + y1z=rz(jp,i)/dis(i,jp) + y11x=yy1*y1x + y11y=yy1*y1y + y11z=yy1*y1z + + yy33=1.0D0/(dis(i,jp)*dis(i,ip)) + yyy3a=pin1(im,j)/(dis(i,jp)**2) + yyy3b=pin1(im,j)/(dis(i,ip)**2) + yy3=-pin1(im,j)/dshe + y3x=(-yy33*(rx(i,ip)+rx(i,jp))+yyy3a*rx(i,jp) + $ +yyy3b*rx(i,ip))*yy3 + y3y=(-yy33*(ry(i,ip)+ry(i,jp))+yyy3a*ry(i,jp) + $ +yyy3b*ry(i,ip))*yy3 + y3z=(-yy33*(rz(i,ip)+rz(i,jp))+yyy3a*rz(i,jp) + $ +yyy3b*rz(i,ip))*yy3 + + yy44=1.0D0/(dis(i,jp)*dis(jp,jpp)) + yyy4=pin2(im,j)/(dis(i,jp)**2) + yy4=-pin2(im,j)/dshe + y4x=(-yy44*rx(jp,jpp)+yyy4*rx(i,jp))*yy4 + y4y=(-yy44*ry(jp,jpp)+yyy4*ry(i,jp))*yy4 + y4z=(-yy44*rz(jp,jpp)+yyy4*rz(i,jp))*yy4 + + yy55=1.0D0/(dis(ip,jpp)*dis(i,ip)) + yyy5=pin3(im,j)/(dis(i,ip)**2) + yy5=-pin3(im,j)/dshe + y5x=(-yy55*rx(ip,jpp)+yyy5*rx(i,ip))*yy5 + y5y=(-yy55*ry(ip,jpp)+yyy5*ry(i,ip))*yy5 + y5z=(-yy55*rz(ip,jpp)+yyy5*rz(i,ip))*yy5 + + sx=y11x+y3x+y4x+y5x + sy=y11y+y3y+y4y+y5y + sz=y11z+y3z+y4z+y5z + + sx1=y11x+y3x+y4x + sy1=y11y+y3y+y4y + sz1=y11z+y3z+y4z + sx2=y5x + sy2=y5y + sz2=y5z + + shefx(i,6)=shefx(i,6)-sx*vbetap(im,j) + $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) + shefy(i,6)=shefy(i,6)-sy*vbetap(im,j) + $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) + shefz(i,6)=shefz(i,6)-sz*vbetap(im,j) + $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) +! shefx(i,6)=shefx(i,6) +! $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) +! shefy(i,6)=shefy(i,6) +! $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) +! shefz(i,6)=shefz(i,6) +! $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) + + yy6=-(dis(jpp,i)-uldhb)/dldhb + y6x=rx(jpp,i)/dis(jpp,i) + y6y=ry(jpp,i)/dis(jpp,i) + y6z=rz(jpp,i)/dis(jpp,i) + y66x=yy6*y6x + y66y=yy6*y6y + y66z=yy6*y6z + + yy88=1.0D0/(dis(i,jpp)*dis(i,ip)) + yyy8a=pina1(im,j)/(dis(i,jpp)**2) + yyy8b=pina1(im,j)/(dis(i,ip)**2) + yy8=-pina1(im,j)/dshe + y8x=(-yy88*(rx(i,jpp)+rx(i,ip))+yyy8a*rx(i,jpp) + $ +yyy8b*rx(i,ip))*yy8 + y8y=(-yy88*(ry(i,jpp)+ry(i,ip))+yyy8a*ry(i,jpp) + $ +yyy8b*ry(i,ip))*yy8 + y8z=(-yy88*(rz(i,jpp)+rz(i,ip))+yyy8a*rz(i,jpp) + $ +yyy8b*rz(i,ip))*yy8 + + yy99=1.0D0/(dis(i,jpp)*dis(jp,jpp)) + yyy9=pina2(im,j)/(dis(i,jpp)**2) + yy9=-pina2(im,j)/dshe + y9x=(-yy99*rx(jp,jpp)+yyy9*rx(i,jpp))*yy9 + y9y=(-yy99*ry(jp,jpp)+yyy9*ry(i,jpp))*yy9 + y9z=(-yy99*rz(jp,jpp)+yyy9*rz(i,jpp))*yy9 + + yy1010=1.0D0/(dis(jp,ip)*dis(i,ip)) + yyy10=pina3(im,j)/(dis(i,ip)**2) + yy10=-pina3(im,j)/dshe + y10x=(-yy1010*rx(jp,ip)+yyy10*rx(i,ip))*yy10 + y10y=(-yy1010*ry(jp,ip)+yyy10*ry(i,ip))*yy10 + y10z=(-yy1010*rz(jp,ip)+yyy10*rz(i,ip))*yy10 + + sx=y66x+y8x+y9x+y10x + sy=y66y+y8y+y9y+y10y + sz=y66z+y8z+y9z+y10z + + sx1=y66x+y8x+y9x + sy1=y66y+y8y+y9y + sz1=y66z+y8z+y9z + sx2=y10x + sy2=y10y + sz2=y10z + + shefx(i,6)=shefx(i,6)-sx*vbetam(im,j) + $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) + shefy(i,6)=shefy(i,6)-sy*vbetam(im,j) + $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) + shefz(i,6)=shefz(i,6)-sz*vbetam(im,j) + $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) + +! shefx(i,6)=shefx(i,6) +! $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) +! shefy(i,6)=shefy(i,6) +! $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) +! shefz(i,6)=shefz(i,6) +! $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) + + endif +ci endif + + enddo + enddo + + return + end +c----------------------------------------------------------------------- + subroutine sheetforce11 + implicit none + integer maxca + parameter(maxca=800) + real*8 dfa_cutoff,dfa_cutoff_delta + parameter(dfa_cutoff=15.5d0) + parameter(dfa_cutoff_delta=0.5d0) +cc********************************************************************** + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12),shefy(maxca,12) + real*8 shefz(maxca,12) + real*8 dp45,dm45,w_beta + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect +cc********************************************************************** + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shef/ shefx,shefy,shefz +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m +C******************************************************************************** +C local variables + integer j,jm,jmm,ip,i,ipp + real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z + real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y + real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y + real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y + real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy4,yyy5a,yyy5b,yy6 + real*8 yyy9a,yyy9b,y5z,y66z,y9z,yyy8 + real*8 e_gcont,fprim_gcont +C******************************************************************************** + + do j=7,inb-1 + jm=j-1 + jmm=j-2 + do i=1,j-6 + + if (dis(i,jmm).lt.dfa_cutoff) then + call gcont(dis(i,jmm),dfa_cutoff-dfa_cutoff_delta,1.0D0, + & dfa_cutoff_delta,e_gcont,fprim_gcont) + + ip=i+1 + ipp=i+2 + +ci if(istrand(i,jmm).eq.1 +ci & .and.(istrand_p(i,jmm)+istrand_m(i,jmm)).ge.1) then + + + yy1=-(dis(ipp,j)-ulhb)/dlhb + y1x=rx(ipp,j)/dis(ipp,j) + y1y=ry(ipp,j)/dis(ipp,j) + y1z=rz(ipp,j)/dis(ipp,j) + y11x=yy1*y1x + y11y=yy1*y1y + y11z=yy1*y1z + + yy33=1.0D0/(dis(ip,jm)*dis(jm,j)) + yyy3=pin2(i,jmm)/(dis(jm,j)**2) + yy3=-pin2(i,jmm)/dshe + y3x=(yy33*rx(ip,jm)-yyy3*rx(jm,j))*yy3 + y3y=(yy33*ry(ip,jm)-yyy3*ry(jm,j))*yy3 + y3z=(yy33*rz(ip,jm)-yyy3*rz(jm,j))*yy3 + + yy44=1.0D0/(dis(ipp,j)*dis(ip,ipp)) + yyy4=pin3(i,jmm)/(dis(ipp,j)**2) + yy4=-pin3(i,jmm)/dshe + y4x=(yy44*rx(ip,ipp)-yyy4*rx(ipp,j))*yy4 + y4y=(yy44*ry(ip,ipp)-yyy4*ry(ipp,j))*yy4 + y4z=(yy44*rz(ip,ipp)-yyy4*rz(ipp,j))*yy4 + + yy55=1.0D0/(dis(ipp,j)*dis(jm,j)) + yyy5a=pin4(i,jmm)/(dis(ipp,j)**2) + yyy5b=pin4(i,jmm)/(dis(jm,j)**2) + yy5=-pin4(i,jmm)/dshe + y5x=(yy55*(rx(jm,j)+rx(ipp,j))-yyy5a*rx(ipp,j) + $ -yyy5b*rx(jm,j))*yy5 + y5y=(yy55*(ry(jm,j)+ry(ipp,j))-yyy5a*ry(ipp,j) + $ -yyy5b*ry(jm,j))*yy5 + y5z=(yy55*(rz(jm,j)+rz(ipp,j))-yyy5a*rz(ipp,j) + $ -yyy5b*rz(jm,j))*yy5 + + sx=y11x+y3x+y4x+y5x + sy=y11y+y3y+y4y+y5y + sz=y11z+y3z+y4z+y5z + + sx1=y3x + sy1=y3y + sz1=y3z + sx2=y11x+y4x+y5x + sy2=y11y+y4y+y5y + sz2=y11z+y4z+y5z + + shefx(j,11)=shefx(j,11)-sx*vbetap(i,jmm) + $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) + shefy(j,11)=shefy(j,11)-sy*vbetap(i,jmm) + $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) + shefz(j,11)=shefz(j,11)-sz*vbetap(i,jmm) + $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) + +! shefx(j,11)=shefx(j,11) +! $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) +! shefy(j,11)=shefy(j,11) +! $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) +! shefz(j,11)=shefz(j,11) +! $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) + + yy6=-(dis(ip,j)-uldhb)/dldhb + y6x=rx(ip,j)/dis(ip,j) + y6y=ry(ip,j)/dis(ip,j) + y6z=rz(ip,j)/dis(ip,j) + y66x=yy6*y6x + y66y=yy6*y6y + y66z=yy6*y6z + + yy88=1.0D0/(dis(ip,j)*dis(ip,ipp)) + yyy8=pina1(i,jmm)/(dis(ip,j)**2) + yy8=-pina1(i,jmm)/dshe + y8x=(yy88*rx(ip,ipp)-yyy8*rx(ip,j))*yy8 + y8y=(yy88*ry(ip,ipp)-yyy8*ry(ip,j))*yy8 + y8z=(yy88*rz(ip,ipp)-yyy8*rz(ip,j))*yy8 + + yy99=1.0D0/(dis(ip,j)*dis(jm,j)) + yyy9a=pina2(i,jmm)/(dis(ip,j)**2) + yyy9b=pina2(i,jmm)/(dis(jm,j)**2) + yy9=-pina2(i,jmm)/dshe + y9x=(yy99*(rx(jm,j)+rx(ip,j))-yyy9a*rx(ip,j) + $ -yyy9b*rx(jm,j))*yy9 + y9y=(yy99*(ry(jm,j)+ry(ip,j))-yyy9a*ry(ip,j) + $ -yyy9b*ry(jm,j))*yy9 + y9z=(yy99*(rz(jm,j)+rz(ip,j))-yyy9a*rz(ip,j) + $ -yyy9b*rz(jm,j))*yy9 + + yy1010=1.0D0/(dis(jm,ipp)*dis(jm,j)) + yyy10=pina4(i,jmm)/(dis(jm,j)**2) + yy10=-pina4(i,jmm)/dshe + y10x=(yy1010*rx(jm,ipp)-yyy10*rx(jm,j))*yy10 + y10y=(yy1010*ry(jm,ipp)-yyy10*ry(jm,j))*yy10 + y10z=(yy1010*rz(jm,ipp)-yyy10*rz(jm,j))*yy10 + + sx=y66x+y8x+y9x+y10x + sy=y66y+y8y+y9y+y10y + sz=y66z+y8z+y9z+y10z + + sx1=y66x+y8x+y9x + sy1=y66y+y8y+y9y + sz1=y66z+y8z+y9z + sx2=y10x + sy2=y10y + sz2=y10z + + shefx(j,11)=shefx(j,11)-sx*vbetam(i,jmm) + $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) + shefy(j,11)=shefy(j,11)-sy*vbetam(i,jmm) + $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) + shefz(j,11)=shefz(j,11)-sz*vbetam(i,jmm) + $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) + +! shefx(j,11)=shefx(j,11) +! $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) +! shefy(j,11)=shefy(j,11) +! $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) +! shefz(j,11)=shefz(j,11) +! $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) + + endif +ci endif + + enddo + enddo + + return + end +c----------------------------------------------------------------------- + subroutine sheetforce12 + implicit none + integer maxca + parameter(maxca=800) + real*8 dfa_cutoff,dfa_cutoff_delta + parameter(dfa_cutoff=15.5d0) + parameter(dfa_cutoff_delta=0.5d0) +cc********************************************************************** + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12),shefy(maxca,12) + real*8 shefz(maxca,12) + real*8 dp45,dm45,w_beta + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect +cc********************************************************************** + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shef/ shefx,shefy,shefz +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m +cc********************************************************************** +C local variables + integer j,jm,jmm,ip,i,ipp,jp + real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z + real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z + real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y,y66z + real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z + real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy10a,yyy10b,yy6,yyy8 + real*8 e_gcont,fprim_gcont +!c*************************************************************************c + do j=6,inb-2 + jp=j+1 + jm=j-1 + do i=1,j-5 + + if (dis(i,jm).lt.dfa_cutoff) then + call gcont(dis(i,jm),dfa_cutoff-dfa_cutoff_delta,1.0D0, + & dfa_cutoff_delta,e_gcont,fprim_gcont) + + ip=i+1 + ipp=i+2 + +ci if(istrand(i,jm).eq.1 +ci & .and.(istrand_p(i,jm)+istrand_m(i,jm)).ge.1) then + + + yy1=-(dis(ip,j)-ulhb)/dlhb + y1x=rx(ip,j)/dis(ip,j) + y1y=ry(ip,j)/dis(ip,j) + y1z=rz(ip,j)/dis(ip,j) + y11x=y1x*yy1 + y11y=y1y*yy1 + y11z=y1z*yy1 + + yy33=1.0D0/(dis(ip,j)*dis(ip,ipp)) + yyy3=pin1(i,jm)/(dis(ip,j)**2) + yy3=-pin1(i,jm)/dshe + y3x=(yy33*rx(ip,ipp)-yyy3*rx(ip,j))*yy3 + y3y=(yy33*ry(ip,ipp)-yyy3*ry(ip,j))*yy3 + y3z=(yy33*rz(ip,ipp)-yyy3*rz(ip,j))*yy3 + yy44=1.0D0/(dis(ip,j)*dis(j,jp)) + + yyy4a=pin2(i,jm)/(dis(ip,j)**2) + yyy4b=pin2(i,jm)/(dis(j,jp)**2) + yy4=-pin2(i,jm)/dshe + y4x=(yy44*(rx(j,jp)-rx(ip,j))-yyy4a*rx(ip,j) + $ +yyy4b*rx(j,jp))*yy4 + y4y=(yy44*(ry(j,jp)-ry(ip,j))-yyy4a*ry(ip,j) + $ +yyy4b*ry(j,jp))*yy4 + y4z=(yy44*(rz(j,jp)-rz(ip,j))-yyy4a*rz(ip,j) + $ +yyy4b*rz(j,jp))*yy4 + + yy55=1.0D0/(dis(ipp,jp)*dis(j,jp)) + yyy5=pin4(i,jm)/(dis(j,jp)**2) + yy5=-pin4(i,jm)/dshe + y5x=(-yy55*rx(ipp,jp)+yyy5*rx(j,jp))*yy5 + y5y=(-yy55*ry(ipp,jp)+yyy5*ry(j,jp))*yy5 + y5z=(-yy55*rz(ipp,jp)+yyy5*rz(j,jp))*yy5 + + sx=y11x+y3x+y4x+y5x + sy=y11y+y3y+y4y+y5y + sz=y11z+y3z+y4z+y5z + + sx1=y11x+y3x+y4x + sy1=y11y+y3y+y4y + sz1=y11z+y3z+y4z + sx2=y5x + sy2=y5y + sz2=y5z + + shefx(j,12)=shefx(j,12)-sx*vbetap(i,jm) + $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) + shefy(j,12)=shefy(j,12)-sy*vbetap(i,jm) + $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) + shefz(j,12)=shefz(j,12)-sz*vbetap(i,jm) + $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) + +! shefx(j,12)=shefx(j,12) +! $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) +! shefy(j,12)=shefy(j,12) +! $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) +! shefz(j,12)=shefz(j,12) +! $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) + + yy6=-(dis(ipp,j)-uldhb)/dldhb + y6x=rx(ipp,j)/dis(ipp,j) + y6y=ry(ipp,j)/dis(ipp,j) + y6z=rz(ipp,j)/dis(ipp,j) + y66x=yy6*y6x + y66y=yy6*y6y + y66z=yy6*y6z + + yy88=1.0D0/(dis(ip,jp)*dis(j,jp)) + yyy8=pina2(i,jm)/(dis(j,jp)**2) + yy8=-pina2(i,jm)/dshe + y8x=(-yy88*rx(ip,jp)+yyy8*rx(j,jp))*yy8 + y8y=(-yy88*ry(ip,jp)+yyy8*ry(j,jp))*yy8 + y8z=(-yy88*rz(ip,jp)+yyy8*rz(j,jp))*yy8 + + yy99=1.0D0/(dis(j,ipp)*dis(ip,ipp)) + yyy9=pina3(i,jm)/(dis(j,ipp)**2) + yy9=-pina3(i,jm)/dshe + y9x=(-yy99*rx(ip,ipp)+yyy9*rx(j,ipp))*yy9 + y9y=(-yy99*ry(ip,ipp)+yyy9*ry(j,ipp))*yy9 + y9z=(-yy99*rz(ip,ipp)+yyy9*rz(j,ipp))*yy9 + + yy1010=1.0D0/(dis(j,ipp)*dis(j,jp)) + yyy10a=pina4(i,jm)/(dis(j,ipp)**2) + yyy10b=pina4(i,jm)/(dis(j,jp)**2) + yy10=-pina4(i,jm)/dshe + y10x=(-yy1010*(rx(j,ipp)+rx(j,jp))+yyy10a*rx(j,ipp) + $ +yyy10b*rx(j,jp))*yy10 + y10y=(-yy1010*(ry(j,ipp)+ry(j,jp))+yyy10a*ry(j,ipp) + $ +yyy10b*ry(j,jp))*yy10 + y10z=(-yy1010*(rz(j,ipp)+rz(j,jp))+yyy10a*rz(j,ipp) + $ +yyy10b*rz(j,jp))*yy10 + + sx=y66x+y8x+y9x+y10x + sy=y66y+y8y+y9y+y10y + sz=y66z+y8z+y9z+y10z + + sx1=y8x + sy1=y8y + sz1=y8z + sx2=y66x+y9x+y10x + sy2=y66y+y9y+y10y + sz2=y66z+y9z+y10z + + shefx(j,12)=shefx(j,12)-sx*vbetam(i,jm) + $ -sx1*vbetam1(i,jm)-sx2*vbetam2(i,jm) + shefy(j,12)=shefy(j,12)-sy*vbetam(i,jm) + $ -sy1*vbetam1(i,jm)-sy2*vbetam2(i,jm) + shefz(j,12)=shefz(j,12)-sz*vbetam(i,jm) + $ -sz1*vbetam1(i,jm)-sz2*vbetam2(i,jm) + + endif + +ci endif + + ENDDO + ENDDO + + RETURN + END +C=============================================================================== diff --git a/source/wham/src-HCD/elecont.f b/source/wham/src-HCD/elecont.f new file mode 100644 index 0000000..fb105a4 --- /dev/null +++ b/source/wham/src-HCD/elecont.f @@ -0,0 +1,258 @@ + subroutine elecont(lprint,ncont,icont,ist,ien,ipermmin) + 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 iperm,ipermmin,ii,jj + integer i,j,k,ist,ien,iteli,itelj,ind,i1,i2,it1,it2,ic1,ic2 + double precision 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, rij,zj_temp,xj_temp,yj_temp, + & sscale,sscagrad,dist_temp,xj_safe,yj_safe,zj_safe,dist_init + double precision elpp6c(2,2),elpp3c(2,2),ael6c(2,2),ael3c(2,2), + & appc(2,2),bppc(2,2) + double precision elcutoff,elecutoff_14 + integer ncont,icont(2,maxcont),xshift,yshift,zshift,isubchap + double precision econt(maxcont) +* +* Load the constants of peptide bond - peptide bond interactions. +* Type 1 - ordinary peptide bond, type 2 - alkylated peptide bond (e.g. +* proline) - determined by averaging ECEPP energy. +* +* as of 7/06/91. +* +c data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ +c data rpp / 4.5088d0, 4.5395d0, 4.5395d0, 4.4846d0/ + data elpp6c /-0.2379d0,-0.2056d0,-0.2056d0,-0.0610d0/ + data elpp3c / 0.0503d0, 0.0000d0, 0.0000d0, 0.0692d0/ + data elcutoff /-0.3d0/,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 + ii=iperm(i,ipermmin) + xi=c(1,ii) + yi=c(2,ii) + zi=c(3,ii) + dxi=c(1,ii+1)-c(1,ii) + dyi=c(2,ii+1)-c(2,ii) + dzi=c(3,ii+1)-c(3,ii) + xmedi=xi+0.5*dxi + ymedi=yi+0.5*dyi + zmedi=zi+0.5*dzi + xmedi=mod(xmedi,boxxsize) + if (xmedi.lt.0) xmedi=xmedi+boxxsize + ymedi=mod(ymedi,boxysize) + if (ymedi.lt.0) ymedi=ymedi+boxysize + zmedi=mod(zmedi,boxzsize) + if (zmedi.lt.0) zmedi=zmedi+boxzsize + do 4 j=i+2,ien-1 + jj=iperm(j,ipermmin) + 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,jj+1)-c(1,jj) + dyj=c(2,jj+1)-c(2,jj) + dzj=c(3,jj+1)-c(3,jj) + xj=c(1,jj)+0.5*dxj + yj=c(2,jj)+0.5*dyj + zj=c(3,jj)+0.5*dzj + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + isubchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + isubchap=1 + endif + enddo + enddo + enddo + if (isubchap.eq.1) then + xj=xj_temp-xmedi + yj=yj_temp-ymedi + zj=zj_temp-zmedi + else + xj=xj_safe-xmedi + yj=yj_safe-ymedi + zj=zj_safe-zmedi + endif + rij=xj*xj+yj*yj+zj*zj + sss=sscale(sqrt(rij)) + sssgrad=sscagrad(sqrt(rij)) + 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*sss + 4 continue + 1 continue + if (lprint) then + write (iout,*) 'Total average electrostatic energy: ',ees + write (iout,*) 'VDW energy between peptide-group centers: ',evdw + write (iout,*) + write (iout,*) 'Electrostatic contacts before pruning: ' + do i=1,ncont + i1=icont(1,i) + i2=icont(2,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4,f10.5)') + & i,restyp(it1),i1,restyp(it2),i2,econt(i) + enddo + endif +c For given residues keep only the contacts with the greatest energy. + i=0 + do while (i.lt.ncont) + i=i+1 + ene=econt(i) + ic1=icont(1,i) + ic2=icont(2,i) + j=i + do while (j.lt.ncont) + j=j+1 + if (ic1.eq.icont(1,j).and.iabs(icont(2,j)-ic2).le.2 .or. + & ic2.eq.icont(2,j).and.iabs(icont(1,j)-ic1).le.2) then +c write (iout,*) "i",i," j",j," ic1",ic1," ic2",ic2, +c & " jc1",icont(1,j)," jc2",icont(2,j)," ncont",ncont + if (econt(j).lt.ene .and. icont(2,j).ne.icont(1,j)+2) then + if (ic1.eq.icont(1,j)) then + do k=1,ncont + if (k.ne.i .and. k.ne.j .and. icont(2,k).eq.icont(2,j) + & .and. iabs(icont(1,k)-ic1).le.2 .and. + & econt(k).lt.econt(j) ) goto 21 + enddo + else if (ic2.eq.icont(2,j) ) then + do k=1,ncont + if (k.ne.i .and. k.ne.j .and. icont(1,k).eq.icont(1,j) + & .and. iabs(icont(2,k)-ic2).le.2 .and. + & econt(k).lt.econt(j) ) goto 21 + enddo + endif +c Remove ith contact + do k=i+1,ncont + icont(1,k-1)=icont(1,k) + icont(2,k-1)=icont(2,k) + econt(k-1)=econt(k) + enddo + i=i-1 + ncont=ncont-1 +c write (iout,*) "ncont",ncont +c do k=1,ncont +c write (iout,*) icont(1,k),icont(2,k) +c enddo + goto 20 + else if (econt(j).gt.ene .and. ic2.ne.ic1+2) + & then + if (ic1.eq.icont(1,j)) then + do k=1,ncont + if (k.ne.i .and. k.ne.j .and. icont(2,k).eq.ic2 + & .and. iabs(icont(1,k)-icont(1,j)).le.2 .and. + & econt(k).lt.econt(i) ) goto 21 + enddo + else if (ic2.eq.icont(2,j) ) then + do k=1,ncont + if (k.ne.i .and. k.ne.j .and. icont(1,k).eq.ic1 + & .and. iabs(icont(2,k)-icont(2,j)).le.2 .and. + & econt(k).lt.econt(i) ) goto 21 + enddo + endif +c Remove jth contact + do k=j+1,ncont + icont(1,k-1)=icont(1,k) + icont(2,k-1)=icont(2,k) + econt(k-1)=econt(k) + enddo + ncont=ncont-1 +c write (iout,*) "ncont",ncont +c do k=1,ncont +c write (iout,*) icont(1,k),icont(2,k) +c enddo + j=j-1 + endif + endif + 21 continue + enddo + 20 continue + enddo + if (lprint) then + write (iout,*) + write (iout,*) 'Electrostatic contacts after pruning: ' + do i=1,ncont + i1=icont(1,i) + i2=icont(2,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4,f10.5)') + & i,restyp(it1),i1,restyp(it2),i2,econt(i) + enddo + endif + return + end diff --git a/source/wham/src-HCD/enecalc1.F b/source/wham/src-HCD/enecalc1.F new file mode 100644 index 0000000..f037ae8 --- /dev/null +++ b/source/wham/src-HCD/enecalc1.F @@ -0,0 +1,825 @@ + subroutine enecalc(islice,*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#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.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" + character*64 nazwa + character*80 bxname + character*3 liczba + double precision qwolynes + external qwolynes + integer errmsg_count,maxerrmsg_count /100/ + double precision rmsnat,gyrate + external rmsnat,gyrate +c double precision tole /1.0d-1/ + integer i,itj,ii,iii,j,k,l,licz,ipermin + integer ir,ib,ipar,iparm + integer iscor,islice,scount_buff(0:99) + real*4 csingle(3,maxres2) + double precision energ + double precision temp + integer ilen,iroof + external ilen,iroof + double precision energia(0:max_ene),rmsdev,efree,eini + double precision fT(6),quot,quotl,kfacl,kfac /2.4d0/,T0 /3.0d2/ + double precision tt + integer snk_p(MaxR,MaxT_h,Max_parm) + logical lerr + character*64 bprotfile_temp + call opentmp(islice,ientout,bprotfile_temp) + iii=0 + ii=0 + errmsg_count=0 +c write (iout,*) "enecalc: nparmset ",nparmset +c write (iout,*) "enecalc: tormode ",tor_mode +#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 + write (iout,*) "indstart(me1),indend(me1)" + &,indstart(me1),indend(me1) + do 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 +#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 + 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,ipermin) + endif + q(nQ+2,iii+1)=gyrate(iii+1) +c fT=T0*beta_h(ib,ipar)*1.987D-3 +c ft=2.0d0/(1.0d0+1.0d0/(T0*beta_h(ib,ipar)*1.987D-3)) + if (rescale_mode.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_mode.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_mode.eq.0) then + do l=1,5 + fT(l)=1.0d0 + enddo + else + write (iout,*) "Error in ECECALC: wrong RESCALE_MODE", + & rescale_mode + call flush(iout) + return1 + endif + +c write (iout,*) "T",1.0d0/(beta_h(ib,ipar)*1.987D-3)," T0",T0, +c & " kfac",kfac,"quot",quot," fT",fT + 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 + do iparm=1,nparmset + + 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 +C write (iout,*) "tuz przed energia" + call etotal(energia(0),fT) +C write (iout,*) "tuz za energia" +#ifdef DEBUG + write (iout,*) "Conformation",i +c write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres), +c & ((c(l,k+nres),l=1,3),k=nnt,nct) + call enerprint(energia(0),fT) +c write (iout,'(2i5,21f8.2)') i,iparm,(energia(k),k=1,21) +c write (iout,*) "ftors(1)",ftors(1) +c call briefout(i,energia(0)) +c temp=1.0d0/(beta_h(ib,ipar)*1.987D-3) +c write (iout,*) "temp", temp +c call pdbout(i,temp,energia(0),energia(0),0.0d0,0.0d0) +#endif + if (isnan(energia(0)) .or. energia(1).ge.1.0d20 + & .or. 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:" +c call intout +c call pdbout(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) + 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)-energia(27)).gt.tole) then + & 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)+energia(27),eini," point", + & " the value read in: ",energia(0),eini," point", + & iii+1,indstart(me1)+iii," T", + & 1.0d0/(1.987D-3*beta_h(ib,ipar)) + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres), + & ((c(l,k+nres),l=1,3),k=nnt,nct) +c call intout + call pdbout(indstart(me1)+iii, + & 1.0d0/(1.987D-3*beta_h(ib,ipar)),energia(0),eini,0.0d0,0.0d0) + 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) + return1 + endif + endif + endif +C write (iout,*) "Czy tu dochodze" + potE(iii+1,iparm)=energia(0) + do k=1,n_ene + enetb(k,iii+1,iparm)=energia(k) + enddo +#ifdef DEBUG + write (iout,'(2i5,f10.1,3e15.5)') i,iii, + & 1.0d0/(beta_h(ib,ipar)*1.987D-3),energia(0),eini,efree +c 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 pdbout(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,ipermin) + 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 +c 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 +c write (iout,*) "iii",iii," iR",iR," ib",ib," ipar",ipar, +c & " 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_buff(me)=iii + write (iout,*) "Me",me," scount_buff",scount_buff(me) + call flush(iout) +c Master gathers updated numbers of conformations written by all procs. +c call MPI_AllGather(MPI_IN_PLACE,1,MPI_DATATYPE_NULL,scount(0),1, +c & MPI_INTEGER, WHAM_COMM, IERROR) + call MPI_AllGather( scount_buff(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) + return + 101 write (iout,*) "Error in scratchfile." + call flush(iout) + return1 + end +c------------------------------------------------------------------------------ + subroutine write_dbase(islice,*) + 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" + include "COMMON.CONTACTS1" + character*64 nazwa + character*80 bxname,cxname + character*64 bprotfile_temp + character*3 liczba,licz + character*2 licz2 + integer i,itj,ii,iii,j,k,l + integer ixdrf,iret + integer iscor,islice + double precision rmsdev,efree,eini + real*4 csingle(3,maxres2) + double precision energ + integer ilen,iroof + external ilen,iroof + integer ir,ib,iparm, scount_buff(0:99) + integer isecstr(maxres) + 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=.fale. + endif + 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 +c 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 +c write (iout,*) "Calling conf_compar",i +c call flush(iout) + anatemp= 1.0d0/(beta_h(ib,iparm)*1.987D-3) + if (indpdb.gt.0) then + call conf_compar(i,.false.,.true.) +c else +c call elecont(.false.,ncont,icont,nnt,nct) +c call secondary2(.false.,.false.,ncont,icont,isecstr) + endif +c write (iout,*) "Exit conf_compar",i +c 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), +c & potE(i,iparm),-entfac(i),rms_nat,iscore + & potE(i,nparmset),-entfac(i),rms_nat,iscore +c 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 +c write (iout,*) "j",j," indstart",indstart(j)," indend",indend(j) +c 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) + return1 + end +c------------------------------------------------------------------------------- + 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 + double precision rmsdev,efree,eini + real*4 csingle(3,maxres2),xoord(3,maxres2+2) + real*4 prec + +c write (iout,*) "cxwrite" +c 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 + +c write (iout,*) "itmp",itmp +c call flush(iout) +#if (defined(AIX) && !defined(JUBL)) + call xdrf3dfcoord_(ixdrf, xoord, itmp, prec, iret) + +c write (iout,*) "xdrf3dfcoord" +c call flush(iout) + 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 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 + 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 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 +c------------------------------------------------------------------------------ + logical function conf_check(ii,iprint) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#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.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" + integer j,k,l,ii,itj,iprint +c if (.not.check_conf) then +c conf_check=.true. +c return +c 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.6.5d0)) 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), + & restyp(itj),itj,dsc(iabs(itj))," 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. +c write (iout,*) "conf_check passed",ii + return + end diff --git a/source/wham/src-HCD/energy_p_new.F b/source/wham/src-HCD/energy_p_new.F new file mode 100644 index 0000000..f4dabad --- /dev/null +++ b/source/wham/src-HCD/energy_p_new.F @@ -0,0 +1,10790 @@ + subroutine etotal(energia,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + +#ifndef ISNAN + external proc_proc +#endif +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif + + include 'COMMON.IOUNITS' + double precision energia(0:max_ene),energia1(0:max_ene+1) + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.SHIELD' + include 'COMMON.CONTROL' + include 'COMMON.TORCNSTR' + double precision fact(6) +c write(iout, '(a,i2)')'Calling etotal ipot=',ipot +c call flush(iout) +cd print *,'nnt=',nnt,' nct=',nct +C +C Compute the side-chain and electrostatic interaction energy +C + goto (101,102,103,104,105) ipot +C Lennard-Jones potential. + 101 call elj(evdw,evdw_t) +cd print '(a)','Exit ELJ' + goto 106 +C Lennard-Jones-Kihara potential (shifted). + 102 call eljk(evdw,evdw_t) + goto 106 +C Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp(evdw,evdw_t) + goto 106 +C Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb(evdw,evdw_t) + goto 106 +C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv(evdw,evdw_t) +C write(iout,*) 'po elektostatyce' +C +C Calculate electrostatic (H-bonding) energy of the main chain. +C + 106 continue + call vec_and_deriv + if (shield_mode.eq.1) then + call set_shield_fac + else if (shield_mode.eq.2) then + call set_shield_fac2 + endif + call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) +C write(iout,*) 'po eelec' + +C Calculate excluded-volume interaction energy between peptide groups +C and side chains. +C + call escp(evdw2,evdw2_14) +c +c Calculate the bond-stretching energy +c + + call ebond(estr) +C write (iout,*) "estr",estr +C +C Calculate the disulfide-bridge and other energy and the contributions +C from other distance constraints. +cd print *,'Calling EHPB' + call edis(ehpb) +cd print *,'EHPB exitted succesfully.' +C +C Calculate the virtual-bond-angle energy. +C +C print *,'Bend energy finished.' + if (wang.gt.0d0) then + if (tor_mode.eq.0) then + call ebend(ebe) + else +C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the +C energy function + call ebend_kcc(ebe) + endif + else + ebe=0.0d0 + endif + ethetacnstr=0.0d0 + if (with_theta_constr) call etheta_constr(ethetacnstr) +c call ebend(ebe,ethetacnstr) +cd print *,'Bend energy finished.' +C +C Calculate the SC local energy. +C + call esc(escloc) +C print *,'SCLOC energy finished.' +C +C Calculate the virtual-bond torsional energy. +C + if (wtor.gt.0.0d0) then + if (tor_mode.eq.0) then + call etor(etors,fact(1)) + else +C etor kcc is Kubo cumulant clustered rigorous attemp to derive the +C energy function + call etor_kcc(etors,fact(1)) + endif + else + etors=0.0d0 + endif + edihcnstr=0.0d0 + if (ndih_constr.gt.0) call etor_constr(edihcnstr) +c print *,"Processor",myrank," computed Utor" +C +C 6/23/01 Calculate double-torsional energy +C + if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then + call etor_d(etors_d,fact(2)) + else + etors_d=0 + endif +c print *,"Processor",myrank," computed Utord" +C + if (wsccor.gt.0.0d0) then + call eback_sc_corr(esccor) + else + esccor=0.0d0 + endif + + if (wliptran.gt.0) then + call Eliptransfer(eliptran) + else + eliptran=0.0d0 + endif +#ifdef FOURBODY +C +C 12/1/95 Multi-body terms +C + n_corr=0 + n_corr1=0 + if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 + & .or. wturn6.gt.0.0d0) then +c write(iout,*)"calling multibody_eello" + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +c write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1 +c write (iout,*) ecorr,ecorr5,ecorr6,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) then +c write (iout,*) "Calling multibody_hbond" + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) + endif +#endif +c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr + if (nsaxs.gt.0 .and. saxs_mode.eq.0) then + call e_saxs(Esaxs_constr) +c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr + else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then + call e_saxsC(Esaxs_constr) +c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr + else + Esaxs_constr = 0.0d0 + endif + +c write(iout,*) "TEST_ENE1 constr_homology=",constr_homology + if (constr_homology.ge.1) then + call e_modeller(ehomology_constr) + else + ehomology_constr=0.0d0 + endif + +c write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr +#ifdef DFA +C BARTEK for dfa test! + if (wdfa_dist.gt.0) call edfad(edfadis) +c write(iout,*)'edfad is finished!', wdfa_dist,edfadis + if (wdfa_tor.gt.0) call edfat(edfator) +c write(iout,*)'edfat is finished!', wdfa_tor,edfator + if (wdfa_nei.gt.0) call edfan(edfanei) +c write(iout,*)'edfan is finished!', wdfa_nei,edfanei + if (wdfa_beta.gt.0) call edfab(edfabet) +c write(iout,*)'edfab is finished!', wdfa_beta,edfabet +#endif + +c write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t +#ifdef SPLITELE + if (shield_mode.gt.0) then + etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2 + & +welec*fact(1)*ees + & +fact(1)*wvdwpp*evdw1 + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr+wsaxs*esaxs_constr + & +wliptran*eliptran*esaxs_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet + else + etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees + & +wvdwpp*evdw1 + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran+wsaxs*esaxs_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet + endif +#else + if (shield_mode.gt.0) then + etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2 + & +welec*fact(1)*(ees+evdw1) + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran+wsaxs*esaxs_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet + else + etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2 + & +welec*fact(1)*(ees+evdw1) + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran+wsaxs*esaxs_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet + endif +#endif + energia(0)=etot + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(17)=evdw2_14 +#else + energia(2)=evdw2 + energia(17)=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(18)=estr + energia(19)=esccor + energia(20)=edihcnstr + energia(21)=evdw_t + energia(22)=eliptran + energia(24)=ethetacnstr + energia(26)=esaxs_constr + energia(27)=ehomology_constr + energia(28)=edfadis + energia(29)=edfator + energia(30)=edfanei + energia(31)=edfabet +c detecting NaNQ +#ifdef ISNAN +#ifdef AIX + if (isnan(etot).ne.0) energia(0)=1.0d+99 +#else + if (isnan(etot)) energia(0)=1.0d+99 +#endif +#else + i=0 +#ifdef WINPGI + idumm=proc_proc(etot,i) +#else + call proc_proc(etot,i) +#endif + if(i.eq.1)energia(0)=1.0d+99 +#endif +#ifdef MPL +c endif +#endif +#ifdef DEBUG + call enerprint(energia,fact) +#endif + if (calc_grad) then +C +C Sum up the components of the Cartesian gradient. +C +#ifdef SPLITELE + do i=1,nct + do j=1,3 + if (shield_mode.eq.0) then + gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+ + & wbond*gradb(j,i)+ + & wstrain*ghpbc(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i)+ + & wliptran*gliptranc(j,i)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(j,i) + 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*fact(2)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + else + gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i) + & +fact(1)*wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+ + & wbond*gradb(j,i)+ + & wstrain*ghpbc(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) + & +welec*gshieldc(j,i) + & +welec*gshieldc_loc(j,i) + & +wcorr*gshieldc_ec(j,i) + & +wcorr*gshieldc_loc_ec(j,i) + & +wturn3*gshieldc_t3(j,i) + & +wturn3*gshieldc_loc_t3(j,i) + & +wturn4*gshieldc_t4(j,i) + & +wturn4*gshieldc_loc_t4(j,i) + & +wel_loc*gshieldc_ll(j,i) + & +wel_loc*gshieldc_loc_ll(j,i)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(j,i) + gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i) + & +fact(1)*wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*fact(2)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + & +welec*gshieldx(j,i) + & +wcorr*gshieldx_ec(j,i) + & +wturn3*gshieldx_t3(j,i) + & +wturn4*gshieldx_t4(j,i) + & +wel_loc*gshieldx_ll(j,i) + endif + enddo +#else + do i=1,nct + do j=1,3 + if (shield_mode.eq.0) then + gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+ + & wbond*gradb(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(j,i) + + 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*fact(1)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + else + gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+ + & fact(1)*wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+ + & wbond*gradb(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) + & +welec*gshieldc(j,i) + & +welec*gshieldc_loc(j,i) + & +wcorr*gshieldc_ec(j,i) + & +wcorr*gshieldc_loc_ec(j,i) + & +wturn3*gshieldc_t3(j,i) + & +wturn3*gshieldc_loc_t3(j,i) + & +wturn4*gshieldc_t4(j,i) + & +wturn4*gshieldc_loc_t4(j,i) + & +wel_loc*gshieldc_ll(j,i) + & +wel_loc*gshieldc_loc_ll(j,i)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(j,i) + gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+ + & fact(1)*wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*fact(1)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + & +welec*gshieldx(j,i) + & +wcorr*gshieldx_ec(j,i) + & +wturn3*gshieldx_t3(j,i) + & +wturn4*gshieldx_t4(j,i) + & +wel_loc*gshieldx_ll(j,i) + + endif + enddo +#endif + enddo + + + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i) + & +wcorr5*fact(4)*g_corr5_loc(i) + & +wcorr6*fact(5)*g_corr6_loc(i) + & +wturn4*fact(3)*gel_loc_turn4(i) + & +wturn3*fact(2)*gel_loc_turn3(i) + & +wturn6*fact(5)*gel_loc_turn6(i) + & +wel_loc*fact(2)*gel_loc_loc(i) +c & +wsccor*fact(1)*gsccor_loc(i) +c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA + enddo + endif + if (dyn_ss) call dyn_set_nss + return + end +C------------------------------------------------------------------------ + subroutine enerprint(energia,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + double precision energia(0:max_ene),fact(6) + etot=energia(0) + evdw=energia(1)+fact(6)*energia(21) +#ifdef SCP14 + evdw2=energia(2)+energia(17) +#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) + esccor=energia(19) + edihcnstr=energia(20) + estr=energia(18) + ethetacnstr=energia(24) + eliptran=energia(22) + esaxs=energia(26) + ehomology_constr=energia(27) +C Bartek + edfadis = energia(28) + edfator = energia(29) + edfanei = energia(30) + edfabet = energia(31) +#ifdef SPLITELE + write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp, + & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1), + & etors_d,wtor_d*fact(2),ehpb,wstrain, +#ifdef FOURBODY + & ecorr,wcorr*fact(3), + & ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), +#endif + & eel_loc, + & wel_loc*fact(2),eello_turn3,wturn3*fact(2), + & eello_turn4,wturn4*fact(3), +#ifdef FOURBODY + & eello_turn6,wturn6*fact(5), +#endif + & esccor,wsccor*fact(1),edihcnstr, + & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, + & etube,wtube,esaxs,wsaxs,ehomology_constr, + & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, + & edfabet,wdfa_beta, + & etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ + & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, + & ' (SS bridges & dist. cnstr.)'/ +#ifdef FOURBODY + & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif + & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY + & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ + & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/ + & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/ + & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/ + & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/ + & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ + & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/ + & 'ETOT= ',1pE16.6,' (total)') + +#else + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1), + & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1), + & etors_d,wtor_d*fact(2),ehpb,wstrain, +#ifdef FOURBODY + & ecorr,wcorr*fact(3), + & ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), +#endif + & eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2), + & eello_turn4,wturn4*fact(3), +#ifdef FOURBODY + & eello_turn6,wturn6*fact(5), +#endif + & esccor,wsccor*fact(1),edihcnstr, + & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, + & etube,wtube,esaxs,wsaxs,ehomology_constr, + & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, + & edfabet,wdfa_beta, + & etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, + & ' (SS bridges & dist. restr.)'/ +#ifdef FOURBODY + & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif + & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY + & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ + & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/ + & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/ + & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/ + & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/ + & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ + & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/ + & 'ETOT= ',1pE16.6,' (total)') +#endif + return + end +C----------------------------------------------------------------------- + subroutine elj(evdw,evdw_t) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJ potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include "DIMENSIONS.COMPAR" + 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.ENEPS' + include 'COMMON.SBRIDGE' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' +#ifdef FOURBODY + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + dimension gg(3) + integer icant + external icant +cd print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon +c ROZNICA z cluster + do i=1,210 + do j=1,2 + eneps_temp(j,i)=0.0d0 + enddo + enddo +cROZNICA + + evdw=0.0D0 + evdw_t=0.0d0 + 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) +C Change 12/1/95 + num_conti=0 +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) +cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +cd & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=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 +C Change 12/1/95 to calculate four-body interactions + rij=xj*xj+yj*yj+zj*zj + rrij=1.0D0/rij + sqrij=dsqrt(rij) + sss1=sscale(sqrij) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(sqrij) +c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 + e1=fac*fac*aa + e2=fac*bb + evdwij=e1+e2 + ij=icant(itypi,itypj) +c ROZNICA z cluster + eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij) + eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij +c + +cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), +cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, +cd & (c(k,i),k=1,3),(c(k,j),k=1,3) + if (bb.gt.0.0d0) then + evdw=evdw+sss1*evdwij + else + evdw_t=evdw_t+sss1*evdwij + endif + if (calc_grad) then +C +C Calculate the components of the gradient in DC and X +C + fac=-rrij*(e1+evdwij)*sss1 + & +evdwij*sssgrad1/sqrij/expon + 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) + enddo + do k=i,j-1 + do l=1,3 + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo + enddo + endif +#ifdef FOURBODY +C +C 12/1/95, revised on 5/20/97 +C +C Calculate the contact function. The ith column of the array JCONT will +C contain the numbers of atoms that make contacts with the atom I (of numbers +C greater than I). The arrays FACONT and GACONT will contain the values of +C the contact function and its derivative. +C +C Uncomment next line, if the correlation interactions include EVDW explicitly. +c if (j.gt.i+1 .and. evdwij.le.0.0D0) then +C Uncomment next line, if the correlation interactions are contact function only + if (j.gt.i+1.and. eps0ij.gt.0.0D0) then + rij=dsqrt(rij) + sigij=sigma(itypi,itypj) + r0ij=rs0(itypi,itypj) +C +C Check whether the SC's are not too far to make a contact. +C + rcut=1.5d0*r0ij + call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) +C Add a new contact, if the SC's are close enough, but not too close (ri' + do k=1,3 + ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) + enddo + endif + do k=1,3 + gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) + enddo + kstart=min0(i+1,j) + kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) + do k=kstart,kend + do l=1,3 + gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) + enddo + enddo + endif ! calc_grad + enddo + enddo ! iint + 1225 continue + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time the factor EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C-------------------------------------------------------------------------- + subroutine edis(ehpb) +C +C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + dimension ggg(3),ggg_peak(3,1000) + ehpb=0.0D0 + do i=1,3 + ggg(i)=0.0d0 + enddo +c 8/21/18 AL: added explicit restraints on reference coords +c write (iout,*) "restr_on_coord",restr_on_coord + if (restr_on_coord) then + + do i=nnt,nct + ecoor=0.0d0 + if (itype(i).eq.ntyp1) cycle + do j=1,3 + ecoor=ecoor+(c(j,i)-cref(j,i))**2 + ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i)) + enddo + if (itype(i).ne.10) then + do j=1,3 + ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2 + ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres)) + enddo + endif + if (energy_dec) write (iout,*) + & "i",i," bfac",bfac(i)," ecoor",ecoor + ehpb=ehpb+0.5d0*bfac(i)*ecoor + enddo + + endif + +C write (iout,*) ,"link_end",link_end,constr_dist +cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr +c write(iout,*)'link_start=',link_start,' link_end=',link_end, +c & " constr_dist",constr_dist + if (link_end.eq.0.and.link_end_peak.eq.0) return + do i=link_start_peak,link_end_peak + ehpb_peak=0.0d0 +c print *,"i",i," link_end_peak",link_end_peak," ipeak", +c & ipeak(1,i),ipeak(2,i) + do ip=ipeak(1,i),ipeak(2,i) + ii=ihpb_peak(ip) + jj=jhpb_peak(ip) + dd=dist(ii,jj) + iip=ip-ipeak(1,i)+1 +C iii and jjj point to the residues for which the distance is assigned. +c if (ii.gt.nres) then +c iii=ii-nres +c jjj=jj-nres +c else +c iii=ii +c jjj=jj +c endif + if (ii.gt.nres) then + iii=ii-nres + else + iii=ii + endif + if (jj.gt.nres) then + jjj=jj-nres + else + jjj=jj + endif + aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip)) + aux=dexp(-scal_peak*aux) + ehpb_peak=ehpb_peak+aux + fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip), + & forcon_peak(ip))*aux/dd + do j=1,3 + ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii)) + enddo + if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)') + & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip), + & forcon_peak(ip),fordepth_peak(ip),ehpb_peak + enddo +c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak + ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak + do ip=ipeak(1,i),ipeak(2,i) + iip=ip-ipeak(1,i)+1 + do j=1,3 + ggg(j)=ggg_peak(j,iip)/ehpb_peak + enddo + ii=ihpb_peak(ip) + jj=jhpb_peak(ip) +C iii and jjj point to the residues for which the distance is assigned. + if (ii.gt.nres) then + iii=ii-nres + jjj=jj-nres + else + iii=ii + jjj=jj + endif + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + enddo + endif + if (jjj.lt.jj) then + do j=1,3 + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + enddo + enddo + do i=link_start,link_end +C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a +C CA-CA distance used in regularization of structure. + ii=ihpb(i) + jj=jhpb(i) +C iii and jjj point to the residues for which the distance is assigned. + if (ii.gt.nres) then + iii=ii-nres + else + iii=ii + endif + if (jj.gt.nres) then + jjj=jj-nres + else + jjj=jj + endif +c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, +c & dhpb(i),dhpb1(i),forcon(i) +C 24/11/03 AL: SS bridges handled separately because of introducing a specific +C distance and angle dependent SS bond potential. +C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. +C & iabs(itype(jjj)).eq.1) then +cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then +C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds + if (.not.dyn_ss .and. i.le.nss) then +C 15/02/13 CC dynamic SSbond - additional check + if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. + & iabs(itype(jjj)).eq.1) then + call ssbond_ene(iii,jjj,eij) + ehpb=ehpb+2*eij + endif +cd write (iout,*) "eij",eij +cd & ' waga=',waga,' fac=',fac +! else if (ii.gt.nres .and. jj.gt.nres) then + else +C Calculate the distance between the two points and its difference from the +C target distance. + dd=dist(ii,jj) + if (irestr_type(i).eq.11) then + ehpb=ehpb+fordepth(i)!**4.0d0 + & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + fac=fordepth(i)!**4.0d0 + & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd + if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)') + & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i), + & ehpb,irestr_type(i) + else if (irestr_type(i).eq.10) then +c AL 6//19/2018 cross-link restraints + xdis = 0.5d0*(dd/forcon(i))**2 + expdis = dexp(-xdis) +c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i) + aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i) +c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux, +c & " wboltzd",wboltzd + ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux) +c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i)) + fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i)) + & *expdis/(aux*forcon(i)**2) + if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)') + & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i), + & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i) + else if (irestr_type(i).eq.2) then +c Quartic restraints + ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)') + & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i), + & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd + else +c Quadratic restraints + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+0.5d0*waga*rdis*rdis + if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)') + & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i), + & 0.5d0*waga*rdis*rdis,irestr_type(i) +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif +c Calculate Cartesian gradient + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC distance, we need to calculate the contributions to the +C Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + enddo + endif + if (jjj.lt.jj) then + do j=1,3 + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + endif + enddo + return + end +C-------------------------------------------------------------------------- + subroutine ssbond_ene(i,j,eij) +C +C Calculate the distance and angle dependent SS-bond potential energy +C using a free-energy function derived based on RHF/6-31G** ab initio +C calculations of diethyl disulfide. +C +C A. Liwo and U. Kozlowska, 11/24/03 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + double precision erij(3),dcosom1(3),dcosom2(3),gg(3) + itypi=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) + itypj=iabs(itype(j)) + dscj_inv=dsc_inv(itypj) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + rij=1.0d0/rij + deltad=rij-d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) + & +akct*deltad*deltat12 + & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi +c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, +c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, +c & " deltat12",deltat12," eij",eij + ed=2*akcm*deltad+akct*deltat12 + pom1=akct*deltad + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + do k=1,3 + gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo + do k=1,3 + ghpbx(k,i)=ghpbx(k,i)-gg(k) + & +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv + ghpbx(k,j)=ghpbx(k,j)+gg(k) + & +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv + enddo +C +C Calculate the components of the gradient in DC and X +C + do k=i,j-1 + do l=1,3 + ghpbc(l,k)=ghpbc(l,k)+gg(l) + enddo + enddo + return + end +C-------------------------------------------------------------------------- +c MODELLER restraint function + subroutine e_modeller(ehomology_constr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + integer nnn, i, j, k, ki, irec, l + integer katy, odleglosci, test7 + real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template) + real*8 distance(max_template),distancek(max_template), + & min_odl,godl(max_template),dih_diff(max_template) + +c +c FP - 30/10/2014 Temporary specifications for homology restraints +c + double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta, + & sgtheta + double precision, dimension (maxres) :: guscdiff,usc_diff + double precision, dimension (max_template) :: + & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3, + & theta_diff + + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'COMMON.HOMRESTR' + include 'COMMON.HOMOLOGY' + include 'COMMON.SETUP' + include 'COMMON.NAMES' + + do i=1,max_template + distancek(i)=9999999.9 + enddo + + odleg=0.0d0 + +c Pseudo-energy and gradient from homology restraints (MODELLER-like +c function) +C AL 5/2/14 - Introduce list of restraints +c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d +#ifdef DEBUG + write(iout,*) "------- dist restrs start -------" +#endif + do ii = link_start_homo,link_end_homo + i = ires_homo(ii) + j = jres_homo(ii) + dij=dist(i,j) +c write (iout,*) "dij(",i,j,") =",dij + nexl=0 + do k=1,constr_homology + if(.not.l_homo(k,ii)) then + nexl=nexl+1 + cycle + endif + distance(k)=odl(k,ii)-dij +c write (iout,*) "distance(",k,") =",distance(k) +c +c For Gaussian-type Urestr +c + distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument +c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii) +c write (iout,*) "distancek(",k,") =",distancek(k) +c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii) +c +c For Lorentzian-type Urestr +c + if (waga_dist.lt.0.0d0) then + sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii)) + distancek(k)=distance(k)**2/(sigma_odlir(k,ii)* + & (distance(k)**2+sigma_odlir(k,ii)**2)) + endif + enddo + +c min_odl=minval(distancek) + do kk=1,constr_homology + if(l_homo(kk,ii)) then + min_odl=distancek(kk) + exit + endif + enddo + do kk=1,constr_homology + if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl) + & min_odl=distancek(kk) + enddo +c write (iout,* )"min_odl",min_odl +#ifdef DEBUG + write (iout,*) "ij dij",i,j,dij + write (iout,*) "distance",(distance(k),k=1,constr_homology) + write (iout,*) "distancek",(distancek(k),k=1,constr_homology) + write (iout,* )"min_odl",min_odl +#endif +#ifdef OLDRESTR + odleg2=0.0d0 +#else + if (waga_dist.ge.0.0d0) then + odleg2=nexl + else + odleg2=0.0d0 + endif +#endif + do k=1,constr_homology +c Nie wiem po co to liczycie jeszcze raz! +c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/ +c & (2*(sigma_odl(i,j,k))**2)) + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + godl(k)=dexp(-distancek(k)+min_odl) + odleg2=odleg2+godl(k) +c +c For Lorentzian-type Urestr +c + else + odleg2=odleg2+distancek(k) + endif + +ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3, +ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=", +ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1), +ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k) + + enddo +c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents +c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps +#ifdef DEBUG + write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents + write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps +#endif + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + odleg=odleg-dLOG(odleg2/constr_homology)+min_odl +c +c For Lorentzian-type Urestr +c + else + odleg=odleg+odleg2/constr_homology + endif +c +#ifdef GRAD +c write (iout,*) "odleg",odleg ! sum of -ln-s +c Gradient +c +c For Gaussian-type Urestr +c + if (waga_dist.ge.0.0d0) sum_godl=odleg2 + sum_sgodl=0.0d0 + do k=1,constr_homology +c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) +c & *waga_dist)+min_odl +c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist +c + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c For Gaussian-type Urestr +c + sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd +c +c For Lorentzian-type Urestr +c + else + sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ + & sigma_odlir(k,ii)**2)**2) + endif + sum_sgodl=sum_sgodl+sgodl + +c sgodl2=sgodl2+sgodl +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1" +c write(iout,*) "constr_homology=",constr_homology +c write(iout,*) i, j, k, "TEST K" + enddo + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + grad_odl3=waga_homology(iset)*waga_dist + & *sum_sgodl/(sum_godl*dij) +c +c For Lorentzian-type Urestr +c + else +c Original grad expr modified by analogy w Gaussian-type Urestr grad +c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl + grad_odl3=-waga_homology(iset)*waga_dist* + & sum_sgodl/(constr_homology*dij) + endif +c +c grad_odl3=sum_sgodl/(sum_godl*dij) + + +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2" +c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2), +c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) + +ccc write(iout,*) godl, sgodl, grad_odl3 + +c grad_odl=grad_odl+grad_odl3 + + do jik=1,3 + ggodl=grad_odl3*(c(jik,i)-c(jik,j)) +ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1)) +ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) + ghpbc(jik,i)=ghpbc(jik,i)+ggodl + ghpbc(jik,j)=ghpbc(jik,j)-ggodl +ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) +c if (i.eq.25.and.j.eq.27) then +c write(iout,*) "jik",jik,"i",i,"j",j +c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl +c write(iout,*) "grad_odl3",grad_odl3 +c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j) +c write(iout,*) "ggodl",ggodl +c write(iout,*) "ghpbc(",jik,i,")", +c & ghpbc(jik,i),"ghpbc(",jik,j,")", +c & ghpbc(jik,j) +c endif + enddo +#endif +ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=", +ccc & dLOG(odleg2),"-odleg=", -odleg + + enddo ! ii-loop for dist +#ifdef DEBUG + write(iout,*) "------- dist restrs end -------" +c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or. +c & waga_d.eq.1.0d0) call sum_gradient +#endif +c Pseudo-energy and gradient from dihedral-angle restraints from +c homology templates +c write (iout,*) "End of distance loop" +c call flush(iout) + kat=0.0d0 +c write (iout,*) idihconstr_start_homo,idihconstr_end_homo +#ifdef DEBUG + write(iout,*) "------- dih restrs start -------" + do i=idihconstr_start_homo,idihconstr_end_homo + write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg) + enddo +#endif + do i=idihconstr_start_homo,idihconstr_end_homo + kat2=0.0d0 +c betai=beta(i,i+1,i+2,i+3) + betai = phi(i) +c write (iout,*) "betai =",betai + do k=1,constr_homology + dih_diff(k)=pinorm(dih(k,i)-betai) +c write (iout,*) "dih_diff(",k,") =",dih_diff(k) +c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)= +c & -(6.28318-dih_diff(i,k)) +c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)= +c & 6.28318+dih_diff(i,k) +#ifdef OLD_DIHED + kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument +#else + kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) +#endif +c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i) + gdih(k)=dexp(kat3) + kat2=kat2+gdih(k) +c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3) +c write(*,*)"" + enddo +c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps +c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps +#ifdef DEBUG + write (iout,*) "i",i," betai",betai," kat2",kat2 + write (iout,*) "gdih",(gdih(k),k=1,constr_homology) +#endif + if (kat2.le.1.0d-14) cycle + kat=kat-dLOG(kat2/constr_homology) +c write (iout,*) "kat",kat ! sum of -ln-s + +ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=", +ccc & dLOG(kat2), "-kat=", -kat + +#ifdef GRAD +c ---------------------------------------------------------------------- +c Gradient +c ---------------------------------------------------------------------- + + sum_gdih=kat2 + sum_sgdih=0.0d0 + do k=1,constr_homology +#ifdef OLD_DIHED + sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd +#else + sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) +#endif +c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle + sum_sgdih=sum_sgdih+sgdih + enddo +c grad_dih3=sum_sgdih/sum_gdih + grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih + +c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3 +ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) + gloc(i,icg)=gloc(i,icg)+grad_dih3 +c if (i.eq.25) then +c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg) +c endif +ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) +#endif + enddo ! i-loop for dih +#ifdef DEBUG + write(iout,*) "------- dih restrs end -------" +#endif + +c Pseudo-energy and gradient for theta angle restraints from +c homology templates +c FP 01/15 - inserted from econstr_local_test.F, loop structure +c adapted + +c +c For constr_homology reference structures (FP) +c +c Uconst_back_tot=0.0d0 + Eval=0.0d0 + Erot=0.0d0 +c Econstr_back legacy +#ifdef GRAD + do i=1,nres +c do i=ithet_start,ithet_end + dutheta(i)=0.0d0 +c enddo +c do i=loc_start,loc_end + do j=1,3 + duscdiff(j,i)=0.0d0 + duscdiffx(j,i)=0.0d0 + enddo + enddo +#endif +c +c do iref=1,nref +c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end +c write (iout,*) "waga_theta",waga_theta + if (waga_theta.gt.0.0d0) then +#ifdef DEBUG + write (iout,*) "usampl",usampl + write(iout,*) "------- theta restrs start -------" +c do i=ithet_start,ithet_end +c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg) +c enddo +#endif +c write (iout,*) "maxres",maxres,"nres",nres + + do i=ithet_start,ithet_end +c +c do i=1,nfrag_back +c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) +c +c Deviation of theta angles wrt constr_homology ref structures +c + utheta_i=0.0d0 ! argument of Gaussian for single k + gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures +c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop +c over residues in a fragment +c write (iout,*) "theta(",i,")=",theta(i) + do k=1,constr_homology +c +c dtheta_i=theta(j)-thetaref(j,iref) +c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing + theta_diff(k)=thetatpl(k,i)-theta(i) +c + utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument +c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta? + gtheta(k)=dexp(utheta_i) ! + min_utheta_i? + gutheta_i=gutheta_i+dexp(utheta_i) ! Sum of Gaussians (pk) +c Gradient for single Gaussian restraint in subr Econstr_back +c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) +c + enddo +c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps +c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps + +c +#ifdef GRAD +c Gradient for multiple Gaussian restraint + sum_gtheta=gutheta_i + sum_sgtheta=0.0d0 + do k=1,constr_homology +c New generalized expr for multiple Gaussian from Econstr_back + sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd +c +c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form? + sum_sgtheta=sum_sgtheta+sgtheta ! cum variable + enddo +c +c Final value of gradient using same var as in Econstr_back + dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta + & *waga_homology(iset) +c dutheta(i)=sum_sgtheta/sum_gtheta +c +c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight +#endif + Eval=Eval-dLOG(gutheta_i/constr_homology) +c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s +c Uconst_back=Uconst_back+utheta(i) + enddo ! (i-loop for theta) +#ifdef DEBUG + write(iout,*) "------- theta restrs end -------" +#endif + endif +c +c Deviation of local SC geometry +c +c Separation of two i-loops (instructed by AL - 11/3/2014) +c +c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end +c write (iout,*) "waga_d",waga_d + +#ifdef DEBUG + write(iout,*) "------- SC restrs start -------" + write (iout,*) "Initial duscdiff,duscdiffx" + do i=loc_start,loc_end + write (iout,*) i,(duscdiff(jik,i),jik=1,3), + & (duscdiffx(jik,i),jik=1,3) + enddo +#endif + do i=loc_start,loc_end + usc_diff_i=0.0d0 ! argument of Gaussian for single k + guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures +c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy +c write(iout,*) "xxtab, yytab, zztab" +c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i) + do k=1,constr_homology +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c Original sign inverted for calc of gradients (s. Econstr_back) + dyy=-yytpl(k,i)+yytab(i) ! ibid y + dzz=-zztpl(k,i)+zztab(i) ! ibid z +c write(iout,*) "dxx, dyy, dzz" +c write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz +c + usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument +c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d? +c uscdiffk(k)=usc_diff(i) + guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff + guscdiff(i)=guscdiff(i)+dexp(usc_diff_i) !Sum of Gaussians (pk) +c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), +c & xxref(j),yyref(j),zzref(j) + enddo +c +c Gradient +c +c Generalized expression for multiple Gaussian acc to that for a single +c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014) +c +c Original implementation +c sum_guscdiff=guscdiff(i) +c +c sum_sguscdiff=0.0d0 +c do k=1,constr_homology +c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d? +c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff +c sum_sguscdiff=sum_sguscdiff+sguscdiff +c enddo +c +c Implementation of new expressions for gradient (Jan. 2015) +c +c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !? +#ifdef GRAD + do k=1,constr_homology +c +c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong +c before. Now the drivatives should be correct +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c Original sign inverted for calc of gradients (s. Econstr_back) + dyy=-yytpl(k,i)+yytab(i) ! ibid y + dzz=-zztpl(k,i)+zztab(i) ! ibid z +c +c New implementation +c + sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong! + & sigma_d(k,i) ! for the grad wrt r' +c sum_sguscdiff=sum_sguscdiff+sum_guscdiff +c +c +c New implementation + sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff + do jik=1,3 + duscdiff(jik,i-1)=duscdiff(jik,i-1)+ + & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+ + & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i) + duscdiff(jik,i)=duscdiff(jik,i)+ + & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+ + & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i) + duscdiffx(jik,i)=duscdiffx(jik,i)+ + & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+ + & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i) +c +#ifdef DEBUG + write(iout,*) "jik",jik,"i",i + write(iout,*) "dxx, dyy, dzz" + write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz + write(iout,*) "guscdiff2(",k,")",guscdiff2(k) +c write(iout,*) "sum_sguscdiff",sum_sguscdiff +cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i) +c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i) +c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i) +c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i) +c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i) +c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i) +c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i) +c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i) +c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i) +c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1) +c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i) +c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i) +c endif +#endif + enddo + enddo +#endif +c +c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required? +c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ? +c +c write (iout,*) i," uscdiff",uscdiff(i) +c +c Put together deviations from local geometry + +c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ +c & wfrag_back(3,i,iset)*uscdiff(i) + Erot=Erot-dLOG(guscdiff(i)/constr_homology) +c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s +c Uconst_back=Uconst_back+usc_diff(i) +c +c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?) +c +c New implment: multiplied by sum_sguscdiff +c + + enddo ! (i-loop for dscdiff) + +c endif + +#ifdef DEBUG + write(iout,*) "------- SC restrs end -------" + write (iout,*) "------ After SC loop in e_modeller ------" + do i=loc_start,loc_end + write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3) + write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3) + enddo + if (waga_theta.eq.1.0d0) then + write (iout,*) "in e_modeller after SC restr end: dutheta" + do i=ithet_start,ithet_end + write (iout,*) i,dutheta(i) + enddo + endif + if (waga_d.eq.1.0d0) then + write (iout,*) "e_modeller after SC loop: duscdiff/x" + do i=1,nres + write (iout,*) i,(duscdiff(j,i),j=1,3) + write (iout,*) i,(duscdiffx(j,i),j=1,3) + enddo + endif +#endif + +c Total energy from homology restraints +#ifdef DEBUG + write (iout,*) "odleg",odleg," kat",kat + write (iout,*) "odleg",odleg," kat",kat + write (iout,*) "Eval",Eval," Erot",Erot + write (iout,*) "waga_homology(",iset,")",waga_homology(iset) + write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle + write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d +#endif +c +c Addition of energy of theta angle and SC local geom over constr_homologs ref strs +c +c ehomology_constr=odleg+kat +c +c For Lorentzian-type Urestr +c + + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c +c ehomology_constr=(waga_dist*odleg+waga_angle*kat+ +c & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) + ehomology_constr=waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot +c write (iout,*) "ehomology_constr=",ehomology_constr + else +c +c For Lorentzian-type Urestr +c +c ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ +c & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) + ehomology_constr=-waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot +c write (iout,*) "ehomology_constr=",ehomology_constr + endif +#ifdef DEBUG + write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat, + & "Eval",waga_theta,eval, + & "Erot",waga_d,Erot + write (iout,*) "ehomology_constr",ehomology_constr +#endif + return + + 748 format(a8,f12.3,a6,f12.3,a7,f12.3) + 747 format(a12,i4,i4,i4,f8.3,f8.3) + 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3) + 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3) + 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X, + & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3) + end +c----------------------------------------------------------------------- + subroutine ebond(estr) +c +c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + double precision u(3),ud(3) + estr=0.0d0 + estr1=0.0d0 +c write (iout,*) "distchainmax",distchainmax + do i=nnt+1,nct + if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle +C estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) +C do j=1,3 +C gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) +C & *dc(j,i-1)/vbld(i) +C enddo +C if (energy_dec) write(iout,*) +C & "estr1",i,vbld(i),distchainmax, +C & gnmr1(vbld(i),-1.0d0,distchainmax) +C else + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then + diff = vbld(i)-vbldpDUM +C write(iout,*) i,diff + else + diff = vbld(i)-vbldp0 +c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff + endif + estr=estr+diff*diff + do j=1,3 + gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) + enddo +C endif +C write (iout,'(a7,i5,4f7.3)') +C & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff + enddo + estr=0.5d0*AKP*estr+estr1 +c +c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included +c + do i=nnt,nct + 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) +C write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, +C & AKSC(1,iti),AKSC(1,iti)*diff*diff + estr=estr+0.5d0*AKSC(1,iti)*diff*diff + do j=1,3 + gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) + enddo + else + do j=1,nbi + diff=vbld(i+nres)-vbldsc0(j,iti) + ud(j)=aksc(j,iti)*diff + u(j)=abond0(j,iti)+0.5d0*ud(j)*diff + enddo + uprod=u(1) + do j=2,nbi + uprod=uprod*u(j) + enddo + usum=0.0d0 + usumsqder=0.0d0 + do j=1,nbi + uprod1=1.0d0 + uprod2=1.0d0 + do k=1,nbi + if (k.ne.j) then + uprod1=uprod1*u(k) + uprod2=uprod2*u(k)*u(k) + endif + enddo + usum=usum+uprod1 + usumsqder=usumsqder+ud(j)*uprod2 + enddo +c write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti), +c & AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi) + estr=estr+uprod/usum + do j=1,3 + gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) + enddo + endif + endif + enddo + return + end +#ifdef CRYST_THETA +C-------------------------------------------------------------------------- + subroutine ebend(etheta,ethetacnstr) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + 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.TORCNSTR' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + double precision y(2),z(2) + delta=0.02d0*pi +c time11=dexp(-2*time) +c time12=1.0d0 + etheta=0.0D0 +c write (iout,*) "nres",nres +c write (*,'(a,i2)') 'EBEND ICG=',icg +c write (iout,*) ithet_start,ithet_end + do i=ithet_start,ithet_end +C if (itype(i-1).eq.ntyp1) cycle + if (i.le.2) cycle + if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle +C Zero the energy function and its derivative at 0 or pi. + call splinthet(theta(i),0.5d0*delta,ss,ssd) + it=itype(i-1) + 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.eq.3) then + y(1)=0.0D0 + y(2)=0.0D0 + else + + if (i.gt.3 .and. itype(i-3).ne.ntyp1) then +#ifdef OSF + phii=phi(i) +c icrc=0 +c call proc_proc(phii,icrc) + if (icrc.eq.1) 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 + endif + if (i.lt.nres .and. itype(i+1).ne.ntyp1) then +#ifdef OSF + phii1=phi(i+1) +c icrc=0 +c call proc_proc(phii1,icrc) + if (icrc.eq.1) phii1=150.0 + phii1=pinorm(phii1) + z(1)=cos(phii1) +#else + phii1=phi(i+1) + z(1)=dcos(phii1) +#endif + z(2)=dsin(phii1) + else + z(1)=0.0D0 + z(2)=0.0D0 + endif +C Calculate the "mean" value of theta from the part of the distribution +C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). +C In following comments this theta will be referred to as t_c. + thet_pred_mean=0.0d0 + do k=1,2 + athetk=athet(k,it,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 +c write (iout,*) "thet_pred_mean",thet_pred_mean + dthett=thet_pred_mean*ssd + thet_pred_mean=thet_pred_mean*ss+a0thet(it) +c write (iout,*) "thet_pred_mean",thet_pred_mean +C 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 +c write (iout,'(a6,i5,0pf7.3,f7.3,i5)') +c & 'ebend',i,ethetai,theta(i),itype(i) +c write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i), +c & rad2deg*phii,rad2deg*phii1,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) +c 1215 continue + enddo + ethetacnstr=0.0d0 +C print *,ithetaconstr_start,ithetaconstr_end,"TU" + do i=1,ntheta_constr + itheta=itheta_constr(i) + thetiii=theta(itheta) + difi=pinorm(thetiii-theta_constr0(i)) + if (difi.gt.theta_drange(i)) then + difi=difi-theta_drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else + difi=0.0 + endif +C if (energy_dec) then +C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", +C & i,itheta,rad2deg*thetiii, +C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), +C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, +C & gloc(itheta+nphi-2,icg) +C endif + enddo +C Ufff.... We've done all this!!! + return + end +C--------------------------------------------------------------------------- + subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, + & E_tc) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it +C Calculate the contributions to both Gaussian lobes. +C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) +C The "polynomial part" of the "standard deviation" of this part of +C the distribution. + sig=polthet(3,it) + do j=2,0,-1 + sig=sig*thet_pred_mean+polthet(j,it) + enddo +C Derivative of the "interior part" of the "standard deviation of the" +C gamma-dependent Gaussian lobe in t_c. + sigtc=3*polthet(3,it) + do j=2,1,-1 + sigtc=sigtc*thet_pred_mean+j*polthet(j,it) + enddo + sigtc=sig*sigtc +C Set the parameters of both Gaussian lobes of the distribution. +C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) + fac=sig*sig+sigc0(it) + sigcsq=fac+fac + sigc=1.0D0/sigcsq +C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c + sigsqtc=-4.0D0*sigcsq*sigtc +c print *,i,sig,sigtc,sigsqtc +C Following variable (sigtc) is d[sigma(t_c)]/dt_c + sigtc=-sigtc/(fac*fac) +C Following variable is sigma(t_c)**(-2) + sigcsq=sigcsq*sigcsq + sig0i=sig0(it) + sig0inv=1.0D0/sig0i**2 + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i + term1=-0.5D0*sigcsq*delthec*delthec + term2=-0.5D0*sig0inv*delthe0*delthe0 +C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and +C NaNs in taking the logarithm. We extract the largest exponent which is added +C to the energy (this being the log of the distribution) at the end of energy +C term evaluation for this virtual-bond angle. + if (term1.gt.term2) then + termm=term1 + term2=dexp(term2-termm) + term1=1.0d0 + else + termm=term2 + term1=dexp(term1-termm) + term2=1.0d0 + endif +C The ratio between the gamma-independent and gamma-dependent lobes of +C the distribution is a Gaussian function of thet_pred_mean too. + diffak=gthet(2,it)-thet_pred_mean + ratak=diffak/gthet(3,it)**2 + ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) +C Let's differentiate it in thet_pred_mean NOW. + aktc=ak*ratak +C Now put together the distribution terms to make complete distribution. + termexp=term1+ak*term2 + termpre=sigc+ak*sig0i +C Contribution of the bending energy from this theta is just the -log of +C the sum of the contributions from the two lobes and the pre-exponential +C factor. Simple enough, isn't it? + ethetai=(-dlog(termexp)-termm+dlog(termpre)) +C NOW the derivatives!!! +C 6/6/97 Take into account the deformation. + E_theta=(delthec*sigcsq*term1 + & +ak*delthe0*sig0inv*term2)/termexp + E_tc=((sigtc+aktc*sig0i)/termpre + & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ + & aktc*term2)/termexp) + return + end +c----------------------------------------------------------------------------- + subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i +C "Thank you" to MAPLE (probably spared one day of hand-differentiation). + t3 = thetai-thet_pred_mean + t6 = t3**2 + t9 = term1 + t12 = t3*sigcsq + t14 = t12+t6*sigsqtc + t16 = 1.0d0 + t21 = thetai-theta0i + t23 = t21**2 + t26 = term2 + t27 = t21*t26 + t32 = termexp + t40 = t32**2 + E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 + & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 + & *(-t12*t9-ak*sig0inv*t27) + return + end +#else +C-------------------------------------------------------------------------- + subroutine ebend(etheta) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C ab initio-derived potentials from +c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + 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.TORCNSTR' + double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), + & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), + & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), + & sinph1ph2(maxdouble,maxdouble) + logical lprn /.false./, lprn1 /.false./ + etheta=0.0D0 +c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) + do i=ithet_start,ithet_end +C if (i.eq.2) cycle +C if (itype(i-1).eq.ntyp1) cycle + if (i.le.2) cycle + if ((itype(i-1).eq.ntyp1).or.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 +cu if (i.eq.3) then +cu phii=0.0d0 +cu ityp1=nthetyp+1 +cu do k=1,nsingle +cu cosph1(k)=0.0d0 +cu sinph1(k)=0.0d0 +cu enddo +cu else + if (i.gt.3 .and. itype(i-3).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))) + do k=1,nsingle + cosph1(k)=dcos(k*phii) + sinph1(k)=dsin(k*phii) + enddo + else + phii=0.0d0 +c ityp1=nthetyp+1 + do k=1,nsingle + ityp1=ithetyp((itype(i-2))) + 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 +c ityp3=nthetyp+1 + ityp3=ithetyp((itype(i))) + do k=1,nsingle + cosph2(k)=0.0d0 + sinph2(k)=0.0d0 + enddo + endif +c write (iout,*) "i",i," ityp1",itype(i-2),ityp1, +c & " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3 +c call flush(iout) + 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 + if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') + & i,theta(i)*rad2deg,phii*rad2deg, + & phii1*rad2deg,ethetai + etheta=etheta+ethetai + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 +c gloc(nphi+i-2,icg)=wang*dethetai + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai + enddo + return + end +#endif +#ifdef CRYST_SC +c----------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + 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' + double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), + & ddersc0(3),ddummy(3),xtemp(3),temp(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 +C write (iout,*) '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)) +c print *,'i=',i,' it=',it,' nlobit=',nlobit +C write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad + theti=theta(i+1)-pipol + x(1)=dtan(theti) + x(2)=alph(i) + x(3)=omeg(i) +c write (iout,*) "i",i," x",x(1),x(2),x(3) + + 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 +c escloci=esclocbi +c write (iout,*) escloci + else if (x(2).lt.delta) then + xtemp(1)=x(1) + xtemp(2)=delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=0.0d0 + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=0.0d0 + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + call splinthet(x(2),0.5d0*delta,ss,ssd) + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +C write (iout,*) 'i=',i, escloci + else + call enesc(x,escloci,dersc,ddummy,.false.) + endif + + escloc=escloc+escloci +C write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc + write (iout,'(a6,i5,0pf7.3)') + & 'escloc',i,escloci + + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ + & wscloc*dersc(1) + gloc(ialph(i,1),icg)=wscloc*dersc(2) + gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) + 1 continue + enddo + return + end +C--------------------------------------------------------------------------- + subroutine enesc(x,escloci,dersc,ddersc,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) + double precision contr(maxlob,-1:1) + logical mixed +c write (iout,*) 'it=',it,' nlobit=',nlobit + escloc_i=0.0D0 + do j=1,3 + dersc(j)=0.0D0 + if (mixed) ddersc(j)=0.0d0 + enddo + x3=x(3) + +C Because of periodicity of the dependence of the SC energy in omega we have +C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). +C To avoid underflows, first compute & store the exponents. + + do iii=-1,1 + + x(3)=x3+iii*dwapi + + do j=1,nlobit + do k=1,3 + z(k)=x(k)-censc(k,j,it) + enddo + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j,iii)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j,iii)*z(k) + enddo + contr(j,iii)=expfac + enddo ! j + + enddo ! iii + + x(3)=x3 +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1,-1) + do iii=-1,1 + do j=1,nlobit + if (emin.gt.contr(j,iii)) emin=contr(j,iii) + enddo + enddo + emin=0.5D0*emin +cd print *,'it=',it,' emin=',emin + +C Compute the contribution to SC energy and derivatives + do iii=-1,1 + + do j=1,nlobit + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) +cd print *,'j=',j,' expfac=',expfac + escloc_i=escloc_i+expfac + do k=1,3 + dersc(k)=dersc(k)+Ax(k,j,iii)*expfac + enddo + if (mixed) then + do k=1,3,2 + ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) + & +gaussc(k,2,j,it))*expfac + enddo + endif + enddo + + enddo ! iii + + dersc(1)=dersc(1)/cos(theti)**2 + ddersc(1)=ddersc(1)/cos(theti)**2 + ddersc(3)=ddersc(3) + + escloci=-(dlog(escloc_i)-emin) + do j=1,3 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) then + do j=1,3,2 + ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) + enddo + endif + return + end +C------------------------------------------------------------------------------ + subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob),dersc(3) + double precision contr(maxlob) + logical mixed + + escloc_i=0.0D0 + + do j=1,3 + dersc(j)=0.0D0 + enddo + + do j=1,nlobit + do k=1,2 + z(k)=x(k)-censc(k,j,it) + enddo + z(3)=dwapi + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j)*z(k) + enddo + contr(j)=expfac + enddo ! j + +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1) + do j=1,nlobit + if (emin.gt.contr(j)) emin=contr(j) + enddo + emin=0.5D0*emin + +C Compute the contribution to SC energy and derivatives + + dersc12=0.0d0 + do j=1,nlobit + expfac=dexp(bsc(j,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 +#else +c---------------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA derived from AM1 all-atom calculations. +C added by Urszula Kozlowska. 07/11/2007 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.SCROT' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.VECTORS' + double precision x_prime(3),y_prime(3),z_prime(3) + & , sumene,dsc_i,dp2_i,x(65), + & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, + & de_dxx,de_dyy,de_dzz,de_dt + double precision s1_t,s1_6_t,s2_t,s2_6_t + double precision + & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), + & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), + & dt_dCi(3),dt_dCi1(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 + do i=loc_start,loc_end + 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 +c +C Compute the axes of tghe local cartesian coordinates system; store in +c x_prime, y_prime and z_prime +c + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo +C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), +C & dc_norm(3,i+nres) + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo + do j = 1,3 + z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i))) + enddo +c write (2,*) "i",i +c write (2,*) "x_prime",(x_prime(j),j=1,3) +c write (2,*) "y_prime",(y_prime(j),j=1,3) +c write (2,*) "z_prime",(z_prime(j),j=1,3) +c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), +c & " xy",scalar(x_prime(1),y_prime(1)), +c & " xz",scalar(x_prime(1),z_prime(1)), +c & " yy",scalar(y_prime(1),y_prime(1)), +c & " yz",scalar(y_prime(1),z_prime(1)), +c & " zz",scalar(z_prime(1),z_prime(1)) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxtab(i)=xx + yytab(i)=yy + zztab(i)=zz +C +C Compute the energy of the ith side cbain +C +c write (2,*) "xx",xx," yy",yy," zz",zz + it=iabs(itype(i)) + do j = 1,65 + x(j) = sc_parmin(j,it) + enddo +#ifdef CHECK_COORD +Cc diagnostics - remove later + xx1 = dcos(alph(2)) + yy1 = dsin(alph(2))*dcos(omeg(2)) + zz1 = -dsign(1.0d0,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 +C," --- ", xx_w,yy_w,zz_w +c end diagnostics +#endif + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 + & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy + & + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 + & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy + & + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 + & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy + & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 + & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx + & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy + & +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 + & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy + & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 + & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx + & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy + & +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) + & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) +c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, +c & sumene4, +c & dscp1,dscp2,sumene +c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + escloc = escloc + sumene +c write (2,*) "escloc",escloc +c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i), +c & zz,xx,yy + if (.not. calc_grad) goto 1 +#ifdef DEBUG +C +C This section to check the numerical derivatives of the energy of ith side +C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert +C #define DEBUG in the code to turn it on. +C + write (2,*) "sumene =",sumene + aincr=1.0d-7 + xxsave=xx + xx=xx+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dxx_num=(sumenep-sumene)/aincr + xx=xxsave + write (2,*) "xx+ sumene from enesc=",sumenep + yysave=yy + yy=yy+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dyy_num=(sumenep-sumene)/aincr + yy=yysave + write (2,*) "yy+ sumene from enesc=",sumenep + zzsave=zz + zz=zz+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dzz_num=(sumenep-sumene)/aincr + zz=zzsave + write (2,*) "zz+ sumene from enesc=",sumenep + costsave=cost2tab(i+1) + sintsave=sint2tab(i+1) + cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) + sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dt_num=(sumenep-sumene)/aincr + write (2,*) " t+ sumene from enesc=",sumenep + cost2tab(i+1)=costsave + sint2tab(i+1)=sintsave +C End of diagnostics section. +#endif +C +C Compute the gradient of esc +C + pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 + pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 + pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 + pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 + pom_dx=dsc_i*dp2_i*cost2tab(i+1) + pom_dy=dsc_i*dp2_i*sint2tab(i+1) + pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) + pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) + pom1=(sumene3*sint2tab(i+1)+sumene1) + & *(pom_s1/dscp1+pom_s16*dscp1**4) + pom2=(sumene4*cost2tab(i+1)+sumene2) + & *(pom_s2/dscp2+pom_s26*dscp2**4) + sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy + sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 + & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) + & +x(40)*yy*zz + sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy + sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 + & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) + & +x(60)*yy*zz + de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) + & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) + & +(pom1+pom2)*pom_dx +#ifdef DEBUG + write(2,*), "de_dxx = ", de_dxx,de_dxx_num +#endif +C + sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz + sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 + & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) + & +x(40)*xx*zz + sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz + sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz + & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz + & +x(59)*zz**2 +x(60)*xx*zz + de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) + & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) + & +(pom1-pom2)*pom_dy +#ifdef DEBUG + write(2,*), "de_dyy = ", de_dyy,de_dyy_num +#endif +C + de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy + & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx + & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) + & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) + & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 + & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy + & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) + & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) +#ifdef DEBUG + write(2,*), "de_dzz = ", de_dzz,de_dzz_num +#endif +C + de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) + & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) + & +pom1*pom_dt1+pom2*pom_dt2 +#ifdef DEBUG + write(2,*), "de_dt = ", de_dt,de_dt_num +#endif +c +C + cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) + cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) + cosfac2xx=cosfac2*xx + sinfac2yy=sinfac2*yy + do k = 1,3 + dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* + & vbld_inv(i+1) + dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* + & vbld_inv(i) + pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) + pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) +c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, +c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) +c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), +c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) + dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx + dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx + dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy + dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy + dZZ_Ci1(k)=0.0d0 + dZZ_Ci(k)=0.0d0 + do j=1,3 + dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) + & *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)) +c + dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) + dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) + enddo + + do k=1,3 + dXX_Ctab(k,i)=dXX_Ci(k) + dXX_C1tab(k,i)=dXX_Ci1(k) + dYY_Ctab(k,i)=dYY_Ci(k) + dYY_C1tab(k,i)=dYY_Ci1(k) + dZZ_Ctab(k,i)=dZZ_Ci(k) + dZZ_C1tab(k,i)=dZZ_Ci1(k) + dXX_XYZtab(k,i)=dXX_XYZ(k) + dYY_XYZtab(k,i)=dYY_XYZ(k) + dZZ_XYZtab(k,i)=dZZ_XYZ(k) + enddo + + do k = 1,3 +c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", +c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) +c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", +c & dyy_ci(k)," dzz_ci",dzz_ci(k) +c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", +c & dt_dci(k) +c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", +c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) + gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) + & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) + gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) + & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) + gsclocx(k,i)= de_dxx*dxx_XYZ(k) + & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) + enddo +c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), +c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) + +C to check gradient call subroutine check_grad + + 1 continue + enddo + return + end +#endif +c------------------------------------------------------------------------------ + subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) +C +C This procedure calculates two-body contact function g(rij) and its derivative: +C +C eps0ij ! x < -1 +C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 +C 0 ! x > 1 +C +C where x=(rij-r0ij)/delta +C +C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy +C + implicit none + double precision rij,r0ij,eps0ij,fcont,fprimcont + double precision x,x2,x4,delta +c delta=0.02D0*r0ij +c delta=0.2D0*r0ij + x=(rij-r0ij)/delta + if (x.lt.-1.0D0) then + fcont=eps0ij + fprimcont=0.0D0 + else if (x.le.1.0D0) then + x2=x*x + x4=x2*x2 + fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) + fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta + else + fcont=0.0D0 + fprimcont=0.0D0 + endif + return + end +c------------------------------------------------------------------------------ + subroutine splinthet(theti,delta,ss,ssder) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + thetup=pi-delta + thetlow=delta + if (theti.gt.pipol) then + call gcont(theti,thetup,1.0d0,delta,ss,ssder) + else + call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) + ssder=-ssder + endif + return + end +c------------------------------------------------------------------------------ + subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) + implicit none + double precision x,x0,delta,f0,f1,fprim0,f,fprim + double precision ksi,ksi2,ksi3,a1,a2,a3 + a1=fprim0*delta/(f1-f0) + a2=3.0d0-2.0d0*a1 + a3=a1-2.0d0 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) + fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) + return + end +c------------------------------------------------------------------------------ + subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) + implicit none + double precision x,x0,delta,f0x,f1x,fprim0x,fx + double precision ksi,ksi2,ksi3,a1,a2,a3 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + a1=fprim0x*delta + a2=3*(f1x-f0x)-2*fprim0x*delta + a3=fprim0x*delta-2*(f1x-f0x) + fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 + return + end +C----------------------------------------------------------------------------- +#ifdef CRYST_TOR +C----------------------------------------------------------------------------- + subroutine etor(etors,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + 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 +C Proline-Proline pair is a special case... + if (itori.eq.3 .and. itori1.eq.3) then + if (phii.gt.-dwapi3) then + cosphi=dcos(3*phii) + fac=1.0D0/(1.0D0-cosphi) + etorsi=v1(1,3,3)*fac + etorsi=etorsi+etorsi + etors=etors+etorsi-v1(1,3,3) + 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) + 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) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + endif + 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*fact*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo + return + end +c------------------------------------------------------------------------------ +#else + subroutine etor(etors,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + if (i.le.2) cycle + if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle +C if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 +C & .or. itype(i).eq.ntyp1) cycle + if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215 + 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 +C 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 + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +C Lorentz terms +C v1 +C E = SUM ----------------------------------- - v1 +C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 +C + cosphi=dcos(0.5d0*phii) + sinphi=dsin(0.5d0*phii) + do j=1,nlor(itori,itori1,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 +c if (energy_dec) etors_ii=etors_ii+ +c & vl1ij*pom1 + pom=-pom*pom1*pom1 + gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom + enddo +C Subtract the constant term + etors=etors-v0(itori,itori1,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,1),j=1,6),(v2(j,itori,itori1,1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + 1215 continue + enddo + return + end +c---------------------------------------------------------------------------- + subroutine etor_d(etors_d,fact2) +C 6/23/01 Compute double torsional energy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors_d=0.0D0 + do i=iphi_start,iphi_end-1 + if (i.le.3) cycle +C if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 +C & .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or. + & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or. + & (itype(i+1).eq.ntyp1)) cycle + if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0) + & goto 1215 + 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 +C 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 + 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 + gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) + gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + enddo + enddo + gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1 + gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2 + 1215 continue + enddo + return + end +#endif +c--------------------------------------------------------------------------- +C The rigorous attempt to derive energy function + subroutine etor_kcc(etors,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + 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' + double precision c1(0:maxval_kcc),c2(0:maxval_kcc) + logical lprn +c double precision thybt1(maxtermkcc),thybt2(maxtermkcc) +C Set lprn=.true. for debugging + lprn=energy_dec +c lprn=.true. +C print *,"wchodze kcc" + if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode + etors=0.0D0 + do i=iphi_start,iphi_end +C ANY TWO ARE DUMMY ATOMS in row CYCLE +c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or. +c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or. +c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle + if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + glocig=0.0D0 + glocit1=0.0d0 + glocit2=0.0d0 +C to avoid multiple devision by 2 +c theti22=0.5d0*theta(i) +C theta 12 is the theta_1 /2 +C theta 22 is theta_2 /2 +c theti12=0.5d0*theta(i-1) +C and appropriate sinus function + sinthet1=dsin(theta(i-1)) + sinthet2=dsin(theta(i)) + costhet1=dcos(theta(i-1)) + costhet2=dcos(theta(i)) +C to speed up lets store its mutliplication + sint1t2=sinthet2*sinthet1 + sint1t2n=1.0d0 +C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma) +C +d_n*sin(n*gamma)) * +C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2))) +C we have two sum 1) Non-Chebyshev which is with n and gamma + nval=nterm_kcc_Tb(itori,itori1) + c1(0)=0.0d0 + c2(0)=0.0d0 + c1(1)=1.0d0 + c2(1)=1.0d0 + do j=2,nval + c1(j)=c1(j-1)*costhet1 + c2(j)=c2(j-1)*costhet2 + enddo + etori=0.0d0 + do j=1,nterm_kcc(itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + sint1t2n1=sint1t2n + sint1t2n=sint1t2n*sint1t2 + sumvalc=0.0d0 + gradvalct1=0.0d0 + gradvalct2=0.0d0 + do k=1,nval + do l=1,nval + sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l) + gradvalct1=gradvalct1+ + & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l) + gradvalct2=gradvalct2+ + & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1) + enddo + enddo + gradvalct1=-gradvalct1*sinthet1 + gradvalct2=-gradvalct2*sinthet2 + sumvals=0.0d0 + gradvalst1=0.0d0 + gradvalst2=0.0d0 + do k=1,nval + do l=1,nval + sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l) + gradvalst1=gradvalst1+ + & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l) + gradvalst2=gradvalst2+ + & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1) + enddo + enddo + gradvalst1=-gradvalst1*sinthet1 + gradvalst2=-gradvalst2*sinthet2 + etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi) +C glocig is the gradient local i site in gamma + glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi) +C now gradient over theta_1 + glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi) + & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi) + glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi) + & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi) + enddo ! j + etors=etors+etori +C derivative over gamma + gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig +C derivative over theta1 + gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1 +C now derivative over theta2 + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2 + if (lprn) then + write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1, + & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori + write (iout,*) "c1",(c1(k),k=0,nval), + & " c2",(c2(k),k=0,nval) + write (iout,*) "sumvalc",sumvalc," sumvals",sumvals + endif + enddo + return + end +c--------------------------------------------------------------------------------------------- + subroutine etor_constr(edihcnstr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + 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' +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 +c do i=1,ndih_constr +c write (iout,*) "idihconstr_start",idihconstr_start, +c & " idihconstr_end",idihconstr_end + + if (raw_psipred) then + do i=idihconstr_start,idihconstr_end + itori=idih_constr(i) + phii=phi(itori) + gaudih_i=vpsipred(1,i) + gauder_i=0.0d0 + do j=1,2 + s = sdihed(j,i) + cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2 + dexpcos_i=dexp(-cos_i*cos_i) + gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i + gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) + & *cos_i*dexpcos_i/s**2 + enddo + edihcnstr=edihcnstr-wdihc*dlog(gaudih_i) + gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i + if (energy_dec) + & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') + & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i), + & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i), + & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg, + & -wdihc*dlog(gaudih_i) + enddo + else + + 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(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + else + difi=0.0 + endif + enddo + + endif + +c write (iout,*) "ETOR_CONSTR",edihcnstr + return + end +c---------------------------------------------------------------------------- +C The rigorous attempt to derive energy function + subroutine ebend_kcc(etheta) + + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + logical lprn + double precision thybt1(maxang_kcc) +C Set lprn=.true. for debugging + lprn=energy_dec +c lprn=.true. +C print *,"wchodze kcc" + if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode + etheta=0.0D0 + do i=ithet_start,ithet_end +c print *,i,itype(i-1),itype(i),itype(i-2) + if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle + iti=iabs(itortyp(itype(i-1))) + sinthet=dsin(theta(i)) + costhet=dcos(theta(i)) + do j=1,nbend_kcc_Tb(iti) + thybt1(j)=v1bend_chyb(j,iti) + enddo + sumth1thyb=v1bend_chyb(0,iti)+ + & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet) + if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg, + & sumth1thyb + ihelp=nbend_kcc_Tb(iti)-1 + gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet) + etheta=etheta+sumth1thyb +C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0) + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet + enddo + return + end +c------------------------------------------------------------------------------------- + subroutine etheta_constr(ethetacnstr) + + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + 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' + ethetacnstr=0.0d0 +C print *,ithetaconstr_start,ithetaconstr_end,"TU" + do i=ithetaconstr_start,ithetaconstr_end + itheta=itheta_constr(i) + thetiii=theta(itheta) + difi=pinorm(thetiii-theta_constr0(i)) + if (difi.gt.theta_drange(i)) then + difi=difi-theta_drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else + difi=0.0 + endif + if (energy_dec) then + write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", + & i,itheta,rad2deg*thetiii, + & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), + & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, + & gloc(itheta+nphi-2,icg) + endif + enddo + return + end +c------------------------------------------------------------------------------ +c------------------------------------------------------------------------------ + subroutine eback_sc_corr(esccor) +c 7/21/2007 Correlations between the backbone-local and side-chain-local +c conformational states; temporarily implemented as differences +c between UNRES torsional potentials (dependent on three types of +c residues) and the torsional potentials dependent on all 20 types +c of residues computed from AM1 energy surfaces of terminally-blocked +c amino-acid residues. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.SCCOR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. +c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor + esccor=0.0D0 + do i=itau_start,itau_end + 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)) + phii=phi(i) + do intertyp=1,3 !intertyp +cc Added 09 May 2012 (Adasko) +cc Intertyp means interaction type of backbone mainchain correlation: +c 1 = SC...Ca...Ca...Ca +c 2 = Ca...Ca...Ca...SC +c 3 = SC...Ca...Ca...SCi + gloci=0.0D0 + if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. + & (itype(i-1).eq.10).or.(itype(i-2).eq.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)) + esccor=esccor+v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +C write (iout,*)"EBACK_SC_COR",esccor,i +c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp, +c & nterm_sccor(isccori,isccori1),isccori,isccori1 +c 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,itori,itori1, + & (v1sccor(j,1,itori,itori1),j=1,6) + & ,(v2sccor(j,1,itori,itori1),j=1,6) +c gsccor_loc(i-3)=gloci + enddo !intertyp + enddo + return + end +#ifdef FOURBODY +c------------------------------------------------------------------------------ + subroutine multibody(ecorr) +C This subroutine calculates multi-body contributions to energy following +C the idea of Skolnick et al. If side chains I and J make a contact and +C at the same time side chains I+1 and J+1 make a contact, an extra +C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + double precision gx(3),gx1(3) + logical lprn + +C Set lprn=.true. for debugging + lprn=.false. + + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(i2,20(1x,i2,f10.5))') + & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) + enddo + endif + ecorr=0.0D0 + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo + do i=nnt,nct-2 + + DO ISHIFT = 3,4 + + i1=i+ishift + num_conti=num_cont(i) + num_conti1=num_cont(i1) + do jj=1,num_conti + j=jcont(jj,i) + do kk=1,num_conti1 + j1=jcont(kk,i1) + if (j1.eq.j+ishift .or. j1.eq.j-ishift) then +cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, +cd & ' ishift=',ishift +C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) + endif ! j1==j+-ishift + enddo ! kk + enddo ! jj + + ENDDO ! ISHIFT + + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function esccorr(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont(jj,i) + ekl=facont(kk,k) +cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl +C Calculate the multi-body contribution to energy. +C Calculate multi-body contributions to the gradient. +cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), +cd & k,l,(gacont(m,kk,k),m=1,3) + do m=1,3 + gx(m) =ekl*gacont(m,jj,i) + gx1(m)=eij*gacont(m,kk,k) + gradxorr(m,i)=gradxorr(m,i)-gx(m) + gradxorr(m,j)=gradxorr(m,j)+gx(m) + gradxorr(m,k)=gradxorr(m,k)-gx1(m) + gradxorr(m,l)=gradxorr(m,l)+gx1(m) + enddo + do m=i,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) + enddo + enddo + do m=k,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) + enddo + enddo + esccorr=-eij*ekl + return + end +c------------------------------------------------------------------------------ + subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + double precision gx(3),gx1(3) + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. + if (lprn) then + write (iout,'(a)') 'Contact function values:' + 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 + ecorr=0.0D0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the local-electrostatic correlation terms + do i=iatel_s,iatel_e+1 + 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) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1 .or. j1.eq.j-1) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) + n_corr=n_corr+1 + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, + & n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.CHAIN' + include 'COMMON.CONTROL' + include 'COMMON.SHIELD' + double precision gx(3),gx1(3) + integer num_cont_hb_old(maxres) + logical lprn,ldone + double precision eello4,eello5,eelo6,eello_turn6 + external eello4,eello5,eello6,eello_turn6 +C Set lprn=.true. for debugging + lprn=.false. + eturn6=0.0d0 + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,5f6.3))') + & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), + & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 + ecorr5=0.0d0 + ecorr6=0.0d0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the dipole-dipole interaction energies + if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then + do i=iatel_s,iatel_e+1 + num_conti=num_cont_hb(i) + do jj=1,num_conti + j=jcont_hb(jj,i) +#ifdef MOMENT + call dipole(i,j,jj) +#endif + enddo + enddo + endif +C Calculate the local-electrostatic correlation terms +c write (iout,*) "gradcorr5 in eello5 before loop" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) +c write (iout,*) "corr loop i",i + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + jp=iabs(j) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) + jp1=iabs(j1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk +c if (j1.eq.j+1 .or. j1.eq.j-1) then + if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 + & .or. j.lt.0 .and. j1.gt.0) .and. + & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + n_corr=n_corr+1 + sqd1=dsqrt(d_cont(jj,i)) + sqd2=dsqrt(d_cont(kk,i1)) + sred_geom = sqd1*sqd2 + IF (sred_geom.lt.cutoff_corr) THEN + call gcont(sred_geom,r0_corr,1.0D0,delt_corr, + & ekont,fprimcont) +cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, +cd & ' jj=',jj,' kk=',kk + fac_prim1=0.5d0*sqd2/sqd1*fprimcont + fac_prim2=0.5d0*sqd1/sqd2*fprimcont + do l=1,3 + g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) + g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) + enddo + n_corr1=n_corr1+1 +cd write (iout,*) 'sred_geom=',sred_geom, +cd & ' ekont=',ekont,' fprim=',fprimcont, +cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 +cd write (iout,*) "g_contij",g_contij +cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) +cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) + call calc_eello(i,jp,i+1,jp1,jj,kk) + if (wcorr4.gt.0.0d0) + & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) +CC & *fac_shield(i)**2*fac_shield(j)**2 + if (energy_dec.and.wcorr4.gt.0.0d0) + 1 write (iout,'(a6,4i5,0pf7.3)') + 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) +c write (iout,*) "gradcorr5 before eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + if (wcorr5.gt.0.0d0) + & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) +c write (iout,*) "gradcorr5 after eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + if (energy_dec.and.wcorr5.gt.0.0d0) + 1 write (iout,'(a6,4i5,0pf7.3)') + 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) +cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 +cd write(2,*)'ijkl',i,jp,i+1,jp1 + if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 + & .or. wturn6.eq.0.0d0))then +cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 + ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') + 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) +cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, +cd & 'ecorr6=',ecorr6 +cd write (iout,'(4e15.5)') sred_geom, +cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)), +cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)), +cd & dabs(eello6(i,jp,i+1,jp1,jj,kk)) + else if (wturn6.gt.0.0d0 + & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then +cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 + eturn6=eturn6+eello_turn6(i,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') + 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) +cd write (2,*) 'multibody_eello:eturn6',eturn6 + endif + ENDIF +1111 continue + endif + enddo ! kk + enddo ! jj + enddo ! i + do i=1,nres + num_cont_hb(i)=num_cont_hb_old(i) + enddo +c write (iout,*) "gradcorr5 in eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + return + end +c------------------------------------------------------------------------------ + double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.SHIELD' + include 'COMMON.CONTROL' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. +C print *,"wchodze",fac_shield(i),shield_mode + 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) +C* +C & fac_shield(i)**2*fac_shield(j)**2 +cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) +C Following 4 lines for diagnostics. +cd ees0pkl=0.0D0 +cd ees0pij=1.0D0 +cd ees0mkl=0.0D0 +cd ees0mij=1.0D0 +c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') +c & 'Contacts ',i,j, +c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l +c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, +c & 'gradcorr_long' +C Calculate the multi-body contribution to energy. +C ecorr=ecorr+ekont*ees +C Calculate multi-body contributions to the gradient. + coeffpees0pij=coeffp*ees0pij + coeffmees0mij=coeffm*ees0mij + coeffpees0pkl=coeffp*ees0pkl + coeffmees0mkl=coeffm*ees0mkl + do ll=1,3 +cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi + & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb1(ll,jj,i)) + gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi + & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb2(ll,jj,i)) +cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk + & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ + & coeffmees0mij*gacontm_hb1(ll,kk,k)) + gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk + & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ + & coeffmees0mij*gacontm_hb2(ll,kk,k)) + gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- + & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb3(ll,jj,i)) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij + gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- + & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ + & coeffmees0mij*gacontm_hb3(ll,kk,k)) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl +c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl + enddo +c write (iout,*) +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ +cgrad & ees*ekl*gacont_hbr(ll,jj,i)- +cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ +cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ +cgrad & ees*eij*gacont_hbr(ll,kk,k)- +cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ +cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) +cgrad enddo +cgrad enddo +c write (iout,*) "ehbcorr",ekont*ees +C print *,ekont,ees,i,k + ehbcorr=ekont*ees +C now gradient over shielding +C return + if (shield_mode.gt.0) then + j=ees0plist(jj,i) + l=ees0plist(kk,k) +C print *,i,j,fac_shield(i),fac_shield(j), +C &fac_shield(k),fac_shield(l) + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. + & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then + do ilist=1,ishield_list(i) + iresshield=shield_list(ilist,i) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + &+rlocshield + enddo + enddo + do ilist=1,ishield_list(j) + iresshield=shield_list(ilist,j) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + & +rlocshield + enddo + enddo + + do ilist=1,ishield_list(k) + iresshield=shield_list(ilist,k) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + & +rlocshield + enddo + enddo + do ilist=1,ishield_list(l) + iresshield=shield_list(ilist,l) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + & +rlocshield + enddo + enddo +C print *,gshieldx(m,iresshield) + do m=1,3 + gshieldc_ec(m,i)=gshieldc_ec(m,i)+ + & grad_shield(m,i)*ehbcorr/fac_shield(i) + gshieldc_ec(m,j)=gshieldc_ec(m,j)+ + & grad_shield(m,j)*ehbcorr/fac_shield(j) + gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+ + & grad_shield(m,i)*ehbcorr/fac_shield(i) + gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+ + & grad_shield(m,j)*ehbcorr/fac_shield(j) + + gshieldc_ec(m,k)=gshieldc_ec(m,k)+ + & grad_shield(m,k)*ehbcorr/fac_shield(k) + gshieldc_ec(m,l)=gshieldc_ec(m,l)+ + & grad_shield(m,l)*ehbcorr/fac_shield(l) + gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+ + & grad_shield(m,k)*ehbcorr/fac_shield(k) + gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+ + & grad_shield(m,l)*ehbcorr/fac_shield(l) + + enddo + endif + endif + return + end +#ifdef MOMENT +C--------------------------------------------------------------------------- + subroutine dipole(i,j,jj) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), + & auxmat(2,2) + iti1 = itortyp(itype(i+1)) + if (j.lt.nres-1) then + itj1 = itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + do iii=1,2 + dipi(iii,1)=Ub2(iii,i) + dipderi(iii)=Ub2der(iii,i) + dipi(iii,2)=b1(iii,i+1) + dipj(iii,1)=Ub2(iii,j) + dipderj(iii)=Ub2der(iii,j) + dipj(iii,2)=b1(iii,j+1) + enddo + kkk=0 + do iii=1,2 + call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) + do jjj=1,2 + kkk=kkk+1 + dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + do kkk=1,5 + do lll=1,3 + mmm=0 + do iii=1,2 + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), + & auxvec(1)) + do jjj=1,2 + mmm=mmm+1 + dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + enddo + enddo + call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) + call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) + do iii=1,2 + dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) + enddo + call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) + do iii=1,2 + dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) + enddo + return + end +#endif +C--------------------------------------------------------------------------- + subroutine calc_eello(i,j,k,l,jj,kk) +C +C This subroutine computes matrices and vectors needed to calculate +C the fourth-, fifth-, and sixth-order local-electrostatic terms. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), + & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) + logical lprn + common /kutas/ lprn +cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, +cd & ' jj=',jj,' kk=',kk +cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return +cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) +cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) + do iii=1,2 + do jjj=1,2 + aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) + aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) + enddo + enddo + call transpose2(aa1(1,1),aa1t(1,1)) + call transpose2(aa2(1,1),aa2t(1,1)) + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), + & aa1tder(1,1,lll,kkk)) + call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), + & aa2tder(1,1,lll,kkk)) + enddo + enddo + if (l.eq.j+1) then +C parallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itype2loc(itype(i)) + else + iti=nloctyp + endif + itk1=itype2loc(itype(k+1)) + itj=itype2loc(itype(j)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +C A1 kernel(j+1) A2T +cd do iii=1,2 +cd write (iout,'(3f10.5,5x,3f10.5)') +cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) +cd enddo + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), + & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + lprn=.false. + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), + & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants +cd lprn=.false. +cd if (lprn) then +cd write (2,*) 'In calc_eello6' +cd do iii=1,2 +cd write (2,*) 'iii=',iii +cd do kkk=1,5 +cd write (2,*) 'kkk=',kkk +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) +cd enddo +cd enddo +cd enddo +cd endif + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A1T kernel(i+1) A2 + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i),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,i),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,k+1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,k+1),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,j),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,j),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,l+1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i), + & 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,k+1), + & 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,j), + & 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,l+1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + else +C Antiparallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itype2loc(itype(i)) + else + iti=nloctyp + endif + itk1=itype2loc(itype(k+1)) + itl=itype2loc(itype(l)) + itj=itype2loc(itype(j)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif +C A2 kernel(j-1)T A1T + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), + & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), + & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A2T kernel(i+1)T A1 + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. + & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i),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,i),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,k+1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,k+1),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,j+1),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,l),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,j+1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i), + & 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,k+1), + & 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,l), + & 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,j+1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + endif + return + end +C--------------------------------------------------------------------------- + subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, + & KK,KKderg,AKA,AKAderg,AKAderx) + implicit none + integer nderg + logical transp + double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), + & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), + & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) + integer iii,kkk,lll + integer jjj,mmm + logical lprn + common /kutas/ lprn + call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) + do iii=1,nderg + call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, + & AKAderg(1,1,iii)) + enddo +cd if (lprn) write (2,*) 'In kernel' + do kkk=1,5 +cd if (lprn) write (2,*) 'kkk=',kkk + do lll=1,3 + call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=1' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) +cd enddo +cd endif + call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=2' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) +cd enddo +cd endif + enddo + enddo + return + end +C--------------------------------------------------------------------------- + double precision function eello4(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then +cd eello4=0.0d0 +cd return +cd endif +cd print *,'eello4:',i,j,k,l,jj,kk +cd write (2,*) 'i',i,' j',j,' k',k,' l',l +cd call checkint4(i,j,k,l,jj,kk,eel4_num) +cold eij=facont_hb(jj,i) +cold ekl=facont_hb(kk,k) +cold ekont=eij*ekl + eel4=-EAEA(1,1,1)-EAEA(2,2,1) + if (calc_grad) then +cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) + gcorr_loc(k-1)=gcorr_loc(k-1) + & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) + if (l.eq.j+1) then + gcorr_loc(l-1)=gcorr_loc(l-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + else + gcorr_loc(j-1)=gcorr_loc(j-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) + & -EAEAderx(2,2,lll,kkk,iii,1) +cd derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd gcorr_loc(l-1)=0.0d0 +cd gcorr_loc(j-1)=0.0d0 +cd gcorr_loc(k-1)=0.0d0 +cd eel4=1.0d0 +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l, +cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel4*g_contij(ll,1) +cgrad ggg2(ll)=eel4*g_contij(ll,2) + glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) + glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) +cgrad ghalf=0.5d0*ggg1(ll) + gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) + gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) + gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) + gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij +cgrad ghalf=0.5d0*ggg2(ll) + gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) + gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) + gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) + gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl + enddo +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,gcorr_loc(iii) +cd enddo + endif ! calc_grad + eello4=ekont*eel4 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello4',ekont*eel4 + return + end +C--------------------------------------------------------------------------- + double precision function eello5(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) + double precision ggg1(3),ggg2(3) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel chains C +C C +C o o o o C +C /l\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j| o |l1 | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C Antiparallel chains C +C C +C o o o o C +C /j\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j1| o |l | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C o denotes a local interaction, vertical lines an electrostatic interaction. C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then +cd eello5=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + itk=itype2loc(itype(k)) + itl=itype2loc(itype(l)) + itj=itype2loc(itype(j)) + eello5_1=0.0d0 + eello5_2=0.0d0 + eello5_3=0.0d0 + eello5_4=0.0d0 +cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, +cd & eel5_3_num,eel5_4_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l +cd goto 1111 +C Contribution from the graph I. +cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) +cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + if (l.eq.j+1) then + if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + else + if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + enddo + enddo + enddo + endif ! calc_grad +c goto 1112 +c1111 continue +C Contribution from graph II + call transpose2(EE(1,1,k),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,k)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + if (l.eq.j+1) then + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k)) + & -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,k)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + enddo + enddo + enddo + endif ! calc_grad +cd goto 1112 +cd1111 continue + if (l.eq.j+1) then +cd goto 1110 +C Parallel orientation +C Contribution from graph III + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) + call transpose2(EUgder(1,1,l),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + enddo + enddo + enddo +cd goto 1112 +C Contribution from graph IV +cd1110 continue + call transpose2(EE(1,1,l),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,l)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + enddo + enddo + enddo + endif ! calc_grad + else +C Antiparallel orientation +C Contribution from graph III +c goto 1110 + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) + call transpose2(EUgder(1,1,j),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + enddo + enddo + enddo + endif ! calc_grad +cd goto 1112 +C Contribution from graph IV +1110 continue + call transpose2(EE(1,1,j),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,j)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + enddo + enddo + enddo + endif ! calc_grad + endif +1112 continue + eel5=eello5_1+eello5_2+eello5_3+eello5_4 +cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then +cd write (2,*) 'ijkl',i,j,k,l +cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, +cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 +cd endif +cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num +cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num +cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num +cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num + if (calc_grad) then + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 +cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont +C 2/11/08 AL Gradients over DC's connecting interacting sites will be +C summed up outside the subrouine as for the other subroutines +C handling long-range interactions. The old code is commented out +C with "cgrad" to keep track of changes. + do ll=1,3 +cgrad ggg1(ll)=eel5*g_contij(ll,1) +cgrad ggg2(ll)=eel5*g_contij(ll,2) + gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) +c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') +c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), +c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), +c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont +c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') +c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), +c & gradcorr5ij, +c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl +cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) + gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) + gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) + gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) + gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij + gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij +cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) +cgrad ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2) + gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) + gradcorr5(ll,l)=gradcorr5(ll,l)+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 + endif ! calc_grad +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +c1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr5_loc(iii) +cd enddo + eello5=ekont*eel5 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello5',ekont*eel5 + return + end +c-------------------------------------------------------------------------- + double precision function eello6(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + eello6_1=0.0d0 + eello6_2=0.0d0 + eello6_3=0.0d0 + eello6_4=0.0d0 + eello6_5=0.0d0 + eello6_6=0.0d0 +cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, +cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + if (l.eq.j+1) then + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(j,i,l,k,2,.false.) + eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) + eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) + else + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(l,k,j,i,2,.true.) + eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + if (wturn6.eq.0.0d0 .or. j.ne.i+4) then + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) + else + eello6_5=0.0d0 + endif + eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) + endif +C If turn contributions are considered, they will be handled separately. + eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 +cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num +cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num +cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num +cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num +cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num +cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num +cd goto 1112 + if (calc_grad) then + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel6*g_contij(ll,1) +cgrad ggg2(ll)=eel6*g_contij(ll,2) +cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) + gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) + gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) + gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) + gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) + gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij + gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij +cgrad ghalf=0.5d0*ggg2(ll) +cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) +cd ghalf=0.0d0 + gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) + gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) + gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) + gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) + gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl + gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl + enddo + endif ! calc_grad +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + eello6=ekont*eel6 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello6',ekont*eel6 + return + end +c-------------------------------------------------------------------------- + double precision function eello6_graph1(i,j,k,l,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) + logical swap + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ /j\ C +C / \ / \ C +C /| o | | o |\ C +C \ j|/k\| / \ |/k\|l / C +C \ / \ / \ / \ / C +C o o o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + itk=itype2loc(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,k)-AEAb1(2,2,imat)*b1(2,k) + vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k) + s5=scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 + eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) + if (calc_grad) then + 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,k)-AEAb1derg(2,2,imat)*b1(2,k) + vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k) + 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,k) + & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k) + vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k) + & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k) + 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 + endif ! calc_grad + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph2(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + logical swap + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxvec2(2),auxmat1(2,2) + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C \ /l\ /j\ / C +C \ / \ / \ / C +C o| o | | o |o C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l +C AL 7/4/01 s1 would occur in the sixth-order moment, +C but not in a cluster cumulant +#ifdef MOMENT + s1=dip(1,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph2=-(s1+s2+s3+s4) +#else + eello6_graph2=-(s2+s3+s4) +#endif +c eello6_graph2=-s3 +C Derivatives in gamma(i-1) + if (calc_grad) then + if (i.gt.1) then +#ifdef MOMENT + s1=dipderg(1,jj,i)*dip(1,kk,k) +#endif + s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 +C Derivatives in gamma(j-1) or gamma(l-1) + if (j.gt.1) then +#ifdef MOMENT + s1=dipderg(3,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) + call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + endif +#endif + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) +c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 + endif +C Derivatives in gamma(l-1) or gamma(j-1) + if (l.gt.1) then +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(3,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + else + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + endif +#endif + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) +c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 + endif +C Cartesian derivatives. + if (lprn) then + write (2,*) 'In eello6_graph2' + do iii=1,2 + write (2,*) 'iii=',iii + do kkk=1,5 + write (2,*) 'kkk=',kkk + do jjj=1,2 + write (2,'(3(2f10.5),5x)') + & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) + enddo + enddo + enddo + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) + else + s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) + endif +#endif + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), + & auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), + & auxvec(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + enddo + enddo + enddo + endif ! calc_grad + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph3(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C j|/k\| / |/k\|l / C +C / \ / / \ / C +C / o / o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. + iti=itortyp(itype(i)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + itk=itype2loc(itype(k)) + itk1=itype2loc(itype(k+1)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +#ifdef MOMENT + s1=dip(4,jj,i)*dip(4,kk,k) +#endif + call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,k),auxvec(1)) + call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) + call transpose2(EE(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, +cd & "sum",-(s2+s3+s4) +#ifdef MOMENT + eello6_graph3=-(s1+s2+s3+s4) +#else + eello6_graph3=-(s2+s3+s4) +#endif +c eello6_graph3=-s4 +C Derivatives in gamma(k-1) + if (calc_grad) then + call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) + s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) +C Derivatives in gamma(l-1) + call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,k),auxvec(1)) + call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) + else + s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1), + & auxvec(1)) + s2=0.5d0*scalar2(b1(1,k),auxvec(1)) + call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1), + & auxvec(1)) + s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) + call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif +c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 + enddo + enddo + enddo + endif ! calc_grad + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxmat1(2,2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o \ o \ C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. +cd write (2,*) 'eello_graph4: wturn6',wturn6 + iti=itype2loc(itype(i)) + itj=itype2loc(itype(j)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + itk=itype2loc(itype(k)) + if (k.lt.nres-1) then + itk1=itype2loc(itype(k+1)) + else + itk1=nloctyp + endif + itl=itype2loc(itype(l)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l +cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, +cd & ' itl',itl,' itl1',itl1 +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dip(3,kk,k) + else + s1=dip(2,jj,j)*dip(2,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) + else + call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) + endif + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph4=-(s1+s2+s3+s4) +#else + eello6_graph4=-(s2+s3+s4) +#endif +C Derivatives in gamma(i-1) + if (calc_grad) then + 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,j+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) + endif + s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +cd write (2,*) 'turn6 derivatives' +#ifdef MOMENT + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif + endif + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderg(2,kk,k) + else + s1=dip(2,jj,j)*dipderg(4,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) + endif + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif + endif +C Derivatives in gamma(j-1) or gamma(l-1) + if (l.eq.j+1 .and. l.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) + else if (j.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then + gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) + endif + endif +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + if (imat.eq.1) then + s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) + else + s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) + endif + else + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) + else + s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) + endif + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), + & auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,j+1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec(1)) + else + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,l+1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,l),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 + endif ! calc_grad + return + end +c---------------------------------------------------------------------------- + double precision function eello_turn6(i,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), + & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), + & ggg1(3),ggg2(3) + double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), + & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) +C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to +C the respective energy moment and not to the cluster cumulant. + s1=0.0d0 + s8=0.0d0 + s13=0.0d0 +c + eello_turn6=0.0d0 + j=i+4 + k=i+1 + l=i+3 + iti=itype2loc(itype(i)) + itk=itype2loc(itype(k)) + itk1=itype2loc(itype(k+1)) + itl=itype2loc(itype(l)) + itj=itype2loc(itype(j)) +cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj +cd write (2,*) 'i',i,' k',k,' j',j,' l',l +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l +cd call checkint_turn6(i,jj,kk,eel_turn6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx_turn(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) +cd eello6_5=0.0d0 +cd write (2,*) 'eello6_5',eello6_5 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) + ss1=scalar2(Ub2(1,i+2),b1(1,l)) + s1 = (auxmat(1,1)+auxmat(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1)) + call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) + s2 = scalar2(b1(1,k),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,k+1),vtemp2(1)) + s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),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,k),vtemp4(1)) + s13 = (gtemp(1,1)+gtemp(2,2))*ss13 +#endif +c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 +c s1=0.0d0 +c s2=0.0d0 +c s8=0.0d0 +c s12=0.0d0 +c s13=0.0d0 + eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) +C Derivatives in gamma(i+2) + if (calc_grad) then + 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,l),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 + gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) +C Derivatives in gamma(i+3) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + ss1d=scalar2(Ub2der(1,i+2),b1(1,l)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d +#endif + call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1)) + call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,k),vtemp1d(1)) +#ifdef MOMENT + call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1)) + s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1)) +#endif + s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Derivatives in gamma(i+4) + call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +C s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) +#else + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) +#endif +C Derivatives in gamma(i+5) +#ifdef MOMENT + call transpose2(AEAderg(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1)) + call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,k),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,l),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,k),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Cartesian derivatives + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), + & vtemp1d(1)) + s2d = scalar2(b1(1,k),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,l),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), + & auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*(s1d+s2d) +#else + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*s2d +#endif +#ifdef MOMENT + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*(s8d+s12d) +#else + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*s12d +#endif + enddo + enddo + enddo +#ifdef MOMENT + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), + & achuj_tempd(1,1)) + call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d=(gtempd(1,1)+gtempd(2,2))*ss13 + derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), + & vtemp4d(1)) + ss13d = scalar2(b1(1,k),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d + derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d + enddo + enddo +#endif +cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', +cd & 16*eel_turn6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel_turn6*g_contij(ll,1) +cgrad ggg2(ll)=eel_turn6*g_contij(ll,2) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) + gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) + gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf + & +ekont*derx_turn(ll,2,1) + gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) + gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf + & +ekont*derx_turn(ll,4,1) + gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) + gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij + gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij +cgrad ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf + & +ekont*derx_turn(ll,2,2) + gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) + gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf + & +ekont*derx_turn(ll,4,2) + gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) + gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl + gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + endif ! calc_grad + eello_turn6=ekont*eel_turn6 +cd write (2,*) 'ekont',ekont +cd write (2,*) 'eel_turn6',ekont*eel_turn6 + return + end +#endif +crc------------------------------------------------- +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + subroutine Eliptransfer(eliptran) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' + include 'COMMON.CONTROL' + include 'COMMON.SPLITELE' + include 'COMMON.SBRIDGE' +C this is done by Adasko +C print *,"wchodze" +C structure of box: +C water +C--bordliptop-- buffore starts +C--bufliptop--- here true lipid starts +C lipid +C--buflipbot--- lipid ends buffore starts +C--bordlipbot--buffore ends + eliptran=0.0 + do i=1,nres +C do i=1,1 + if (itype(i).eq.ntyp1) cycle + + positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize)) + if (positi.le.0) positi=positi+boxzsize +C print *,i +C first for peptide groups +c for each residue check if it is in lipid or lipid water border area + if ((positi.gt.bordlipbot) + &.and.(positi.lt.bordliptop)) then +C the energy transfer exist + if (positi.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((positi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslip=sscalelip(fracinbuf) + ssgradlip=-sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*pepliptran + gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 + gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 +C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran + elseif (positi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) + sslip=sscalelip(fracinbuf) + ssgradlip=sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*pepliptran + gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 + gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 +C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran +C print *, "doing sscalefor top part" +C print *,i,sslip,fracinbuf,ssgradlip + else + eliptran=eliptran+pepliptran +C print *,"I am in true lipid" + endif +C else +C eliptran=elpitran+0.0 ! I am in water + endif + enddo +C print *, "nic nie bylo w lipidzie?" +C now multiply all by the peptide group transfer factor +C eliptran=eliptran*pepliptran +C now the same for side chains +CV do i=1,1 + do i=1,nres + if (itype(i).eq.ntyp1) cycle + positi=(mod(c(3,i+nres),boxzsize)) + if (positi.le.0) positi=positi+boxzsize +C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop +c for each residue check if it is in lipid or lipid water border area +C respos=mod(c(3,i+nres),boxzsize) +C print *,positi,bordlipbot,buflipbot + if ((positi.gt.bordlipbot) + & .and.(positi.lt.bordliptop)) then +C the energy transfer exist + if (positi.lt.buflipbot) then + fracinbuf=1.0d0- + & ((positi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslip=sscalelip(fracinbuf) + ssgradlip=-sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*liptranene(itype(i)) + gliptranx(3,i)=gliptranx(3,i) + &+ssgradlip*liptranene(itype(i)) + gliptranc(3,i-1)= gliptranc(3,i-1) + &+ssgradlip*liptranene(itype(i)) +C print *,"doing sccale for lower part" + elseif (positi.gt.bufliptop) then + fracinbuf=1.0d0- + &((bordliptop-positi)/lipbufthick) + sslip=sscalelip(fracinbuf) + ssgradlip=sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*liptranene(itype(i)) + gliptranx(3,i)=gliptranx(3,i) + &+ssgradlip*liptranene(itype(i)) + gliptranc(3,i-1)= gliptranc(3,i-1) + &+ssgradlip*liptranene(itype(i)) +C print *, "doing sscalefor top part",sslip,fracinbuf + else + eliptran=eliptran+liptranene(itype(i)) +C print *,"I am in true lipid" + endif + endif ! if in lipid or buffor +C else +C eliptran=elpitran+0.0 ! I am in water + enddo + return + end + + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + SUBROUTINE MATVEC2(A1,V1,V2) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),V1(2),V2(2) +c DO 1 I=1,2 +c VI=0.0 +c DO 3 K=1,2 +c 3 VI=VI+A1(I,K)*V1(K) +c Vaux(I)=VI +c 1 CONTINUE + + vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) + vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) + + v2(1)=vaux1 + v2(2)=vaux2 + END +C--------------------------------------- + SUBROUTINE MATMAT2(A1,A2,A3) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),A2(2,2),A3(2,2) +c DIMENSION AI3(2,2) +c DO J=1,2 +c A3IJ=0.0 +c DO K=1,2 +c A3IJ=A3IJ+A1(I,K)*A2(K,J) +c enddo +c A3(I,J)=A3IJ +c enddo +c enddo + + ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) + ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) + ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) + ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) + + A3(1,1)=AI3_11 + A3(2,1)=AI3_21 + A3(1,2)=AI3_12 + A3(2,2)=AI3_22 + END + +c------------------------------------------------------------------------- + double precision function scalar2(u,v) + implicit none + double precision u(2),v(2) + double precision sc + integer i + scalar2=u(1)*v(1)+u(2)*v(2) + return + end + +C----------------------------------------------------------------------------- + + subroutine transpose2(a,at) + implicit none + double precision a(2,2),at(2,2) + at(1,1)=a(1,1) + at(1,2)=a(2,1) + at(2,1)=a(1,2) + at(2,2)=a(2,2) + return + end +c-------------------------------------------------------------------------- + subroutine transpose(n,a,at) + implicit none + integer n,i,j + double precision a(n,n),at(n,n) + do i=1,n + do j=1,n + at(j,i)=a(i,j) + enddo + enddo + return + end +C--------------------------------------------------------------------------- + subroutine prodmat3(a1,a2,kk,transp,prod) + implicit none + integer i,j + double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) + logical transp +crc double precision auxmat(2,2),prod_(2,2) + + if (transp) then +crc call transpose2(kk(1,1),auxmat(1,1)) +crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) + + else +crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) + + endif +c call transpose2(a2(1,1),a2t(1,1)) + +crc print *,transp +crc print *,((prod_(i,j),i=1,2),j=1,2) +crc print *,((prod(i,j),i=1,2),j=1,2) + + return + end +C----------------------------------------------------------------------------- + double precision function scalar(u,v) + implicit none + double precision u(3),v(3) + double precision sc + integer i + sc=0.0d0 + do i=1,3 + sc=sc+u(i)*v(i) + enddo + scalar=sc + return + end +C----------------------------------------------------------------------- + double precision function sscale(r) + double precision r,gamm + include "COMMON.SPLITELE" + if(r.lt.r_cut-rlamb) then + sscale=1.0d0 + else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then + gamm=(r-(r_cut-rlamb))/rlamb + sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) + else + sscale=0d0 + endif + return + end +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + double precision function sscagrad(r) + double precision r,gamm + include "COMMON.SPLITELE" + if(r.lt.r_cut-rlamb) then + sscagrad=0.0d0 + else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then + gamm=(r-(r_cut-rlamb))/rlamb + sscagrad=gamm*(6*gamm-6.0d0)/rlamb + else + sscagrad=0.0d0 + endif + return + end +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + double precision function sscalelip(r) + double precision r,gamm + include "COMMON.SPLITELE" +C if(r.lt.r_cut-rlamb) then +C sscale=1.0d0 +C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then +C gamm=(r-(r_cut-rlamb))/rlamb + sscalelip=1.0d0+r*r*(2*r-3.0d0) +C else +C sscale=0d0 +C endif + return + end +C----------------------------------------------------------------------- + double precision function sscagradlip(r) + double precision r,gamm + include "COMMON.SPLITELE" +C if(r.lt.r_cut-rlamb) then +C sscagrad=0.0d0 +C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then +C gamm=(r-(r_cut-rlamb))/rlamb + sscagradlip=r*(6*r-6.0d0) +C else +C sscagrad=0.0d0 +C endif + return + end + +C----------------------------------------------------------------------- + subroutine set_shield_fac + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SHIELD' + include 'COMMON.INTERACT' +C this is the squar root 77 devided by 81 the epislion in lipid (in protein) + double precision div77_81/0.974996043d0/, + &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) + +C the vector between center of side_chain and peptide group + double precision pep_side(3),long,side_calf(3), + &pept_group(3),costhet_grad(3),cosphi_grad_long(3), + &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) +C the line belowe needs to be changed for FGPROC>1 + do i=1,nres-1 + if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle + ishield_list(i)=0 +Cif there two consequtive dummy atoms there is no peptide group between them +C the line below has to be changed for FGPROC>1 + VolumeTotal=0.0 + do k=1,nres + if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle + dist_pep_side=0.0 + dist_side_calf=0.0 + do j=1,3 +C first lets set vector conecting the ithe side-chain with kth side-chain + pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 +C pep_side(j)=2.0d0 +C and vector conecting the side-chain with its proper calfa + side_calf(j)=c(j,k+nres)-c(j,k) +C side_calf(j)=2.0d0 + pept_group(j)=c(j,i)-c(j,i+1) +C lets have their lenght + dist_pep_side=pep_side(j)**2+dist_pep_side + dist_side_calf=dist_side_calf+side_calf(j)**2 + dist_pept_group=dist_pept_group+pept_group(j)**2 + enddo + dist_pep_side=dsqrt(dist_pep_side) + dist_pept_group=dsqrt(dist_pept_group) + dist_side_calf=dsqrt(dist_side_calf) + do j=1,3 + pep_side_norm(j)=pep_side(j)/dist_pep_side + side_calf_norm(j)=dist_side_calf + enddo +C now sscale fraction + sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield +C print *,buff_shield,"buff" +C now sscale + if (sh_frac_dist.le.0.0) cycle +C If we reach here it means that this side chain reaches the shielding sphere +C Lets add him to the list for gradient + ishield_list(i)=ishield_list(i)+1 +C ishield_list is a list of non 0 side-chain that contribute to factor gradient +C this list is essential otherwise problem would be O3 + shield_list(ishield_list(i),i)=k +C Lets have the sscale value + if (sh_frac_dist.gt.1.0) then + scale_fac_dist=1.0d0 + do j=1,3 + sh_frac_dist_grad(j)=0.0d0 + enddo + else + scale_fac_dist=-sh_frac_dist*sh_frac_dist + & *(2.0*sh_frac_dist-3.0d0) + fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2) + & /dist_pep_side/buff_shield*0.5 +C remember for the final gradient multiply sh_frac_dist_grad(j) +C for side_chain by factor -2 ! + do j=1,3 + sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) +C print *,"jestem",scale_fac_dist,fac_help_scale, +C & sh_frac_dist_grad(j) + enddo + endif +C if ((i.eq.3).and.(k.eq.2)) then +C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist +C & ,"TU" +C endif + +C this is what is now we have the distance scaling now volume... + short=short_r_sidechain(itype(k)) + long=long_r_sidechain(itype(k)) + costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2) +C now costhet_grad +C costhet=0.0d0 + costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4 +C costhet_fac=0.0d0 + do j=1,3 + costhet_grad(j)=costhet_fac*pep_side(j) + enddo +C remember for the final gradient multiply costhet_grad(j) +C for side_chain by factor -2 ! +C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 +C pep_side0pept_group is vector multiplication + pep_side0pept_group=0.0 + do j=1,3 + pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) + enddo + cosalfa=(pep_side0pept_group/ + & (dist_pep_side*dist_side_calf)) + fac_alfa_sin=1.0-cosalfa**2 + fac_alfa_sin=dsqrt(fac_alfa_sin) + rkprim=fac_alfa_sin*(long-short)+short +C now costhet_grad + cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2) + cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4 + + do j=1,3 + cosphi_grad_long(j)=cosphi_fac*pep_side(j) + &+cosphi**3*0.5/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa/ + &((dist_pep_side*dist_side_calf))* + &((side_calf(j))-cosalfa* + &((pep_side(j)/dist_pep_side)*dist_side_calf)) + + cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa + &/((dist_pep_side*dist_side_calf))* + &(pep_side(j)- + &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) + enddo + + VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi) + & /VSolvSphere_div + & *wshield +C now the gradient... +C grad_shield is gradient of Calfa for peptide groups +C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist, +C & costhet,cosphi +C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group, +C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k) + do j=1,3 + grad_shield(j,i)=grad_shield(j,i) +C gradient po skalowaniu + & +(sh_frac_dist_grad(j) +C gradient po costhet + &-scale_fac_dist*costhet_grad(j)/(1.0-costhet) + &-scale_fac_dist*(cosphi_grad_long(j)) + &/(1.0-cosphi) )*div77_81 + &*VofOverlap +C grad_shield_side is Cbeta sidechain gradient + grad_shield_side(j,ishield_list(i),i)= + & (sh_frac_dist_grad(j)*(-2.0d0) + & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet) + & +scale_fac_dist*(cosphi_grad_long(j)) + & *2.0d0/(1.0-cosphi)) + & *div77_81*VofOverlap + + grad_shield_loc(j,ishield_list(i),i)= + & scale_fac_dist*cosphi_grad_loc(j) + & *2.0d0/(1.0-cosphi) + & *div77_81*VofOverlap + enddo + VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist + enddo + fac_shield(i)=VolumeTotal*div77_81+div4_81 +C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) + enddo + return + end +C-------------------------------------------------------------------------- +C first for shielding is setting of function of side-chains + subroutine set_shield_fac2 + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SHIELD' + include 'COMMON.INTERACT' +C this is the squar root 77 devided by 81 the epislion in lipid (in protein) + double precision div77_81/0.974996043d0/, + &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) + +C the vector between center of side_chain and peptide group + double precision pep_side(3),long,side_calf(3), + &pept_group(3),costhet_grad(3),cosphi_grad_long(3), + &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) +C the line belowe needs to be changed for FGPROC>1 + do i=1,nres-1 + if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle + ishield_list(i)=0 +Cif there two consequtive dummy atoms there is no peptide group between them +C the line below has to be changed for FGPROC>1 + VolumeTotal=0.0 + do k=1,nres + if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle + dist_pep_side=0.0 + dist_side_calf=0.0 + do j=1,3 +C first lets set vector conecting the ithe side-chain with kth side-chain + pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 +C pep_side(j)=2.0d0 +C and vector conecting the side-chain with its proper calfa + side_calf(j)=c(j,k+nres)-c(j,k) +C side_calf(j)=2.0d0 + pept_group(j)=c(j,i)-c(j,i+1) +C lets have their lenght + dist_pep_side=pep_side(j)**2+dist_pep_side + dist_side_calf=dist_side_calf+side_calf(j)**2 + dist_pept_group=dist_pept_group+pept_group(j)**2 + enddo + dist_pep_side=dsqrt(dist_pep_side) + dist_pept_group=dsqrt(dist_pept_group) + dist_side_calf=dsqrt(dist_side_calf) + do j=1,3 + pep_side_norm(j)=pep_side(j)/dist_pep_side + side_calf_norm(j)=dist_side_calf + enddo +C now sscale fraction + sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield +C print *,buff_shield,"buff" +C now sscale + if (sh_frac_dist.le.0.0) cycle +C If we reach here it means that this side chain reaches the shielding sphere +C Lets add him to the list for gradient + ishield_list(i)=ishield_list(i)+1 +C ishield_list is a list of non 0 side-chain that contribute to factor gradient +C this list is essential otherwise problem would be O3 + shield_list(ishield_list(i),i)=k +C Lets have the sscale value + if (sh_frac_dist.gt.1.0) then + scale_fac_dist=1.0d0 + do j=1,3 + sh_frac_dist_grad(j)=0.0d0 + enddo + else + scale_fac_dist=-sh_frac_dist*sh_frac_dist + & *(2.0d0*sh_frac_dist-3.0d0) + fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) + & /dist_pep_side/buff_shield*0.5d0 +C remember for the final gradient multiply sh_frac_dist_grad(j) +C for side_chain by factor -2 ! + do j=1,3 + sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) +C sh_frac_dist_grad(j)=0.0d0 +C scale_fac_dist=1.0d0 +C print *,"jestem",scale_fac_dist,fac_help_scale, +C & sh_frac_dist_grad(j) + enddo + endif +C this is what is now we have the distance scaling now volume... + short=short_r_sidechain(itype(k)) + long=long_r_sidechain(itype(k)) + costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2) + sinthet=short/dist_pep_side*costhet +C now costhet_grad +C costhet=0.6d0 +C sinthet=0.8 + costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4 +C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet +C & -short/dist_pep_side**2/costhet) +C costhet_fac=0.0d0 + do j=1,3 + costhet_grad(j)=costhet_fac*pep_side(j) + enddo +C remember for the final gradient multiply costhet_grad(j) +C for side_chain by factor -2 ! +C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 +C pep_side0pept_group is vector multiplication + pep_side0pept_group=0.0d0 + do j=1,3 + pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) + enddo + cosalfa=(pep_side0pept_group/ + & (dist_pep_side*dist_side_calf)) + fac_alfa_sin=1.0d0-cosalfa**2 + fac_alfa_sin=dsqrt(fac_alfa_sin) + rkprim=fac_alfa_sin*(long-short)+short +C rkprim=short + +C now costhet_grad + cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2) +C cosphi=0.6 + cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4 + sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ + & dist_pep_side**2) +C sinphi=0.8 + do j=1,3 + cosphi_grad_long(j)=cosphi_fac*pep_side(j) + &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa/ + &((dist_pep_side*dist_side_calf))* + &((side_calf(j))-cosalfa* + &((pep_side(j)/dist_pep_side)*dist_side_calf)) +C cosphi_grad_long(j)=0.0d0 + cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa + &/((dist_pep_side*dist_side_calf))* + &(pep_side(j)- + &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) +C cosphi_grad_loc(j)=0.0d0 + enddo +C print *,sinphi,sinthet + VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) + & /VSolvSphere_div +C & *wshield +C now the gradient... + do j=1,3 + grad_shield(j,i)=grad_shield(j,i) +C gradient po skalowaniu + & +(sh_frac_dist_grad(j)*VofOverlap +C gradient po costhet + & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* + &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( + & sinphi/sinthet*costhet*costhet_grad(j) + & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) + & )*wshield +C grad_shield_side is Cbeta sidechain gradient + grad_shield_side(j,ishield_list(i),i)= + & (sh_frac_dist_grad(j)*(-2.0d0) + & *VofOverlap + & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0* + &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( + & sinphi/sinthet*costhet*costhet_grad(j) + & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) + & )*wshield + + grad_shield_loc(j,ishield_list(i),i)= + & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0* + &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*( + & sinthet/sinphi*cosphi*cosphi_grad_loc(j) + & )) + & *wshield + enddo + VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist + enddo + fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield) +c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i), +c & " wshield",wshield +c write(2,*) "TU",rpp(1,1),short,long,buff_shield + enddo + return + end +C-------------------------------------------------------------------------- + double precision function tschebyshev(m,n,x,y) + implicit none + include "DIMENSIONS" + integer i,m,n + double precision x(n),y,yy(0:maxvar),aux +c Tschebyshev polynomial. Note that the first term is omitted +c m=0: the constant term is included +c m=1: the constant term is not included + yy(0)=1.0d0 + yy(1)=y + do i=2,n + yy(i)=2*yy(1)*yy(i-1)-yy(i-2) + enddo + aux=0.0d0 + do i=m,n + aux=aux+x(i)*yy(i) + enddo + tschebyshev=aux + return + end +C-------------------------------------------------------------------------- + double precision function gradtschebyshev(m,n,x,y) + implicit none + include "DIMENSIONS" + integer i,m,n + double precision x(n+1),y,yy(0:maxvar),aux +c Tschebyshev polynomial. Note that the first term is omitted +c m=0: the constant term is included +c m=1: the constant term is not included + yy(0)=1.0d0 + yy(1)=2.0d0*y + do i=2,n + yy(i)=2*y*yy(i-1)-yy(i-2) + enddo + aux=0.0d0 + do i=m,n + aux=aux+x(i+1)*yy(i)*(i+1) +C print *, x(i+1),yy(i),i + enddo + gradtschebyshev=aux + return + end +c---------------------------------------------------------------------------- + double precision function sscale2(r,r_cut,r0,rlamb) + implicit none + double precision r,gamm,r_cut,r0,rlamb,rr + rr = dabs(r-r0) +c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb +c write (2,*) "rr",rr + if(rr.lt.r_cut-rlamb) then + sscale2=1.0d0 + else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then + gamm=(rr-(r_cut-rlamb))/rlamb + sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0) + else + sscale2=0d0 + endif + return + end +C----------------------------------------------------------------------- + double precision function sscalgrad2(r,r_cut,r0,rlamb) + implicit none + double precision r,gamm,r_cut,r0,rlamb,rr + rr = dabs(r-r0) + if(rr.lt.r_cut-rlamb) then + sscalgrad2=0.0d0 + else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then + gamm=(rr-(r_cut-rlamb))/rlamb + if (r.ge.r0) then + sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb + else + sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb + endif + else + sscalgrad2=0.0d0 + endif + return + end +c---------------------------------------------------------------------------- + subroutine e_saxs(Esaxs_constr) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' +#ifdef MPI + include "mpif.h" + include "COMMON.SETUP" + integer IERR +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.CONTROL' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.LANGEVIN' + include 'COMMON.SAXS' +c + double precision Esaxs_constr + integer i,iint,j,k,l + double precision PgradC(maxSAXS,3,maxres), + & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS) +#ifdef MPI + double precision PgradC_(maxSAXS,3,maxres), + & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS) +#endif + double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC, + & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC, + & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1, + & auxX,auxX1,CACAgrad,Cnorm + double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2 + double precision dist + external dist +c SAXS restraint penalty function +#ifdef DEBUG + write(iout,*) "------- SAXS penalty function start -------" + write (iout,*) "nsaxs",nsaxs + write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e + write (iout,*) "Psaxs" + do i=1,nsaxs + write (iout,'(i5,e15.5)') i, Psaxs(i) + enddo +#endif + Esaxs_constr = 0.0d0 + do k=1,nsaxs + Pcalc(k)=0.0d0 + do j=1,nres + do l=1,3 + PgradC(k,l,j)=0.0d0 + PgradX(k,l,j)=0.0d0 + enddo + enddo + enddo + do i=iatsc_s,iatsc_e + if (itype(i).eq.ntyp1) cycle + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + if (itype(j).eq.ntyp1) cycle +#ifdef ALLSAXS + dijCACA=dist(i,j) + dijCASC=dist(i,j+nres) + dijSCCA=dist(i+nres,j) + dijSCSC=dist(i+nres,j+nres) + sigma2CACA=2.0d0/(pstok**2) + sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2) + sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2) + sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2) + do k=1,nsaxs + dk = distsaxs(k) + expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2) + if (itype(j).ne.10) then + expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2) + else + endif + expCASC = 0.0d0 + if (itype(i).ne.10) then + expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2) + else + expSCCA = 0.0d0 + endif + if (itype(i).ne.10 .and. itype(j).ne.10) then + expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2) + else + expSCSC = 0.0d0 + endif + Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC +#ifdef DEBUG + write(iout,*) "i j k Pcalc",i,j,Pcalc(k) +#endif + CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA + CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC + SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA + SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC + do l=1,3 +c CA CA + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux +c CA SC + if (itype(j).ne.10) then + aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + PgradX(k,l,j) = PgradX(k,l,j)+aux + endif +c SC CA + if (itype(i).ne.10) then + aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA + PgradX(k,l,i) = PgradX(k,l,i)-aux + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + endif +c SC SC + if (itype(i).ne.10 .and. itype(j).ne.10) then + aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + PgradX(k,l,i) = PgradX(k,l,i)-aux + PgradX(k,l,j) = PgradX(k,l,j)+aux + endif + enddo ! l + enddo ! k +#else + dijCACA=dist(i,j) + sigma2CACA=scal_rad**2*0.25d0/ + & (restok(itype(j))**2+restok(itype(i))**2) + + IF (saxs_cutoff.eq.0) THEN + do k=1,nsaxs + dk = distsaxs(k) + expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2) + Pcalc(k) = Pcalc(k)+expCACA + CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA + do l=1,3 + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + enddo ! l + enddo ! k + ELSE + rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA) + do k=1,nsaxs + dk = distsaxs(k) +c write (2,*) "ijk",i,j,k + sss2 = sscale2(dijCACA,rrr,dk,0.3d0) + if (sss2.eq.0.0d0) cycle + ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0) + expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2 + Pcalc(k) = Pcalc(k)+expCACA +#ifdef DEBUG + write(iout,*) "i j k Pcalc",i,j,Pcalc(k) +#endif + CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+ + & ssgrad2*expCACA/sss2 + do l=1,3 +c CA CA + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)+aux + PgradC(k,l,j) = PgradC(k,l,j)-aux + enddo ! l + enddo ! k + ENDIF +#endif + enddo ! j + enddo ! iint + enddo ! i +#ifdef MPI + if (nfgtasks.gt.1) then + call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION, + & MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do k=1,nsaxs + Pcalc(k) = Pcalc_(k) + enddo + endif + call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do i=1,nres + do l=1,3 + do k=1,nsaxs + PgradC(k,l,i) = PgradC_(k,l,i) + enddo + enddo + enddo + endif +#ifdef ALLSAXS + call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do i=1,nres + do l=1,3 + do k=1,nsaxs + PgradX(k,l,i) = PgradX_(k,l,i) + enddo + enddo + enddo + endif +#endif + endif +#endif +#ifdef MPI + if (fg_rank.eq.king) then +#endif + Cnorm = 0.0d0 + do k=1,nsaxs + Cnorm = Cnorm + Pcalc(k) + enddo + Esaxs_constr = dlog(Cnorm)-wsaxs0 + do k=1,nsaxs + if (Pcalc(k).gt.0.0d0) + & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k)) +#ifdef DEBUG + write (iout,*) "k",k," Esaxs_constr",Esaxs_constr +#endif + enddo +#ifdef DEBUG + write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr +#endif + do i=nnt,nct + do l=1,3 + auxC=0.0d0 + auxC1=0.0d0 + auxX=0.0d0 + auxX1=0.d0 + do k=1,nsaxs + if (Pcalc(k).gt.0) + & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k) + auxC1 = auxC1+PgradC(k,l,i) +#ifdef ALLSAXS + auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k) + auxX1 = auxX1+PgradX(k,l,i) +#endif + enddo + gsaxsC(l,i) = auxC - auxC1/Cnorm +#ifdef ALLSAXS + gsaxsX(l,i) = auxX - auxX1/Cnorm +#endif +c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm), +c * " gradX",wsaxs*(auxX - auxX1/Cnorm) + enddo + enddo +#ifdef MPI + endif +#endif + return + end +c---------------------------------------------------------------------------- + subroutine e_saxsC(Esaxs_constr) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' +#ifdef MPI + include "mpif.h" + include "COMMON.SETUP" + integer IERR +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.CONTROL' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.LANGEVIN' + include 'COMMON.SAXS' +c + double precision Esaxs_constr + integer i,iint,j,k,l + double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot +#ifdef MPI + double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_ +#endif + double precision dk,dijCASPH,dijSCSPH, + & sigma2CA,sigma2SC,expCASPH,expSCSPH, + & CASPHgrad,SCSPHgrad,aux,auxC,auxC1, + & auxX,auxX1,Cnorm +c SAXS restraint penalty function +#ifdef DEBUG + write(iout,*) "------- SAXS penalty function start -------" + write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start, + & " isaxs_end",isaxs_end + write (iout,*) "nnt",nnt," ntc",nct + do i=nnt,nct + write(iout,'(a6,i5,3f10.5,5x,2f10.5)') + & "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i)) + enddo + do i=nnt,nct + write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3) + enddo +#endif + Esaxs_constr = 0.0d0 + logPtot=0.0d0 + do j=isaxs_start,isaxs_end + Pcalc=0.0d0 + do i=1,nres + do l=1,3 + PgradC(l,i)=0.0d0 + PgradX(l,i)=0.0d0 + enddo + enddo + do i=nnt,nct + dijCASPH=0.0d0 + dijSCSPH=0.0d0 + do l=1,3 + dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2 + enddo + if (itype(i).ne.10) then + do l=1,3 + dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2 + enddo + endif + sigma2CA=2.0d0/pstok**2 + sigma2SC=4.0d0/restok(itype(i))**2 + expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH) + expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH) + Pcalc = Pcalc+expCASPH+expSCSPH +#ifdef DEBUG + write(*,*) "processor i j Pcalc", + & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc +#endif + CASPHgrad = sigma2CA*expCASPH + SCSPHgrad = sigma2SC*expSCSPH + do l=1,3 + aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad + PgradX(l,i) = PgradX(l,i) + aux + PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux + enddo ! l + enddo ! i + do i=nnt,nct + do l=1,3 + gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc + gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc + enddo + enddo + logPtot = logPtot - dlog(Pcalc) +c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc), +c & " logPtot",logPtot + enddo ! j +#ifdef MPI + if (nfgtasks.gt.1) then +c write (iout,*) "logPtot before reduction",logPtot + call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION, + & MPI_SUM,king,FG_COMM,IERR) + logPtot = logPtot_ +c write (iout,*) "logPtot after reduction",logPtot + call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do i=1,nres + do l=1,3 + gsaxsC(l,i) = gsaxsC_(l,i) + enddo + enddo + endif + call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do i=1,nres + do l=1,3 + gsaxsX(l,i) = gsaxsX_(l,i) + enddo + enddo + endif + endif +#endif + Esaxs_constr = logPtot + return + end + diff --git a/source/wham/src-HCD/energy_p_new.F.org b/source/wham/src-HCD/energy_p_new.F.org new file mode 100644 index 0000000..8f99a16 --- /dev/null +++ b/source/wham/src-HCD/energy_p_new.F.org @@ -0,0 +1,6452 @@ + subroutine etotal(energia) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif + + include 'COMMON.IOUNITS' + double precision energia(0:max_ene),energia1(0:max_ene+1) +#ifdef MPL + include 'COMMON.INFO' + external d_vadd + integer ready +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' +cd write(iout, '(a,i2)')'Calling etotal ipot=',ipot +cd print *,'nnt=',nnt,' nct=',nct +C +C Compute the side-chain and electrostatic interaction energy +C + goto (101,102,103,104,105) ipot +C Lennard-Jones potential. + 101 call elj(evdw) +cd print '(a)','Exit ELJ' + goto 106 +C Lennard-Jones-Kihara potential (shifted). + 102 call eljk(evdw) + goto 106 +C Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp(evdw) + goto 106 +C Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb(evdw) + goto 106 +C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv(evdw) +C +C Calculate electrostatic (H-bonding) energy of the main chain. +C + 106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) +C +C Calculate excluded-volume interaction energy between peptide groups +C and side chains. +C + call escp(evdw2,evdw2_14) +C +C Calculate the disulfide-bridge and other energy and the contributions +C from other distance constraints. +cd print *,'Calling EHPB' + call edis(ehpb) +cd print *,'EHPB exitted succesfully.' +C +C Calculate the virtual-bond-angle energy. +C + call ebend(ebe) +cd print *,'Bend energy finished.' +C +C Calculate the SC local energy. +C + call esc(escloc) +cd print *,'SCLOC energy finished.' +C +C Calculate the virtual-bond torsional energy. +C +cd print *,'nterm=',nterm + call etor(etors,edihcnstr) +C +C 6/23/01 Calculate double-torsional energy +C + call etor_d(etors_d) +C +C 12/1/95 Multi-body terms +C + n_corr=0 + n_corr1=0 + if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 + & .or. wturn6.gt.0.0d0) then +c print *,"calling multibody_eello" + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +c write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1 +c print *,ecorr,ecorr5,ecorr6,eturn6 + endif + if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) + endif +C call multibody(ecorr) +C +C Sum the energies +C +C scale large componenets +#ifdef SCALE + ecorr5_scal=1000.0 + eel_loc_scal=100.0 + eello_turn3_scal=100.0 + eello_turn4_scal=100.0 + eturn6_scal=1000.0 + ecorr6_scal=1000.0 +#else + ecorr5_scal=1.0 + eel_loc_scal=1.0 + eello_turn3_scal=1.0 + eello_turn4_scal=1.0 + eturn6_scal=1.0 + ecorr6_scal=1.0 +#endif + + ecorr5=ecorr5/ecorr5_scal + eel_loc=eel_loc/eel_loc_scal + eello_turn3=eello_turn3/eello_turn3_scal + eello_turn4=eello_turn4/eello_turn4_scal + eturn6=eturn6/eturn6_scal + ecorr6=ecorr6/ecorr6_scal +#ifdef MPL + if (fgprocs.gt.1) then +cd call enerprint(evdw,evdw1,evdw2,ees,ebe,escloc,etors,ehpb, +cd & edihcnstr,ecorr,eel_loc,eello_turn4,etot) + energia(1)=evdw + energia(2)=evdw2 + energia(3)=ees + energia(4)=evdw1 + energia(5)=ecorr + energia(6)=etors + energia(7)=ebe + energia(8)=escloc + energia(9)=ehpb + energia(10)=edihcnstr + energia(11)=eel_loc + energia(12)=ecorr5 + energia(13)=ecorr6 + energia(14)=eello_turn3 + energia(15)=eello_turn4 + energia(16)=eturn6 + energia(17)=etors_d + msglen=80 + do i=1,15 + energia1(i)=energia(i) + enddo +cd write (iout,*) 'BossID=',BossID,' MyGroup=',MyGroup +cd write (*,*) 'BossID=',BossID,' MyGroup=',MyGroup +cd write (*,*) 'Processor',MyID,' calls MP_REDUCE in ENERGY', +cd & ' BossID=',BossID,' MyGroup=',MyGroup + call mp_reduce(energia1(1),energia(1),msglen,BossID,d_vadd, + & fgGroupID) +cd write (iout,*) 'Processor',MyID,' Reduce finished' + evdw=energia(1) + evdw2=energia(2) + ees=energia(3) + evdw1=energia(4) + ecorr=energia(5) + etors=energia(6) + ebe=energia(7) + escloc=energia(8) + ehpb=energia(9) + edihcnstr=energia(10) + eel_loc=energia(11) + ecorr5=energia(12) + ecorr6=energia(13) + eello_turn3=energia(14) + eello_turn4=energia(15) + eturn6=energia(16) + etors_d=energia(17) + endif +c if (MyID.eq.BossID) then +#endif + etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) + & +wang*ebe+wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 + & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 + & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d + energia(0)=etot + energia(1)=evdw + energia(2)=evdw2 + energia(3)=ees+evdw1 + 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(16)=edihcnstr + energia(17)=evdw2_14 +c detecting NaNQ + 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 +#ifdef MPL +c endif +#endif + if (calc_grad) then +C +C Sum up the components of the Cartesian gradient. +C + do i=1,nct + do j=1,3 + gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ + & welec*gelc(j,i)+wstrain*ghpbc(j,i)+ + & wcorr*gradcorr(j,i)+ + & wel_loc*gel_loc(j,i)/eel_loc_scal+ + & wturn3*gcorr3_turn(j,i)/eello_turn3_scal+ + & wturn4*gcorr4_turn(j,i)/eello_turn4_scal+ + & wcorr5*gradcorr5(j,i)/ecorr5_scal+ + & wcorr6*gradcorr6(j,i)/ecorr6_scal+ + & wturn6*gcorr6_turn(j,i)/eturn6_scal + gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i) + enddo +cd print '(i3,9(1pe12.4))',i,(gvdwc(k,i),k=1,3),(gelc(k,i),k=1,3), +cd & (gradc(k,i),k=1,3) + enddo + + + do i=1,nres-3 +cd write (iout,*) i,g_corr5_loc(i) + gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) + & +wcorr5*g_corr5_loc(i)/ecorr5_scal + & +wcorr6*g_corr6_loc(i)/ecorr6_scal + & +wturn4*gel_loc_turn4(i)/eello_turn4_scal + & +wturn3*gel_loc_turn3(i)/eello_turn3_scal + & +wturn6*gel_loc_turn6(i)/eturn6_scal + & +wel_loc*gel_loc_loc(i)/eel_loc_scal + enddo + endif +cd print*,evdw,wsc,evdw2,wscp,ees+evdw1,welec,ebe,wang, +cd & escloc,wscloc,etors,wtor,ehpb,wstrain,nss,ebr,etot +cd call enerprint(energia(0)) +cd call intout +cd stop + return + end +C------------------------------------------------------------------------ + subroutine enerprint(energia) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + double precision energia(0:max_ene) + etot=energia(0) + evdw=energia(1) + evdw2=energia(2) + ees=energia(3) + 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(16) + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,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,edihcnstr,ebr*nss,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)'/ + & '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)'/ + & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'ETOT= ',1pE16.6,' (total)') + return + end +C----------------------------------------------------------------------- + subroutine elj(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJ potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + 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.ENEPS' + include 'COMMON.SBRIDGE' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.CONTACTS' + dimension gg(3) + integer icant + external icant +cd print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon + do i=1,210 + do j=1,2 + eneps_temp(j,i)=0.0d0 + enddo + enddo + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +C Change 12/1/95 + num_conti=0 +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) +cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +cd & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi +C Change 12/1/95 to calculate four-body interactions + rij=xj*xj+yj*yj+zj*zj + rrij=1.0D0/rij +c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e1+e2 + ij=icant(itypi,itypj) + eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij) + eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij +cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), +cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, +cd & (c(k,i),k=1,3),(c(k,j),k=1,3) + evdw=evdw+evdwij + if (calc_grad) then +C +C Calculate the components of the gradient in DC and X +C + fac=-rrij*(e1+evdwij) + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + enddo + do k=i,j-1 + do l=1,3 + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo + enddo + endif +C +C 12/1/95, revised on 5/20/97 +C +C Calculate the contact function. The ith column of the array JCONT will +C contain the numbers of atoms that make contacts with the atom I (of numbers +C greater than I). The arrays FACONT and GACONT will contain the values of +C the contact function and its derivative. +C +C Uncomment next line, if the correlation interactions include EVDW explicitly. +c if (j.gt.i+1 .and. evdwij.le.0.0D0) then +C Uncomment next line, if the correlation interactions are contact function only + if (j.gt.i+1.and. eps0ij.gt.0.0D0) then + rij=dsqrt(rij) + sigij=sigma(itypi,itypj) + r0ij=rs0(itypi,itypj) +C +C Check whether the SC's are not too far to make a contact. +C + rcut=1.5d0*r0ij + call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) +C Add a new contact, if the SC's are close enough, but not too close (ri' + do k=1,3 + ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) + enddo + endif + do k=1,3 + gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) + enddo + kstart=min0(i+1,j) + kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) + do k=kstart,kend + do l=1,3 + gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) + enddo + enddo + endif + enddo + enddo ! iint + 1225 continue + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time the factor EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C-------------------------------------------------------------------------- + subroutine edis(ehpb) +C +C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + dimension ggg(3) + ehpb=0.0D0 +cd print *,'edis: nhpb=',nhpb,' fbr=',fbr +cd print *,'link_start=',link_start,' link_end=',link_end + if (link_end.eq.0) return + do i=link_start,link_end +C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a +C CA-CA distance used in regularization of structure. + ii=ihpb(i) + jj=jhpb(i) +C iii and jjj point to the residues for which the distance is assigned. + if (ii.gt.nres) then + iii=ii-nres + jjj=jj-nres + else + iii=ii + jjj=jj + endif +C Calculate the distance between the two points and its difference from the +C target distance. + dd=dist(ii,jj) + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd +cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, +cd & ' waga=',waga,' fac=',fac + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC distace, we need to calculate the contributions to the +C Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + do j=iii,jjj-1 + do k=1,3 + ghpbc(k,j)=ghpbc(k,j)+ggg(k) + enddo + enddo + enddo + ehpb=0.5D0*ehpb + return + end +C-------------------------------------------------------------------------- + subroutine ebend(etheta) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + 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' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + double precision y(2),z(2) + delta=0.02d0*pi + time11=dexp(-2*time) + time12=1.0d0 + etheta=0.0D0 +c write (iout,*) "nres",nres +c write (*,'(a,i2)') 'EBEND ICG=',icg +c write (iout,*) ithet_start,ithet_end + do i=ithet_start,ithet_end +C Zero the energy function and its derivative at 0 or pi. + call splinthet(theta(i),0.5d0*delta,ss,ssd) + it=itype(i-1) + if (i.gt.ithet_start .and. + & (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215 + if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then + phii=phi(i) + y(1)=dcos(phii) + y(2)=dsin(phii) + else + y(1)=0.0D0 + y(2)=0.0D0 + endif + if (i.lt.nres .and. itel(i).ne.0) then + phii1=phi(i+1) + z(1)=dcos(phii1) + z(2)=dsin(phii1) + else + z(1)=0.0D0 + z(2)=0.0D0 + endif +C Calculate the "mean" value of theta from the part of the distribution +C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). +C In following comments this theta will be referred to as t_c. + thet_pred_mean=0.0d0 + do k=1,2 + athetk=athet(k,it) + bthetk=bthet(k,it) + thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) + enddo +c write (iout,*) "thet_pred_mean",thet_pred_mean + dthett=thet_pred_mean*ssd + thet_pred_mean=thet_pred_mean*ss+a0thet(it) +c write (iout,*) "thet_pred_mean",thet_pred_mean +C Derivatives of the "mean" values in gamma1 and gamma2. + dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss + dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss + if (theta(i).gt.pi-delta) then + call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, + & E_tc0) + call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) + call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, + & E_theta) + call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, + & E_tc) + else if (theta(i).lt.delta) then + call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) + call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, + & E_theta) + call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) + call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, + & E_tc) + else + call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, + & E_theta,E_tc) + endif + etheta=etheta+ethetai +c write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i), +c & rad2deg*phii,rad2deg*phii1,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) + 1215 continue + enddo +C Ufff.... We've done all this!!! + return + end +C--------------------------------------------------------------------------- + subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, + & E_tc) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it +C Calculate the contributions to both Gaussian lobes. +C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) +C The "polynomial part" of the "standard deviation" of this part of +C the distribution. + sig=polthet(3,it) + do j=2,0,-1 + sig=sig*thet_pred_mean+polthet(j,it) + enddo +C Derivative of the "interior part" of the "standard deviation of the" +C gamma-dependent Gaussian lobe in t_c. + sigtc=3*polthet(3,it) + do j=2,1,-1 + sigtc=sigtc*thet_pred_mean+j*polthet(j,it) + enddo + sigtc=sig*sigtc +C Set the parameters of both Gaussian lobes of the distribution. +C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) + fac=sig*sig+sigc0(it) + sigcsq=fac+fac + sigc=1.0D0/sigcsq +C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c + sigsqtc=-4.0D0*sigcsq*sigtc +c print *,i,sig,sigtc,sigsqtc +C Following variable (sigtc) is d[sigma(t_c)]/dt_c + sigtc=-sigtc/(fac*fac) +C Following variable is sigma(t_c)**(-2) + sigcsq=sigcsq*sigcsq + sig0i=sig0(it) + sig0inv=1.0D0/sig0i**2 + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i + term1=-0.5D0*sigcsq*delthec*delthec + term2=-0.5D0*sig0inv*delthe0*delthe0 +C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and +C NaNs in taking the logarithm. We extract the largest exponent which is added +C to the energy (this being the log of the distribution) at the end of energy +C term evaluation for this virtual-bond angle. + if (term1.gt.term2) then + termm=term1 + term2=dexp(term2-termm) + term1=1.0d0 + else + termm=term2 + term1=dexp(term1-termm) + term2=1.0d0 + endif +C The ratio between the gamma-independent and gamma-dependent lobes of +C the distribution is a Gaussian function of thet_pred_mean too. + diffak=gthet(2,it)-thet_pred_mean + ratak=diffak/gthet(3,it)**2 + ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) +C Let's differentiate it in thet_pred_mean NOW. + aktc=ak*ratak +C Now put together the distribution terms to make complete distribution. + termexp=term1+ak*term2 + termpre=sigc+ak*sig0i +C Contribution of the bending energy from this theta is just the -log of +C the sum of the contributions from the two lobes and the pre-exponential +C factor. Simple enough, isn't it? + ethetai=(-dlog(termexp)-termm+dlog(termpre)) +C NOW the derivatives!!! +C 6/6/97 Take into account the deformation. + E_theta=(delthec*sigcsq*term1 + & +ak*delthe0*sig0inv*term2)/termexp + E_tc=((sigtc+aktc*sig0i)/termpre + & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ + & aktc*term2)/termexp) + return + end +c----------------------------------------------------------------------------- + subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i +C "Thank you" to MAPLE (probably spared one day of hand-differentiation). + t3 = thetai-thet_pred_mean + t6 = t3**2 + t9 = term1 + t12 = t3*sigcsq + t14 = t12+t6*sigsqtc + t16 = 1.0d0 + t21 = thetai-theta0i + t23 = t21**2 + t26 = term2 + t27 = t21*t26 + t32 = termexp + t40 = t32**2 + E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 + & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 + & *(-t12*t9-ak*sig0inv*t27) + return + end +c----------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + 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' + double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), + & ddersc0(3),ddummy(3),xtemp(3),temp(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 +c write (iout,'(a)') 'ESC' + do i=loc_start,loc_end + it=itype(i) + if (it.eq.10) goto 1 + nlobit=nlob(it) +c print *,'i=',i,' it=',it,' nlobit=',nlobit +c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad + theti=theta(i+1)-pipol + x(1)=dtan(theti) + x(2)=alph(i) + x(3)=omeg(i) + + if (x(2).gt.pi-delta) then + xtemp(1)=x(1) + xtemp(2)=pi-delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=pi + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=pi-delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=pi + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + call splinthet(x(2),0.5d0*delta,ss,ssd) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c escloci=esclocbi +c write (iout,*) escloci + else if (x(2).lt.delta) then + xtemp(1)=x(1) + xtemp(2)=delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=0.0d0 + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=0.0d0 + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + call splinthet(x(2),0.5d0*delta,ss,ssd) + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c write (iout,*) escloci + else + call enesc(x,escloci,dersc,ddummy,.false.) + endif + + escloc=escloc+escloci +c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc + + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ + & wscloc*dersc(1) + gloc(ialph(i,1),icg)=wscloc*dersc(2) + gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) + 1 continue + enddo + return + end +C--------------------------------------------------------------------------- + subroutine enesc(x,escloci,dersc,ddersc,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) + double precision contr(maxlob,-1:1) + logical mixed +c write (iout,*) 'it=',it,' nlobit=',nlobit + escloc_i=0.0D0 + do j=1,3 + dersc(j)=0.0D0 + if (mixed) ddersc(j)=0.0d0 + enddo + x3=x(3) + +C Because of periodicity of the dependence of the SC energy in omega we have +C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). +C To avoid underflows, first compute & store the exponents. + + do iii=-1,1 + + x(3)=x3+iii*dwapi + + do j=1,nlobit + do k=1,3 + z(k)=x(k)-censc(k,j,it) + enddo + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j,iii)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j,iii)*z(k) + enddo + contr(j,iii)=expfac + enddo ! j + + enddo ! iii + + x(3)=x3 +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1,-1) + do iii=-1,1 + do j=1,nlobit + if (emin.gt.contr(j,iii)) emin=contr(j,iii) + enddo + enddo + emin=0.5D0*emin +cd print *,'it=',it,' emin=',emin + +C Compute the contribution to SC energy and derivatives + do iii=-1,1 + + do j=1,nlobit + expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin) +cd print *,'j=',j,' expfac=',expfac + escloc_i=escloc_i+expfac + do k=1,3 + dersc(k)=dersc(k)+Ax(k,j,iii)*expfac + enddo + if (mixed) then + do k=1,3,2 + ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) + & +gaussc(k,2,j,it))*expfac + enddo + endif + enddo + + enddo ! iii + + dersc(1)=dersc(1)/cos(theti)**2 + ddersc(1)=ddersc(1)/cos(theti)**2 + ddersc(3)=ddersc(3) + + escloci=-(dlog(escloc_i)-emin) + do j=1,3 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) then + do j=1,3,2 + ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) + enddo + endif + return + end +C------------------------------------------------------------------------------ + subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob),dersc(3) + double precision contr(maxlob) + logical mixed + + escloc_i=0.0D0 + + do j=1,3 + dersc(j)=0.0D0 + enddo + + do j=1,nlobit + do k=1,2 + z(k)=x(k)-censc(k,j,it) + enddo + z(3)=dwapi + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j)*z(k) + enddo + contr(j)=expfac + enddo ! j + +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1) + do j=1,nlobit + if (emin.gt.contr(j)) emin=contr(j) + enddo + emin=0.5D0*emin + +C Compute the contribution to SC energy and derivatives + + dersc12=0.0d0 + do j=1,nlobit + expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin) + escloc_i=escloc_i+expfac + do k=1,2 + dersc(k)=dersc(k)+Ax(k,j)*expfac + enddo + if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) + & +gaussc(1,2,j,it))*expfac + dersc(3)=0.0d0 + enddo + + dersc(1)=dersc(1)/cos(theti)**2 + dersc12=dersc12/cos(theti)**2 + escloci=-(dlog(escloc_i)-emin) + do j=1,2 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) + return + end +c------------------------------------------------------------------------------ + subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) +C +C This procedure calculates two-body contact function g(rij) and its derivative: +C +C eps0ij ! x < -1 +C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 +C 0 ! x > 1 +C +C where x=(rij-r0ij)/delta +C +C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy +C + implicit none + double precision rij,r0ij,eps0ij,fcont,fprimcont + double precision x,x2,x4,delta +c delta=0.02D0*r0ij +c delta=0.2D0*r0ij + x=(rij-r0ij)/delta + if (x.lt.-1.0D0) then + fcont=eps0ij + fprimcont=0.0D0 + else if (x.le.1.0D0) then + x2=x*x + x4=x2*x2 + fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) + fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta + else + fcont=0.0D0 + fprimcont=0.0D0 + endif + return + end +c------------------------------------------------------------------------------ + subroutine splinthet(theti,delta,ss,ssder) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + thetup=pi-delta + thetlow=delta + if (theti.gt.pipol) then + call gcont(theti,thetup,1.0d0,delta,ss,ssder) + else + call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) + ssder=-ssder + endif + return + end +c------------------------------------------------------------------------------ + subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) + implicit none + double precision x,x0,delta,f0,f1,fprim0,f,fprim + double precision ksi,ksi2,ksi3,a1,a2,a3 + a1=fprim0*delta/(f1-f0) + a2=3.0d0-2.0d0*a1 + a3=a1-2.0d0 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) + fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) + return + end +c------------------------------------------------------------------------------ + subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) + implicit none + double precision x,x0,delta,f0x,f1x,fprim0x,fx + double precision ksi,ksi2,ksi3,a1,a2,a3 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + a1=fprim0x*delta + a2=3*(f1x-f0x)-2*fprim0x*delta + a3=fprim0x*delta-2*(f1x-f0x) + fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 + return + end +C----------------------------------------------------------------------------- +#ifdef CRYST_TOR +C----------------------------------------------------------------------------- + subroutine etor(etors,edihcnstr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Proline-Proline pair is a special case... + if (itori.eq.3 .and. itori1.eq.3) then + if (phii.gt.-dwapi3) then + cosphi=dcos(3*phii) + fac=1.0D0/(1.0D0-cosphi) + etorsi=v1(1,3,3)*fac + etorsi=etorsi+etorsi + etors=etors+etorsi-v1(1,3,3) + 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) + 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) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + endif + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 + do i=1,ndih_constr + itori=idih_constr(i) + phii=phi(itori) + difi=phii-phi0(i) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + endif +! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, +! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +! write (iout,*) 'edihcnstr',edihcnstr + return + end +c------------------------------------------------------------------------------ +#else + subroutine etor(etors,edihcnstr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215 + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Regular cosine and sine terms + do j=1,nterm(itori,itori1) + v1ij=v1(j,itori,itori1) + v2ij=v2(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +C Lorentz terms +C v1 +C E = SUM ----------------------------------- - v1 +C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 +C + cosphi=dcos(0.5d0*phii) + sinphi=dsin(0.5d0*phii) + do j=1,nlor(itori,itori1) + vl1ij=vlor1(j,itori,itori1) + vl2ij=vlor2(j,itori,itori1) + vl3ij=vlor3(j,itori,itori1) + pom=vl2ij*cosphi+vl3ij*sinphi + pom1=1.0d0/(pom*pom+1.0d0) + etors=etors+vl1ij*pom1 + pom=-pom*pom1*pom1 + gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom + enddo +C Subtract the constant term + etors=etors-v0(itori,itori1) + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + 1215 continue + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 + do i=1,ndih_constr + print *,"i",i + itori=idih_constr(i) + phii=phi(itori) + difi=phii-phi0(i) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + endif +! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, +! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +! write (iout,*) 'edihcnstr',edihcnstr + return + end +c---------------------------------------------------------------------------- + subroutine etor_d(etors_d) +C 6/23/01 Compute double torsional energy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors_d=0.0D0 + do i=iphi_start,iphi_end-1 + if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0) + & goto 1215 + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + itori2=itortyp(itype(i)) + phii=phi(i) + phii1=phi(i+1) + gloci1=0.0D0 + gloci2=0.0D0 +C Regular cosine and sine terms + do j=1,ntermd_1(itori,itori1,itori2) + v1cij=v1c(1,j,itori,itori1,itori2) + v1sij=v1s(1,j,itori,itori1,itori2) + v2cij=v1c(2,j,itori,itori1,itori2) + v2sij=v1s(2,j,itori,itori1,itori2) + cosphi1=dcos(j*phii) + sinphi1=dsin(j*phii) + cosphi2=dcos(j*phii1) + sinphi2=dsin(j*phii1) + etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ + & v2cij*cosphi2+v2sij*sinphi2 + gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) + gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) + enddo + do k=2,ntermd_2(itori,itori1,itori2) + do l=1,k-1 + v1cdij = v2c(k,l,itori,itori1,itori2) + v2cdij = v2c(l,k,itori,itori1,itori2) + v1sdij = v2s(k,l,itori,itori1,itori2) + v2sdij = v2s(l,k,itori,itori1,itori2) + cosphi1p2=dcos(l*phii+(k-l)*phii1) + cosphi1m2=dcos(l*phii-(k-l)*phii1) + sinphi1p2=dsin(l*phii+(k-l)*phii1) + sinphi1m2=dsin(l*phii-(k-l)*phii1) + etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ + & v1sdij*sinphi1p2+v2sdij*sinphi1m2 + gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) + gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + enddo + enddo + gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 + gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 + 1215 continue + enddo + return + end +#endif +c------------------------------------------------------------------------------ + subroutine multibody(ecorr) +C This subroutine calculates multi-body contributions to energy following +C the idea of Skolnick et al. If side chains I and J make a contact and +C at the same time side chains I+1 and J+1 make a contact, an extra +C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + +C Set lprn=.true. for debugging + lprn=.false. + + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(i2,20(1x,i2,f10.5))') + & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) + enddo + endif + ecorr=0.0D0 + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo + do i=nnt,nct-2 + + DO ISHIFT = 3,4 + + i1=i+ishift + num_conti=num_cont(i) + num_conti1=num_cont(i1) + do jj=1,num_conti + j=jcont(jj,i) + do kk=1,num_conti1 + j1=jcont(kk,i1) + if (j1.eq.j+ishift .or. j1.eq.j-ishift) then +cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, +cd & ' ishift=',ishift +C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) + endif ! j1==j+-ishift + enddo ! kk + enddo ! jj + + ENDDO ! ISHIFT + + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function esccorr(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont(jj,i) + ekl=facont(kk,k) +cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl +C Calculate the multi-body contribution to energy. +C Calculate multi-body contributions to the gradient. +cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), +cd & k,l,(gacont(m,kk,k),m=1,3) + do m=1,3 + gx(m) =ekl*gacont(m,jj,i) + gx1(m)=eij*gacont(m,kk,k) + gradxorr(m,i)=gradxorr(m,i)-gx(m) + gradxorr(m,j)=gradxorr(m,j)+gx(m) + gradxorr(m,k)=gradxorr(m,k)-gx1(m) + gradxorr(m,l)=gradxorr(m,l)+gx1(m) + enddo + do m=i,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) + enddo + enddo + do m=k,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) + enddo + enddo + esccorr=-eij*ekl + return + end +c------------------------------------------------------------------------------ +#ifdef MPL + subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + integer dimen1,dimen2,atom,indx + double precision buffer(dimen1,dimen2) + double precision zapas + common /contacts_hb/ zapas(3,20,maxres,7), + & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), + & num_cont_hb(maxres),jcont_hb(20,maxres) + num_kont=num_cont_hb(atom) + do i=1,num_kont + do k=1,7 + do j=1,3 + buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k) + enddo ! j + enddo ! k + buffer(i,indx+22)=facont_hb(i,atom) + buffer(i,indx+23)=ees0p(i,atom) + buffer(i,indx+24)=ees0m(i,atom) + buffer(i,indx+25)=dfloat(jcont_hb(i,atom)) + enddo ! i + buffer(1,indx+26)=dfloat(num_kont) + return + end +c------------------------------------------------------------------------------ + subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + integer dimen1,dimen2,atom,indx + double precision buffer(dimen1,dimen2) + double precision zapas + common /contacts_hb/ zapas(3,20,maxres,7), + & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), + & num_cont_hb(maxres),jcont_hb(20,maxres) + num_kont=buffer(1,indx+26) + num_kont_old=num_cont_hb(atom) + num_cont_hb(atom)=num_kont+num_kont_old + do i=1,num_kont + ii=i+num_kont_old + do k=1,7 + do j=1,3 + zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j) + enddo ! j + enddo ! k + facont_hb(ii,atom)=buffer(i,indx+22) + ees0p(ii,atom)=buffer(i,indx+23) + ees0m(ii,atom)=buffer(i,indx+24) + jcont_hb(ii,atom)=buffer(i,indx+25) + enddo ! i + return + end +c------------------------------------------------------------------------------ +#endif + subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' +#ifdef MPL + parameter (max_cont=maxconts) + parameter (max_dim=2*(8*3+2)) + parameter (msglen1=max_cont*max_dim*4) + parameter (msglen2=2*msglen1) + integer source,CorrelType,CorrelID,Error + double precision buffer(max_cont,max_dim) +#endif + double precision gx(3),gx1(3) + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. +#ifdef MPL + n_corr=0 + n_corr1=0 + if (fgProcs.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values:' + 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 +C Caution! Following code assumes that electrostatic interactions concerning +C a given atom are split among at most two processors! + CorrelType=477 + CorrelID=MyID+1 + ldone=.false. + do i=1,max_cont + do j=1,max_dim + buffer(i,j)=0.0D0 + enddo + enddo + mm=mod(MyRank,2) +cd write (iout,*) 'MyRank',MyRank,' mm',mm + if (mm) 20,20,10 + 10 continue +cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.gt.0) then +C Send correlation contributions to the preceding processor + msglen=msglen1 + nn=num_cont_hb(iatel_s) + call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) +cd write (iout,*) 'The BUFFER array:' +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26) +cd enddo + if (ielstart(iatel_s).gt.iatel_s+ispp) then + msglen=msglen2 + call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer) +C Clear the contacts of the atom passed to the neighboring processor + nn=num_cont_hb(iatel_s+1) +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26) +cd enddo + num_cont_hb(iatel_s)=0 + endif +cd write (iout,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen +cd write (*,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID) +cd write (iout,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID +cd write (*,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID + msglen=msglen1 + endif ! (MyRank.gt.0) + if (ldone) goto 30 + ldone=.true. + 20 continue +cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.lt.fgProcs-1) then +C Receive correlation contributions from the next processor + msglen=msglen1 + if (ielend(iatel_e).lt.nct-1) msglen=msglen2 +cd write (iout,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType +cd write (*,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + nbytes=-1 + do while (nbytes.le.0) + call mp_probe(MyID+1,CorrelType,nbytes) + enddo +cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes + call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes) +cd write (iout,*) 'Processor',MyID, +cd & ' has received correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' nbytes=',nbytes +cd write (iout,*) 'The received BUFFER array:' +cd do i=1,max_cont +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52) +cd enddo + if (msglen.eq.msglen1) then + call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer) + else if (msglen.eq.msglen2) then + call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) + call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) + else + write (iout,*) + & 'ERROR!!!! message length changed while processing correlations.' + write (*,*) + & 'ERROR!!!! message length changed while processing correlations.' + call mp_stopall(Error) + endif ! msglen.eq.msglen1 + endif ! MyRank.lt.fgProcs-1 + if (ldone) goto 30 + ldone=.true. + goto 10 + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + 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 + ecorr=0.0D0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the local-electrostatic correlation terms + do i=iatel_s,iatel_e+1 + 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) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1 .or. j1.eq.j-1) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) + n_corr=n_corr+1 + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, + & n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' +#ifdef MPL + parameter (max_cont=maxconts) + parameter (max_dim=2*(8*3+2)) + parameter (msglen1=max_cont*max_dim*4) + parameter (msglen2=2*msglen1) + integer source,CorrelType,CorrelID,Error + double precision buffer(max_cont,max_dim) +#endif + double precision gx(3),gx1(3) + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. + eturn6=0.0d0 +#ifdef MPL + n_corr=0 + n_corr1=0 + if (fgProcs.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values:' + 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 +C Caution! Following code assumes that electrostatic interactions concerning +C a given atom are split among at most two processors! + CorrelType=477 + CorrelID=MyID+1 + ldone=.false. + do i=1,max_cont + do j=1,max_dim + buffer(i,j)=0.0D0 + enddo + enddo + mm=mod(MyRank,2) +cd write (iout,*) 'MyRank',MyRank,' mm',mm + if (mm) 20,20,10 + 10 continue +cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.gt.0) then +C Send correlation contributions to the preceding processor + msglen=msglen1 + nn=num_cont_hb(iatel_s) + call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) +cd write (iout,*) 'The BUFFER array:' +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26) +cd enddo + if (ielstart(iatel_s).gt.iatel_s+ispp) then + msglen=msglen2 + call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer) +C Clear the contacts of the atom passed to the neighboring processor + nn=num_cont_hb(iatel_s+1) +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26) +cd enddo + num_cont_hb(iatel_s)=0 + endif +cd write (iout,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen +cd write (*,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID) +cd write (iout,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID +cd write (*,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID + msglen=msglen1 + endif ! (MyRank.gt.0) + if (ldone) goto 30 + ldone=.true. + 20 continue +cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.lt.fgProcs-1) then +C Receive correlation contributions from the next processor + msglen=msglen1 + if (ielend(iatel_e).lt.nct-1) msglen=msglen2 +cd write (iout,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType +cd write (*,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + nbytes=-1 + do while (nbytes.le.0) + call mp_probe(MyID+1,CorrelType,nbytes) + enddo +cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes + call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes) +cd write (iout,*) 'Processor',MyID, +cd & ' has received correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' nbytes=',nbytes +cd write (iout,*) 'The received BUFFER array:' +cd do i=1,max_cont +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52) +cd enddo + if (msglen.eq.msglen1) then + call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer) + else if (msglen.eq.msglen2) then + call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) + call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) + else + write (iout,*) + & 'ERROR!!!! message length changed while processing correlations.' + write (*,*) + & 'ERROR!!!! message length changed while processing correlations.' + call mp_stopall(Error) + endif ! msglen.eq.msglen1 + endif ! MyRank.lt.fgProcs-1 + if (ldone) goto 30 + ldone=.true. + goto 10 + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + 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 + ecorr=0.0D0 + ecorr5=0.0d0 + ecorr6=0.0d0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the dipole-dipole interaction energies + if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then + do i=iatel_s,iatel_e+1 + num_conti=num_cont_hb(i) + do jj=1,num_conti + j=jcont_hb(jj,i) + call dipole(i,j,jj) + enddo + enddo + endif +C Calculate the local-electrostatic correlation terms + do i=iatel_s,iatel_e+1 + 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) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) +c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1 .or. j1.eq.j-1) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + n_corr=n_corr+1 + sqd1=dsqrt(d_cont(jj,i)) + sqd2=dsqrt(d_cont(kk,i1)) + sred_geom = sqd1*sqd2 + IF (sred_geom.lt.cutoff_corr) THEN + call gcont(sred_geom,r0_corr,1.0D0,delt_corr, + & ekont,fprimcont) +c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + fac_prim1=0.5d0*sqd2/sqd1*fprimcont + fac_prim2=0.5d0*sqd1/sqd2*fprimcont + do l=1,3 + g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) + g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) + enddo + n_corr1=n_corr1+1 +cd write (iout,*) 'sred_geom=',sred_geom, +cd & ' ekont=',ekont,' fprim=',fprimcont + call calc_eello(i,j,i+1,j1,jj,kk) + if (wcorr4.gt.0.0d0) + & ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk) + if (wcorr5.gt.0.0d0) + & ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk) +c print *,"wcorr5",ecorr5 +cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 +cd write(2,*)'ijkl',i,j,i+1,j1 + if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3 + & .or. wturn6.eq.0.0d0))then +cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 + ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk) +cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, +cd & 'ecorr6=',ecorr6 +cd write (iout,'(4e15.5)') sred_geom, +cd & dabs(eello4(i,j,i+1,j1,jj,kk)), +cd & dabs(eello5(i,j,i+1,j1,jj,kk)), +cd & dabs(eello6(i,j,i+1,j1,jj,kk)) + else if (wturn6.gt.0.0d0 + & .and. (j.eq.i+4 .and. j1.eq.i+3)) then +cd write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1 + eturn6=eturn6+eello_turn6(i,jj,kk) +cd write (2,*) 'multibody_eello:eturn6',eturn6 + endif + ENDIF +1111 continue + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont_hb(jj,i) + ekl=facont_hb(kk,k) + ees0pij=ees0p(jj,i) + ees0pkl=ees0p(kk,k) + ees0mij=ees0m(jj,i) + ees0mkl=ees0m(kk,k) + ekont=eij*ekl + ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) +cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) +C Following 4 lines for diagnostics. +cd ees0pkl=0.0D0 +cd ees0pij=1.0D0 +cd ees0mkl=0.0D0 +cd ees0mij=1.0D0 +c write (iout,*)'Contacts have occurred for peptide groups',i,j, +c & ' and',k,l +c write (iout,*)'Contacts have occurred for peptide groups', +c & i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l +c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees +C Calculate the multi-body contribution to energy. + ecorr=ecorr+ekont*ees + if (calc_grad) then +C Calculate multi-body contributions to the gradient. + do ll=1,3 + ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,i)=gradcorr(ll,i)+ghalf + & -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+ + & coeffm*ees0mkl*gacontm_hb1(ll,jj,i)) + gradcorr(ll,j)=gradcorr(ll,j)+ghalf + & -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+ + & coeffm*ees0mkl*gacontm_hb2(ll,jj,i)) + ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,k)=gradcorr(ll,k)+ghalf + & -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+ + & coeffm*ees0mij*gacontm_hb1(ll,kk,k)) + gradcorr(ll,l)=gradcorr(ll,l)+ghalf + & -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+ + & coeffm*ees0mij*gacontm_hb2(ll,kk,k)) + enddo + do m=i+1,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ + & ees*ekl*gacont_hbr(ll,jj,i)- + & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ + & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ + & ees*eij*gacont_hbr(ll,kk,k)- + & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ + & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) + enddo + enddo + endif + ehbcorr=ekont*ees + return + end +C--------------------------------------------------------------------------- + subroutine dipole(i,j,jj) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), + & auxmat(2,2) + iti1 = itortyp(itype(i+1)) + if (j.lt.nres-1) then + itj1 = itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + do iii=1,2 + dipi(iii,1)=Ub2(iii,i) + dipderi(iii)=Ub2der(iii,i) + dipi(iii,2)=b1(iii,iti1) + dipj(iii,1)=Ub2(iii,j) + dipderj(iii)=Ub2der(iii,j) + dipj(iii,2)=b1(iii,itj1) + enddo + kkk=0 + do iii=1,2 + call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) + do jjj=1,2 + kkk=kkk+1 + dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + if (.not.calc_grad) return + 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 +C--------------------------------------------------------------------------- + subroutine calc_eello(i,j,k,l,jj,kk) +C +C This subroutine computes matrices and vectors needed to calculate +C the fourth-, fifth-, and sixth-order local-electrostatic terms. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), + & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) + logical lprn + common /kutas/ lprn +cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, +cd & ' jj=',jj,' kk=',kk +cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return + do iii=1,2 + do jjj=1,2 + aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) + aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) + enddo + enddo + call transpose2(aa1(1,1),aa1t(1,1)) + call transpose2(aa2(1,1),aa2t(1,1)) + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), + & aa1tder(1,1,lll,kkk)) + call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), + & aa2tder(1,1,lll,kkk)) + enddo + enddo + if (l.eq.j+1) then +C parallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itj=itortyp(itype(j)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +C A1 kernel(j+1) A2T +cd do iii=1,2 +cd write (iout,'(3f10.5,5x,3f10.5)') +cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) +cd enddo + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), + & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + lprn=.false. + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), + & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants +cd lprn=.false. +cd if (lprn) then +cd write (2,*) 'In calc_eello6' +cd do iii=1,2 +cd write (2,*) 'iii=',iii +cd do kkk=1,5 +cd write (2,*) 'kkk=',kkk +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) +cd enddo +cd enddo +cd enddo +cd endif + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A1T kernel(i+1) A2 + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti), + & AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i), + & AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), + & AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj), + & AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + else +C Antiparallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif +C A2 kernel(j-1)T A1T + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), + & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), + & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A2T kernel(i+1)T A1 + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. + & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti), + & AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i), + & AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), + & AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl), + & AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l), + & AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + endif + return + end +C--------------------------------------------------------------------------- + subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, + & KK,KKderg,AKA,AKAderg,AKAderx) + implicit none + integer nderg + logical transp + double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), + & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), + & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) + integer iii,kkk,lll + integer jjj,mmm + logical lprn + common /kutas/ lprn + call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) + do iii=1,nderg + call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, + & AKAderg(1,1,iii)) + enddo +cd if (lprn) write (2,*) 'In kernel' + do kkk=1,5 +cd if (lprn) write (2,*) 'kkk=',kkk + do lll=1,3 + call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=1' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) +cd enddo +cd endif + call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=2' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) +cd enddo +cd endif + enddo + enddo + return + end +C--------------------------------------------------------------------------- + double precision function eello4(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then +cd eello4=0.0d0 +cd return +cd endif +cd print *,'eello4:',i,j,k,l,jj,kk +cd write (2,*) 'i',i,' j',j,' k',k,' l',l +cd call checkint4(i,j,k,l,jj,kk,eel4_num) +cold eij=facont_hb(jj,i) +cold ekl=facont_hb(kk,k) +cold ekont=eij*ekl + eel4=-EAEA(1,1,1)-EAEA(2,2,1) + if (calc_grad) then +cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) + gcorr_loc(k-1)=gcorr_loc(k-1) + & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) + if (l.eq.j+1) then + gcorr_loc(l-1)=gcorr_loc(l-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + else + gcorr_loc(j-1)=gcorr_loc(j-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) + & -EAEAderx(2,2,lll,kkk,iii,1) +cd derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd gcorr_loc(l-1)=0.0d0 +cd gcorr_loc(j-1)=0.0d0 +cd gcorr_loc(k-1)=0.0d0 +cd eel4=1.0d0 +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l, +cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cold ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i) + ggg1(ll)=eel4*g_contij(ll,1) + ggg2(ll)=eel4*g_contij(ll,2) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1) + gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) + gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1) + gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) +cold ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k) + ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) + gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 +cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 +cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) + enddo + enddo +1112 continue + do m=i+2,j2 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,gcorr_loc(iii) +cd enddo + endif + eello4=ekont*eel4 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello4',ekont*eel4 + return + end +C--------------------------------------------------------------------------- + double precision function eello5(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) + double precision ggg1(3),ggg2(3) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel chains C +C C +C o o o o C +C /l\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j| o |l1 | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C Antiparallel chains C +C C +C o o o o C +C /j\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j1| o |l | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C o denotes a local interaction, vertical lines an electrostatic interaction. C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then +cd eello5=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + itk=itortyp(itype(k)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + eello5_1=0.0d0 + eello5_2=0.0d0 + eello5_3=0.0d0 + eello5_4=0.0d0 +cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, +cd & eel5_3_num,eel5_4_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l +cd goto 1111 +C Contribution from the graph I. +cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) +cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + if (l.eq.j+1) then + if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + else + if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + enddo + enddo + enddo +c goto 1112 + endif +c1111 continue +C Contribution from graph II + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + if (l.eq.j+1) then + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + else + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + enddo + enddo + enddo +cd goto 1112 + endif +cd1111 continue + if (l.eq.j+1) then +cd goto 1110 +C Parallel orientation +C Contribution from graph III + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) + call transpose2(EUgder(1,1,l),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + enddo + enddo + enddo +cd goto 1112 + endif +C Contribution from graph IV +cd1110 continue + call transpose2(EE(1,1,itl),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + enddo + enddo + enddo + endif + else +C Antiparallel orientation +C Contribution from graph III +c goto 1110 + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) + call transpose2(EUgder(1,1,j),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + enddo + enddo + enddo +cd goto 1112 + endif +C Contribution from graph IV +1110 continue + call transpose2(EE(1,1,itj),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + enddo + enddo + enddo + endif + endif +1112 continue + eel5=eello5_1+eello5_2+eello5_3+eello5_4 +cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then +cd write (2,*) 'ijkl',i,j,k,l +cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, +cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 +cd endif +cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num +cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num +cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num +cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num + if (calc_grad) then + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 +cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont + do ll=1,3 + ggg1(ll)=eel5*g_contij(ll,1) + ggg2(ll)=eel5*g_contij(ll,2) +cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1) + gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) + gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1) + gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) +cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) + ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) + gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) + gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) + gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) + enddo + enddo +c1112 continue + do m=i+2,j2 + do ll=1,3 + gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr5_loc(iii) +cd enddo + endif + eello5=ekont*eel5 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello5',ekont*eel5 + return + end +c-------------------------------------------------------------------------- + double precision function eello6(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + eello6_1=0.0d0 + eello6_2=0.0d0 + eello6_3=0.0d0 + eello6_4=0.0d0 + eello6_5=0.0d0 + eello6_6=0.0d0 +cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, +cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + if (l.eq.j+1) then + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(j,i,l,k,2,.false.) + eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) + eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) + else + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(l,k,j,i,2,.true.) + eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + if (wturn6.eq.0.0d0 .or. j.ne.i+4) then + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) + else + eello6_5=0.0d0 + endif + eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) + endif +C If turn contributions are considered, they will be handled separately. + eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 +cd write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num +cd write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num +cd write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num +cd write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num +cd write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num +cd write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num +cd goto 1112 + if (calc_grad) then + 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 + ggg1(ll)=eel6*g_contij(ll,1) + ggg2(ll)=eel6*g_contij(ll,2) +cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1) + gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) + gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1) + gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) + ghalf=0.5d0*ggg2(ll) +cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) +cd ghalf=0.0d0 + gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) + gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) + gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) + gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) + enddo + enddo +1112 continue + do m=i+2,j2 + do ll=1,3 + gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + endif + eello6=ekont*eel6 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello6',ekont*eel6 + return + end +c-------------------------------------------------------------------------- + double precision function eello6_graph1(i,j,k,l,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) + logical swap + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Parallel Antiparallel +C +C o o +C /l\ /j\ +C / \ / \ +C /| o | | o |\ +C \ j|/k\| / \ |/k\|l / +C \ / \ / \ / \ / +C o o o o +C i i +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + itk=itortyp(itype(k)) + s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) + vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 + eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) + if (.not. calc_grad) return + if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) + & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) + & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) + & +scalar2(vv(1),Dtobr2der(1,i))) + call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) + vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) + if (l.eq.j+1) then + g_corr6_loc(l-1)=g_corr6_loc(l-1) + & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) + & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1) + & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) + & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + endif + call transpose2(EUgCder(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) + & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) + & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) + do iii=1,2 + if (swap) then + ind=3-iii + else + ind=iii + endif + do kkk=1,5 + do lll=1,3 + s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) + & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) + vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) + & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) + derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph2(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + logical swap + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxvec2(1),auxmat1(2,2) + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 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 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l +C AL 7/4/01 s1 would occur in the sixth-order moment, +C but not in a cluster cumulant +#ifdef MOMENT + s1=dip(1,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph2=-(s1+s2+s3+s4) +#else + eello6_graph2=-(s2+s3+s4) +#endif +c eello6_graph2=-s3 + if (.not. calc_grad) return +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + s1=dipderg(1,jj,i)*dip(1,kk,k) +#endif + s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 +C Derivatives in gamma(j-1) or gamma(l-1) + if (j.gt.1) then +#ifdef MOMENT + s1=dipderg(3,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) + call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + endif +#endif + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) +c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 + endif +C Derivatives in gamma(l-1) or gamma(j-1) + if (l.gt.1) then +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(3,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + else + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + endif +#endif + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) +c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 + endif +C Cartesian derivatives. + if (lprn) then + write (2,*) 'In eello6_graph2' + do iii=1,2 + write (2,*) 'iii=',iii + do kkk=1,5 + write (2,*) 'kkk=',kkk + do jjj=1,2 + write (2,'(3(2f10.5),5x)') + & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) + enddo + enddo + enddo + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) + else + s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) + endif +#endif + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), + & auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), + & auxvec(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph3(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 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 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. + iti=itortyp(itype(i)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +#ifdef MOMENT + s1=dip(4,jj,i)*dip(4,kk,k) +#endif + call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph3=-(s1+s2+s3+s4) +#else + eello6_graph3=-(s2+s3+s4) +#endif +c eello6_graph3=-s4 + if (.not. calc_grad) return +C Derivatives in gamma(k-1) + call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) +C Derivatives in gamma(l-1) + call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) + else + s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), + & auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif +c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxmat1(2,2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 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 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. +cd write (2,*) 'eello_graph4: wturn6',wturn6 + iti=itortyp(itype(i)) + itj=itortyp(itype(j)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + if (k.lt.nres-1) then + itk1=itortyp(itype(k+1)) + else + itk1=ntortyp+1 + endif + itl=itortyp(itype(l)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l +cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, +cd & ' itl',itl,' itl1',itl1 +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dip(3,kk,k) + else + s1=dip(2,jj,j)*dip(2,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph4=-(s1+s2+s3+s4) +#else + eello6_graph4=-(s2+s3+s4) +#endif + if (.not. calc_grad) return +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + if (imat.eq.1) then + s1=dipderg(2,jj,i)*dip(3,kk,k) + else + s1=dipderg(4,jj,j)*dip(2,kk,l) + endif +#endif + s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +cd write (2,*) 'turn6 derivatives' +#ifdef MOMENT + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif + endif + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderg(2,kk,k) + else + s1=dip(2,jj,j)*dipderg(4,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif + endif +C Derivatives in gamma(j-1) or gamma(l-1) + if (l.eq.j+1 .and. l.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) + else if (j.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then + gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) + endif + endif +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + if (imat.eq.1) then + s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) + else + s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) + endif + else + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) + else + s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) + endif + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), + & auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,itj1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) + else + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,itl1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) + endif + call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (swap) then + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s1+s2+s4) +#else + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s2+s4) +#endif + derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 + else +#ifdef MOMENT + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) +#else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) +#endif + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + else +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (l.eq.j+1) then + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + endif + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello_turn6(i,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), + & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), + & ggg1(3),ggg2(3) + double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), + & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) +C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to +C the respective energy moment and not to the cluster cumulant. + eello_turn6=0.0d0 + j=i+4 + k=i+1 + l=i+3 + iti=itortyp(itype(i)) + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) +cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj +cd write (2,*) 'i',i,' k',k,' j',j,' l',l +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l +cd call checkint_turn6(i,jj,kk,eel_turn6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx_turn(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) +cd eello6_5=0.0d0 +cd write (2,*) 'eello6_5',eello6_5 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) + ss1=scalar2(Ub2(1,i+2),b1(1,itl)) + s1 = (auxmat(1,1)+auxmat(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) + call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) + s2 = scalar2(b1(1,itk),vtemp1(1)) +#ifdef MOMENT + call transpose2(AEA(1,1,2),atemp(1,1)) + call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) + call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) + s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) + s12 = scalar2(Ub2(1,i+2),vtemp3(1)) +#ifdef MOMENT + call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) + call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) + call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) + ss13 = scalar2(b1(1,itk),vtemp4(1)) + s13 = (gtemp(1,1)+gtemp(2,2))*ss13 +#endif +c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 +c s1=0.0d0 +c s2=0.0d0 +c s8=0.0d0 +c s12=0.0d0 +c s13=0.0d0 + eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) + if (calc_grad) then +C Derivatives in gamma(i+2) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 + call transpose2(AEAderg(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 + gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) +C Derivatives in gamma(i+3) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d +#endif + call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) + call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) + s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) +#endif + s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Derivatives in gamma(i+4) + call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +C s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) +#else + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) +#endif +C Derivatives in gamma(i+5) +#ifdef MOMENT + call transpose2(AEAderg(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) + call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call transpose2(AEA(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Cartesian derivatives + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), + & vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))* + & scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), + & auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*(s1d+s2d) +#else + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*s2d +#endif +#ifdef MOMENT + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*(s8d+s12d) +#else + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*s12d +#endif + enddo + enddo + enddo +#ifdef MOMENT + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), + & achuj_tempd(1,1)) + call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d=(gtempd(1,1)+gtempd(2,2))*ss13 + derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), + & vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d + derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d + enddo + enddo +#endif +cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', +cd & 16*eel_turn6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 + ggg1(ll)=eel_turn6*g_contij(ll,1) + ggg2(ll)=eel_turn6*g_contij(ll,2) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + 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) + ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf + & +ekont*derx_turn(ll,2,2) + gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) + gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf + & +ekont*derx_turn(ll,4,2) + gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) + enddo + enddo +1112 continue + do m=i+2,j2 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + endif + eello_turn6=ekont*eel_turn6 +cd write (2,*) 'ekont',ekont +cd write (2,*) 'eel_turn6',ekont*eel_turn6 + return + end +crc------------------------------------------------- + SUBROUTINE MATVEC2(A1,V1,V2) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),V1(2),V2(2) +c DO 1 I=1,2 +c VI=0.0 +c DO 3 K=1,2 +c 3 VI=VI+A1(I,K)*V1(K) +c Vaux(I)=VI +c 1 CONTINUE + + vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) + vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) + + v2(1)=vaux1 + v2(2)=vaux2 + END +C--------------------------------------- + SUBROUTINE MATMAT2(A1,A2,A3) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),A2(2,2),A3(2,2) +c DIMENSION AI3(2,2) +c DO J=1,2 +c A3IJ=0.0 +c DO K=1,2 +c A3IJ=A3IJ+A1(I,K)*A2(K,J) +c enddo +c A3(I,J)=A3IJ +c enddo +c enddo + + ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) + ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) + ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) + ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) + + A3(1,1)=AI3_11 + A3(2,1)=AI3_21 + A3(1,2)=AI3_12 + A3(2,2)=AI3_22 + END + +c------------------------------------------------------------------------- + double precision function scalar2(u,v) + implicit none + double precision u(2),v(2) + double precision sc + integer i + scalar2=u(1)*v(1)+u(2)*v(2) + return + end + +C----------------------------------------------------------------------------- + + subroutine transpose2(a,at) + implicit none + double precision a(2,2),at(2,2) + at(1,1)=a(1,1) + at(1,2)=a(2,1) + at(2,1)=a(1,2) + at(2,2)=a(2,2) + return + end +c-------------------------------------------------------------------------- + subroutine transpose(n,a,at) + implicit none + integer n,i,j + double precision a(n,n),at(n,n) + do i=1,n + do j=1,n + at(j,i)=a(i,j) + enddo + enddo + return + end +C--------------------------------------------------------------------------- + subroutine prodmat3(a1,a2,kk,transp,prod) + implicit none + integer i,j + double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) + logical transp +crc double precision auxmat(2,2),prod_(2,2) + + if (transp) then +crc call transpose2(kk(1,1),auxmat(1,1)) +crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) + + else +crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) + + endif +c call transpose2(a2(1,1),a2t(1,1)) + +crc print *,transp +crc print *,((prod_(i,j),i=1,2),j=1,2) +crc print *,((prod(i,j),i=1,2),j=1,2) + + return + end +C----------------------------------------------------------------------------- + double precision function scalar(u,v) + implicit none + double precision u(3),v(3) + double precision sc + integer i + sc=0.0d0 + do i=1,3 + sc=sc+u(i)*v(i) + enddo + scalar=sc + return + end + diff --git a/source/wham/src-HCD/fitsq.f b/source/wham/src-HCD/fitsq.f new file mode 100644 index 0000000..17d92ee --- /dev/null +++ b/source/wham/src-HCD/fitsq.f @@ -0,0 +1,352 @@ + subroutine fitsq(rms,x,y,nn,t,b,non_conv) + implicit real*8 (a-h,o-z) + include 'COMMON.IOUNITS' +c x and y are the vectors of coordinates (dimensioned (3,n)) of the two +c structures to be superimposed. nn is 3*n, where n is the number of +c points. t and b are respectively the translation vector and the +c rotation matrix that transforms the second set of coordinates to the +c frame of the first set. +c eta = machine-specific variable + + dimension x(3*nn),y(3*nn),t(3) + dimension b(3,3),q(3,3),r(3,3),v(3),xav(3),yav(3),e(3),c(3,3) + logical non_conv + eta = z00100000 +c small=25.0*rmdcon(3) +c small=25.0*eta +c small=25.0*10.e-10 +c the following is a very lenient value for 'small' + small = 0.0001D0 + non_conv=.false. + fn=nn + do 10 i=1,3 + xav(i)=0.0D0 + yav(i)=0.0D0 + do 10 j=1,3 + 10 b(j,i)=0.0D0 + nc=0 +c + do 30 n=1,nn + do 20 i=1,3 +crc write(iout,*)'x = ',x(nc+i),' y = ',y(nc+i) + xav(i)=xav(i)+x(nc+i)/fn + 20 yav(i)=yav(i)+y(nc+i)/fn + 30 nc=nc+3 +c + do i=1,3 + t(i)=yav(i)-xav(i) + enddo + + rms=0.0d0 + do n=1,nn + do i=1,3 + rms=rms+(y(3*(n-1)+i)-x(3*(n-1)+i)-t(i))**2 + enddo + enddo + rms=dabs(rms/fn) + +c write(iout,*)'xav = ',(xav(j),j=1,3) +c write(iout,*)'yav = ',(yav(j),j=1,3) +c write(iout,*)'t = ',(t(j),j=1,3) +c write(iout,*)'rms=',rms + if (rms.lt.small) return + + + nc=0 + rms=0.0D0 + do 50 n=1,nn + do 40 i=1,3 + rms=rms+((x(nc+i)-xav(i))**2+(y(nc+i)-yav(i))**2)/fn + do 40 j=1,3 + b(j,i)=b(j,i)+(x(nc+i)-xav(i))*(y(nc+j)-yav(j))/fn + 40 c(j,i)=b(j,i) + 50 nc=nc+3 + call sivade(b,q,r,d,non_conv) + sn3=dsign(1.0d0,d) + do 120 i=1,3 + do 120 j=1,3 + 120 b(j,i)=-q(j,1)*r(i,1)-q(j,2)*r(i,2)-sn3*q(j,3)*r(i,3) + call mvvad(b,xav,yav,t) + do 130 i=1,3 + do 130 j=1,3 + rms=rms+2.0*c(j,i)*b(j,i) + 130 b(j,i)=-b(j,i) + if (dabs(rms).gt.small) go to 140 +* write (6,301) + return + 140 if (rms.gt.0.0d0) go to 150 +c write (iout,303) rms + rms=0.0d0 +* stop +c 150 write (iout,302) dsqrt(rms) + 150 continue + return + 301 format (5x,'rms deviation negligible') + 302 format (5x,'rms deviation ',f14.6) + 303 format (//,5x,'negative ms deviation - ',f14.6) + end + subroutine sivade(x,q,r,dt,non_conv) + implicit real*8(a-h,o-z) +c computes q,e and r such that q(t)xr = diag(e) + dimension x(3,3),q(3,3),r(3,3),e(3) + dimension h(3,3),p(3,3),u(3,3),d(3) + logical non_conv + eta = z00100000 + nit = 0 + small=25.0*10.e-10 +c small=25.0*eta +c small=2.0*rmdcon(3) + xnrm=0.0d0 + do 20 i=1,3 + do 10 j=1,3 + xnrm=xnrm+x(j,i)*x(j,i) + u(j,i)=0.0d0 + r(j,i)=0.0d0 + 10 h(j,i)=0.0d0 + u(i,i)=1.0 + 20 r(i,i)=1.0 + xnrm=dsqrt(xnrm) + do 110 n=1,2 + xmax=0.0d0 + do 30 j=n,3 + 30 if (dabs(x(j,n)).gt.xmax) xmax=dabs(x(j,n)) + a=0.0d0 + do 40 j=n,3 + h(j,n)=x(j,n)/xmax + 40 a=a+h(j,n)*h(j,n) + a=dsqrt(a) + den=a*(a+dabs(h(n,n))) + d(n)=1.0/den + h(n,n)=h(n,n)+dsign(a,h(n,n)) + do 70 i=n,3 + s=0.0d0 + do 50 j=n,3 + 50 s=s+h(j,n)*x(j,i) + s=d(n)*s + do 60 j=n,3 + 60 x(j,i)=x(j,i)-s*h(j,n) + 70 continue + if (n.gt.1) go to 110 + xmax=dmax1(dabs(x(1,2)),dabs(x(1,3))) + h(2,3)=x(1,2)/xmax + h(3,3)=x(1,3)/xmax + a=dsqrt(h(2,3)*h(2,3)+h(3,3)*h(3,3)) + den=a*(a+dabs(h(2,3))) + d(3)=1.0/den + h(2,3)=h(2,3)+sign(a,h(2,3)) + do 100 i=1,3 + s=0.0d0 + do 80 j=2,3 + 80 s=s+h(j,3)*x(i,j) + s=d(3)*s + do 90 j=2,3 + 90 x(i,j)=x(i,j)-s*h(j,3) + 100 continue + 110 continue + do 130 i=1,3 + do 120 j=1,3 + 120 p(j,i)=-d(1)*h(j,1)*h(i,1) + 130 p(i,i)=1.0+p(i,i) + do 140 i=2,3 + do 140 j=2,3 + u(j,i)=u(j,i)-d(2)*h(j,2)*h(i,2) + 140 r(j,i)=r(j,i)-d(3)*h(j,3)*h(i,3) + call mmmul(p,u,q) + 150 np=1 + nq=1 + nit=nit+1 + 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 + if (np.gt.npq) go to 230 + n0=0 + do 220 n=np,npq + nn=n+np-1 + 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 + 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 + 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 + 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 + 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 + 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 (1,501) (e(i),i=1,3) + return + 501 format (/,5x,'singular values - ',3e15.5) + end + subroutine givns(a,b,m,n) + implicit real*8 (a-h,o-z) + dimension a(3,3),b(3,3) + if (dabs(a(m,n)).lt.dabs(a(n,n))) go to 10 + t=a(n,n)/a(m,n) + s=1.0/dsqrt(1.0+t*t) + c=s*t + go to 20 + 10 t=a(m,n)/a(n,n) + c=1.0/dsqrt(1.0+t*t) + s=c*t + 20 do 30 j=1,3 + v=a(m,j) + w=a(n,j) + x=b(j,m) + y=b(j,n) + a(m,j)=c*v-s*w + a(n,j)=s*v+c*w + b(j,m)=c*x-s*y + 30 b(j,n)=s*x+c*y + return + end + subroutine switch(n,m,u,v,d) + implicit real*8 (a-h,o-z) + dimension u(3,3),v(3,3),d(3) + do 10 i=1,3 + tem=u(i,n) + u(i,n)=u(i,n-1) + u(i,n-1)=tem + if (m.eq.0) go to 10 + tem=v(i,n) + v(i,n)=v(i,n-1) + v(i,n-1)=tem + 10 continue + tem=d(n) + d(n)=d(n-1) + d(n-1)=tem + return + end + subroutine mvvad(b,xav,yav,t) + implicit real*8 (a-h,o-z) + dimension b(3,3),xav(3),yav(3),t(3) +c dimension a(3,3),b(3),c(3),d(3) +c do 10 j=1,3 +c d(j)=c(j) +c do 10 i=1,3 +c 10 d(j)=d(j)+a(j,i)*b(i) + do 10 j=1,3 + t(j)=yav(j) + do 10 i=1,3 + 10 t(j)=t(j)+b(j,i)*xav(i) + return + end + double precision function det (a,b,c) + implicit real*8 (a-h,o-z) + dimension a(3),b(3),c(3) + det=a(1)*(b(2)*c(3)-b(3)*c(2))+a(2)*(b(3)*c(1)-b(1)*c(3)) + 1 +a(3)*(b(1)*c(2)-b(2)*c(1)) + return + end + subroutine mmmul(a,b,c) + implicit real*8 (a-h,o-z) + dimension a(3,3),b(3,3),c(3,3) + do 10 i=1,3 + do 10 j=1,3 + c(i,j)=0.0d0 + do 10 k=1,3 + 10 c(i,j)=c(i,j)+a(i,k)*b(k,j) + return + end + subroutine matvec(uvec,tmat,pvec,nback) + implicit real*8 (a-h,o-z) + real*8 tmat(3,3),uvec(3,nback), pvec(3,nback) +c + do 2 j=1,nback + do 1 i=1,3 + uvec(i,j) = 0.0d0 + do 1 k=1,3 + 1 uvec(i,j)=uvec(i,j)+tmat(i,k)*pvec(k,j) + 2 continue + return + end diff --git a/source/wham/src-HCD/geomout.F b/source/wham/src-HCD/geomout.F new file mode 100644 index 0000000..097040f --- /dev/null +++ b/source/wham/src-HCD/geomout.F @@ -0,0 +1,198 @@ + subroutine pdbout(ii,temp,efree,etot,entropy,rmsdev) + 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*50 tytul + character*1 chainid(10) /'A','B','C','D','E','F','G','H','I','J'/ + dimension ica(maxres) + 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 + if (dyn_ss) then + write (iunit,30) ica(idssb(i))+1,ica(jdssb(i))+1 + else + write (ipdb,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 + endif + 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 +c------------------------------------------------------------------------------ + subroutine MOL2out(etot,tytul) +C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2 +C format. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.HEADER' + include 'COMMON.SBRIDGE' + character*32 tytul,fd + character*3 liczba + character*6 res_num,pom,ucase +#ifdef AIX + call fdate_(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 (liczba,*) i + pom=ucase(restyp(itype(i))) + res_num = pom(:3)//liczba(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 +C write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 + if (dyn_ss) then + write(imol2,'(a6,i4,1x,a3,i7,4x,a3,i7)') + & 'SSBOND',i,'CYS',ihpb(i)-1-nres, + & 'CYS',jhpb(i)-1-nres +C & 'SSBOND',i,'CYS',idssb(i)-nnt+1, +C & 'CYS',jdssb(i)-nnt+1 + else + write(imol2,'(a6,i4,1x,a3,i7,4x,a3,i7)') + & 'SSBOND',i,'CYS',ihpb(i)-nnt+1-nres, + & 'CYS',jhpb(i)-nnt+1-nres + endif + enddo + write (imol2,'(a)') '\@SUBSTRUCTURE' + do i=nnt,nct + write (liczba,*) i + pom = ucase(restyp(itype(i))) + res_num = pom(:3)//liczba(2:) + write (imol2,30) i-nnt+1,res_num,i-nnt+1,0 + enddo + 10 FORMAT (I7,' CA ',3F10.4,' C.3',I8,1X,A,F11.4,' ****') + 30 FORMAT (I7,1x,A,I14,' RESIDUE',I13,' **** ****') + return + end +c------------------------------------------------------------------------ + subroutine intout + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + write (iout,'(/a)') 'Geometry of the virtual chain.' + write (iout,'(7a)') ' Res ',' Dpep',' Theta', + & ' Phi',' Dsc',' Alpha',' Omega' + do i=1,nres + iti=itype(i) + write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i+1), + & rad2deg*theta(i), + & rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i),rad2deg*omeg(i) + enddo + return + end +c--------------------------------------------------------------------------- + subroutine briefout(it,ener) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + 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 +#if defined(AIX) || defined(PGI) + open (igeom,file=intname,position='append') +#else + open (igeom,file=intname,access='append') +#endif + iii=igeom + igeom=iout + IF (NSS.LE.9) THEN + WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS) + ELSE + WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9) + WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS) + ENDIF +c IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) + WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) + WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES) +c if (nvar.gt.nphi+ntheta) then + write (igeom,200) (rad2deg*alph(i),i=2,nres-1) + write (igeom,200) (rad2deg*omeg(i),i=2,nres-1) +c endif + close(igeom) + 180 format (I5,F12.3,I2,9(1X,2I3)) + 190 format (3X,11(1X,2I3)) + 200 format (8F10.4) + return + end diff --git a/source/wham/src-HCD/gnmr1.f b/source/wham/src-HCD/gnmr1.f new file mode 100644 index 0000000..8bfc43a --- /dev/null +++ b/source/wham/src-HCD/gnmr1.f @@ -0,0 +1,73 @@ + double precision function gnmr1(y,ymin,ymax) + implicit none + double precision y,ymin,ymax + double precision wykl /4.0d0/ + if (y.lt.ymin) then + gnmr1=(ymin-y)**wykl/wykl + else if (y.gt.ymax) then + gnmr1=(y-ymax)**wykl/wykl + else + gnmr1=0.0d0 + endif + return + end +c------------------------------------------------------------------------------ + double precision function gnmr1prim(y,ymin,ymax) + implicit none + double precision y,ymin,ymax + double precision wykl /4.0d0/ + if (y.lt.ymin) then + gnmr1prim=-(ymin-y)**(wykl-1) + else if (y.gt.ymax) then + gnmr1prim=(y-ymax)**(wykl-1) + else + gnmr1prim=0.0d0 + endif + return + end +c------------------------------------------------------------------------------ + double precision function harmonic(y,ymax) + implicit none + double precision y,ymax + double precision wykl /2.0d0/ + harmonic=(y-ymax)**wykl + return + end +c------------------------------------------------------------------------------- + double precision function harmonicprim(y,ymax) + double precision y,ymin,ymax + double precision wykl /2.0d0/ + harmonicprim=(y-ymax)*wykl + return + end +c--------------------------------------------------------------------------------- + double precision function rlornmr1(y,ymin,ymax,sigma) + implicit none + double precision y,ymin,ymax,sigma + double precision wykl /4.0d0/ + if (y.lt.ymin) then + rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl) + else if (y.gt.ymax) then + rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl) + else + rlornmr1=0.0d0 + endif + return + end +c------------------------------------------------------------------------------ + double precision function rlornmr1prim(y,ymin,ymax,sigma) + implicit none + double precision y,ymin,ymax,sigma + double precision wykl /4.0d0/ + if (y.lt.ymin) then + rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ + & ((ymin-y)**wykl+sigma**wykl)**2 + else if (y.gt.ymax) then + rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ + & ((y-ymax)**wykl+sigma**wykl)**2 + else + rlornmr1prim=0.0d0 + endif + return + end + diff --git a/source/wham/src-HCD/icant.f b/source/wham/src-HCD/icant.f new file mode 100644 index 0000000..8dc1ec1 --- /dev/null +++ b/source/wham/src-HCD/icant.f @@ -0,0 +1,9 @@ + INTEGER FUNCTION ICANT(I,J) + IF (I.GE.J) THEN + ICANT=(I*(I-1))/2+J + ELSE + ICANT=(J*(J-1))/2+I + ENDIF + RETURN + END + diff --git a/source/wham/src-HCD/include_unres/COMMON.CALC b/source/wham/src-HCD/include_unres/COMMON.CALC new file mode 100644 index 0000000..67b4bb9 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.CALC @@ -0,0 +1,15 @@ + integer i,j,k,l + double precision erij,rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, + & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, + & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, + & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, + & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, + & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, + & dsci_inv,dscj_inv,gg + common /calc/ erij(3),rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, + & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, + & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, + & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, + & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, + & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, + & dsci_inv,dscj_inv,gg(3),i,j diff --git a/source/wham/src-HCD/include_unres/COMMON.CONTACTS b/source/wham/src-HCD/include_unres/COMMON.CONTACTS new file mode 100644 index 0000000..871e353 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.CONTACTS @@ -0,0 +1,5 @@ +C Change 12/1/95 - common block CONTACTS1 included. + integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont + double precision facont,gacont + common /contacts/ ncont,ncont_ref,icont(2,maxcont), + & icont_ref(2,maxcont) diff --git a/source/wham/src-HCD/include_unres/COMMON.CONTACTS.safe b/source/wham/src-HCD/include_unres/COMMON.CONTACTS.safe new file mode 100644 index 0000000..4525a07 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.CONTACTS.safe @@ -0,0 +1,71 @@ +C Change 12/1/95 - common block CONTACTS1 included. + integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont + double precision facont,gacont + common /contacts/ ncont,ncont_ref,icont(2,maxcont), + & icont_ref(2,maxcont) + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +C Interactions of pseudo-dipoles generated by loc-el interactions. + double precision dip,dipderg,dipderx + common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), + & dipderx(3,5,4,maxconts,maxres) +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,gmu,gUb2, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der, + & gtEUg + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres), + & gmu(2,maxres),gUb2(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres), + & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres), + & gtEUg(2,2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),DtUg2EUgder(2,2,2,maxres), + & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres),muder(2,maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont diff --git a/source/wham/src-HCD/include_unres/COMMON.CONTMAT b/source/wham/src-HCD/include_unres/COMMON.CONTMAT new file mode 100644 index 0000000..f0b6122 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.CONTMAT @@ -0,0 +1,26 @@ +C Change 12/1/95 - common block CONTACTS1 included. + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + double precision gacontp_hb1,gacontp_hb2,gacontp_hb3,gacont_hbr, + & gacontm_hb1,gacontm_hb2,gacontm_hb3,grij_hb_cont,facont_hb, + & ees0p,ees0m,d_cont + integer num_cont_hb,jcont_hb + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +c 7/25/08 Commented out; not needed when cumulants used +C Interactions of pseudo-dipoles generated by loc-el interactions. +c double precision dip,dipderg,dipderx +c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), +c & dipderx(3,5,4,maxconts,maxres) diff --git a/source/wham/src-HCD/include_unres/COMMON.CONTPAR b/source/wham/src-HCD/include_unres/COMMON.CONTPAR new file mode 100644 index 0000000..97a73eb --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.CONTPAR @@ -0,0 +1,3 @@ + double precision sig_comp,chi_comp,chip_comp,sc_cutoff + common /contpar/ sig_comp(ntyp,ntyp),chi_comp(ntyp,ntyp), + & chip_comp(ntyp,ntyp),sc_cutoff(ntyp,ntyp) diff --git a/source/wham/src-HCD/include_unres/COMMON.CORRMAT b/source/wham/src-HCD/include_unres/COMMON.CORRMAT new file mode 100644 index 0000000..5f154e0 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.CORRMAT @@ -0,0 +1,47 @@ +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,gmu,gUb2, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der, + & gtEug + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres), + & gmu(2,maxres),gUb2(2,maxres), + & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres), + & Dtobr2(2,maxres),Dtobr2der(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),gtEUg(2,2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder,Ug2DtEUg,Ug2DtEUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres), + & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont,EAEA,EAEAderg,EAEAderx, + & ADtEA1,AdTEA1derg,ADtEA1derx + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont diff --git a/source/wham/src-HCD/include_unres/COMMON.DERIV b/source/wham/src-HCD/include_unres/COMMON.DERIV new file mode 100644 index 0000000..b694524 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.DERIV @@ -0,0 +1,69 @@ + double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gelc_long, + & gvdwpp,gel_loc,gel_loc_long,gvdwc_scpp,gliptranc,gliptranx, + & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gloc_x,dtheta,dphi,dalpha, + & domega,gscloc,gsclocx,gradcorr,gradcorr_long,gradcorr5_long, + & gradcorr6_long,gcorr6_turn_long,gvdwx,gshieldx,gradafm, + & gradxorr,gradcorr5,gradcorr6,gcorr3_turn,gcorr4_turn,gcorr6_turn, + & gradb,gradbx,gel_loc_loc,gel_loc_turn3,gel_loc_turn4, + & gel_loc_turn6,gcorr_loc,g_corr5_loc,g_corr6_loc,gsccorc, + & gsccorx,gsccor_loc, + & gg_tube,gg_tube_SC, + & gshieldc, gshieldc_loc, gshieldx_ec, gshieldc_ec, + & gshieldc_loc_ec, gshieldx_t3,gshieldc_t3,gshieldc_loc_t3, + & gshieldx_t4, gshieldc_t4,gshieldc_loc_t4,gshieldx_ll, + & gshieldc_ll, gshieldc_loc_ll,gsaxsC,gsaxsX, + & gdfad,gdfat,gdfan,gdfab + integer nfl,icg + logical calc_grad + common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), + & gradx(3,-1:maxres,2),gradc(3,-1:maxres,2),gvdwx(3,-1:maxres), + & gvdwc(3,-1:maxres),gelc(3,-1:maxres),gelc_long(3,-1:maxres), + & gvdwpp(3,-1:maxres),gvdwc_scpp(3,-1:maxres), + & gliptranc(3,-1:maxres), + & gliptranx(3,-1:maxres), + & gshieldx(3,-1:maxres), gshieldc(3,-1:maxres), + & gshieldc_loc(3,-1:maxres), + & gshieldx_ec(3,-1:maxres), gshieldc_ec(3,-1:maxres), + & gshieldc_loc_ec(3,-1:maxres), + & gshieldx_t3(3,-1:maxres), gshieldc_t3(3,-1:maxres), + & gshieldc_loc_t3(3,-1:maxres), + & gshieldx_t4(3,-1:maxres), gshieldc_t4(3,-1:maxres), + & gshieldc_loc_t4(3,-1:maxres), + & gshieldx_ll(3,-1:maxres), gshieldc_ll(3,-1:maxres), + & gshieldc_loc_ll(3,-1:maxres), + & gradafm(3,-1:maxres),gg_tube(3,-1:maxres), + & gg_tube_sc(3,-1:maxres), + & gradx_scp(3,-1:maxres),gvdwc_scp(3,-1:maxres), + & ghpbx(3,-1:maxres), + & gsaxsC(3,-1:maxres),gsaxsX(3,-1:maxres), + & ghpbc(3,-1:maxres),gloc(maxvar,2),gradcorr(3,-1:maxres), + & gradcorr_long(3,-1:maxres),gradcorr5_long(3,-1:maxres), + & gradcorr6_long(3,-1:maxres),gcorr6_turn_long(3,-1:maxres), + & gradxorr(3,-1:maxres),gradcorr5(3,-1:maxres), + & gradcorr6(3,-1:maxres), + & gloc_x(maxvar,2),gel_loc(3,-1:maxres),gel_loc_long(3,-1:maxres), + & gcorr3_turn(3,-1:maxres), + & gcorr4_turn(3,-1:maxres),gcorr6_turn(3,-1:maxres), + & gradb(3,-1:maxres), + & gradbx(3,-1:maxres),gel_loc_loc(maxvar),gel_loc_turn3(maxvar), + & gel_loc_turn4(maxvar),gel_loc_turn6(maxvar), + & gcorr_loc(maxvar), + & g_corr5_loc(maxvar),g_corr6_loc(maxvar),gsccorc(3,-1:maxres), + & gsccorx(3,-1:maxres),gsccor_loc(-1:maxres), + & dtheta(3,2,-1:maxres), + & gscloc(3,-1:maxres),gsclocx(3,-1:maxres), + & dphi(3,3,-1:maxres),dalpha(3,3,-1:maxres),domega(3,3,-1:maxres), + & gdfad(3,maxres),gdfat(3,maxres),gdfan(3,maxres),gdfab(3,maxres), + & nfl, + & icg,calc_grad + double precision derx,derx_turn + common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2) + double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres), + & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres), + & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres), + & dZZ_XYZtab(3,maxres) + common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab, + & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab + integer igrad_start,igrad_end,jgrad_start(maxres), + & jgrad_end(maxres) + common /mpgrad/ igrad_start,igrad_end,jgrad_start,jgrad_end diff --git a/source/wham/src-HCD/include_unres/COMMON.DERIV_safe b/source/wham/src-HCD/include_unres/COMMON.DERIV_safe new file mode 100644 index 0000000..7f8ddfb --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.DERIV_safe @@ -0,0 +1,48 @@ + double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gvdwpp, + & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gvdwx,gradcorr,gradxorr, + & gliptranc,gliptranx, + & gradcorr5,gradcorr6,gel_loc,gcorr3_turn,gcorr4_turn,gcorr6_turn, + & gel_loc_loc,gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc, + & g_corr5_loc,g_corr6_loc,gradb,gradbx,gsccorc,gsccorx,gsccor_loc, + & gscloc,gsclocx,gshieldx,gradafm, + & gshieldc, gshieldc_loc, gshieldx_ec, gshieldc_ec, + & gshieldc_loc_ec, gshieldx_t3,gshieldc_t3,gshieldc_loc_t3, + & gshieldx_t4, gshieldc_t4,gshieldc_loc_t4,gshieldx_ll, + & gshieldc_ll, gshieldc_loc_ll + + integer nfl,icg + logical calc_grad + common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), + & gradx(3,maxres,2),gradc(3,maxres,2),gvdwx(3,maxres), + & gvdwc(3,maxres),gelc(3,maxres),gvdwpp(3,maxres), + & gradx_scp(3,maxres), + & gliptranc(3,-1:maxres), + & gliptranx(3,-1:maxres), + & gshieldx(3,-1:maxres), gshieldc(3,-1:maxres), + & gshieldc_loc(3,-1:maxres), + & gshieldx_ec(3,-1:maxres), gshieldc_ec(3,-1:maxres), + & gshieldc_loc_ec(3,-1:maxres), + & gshieldx_t3(3,-1:maxres), gshieldc_t3(3,-1:maxres), + & gshieldc_loc_t3(3,-1:maxres), + & gshieldx_t4(3,-1:maxres), gshieldc_t4(3,-1:maxres), + & gshieldc_loc_t4(3,-1:maxres), + & gshieldx_ll(3,-1:maxres), gshieldc_ll(3,-1:maxres), + & gshieldc_loc_ll(3,-1:maxres), + & gvdwc_scp(3,maxres),ghpbx(3,maxres),ghpbc(3,maxres), + & gloc(maxvar,2),gradcorr(3,maxres),gradxorr(3,maxres), + & gradcorr5(3,maxres),gradcorr6(3,maxres), + & gel_loc(3,maxres),gcorr3_turn(3,maxres),gcorr4_turn(3,maxres), + & gcorr6_turn(3,maxres),gradb(3,maxres),gradbx(3,maxres), + & gel_loc_loc(maxvar),gel_loc_turn3(maxvar),gel_loc_turn4(maxvar), + & gel_loc_turn6(maxvar),gcorr_loc(maxvar), + & g_corr5_loc(maxvar),g_corr6_loc(maxvar),gsccorc(3,maxres), + & gsccorx(3,maxres),gsccor_loc(maxres), + & gscloc(3,maxres),gsclocx(3,maxres),nfl,icg,calc_grad + double precision derx,derx_turn + common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2) + double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres), + & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres), + & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres), + & dZZ_XYZtab(3,maxres) + common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab, + & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab diff --git a/source/wham/src-HCD/include_unres/COMMON.FFIELD b/source/wham/src-HCD/include_unres/COMMON.FFIELD new file mode 100644 index 0000000..c54e583 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.FFIELD @@ -0,0 +1,31 @@ +C----------------------------------------------------------------------- +C The following COMMON block selects the type of the force field used in +C calculations and defines weights of various energy terms. +C 12/1/95 wcorr added +C----------------------------------------------------------------------- + double precision wsc,wscp,welec,wstrain,wtor,wtor_d,wang,wscloc, + & wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4, + & wturn6,wvdwpp,wbond,weights,scal14,cutoff_corr,delt_corr, + & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta, + & r0_corr,wliptran,wsaxs + integer ipot,n_ene_comp + common /ffield/ wsc,wscp,welec,wstrain,wtor,wtor_d,wang,wscloc, + & wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4, + & wturn6,wvdwpp,wbond,wliptran,wsaxs, + & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta, + & weights(max_ene), + & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp + common /potentials/ potname(5) + character*3 potname +C----------------------------------------------------------------------- +C wlong,welec,wtor,wang,wscloc are the weight of the energy terms +C corresponding to side-chain, electrostatic, torsional, valence-angle, +C and local side-chain terms. +C +C IPOT determines which SC...SC interaction potential will be used: +C 1 - LJ: 2n-n Lennard-Jones +C 2 - LJK: 2n-n Kihara type (shifted Lennard-Jones) +C 3 - BP; Berne-Pechukas (angular dependence) +C 4 - GB; Gay-Berne (angular dependence) +C 5 - GBV; Gay-Berne-Vorobjev; angularly-dependent Kihara potential +C------------------------------------------------------------------------ diff --git a/source/wham/src-HCD/include_unres/COMMON.FRAG b/source/wham/src-HCD/include_unres/COMMON.FRAG new file mode 100644 index 0000000..ee151f5 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.FRAG @@ -0,0 +1,5 @@ + integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0, + & nh310frag,h310frag + COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3), + & nh310frag,h310frag(2,maxres/2) + COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3) diff --git a/source/wham/src-HCD/include_unres/COMMON.GEO b/source/wham/src-HCD/include_unres/COMMON.GEO new file mode 100644 index 0000000..8cfbbde --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.GEO @@ -0,0 +1,2 @@ + double precision pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin + common /geo/ pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin diff --git a/source/wham/src-HCD/include_unres/COMMON.HEADER b/source/wham/src-HCD/include_unres/COMMON.HEADER new file mode 100644 index 0000000..7154812 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.HEADER @@ -0,0 +1,2 @@ + character*80 titel + common /header/ titel diff --git a/source/wham/src-HCD/include_unres/COMMON.INTERACT b/source/wham/src-HCD/include_unres/COMMON.INTERACT new file mode 100644 index 0000000..7d6b59f --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.INTERACT @@ -0,0 +1,36 @@ + double precision aa_aq,bb_aq,augm,aad,bad,app,bpp,ael6,ael3, + & aa_lip,bb_lip + integer nnt,nct,nint_gr,istart,iend,itype,itel,itypro,ielstart, + & ielend,nscp_gr,iscpstart,iscpend,iatsc_s,iatsc_e,iatel_s, + & iatel_e,iatscp_s,iatscp_e,ispp,iscp,expon,expon2 + common /interact/aa_aq(ntyp,ntyp),bb_aq(ntyp,ntyp), + & augm(ntyp,ntyp),aa_lip(ntyp,ntyp),bb_lip(ntyp,ntyp), + & aad(ntyp,2),bad(ntyp,2),app(2,2),bpp(2,2),ael6(2,2),ael3(2,2), + & expon,expon2,nnt,nct,nint_gr(maxres),istart(maxres,maxint_gr), + & iend(maxres,maxint_gr),itype(maxres),itel(maxres),itypro, + & ielstart(maxres),ielend(maxres),nscp_gr(maxres), + & iscpstart(maxres,maxint_gr),iscpend(maxres,maxint_gr), + & iatsc_s,iatsc_e,iatel_s,iatel_e,iatscp_s,iatscp_e,ispp,iscp +C 12/1/95 Array EPS included in the COMMON block. + double precision eps,sigma,sigmaii,rs0,chi,chip,chip0,alp,signa0, + & sigii,sigma0,rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp, + & eps_orig,epslip + common /body/eps(ntyp,ntyp),sigma(ntyp,ntyp),sigmaii(ntyp,ntyp), + &epslip(ntyp,ntyp), + & rs0(ntyp,ntyp),chi(ntyp,ntyp),chip(ntyp),chip0(ntyp),alp(ntyp), + & sigma0(ntyp),sigii(ntyp),rr0(ntyp),r0(ntyp,ntyp),r0e(ntyp,ntyp), + & r0d(ntyp,2),rpp(2,2),epp(2,2),elpp6(2,2),elpp3(2,2), + & eps_scp(ntyp,2),rscp(ntyp,2),eps_orig(ntyp,ntyp) +c 12/5/03 modified 09/18/03 Bond stretching parameters. + double precision vbldp0,vbldsc0,akp,aksc,abond0,distchainmax + &,vbldpDUM + integer nbondterm + common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp, + & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp), + & distchainmax,nbondterm(ntyp) + &,vbldpDUM +C 01/29/15 Lipidic parameters + double precision pepliptran,liptranene + common /lipid/ pepliptran,liptranene(ntyp) + + diff --git a/source/wham/src-HCD/include_unres/COMMON.LOCAL b/source/wham/src-HCD/include_unres/COMMON.LOCAL new file mode 100644 index 0000000..88a984b --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.LOCAL @@ -0,0 +1,55 @@ + double precision a0thet,athet,bthet,polthet,gthet,theta0,sig0, + & sigc0,dsc,dsc_inv,bsc,censc,gaussc,dsc0 + integer nlob +C Parameters of the virtual-bond-angle probability distribution + common /thetas/ a0thet(-ntyp:ntyp),athet(2,-ntyp:ntyp,-1:1,-1:1), + & bthet(2,-ntyp:ntyp,-1:1,-1:1),polthet(0:3,-ntyp:ntyp), + & gthet(3,-ntyp:ntyp),theta0(-ntyp:ntyp),sig0(-ntyp:ntyp), + & sigc0(-ntyp:ntyp) +C Parameters of the side-chain probability distribution + common /sclocal/ dsc(ntyp1),dsc_inv(ntyp1),bsc(maxlob,ntyp), + & censc(3,maxlob,-ntyp:ntyp),gaussc(3,3,maxlob,-ntyp:ntyp), + &dsc0(ntyp1), + & nlob(ntyp1) +C Parameters of ab initio-derived potential of virtual-bond-angle bending + integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, + & ithetyp(-ntyp1:ntyp1),nntheterm + common /theta_abinitio/ aa0thet(-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & aathet(maxtheterm,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & bbthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ccthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ddthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & eethet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ffthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2), + & ggthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2), + & ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle, + & ndouble,nntheterm + + double precision aa0thet,aathet,bbthet,ccthet,ddthet,eethet, + & ffthet, + & ggthet +C Virtual-bond lenghts + double precision vbl,vblinv,vblinv2,vbl_cis,vbl0,vbld_inv + integer loc_start,loc_end,ithet_start,ithet_end,iphi_start, + & iphi_end,iphid_start,iphid_end,ibond_start,ibond_end, + & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end, + & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start, + & iint_end,iphi1_start,iphi1_end,itau_start,itau_end, + & isaxs_start,isaxs_end + common /peptbond/ vbl,vblinv,vblinv2,vbl_cis,vbl0 + common /indices/ loc_start,loc_end,ithet_start,ithet_end, + & iphi_start,iphi_end,iphid_start,iphid_end,ibond_start,ibond_end, + & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end, + & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start, + & iint_end,iphi1_start,iphi1_end,itau_start,itau_end, + & isaxs_start,isaxs_end +C Inverses of the actual virtual bond lengths + common /invlen/ vbld_inv(maxres2) diff --git a/source/wham/src-HCD/include_unres/COMMON.MINIM b/source/wham/src-HCD/include_unres/COMMON.MINIM new file mode 100644 index 0000000..b231b47 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.MINIM @@ -0,0 +1,3 @@ + double precision tolf,rtolf + integer maxfun,maxmin + common /minimm/ tolf,rtolf,maxfun,maxmin diff --git a/source/wham/src-HCD/include_unres/COMMON.NAMES b/source/wham/src-HCD/include_unres/COMMON.NAMES new file mode 100644 index 0000000..7beefb7 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.NAMES @@ -0,0 +1,8 @@ + character*3 restyp + character*1 onelet + common /names/ restyp(-ntyp1:ntyp1), + & onelet(-ntyp1:ntyp1) + character*10 ename,wname + integer nprint_ene,print_order + common /namterm/ ename(max_ene),wname(max_ene),nprint_ene, + & print_order(max_ene) diff --git a/source/wham/src-HCD/include_unres/COMMON.SBRIDGE b/source/wham/src-HCD/include_unres/COMMON.SBRIDGE new file mode 100644 index 0000000..7facbfe --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.SBRIDGE @@ -0,0 +1,29 @@ + double precision ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss + integer ns,nss,nfree,iss + common /sbridge/ ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss, + & ns,nss,nfree,iss(maxss) + double precision dhpb,dhpb1,forcon,fordepth,xlscore,wboltzd, + & dhpb_peak,dhpb1_peak,forcon_peak,fordepth_peak,scal_peak,bfac + integer ihpb,jhpb,nhpb,idssb,jdssb,ibecarb,ibecarb_peak,npeak, + & ipeak,irestr_type,irestr_type_peak,ihpb_peak,jhpb_peak,nhpb_peak + logical restr_on_coord + common /links/ dhpb(maxdim),dhpb1(maxdim),forcon(maxdim), + & fordepth(maxdim),bfac(maxres),xlscore(maxdim),wboltzd, + & ihpb(maxdim),jhpb(maxdim),ibecarb(maxdim),irestr_type(maxdim), + & nhpb,restr_on_coord + common /NMRpeaks/ dhpb_peak(maxdim),dhpb1_peak(maxdim), + & forcon_peak(maxdim),fordepth_peak(maxdim),scal_peak, + & ihpb_peak(maxdim),jhpb_peak(maxdim),ibecarb_peak(maxdim), + & irestr_type_peak(maxdim),ipeak(2,maxdim),npeak,nhpb_peak + double precision weidis + common /restraints/ weidis + integer link_start,link_end,link_start_peak,link_end_peak + common /links_split/ link_start,link_end,link_start_peak, + & link_end_peak + double precision Ht,dyn_ssbond_ij,dtriss,atriss,btriss,ctriss + logical dyn_ss,dyn_ss_mask + common /dyn_ssbond/ dtriss,atriss,btriss,ctriss,Ht, + & dyn_ssbond_ij(maxres,maxres), + & idssb(maxdim),jdssb(maxdim) + common /dyn_ss_logic/ + & dyn_ss,dyn_ss_mask(maxres) diff --git a/source/wham/src-HCD/include_unres/COMMON.SCCOR b/source/wham/src-HCD/include_unres/COMMON.SCCOR new file mode 100644 index 0000000..33a865d --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.SCCOR @@ -0,0 +1,20 @@ +cc Parameters of the SCCOR term + double precision v1sccor,v2sccor,vlor1sccor, + & vlor2sccor,vlor3sccor,gloc_sc, + & dcostau,dsintau,dtauangle,dcosomicron, + & domicron,v0sccor + integer nterm_sccor,isccortyp,nsccortyp,nlor_sccor + common /sccor/ v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp), + & v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp), + & v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp), + & vlor1sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp), + & vlor2sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp), + & vlor3sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp), + & gloc_sc(3,0:maxres2,10), + & dcostau(3,3,3,maxres2),dsintau(3,3,3,maxres2), + & dtauangle(3,3,3,maxres2),dcosomicron(3,3,3,maxres2), + & domicron(3,3,3,maxres2), + & nterm_sccor(-ntyp:ntyp,-ntyp:ntyp),isccortyp(-ntyp:ntyp), + & nsccortyp, + & nlor_sccor(-ntyp:ntyp,-ntyp:ntyp) + diff --git a/source/wham/src-HCD/include_unres/COMMON.SCROT b/source/wham/src-HCD/include_unres/COMMON.SCROT new file mode 100644 index 0000000..a352775 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.SCROT @@ -0,0 +1,3 @@ +C Parameters of the SC rotamers (local) term + double precision sc_parmin + common/scrot/sc_parmin(maxsccoef,ntyp) diff --git a/source/wham/src-HCD/include_unres/COMMON.SETUP b/source/wham/src-HCD/include_unres/COMMON.SETUP new file mode 100644 index 0000000..5039116 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.SETUP @@ -0,0 +1,21 @@ + integer king,idint,idreal,idchar,is_done + parameter (king=0,idint=1105,idreal=1729,idchar=1597,is_done=1) + integer me,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,nfgtasks,kolor, + & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1),CG_COMM,FG_COMM, + & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp(0:maxprocs-1), + & kolor1,key1,nfgtasks1,MyRank, + & max_gs_size + logical yourjob, finished, cgdone + common/setup/me,MyRank,cg_rank,fg_rank,fg_rank1,nodes,Nprocs, + & nfgtasks,nfgtasks1, + & max_gs_size,kolor,koniec,WhatsUp,ifinish,CG_COMM,FG_COMM, + & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp + integer MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, + & MPI_THET,MPI_GAM, + & MPI_ROTAT1(0:1),MPI_ROTAT2(0:1),MPI_ROTAT_OLD(0:1), + & MPI_PRECOMP11(0:1),MPI_PRECOMP12(0:1),MPI_PRECOMP22(0:1), + & MPI_PRECOMP23(0:1) + common /types/ MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, + & MPI_THET,MPI_GAM, + & MPI_ROTAT1,MPI_ROTAT2,MPI_ROTAT_OLD,MPI_PRECOMP11,MPI_PRECOMP12, + & MPI_PRECOMP22,MPI_PRECOMP23 diff --git a/source/wham/src-HCD/include_unres/COMMON.TIME1 b/source/wham/src-HCD/include_unres/COMMON.TIME1 new file mode 100644 index 0000000..f7f4849 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.TIME1 @@ -0,0 +1,13 @@ + DOUBLE PRECISION BATIME,TIMLIM,STIME,PREVTIM,SAFETY,RSTIME + INTEGER WhatsUp,ndelta + logical cutoffviol,cutoffeval,llocal + COMMON/TIME1/STIME,TIMLIM,BATIME,PREVTIM,SAFETY,RSTIME + COMMON/STOPTIM/WhatsUp,ndelta,cutoffviol,cutoffeval,llocal + double precision 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 + common /timing/ t_func,t_grad,t_fhel,t_fbet,t_ghel,t_gbet,t_viol, + & t_gviol,t_map,t_alamap,t_betamap, + & n_func,n_grad,n_fhel,n_fbet,n_ghel,n_gbet,n_viol,n_gviol, + & n_map,n_alamap,n_betamap diff --git a/source/wham/src-HCD/include_unres/COMMON.TORCNSTR b/source/wham/src-HCD/include_unres/COMMON.TORCNSTR new file mode 100644 index 0000000..8958b81 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.TORCNSTR @@ -0,0 +1,17 @@ + integer ndih_constr,idih_constr(maxdih_constr),ntheta_constr, + & itheta_constr(maxdih_constr) + integer ndih_nconstr,idih_nconstr(maxdih_constr) + integer idihconstr_start,idihconstr_end,ithetaconstr_start, + & ithetaconstr_end + logical raw_psipred + double precision phi0(maxdih_constr),drange(maxdih_constr), + & ftors(maxdih_constr),theta_constr0(maxdih_constr), + & theta_drange(maxdih_constr),for_thet_constr(maxdih_constr), + & vpsipred(3,maxdih_constr),sdihed(2,maxdih_constr), + & phibound(2,maxres),wdihc + common /torcnstr/ phi0,drange,ftors,theta_constr0,theta_drange, + & for_thet_constr,vpsipred,sdihed,phibound,wdihc, + & ndih_constr,idih_constr, + & ndih_nconstr,idih_nconstr,idihconstr_start,idihconstr_end, + & ntheta_constr,itheta_constr,ithetaconstr_start, + & ithetaconstr_end,raw_psipred diff --git a/source/wham/src-HCD/include_unres/COMMON.TORSION b/source/wham/src-HCD/include_unres/COMMON.TORSION new file mode 100644 index 0000000..cd576c8 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.TORSION @@ -0,0 +1,60 @@ +C Torsional constants of the rotation about virtual-bond dihedral angles + double precision v1,v2,vlor1,vlor2,vlor3,v0,v1_kcc,v2_kcc, + & v11_chyb,v21_chyb,v12_chyb,v22_chyb,v1bend_chyb + integer itortyp,ntortyp,nterm,nlor,nterm_old,nterm_kcc_Tb, + & nterm_kcc,itortyp_kcc,nbend_kcc_Tb + common/torsion/v0(-maxtor:maxtor,-maxtor:maxtor,2), + & v1(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & v2(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & vlor1(maxlor,-maxtor:maxtor,-maxtor:maxtor), + & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor), + & v1_kcc(maxval_kcc,maxval_kcc,maxtor_kcc, + & -maxtor:maxtor,-maxtor:maxtor), + & v2_kcc(maxval_kcc,maxval_kcc,maxtor_kcc, + & -maxtor:maxtor,-maxtor:maxtor), + & v1bend_chyb(0:maxang_kcc,-maxtor:maxtor), + & itortyp(-ntyp1:ntyp1),ntortyp, + & itortyp_kcc(-ntyp1:ntyp1), + & nterm(-maxtor:maxtor,-maxtor:maxtor,2), + & nlor(-maxtor:maxtor,-maxtor:maxtor,2), + & nterm_kcc_Tb(-maxtor:maxtor,-maxtor:maxtor), + & nterm_kcc(-maxtor:maxtor,-maxtor:maxtor), + & nbend_kcc_Tb(-maxtor:maxtor), + & nterm_old +C 6/23/01 - constants for double torsionals + double precision v1c,v1s,v2c,v2s + integer ntermd_1,ntermd_2 + common /torsiond/ + &v1c(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v1s(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v2c(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + &v2s(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + & ntermd_1(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + & ntermd_2(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) +C 9/18/99 - added Fourier coeffficients of the expansion of local energy +C surface + double precision b1,b2,cc,dd,ee,ctilde,dtilde,b2tilde,b1tilde, + & b,bnew1,bnew2,ccold,ddold,ccnew,ddnew,eenew,e0new,gtb1,gtb2, + & eeold,gtcc,gtdd,gtee, + & bnew1tor,bnew2tor,ccnewtor,ddnewtor,eenewtor,e0newtor + integer nloctyp,iloctyp(-ntyp1:ntyp1),itype2loc(-ntyp1:ntyp1) + logical SPLIT_FOURIERTOR + common/fourier/ b1(2,maxres),b2(2,maxres),b(13,-ntyp:ntyp), + & bnew1(3,2,-ntyp:ntyp),bnew2(3,2,-ntyp:ntyp), + & ccnew(3,2,-ntyp:ntyp),ddnew(3,2,-ntyp:ntyp), + & bnew1tor(3,2,-ntyp:ntyp),bnew2tor(3,2,-ntyp:ntyp), + & ccnewtor(3,2,-ntyp:ntyp),ddnewtor(3,2,-ntyp:ntyp), + & ccold(2,2,-ntyp:ntyp),ddold(2,2,-ntyp:ntyp), + & cc(2,2,maxres), + & dd(2,2,maxres),eeold(2,2,-ntyp:ntyp), + & e0new(3,-ntyp:ntyp),eenew(2,2,2,-ntyp:ntyp), + & e0newtor(3,-ntyp:ntyp),eenewtor(2,2,2,-ntyp:ntyp), + & ee(2,2,maxres), + & ctilde(2,2,maxres), + & dtilde(2,2,maxres),b1tilde(2,maxres), + & b2tilde(2,maxres), + & gtb1(2,maxres),gtb2(2,maxres),gtCC(2,2,maxres), + & gtDD(2,2,maxres),gtEE(2,2,maxres), + & nloctyp,iloctyp,itype2loc,SPLIT_FOURIERTOR diff --git a/source/wham/src-HCD/include_unres/COMMON.TORSION.safe b/source/wham/src-HCD/include_unres/COMMON.TORSION.safe new file mode 100644 index 0000000..c30896d --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.TORSION.safe @@ -0,0 +1,55 @@ +C Torsional constants of the rotation about virtual-bond dihedral angles + double precision v1,v2,vlor1,vlor2,vlor3,v0,v1_kcc,v2_kcc, + & v11_chyb,v21_chyb,v12_chyb,v22_chyb,v1bend_chyb + integer itortyp,ntortyp,nterm,nlor,nterm_old,nterm_kcc_Tb, + & nterm_kcc,itortyp_kcc,nbend_kcc_Tb + common/torsion/v0(-maxtor:maxtor,-maxtor:maxtor,2), + & v1(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & v2(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & vlor1(maxlor,-maxtor:maxtor,-maxtor:maxtor), + & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor), + & v1_kcc(maxval_kcc,maxval_kcc,maxtor_kcc, + & -maxtor:maxtor,-maxtor:maxtor), + & v2_kcc(maxval_kcc,maxval_kcc,maxtor_kcc, + & -maxtor:maxtor,-maxtor:maxtor), + & v1bend_chyb(0:maxang_kcc,-maxtor:maxtor), + & itortyp(-ntyp1:ntyp1),ntortyp, + & itortyp_kcc(-ntyp1:ntyp1), + & nterm(-maxtor:maxtor,-maxtor:maxtor,2), + & nlor(-maxtor:maxtor,-maxtor:maxtor,2), + & nterm_kcc_Tb(-maxtor:maxtor,-maxtor:maxtor), + & nterm_kcc(-maxtor:maxtor,-maxtor:maxtor), + & nbend_kcc_Tb(-maxtor:maxtor), + & nterm_old +C 6/23/01 - constants for double torsionals + double precision v1c,v1s,v2c,v2s + integer ntermd_1,ntermd_2 + common /torsiond/ + &v1c(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v1s(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v2c(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + &v2s(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + & ntermd_1(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + & ntermd_2(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) +C 9/18/99 - added Fourier coeffficients of the expansion of local energy +C surface + double precision b1,b2,cc,dd,ee,ctilde,dtilde,b2tilde,b1tilde, + & b,bnew1,bnew2,ccold,ddold,ccnew,ddnew,eenew,e0new,gtb1,gtb2, + & eeold,gtcc,gtdd,gtee + integer nloctyp,iloctyp(-ntyp1:ntyp1),itype2loc(-ntyp1:ntyp1) + common/fourier/ b1(2,maxres),b2(2,maxres),b(13,-ntyp:ntyp), + & bnew1(3,2,-ntyp:ntyp),bnew2(3,2,-ntyp:ntyp), + & ccnew(3,2,-ntyp:ntyp),ddnew(3,2,-ntyp:ntyp), + & ccold(2,2,-ntyp:ntyp),ddold(2,2,-ntyp:ntyp), + & cc(2,2,maxres), + & dd(2,2,maxres),eeold(2,2,-ntyp:ntyp), + & e0new(3,-ntyp:ntyp),eenew(2,2,2,-ntyp:ntyp), + & ee(2,2,maxres), + & ctilde(2,2,maxres), + & dtilde(2,2,maxres),b1tilde(2,maxres), + & b2tilde(2,maxres), + & gtb1(2,maxres),gtb2(2,maxres),gtCC(2,2,maxres), + & gtDD(2,2,maxres),gtEE(2,2,maxres), + & nloctyp,iloctyp,itype2loc diff --git a/source/wham/src-HCD/include_unres/COMMON.TOTSION_safe b/source/wham/src-HCD/include_unres/COMMON.TOTSION_safe new file mode 100644 index 0000000..71b0f1f --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.TOTSION_safe @@ -0,0 +1,35 @@ +C Torsional constants of the rotation about virtual-bond dihedral angles + double precision v1,v2,vlor1,vlor2,vlor3,v0 + integer itortyp,ntortyp,nterm,nlor,nterm_old + common/torsion/v0(-maxtor:maxtor,-maxtor:maxtor,2), + & v1(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & v2(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & vlor1(maxlor,-maxtor:maxtor,-maxtor:maxtor), + & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor), + & itortyp(-ntyp:ntyp),ntortyp, + & nterm(-maxtor:maxtor,-maxtor:maxtor,2), + & nlor(-maxtor:maxtor,-maxtor:maxtor,2) + & ,nterm_old +C 6/23/01 - constants for double torsionals + double precision v1c,v1s,v2c,v2s + integer ntermd_1,ntermd_2 + common /torsiond/ + &v1c(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v1s(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v2c(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + &v2s(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + & ntermd_1(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + & ntermd_2(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) +C 9/18/99 - added Fourier coeffficients of the expansion of local energy +C surface + double precision b1,b2,cc,dd,ee,ctilde,dtilde,b2tilde,b1tilde + integer nloctyp + common/fourier/ b1(2,-maxtor:maxtor),b2(2,-maxtor:maxtor) + & ,cc(2,2,-maxtor:maxtor), + & dd(2,2,-maxtor:maxtor),ee(2,2,-maxtor:maxtor), + & ctilde(2,2,-maxtor:maxtor), + & dtilde(2,2,-maxtor:maxtor),b1tilde(2,-maxtor:maxtor),nloctyp + double precision b + common /fourier1/ b(13,0:maxtor) diff --git a/source/wham/src-HCD/include_unres/COMMON.VECTORS b/source/wham/src-HCD/include_unres/COMMON.VECTORS new file mode 100644 index 0000000..d880c24 --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.VECTORS @@ -0,0 +1,3 @@ + common /vectors/ uy(3,maxres),uz(3,maxres), + & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres) + diff --git a/source/wham/src-HCD/include_unres/COMMON.WEIGHTS b/source/wham/src-HCD/include_unres/COMMON.WEIGHTS new file mode 100644 index 0000000..86f8d7a --- /dev/null +++ b/source/wham/src-HCD/include_unres/COMMON.WEIGHTS @@ -0,0 +1,22 @@ + double precision ww,ww0,ww_low,ww_up,ww_orig,x_orig, + & epp_low,epp_up,rpp_low,rpp_up,elpp6_low,elpp6_up,elpp3_low, + & elpp3_up,b_low,b_up,epscp_low,epscp_up,rscp_low,rscp_up, + & x_up,x_low,xm,xm1,xm2,epss_low,epss_up,epsp_low,epsp_up + integer imask,mask_elec,mask_fourier,mod_fourier,mask_scp,indz,iw, + & nsingle_sc,npair_sc,ityp_ssc,ityp_psc + logical mod_other_params,mod_elec,mod_scp,mod_side + common /chujec/ ww(max_ene),ww0(max_ene),ww_low(max_ene), + & ww_up(max_ene),ww_orig(max_ene),x_orig(max_paropt), + & epp_low(2,2),epp_up(2,2),rpp_low(2,2),rpp_up(2,2), + & elpp6_low(2,2),elpp6_up(2,2),elpp3_low(2,2),elpp3_up(2,2), + & b_low(13,3),b_up(13,3),x_up(max_paropt),x_low(max_paropt), + & epscp_low(0:ntyp,2),epscp_up(0:ntyp,2),rscp_low(0:ntyp,2), + & rscp_up(0:ntyp,2),epss_low(ntyp),epss_up(ntyp),epsp_low(nntyp), + & epsp_up(nntyp), + & xm(max_paropt,0:maxprot),xm1(max_paropt,0:maxprot), + & xm2(max_paropt,0:maxprot), + & imask(max_ene),nsingle_sc,npair_sc,ityp_ssc(ntyp), + & ityp_psc(2,nntyp),mask_elec(2,2,4), + & mask_fourier(13,3), + & mask_scp(0:ntyp,2,2),mod_other_params,mod_fourier(0:3), + & mod_elec,mod_scp,mod_side,indz(maxbatch+1,maxprot),iw(max_ene) diff --git a/source/wham/src-HCD/initialize_p.F b/source/wham/src-HCD/initialize_p.F new file mode 100644 index 0000000..baf3aa2 --- /dev/null +++ b/source/wham/src-HCD/initialize_p.F @@ -0,0 +1,602 @@ + subroutine initialize +C +C Define constants and zero out tables. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.MINIM' + include 'COMMON.DERIV' + include "COMMON.WEIGHTS" + include "COMMON.NAMES" + include "COMMON.TIME1" + include "COMMON.TORCNSTR" +C +C The following is just to define auxiliary variables used in angle conversion +C + pi=4.0D0*datan(1.0D0) + dwapi=2.0D0*pi + dwapi3=dwapi/3.0D0 + pipol=0.5D0*pi + deg2rad=pi/180.0D0 + rad2deg=1.0D0/deg2rad + angmin=10.0D0*deg2rad +C +C Define I/O units. +C + inp= 1 + iout= 2 + ipdbin= 3 + ipdb= 7 + imol2= 4 + igeom= 8 + intin= 9 + ithep= 11 + irotam=12 + itorp= 13 + itordp= 23 + ielep= 14 + isidep=15 + isidep1=22 + iscpp=25 + icbase=16 + ifourier=20 + istat= 17 + ientin=18 + ientout=19 + ibond=28 + isccor=29 +C +C WHAM files +C + ihist=30 + iweight=31 + izsc=32 +C Lipidic input file for parameters range 60-79 + iliptranpar=60 +C +C Set default weights of the energy terms. +C + wlong=1.0D0 + welec=1.0D0 + wtor =1.0D0 + wang =1.0D0 + wscloc=1.0D0 + wstrain=1.0D0 +C +C Zero out tables. +C + ndih_constr=0 + do i=1,maxres2 + do j=1,3 + c(j,i)=0.0D0 + dc(j,i)=0.0D0 + enddo + enddo + do i=1,maxres + do j=1,3 + xloc(j,i)=0.0D0 + enddo + enddo + do i=1,ntyp + do j=1,ntyp + aa_lip(i,j)=0.0D0 + bb_lip(i,j)=0.0D0 + aa_aq(i,j)=0.0D0 + bb_aq(i,j)=0.0D0 + augm(i,j)=0.0D0 + sigma(i,j)=0.0D0 + r0(i,j)=0.0D0 + chi(i,j)=0.0D0 + enddo + do j=1,2 + bad(i,j)=0.0D0 + enddo + chip(i)=0.0D0 + alp(i)=0.0D0 + sigma0(i)=0.0D0 + sigii(i)=0.0D0 + rr0(i)=0.0D0 + a0thet(i)=0.0D0 + do j=1,2 + do ichir1=-1,1 + do ichir2=-1,1 + athet(j,i,ichir1,ichir2)=0.0D0 + bthet(j,i,ichir1,ichir2)=0.0D0 + enddo + enddo + enddo + do j=0,3 + polthet(j,i)=0.0D0 + enddo + do j=1,3 + gthet(j,i)=0.0D0 + enddo + theta0(i)=0.0D0 + sig0(i)=0.0D0 + sigc0(i)=0.0D0 + do j=1,maxlob + bsc(j,i)=0.0D0 + do k=1,3 + censc(k,j,i)=0.0D0 + enddo + do k=1,3 + do l=1,3 + gaussc(l,k,j,i)=0.0D0 + enddo + enddo + nlob(i)=0 + enddo + enddo + nlob(ntyp1)=0 + dsc(ntyp1)=0.0D0 + do i=-maxtor,maxtor + itortyp(i)=0 + do iblock=1,2 + do j=-maxtor,maxtor + do k=1,maxterm + v1(k,j,i,iblock)=0.0D0 + v2(k,j,i,iblock)=0.0D0 + enddo + enddo + enddo + enddo + do iblock=1,2 + do i=-maxtor,maxtor + do j=-maxtor,maxtor + do k=-maxtor,maxtor + do l=1,maxtermd_1 + v1c(1,l,i,j,k,iblock)=0.0D0 + v1s(1,l,i,j,k,iblock)=0.0D0 + v1c(2,l,i,j,k,iblock)=0.0D0 + v1s(2,l,i,j,k,iblock)=0.0D0 + enddo !l + do l=1,maxtermd_2 + do m=1,maxtermd_2 + v2c(m,l,i,j,k,iblock)=0.0D0 + v2s(m,l,i,j,k,iblock)=0.0D0 + enddo !m + enddo !l + enddo !k + enddo !j + enddo !i + enddo !iblock + do i=1,maxres + itype(i)=0 + itel(i)=0 + enddo +C Initialize the bridge arrays + ns=0 + nss=0 + nhpb=0 + do i=1,maxss + iss(i)=0 + enddo + do i=1,maxdim + dhpb(i)=0.0D0 + enddo + do i=1,maxres + ihpb(i)=0 + jhpb(i)=0 + dyn_ss_mask(i)=.false. + enddo +C +C Initialize timing. +C + call set_timers +C +C Initialize variables used in minimization. +C +c maxfun=5000 +c maxit=2000 + maxfun=500 + maxit=200 + tolf=1.0D-2 + rtolf=5.0D-4 +C +C Initialize the variables responsible for the mode of gradient storage. +C + nfl=0 + icg=1 + do i=1,14 + do j=1,14 + if (print_order(i).eq.j) then + iw(print_order(i))=j + goto 1121 + endif + enddo +1121 continue + enddo + calc_grad=.false. +C Set timers and counters for the respective routines + t_func = 0.0d0 + t_grad = 0.0d0 + t_fhel = 0.0d0 + t_fbet = 0.0d0 + t_ghel = 0.0d0 + t_gbet = 0.0d0 + t_viol = 0.0d0 + t_gviol = 0.0d0 + n_func = 0 + n_grad = 0 + n_fhel = 0 + n_fbet = 0 + n_ghel = 0 + n_gbet = 0 + n_viol = 0 + n_gviol = 0 + n_map = 0 +#ifndef SPLITELE + nprint_ene=nprint_ene-1 +#endif + return + end +c------------------------------------------------------------------------- + block data nazwy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.NAMES' + include 'COMMON.WEIGHTS' + include 'COMMON.FFIELD' + include 'COMMON.SHIELD' + data 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'/ + data 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'/ + data potname /'LJ','LJK','BP','GB','GBV'/ + data ename / + 1 "ESC-SC", + 2 "ESC-p", + 3 "Ep-p(el)", + 4 "ECORR4 ", + 5 "ECORR5 ", + 6 "ECORR6 ", + 7 "ECORR3 ", + 8 "ETURN3 ", + 9 "ETURN4 ", + @ "ETURN6 ", + 1 "Ebend", + 2 "ESCloc", + 3 "ETORS ", + 4 "ETORSD ", + 5 "Edist", + 6 "Epp(VDW)", + 7 "EVDW2_14", + 8 "Ebond", + 9 "ESCcor", + @ "EDIHC", + 1 "EVDW_T", + 2 "ELIPTRAN", + 3 "EAFM", + 4 "ETHETC", + 5 "ESHIELD", + 6 "ESAXS", + 7 "EHOMO", + 8 "EDFADIS", + 9 "EDFATOR", + @ "EDFANEI", + 1 "EDFABET"/ + data wname / +! 1 2 3 4 5 6 7 + & "WSC ","WSCP ","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", +! 8 9 10 11 12 13 14 + & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR ","WTORD", +! 15 16 17 18 19 20 21 + & "WHPB ","WVDWPP","WSCP14","WBOND","WSCCOR","WDIHC","WSC", +! 22 23 24 25 26 27 28 + & "WLIPTRAN","WAFM","WTHETC","WSHIELD","WSAXS","WHOMO","WDFAD", +! 29 30 31 + & "WDFAT","WDFAN","WDFAB"/ + data ww0 / + 1 1.0d0, ! WSC + 2 1.0d0, ! WSCP + 3 1.0d0, ! WELEC + 4 0.0d0, ! WCORR + 5 0.0d0, ! WCORR5 + 6 0.0d0, ! WCORR6 + 7 1.0d0, ! WEL_LOC + 8 1.0d0, ! WTURN3 + 9 1.0d0, ! WTURN4 + @ 0.0d0, ! WTURN6 + 1 1.0d0, ! WANG + 2 1.0d0, ! WSCLOC + 3 1.0d0, ! WTOR + 4 1.0d0, ! WTORD + 5 1.0d0, ! WHPB + 6 1.0d0, ! WVDWPP + 7 0.4d0, ! WSCP14 + 8 1.0d0, ! WBOND + 9 1.0d0, ! WSCCOR + @ 0.0d0, ! WDIHC + 1 0.0d0, ! WSC_T + 2 0.0d0, ! WLIPTRAN + 3 0.0d0, ! WAFM + 4 0.0d0, ! WTHETC + 5 0.0d0, ! WSHIELD + 6 0.0d0, ! WSAXS + 7 0.0d0, ! WHOMO + 8 0.0d0, ! WDFADIS + 9 0.0d0, ! WDFATOR + @ 0.0d0, ! WDFANEI + 1 0.0d0 ! WDFABET + & / +#ifdef DFA +#if defined(SCP14) && defined(SPLITELE) + data nprint_ene /31/ + data print_order/1,2,18,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,28,29,30,31,22,23,25,20/ +#elif defined(SCP14) + data nprint_ene /30/ + data print_order/1,2,18,3,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,28,29,30,31,22,23,25,20,0/ +#elif defined(SPLITELE) + data nprint_ene /30/ + data print_order/1,2,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,28,29,30,31,22,23,25,20,0/ +#else + data nprint_ene /29/ + data print_order/1,2,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,28,29,30,31,22,23,25,20,2*0/ +#endif +#else +#if defined(SCP14) && defined(SPLITELE) + data nprint_ene /27/ + data print_order/1,2,18,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,22,23,25,20,4*0/ +#elif defined(SCP14) + data nprint_ene /26/ + data print_order/1,2,18,3,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,22,23,25,20,5*0/ +#elif defined(SPLITELE) + data nprint_ene /26/ + data print_order/1,2,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,22,23,25,20,5*0/ +#else + data nprint_ene /25/ + data print_order/1,2,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19, + & 24,15,26,27,22,23,25,20,6*0/ +#endif +#endif + end +c--------------------------------------------------------------------------- + subroutine init_int_table + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' +#ifdef MPI + 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' + include "COMMON.TORCNSTR" + logical scheck,lprint + lprint=.false. + do i=1,maxres + nint_gr(i)=0 + nscp_gr(i)=0 + do j=1,maxint_gr + istart(i,1)=0 + iend(i,1)=0 + ielstart(i)=0 + ielend(i)=0 + iscpstart(i,1)=0 + iscpend(i,1)=0 + enddo + enddo + ind_scint=0 + ind_scint_old=0 +cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', +cd & (ihpb(i),jhpb(i),i=1,nss) + do i=nnt,nct-1 + scheck=.false. + if (dyn_ss) goto 10 + do ii=1,nss + if (ihpb(ii).eq.i+nres) then + scheck=.true. + jj=jhpb(ii)-nres + goto 10 + endif + enddo + 10 continue +cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj + if (scheck) then + if (jj.eq.i+1) then + nint_gr(i)=1 + istart(i,1)=i+2 + iend(i,1)=nct + else if (jj.eq.nct) then + nint_gr(i)=1 + istart(i,1)=i+1 + iend(i,1)=nct-1 + 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 + else + nint_gr(i)=1 + istart(i,1)=i+1 + iend(i,1)=nct + ind_scint=int_scint+nct-i + endif + enddo + 12 continue + iatsc_s=nnt + iatsc_e=nct-1 + 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 + iatel_s=nnt + iatel_e=nct-3 + do i=iatel_s,iatel_e + ielstart(i)=i+4 + ielend(i)=nct-1 + enddo + 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 +c iscp=3 + iscp=2 +C Partition the SC-p interaction array + 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 + if (lprint) then + write (iout,'(a)') 'SC-p interaction array:' + do i=iatscp_s,iatscp_e + write (iout,'(i3,2(2x,2i3))') + & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) + enddo + endif ! lprint +C Partition local interactions + loc_start=2 + loc_end=nres-1 + ithet_start=3 + ithet_end=nres + iturn3_start=nnt + iturn3_end=nct-3 + iturn4_start=nnt + iturn4_end=nct-4 + iphi_start=nnt+3 + iphi_end=nct + idihconstr_start=1 + idihconstr_end=ndih_constr + ithetaconstr_start=1 + ithetaconstr_end=ntheta_constr + itau_start=4 + itau_end=nres + return + end +c--------------------------------------------------------------------------- + subroutine int_partition(int_index,lower_index,upper_index,atom, + & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + integer int_index,lower_index,upper_index,atom,at_start,at_end, + & first_atom,last_atom,int_gr,jat_start,jat_end + logical lprn + lprn=.false. + if (lprn) write (iout,*) 'int_index=',int_index + int_index_old=int_index + int_index=int_index+last_atom-first_atom+1 + if (lprn) + & write (iout,*) 'int_index=',int_index, + & ' int_index_old',int_index_old, + & ' lower_index=',lower_index, + & ' upper_index=',upper_index, + & ' atom=',atom,' first_atom=',first_atom, + & ' last_atom=',last_atom + if (int_index.ge.lower_index) then + int_gr=int_gr+1 + if (at_start.eq.0) then + at_start=atom + jat_start=first_atom-1+lower_index-int_index_old + else + jat_start=first_atom + endif + if (lprn) write (iout,*) 'jat_start',jat_start + if (int_index.ge.upper_index) then + at_end=atom + jat_end=first_atom-1+upper_index-int_index_old + return1 + else + jat_end=last_atom + endif + if (lprn) write (iout,*) 'jat_end',jat_end + endif + return + end +c------------------------------------------------------------------------------ + subroutine hpb_partition + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' + link_start=1 + link_end=nhpb + link_start_peak=1 + link_end_peak=npeak + write (iout,*) 'HPB_PARTITION', + & ' nhpb',nhpb,' link_start=',link_start, + & ' link_end',link_end,' link_start_peak',link_start_peak, + & ' link_end_peak',link_end_peak + return + end +c------------------------------------------------------------------------------ + subroutine homology_partition + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.FREE' + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'COMMON.HOMOLOGY' + include 'COMMON.HOMRESTR' + include 'COMMON.INTERACT' +cd write(iout,*)"homology_partition: lim_odl=",lim_odl, +cd & " lim_dih",lim_dih + link_start_homo=1 + link_end_homo=lim_odl + idihconstr_start_homo=nnt+3 + idihconstr_end_homo=lim_dih+nnt-1+3 + write (iout,*) + & ' lim_odl',lim_odl,' link_start=',link_start_homo, + & ' link_end',link_end_homo,' lim_dih',lim_dih, + & ' idihconstr_start_homo',idihconstr_start_homo, + & ' idihconstr_end_homo',idihconstr_end_homo + return + end + diff --git a/source/wham/src-HCD/initialize_p.F.org b/source/wham/src-HCD/initialize_p.F.org new file mode 100644 index 0000000..3e7d056 --- /dev/null +++ b/source/wham/src-HCD/initialize_p.F.org @@ -0,0 +1,571 @@ + subroutine initialize +C +C Define constants and zero out tables. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.MINIM' + include 'COMMON.DERIV' + include "COMMON.WEIGHTS" + include "COMMON.NAMES" + include "COMMON.TIME1" +C +C The following is just to define auxiliary variables used in angle conversion +C + pi=4.0D0*datan(1.0D0) + dwapi=2.0D0*pi + dwapi3=dwapi/3.0D0 + pipol=0.5D0*pi + deg2rad=pi/180.0D0 + rad2deg=1.0D0/deg2rad + angmin=10.0D0*deg2rad +C +C Define I/O units. +C + inp= 1 + iout= 2 + ipdbin= 3 + ipdb= 7 + imol2= 4 + igeom= 8 + intin= 9 + ithep= 11 + irotam=12 + itorp= 13 + itordp= 23 + ielep= 14 + isidep=15 + iscpp=25 + icbase=16 + ifourier=20 + istat= 17 + ientin=18 + ientout=19 +C +C CSA I/O units (separated from others especially for Jooyoung) +C + icsa_rbank=30 + icsa_seed=31 + icsa_history=32 + icsa_bank=33 + icsa_bank1=34 + icsa_alpha=35 + icsa_alpha1=36 + icsa_bankt=37 + icsa_int=39 + icsa_bank_reminimized=38 + icsa_native_int=41 + icsa_in=40 +C +C Set default weights of the energy terms. +C + wlong=1.0D0 + welec=1.0D0 + wtor =1.0D0 + wang =1.0D0 + wscloc=1.0D0 + wstrain=1.0D0 +C +C Zero out tables. +C + ndih_constr=0 + do i=1,maxres2 + do j=1,3 + c(j,i)=0.0D0 + dc(j,i)=0.0D0 + enddo + enddo + do i=1,maxres + do j=1,3 + xloc(j,i)=0.0D0 + enddo + enddo + do i=1,ntyp + do j=1,ntyp + aa(i,j)=0.0D0 + bb(i,j)=0.0D0 + augm(i,j)=0.0D0 + sigma(i,j)=0.0D0 + r0(i,j)=0.0D0 + chi(i,j)=0.0D0 + enddo + do j=1,2 + bad(i,j)=0.0D0 + enddo + chip(i)=0.0D0 + alp(i)=0.0D0 + sigma0(i)=0.0D0 + sigii(i)=0.0D0 + rr0(i)=0.0D0 + a0thet(i)=0.0D0 + do j=1,2 + athet(j,i)=0.0D0 + bthet(j,i)=0.0D0 + enddo + do j=0,3 + polthet(j,i)=0.0D0 + enddo + do j=1,3 + gthet(j,i)=0.0D0 + enddo + theta0(i)=0.0D0 + sig0(i)=0.0D0 + sigc0(i)=0.0D0 + do j=1,maxlob + bsc(j,i)=0.0D0 + do k=1,3 + censc(k,j,i)=0.0D0 + enddo + do k=1,3 + do l=1,3 + gaussc(l,k,j,i)=0.0D0 + enddo + enddo + nlob(i)=0 + enddo + enddo + nlob(ntyp1)=0 + dsc(ntyp1)=0.0D0 + do i=1,maxtor + itortyp(i)=0 + do j=1,maxtor + do k=1,maxterm + v1(k,j,i)=0.0D0 + v2(k,j,i)=0.0D0 + enddo + enddo + enddo + do i=1,maxres + itype(i)=0 + itel(i)=0 + enddo +C Initialize the bridge arrays + ns=0 + nss=0 + nhpb=0 + do i=1,maxss + iss(i)=0 + enddo + do i=1,maxdim + dhpb(i)=0.0D0 + enddo + do i=1,maxres + ihpb(i)=0 + jhpb(i)=0 + enddo +C +C Initialize timing. +C + call set_timers +C +C Initialize variables used in minimization. +C +c maxfun=5000 +c maxit=2000 + maxfun=500 + maxit=200 + tolf=1.0D-2 + rtolf=5.0D-4 +C +C Initialize the variables responsible for the mode of gradient storage. +C + nfl=0 + icg=1 + do i=1,14 + do j=1,14 + if (print_order(i).eq.j) then + iw(print_order(i))=j + goto 1121 + endif + enddo +1121 continue + enddo + calc_grad=.false. +C Set timers and counters for the respective routines + t_func = 0.0d0 + t_grad = 0.0d0 + t_fhel = 0.0d0 + t_fbet = 0.0d0 + t_ghel = 0.0d0 + t_gbet = 0.0d0 + t_viol = 0.0d0 + t_gviol = 0.0d0 + n_func = 0 + n_grad = 0 + n_fhel = 0 + n_fbet = 0 + n_ghel = 0 + n_gbet = 0 + n_viol = 0 + n_gviol = 0 + n_map = 0 + return + end +c------------------------------------------------------------------------- + block data nazwy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + data restyp / + &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR', + &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/ + data onelet / + &'C','M','F','I','L','V','W','Y','A','G','T', + &'S','Q','N','E','D','H','R','K','P','X'/ + data potname /'LJ','LJK','BP','GB','GBV'/ + data ename / + & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ", + & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ", + & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EVDW2_14",2*" "/ + data wname / + & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", + & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD", + & "SCAL14",2*" "/ +#ifdef SCP14 + data nprint_ene /15/ + data print_order /1,2,3,11,12,13,14,4,5,6,7,8,9,10,16,0/ +#else + data nprint_ene /14/ + data print_order /1,2,3,11,12,13,14,4,5,6,7,8,9,10,3*0/ +#endif + end +c--------------------------------------------------------------------------- + subroutine init_int_table + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' +#ifdef MPI + 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 MPL + integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs), + & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs) +C... Determine the numbers of start and end SC-SC interaction +C... to deal with by current processor. + lprint=.false. + if (lprint) + &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct + n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss + 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 + nint_gr(i)=0 + nscp_gr(i)=0 + do j=1,maxint_gr + istart(i,1)=0 + iend(i,1)=0 + ielstart(i)=0 + ielend(i)=0 + iscpstart(i,1)=0 + iscpend(i,1)=0 + enddo + enddo + ind_scint=0 + ind_scint_old=0 +cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', +cd & (ihpb(i),jhpb(i),i=1,nss) + do i=nnt,nct-1 + scheck=.false. + do ii=1,nss + if (ihpb(ii).eq.i+nres) then + scheck=.true. + jj=jhpb(ii)-nres + goto 10 + endif + enddo + 10 continue +cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj + if (scheck) then + if (jj.eq.i+1) then +#ifdef MPL + 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 MPL + 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 MPL + 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 MPL + 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 MPL + ind_scint_old=ind_scint +#endif + enddo + 12 continue +#ifndef MPL + iatsc_s=nnt + iatsc_e=nct-1 +#endif +#ifdef MPL + 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 MPL +C Now partition the electrostatic-interaction array + npept=nct-nnt + nele_int_tot=(npept-ispp)*(npept-ispp+1)/2 + call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde) + if (lprint) + & write (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 +c iscp=3 + iscp=2 +C Partition the SC-p interaction array +#ifdef MPL + 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 +cd write (iout,*) 'i.le.nnt+iscp' + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1), + & iscpend(i,1),*14) + else if (i.gt.nct-iscp) then +cd write (iout,*) 'i.gt.nct-iscp' + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), + & iscpend(i,1),*14) + else + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), + & iscpend(i,1),*14) + ii=nscp_gr(i)+1 + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii), + & iscpend(i,ii),*14) + endif + enddo ! i + 14 continue +#else + iatscp_s=nnt + iatscp_e=nct-1 + do i=nnt,nct-1 + if (i.lt.nnt+iscp) then + nscp_gr(i)=1 + iscpstart(i,1)=i+iscp + iscpend(i,1)=nct + elseif (i.gt.nct-iscp) then + nscp_gr(i)=1 + iscpstart(i,1)=nnt + iscpend(i,1)=i-iscp + else + nscp_gr(i)=2 + iscpstart(i,1)=nnt + iscpend(i,1)=i-iscp + iscpstart(i,2)=i+iscp + iscpend(i,2)=nct + endif + enddo ! i +#endif + if (lprint) then + write (iout,'(a)') 'SC-p interaction array:' + do i=iatscp_s,iatscp_e + write (iout,'(i3,2(2x,2i3))') + & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) + enddo + endif ! lprint +C Partition local interactions +#ifdef MPL + 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 + 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 +#endif + return + end +c--------------------------------------------------------------------------- + subroutine int_partition(int_index,lower_index,upper_index,atom, + & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + integer int_index,lower_index,upper_index,atom,at_start,at_end, + & first_atom,last_atom,int_gr,jat_start,jat_end + logical lprn + lprn=.false. + if (lprn) write (iout,*) 'int_index=',int_index + int_index_old=int_index + int_index=int_index+last_atom-first_atom+1 + if (lprn) + & write (iout,*) 'int_index=',int_index, + & ' int_index_old',int_index_old, + & ' lower_index=',lower_index, + & ' upper_index=',upper_index, + & ' atom=',atom,' first_atom=',first_atom, + & ' last_atom=',last_atom + if (int_index.ge.lower_index) then + int_gr=int_gr+1 + if (at_start.eq.0) then + at_start=atom + jat_start=first_atom-1+lower_index-int_index_old + else + jat_start=first_atom + endif + if (lprn) write (iout,*) 'jat_start',jat_start + if (int_index.ge.upper_index) then + at_end=atom + jat_end=first_atom-1+upper_index-int_index_old + return1 + else + jat_end=last_atom + endif + if (lprn) write (iout,*) 'jat_end',jat_end + endif + return + end +c------------------------------------------------------------------------------ + subroutine hpb_partition + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' + call int_bounds(nhpb,link_start,link_end) +#else + link_start=1 + link_end=nhpb +#endif +cd write (iout,*) 'Processor',MyID,' MyRank',MyRank, +cd & ' nhpb',nhpb,' link_start=',link_start, +cd & ' link_end',link_end + return + end diff --git a/source/wham/src-HCD/int_from_cart.f b/source/wham/src-HCD/int_from_cart.f new file mode 100644 index 0000000..6e22094 --- /dev/null +++ b/source/wham/src-HCD/int_from_cart.f @@ -0,0 +1,65 @@ + subroutine int_from_cart1(lprn) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.NAMES' + integer i,j + double precision dist,alpha,beta,dnorm1,dnorm2,be + logical lprn + if (lprn) write (iout,'(/a)') 'Recalculated internal coordinates' + vbld(nres+1)=0.0d0 + vbld(2*nres)=0.0d0 + vbld_inv(nres+1)=0.0d0 + vbld_inv(2*nres)=0.0d0 + do i=2,nres + dnorm1=dist(i-1,i) + dnorm2=dist(i,i+1) + do j=1,3 + c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))/dnorm1 + & +(c(j,i+1)-c(j,i))/dnorm2) + enddo + be=0.0D0 + if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) + if (i.gt.2) tauangle(3,i+1)=beta(i+nres-1,i-1,i,i+nres) + if (i.gt.2) tauangle(1,i+1)=beta(i-1+nres,i-1,i,i+1) + if (i.gt.2) tauangle(2,i+1)=beta(i-2,i-1,i,i+nres) + omeg(i)=beta(nres+i,i,maxres2,i+1) + theta(i+1)=alpha(i-1,i,i+1) + alph(i)=alpha(nres+i,i,maxres2) + 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 + 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=1,nres + 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 + 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)) + return + end diff --git a/source/wham/src-HCD/intcor.f b/source/wham/src-HCD/intcor.f new file mode 100644 index 0000000..04cbbbc --- /dev/null +++ b/source/wham/src-HCD/intcor.f @@ -0,0 +1,94 @@ +C +C------------------------------------------------------------------------------ +C + double precision function alpha(i1,i2,i3) +c +c Calculates the planar angle between atoms (i1), (i2), and (i3). +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + x12=c(1,i1)-c(1,i2) + x23=c(1,i3)-c(1,i2) + y12=c(2,i1)-c(2,i2) + y23=c(2,i3)-c(2,i2) + z12=c(3,i1)-c(3,i2) + z23=c(3,i3)-c(3,i2) + vnorm=dsqrt(x12*x12+y12*y12+z12*z12) + wnorm=dsqrt(x23*x23+y23*y23+z23*z23) + scalar=(x12*x23+y12*y23+z12*z23)/(vnorm*wnorm) + alpha=arcos(scalar) + return + end +C +C------------------------------------------------------------------------------ +C + double precision function beta(i1,i2,i3,i4) +c +c Calculates the dihedral angle between atoms (i1), (i2), (i3) and (i4) +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + x12=c(1,i1)-c(1,i2) + x23=c(1,i3)-c(1,i2) + x34=c(1,i4)-c(1,i3) + y12=c(2,i1)-c(2,i2) + y23=c(2,i3)-c(2,i2) + y34=c(2,i4)-c(2,i3) + z12=c(3,i1)-c(3,i2) + z23=c(3,i3)-c(3,i2) + z34=c(3,i4)-c(3,i3) +cd print '(2i3,3f10.5)',i1,i2,x12,y12,z12 +cd print '(2i3,3f10.5)',i2,i3,x23,y23,z23 +cd print '(2i3,3f10.5)',i3,i4,x34,y34,z34 + wx=-y23*z34+y34*z23 + wy=x23*z34-z23*x34 + wz=-x23*y34+y23*x34 + wnorm=dsqrt(wx*wx+wy*wy+wz*wz) + vx=y12*z23-z12*y23 + vy=-x12*z23+z12*x23 + vz=x12*y23-y12*x23 + vnorm=dsqrt(vx*vx+vy*vy+vz*vz) + if (vnorm.gt.1.0D-13 .and. wnorm.gt.1.0D-13) then + scalar=(vx*wx+vy*wy+vz*wz)/(vnorm*wnorm) + if (dabs(scalar).gt.1.0D0) + &scalar=0.99999999999999D0*scalar/dabs(scalar) + angle=dacos(scalar) +cd print '(2i4,10f7.3)',i2,i3,vx,vy,vz,wx,wy,wz,vnorm,wnorm, +cd &scalar,angle + else + angle=pi + endif +c if (angle.le.0.0D0) angle=pi+angle + tx=vy*wz-vz*wy + ty=-vx*wz+vz*wx + tz=vx*wy-vy*wx + scalar=tx*x23+ty*y23+tz*z23 + if (scalar.lt.0.0D0) angle=-angle + beta=angle + return + end +C +C------------------------------------------------------------------------------ +C + double precision function dist(i1,i2) +c +c Calculates the distance between atoms (i1) and (i2). +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + x12=c(1,i1)-c(1,i2) + y12=c(2,i1)-c(2,i2) + z12=c(3,i1)-c(3,i2) + dist=dsqrt(x12*x12+y12*y12+z12*z12) + return + end +C diff --git a/source/wham/src-HCD/iperm.f b/source/wham/src-HCD/iperm.f new file mode 100644 index 0000000..77ba7ed --- /dev/null +++ b/source/wham/src-HCD/iperm.f @@ -0,0 +1,15 @@ + integer function iperm(ires,ipermut) + implicit none + include "DIMENSIONS" + include "COMMON.CHAIN" + integer ipermut,ires,ii,iii + integer tperm + ii=ireschain(ires) + if (ii.eq.0) then + iperm=ires + else + iii=tabpermchain(ii,ipermut) + iperm=chain_border(1,iii)+ires-chain_border(1,ii) + endif + return + end diff --git a/source/wham/src-HCD/make_ensemble1.F b/source/wham/src-HCD/make_ensemble1.F new file mode 100644 index 0000000..a07dbeb --- /dev/null +++ b/source/wham/src-HCD/make_ensemble1.F @@ -0,0 +1,424 @@ + subroutine make_ensembles(islice,*) +! construct the conformational ensembles at REMD temperatures + 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.HOMOLOGY" + 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*4 csingle(3,maxres2) + double precision fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl, + & eprim,ebis,temper,kfac/2.4d0/,T0/300.0d0/ + double precision etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors, + & escloc,eliptran,esaxs, + & ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3, + & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor,tt, + & ehomology_constr,edfadis,edfator,edfanei,edfabet + integer i,ii,ik,iproc,iscor,j,k,l,ib,iparm,iprot,nlist + double precision qfree,sumprob,eini,efree,rmsdev + character*80 bxname + character*2 licz1,licz2 + character*3 licz3,licz4 + character*5 ctemper + integer ilen + external ilen + real*4 Fdimless(MaxStr),Fdimless_(MaxStr) + double precision enepot(MaxStr) + integer iperm(MaxStr) + integer islice + +#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,nParmSet + 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) +c quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) +c quotl=1.0d0 +c kfacl=1.0d0 +c do l=1,5 +c quotl1=quotl +c quotl=quotl*quot +c kfacl=kfacl*kfac +c fT(l)=kfacl/(kfacl-1.0d0+quotl) +c enddo + 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 +c 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) + return1 + endif +#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) +#ifdef SCP14 + evdw2_14=enetb(17,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) + eturn6=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) + esccor=enetb(19,i,iparm) + edihcnstr=enetb(20,i,iparm) + eliptran=enetb(22,i,iparm) + esaxs=enetb(26,i,iparm) + ehomology_constr=enetb(27,i,iparm) + edfadis=enetb(28,i,iparm) + edfator=enetb(29,i,iparm) + edfanei=enetb(30,i,iparm) + edfabet=enetb(31,i,iparm) + if (homol_nset.gt.1) + & ehomology_constr=waga_homology(homol_nset)*ehomology_constr +#ifdef SPLITELE + if (shield_mode.gt.0) then + etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2 + & +ft(1)*welec*ees + & +ft(1)*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+wliptran*eliptran+wsaxs*esaxs + & +ehomology_constr + & +wdfa_dist*edfadis + & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet + else + 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+wliptran*eliptran+wsaxs*esaxs + & +ehomology_constr + & +wdfa_dist*edfadis + & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet + endif +#else + if (shield_mode.gt.0) then + etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*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+wliptran*eliptran+wsaxs*esaxs + & +ehomology_constr + & +wdfa_dist*edfadis + & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet + 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+wliptran*eliptran+wsaxs*esaxs + & +ehomology_constr + & +wdfa_dist*edfadis + & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet + endif +#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 + 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 +c 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 + return1 + 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) + write (iout,*) "Before reading nlist",nlist + 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 pdbout(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 + return + end +!-------------------------------------------------- + subroutine mysort1(n, x, ipermut) + implicit none + integer i,j,imax,ipm,n + real x(n) + integer ipermut(n) + real 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 diff --git a/source/wham/src-HCD/match_contact.f b/source/wham/src-HCD/match_contact.f new file mode 100644 index 0000000..132d9b8 --- /dev/null +++ b/source/wham/src-HCD/match_contact.f @@ -0,0 +1,345 @@ + 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,ipermmin,llocal,lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + integer ncont_ref,icont_ref(2,maxcont),ncont,icont(2,maxcont), + & ishift,ishif2,nc_match,ipermmin + double precision nc_frac + logical llocal,lprn + 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 +c write (iout,*) "match_contact: nc_req:",nc_req +c write (iout,*) "nc_match_max",nc_match_max +c write (iout,*) "jfrag",jfrag," n_shif1",n_shif1, +c & " n_shif2",n_shif2 +C Match current contact map against reference contact map; exit, if at least +C half of the contacts match + call ncont_match(nc_match,nc_match1,0,0,ncont_ref,icont_ref, + & ncont,icont,jfrag,ipermmin,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 +C If sufficient matches are not found, try to shift contact maps up to three +C positions. + if (n_shif1.gt.0) then + do is=1,n_shif1 +C The following four tries help to find shifted beta-sheet patterns +C Shift "left" strand backward + call ncont_match(nc_match,nc_match1,-is,0,ncont_ref, + & icont_ref,ncont,icont,jfrag,ipermmin,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 +C Shift "left" strand forward + call ncont_match(nc_match,nc_match1,is,0,ncont_ref, + & icont_ref,ncont,icont,jfrag,ipermmin,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 +C 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,ipermmin,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 +C Shift "right" strand upward + call ncont_match(nc_match,nc_match1,0,is,ncont_ref, + & icont_ref,ncont,icont,jfrag,ipermmin,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 +C 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,ipermmin,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,ipermmin,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 +c + call ncont_match(nc_match,nc_match1,-js,-is,ncont_ref, + & icont_ref,ncont,icont,jfrag,ipermmin,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 +c + call ncont_match(nc_match,nc_match1,js,is,ncont_ref, + & icont_ref,ncont,icont,jfrag,ipermmin,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 +c + if (is+js.le.n_shif1) then + call ncont_match(nc_match,nc_match1,-is,js,ncont_ref, + & icont_ref,ncont,icont,jfrag,ipermmin,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 +c + call ncont_match(nc_match,nc_match1,js,-is,ncont_ref, + & icont_ref,ncont,icont,jfrag,ipermmin,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 +c + 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,ipermmin,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,ipermmin,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 +C If this point is reached, the contact maps are different. + nc_match=0 + ishif1=0 + ishif2=0 + return + end +c------------------------------------------------------------------------- + subroutine ncont_match(nc_match,nc_match1,ishif1,ishif2, + & ncont_ref,icont_ref,ncont,icont,jfrag,ipermmin,llocal,lprn) + 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,icont_ref(2,maxcont),ncont,icont(2,maxcont), + & icont_match(2,maxcont),ishift,ishif2,nang_pair, + & iang_pair(2,maxres),ipermmin,iperm +C Compare the contact map against the reference contact map; they're stored +C in ICONT and ICONT_REF, respectively. The current contact map can be shifted. + if (lprn) then + write (iout,'(80(1h*))') + write (iout,*) "ncont_match" + write (iout,*) "ipermmin",ipermmin + write (iout,'(80(1h*))') + endif + nc_match=0 + nc_match1=0 +c Check the local structure by comparing dihedral angles. +c write (iout,*) "ncont_match: ncont_ref",ncont_ref," llocal",llocal + if (llocal .and. ncont_ref.eq.0) then +c If there are no contacts just compare the dihedral angles and exit. + call angnorm(jfrag,ishif1,ishif2,ang_cut1(jfrag),diffang,fract, + & ipermmin,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 +c write (iout,*) "i",i," icont",icont(1,i),icont(2,i) + ic1=icont(1,i)+ishif1 + ic2=icont(2,i)+ishif2 +c 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 +c call add_angpair(icont(1,i),icont_ref(1,j), +c & nang_pair,iang_pair) +c call add_angpair(icont(2,i),icont_ref(2,j), +c & 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,ipermmin,lprn) + 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 +c if (nc_match.gt.0) then +c diffang = angnorm1(nang_pair,iang_pair,lprn) +c if (diffang.gt.ang_cut(jfrag)) nc_match=0 +c endif + if (lprn) write (iout,*) "ishif1",ishif1," ishif2",ishif2, + & " diffang",rad2deg*diffang," nc_match",nc_match + return + end +c------------------------------------------------------------------------------ + subroutine match_secondary(jfrag,isecstr,nsec_match,ipermmin,lprn) +c This subroutine compares the secondary structure (isecstr) of fragment jfrag +c conformation considered to that of the reference conformation. +c 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(maxres),ipermmin,iperm + 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) +c The residue has equivalent conformational state to that of the reference +c structure, if: +c a) the conformational states are equal or +c b) the reference state is a coil and that of the conformation considered +c is a strand or +c c) the conformational state of the conformation considered is a strand +c and that of the reference conformation is a coil. +c 10/28/02 - case (b) deleted. + if (isecstr(iperm(j,ipermmin)).eq.isec_ref(j) .or. +c & isecstr(j).eq.0 .and. isec_ref(j).eq.1 .or. + & isec_ref(j).eq.0 .and. isecstr(iperm(j,ipermmin)).eq.1) + & nsec_match=nsec_match+1 + enddo + enddo + return + end diff --git a/source/wham/src-HCD/matmult.f b/source/wham/src-HCD/matmult.f new file mode 100644 index 0000000..e9257cf --- /dev/null +++ b/source/wham/src-HCD/matmult.f @@ -0,0 +1,18 @@ + SUBROUTINE MATMULT(A1,A2,A3) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(3,3),A2(3,3),A3(3,3) + DIMENSION AI3(3,3) + DO 1 I=1,3 + DO 2 J=1,3 + A3IJ=0.0 + DO 3 K=1,3 + 3 A3IJ=A3IJ+A1(I,K)*A2(K,J) + AI3(I,J)=A3IJ + 2 CONTINUE + 1 CONTINUE + DO 4 I=1,3 + DO 4 J=1,3 + 4 A3(I,J)=AI3(I,J) + RETURN + END diff --git a/source/wham/src-HCD/misc.f b/source/wham/src-HCD/misc.f new file mode 100644 index 0000000..e189839 --- /dev/null +++ b/source/wham/src-HCD/misc.f @@ -0,0 +1,203 @@ +C $Date: 1994/10/12 17:24:21 $ +C $Revision: 2.5 $ +C +C +C + logical function find_arg(ipos,line,errflag) + parameter (maxlen=80) + character*80 line + character*1 empty /' '/,equal /'='/ + logical errflag +* This function returns .TRUE., if an argument follows keyword keywd; if so +* IPOS will point to the first non-blank character of the argument. Returns +* .FALSE., if no argument follows the keyword; in this case IPOS points +* to the first non-blank character of the next keyword. + do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + errflag=.false. + if (line(ipos:ipos).eq.equal) then + find_arg=.true. + ipos=ipos+1 + do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + if (ipos.gt.maxlen) errflag=.true. + else + find_arg=.false. + endif + return + end + logical function find_group(iunit,jout,key1) + character*(*) key1 + character*80 karta,ucase + integer ilen + external ilen + logical lcom + rewind (iunit) + karta=' ' + ll=ilen(key1) + do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta)) + read (iunit,'(a)',end=10) karta + enddo + write (jout,'(2a)') '> ',karta(1:78) + find_group=.true. + return + 10 find_group=.false. + return + end + logical function iblnk(charc) + character*1 charc + integer n + n = ichar(charc) + iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq. ' ') + return + end + integer function ilen(string) + character*(*) string + logical iblnk + + ilen = len(string) +1 if ( ilen .gt. 0 ) then + if ( iblnk( string(ilen:ilen) ) ) then + ilen = ilen - 1 + goto 1 + endif + endif + return + end + integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset) + character*16 keywd,keywdset(1:nkey,0:nkey) + character*16 ucase + do i=1,narg + if (ucase(keywd).eq.keywdset(i,ikey)) then +* Match found + in_keywd_set=i + return + endif + enddo +* No match to the allowed set of keywords if this point is reached. + in_keywd_set=0 + return + end + character*(*) function lcase(string) + integer i, k, idiff + character*(*) string + character*1 c + character*40 chtmp +c + i = len(lcase) + k = len(string) + if (i .lt. k) then + k = i + if (string(k+1:) .ne. ' ') then + chtmp = string + endif + endif + idiff = ichar('a') - ichar('A') + lcase = string + do 99 i = 1, k + c = string(i:i) + if (lge(c,'A') .and. lle(c,'Z')) then + lcase(i:i) = char(ichar(c) + idiff) + endif + 99 continue + return + end + logical function lcom(ipos,karta) + character*80 karta + character koment(2) /'!','#'/ + lcom=.false. + do i=1,2 + if (karta(ipos:ipos).eq.koment(i)) lcom=.true. + enddo + return + end + logical function lower_case(ch) + character*(*) ch + lower_case=(ch.ge.'a' .and. ch.le.'z') + return + end + subroutine mykey(line,keywd,ipos,blankline,errflag) +* This subroutine seeks a non-empty substring keywd in the string LINE. +* The substring begins with the first character different from blank and +* "=" encountered right to the pointer IPOS (inclusively) and terminates +* at the character left to the first blank or "=". When the subroutine is +* exited, the pointer IPOS is moved to the position of the terminator in LINE. +* The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains +* only separators or the maximum length of the data line (80) has been reached. +* The logical variable ERRFLAG is set at .TRUE. if the string +* consists only from a "=". + parameter (maxlen=80) + character*1 empty /' '/,equal /'='/,comma /','/ + character*(*) keywd + character*80 line + logical blankline,errflag,lcom + errflag=.false. + do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen)) + ipos=ipos+1 + enddo + if (ipos.gt.maxlen .or. lcom(ipos,line) ) then +* At this point the rest of the input line turned out to contain only blanks +* or to be commented out. + blankline=.true. + return + endif + blankline=.false. + istart=ipos +* Checks whether the current char is a separator. + do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal + & .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + iend=ipos-1 +* Error flag set to .true., if the length of the keyword was found less than 1. + if (iend.lt.istart) then + errflag=.true. + return + endif + keywd=line(istart:iend) + return + end + subroutine numstr(inum,numm) + character*10 huj /'0123456789'/ + character*(*) numm + inumm=inum + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(3:3)=huj(inum2+1:inum2+1) + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(2:2)=huj(inum2+1:inum2+1) + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(1:1)=huj(inum2+1:inum2+1) + return + end + character*(*) function ucase(string) + integer i, k, idiff + character*(*) string + character*1 c + character*40 chtmp +c + i = len(ucase) + k = len(string) + if (i .lt. k) then + k = i + if (string(k+1:) .ne. ' ') then + chtmp = string + endif + endif + idiff = ichar('a') - ichar('A') + ucase = string + do 99 i = 1, k + c = string(i:i) + if (lge(c,'a') .and. lle(c,'z')) then + ucase(i:i) = char(ichar(c) - idiff) + endif + 99 continue + return + end diff --git a/source/wham/src-HCD/module b/source/wham/src-HCD/module new file mode 100644 index 0000000..e69de29 diff --git a/source/wham/src-HCD/molread_zs.F b/source/wham/src-HCD/molread_zs.F new file mode 100644 index 0000000..d7f586d --- /dev/null +++ b/source/wham/src-HCD/molread_zs.F @@ -0,0 +1,492 @@ + subroutine molread(*) +C +C Read molecular data. +C + 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' + include 'COMMON.SAXS' + character*4 sequence(maxres) + integer rescode,tperm + double precision x(maxvar) + character*320 controlcard,ucase + dimension itype_pdb(maxres) + logical seq_comp + double precision secprob(3,maxdih_constr),phihel,phibet + call card_concat(controlcard,.true.) + call readi(controlcard,"NRES",nres,0) + iscode=index(controlcard,"ONE_LETTER") + if (nres.le.0) then + write (iout,*) "Error: no residues in molecule" + return1 + endif + if (nres.gt.maxres) then + write (iout,*) "Error: too many residues",nres,maxres + endif + write(iout,*) 'nres=',nres +C 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 +C 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 + nnt=1 + nct=nres + call seq2chains(nres,itype,nchain,chain_length,chain_border, + & ireschain) + write(iout,*) "nres",nres," nchain",nchain + do i=1,nchain + write(iout,*)"chain",i,chain_length(i),chain_border(1,i), + & chain_border(2,i) + enddo + call chain_symmetry(nchain,nres,itype,chain_border, + & chain_length,npermchain,tabpermchain) + write(iout,*) "ireschain permutations" + do i=1,nres + write(iout,*) i,(tperm(ireschain(i),ii,tabpermchain), + & ii=1,npermchain) + enddo + write(iout,*) "residue permutations" + do i=1,nres + write(iout,*) i,(iperm(i,ii),ii=1,npermchain) + enddo + + if (itype(1).eq.ntyp1) nnt=2 + if (itype(nres).eq.ntyp1) nct=nct-1 + write(iout,*) 'NNT=',NNT,' NCT=',NCT + if (with_dihed_constr) then + + read (inp,*) ndih_constr + write (iout,*) "ndih_constr",ndih_constr + if (ndih_constr.gt.0) then + raw_psipred=.false. +C read (inp,*) ftors +C write (iout,*) 'FTORS',ftors + read (inp,*) (idih_constr(i),phi0(i),drange(i),ftors(i), + & i=1,ndih_constr) + write (iout,*) + & 'There are',ndih_constr,' restraints on gamma angles.' + do i=1,ndih_constr + write (iout,'(i5,3f8.3)') idih_constr(i),phi0(i),drange(i), + & ftors(i) + enddo + do i=1,ndih_constr + phi0(i)=deg2rad*phi0(i) + drange(i)=deg2rad*drange(i) + enddo + else if (ndih_constr.lt.0) then + raw_psipred=.true. + call card_concat(controlcard,.true.) + call reada(controlcard,"PHIHEL",phihel,50.0D0) + call reada(controlcard,"PHIBET",phibet,180.0D0) + call reada(controlcard,"SIGMAHEL",sigmahel,30.0d0) + call reada(controlcard,"SIGMABET",sigmabet,40.0d0) + call reada(controlcard,"WDIHC",wdihc,0.591d0) + write (iout,*) "Weight of the dihedral restraint term",wdihc + read(inp,'(9x,3f7.3)') + & (secprob(1,i),secprob(2,i),secprob(3,i),i=nnt,nct) + write (iout,*) "The secprob array" + do i=nnt,nct + write (iout,'(i5,3f8.3)') i,(secprob(j,i),j=1,3) + enddo + ndih_constr=0 + do i=nnt+3,nct + if (itype(i-3).ne.ntyp1 .and. itype(i-2).ne.ntyp1 + & .and. itype(i-1).ne.ntyp1 .and. itype(i).ne.ntyp1) then + ndih_constr=ndih_constr+1 + idih_constr(ndih_constr)=i + sumv=0.0d0 + do j=1,3 + vpsipred(j,ndih_constr)=secprob(j,i-1)*secprob(j,i-2) + sumv=sumv+vpsipred(j,ndih_constr) + enddo + do j=1,3 + vpsipred(j,ndih_constr)=vpsipred(j,ndih_constr)/sumv + enddo + phibound(1,ndih_constr)=phihel*deg2rad + phibound(2,ndih_constr)=phibet*deg2rad + sdihed(1,ndih_constr)=sigmahel*deg2rad + sdihed(2,ndih_constr)=sigmabet*deg2rad + endif + enddo + write (iout,*) + & 'There are',ndih_constr, + & ' bimodal restraints on gamma angles.' + do i=1,ndih_constr + write(iout,'(i5,1x,a4,i5,1h-,a4,i5,4f8.3,3f10.5)') i, + & restyp(itype(idih_constr(i)-2)),idih_constr(i)-2, + & restyp(itype(idih_constr(i)-1)),idih_constr(i)-1, + & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg, + & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg, + & (vpsipred(j,i),j=1,3) + enddo + + endif + + endif + if (with_theta_constr) then +C with_theta_constr is keyword allowing for occurance of theta constrains + read (inp,*) ntheta_constr +C ntheta_constr is the number of theta constrains + if (ntheta_constr.gt.0) then +C read (inp,*) ftors + read (inp,*) (itheta_constr(i),theta_constr0(i), + & theta_drange(i),for_thet_constr(i), + & i=1,ntheta_constr) +C the above code reads from 1 to ntheta_constr +C itheta_constr(i) residue i for which is theta_constr +C theta_constr0 the global minimum value +C theta_drange is range for which there is no energy penalty +C for_thet_constr is the force constant for quartic energy penalty +C E=k*x**4 +C if(me.eq.king.or..not.out1file)then + write (iout,*) + & 'There are',ntheta_constr,' constraints on phi angles.' + do i=1,ntheta_constr + write (iout,'(i5,3f8.3)') itheta_constr(i),theta_constr0(i), + & theta_drange(i), + & for_thet_constr(i) + enddo +C endif + do i=1,ntheta_constr + theta_constr0(i)=deg2rad*theta_constr0(i) + theta_drange(i)=deg2rad*theta_drange(i) + enddo +C if(me.eq.king.or..not.out1file) +C & write (iout,*) 'FTORS',ftors +C do i=1,ntheta_constr +C ii = itheta_constr(i) +C thetabound(1,ii) = phi0(i)-drange(i) +C thetabound(2,ii) = phi0(i)+drange(i) +C enddo + endif ! ntheta_constr.gt.0 + endif! with_theta_constr + if (constr_homology.gt.0) then +c write (iout,*) "About to call read_constr_homology" +c call flush(iout) + call read_constr_homology +c write (iout,*) "Exit read_constr_homology" +c call flush(iout) + if (indpdb.gt.0 .or. pdbref) then + do i=1,2*nres + do j=1,3 + c(j,i)=crefjlee(j,i) + cref(j,i)=crefjlee(j,i) + enddo + enddo + endif +#ifdef DEBUG + write (iout,*) "Array C" + do i=1,nres + write (iout,'(i5,3f8.3,5x,3f8.3)') i,(c(j,i),j=1,3), + & (c(j,i+nres),j=1,3) + enddo + write (iout,*) "Array Cref" + do i=1,nres + write (iout,'(i5,3f8.3,5x,3f8.3)') i,(cref(j,i),j=1,3), + & (cref(j,i+nres),j=1,3) + enddo +#endif +#ifdef DEBUG + call int_from_cart1(.false.) + call sc_loc_geom(.false.) + do i=1,nres + thetaref(i)=theta(i) + phiref(i)=phi(i) + write (iout,*) i," phiref",phiref(i)," thetaref",thetaref(i) + enddo + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=2,nres-1 + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo + enddo +#endif + else + homol_nset=0 + endif + + 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) + if (dyn_ss) then + write(iout,*)"Running with dynamic disulfide-bond formation" + else + write (iout,'(/a/)') 'Pre-formed links are:' + do i=1,nss + i1=ihpb(i)-nres + i2=jhpb(i)-nres + it1=itype(i1) + it2=itype(i2) + write (iout,'(2a,i3,3a,i3,a,3f10.3)') + & restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')', + & dhpb(i),ebr,forcon(i) + enddo + endif + endif + write (iout,'(a)') + 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 + write (iout,*) "calling read_saxs_consrtr",nsaxs + if (nsaxs.gt.0) call read_saxs_constr + + return + end +c----------------------------------------------------------------------------- + logical function seq_comp(itypea,itypeb,length) + implicit none + integer length,itypea(length),itypeb(length) + integer i + do i=1,length + if (itypea(i).ne.itypeb(i)) then + seq_comp=.false. + return + endif + enddo + seq_comp=.true. + return + end +c----------------------------------------------------------------------------- + subroutine read_bridge +C Read information about disulfide bridges. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' +C Read bridging residues. + read (inp,*) ns,(iss(i),i=1,ns) + print *,'ns=',ns + write (iout,*) 'ns=',ns,' iss:',(iss(i),i=1,ns) +C Check whether the specified bridging residues are cystines. + do i=1,ns + if (itype(iss(i)).ne.1) then + 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?!!!' + stop + endif + enddo +C Read preformed bridges. + if (ns.gt.0) then + read (inp,*) nss,(ihpb(i),jhpb(i),i=1,nss) + write (iout,*) 'nss=',nss,' ihpb,jhpb: ',(ihpb(i),jhpb(i),i=1,nss) + if (nss.gt.0) then + nhpb=nss +C Check if the residues involved in bridges are in the specified list of +C bridging residues. + do i=1,nss + do j=1,i-1 + if (ihpb(i).eq.ihpb(j).or.ihpb(i).eq.jhpb(j) + & .or.jhpb(i).eq.ihpb(j).or.jhpb(i).eq.jhpb(j)) then + write (iout,'(a,i3,a)') 'Disulfide pair',i, + & ' contains residues present in other pairs.' + write (*,'(a,i3,a)') 'Disulfide pair',i, + & ' contains residues present in other pairs.' + stop + endif + enddo + do j=1,ns + if (ihpb(i).eq.iss(j)) goto 10 + enddo + write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' + 10 continue + do j=1,ns + if (jhpb(i).eq.iss(j)) goto 20 + enddo + write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' + 20 continue + dhpb(i)=dbr + forcon(i)=fbr + enddo + do i=1,nss + ihpb(i)=ihpb(i)+nres + jhpb(i)=jhpb(i)+nres + enddo + endif + endif + return + end +c------------------------------------------------------------------------------ + subroutine read_angles(kanal,iscor,energ,iprot,*) + 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*80 lineh + 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 +c print *,"energy",energ," iscor",iscor + 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 + theta(i)=deg2rad*theta(i) + phi(i)=deg2rad*phi(i) + alph(i)=deg2rad*alph(i) + omeg(i)=deg2rad*omeg(i) + enddo + return + 10 return1 + end +c------------------------------------------------------------------------------- + subroutine read_saxs_constr + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.SBRIDGE' + include 'COMMON.SAXS' + double precision cm(3) +c read(inp,*) nsaxs + write (iout,*) "Calling read_saxs nsaxs",nsaxs + call flush(iout) + if (saxs_mode.eq.0) then +c SAXS distance distribution + do i=1,nsaxs + read(inp,*) distsaxs(i),Psaxs(i) + enddo + Cnorm = 0.0d0 + do i=1,nsaxs + Cnorm = Cnorm + Psaxs(i) + enddo + write (iout,*) "Cnorm",Cnorm + do i=1,nsaxs + Psaxs(i)=Psaxs(i)/Cnorm + enddo + write (iout,*) "Normalized distance distribution from SAXS" + do i=1,nsaxs + write (iout,'(f8.2,e15.5)') distsaxs(i),Psaxs(i) + enddo + Wsaxs0=0.0d0 + do i=1,nsaxs + Wsaxs0=Wsaxs0-Psaxs(i)*dlog(Psaxs(i)) + enddo + write (iout,*) "Wsaxs0",Wsaxs0 + else +c SAXS "spheres". + do i=1,nsaxs + read (inp,'(30x,3f8.3)') (Csaxs(j,i),j=1,3) + enddo + do j=1,3 + cm(j)=0.0d0 + enddo + do i=1,nsaxs + do j=1,3 + cm(j)=cm(j)+Csaxs(j,i) + enddo + enddo + do j=1,3 + cm(j)=cm(j)/nsaxs + enddo + do i=1,nsaxs + do j=1,3 + Csaxs(j,i)=Csaxs(j,i)-cm(j) + enddo + enddo + write (iout,*) "SAXS sphere coordinates" + do i=1,nsaxs + write (iout,'(i5,3f10.5)') i,(Csaxs(j,i),j=1,3) + enddo + endif + return + end diff --git a/source/wham/src-HCD/mygetenv.F b/source/wham/src-HCD/mygetenv.F new file mode 100644 index 0000000..b5ea4a2 --- /dev/null +++ b/source/wham/src-HCD/mygetenv.F @@ -0,0 +1,55 @@ + subroutine mygetenv(string,var) +C +C Version 1.0 +C +C This subroutine passes the environmental variables to FORTRAN program. +C If the flags -DMYGETENV and -DMPI are not for compilation, it calls the +C standard FORTRAN GETENV subroutine. If both flags are set, the subroutine +C reads the environmental variables from $HOME/.env +C +C Usage: As for the standard FORTRAN GETENV subroutine. +C +C Purpose: some versions/installations of MPI do not transfer the environmental +C variables to slave processors, if these variables are set in the shell script +C from which mpirun is called. +C +C A.Liwo, 7/29/01 +C + implicit none + character*(*) string,var +#if defined(MYGETENV) && defined(MPI) + include "DIMENSIONS.ZSCOPT" + include "mpif.h" + include "COMMON.MPI" + character*360 ucase + external ucase + character*360 string1(360),karta + character*240 home + integer i,n,ilen + 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 diff --git a/source/wham/src-HCD/mysort.f b/source/wham/src-HCD/mysort.f new file mode 100644 index 0000000..cb1bbe7 --- /dev/null +++ b/source/wham/src-HCD/mysort.f @@ -0,0 +1,52 @@ + 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 + double precision z2(n),z3(n),z4(n),z5(n) + double precision 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 diff --git a/source/wham/src-HCD/odlodc.f b/source/wham/src-HCD/odlodc.f new file mode 100644 index 0000000..c18ac72 --- /dev/null +++ b/source/wham/src-HCD/odlodc.f @@ -0,0 +1,55 @@ + subroutine odlodc(r1,r2,a,b,uu,vv,aa,bb,dd) + implicit real*8 (a-h,o-z) + dimension r1(3),r2(3),a(3),b(3),x(3),y(3) + odl(u,v) = (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 +c print *,"r1",(r1(i),i=1,3) +c print *,"r2",(r2(i),i=1,3) +c print *,"a",(a(i),i=1,3) +c 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 +c 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 +c print *,u,v + uu=dmin1(uu,1.0d0) + uu=dmax1(uu,0.0d0) + vv=dmin1(vv,1.0d0) + vv=dmax1(vv,0.0d0) + dd1 = odl(uu,vv) + dd2 = odl(0.0d0,0.0d0) + dd3 = odl(0.0d0,1.0d0) + dd4 = odl(1.0d0,0.0d0) + dd5 = odl(1.0d0,1.0d0) + 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 +c Control check +c do i=1,3 +c x(i)=r1(i)+u*a(i) +c y(i)=r2(i)+v*b(i) +c enddo +c dd1 = (x(1)-y(1))**2+(x(2)-y(2))**2+(x(3)-y(3))**2 +c dd1 = dsqrt(dd1) + aa = dsqrt(aa) + bb = dsqrt(bb) +c write (8,*) uu,vv,dd,dd1 +c print *,dd,dd1 + return + end diff --git a/source/wham/src-HCD/oligomer.F b/source/wham/src-HCD/oligomer.F new file mode 100644 index 0000000..34b7be0 --- /dev/null +++ b/source/wham/src-HCD/oligomer.F @@ -0,0 +1,76 @@ + subroutine oligomer + implicit none + include "DIMENSIONS" + include "COMMON.CHAIN" + include "COMMON.INTERACT" + include "COMMON.IOUNITS" + integer i,ii,ipi,ipj,ipmin,j,jmin,k,ix,iy,iz, + & ixmin,iymin,izmin,ir_start,ir_end + integer iper(maxchain),iaux + double precision dchain,dchainmin,cmchain(3,20) + cmchain=0.0d0 + do i=1,nchain + ii=0 + do j=chain_border(1,i),chain_border(2,i) + if (itype(j).eq.ntyp1) cycle + ii=ii+1 + do k=1,3 + cmchain(k,i)=cmchain(k,i)+c(k,j) + enddo + enddo + do k=1,3 + cmchain(k,i)=cmchain(k,i)/ii + enddo + enddo + do i=1,nchain + iper(i)=i + enddo + do i=1,nchain-1 + dchainmin=1.0d10 + do j=i+1,nchain + ipi=iper(i) + ipj=iper(j) + do ix=-1,1 + do iy=-1,1 + do iz=-1,1 + dchain=(cmchain(1,ipj)-cmchain(1,ipi)+ix*boxxsize)**2+ + & (cmchain(2,ipj)-cmchain(2,ipi)+iy*boxysize)**2+ + & (cmchain(3,ipj)-cmchain(3,ipi)+iz*boxzsize)**2 +c write (iout,*) "i",i," ipi",ipi," j",j," ipj",ipj," d", +c & dsqrt(dchain)," dmin",dsqrt(dchainmin)," jmin",jmin + if (dchain.lt.dchainmin) then + dchainmin=dchain + ixmin=ix + iymin=iy + izmin=iz + jmin=j + endif + enddo + enddo + enddo + enddo + if (ixmin.eq.0 .and. iymin.eq.0 .and. izmin.eq.0) cycle + ipj=iper(jmin) + cmchain(1,ipj)=cmchain(1,ipj)+ixmin*boxxsize + cmchain(2,ipj)=cmchain(2,ipj)+iymin*boxysize + cmchain(3,ipj)=cmchain(3,ipj)+izmin*boxzsize + ir_start=chain_border(1,ipj) + if (ir_start.gt.1) ir_start=ir_start-1 + ir_end=chain_border(2,ipj) + if (ir_end.lt.nres) ir_end=ir_end+1 + do k=ir_start,ir_end + c(1,k)=c(1,k)+ixmin*boxxsize + c(2,k)=c(2,k)+iymin*boxysize + c(3,k)=c(3,k)+izmin*boxzsize + c(1,k+nres)=c(1,k+nres)+ixmin*boxxsize + c(2,k+nres)=c(2,k+nres)+iymin*boxysize + c(3,k+nres)=c(3,k+nres)+izmin*boxzsize + enddo +c write (iout,*) "jmin",jmin," ipj",ipj, +c & " ixmin",ixmin," iymin",iymin," izmin",izmin + iaux=iper(i+1) + iper(i+1)=iper(jmin) + iper(jmin)=iaux + enddo + return + end diff --git a/source/wham/src-HCD/openunits.F b/source/wham/src-HCD/openunits.F new file mode 100644 index 0000000..2d6fcfc --- /dev/null +++ b/source/wham/src-HCD/openunits.F @@ -0,0 +1,109 @@ + subroutine openunits +#ifdef WIN + use dfport +#endif + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' +#ifdef MPI + include 'mpif.h' + include 'COMMON.MPI' + integer MyRank + character*3 liczba +#endif + include 'COMMON.IOUNITS' + integer lenpre,lenpot,ilen + 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' +C Get the names and open the input files + open (1,file=prefix(:ilen(prefix))//'.inp',status='old') +C Get parameter filenames and open the parameter files. + call mygetenv('BONDPAR',bondname) +c open (ibond,file=bondname,status='old') + call mygetenv('THETPAR',thetname) +c open (ithep,file=thetname,status='old') + call mygetenv('ROTPAR',rotname) +c open (irotam,file=rotname,status='old') + call mygetenv('TORPAR',torname) +c open (itorp,file=torname,status='old') + call mygetenv('TORDPAR',tordname) +c open (itordp,file=tordname,status='old') + call mygetenv('FOURIER',fouriername) +c open (ifourier,file=fouriername,status='old') + call mygetenv('SCCORPAR',sccorname) +c open (isccor,file=sccorname,status='old') + call mygetenv('ELEPAR',elename) +c open (ielep,file=elename,status='old') + call mygetenv('SIDEPAR',sidename) +c open (isidep,file=sidename,status='old') + call mygetenv('SIDEP',sidepname) + open (isidep1,file=sidepname,status="old") + call mygetenv('LIPTRANPAR',liptranname) + open (iliptranpar,file=liptranname,status='old',action='read') +#ifndef OLDSCP +C +C 8/9/01 In the newest version SCp interaction constants are read from a file +C Use -DOLDSCP to use hard-coded constants instead. +C + call 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,*) "Lipid-transfer parameter file : ", + & liptranname(:ilen(liptranname)) + write (iout,'(80(1h-))') + write (iout,*) + return + end + diff --git a/source/wham/src-HCD/parmread.F b/source/wham/src-HCD/parmread.F new file mode 100644 index 0000000..ecf40a7 --- /dev/null +++ b/source/wham/src-HCD/parmread.F @@ -0,0 +1,1828 @@ + subroutine parmread(iparm,*) +C +C Read the parameters of the probability distributions of the virtual-bond +C valence angles and the side chains and energy parameters. +C + 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' + include 'COMMON.SHIELD' + include 'COMMON.CONTROL' + include 'COMMON.LANGEVIN' + character*1 t1,t2,t3 + character*1 onelett(4) /"G","A","P","D"/ + character*1 toronelet(-2:2) /"p","a","G","A","P"/ + logical lprint + dimension blower(3,3,maxlob) + character*800 controlcard + character*256 bondname_t,thetname_t,rotname_t,torname_t, + & tordname_t,fouriername_t,elename_t,sidename_t,scpname_t, + & sccorname_t + integer ilen + external ilen + character*16 key + integer iparm + character*6 res1 + character*3 lancuch,ucase +C write (iout,*) "KURWA" +C +C Body +C + call getenv("PRINT_PARM",lancuch) + lprint = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") +C Set LPRINT=.TRUE. for debugging + dwa16=2.0d0**(1.0d0/6.0d0) + itypro=20 +C Assign virtual-bond length + vbl=3.8D0 + vblinv=1.0D0/vbl + vblinv2=vblinv*vblinv + call card_concat(controlcard,.true.) + wname(4)="WCORRH" + do i=1,n_ene + key = wname(i)(:ilen(wname(i))) + call reada(controlcard,key(:ilen(key)),ww(i),ww0(i)) + write (iout,*) i,key(:ilen(key)),ww(i) + enddo + 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,'DELT_CORR',delt_corr,0.5d0) + r0_corr=cutoff_corr-delt_corr + + write (iout,*) "iparm",iparm," myparm",myparm +c If reading not own parameters, skip assignment + call reada(controlcard,"D0CM",d0cm,3.78d0) + call reada(controlcard,"AKCM",akcm,15.1d0) + call reada(controlcard,"AKTH",akth,11.0d0) + call reada(controlcard,"AKCT",akct,12.0d0) + call reada(controlcard,"V1SS",v1ss,-1.08d0) + call reada(controlcard,"V2SS",v2ss,7.61d0) + call reada(controlcard,"V3SS",v3ss,13.7d0) + call reada(controlcard,"EBR",ebr,-5.50D0) + call reada(controlcard,"DTRISS",dtriss,1.0D0) + call reada(controlcard,"ATRISS",atriss,0.3D0) + call reada(controlcard,"BTRISS",btriss,0.02D0) + call reada(controlcard,"CTRISS",ctriss,1.0D0) + dyn_ss=(index(controlcard,'DYN_SS').gt.0) +C do i=1,maxres +C dyn_ss_mask(i)=.false. +C enddo +C ebr=-12.0D0 +c +c Old arbitrary potential - commented out. +c +c dbr= 4.20D0 +c fbr= 3.30D0 +c +c Constants of the disulfide-bond potential determined based on the RHF/6-31G** +c energy surface of diethyl disulfide. +c A. Liwo and U. Kozlowska, 11/24/03 +c + D0CM = 3.78d0 + AKCM = 15.1d0 + AKTH = 11.0d0 + AKCT = 12.0d0 + V1SS =-1.08d0 + V2SS = 7.61d0 + V3SS = 13.7d0 + + do i=1,maxres-1 + do j=i+1,maxres + dyn_ssbond_ij(i,j)=1.0d300 + enddo + enddo + call reada(controlcard,"HT",Ht,0.0D0) +C if (dyn_ss) then +C ss_depth=ebr/wsc-0.25*eps(1,1) +C write(iout,*) HT,wsc,eps(1,1),'KURWA' +C Ht=Ht/wsc-0.25*eps(1,1) + +C akcm=akcm*whpb/wsc +C akth=akth*whpb/wsc +C akct=akct*whpb/wsc +C v1ss=v1ss*whpb/wsc +C v2ss=v2ss*whpb/wsc +C v3ss=v3ss*whpb/wsc +C else +C ss_depth=ebr/whpb-0.25*eps(1,1)*wsc/whpb +C endif + + if (iparm.eq.myparm .or. .not.separate_parset) then + +c +c Setup weights for UNRES +c + 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) + whpb=ww(15) + wstrain=ww(15) + wliptran=ww(22) + wshield=ww(25) + wsaxs=ww(26) +c write (iout,*) "PARMREAD: wsaxs",wsaxs + wdfa_dist=ww(28) + wdfa_tor=ww(29) + wdfa_nei=ww(30) + wdfa_beta=ww(31) +c write(iout,*)"PARMREAD: wdfa_dist",wdfa_dist," wdfa_tor",wdfa_tor, +c & " wdfa_nei",wdfa_nei," wdfa_beta",wdfa_beta + endif + +#ifdef DFA +C Juyong:READ init_vars +C Initialize variables! +C Juyong:READ read_info +C READ fragment information!! +C both routines should be in dfa.F file!! + write (iout,*) "Before initializing DFA",wdfa_dist,wdfa_tor, + & wdfa_nei,wdfa_beta + if (.not. (wdfa_dist.eq.0.0 .and. wdfa_tor.eq.0.0 .and. + & wdfa_nei.eq.0.0 .and. wdfa_beta.eq.0.0)) then + write (iout,*) "Calling init_dfa_vars" + call flush(iout) + call init_dfa_vars + write (iout,*) 'init_dfa_vars finished!' + call flush(iout) + call read_dfa_info + write (iout,*) 'read_dfa_info finished!' + call flush(iout) + endif +#endif + call card_concat(controlcard,.false.) + +c 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) + write (iout,*) "tor_mode",tor_mode + call flush(iout) + if (tor_mode.eq.0) + & 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_ene + 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)) + +c +c Read the virtual-bond parameters, masses, and moments of inertia +c and Stokes' radii of the peptide group and side chains +c +#ifdef CRYST_BOND + read (ibond,*,end=121,err=121) vbldp0,vbldpdum,akp,mp,ip,pstok + do i=1,ntyp + nbondterm(i)=1 + read (ibond,*,end=121,err=121) 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,*,end=121,err=121) ijunk,vbldp0,vbldpdum,akp,rjunk, + & mp,ip,pstok + do i=1,ntyp + read (ibond,*,end=121,err=121) 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/)')"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 +c write (iout,*) "iliptranpar",iliptranpar +c write (iout,*) "liptranname ",liptranname + read(iliptranpar,*,end=1161,err=1161) pepliptran + do i=1,ntyp + read(iliptranpar,*,end=1161,err=1161) liptranene(i) + enddo + rewind iliptranpar + if (lprint) then + write (iout,'(/a)') "Water-lipid transfer parameters" + write (iout,'(a3,3x,f10.5)') 'p',pepliptran + do i=1,ntyp + write (iout,'(a3,3x,f10.5)') restyp(i),liptranene(i) + enddo + endif +#ifdef CRYST_THETA +C +C Read the parameters of the probability distribution/energy expression +C of the virtual-bond valence angles theta +C + do i=1,ntyp + read (ithep,*,end=111,err=111) a0thet(i),(athet(j,i,1,1),j=1,2), + & (bthet(j,i,1,1),j=1,2) + read (ithep,*,end=111,err=111) (polthet(j,i),j=0,3) + read (ithep,*,end=111,err=111) (gthet(j,i),j=1,3) + read (ithep,*,end=111,err=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 +c write (iout,'(a)') +c & 'Parameters of the virtual-bond valence angles:' +c write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:', +c & ' ATHETA0 ',' A1 ',' A2 ', +c & ' B1 ',' B2 ' +c do i=1,ntyp +c write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, +c & a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2) +c enddo +c write (iout,'(/a/9x,5a/79(1h-))') +c & 'Parameters of the expression for sigma(theta_c):', +c & ' ALPH0 ',' ALPH1 ',' ALPH2 ', +c & ' ALPH3 ',' SIGMA0C ' +c do i=1,ntyp +c write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, +c & (polthet(j,i),j=0,3),sigc0(i) +c enddo +c write (iout,'(/a/9x,5a/79(1h-))') +c & 'Parameters of the second gaussian:', +c & ' THETA0 ',' SIGMA0 ',' G1 ', +c & ' G2 ',' G3 ' +c do i=1,ntyp +c write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i), +c & sig0(i),(gthet(j,i),j=1,3) +c 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 + IF (tor_mode.eq.0) THEN +C +C Read the parameters of Utheta determined from ab initio surfaces +C Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +C + read (ithep,*,end=111,err=111) nthetyp,ntheterm,ntheterm2, + & ntheterm3,nsingle,ndouble + nntheterm=max0(ntheterm,ntheterm2,ntheterm3) + read (ithep,*,end=111,err=111) (ithetyp(i),i=1,ntyp1) + do i=-ntyp1,-1 + ithetyp(i)=-ithetyp(-i) + enddo + 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 +C write (iout,*) "KURWA1" + do iblock=1,2 + do i=0,nthetyp + do j=-nthetyp,nthetyp + do k=-nthetyp,nthetyp + read (ithep,'(6a)',end=111,err=111) res1 + write(iout,*) res1,i,j,k + read (ithep,*,end=111,err=111) aa0thet(i,j,k,iblock) + 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 +C write(iout,*) "KURWA1.1" +C +C For dummy ends assign glycine-type coefficients of theta-only terms; the +C coefficients of theta-and-gamma-dependent terms are zero. +C + do i=1,nthetyp + do j=1,nthetyp + do l=1,ntheterm + aathet(l,i,j,nthetyp+1,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 +C write(iout,*) "KURWA1.5" +C 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 + +C +C Control printout of the coefficients of virtual-bond-angle potentials +C + if (lprint) then + write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' + do 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 + enddo + enddo + enddo + enddo + enddo + enddo + call flush(iout) + endif + + ELSE + +C here will be the apropriate recalibrating for D-aminoacid + read (ithep,*,end=111,err=111) nthetyp + do i=-nthetyp+1,nthetyp-1 + read (ithep,*,end=111,err=111) nbend_kcc_Tb(i) + do j=0,nbend_kcc_Tb(i) + read (ithep,*,end=111,err=111) ijunk,v1bend_chyb(j,i) + enddo + enddo + if (lprint) then + write (iout,'(/a)') + & "Parameters of the valence-only potentials" + do i=-nthetyp+1,nthetyp-1 + write (iout,'(2a)') "Type ",toronelet(i) + do k=0,nbend_kcc_Tb(i) + write(iout,'(i5,f15.5)') k,v1bend_chyb(k,i) + enddo + enddo + endif + + ENDIF ! TOR_MODE + + close(ithep) +#endif +C write(iout,*) 'KURWA2' +#ifdef CRYST_SC +C +C Read the parameters of the probability distribution/energy expression +C of the side chains. +C + do i=1,ntyp +cc 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,*,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) +C 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) +c write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi) +c write (iout,'(a,f10.4,4(16x,f10.4))') +c & 'Center ',(bsc(j,i),j=1,nlobi) +c 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) +c write (iout,'(a)') +c do j=1,nlobi +c ind=0 +c do k=1,3 +c do l=1,k +c ind=ind+1 +c blower(k,l,j)=gaussc(ind,j,i) +c enddo +c enddo +c 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 +C +C Read scrot parameters for potentials determined from all-atom AM1 calculations +C added by Urszula Kozlowska 07/11/2007 +C + do i=1,ntyp + read (irotam,*,end=112,err=112) + if (i.eq.10) then + read (irotam,*,end=112,err=112) + else + do j=1,65 + read(irotam,*,end=112,err=112) sc_parmin(j,i) + enddo + endif + enddo +#endif + close(irotam) +C +C 9/18/99 (AL) Read coefficients of the Fourier expansion of the local +C interaction energy of the Gly, Ala, and Pro prototypes. +C + read (ifourier,*,end=115,err=115) nloctyp + SPLIT_FOURIERTOR = nloctyp.lt.0 + nloctyp = iabs(nloctyp) +#ifdef NEWCORR + read (ifourier,*,end=115,err=115) (itype2loc(i),i=1,ntyp) + read (ifourier,*,end=115,err=115) (iloctyp(i),i=0,nloctyp-1) + itype2loc(ntyp1)=nloctyp + iloctyp(nloctyp)=ntyp1 + do i=1,ntyp1 + itype2loc(-i)=-itype2loc(i) + enddo +#else + iloctyp(0)=10 + iloctyp(1)=9 + iloctyp(2)=20 + iloctyp(3)=ntyp1 +#endif + do i=1,nloctyp + iloctyp(-i)=-iloctyp(i) + enddo +c write (iout,*) "itype2loc",(itype2loc(i),i=1,ntyp1) +c write (iout,*) "nloctyp",nloctyp, +c & " iloctyp",(iloctyp(i),i=0,nloctyp) +#ifdef NEWCORR + do i=0,nloctyp-1 +c write (iout,*) "NEWCORR",i + read (ifourier,*,end=115,err=115) + do ii=1,3 + do j=1,2 + read (ifourier,*,end=115,err=115) bnew1(ii,j,i) + enddo + enddo +c write (iout,*) "NEWCORR BNEW1" +c write (iout,*) ((bnew1(ii,j,i),ii=1,3),j=1,2) + do ii=1,3 + do j=1,2 + read (ifourier,*,end=115,err=115) bnew2(ii,j,i) + enddo + enddo +c write (iout,*) "NEWCORR BNEW2" +c write (iout,*) ((bnew2(ii,j,i),ii=1,3),j=1,2) + do kk=1,3 + read (ifourier,*,end=115,err=115) ccnew(kk,1,i) + read (ifourier,*,end=115,err=115) ccnew(kk,2,i) + enddo +c write (iout,*) "NEWCORR CCNEW" +c write (iout,*) ((ccnew(ii,j,i),ii=1,3),j=1,2) + do kk=1,3 + read (ifourier,*,end=115,err=115) ddnew(kk,1,i) + read (ifourier,*,end=115,err=115) ddnew(kk,2,i) + enddo +c write (iout,*) "NEWCORR DDNEW" +c write (iout,*) ((ddnew(ii,j,i),ii=1,3),j=1,2) + do ii=1,2 + do jj=1,2 + do kk=1,2 + read (ifourier,*,end=115,err=115) eenew(ii,jj,kk,i) + enddo + enddo + enddo +c write (iout,*) "NEWCORR EENEW1" +c write(iout,*)(((eenew(ii,jj,kk,i),kk=1,2),jj=1,2),ii=1,2) + do ii=1,3 + read (ifourier,*,end=115,err=115) e0new(ii,i) + enddo +c write (iout,*) (e0new(ii,i),ii=1,3) + enddo +c write (iout,*) "NEWCORR EENEW" + do i=0,nloctyp-1 + do ii=1,3 + ccnew(ii,1,i)=ccnew(ii,1,i)/2 + ccnew(ii,2,i)=ccnew(ii,2,i)/2 + ddnew(ii,1,i)=ddnew(ii,1,i)/2 + ddnew(ii,2,i)=ddnew(ii,2,i)/2 + enddo + enddo + do i=1,nloctyp-1 + do ii=1,3 + bnew1(ii,1,-i)= bnew1(ii,1,i) + bnew1(ii,2,-i)=-bnew1(ii,2,i) + bnew2(ii,1,-i)= bnew2(ii,1,i) + bnew2(ii,2,-i)=-bnew2(ii,2,i) + enddo + do ii=1,3 +c ccnew(ii,1,i)=ccnew(ii,1,i)/2 +c ccnew(ii,2,i)=ccnew(ii,2,i)/2 +c ddnew(ii,1,i)=ddnew(ii,1,i)/2 +c ddnew(ii,2,i)=ddnew(ii,2,i)/2 + ccnew(ii,1,-i)=ccnew(ii,1,i) + ccnew(ii,2,-i)=-ccnew(ii,2,i) + ddnew(ii,1,-i)=ddnew(ii,1,i) + ddnew(ii,2,-i)=-ddnew(ii,2,i) + enddo + e0new(1,-i)= e0new(1,i) + e0new(2,-i)=-e0new(2,i) + e0new(3,-i)=-e0new(3,i) + do kk=1,2 + eenew(kk,1,1,-i)= eenew(kk,1,1,i) + eenew(kk,1,2,-i)=-eenew(kk,1,2,i) + eenew(kk,2,1,-i)=-eenew(kk,2,1,i) + eenew(kk,2,2,-i)= eenew(kk,2,2,i) + enddo + enddo + if (lprint) then + write (iout,'(a)') "Coefficients of the multibody terms" + do i=-nloctyp+1,nloctyp-1 + write (iout,*) "Type: ",onelet(iloctyp(i)) + write (iout,*) "Coefficients of the expansion of B1" + do j=1,2 + write (iout,'(3hB1(,i1,1h),3f10.5)') j,(bnew1(k,j,i),k=1,3) + enddo + write (iout,*) "Coefficients of the expansion of B2" + do j=1,2 + write (iout,'(3hB2(,i1,1h),3f10.5)') j,(bnew2(k,j,i),k=1,3) + enddo + write (iout,*) "Coefficients of the expansion of C" + write (iout,'(3hC11,3f10.5)') (ccnew(j,1,i),j=1,3) + write (iout,'(3hC12,3f10.5)') (ccnew(j,2,i),j=1,3) + write (iout,*) "Coefficients of the expansion of D" + write (iout,'(3hD11,3f10.5)') (ddnew(j,1,i),j=1,3) + write (iout,'(3hD12,3f10.5)') (ddnew(j,2,i),j=1,3) + write (iout,*) "Coefficients of the expansion of E" + write (iout,'(2hE0,3f10.5)') (e0new(j,i),j=1,3) + do j=1,2 + do k=1,2 + write (iout,'(1hE,2i1,2f10.5)') j,k,(eenew(l,j,k,i),l=1,2) + enddo + enddo + enddo + endif + IF (SPLIT_FOURIERTOR) THEN + do i=0,nloctyp-1 +c write (iout,*) "NEWCORR TOR",i + read (ifourier,*,end=115,err=115) + do ii=1,3 + do j=1,2 + read (ifourier,*,end=115,err=115) bnew1tor(ii,j,i) + enddo + enddo +c write (iout,*) "NEWCORR BNEW1 TOR" +c write (iout,*) ((bnew1tor(ii,j,i),ii=1,3),j=1,2) + do ii=1,3 + do j=1,2 + read (ifourier,*,end=115,err=115) bnew2tor(ii,j,i) + enddo + enddo +c write (iout,*) "NEWCORR BNEW2 TOR" +c write (iout,*) ((bnew2tor(ii,j,i),ii=1,3),j=1,2) + do kk=1,3 + read (ifourier,*,end=115,err=115) ccnewtor(kk,1,i) + read (ifourier,*,end=115,err=115) ccnewtor(kk,2,i) + enddo +c write (iout,*) "NEWCORR CCNEW TOR" +c write (iout,*) ((ccnew(ii,j,i),ii=1,3),j=1,2) + do kk=1,3 + read (ifourier,*,end=115,err=115) ddnewtor(kk,1,i) + read (ifourier,*,end=115,err=115) ddnewtor(kk,2,i) + enddo +c write (iout,*) "NEWCORR DDNEW TOR" +c write (iout,*) ((ddnewtor(ii,j,i),ii=1,3),j=1,2) + do ii=1,2 + do jj=1,2 + do kk=1,2 + read (ifourier,*,end=115,err=115) eenewtor(ii,jj,kk,i) + enddo + enddo + enddo +c write (iout,*) "NEWCORR EENEW1 TOR" +c write(iout,*)(((eenewtor(ii,jj,kk,i),kk=1,2),jj=1,2),ii=1,2) + do ii=1,3 + read (ifourier,*,end=115,err=115) e0newtor(ii,i) + enddo +c write (iout,*) (e0newtor(ii,i),ii=1,3) + enddo +c write (iout,*) "NEWCORR EENEW TOR" + do i=0,nloctyp-1 + do ii=1,3 + ccnewtor(ii,1,i)=ccnewtor(ii,1,i)/2 + ccnewtor(ii,2,i)=ccnewtor(ii,2,i)/2 + ddnewtor(ii,1,i)=ddnewtor(ii,1,i)/2 + ddnewtor(ii,2,i)=ddnewtor(ii,2,i)/2 + enddo + enddo + do i=1,nloctyp-1 + do ii=1,3 + bnew1tor(ii,1,-i)= bnew1tor(ii,1,i) + bnew1tor(ii,2,-i)=-bnew1tor(ii,2,i) + bnew2tor(ii,1,-i)= bnew2tor(ii,1,i) + bnew2tor(ii,2,-i)=-bnew2tor(ii,2,i) + enddo + do ii=1,3 + ccnewtor(ii,1,-i)=ccnewtor(ii,1,i) + ccnewtor(ii,2,-i)=-ccnewtor(ii,2,i) + ddnewtor(ii,1,-i)=ddnewtor(ii,1,i) + ddnewtor(ii,2,-i)=-ddnewtor(ii,2,i) + enddo + e0newtor(1,-i)= e0newtor(1,i) + e0newtor(2,-i)=-e0newtor(2,i) + e0newtor(3,-i)=-e0newtor(3,i) + do kk=1,2 + eenewtor(kk,1,1,-i)= eenewtor(kk,1,1,i) + eenewtor(kk,1,2,-i)=-eenewtor(kk,1,2,i) + eenewtor(kk,2,1,-i)=-eenewtor(kk,2,1,i) + eenewtor(kk,2,2,-i)= eenewtor(kk,2,2,i) + enddo + enddo + if (lprint) then + write (iout,'(a)') + & "Single-body coefficients of the torsional potentials" + do i=-nloctyp+1,nloctyp-1 + write (iout,*) "Type: ",onelet(iloctyp(i)) + write (iout,*) "Coefficients of the expansion of B1tor" + do j=1,2 + write (iout,'(3hB1(,i1,1h),3f10.5)') + & j,(bnew1tor(k,j,i),k=1,3) + enddo + write (iout,*) "Coefficients of the expansion of B2tor" + do j=1,2 + write (iout,'(3hB2(,i1,1h),3f10.5)') + & j,(bnew2tor(k,j,i),k=1,3) + enddo + write (iout,*) "Coefficients of the expansion of Ctor" + write (iout,'(3hC11,3f10.5)') (ccnewtor(j,1,i),j=1,3) + write (iout,'(3hC12,3f10.5)') (ccnewtor(j,2,i),j=1,3) + write (iout,*) "Coefficients of the expansion of Dtor" + write (iout,'(3hD11,3f10.5)') (ddnewtor(j,1,i),j=1,3) + write (iout,'(3hD12,3f10.5)') (ddnewtor(j,2,i),j=1,3) + write (iout,*) "Coefficients of the expansion of Etor" + write (iout,'(2hE0,3f10.5)') (e0newtor(j,i),j=1,3) + do j=1,2 + do k=1,2 + write (iout,'(1hE,2i1,2f10.5)') + & j,k,(eenewtor(l,j,k,i),l=1,2) + enddo + enddo + enddo + endif + ELSE + do i=-nloctyp+1,nloctyp-1 + do ii=1,3 + do j=1,2 + bnew1tor(ii,j,i)=bnew1(ii,j,i) + enddo + enddo + do ii=1,3 + do j=1,2 + bnew2tor(ii,j,i)=bnew2(ii,j,i) + enddo + enddo + do ii=1,3 + ccnewtor(ii,1,i)=ccnew(ii,1,i) + ccnewtor(ii,2,i)=ccnew(ii,2,i) + ddnewtor(ii,1,i)=ddnew(ii,1,i) + ddnewtor(ii,2,i)=ddnew(ii,2,i) + enddo + enddo + ENDIF !SPLIT_FOURIER_TOR +#else + if (lprint) + & write (iout,*) "Coefficients of the expansion of Eloc(l1,l2)" + do i=0,nloctyp-1 + read (ifourier,*,end=115,err=115) + read (ifourier,*,end=115,err=115) (b(ii,i),ii=1,13) + if (lprint) then + write (iout,*) 'Type ',onelet(iloctyp(i)) + write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii,i),ii=1,13) + endif + if (i.gt.0) then + b(2,-i)= b(2,i) + b(3,-i)= b(3,i) + b(4,-i)=-b(4,i) + b(5,-i)=-b(5,i) + endif +c B1(1,i) = b(3) +c B1(2,i) = b(5) +c B1(1,-i) = b(3) +c B1(2,-i) = -b(5) +c b1(1,i)=0.0d0 +c b1(2,i)=0.0d0 +c B1tilde(1,i) = b(3) +c B1tilde(2,i) =-b(5) +c B1tilde(1,-i) =-b(3) +c B1tilde(2,-i) =b(5) +c b1tilde(1,i)=0.0d0 +c b1tilde(2,i)=0.0d0 +c B2(1,i) = b(2) +c B2(2,i) = b(4) +c B2(1,-i) =b(2) +c B2(2,-i) =-b(4) +cc B1tilde(1,i) = b(3,i) +cc B1tilde(2,i) =-b(5,i) +C B1tilde(1,-i) =-b(3,i) +C B1tilde(2,-i) =b(5,i) +cc b1tilde(1,i)=0.0d0 +cc b1tilde(2,i)=0.0d0 +cc B2(1,i) = b(2,i) +cc B2(2,i) = b(4,i) +C B2(1,-i) =b(2,i) +C B2(2,-i) =-b(4,i) + +c b2(1,i)=0.0d0 +c b2(2,i)=0.0d0 + CCold(1,1,i)= b(7,i) + CCold(2,2,i)=-b(7,i) + CCold(2,1,i)= b(9,i) + CCold(1,2,i)= b(9,i) + CCold(1,1,-i)= b(7,i) + CCold(2,2,-i)=-b(7,i) + CCold(2,1,-i)=-b(9,i) + CCold(1,2,-i)=-b(9,i) +c CC(1,1,i)=0.0d0 +c CC(2,2,i)=0.0d0 +c CC(2,1,i)=0.0d0 +c CC(1,2,i)=0.0d0 +c Ctilde(1,1,i)= CCold(1,1,i) +c Ctilde(1,2,i)= CCold(1,2,i) +c Ctilde(2,1,i)=-CCold(2,1,i) +c Ctilde(2,2,i)=-CCold(2,2,i) + +c Ctilde(1,1,i)=0.0d0 +c Ctilde(1,2,i)=0.0d0 +c Ctilde(2,1,i)=0.0d0 +c Ctilde(2,2,i)=0.0d0 + DDold(1,1,i)= b(6,i) + DDold(2,2,i)=-b(6,i) + DDold(2,1,i)= b(8,i) + DDold(1,2,i)= b(8,i) + DDold(1,1,-i)= b(6,i) + DDold(2,2,-i)=-b(6,i) + DDold(2,1,-i)=-b(8,i) + DDold(1,2,-i)=-b(8,i) +c DD(1,1,i)=0.0d0 +c DD(2,2,i)=0.0d0 +c DD(2,1,i)=0.0d0 +c DD(1,2,i)=0.0d0 +c Dtilde(1,1,i)= DD(1,1,i) +c Dtilde(1,2,i)= DD(1,2,i) +c Dtilde(2,1,i)=-DD(2,1,i) +c Dtilde(2,2,i)=-DD(2,2,i) + +c Dtilde(1,1,i)=0.0d0 +c Dtilde(1,2,i)=0.0d0 +c Dtilde(2,1,i)=0.0d0 +c Dtilde(2,2,i)=0.0d0 + EEold(1,1,i)= b(10,i)+b(11,i) + EEold(2,2,i)=-b(10,i)+b(11,i) + EEold(2,1,i)= b(12,i)-b(13,i) + EEold(1,2,i)= b(12,i)+b(13,i) + EEold(1,1,-i)= b(10,i)+b(11,i) + EEold(2,2,-i)=-b(10,i)+b(11,i) + EEold(2,1,-i)=-b(12,i)+b(13,i) + EEold(1,2,-i)=-b(12,i)-b(13,i) + write(iout,*) "TU DOCHODZE" + print *,"JESTEM" +c ee(1,1,i)=1.0d0 +c ee(2,2,i)=1.0d0 +c ee(2,1,i)=0.0d0 +c ee(1,2,i)=0.0d0 +c ee(2,1,i)=ee(1,2,i) + enddo + if (lprint) then + write (iout,*) + write (iout,*) + &"Coefficients of the cumulants (independent of valence angles)" + do i=-nloctyp+1,nloctyp-1 + write (iout,*) 'Type ',onelet(iloctyp(i)) + write (iout,*) 'B1' + write(iout,'(2f10.5)') B(3,i),B(5,i) + write (iout,*) 'B2' + write(iout,'(2f10.5)') B(2,i),B(4,i) + write (iout,*) 'CC' + do j=1,2 + write (iout,'(2f10.5)') CCold(j,1,i),CCold(j,2,i) + enddo + write(iout,*) 'DD' + do j=1,2 + write (iout,'(2f10.5)') DDold(j,1,i),DDold(j,2,i) + enddo + write(iout,*) 'EE' + do j=1,2 + write (iout,'(2f10.5)') EEold(j,1,i),EEold(j,2,i) + enddo + enddo + endif +#endif +C write (iout,*) 'KURWAKURWA' +#ifdef CRYST_TOR +C +C Read torsional parameters in old format +C + read (itorp,*,end=113,err=113) ntortyp,nterm_old + write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + do i=1,ntortyp + do j=1,ntortyp + read (itorp,'(a)',end=113,err=113) + do k=1,nterm_old + read (itorp,*,end=113,err=113) kk,v1(k,j,i),v2(k,j,i) + enddo + enddo + enddo + close (itorp) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do i=1,ntortyp + do j=1,ntortyp + write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) + write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) + enddo + enddo + endif +#else +C +C Read torsional parameters +C + IF (TOR_MODE.eq.0) THEN + + read (itorp,*,end=113,err=113) ntortyp + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + do i=1,ntyp1 + itype2loc(i)=itortyp(i) + enddo + write (iout,*) 'ntortyp',ntortyp + do i=1,ntyp1 + itype2loc(-i)=-itype2loc(i) + enddo + itortyp(ntyp1)=ntortyp + do iblock=1,2 + do i=-ntyp,-1 + itortyp(i)=-itortyp(-i) + enddo +c 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 + 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 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 + endif +C +C 6/23/01 Read parameters for double torsionals +C + 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 +c write (iout,*) "OK onelett", +c & 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)) +C 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) +c write(iout,*) "whcodze" , +c & 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)) +C 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 + + ELSE IF (TOR_MODE.eq.1) THEN + +C read valence-torsional parameters + read (itorp,*,end=113,err=113) ntortyp + nkcctyp=ntortyp + write (iout,*) "Valence-torsional parameters read in ntortyp", + & ntortyp + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + write (iout,*) "itortyp_kcc",(itortyp(i),i=1,ntyp) + do i=-ntyp,-1 + itortyp(i)=-itortyp(-i) + enddo + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 +C first we read the cos and sin gamma parameters + read (itorp,'(13x,a)',end=113,err=113) string + write (iout,*) i,j,string + read (itorp,*,end=113,err=113) + & nterm_kcc(j,i),nterm_kcc_Tb(j,i) +C read (itorkcc,*,end=121,err=121) nterm_kcc_Tb(j,i) + do k=1,nterm_kcc(j,i) + do l=1,nterm_kcc_Tb(j,i) + do ll=1,nterm_kcc_Tb(j,i) + read (itorp,*,end=113,err=113) ii,jj,kk, + & v1_kcc(ll,l,k,j,i),v2_kcc(ll,l,k,j,i) + enddo + enddo + enddo + enddo + enddo + + ELSE +c AL 4/8/16: Calculate coefficients from one-body parameters + ntortyp=nloctyp + do i=-ntyp1,ntyp1 + itortyp(i)=itype2loc(i) + enddo + if (lprint) write (iout,*) + &"Val-tor parameters calculated from cumulant coefficients ntortyp" + & ,ntortyp + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + nterm_kcc(j,i)=2 + nterm_kcc_Tb(j,i)=3 + do k=1,nterm_kcc_Tb(j,i) + do l=1,nterm_kcc_Tb(j,i) + v1_kcc(k,l,1,i,j)=bnew1tor(k,1,i)*bnew2tor(l,1,j) + & +bnew1tor(k,2,i)*bnew2tor(l,2,j) + v2_kcc(k,l,1,i,j)=bnew1tor(k,1,i)*bnew2tor(l,2,j) + & +bnew1tor(k,2,i)*bnew2tor(l,1,j) + enddo + enddo + do k=1,nterm_kcc_Tb(j,i) + do l=1,nterm_kcc_Tb(j,i) +#ifdef CORRCD + v1_kcc(k,l,2,i,j)=-(ccnewtor(k,1,i)*ddnewtor(l,1,j) + & -ccnewtor(k,2,i)*ddnewtor(l,2,j)) + v2_kcc(k,l,2,i,j)=-(ccnewtor(k,2,i)*ddnewtor(l,1,j) + & +ccnewtor(k,1,i)*ddnewtor(l,2,j)) +#else + v1_kcc(k,l,2,i,j)=-0.25*(ccnewtor(k,1,i)*ddnewtor(l,1,j) + & -ccnewtor(k,2,i)*ddnewtor(l,2,j)) + v2_kcc(k,l,2,i,j)=-0.25*(ccnewtor(k,2,i)*ddnewtor(l,1,j) + & +ccnewtor(k,1,i)*ddnewtor(l,2,j)) +#endif + enddo + enddo +cf(theta,gamma)=-(b21(theta)*b11(theta)+b12(theta)*b22(theta))*cos(gamma)-(b22(theta)*b11(theta)+b21(theta)*b12(theta))*sin(gamma)+(c11(theta)*d11(theta)-c12(theta)*d12(theta))*cos(2*gamma)+(c12(theta)*d11(theta)+c11(theta)*d12(theta))*sin(2*gamma) + enddo + enddo + + ENDIF ! TOR_MODE + + if (tor_mode.gt.0 .and. lprint) then +c Print valence-torsional parameters + write (iout,'(/a)') + & "Parameters of the valence-torsional potentials" + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + write (iout,'(3a)') "Type ",toronelet(i),toronelet(j) + write (iout,'(3a5,2a15)') "itor","ival","jval","v_kcc","v2_kcc" + do k=1,nterm_kcc(j,i) + do l=1,nterm_kcc_Tb(j,i) + do ll=1,nterm_kcc_Tb(j,i) + write (iout,'(3i5,2f15.4)') + & k,l-1,ll-1,v1_kcc(ll,l,k,j,i),v2_kcc(ll,l,k,j,i) + enddo + enddo + enddo + enddo + enddo + endif + +#endif +C Read of Side-chain backbone correlation parameters +C Modified 11 May 2012 by Adasko +CCC +C + read (isccor,*,end=119,err=119) nsccortyp + read (isccor,*,end=119,err=119) (isccortyp(i),i=1,ntyp) + do i=-ntyp,-1 + isccortyp(i)=-isccortyp(-i) + enddo + iscprol=isccortyp(20) +c write (iout,*) 'ntortyp',ntortyp + maxinter=3 +cc maxinter is maximum interaction sites + do l=1,maxinter + do i=1,nsccortyp + do j=1,nsccortyp + read (isccor,*,end=119,err=119) + &nterm_sccor(i,j),nlor_sccor(i,j) +c write (iout,*) nterm_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) +c write (iout,*) nterm_sccor(i,j),nterm_sccor(-i,j), +c & 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) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants of SCCORR:' + do l=1,maxinter + 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 + enddo + endif +C +C Read electrostatic-interaction parameters +C + 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,*,end=116,err=116) ((epp(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((rpp(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((elpp6(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((elpp3(i,j),j=1,2),i=1,2) + close (ielep) + do i=1,2 + do j=1,2 + rri=rpp(i,j)**6 + app (i,j)=epp(i,j)*rri*rri + bpp (i,j)=-2.0D0*epp(i,j)*rri + ael6(i,j)=elpp6(i,j)*4.2D0**6 + ael3(i,j)=elpp3(i,j)*4.2D0**3 + if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j), + & ael6(i,j),ael3(i,j) + enddo + enddo +C +C Read side-chain interaction parameters. +C + read (isidep,*,end=117,err=117) ipot,expon + if (ipot.lt.1 .or. ipot.gt.5) then + write (iout,'(2a)') 'Error while reading SC interaction', + & 'potential file - unknown potential type.' + stop + endif + expon2=expon/2 + write(iout,'(/3a,2i3)') 'Potential is ',potname(ipot), + & ', exponents are ',expon,2*expon + goto (10,20,30,30,40) ipot +C----------------------- LJ potential --------------------------------- + 10 read (isidep,*,end=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 +C----------------------- LJK potential -------------------------------- + 20 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 +C---------------------- GB or BP potential ----------------------------- + 30 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) + do i=1,ntyp + read (isidep,*,end=117,err=117)(epslip(i,j),j=i,ntyp) +C write(iout,*) "WARNING!!",i,ntyp + if (lprint) write(iout,*) "epslip", i, (epslip(i,j),j=i,ntyp) +C do j=1,ntyp +C epslip(i,j)=epslip(i,j)+0.05d0 +C enddo + enddo +C For the GB potential convert sigma'**2 into chi' + if (ipot.eq.4) then + do i=1,ntyp + chip(i)=(chip(i)-1.0D0)/(chip(i)+1.0D0) + enddo + endif + if (lprint) then + write (iout,'(/a/)') 'Parameters of the BP potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,4a)') 'residue',' sigma ','s||/s_|_^2', + & ' chip ',' alph ' + write (iout,'(a3,6x,4f10.5)') (restyp(i),sigma0(i),sigii(i), + & chip(i),alp(i),i=1,ntyp) + endif + goto 50 +C--------------------- GBV potential ----------------------------------- + 40 read (isidep,*,end=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 + 50 continue + close (isidep) +C----------------------------------------------------------------------- +C Calculate the "working" parameters of SC interactions. + do i=2,ntyp + do j=1,i-1 + eps(i,j)=eps(j,i) + epslip(i,j)=epslip(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) + epsijlip=epslip(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_aq(i,j)=epsij*rrij*rrij + bb_aq(i,j)=-sigeps*epsij*rrij + aa_aq(j,i)=aa_aq(i,j) + bb_aq(j,i)=bb_aq(i,j) + sigeps=dsign(1.0D0,epsijlip) + epsijlip=dabs(epsijlip) + aa_lip(i,j)=epsijlip*rrij*rrij + bb_lip(i,j)=-sigeps*epsijlip*rrij + aa_lip(j,i)=aa_lip(i,j) + bb_lip(j,i)=bb_lip(i,j) + if (ipot.gt.2) then + sigt1sq=sigma0(i)**2 + sigt2sq=sigma0(j)**2 + sigii1=sigii(i) + sigii2=sigii(j) + ratsig1=sigt2sq/sigt1sq + ratsig2=1.0D0/ratsig1 + chi(i,j)=(sigii1-1.0D0)/(sigii1+ratsig1) + if (j.gt.i) chi(j,i)=(sigii2-1.0D0)/(sigii2+ratsig2) + rsum_max=dsqrt(sigii1*sigt1sq+sigii2*sigt2sq) + else + rsum_max=sigma(i,j) + endif +c if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then + sigmaii(i,j)=rsum_max + sigmaii(j,i)=rsum_max +c else +c sigmaii(i,j)=r0(i,j) +c sigmaii(j,i)=r0(i,j) +c endif +cd write (iout,*) i,j,r0(i,j),sigma(i,j),rsum_max + if ((ipot.eq.2 .or. ipot.eq.5) .and. r0(i,j).gt.rsum_max) then + r_augm=sigma(i,j)*(rrij-sigma(i,j))/rrij + augm(i,j)=epsij*r_augm**(2*expon) +c augm(i,j)=0.5D0**(2*expon)*aa(i,j) + augm(j,i)=augm(i,j) + else + augm(i,j)=0.0D0 + augm(j,i)=0.0D0 + endif + if (lprint) then + write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') + & restyp(i),restyp(j),aa_aq(i,j),bb_aq(i,j),augm(i,j), + & sigma(i,j),r0(i,j),chi(i,j),chi(j,i) + endif + enddo + enddo +C +C Define the SC-p interaction constants +C +#ifdef OLDSCP + do i=1,20 +C "Soft" SC-p repulsion (causes helices to be too flat, but facilitates +C helix formation) +c aad(i,1)=0.3D0*4.0D0**12 +C Following line for constants currently implemented +C "Hard" SC-p repulsion (gives correct turn spacing in helices) + aad(i,1)=1.5D0*4.0D0**12 +c aad(i,1)=0.17D0*5.6D0**12 + aad(i,2)=aad(i,1) +C "Soft" SC-p repulsion + bad(i,1)=0.0D0 +C Following line for constants currently implemented +c aad(i,1)=0.3D0*4.0D0**6 +C "Hard" SC-p repulsion + bad(i,1)=3.0D0*4.0D0**6 +c bad(i,1)=-2.0D0*0.17D0*5.6D0**6 + bad(i,2)=bad(i,1) +c aad(i,1)=0.0D0 +c aad(i,2)=0.0D0 +c bad(i,1)=1228.8D0 +c bad(i,2)=1228.8D0 + enddo +#else +C +C 8/9/01 Read the SC-p interaction constants from file +C + do i=1,ntyp + read (iscpp,*,end=118,err=118) (eps_scp(i,j),rscp(i,j),j=1,2) + enddo + do i=1,ntyp + aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12 + aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12 + bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6 + bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6 + enddo + + if (lprint) then + write (iout,'(/a)') "Parameters of SC-p interactions:" + do i=1,20 + write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1), + & eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) + enddo + endif +#endif +C +C Define the constants of the disulfide bridge +C +C ebr=-12.0D0 +c +c Old arbitrary potential - commented out. +c +c dbr= 4.20D0 +c fbr= 3.30D0 +c +c Constants of the disulfide-bond potential determined based on the RHF/6-31G** +c energy surface of diethyl disulfide. +c A. Liwo and U. Kozlowska, 11/24/03 +c +C D0CM = 3.78d0 +C AKCM = 15.1d0 +C AKTH = 11.0d0 +C AKCT = 12.0d0 +C V1SS =-1.08d0 +C V2SS = 7.61d0 +C V3SS = 13.7d0 + if (dyn_ss) + & write (iout,*) 'Dynamic formation/breaking of disulfides' + if (dyn_ss) then + ss_depth=ebr/wsc-0.25*eps(1,1) +C write(iout,*) akcm,whpb,wsc,'KURWA' + Ht=Ht/wsc-0.25*eps(1,1) + + akcm=akcm*whpb/wsc + akth=akth*whpb/wsc + akct=akct*whpb/wsc + v1ss=v1ss*whpb/wsc + v2ss=v2ss*whpb/wsc + v3ss=v3ss*whpb/wsc + else + ss_depth=ebr/whpb-0.25*eps(1,1)*wsc/whpb + endif + +C if (lprint) then + 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 + write (iout,'(a)') "Parameters of the 'trisulfide' potential" + write(iout,*) "ATRISS",atriss + write(iout,*) "BTRISS",btriss + write(iout,*) "CTRISS",ctriss + write(iout,*) "DTRISS",dtriss + endif +C endif + if (shield_mode.gt.0) then + pi=3.141592d0 +C VSolvSphere the volume of solving sphere +C print *,pi,"pi" +C rpp(1,1) is the energy r0 for peptide group contact and will be used for it +C there will be no distinction between proline peptide group and normal peptide +C group in case of shielding parameters + VSolvSphere=4.0/3.0*pi*rpp(1,1)**3 + VSolvSphere_div=VSolvSphere-4.0/3.0*pi*(rpp(1,1)/2.0)**3 + write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div", + & VSolvSphere_div +C long axis of side chain + do i=1,ntyp + long_r_sidechain(i)=vbldsc0(1,i) + short_r_sidechain(i)=sigma0(i) + enddo + buff_shield=1.0d0 + 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 + 1161 write (iout,*) "Error reading lipid 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" + goto 999 + 121 write (iout,*) "Error reading bond parameters" + 999 continue +#ifdef MPI + call MPI_Finalize(Ierror) +#endif + stop + return + end diff --git a/source/wham/src-HCD/parmread.F.safe b/source/wham/src-HCD/parmread.F.safe new file mode 100644 index 0000000..38f8997 --- /dev/null +++ b/source/wham/src-HCD/parmread.F.safe @@ -0,0 +1,1651 @@ + subroutine parmread(iparm,*) +C +C Read the parameters of the probability distributions of the virtual-bond +C valence angles and the side chains and energy parameters. +C + 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' + include 'COMMON.SHIELD' + include 'COMMON.CONTROL' + character*1 t1,t2,t3 + character*1 onelett(4) /"G","A","P","D"/ + character*1 toronelet(-2:2) /"p","a","G","A","P"/ + logical lprint + dimension blower(3,3,maxlob) + character*800 controlcard + character*256 bondname_t,thetname_t,rotname_t,torname_t, + & tordname_t,fouriername_t,elename_t,sidename_t,scpname_t, + & sccorname_t + integer ilen + external ilen + character*16 key + integer iparm + double precision ip,mp + character*6 res1 + character*3 lancuch,ucase +C write (iout,*) "KURWA" +C +C Body +C + call getenv("PRINT_PARM",lancuch) + lprint = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") + write (iout,*) "lprint ",lprint +C Set LPRINT=.TRUE. for debugging + dwa16=2.0d0**(1.0d0/6.0d0) + itypro=20 +C Assign virtual-bond length + vbl=3.8D0 + vblinv=1.0D0/vbl + vblinv2=vblinv*vblinv + call card_concat(controlcard,.true.) + wname(4)="WCORRH" + do i=1,n_ene + key = wname(i)(:ilen(wname(i))) + call reada(controlcard,key(:ilen(key)),ww(i),1.0d0) + enddo + + write (iout,*) "iparm",iparm," myparm",myparm +c If reading not own parameters, skip assignment + call reada(controlcard,"D0CM",d0cm,3.78d0) + call reada(controlcard,"AKCM",akcm,15.1d0) + call reada(controlcard,"AKTH",akth,11.0d0) + call reada(controlcard,"AKCT",akct,12.0d0) + call reada(controlcard,"V1SS",v1ss,-1.08d0) + call reada(controlcard,"V2SS",v2ss,7.61d0) + call reada(controlcard,"V3SS",v3ss,13.7d0) + call reada(controlcard,"EBR",ebr,-5.50D0) + call reada(controlcard,"DTRISS",dtriss,1.0D0) + call reada(controlcard,"ATRISS",atriss,0.3D0) + call reada(controlcard,"BTRISS",btriss,0.02D0) + call reada(controlcard,"CTRISS",ctriss,1.0D0) + dyn_ss=(index(controlcard,'DYN_SS').gt.0) + write(iout,*) "ATRISS",atriss + write(iout,*) "BTRISS",btriss + write(iout,*) "CTRISS",ctriss + write(iout,*) "DTRISS",dtriss + +C do i=1,maxres +C dyn_ss_mask(i)=.false. +C enddo +C ebr=-12.0D0 +c +c Old arbitrary potential - commented out. +c +c dbr= 4.20D0 +c fbr= 3.30D0 +c +c Constants of the disulfide-bond potential determined based on the RHF/6-31G** +c energy surface of diethyl disulfide. +c A. Liwo and U. Kozlowska, 11/24/03 +c + D0CM = 3.78d0 + AKCM = 15.1d0 + AKTH = 11.0d0 + AKCT = 12.0d0 + V1SS =-1.08d0 + V2SS = 7.61d0 + V3SS = 13.7d0 + + do i=1,maxres-1 + do j=i+1,maxres + dyn_ssbond_ij(i,j)=1.0d300 + enddo + enddo + call reada(controlcard,"HT",Ht,0.0D0) +C if (dyn_ss) then +C ss_depth=ebr/wsc-0.25*eps(1,1) +C write(iout,*) HT,wsc,eps(1,1),'KURWA' +C Ht=Ht/wsc-0.25*eps(1,1) + +C akcm=akcm*whpb/wsc +C akth=akth*whpb/wsc +C akct=akct*whpb/wsc +C v1ss=v1ss*whpb/wsc +C v2ss=v2ss*whpb/wsc +C v3ss=v3ss*whpb/wsc +C else +C ss_depth=ebr/whpb-0.25*eps(1,1)*wsc/whpb +C endif + + if (iparm.eq.myparm .or. .not.separate_parset) then + +c +c Setup weights for UNRES +c + 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) + whpb=ww(15) + wstrain=ww(15) + wliptran=ww(22) + wshield=ww(25) + endif + + call card_concat(controlcard,.false.) + +c 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) + write (iout,*) "tor_mode",tor_mode + call flush(iout) + if (tor_mode.eq.0) + & 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_ene + 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)) + +c +c Read the virtual-bond parameters, masses, and moments of inertia +c and Stokes' radii of the peptide group and side chains +c +#ifdef CRYST_BOND + read (ibond,*,end=121,err=121) vbldp0,vbldpdum,akp + do i=1,ntyp + nbondterm(i)=1 + read (ibond,*,end=121,err=121) 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,*,end=121,err=121) ijunk,vbldp0,vbldpdum,akp,rjunk + do i=1,ntyp + read (ibond,*,end=121,err=121) 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 + write (iout,*) "iliptranpar",iliptranpar + write (iout,*) "liptranname ",liptranname + read(iliptranpar,*,end=1161,err=1161) pepliptran + write (iout,*) "pepliptran",pepliptran + do i=1,ntyp + read(iliptranpar,*,end=1161,err=1161) liptranene(i) + write (iout,*) i,liptranene(i) + enddo + rewind iliptranpar +#ifdef CRYST_THETA +C +C Read the parameters of the probability distribution/energy expression +C of the virtual-bond valence angles theta +C + do i=1,ntyp + read (ithep,*,end=111,err=111) a0thet(i),(athet(j,i,1,1),j=1,2), + & (bthet(j,i,1,1),j=1,2) + read (ithep,*,end=111,err=111) (polthet(j,i),j=0,3) + read (ithep,*,end=111,err=111) (gthet(j,i),j=1,3) + read (ithep,*,end=111,err=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 +c write (iout,'(a)') +c & 'Parameters of the virtual-bond valence angles:' +c write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:', +c & ' ATHETA0 ',' A1 ',' A2 ', +c & ' B1 ',' B2 ' +c do i=1,ntyp +c write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, +c & a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2) +c enddo +c write (iout,'(/a/9x,5a/79(1h-))') +c & 'Parameters of the expression for sigma(theta_c):', +c & ' ALPH0 ',' ALPH1 ',' ALPH2 ', +c & ' ALPH3 ',' SIGMA0C ' +c do i=1,ntyp +c write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, +c & (polthet(j,i),j=0,3),sigc0(i) +c enddo +c write (iout,'(/a/9x,5a/79(1h-))') +c & 'Parameters of the second gaussian:', +c & ' THETA0 ',' SIGMA0 ',' G1 ', +c & ' G2 ',' G3 ' +c do i=1,ntyp +c write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i), +c & sig0(i),(gthet(j,i),j=1,3) +c 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 + IF (tor_mode.eq.0) THEN +C +C Read the parameters of Utheta determined from ab initio surfaces +C Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +C + read (ithep,*,end=111,err=111) nthetyp,ntheterm,ntheterm2, + & ntheterm3,nsingle,ndouble + nntheterm=max0(ntheterm,ntheterm2,ntheterm3) + read (ithep,*,end=111,err=111) (ithetyp(i),i=1,ntyp1) + do i=-ntyp1,-1 + ithetyp(i)=-ithetyp(-i) + enddo + 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 +C write (iout,*) "KURWA1" + do iblock=1,2 + do i=0,nthetyp + do j=-nthetyp,nthetyp + do k=-nthetyp,nthetyp + read (ithep,'(6a)',end=111,err=111) res1 + write(iout,*) res1,i,j,k + read (ithep,*,end=111,err=111) aa0thet(i,j,k,iblock) + 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 +C write(iout,*) "KURWA1.1" +C +C For dummy ends assign glycine-type coefficients of theta-only terms; the +C coefficients of theta-and-gamma-dependent terms are zero. +C + do i=1,nthetyp + do j=1,nthetyp + do l=1,ntheterm + aathet(l,i,j,nthetyp+1,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 +C write(iout,*) "KURWA1.5" +C 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 + +C +C Control printout of the coefficients of virtual-bond-angle potentials +C + if (lprint) then + write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' + do 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 + enddo + enddo + enddo + enddo + enddo + enddo + call flush(iout) + endif + + ELSE + +C here will be the apropriate recalibrating for D-aminoacid + read (ithep,*,end=111,err=111) nthetyp + do i=-nthetyp+1,nthetyp-1 + read (ithep,*,end=111,err=111) nbend_kcc_Tb(i) + do j=0,nbend_kcc_Tb(i) + read (ithep,*,end=111,err=111) ijunk,v1bend_chyb(j,i) + enddo + enddo + if (lprint) then + write (iout,'(a)') + & "Parameters of the valence-only potentials" + do i=-nthetyp+1,nthetyp-1 + write (iout,'(2a)') "Type ",toronelet(i) + do k=0,nbend_kcc_Tb(i) + write(iout,'(i5,f15.5)') k,v1bend_chyb(k,i) + enddo + enddo + endif + + ENDIF ! TOR_MODE + + close(ithep) +#endif +C write(iout,*) 'KURWA2' +#ifdef CRYST_SC +C +C Read the parameters of the probability distribution/energy expression +C of the side chains. +C + do i=1,ntyp +cc 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,*,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) +C 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) +c write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi) +c write (iout,'(a,f10.4,4(16x,f10.4))') +c & 'Center ',(bsc(j,i),j=1,nlobi) +c 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) +c write (iout,'(a)') +c do j=1,nlobi +c ind=0 +c do k=1,3 +c do l=1,k +c ind=ind+1 +c blower(k,l,j)=gaussc(ind,j,i) +c enddo +c enddo +c 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 +C +C Read scrot parameters for potentials determined from all-atom AM1 calculations +C added by Urszula Kozlowska 07/11/2007 +C + do i=1,ntyp + read (irotam,*,end=112,err=112) + if (i.eq.10) then + read (irotam,*,end=112,err=112) + else + do j=1,65 + read(irotam,*,end=112,err=112) sc_parmin(j,i) + enddo + endif + enddo +#endif + close(irotam) +C +C 9/18/99 (AL) Read coefficients of the Fourier expansion of the local +C interaction energy of the Gly, Ala, and Pro prototypes. +C + read (ifourier,*,end=115,err=115) nloctyp +#ifdef NEWCORR + read (ifourier,*,end=115,err=115) (itype2loc(i),i=1,ntyp) + read (ifourier,*,end=115,err=115) (iloctyp(i),i=0,nloctyp-1) + itype2loc(ntyp1)=nloctyp + iloctyp(nloctyp)=ntyp1 + do i=1,ntyp1 + itype2loc(-i)=-itype2loc(i) + enddo +#else + iloctyp(0)=10 + iloctyp(1)=9 + iloctyp(2)=20 + iloctyp(3)=ntyp1 +#endif + do i=1,nloctyp + iloctyp(-i)=-iloctyp(i) + enddo +c write (iout,*) "itype2loc",(itype2loc(i),i=1,ntyp1) +c write (iout,*) "nloctyp",nloctyp, +c & " iloctyp",(iloctyp(i),i=0,nloctyp) +#ifdef NEWCORR + do i=0,nloctyp-1 +c write (iout,*) "NEWCORR",i + read (ifourier,*,end=115,err=115) + do ii=1,3 + do j=1,2 + read (ifourier,*,end=115,err=115) bnew1(ii,j,i) + enddo + enddo +c write (iout,*) "NEWCORR BNEW1" +c write (iout,*) ((bnew1(ii,j,i),ii=1,3),j=1,2) + do ii=1,3 + do j=1,2 + read (ifourier,*,end=115,err=115) bnew2(ii,j,i) + enddo + enddo +c write (iout,*) "NEWCORR BNEW2" +c write (iout,*) ((bnew2(ii,j,i),ii=1,3),j=1,2) + do kk=1,3 + read (ifourier,*,end=115,err=115) ccnew(kk,1,i) + read (ifourier,*,end=115,err=115) ccnew(kk,2,i) + enddo +c write (iout,*) "NEWCORR CCNEW" +c write (iout,*) ((ccnew(ii,j,i),ii=1,3),j=1,2) + do kk=1,3 + read (ifourier,*,end=115,err=115) ddnew(kk,1,i) + read (ifourier,*,end=115,err=115) ddnew(kk,2,i) + enddo +c write (iout,*) "NEWCORR DDNEW" +c write (iout,*) ((ddnew(ii,j,i),ii=1,3),j=1,2) + do ii=1,2 + do jj=1,2 + do kk=1,2 + read (ifourier,*,end=115,err=115) eenew(ii,jj,kk,i) + enddo + enddo + enddo +c write (iout,*) "NEWCORR EENEW1" +c write(iout,*)(((eenew(ii,jj,kk,i),kk=1,2),jj=1,2),ii=1,2) + do ii=1,3 + read (ifourier,*,end=115,err=115) e0new(ii,i) + enddo +c write (iout,*) (e0new(ii,i),ii=1,3) + enddo +c write (iout,*) "NEWCORR EENEW" + do i=0,nloctyp-1 + do ii=1,3 + ccnew(ii,1,i)=ccnew(ii,1,i)/2 + ccnew(ii,2,i)=ccnew(ii,2,i)/2 + ddnew(ii,1,i)=ddnew(ii,1,i)/2 + ddnew(ii,2,i)=ddnew(ii,2,i)/2 + enddo + enddo + do i=1,nloctyp-1 + do ii=1,3 + bnew1(ii,1,-i)= bnew1(ii,1,i) + bnew1(ii,2,-i)=-bnew1(ii,2,i) + bnew2(ii,1,-i)= bnew2(ii,1,i) + bnew2(ii,2,-i)=-bnew2(ii,2,i) + enddo + do ii=1,3 +c ccnew(ii,1,i)=ccnew(ii,1,i)/2 +c ccnew(ii,2,i)=ccnew(ii,2,i)/2 +c ddnew(ii,1,i)=ddnew(ii,1,i)/2 +c ddnew(ii,2,i)=ddnew(ii,2,i)/2 + ccnew(ii,1,-i)=ccnew(ii,1,i) + ccnew(ii,2,-i)=-ccnew(ii,2,i) + ddnew(ii,1,-i)=ddnew(ii,1,i) + ddnew(ii,2,-i)=-ddnew(ii,2,i) + enddo + e0new(1,-i)= e0new(1,i) + e0new(2,-i)=-e0new(2,i) + e0new(3,-i)=-e0new(3,i) + do kk=1,2 + eenew(kk,1,1,-i)= eenew(kk,1,1,i) + eenew(kk,1,2,-i)=-eenew(kk,1,2,i) + eenew(kk,2,1,-i)=-eenew(kk,2,1,i) + eenew(kk,2,2,-i)= eenew(kk,2,2,i) + enddo + enddo + if (lprint) then + write (iout,'(a)') "Coefficients of the multibody terms" + do i=-nloctyp+1,nloctyp-1 + write (iout,*) "Type: ",onelet(iloctyp(i)) + write (iout,*) "Coefficients of the expansion of B1" + do j=1,2 + write (iout,'(3hB1(,i1,1h),3f10.5)') j,(bnew1(k,j,i),k=1,3) + enddo + write (iout,*) "Coefficients of the expansion of B2" + do j=1,2 + write (iout,'(3hB2(,i1,1h),3f10.5)') j,(bnew2(k,j,i),k=1,3) + enddo + write (iout,*) "Coefficients of the expansion of C" + write (iout,'(3hC11,3f10.5)') (ccnew(j,1,i),j=1,3) + write (iout,'(3hC12,3f10.5)') (ccnew(j,2,i),j=1,3) + write (iout,*) "Coefficients of the expansion of D" + write (iout,'(3hD11,3f10.5)') (ddnew(j,1,i),j=1,3) + write (iout,'(3hD12,3f10.5)') (ddnew(j,2,i),j=1,3) + write (iout,*) "Coefficients of the expansion of E" + write (iout,'(2hE0,3f10.5)') (e0new(j,i),j=1,3) + do j=1,2 + do k=1,2 + write (iout,'(1hE,2i1,2f10.5)') j,k,(eenew(l,j,k,i),l=1,2) + enddo + enddo + enddo + endif +#else + if (lprint) + & write (iout,*) "Coefficients of the expansion of Eloc(l1,l2)" + do i=0,nloctyp-1 + read (ifourier,*,end=115,err=115) + read (ifourier,*,end=115,err=115) (b(ii,i),ii=1,13) + if (lprint) then + write (iout,*) 'Type ',onelet(iloctyp(i)) + write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii,i),ii=1,13) + endif + if (i.gt.0) then + b(2,-i)= b(2,i) + b(3,-i)= b(3,i) + b(4,-i)=-b(4,i) + b(5,-i)=-b(5,i) + endif +c B1(1,i) = b(3) +c B1(2,i) = b(5) +c B1(1,-i) = b(3) +c B1(2,-i) = -b(5) +c b1(1,i)=0.0d0 +c b1(2,i)=0.0d0 +c B1tilde(1,i) = b(3) +c B1tilde(2,i) =-b(5) +c B1tilde(1,-i) =-b(3) +c B1tilde(2,-i) =b(5) +c b1tilde(1,i)=0.0d0 +c b1tilde(2,i)=0.0d0 +c B2(1,i) = b(2) +c B2(2,i) = b(4) +c B2(1,-i) =b(2) +c B2(2,-i) =-b(4) +cc B1tilde(1,i) = b(3,i) +cc B1tilde(2,i) =-b(5,i) +C B1tilde(1,-i) =-b(3,i) +C B1tilde(2,-i) =b(5,i) +cc b1tilde(1,i)=0.0d0 +cc b1tilde(2,i)=0.0d0 +cc B2(1,i) = b(2,i) +cc B2(2,i) = b(4,i) +C B2(1,-i) =b(2,i) +C B2(2,-i) =-b(4,i) + +c b2(1,i)=0.0d0 +c b2(2,i)=0.0d0 + CCold(1,1,i)= b(7,i) + CCold(2,2,i)=-b(7,i) + CCold(2,1,i)= b(9,i) + CCold(1,2,i)= b(9,i) + CCold(1,1,-i)= b(7,i) + CCold(2,2,-i)=-b(7,i) + CCold(2,1,-i)=-b(9,i) + CCold(1,2,-i)=-b(9,i) +c CC(1,1,i)=0.0d0 +c CC(2,2,i)=0.0d0 +c CC(2,1,i)=0.0d0 +c CC(1,2,i)=0.0d0 +c Ctilde(1,1,i)= CCold(1,1,i) +c Ctilde(1,2,i)= CCold(1,2,i) +c Ctilde(2,1,i)=-CCold(2,1,i) +c Ctilde(2,2,i)=-CCold(2,2,i) + +c Ctilde(1,1,i)=0.0d0 +c Ctilde(1,2,i)=0.0d0 +c Ctilde(2,1,i)=0.0d0 +c Ctilde(2,2,i)=0.0d0 + DDold(1,1,i)= b(6,i) + DDold(2,2,i)=-b(6,i) + DDold(2,1,i)= b(8,i) + DDold(1,2,i)= b(8,i) + DDold(1,1,-i)= b(6,i) + DDold(2,2,-i)=-b(6,i) + DDold(2,1,-i)=-b(8,i) + DDold(1,2,-i)=-b(8,i) +c DD(1,1,i)=0.0d0 +c DD(2,2,i)=0.0d0 +c DD(2,1,i)=0.0d0 +c DD(1,2,i)=0.0d0 +c Dtilde(1,1,i)= DD(1,1,i) +c Dtilde(1,2,i)= DD(1,2,i) +c Dtilde(2,1,i)=-DD(2,1,i) +c Dtilde(2,2,i)=-DD(2,2,i) + +c Dtilde(1,1,i)=0.0d0 +c Dtilde(1,2,i)=0.0d0 +c Dtilde(2,1,i)=0.0d0 +c Dtilde(2,2,i)=0.0d0 + EEold(1,1,i)= b(10,i)+b(11,i) + EEold(2,2,i)=-b(10,i)+b(11,i) + EEold(2,1,i)= b(12,i)-b(13,i) + EEold(1,2,i)= b(12,i)+b(13,i) + EEold(1,1,-i)= b(10,i)+b(11,i) + EEold(2,2,-i)=-b(10,i)+b(11,i) + EEold(2,1,-i)=-b(12,i)+b(13,i) + EEold(1,2,-i)=-b(12,i)-b(13,i) + write(iout,*) "TU DOCHODZE" + print *,"JESTEM" +c ee(1,1,i)=1.0d0 +c ee(2,2,i)=1.0d0 +c ee(2,1,i)=0.0d0 +c ee(1,2,i)=0.0d0 +c ee(2,1,i)=ee(1,2,i) + enddo + if (lprint) then + write (iout,*) + write (iout,*) + &"Coefficients of the cumulants (independent of valence angles)" + do i=-nloctyp+1,nloctyp-1 + write (iout,*) 'Type ',onelet(iloctyp(i)) + write (iout,*) 'B1' + write(iout,'(2f10.5)') B(3,i),B(5,i) + write (iout,*) 'B2' + write(iout,'(2f10.5)') B(2,i),B(4,i) + write (iout,*) 'CC' + do j=1,2 + write (iout,'(2f10.5)') CCold(j,1,i),CCold(j,2,i) + enddo + write(iout,*) 'DD' + do j=1,2 + write (iout,'(2f10.5)') DDold(j,1,i),DDold(j,2,i) + enddo + write(iout,*) 'EE' + do j=1,2 + write (iout,'(2f10.5)') EEold(j,1,i),EEold(j,2,i) + enddo + enddo + endif +#endif +C write (iout,*) 'KURWAKURWA' +#ifdef CRYST_TOR +C +C Read torsional parameters in old format +C + read (itorp,*,end=113,err=113) ntortyp,nterm_old + write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + do i=1,ntortyp + do j=1,ntortyp + read (itorp,'(a)',end=113,err=113) + do k=1,nterm_old + read (itorp,*,end=113,err=113) kk,v1(k,j,i),v2(k,j,i) + enddo + enddo + enddo + close (itorp) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do i=1,ntortyp + do j=1,ntortyp + write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) + write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) + enddo + enddo + endif +#else +C +C Read torsional parameters +C + IF (TOR_MODE.eq.0) THEN + + read (itorp,*,end=113,err=113) ntortyp + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + do i=1,ntyp1 + itype2loc(i)=itortyp(i) + enddo + write (iout,*) 'ntortyp',ntortyp + do i=1,ntyp1 + itype2loc(-i)=-itype2loc(i) + enddo + itortyp(ntyp1)=ntortyp + do iblock=1,2 + do i=-ntyp,-1 + itortyp(i)=-itortyp(-i) + enddo +c 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 + 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 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 + endif +C +C 6/23/01 Read parameters for double torsionals +C + 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 +c write (iout,*) "OK onelett", +c & 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)) +C 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) +c write(iout,*) "whcodze" , +c & 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)) +C 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 + + ELSE IF (TOR_MODE.eq.1) THEN + +C read valence-torsional parameters + read (itorp,*,end=113,err=113) ntortyp + nkcctyp=ntortyp + write (iout,*) "Valence-torsional parameters read in ntortyp", + & ntortyp + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + write (iout,*) "itortyp_kcc",(itortyp(i),i=1,ntyp) + do i=-ntyp,-1 + itortyp(i)=-itortyp(-i) + enddo + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 +C first we read the cos and sin gamma parameters + read (itorp,'(13x,a)',end=113,err=113) string + write (iout,*) i,j,string + read (itorp,*,end=113,err=113) + & nterm_kcc(j,i),nterm_kcc_Tb(j,i) +C read (itorkcc,*,end=121,err=121) nterm_kcc_Tb(j,i) + do k=1,nterm_kcc(j,i) + do l=1,nterm_kcc_Tb(j,i) + do ll=1,nterm_kcc_Tb(j,i) + read (itorp,*,end=113,err=113) ii,jj,kk, + & v1_kcc(ll,l,k,j,i),v2_kcc(ll,l,k,j,i) + enddo + enddo + enddo + enddo + enddo + + ELSE +c AL 4/8/16: Calculate coefficients from one-body parameters + ntortyp=nloctyp + do i=-ntyp1,ntyp1 + itortyp(i)=itype2loc(i) + enddo + write (iout,*) + &"Val-tor parameters calculated from cumulant coefficients ntortyp" + & ,ntortyp + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + nterm_kcc(j,i)=2 + nterm_kcc_Tb(j,i)=3 + do k=1,nterm_kcc_Tb(j,i) + do l=1,nterm_kcc_Tb(j,i) + v1_kcc(k,l,1,i,j)=bnew1(k,1,i)*bnew2(l,1,j) + & +bnew1(k,2,i)*bnew2(l,2,j) + v2_kcc(k,l,1,i,j)=bnew1(k,1,i)*bnew2(l,2,j) + & +bnew1(k,2,i)*bnew2(l,1,j) + enddo + enddo + do k=1,nterm_kcc_Tb(j,i) + do l=1,nterm_kcc_Tb(j,i) + v1_kcc(k,l,2,i,j)=-0.25*(ccnew(k,1,i)*ddnew(l,1,j) + & -ccnew(k,2,i)*ddnew(l,2,j)) + v2_kcc(k,l,2,i,j)=-0.25*(ccnew(k,2,i)*ddnew(l,1,j) + & +ccnew(k,1,i)*ddnew(l,2,j)) + enddo + enddo +cf(theta,gamma)=-(b21(theta)*b11(theta)+b12(theta)*b22(theta))*cos(gamma)-(b22(theta)*b11(theta)+b21(theta)*b12(theta))*sin(gamma)+(c11(theta)*d11(theta)-c12(theta)*d12(theta))*cos(2*gamma)+(c12(theta)*d11(theta)+c11(theta)*d12(theta))*sin(2*gamma) + enddo + enddo + + ENDIF ! TOR_MODE + + if (tor_mode.gt.0 .and. lprint) then +c Print valence-torsional parameters + write (iout,'(a)') + & "Parameters of the valence-torsional potentials" + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + write (iout,'(3a)') "Type ",toronelet(i),toronelet(j) + write (iout,'(3a5,2a15)') "itor","ival","jval","v_kcc","v2_kcc" + do k=1,nterm_kcc(j,i) + do l=1,nterm_kcc_Tb(j,i) + do ll=1,nterm_kcc_Tb(j,i) + write (iout,'(3i5,2f15.4)') + & k,l-1,ll-1,v1_kcc(ll,l,k,j,i),v2_kcc(ll,l,k,j,i) + enddo + enddo + enddo + enddo + enddo + endif + +#endif +C Read of Side-chain backbone correlation parameters +C Modified 11 May 2012 by Adasko +CCC +C + read (isccor,*,end=119,err=119) nsccortyp + read (isccor,*,end=119,err=119) (isccortyp(i),i=1,ntyp) + do i=-ntyp,-1 + isccortyp(i)=-isccortyp(-i) + enddo + iscprol=isccortyp(20) +c write (iout,*) 'ntortyp',ntortyp + maxinter=3 +cc maxinter is maximum interaction sites + do l=1,maxinter + do i=1,nsccortyp + do j=1,nsccortyp + read (isccor,*,end=119,err=119) + &nterm_sccor(i,j),nlor_sccor(i,j) +c write (iout,*) nterm_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) +c write (iout,*) nterm_sccor(i,j),nterm_sccor(-i,j), +c & 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) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants of SCCORR:' + do l=1,maxinter + 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 + enddo + endif +C +C Read electrostatic-interaction parameters +C + 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,*,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 +C +C Read side-chain interaction parameters. +C + read (isidep,*,end=117,err=117) ipot,expon + if (ipot.lt.1 .or. ipot.gt.5) then + write (iout,'(2a)') 'Error while reading SC interaction', + & 'potential file - unknown potential type.' + stop + endif + expon2=expon/2 + write(iout,'(/3a,2i3)') 'Potential is ',potname(ipot), + & ', exponents are ',expon,2*expon + goto (10,20,30,30,40) ipot +C----------------------- LJ potential --------------------------------- + 10 read (isidep,*,end=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 +C----------------------- LJK potential -------------------------------- + 20 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 +C---------------------- GB or BP potential ----------------------------- + 30 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) + do i=1,ntyp + read (isidep,*,end=117,err=117)(epslip(i,j),j=i,ntyp) +C write(iout,*) "WARNING!!",i,ntyp + write(iout,*) "epslip", i, (epslip(i,j),j=i,ntyp) +C do j=1,ntyp +C epslip(i,j)=epslip(i,j)+0.05d0 +C enddo + enddo +C For the GB potential convert sigma'**2 into chi' + if (ipot.eq.4) then + do i=1,ntyp + chip(i)=(chip(i)-1.0D0)/(chip(i)+1.0D0) + enddo + endif + if (lprint) then + write (iout,'(/a/)') 'Parameters of the BP potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,4a)') 'residue',' sigma ','s||/s_|_^2', + & ' chip ',' alph ' + write (iout,'(a3,6x,4f10.5)') (restyp(i),sigma0(i),sigii(i), + & chip(i),alp(i),i=1,ntyp) + endif + goto 50 +C--------------------- GBV potential ----------------------------------- + 40 read (isidep,*,end=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 + 50 continue + close (isidep) +C----------------------------------------------------------------------- +C Calculate the "working" parameters of SC interactions. + do i=2,ntyp + do j=1,i-1 + eps(i,j)=eps(j,i) + epslip(i,j)=epslip(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) + epsijlip=epslip(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_aq(i,j)=epsij*rrij*rrij + bb_aq(i,j)=-sigeps*epsij*rrij + aa_aq(j,i)=aa_aq(i,j) + bb_aq(j,i)=bb_aq(i,j) + sigeps=dsign(1.0D0,epsijlip) + epsijlip=dabs(epsijlip) + aa_lip(i,j)=epsijlip*rrij*rrij + bb_lip(i,j)=-sigeps*epsijlip*rrij + aa_lip(j,i)=aa_lip(i,j) + bb_lip(j,i)=bb_lip(i,j) + if (ipot.gt.2) then + sigt1sq=sigma0(i)**2 + sigt2sq=sigma0(j)**2 + sigii1=sigii(i) + sigii2=sigii(j) + ratsig1=sigt2sq/sigt1sq + ratsig2=1.0D0/ratsig1 + chi(i,j)=(sigii1-1.0D0)/(sigii1+ratsig1) + if (j.gt.i) chi(j,i)=(sigii2-1.0D0)/(sigii2+ratsig2) + rsum_max=dsqrt(sigii1*sigt1sq+sigii2*sigt2sq) + else + rsum_max=sigma(i,j) + endif +c if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then + sigmaii(i,j)=rsum_max + sigmaii(j,i)=rsum_max +c else +c sigmaii(i,j)=r0(i,j) +c sigmaii(j,i)=r0(i,j) +c endif +cd write (iout,*) i,j,r0(i,j),sigma(i,j),rsum_max + if ((ipot.eq.2 .or. ipot.eq.5) .and. r0(i,j).gt.rsum_max) then + r_augm=sigma(i,j)*(rrij-sigma(i,j))/rrij + augm(i,j)=epsij*r_augm**(2*expon) +c augm(i,j)=0.5D0**(2*expon)*aa(i,j) + augm(j,i)=augm(i,j) + else + augm(i,j)=0.0D0 + augm(j,i)=0.0D0 + endif + if (lprint) then + write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') + & restyp(i),restyp(j),aa_aq(i,j),bb_aq(i,j),augm(i,j), + & sigma(i,j),r0(i,j),chi(i,j),chi(j,i) + endif + enddo + enddo +C +C Define the SC-p interaction constants +C +#ifdef OLDSCP + do i=1,20 +C "Soft" SC-p repulsion (causes helices to be too flat, but facilitates +C helix formation) +c aad(i,1)=0.3D0*4.0D0**12 +C Following line for constants currently implemented +C "Hard" SC-p repulsion (gives correct turn spacing in helices) + aad(i,1)=1.5D0*4.0D0**12 +c aad(i,1)=0.17D0*5.6D0**12 + aad(i,2)=aad(i,1) +C "Soft" SC-p repulsion + bad(i,1)=0.0D0 +C Following line for constants currently implemented +c aad(i,1)=0.3D0*4.0D0**6 +C "Hard" SC-p repulsion + bad(i,1)=3.0D0*4.0D0**6 +c bad(i,1)=-2.0D0*0.17D0*5.6D0**6 + bad(i,2)=bad(i,1) +c aad(i,1)=0.0D0 +c aad(i,2)=0.0D0 +c bad(i,1)=1228.8D0 +c bad(i,2)=1228.8D0 + enddo +#else +C +C 8/9/01 Read the SC-p interaction constants from file +C + do i=1,ntyp + read (iscpp,*,end=118,err=118) (eps_scp(i,j),rscp(i,j),j=1,2) + enddo + do i=1,ntyp + aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12 + aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12 + bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6 + bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6 + enddo + + if (lprint) then + write (iout,*) "Parameters of SC-p interactions:" + do i=1,20 + write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1), + & eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) + enddo + endif +#endif +C +C Define the constants of the disulfide bridge +C +C ebr=-12.0D0 +c +c Old arbitrary potential - commented out. +c +c dbr= 4.20D0 +c fbr= 3.30D0 +c +c Constants of the disulfide-bond potential determined based on the RHF/6-31G** +c energy surface of diethyl disulfide. +c A. Liwo and U. Kozlowska, 11/24/03 +c +C D0CM = 3.78d0 +C AKCM = 15.1d0 +C AKTH = 11.0d0 +C AKCT = 12.0d0 +C V1SS =-1.08d0 +C V2SS = 7.61d0 +C V3SS = 13.7d0 + write (iout,*) dyn_ss,'dyndyn' + if (dyn_ss) then + ss_depth=ebr/wsc-0.25*eps(1,1) +C write(iout,*) akcm,whpb,wsc,'KURWA' + Ht=Ht/wsc-0.25*eps(1,1) + + akcm=akcm*whpb/wsc + akth=akth*whpb/wsc + akct=akct*whpb/wsc + v1ss=v1ss*whpb/wsc + v2ss=v2ss*whpb/wsc + v3ss=v3ss*whpb/wsc + else + ss_depth=ebr/whpb-0.25*eps(1,1)*wsc/whpb + endif + +C 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 +C endif + if (shield_mode.gt.0) then + pi=3.141592d0 +C VSolvSphere the volume of solving sphere +C print *,pi,"pi" +C rpp(1,1) is the energy r0 for peptide group contact and will be used for it +C there will be no distinction between proline peptide group and normal peptide +C group in case of shielding parameters + VSolvSphere=4.0/3.0*pi*rpp(1,1)**3 + VSolvSphere_div=VSolvSphere-4.0/3.0*pi*(rpp(1,1)/2.0)**3 + write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div", + & VSolvSphere_div +C long axis of side chain + do i=1,ntyp + long_r_sidechain(i)=vbldsc0(1,i) + short_r_sidechain(i)=sigma0(i) + enddo + buff_shield=1.0d0 + 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 + 1161 write (iout,*) "Error reading lipid 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" + goto 999 + 121 write (iout,*) "Error reading bond parameters" + 999 continue +#ifdef MPI + call MPI_Finalize(Ierror) +#endif + stop + return + end diff --git a/source/wham/src-HCD/permut.F b/source/wham/src-HCD/permut.F new file mode 100644 index 0000000..f81abd8 --- /dev/null +++ b/source/wham/src-HCD/permut.F @@ -0,0 +1,61 @@ + subroutine permut(isym,nperm,tabperm) +c integer maxperm,maxsym +c parameter (maxperm=3628800) +c parameter (maxsym=10) + include "DIMENSIONS" + integer n,a,tabperm + logical nextp + external nextp + dimension a(isym),tabperm(maxchain,maxperm) + n=isym + nperm=1 + if (n.eq.1) then + tabperm(1,1)=1 + return + endif + do i=2,n + nperm=nperm*i + enddo + kkk=0 + do i=1,n + a(i)=i + enddo + 10 continue +c print '(i3,2x,100i3)',kkk+1,(a(i),i=1,n) + kkk=kkk+1 + do i=1,n + tabperm(i,kkk)=a(i) + enddo + if(nextp(n,a)) go to 10 + return + end + + function nextp(n,a) + integer n,a,i,j,k,t + logical nextp + dimension a(n) + 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 diff --git a/source/wham/src-HCD/pinorm.f b/source/wham/src-HCD/pinorm.f new file mode 100644 index 0000000..91392bf --- /dev/null +++ b/source/wham/src-HCD/pinorm.f @@ -0,0 +1,17 @@ + double precision function pinorm(x) + implicit real*8 (a-h,o-z) +c +c this function takes an angle (in radians) and puts it in the range of +c -pi to +pi. +c + integer n + include 'COMMON.GEO' + n = x / dwapi + pinorm = x - n * dwapi + if ( pinorm .gt. pi ) then + pinorm = pinorm - dwapi + else if ( pinorm .lt. - pi ) then + pinorm = pinorm + dwapi + end if + return + end diff --git a/source/wham/src-HCD/printmat.f b/source/wham/src-HCD/printmat.f new file mode 100644 index 0000000..be2b38f --- /dev/null +++ b/source/wham/src-HCD/printmat.f @@ -0,0 +1,16 @@ + subroutine printmat(ldim,m,n,iout,key,a) + character*3 key(n) + double precision a(ldim,n) + do 1 i=1,n,8 + nlim=min0(i+7,n) + write (iout,1000) (key(k),k=i,nlim) + write (iout,1020) + 1000 format (/5x,8(6x,a3)) + 1020 format (/80(1h-)/) + do 2 j=1,n + write (iout,1010) key(j),(a(j,k),k=i,nlim) + 2 continue + 1 continue + 1010 format (a3,2x,8(f9.4)) + return + end diff --git a/source/wham/src-HCD/proc_cont.f b/source/wham/src-HCD/proc_cont.f new file mode 100644 index 0000000..9269496 --- /dev/null +++ b/source/wham/src-HCD/proc_cont.f @@ -0,0 +1,156 @@ + subroutine proc_cont + 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' + 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 diff --git a/source/wham/src-HCD/proc_proc.c b/source/wham/src-HCD/proc_proc.c new file mode 100644 index 0000000..7a21274 --- /dev/null +++ b/source/wham/src-HCD/proc_proc.c @@ -0,0 +1,124 @@ +#include +#include +#include + +#ifdef LINUX +#ifdef PGI +void proc_proc_(long int *f, int *i) +#else +void proc_proc__(long int *f, int *i) +#endif +#endif +#ifdef SGI +void proc_proc_(long int *f, int *i) +#endif +#ifdef WIN +void _stdcall PROC_PROC(long int *f, int *i) +#endif +#if defined(AIX) || defined(WINPGI) +void proc_proc(long int *f, int *i) +#endif + +{ +static long int NaNQ; +static long int NaNQm; + +if(*i==-1) + { + NaNQ=*f; + NaNQm=0xffffffff; + return; + } +*i=0; +if(*f==NaNQ) + *i=1; +if(*f==NaNQm) + *i=1; +} + + +#ifdef LINUX +void proc_conv__(char *buf, int *i, int n) +#endif +#ifdef SGI +void proc_conv_(char *buf, int *i, int n) +#endif +#if defined(AIX) || defined(WINPGI) +void proc_conv(char *buf, int *i, int n) +#endif +#ifdef WIN +void _stdcall PROC_CONV(char *buf, int *i, int n) +#endif +{ +int j; + +if (sscanf(buf,"%d",&j) != EOF) + *i=j; +return; +} + +#ifdef LINUX +void proc_conv_r__(char *buf, int *i, int n) +#endif +#ifdef SGI +void proc_conv_r_(char *buf, int *i, int n) +#endif +#if defined(AIX) || defined(WINPGI) +void proc_conv_r(char *buf, int *i, int n) +#endif +#ifdef WIN +void _stdcall PROC_CONV_R(char *buf, int *i, int n) +#endif + +{ + +/* sprintf(buf,"%d",*i); */ + +return; +} + +#ifndef IMSL +#ifdef LINUX +void dsvrgp__(int *n, double *tab1, double *tab2, int *itab) +#endif +#ifdef SGI +void dsvrgp_(int *n, double *tab1, double *tab2, int *itab) +#endif +#if defined(AIX) || defined(WINPGI) +void dsvrgp(int *n, double *tab1, double *tab2, int *itab) +#endif +#ifdef WIN +void _stdcall DSVRGP(int *n, double *tab1, double *tab2, int *itab) +#endif +{ +double t; +int i,j,k; + +if(tab1 != tab2) + { + for(i=0; i<*n; i++) + tab2[i]=tab1[i]; + } +k=0; +while(k<*n-1) + { + j=k; + t=tab2[k]; + for(i=k+1; i<*n; i++) + if(t>tab2[i]) + { + j=i; + t=tab2[i]; + } + if(j!=k) + { + tab2[j]=tab2[k]; + tab2[k]=t; + i=itab[j]; + itab[j]=itab[k]; + itab[k]=i; + } + k++; + } +} +#endif diff --git a/source/wham/src-HCD/promienie.f b/source/wham/src-HCD/promienie.f new file mode 100644 index 0000000..c2d8732 --- /dev/null +++ b/source/wham/src-HCD/promienie.f @@ -0,0 +1,46 @@ + subroutine promienie(*) + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.CONTPAR' + include 'COMMON.LOCAL' + integer i,j + real*8 facont /1.569D0/ ! facont = (2/(1-sqrt(1-1/4)))**(1/6) + character*8 contfunc + character*8 contfuncid(5)/'GB','DIST','CEN','ODC','SIG'/ + character*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" + return1 + 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 diff --git a/source/wham/src-HCD/qwolynes.f b/source/wham/src-HCD/qwolynes.f new file mode 100644 index 0000000..291b0aa --- /dev/null +++ b/source/wham/src-HCD/qwolynes.f @@ -0,0 +1,195 @@ + double precision function qwolynes(ilevel,jfrag,kkk) + 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/ + integer iperm + double precision dist + double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM + logical lprn /.false./ + double precision sigm,x + sigm(x)=0.25d0*x +c write (iout,*) "QWolyes: " jfrag",jfrag, +c & " ilevel",ilevel +c write (iout,*) "qwolynes: permutation",kkk + qq = 0.0d0 + if (ilevel.eq.0) then + if (lprn) write (iout,*) "Q computed for whole molecule" + nl=0 + do il=nnt+nsep,nct + if (itype(il).eq.ntyp1) cycle + do jl=nnt,il-nsep + if (itype(jl).eq.ntyp1) cycle + 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)-cref(1,il))**2+ + & (cref(2,jl)-cref(2,il))**2+ + & (cref(3,jl)-cref(3,il))**2) + dij=dist(iperm(il,kkk),iperm(jl,kkk)) + qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( + & (cref(1,jl+nres)-cref(1,il+nres))**2+ + & (cref(2,jl+nres)-cref(2,il+nres))**2+ + & (cref(3,jl+nres)-cref(3,il+nres))**2) + dijCM=dist(iperm(il,kkk)+nres,iperm(jl,kkk)+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 +c 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 (itype(il).eq.ntyp1.or.itype(jl).eq.ntyp1) cycle + 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)-cref(1,il))**2+ + & (cref(2,jl)-cref(2,il))**2+ + & (cref(3,jl)-cref(3,il))**2) + dij=dist(iperm(il,kkk),iperm(jl,kkk)) + qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( + & (cref(1,jl+nres)-cref(1,il+nres))**2+ + & (cref(2,jl+nres)-cref(2,il+nres))**2+ + & (cref(3,jl+nres)-cref(3,il+nres))**2) + dijCM=dist(iperm(il,kkk)+nres, + & iperm(iperm(jl,kkk),kkk)+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) + if (itype(il).eq.ntyp1) cycle + do k=1,i-1 + kp=ipiece(k,jfrag,ilevel) + do l=1,nlist_frag(kp) + kl=list_frag(l,kp) + if (itype(kl).eq.ntyp1) cycle + 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)-cref(1,il))**2+ + & (cref(2,kl)-cref(2,il))**2+ + & (cref(3,kl)-cref(3,il))**2) + dij=dist(iperm(il,kkk),iperm(kl,kkk)) + 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)-cref(1,il+nres))**2+ + & (cref(2,kl+nres)-cref(2,il+nres))**2+ + & (cref(3,kl+nres)-cref(3,il+nres))**2) + dijCM=dist(iperm(il,kkk)+nres,iperm(kl,kkk)+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 + qwolynes=1.0d0-qq + return + end +c------------------------------------------------------------------------------- + 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 diff --git a/source/wham/src-HCD/read_constr_homology.F b/source/wham/src-HCD/read_constr_homology.F new file mode 100644 index 0000000..ab9901d --- /dev/null +++ b/source/wham/src-HCD/read_constr_homology.F @@ -0,0 +1,719 @@ + subroutine read_constr_homology + + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.HOMRESTR' + include 'COMMON.HOMOLOGY' +c +c For new homol impl +c + include 'COMMON.VAR' +c include 'include_unres/COMMON.VAR' +c + +c double precision odl_temp,sigma_odl_temp,waga_theta,waga_d, +c & dist_cut +c common /przechowalnia/ odl_temp(maxres,maxres,max_template), +c & sigma_odl_temp(maxres,maxres,max_template) + character*2 kic2 + character*24 model_ki_dist, model_ki_angle + character*500 controlcard + integer ki, i, j, k, l, ii_in_use(maxdim),i_tmp,idomain_tmp + integer idomain(max_template,maxres) + logical lprn /.true./ + integer ilen + external ilen + logical liiflag +c +c FP - Nov. 2014 Temporary specifications for new vars +c + double precision rescore_tmp,x12,y12,z12,rescore2_tmp, + & rescore3_tmp + double precision, dimension (max_template,maxres) :: rescore + double precision, dimension (max_template,maxres) :: rescore2 + double precision, dimension (max_template,maxres) :: rescore3 + character*24 tpl_k_rescore +c ----------------------------------------------------------------- +c Reading multiple PDB ref structures and calculation of retraints +c not using pre-computed ones stored in files model_ki_{dist,angle} +c FP (Nov., 2014) +c ----------------------------------------------------------------- +c +c +c Alternative: reading from input + call card_concat(controlcard,.true.) + call reada(controlcard,"HOMOL_DIST",waga_dist,1.0d0) + call reada(controlcard,"HOMOL_ANGLE",waga_angle,1.0d0) + call reada(controlcard,"HOMOL_THETA",waga_theta,1.0d0) ! new + call reada(controlcard,"HOMOL_SCD",waga_d,1.0d0) ! new + call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) ! for diff ways of calc sigma + call reada(controlcard,'DIST2_CUT',dist2_cut,9999.0d0) + call readi(controlcard,"HOMOL_NSET",homol_nset,1) + read2sigma=(index(controlcard,'READ2SIGMA').gt.0) + call readi(controlcard,"IHSET",ihset,1) + if (homol_nset.gt.1)then + call card_concat(controlcard,.true.) + read(controlcard,*) (waga_homology(i),i=1,homol_nset) +c if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then +c write(iout,*) "iset homology_weight " +c do i=1,homol_nset +c write(iout,*) i,waga_homology(i) +c enddo +c endif + iset=mod(kolor,homol_nset)+1 + else + iset=1 + waga_homology(1)=1.0 + endif +c write(iout,*) "waga_homology(",iset,")",waga_homology(iset) + +cd write (iout,*) "nnt",nnt," nct",nct +cd call flush(iout) + + + lim_odl=0 + lim_dih=0 +c +c New +c + lim_theta=0 + lim_xx=0 +c +c Reading HM global scores (prob not required) +c + do i = nnt,nct + do k=1,constr_homology + idomain(k,i)=0 + enddo + enddo +c open (4,file="HMscore") +c do k=1,constr_homology +c read (4,*,end=521) hmscore_tmp +c hmscore(k)=hmscore_tmp ! Another transformation can be used +c write(*,*) "Model", k, ":", hmscore(k) +c enddo +c521 continue + + ii=0 + do i = nnt,nct-2 + do j=i+2,nct + ii=ii+1 + ii_in_use(ii)=0 + enddo + enddo +c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d + + if (read_homol_frag) then + call read_klapaucjusz + else + + do k=1,constr_homology + + read(inp,'(a)') pdbfile +c Next stament causes error upon compilation (?) +c if(me.eq.king.or. .not. out1file) +c write (iout,'(2a)') 'PDB data will be read from file ', +c & pdbfile(:ilen(pdbfile)) + write (iout,'(a,5x,a)') 'HOMOL: Opening PDB file', + & pdbfile(:ilen(pdbfile)) + open(ipdbin,file=pdbfile,status='old',err=33) + goto 34 + 33 write (iout,'(a,5x,a)') 'Error opening PDB file', + & pdbfile(:ilen(pdbfile)) + stop + 34 continue +c print *,'Begin reading pdb data' +c +c Files containing res sim or local scores (former containing sigmas) +c + + write(kic2,'(bz,i2.2)') k + + tpl_k_rescore="template"//kic2//".sco" + + unres_pdb=.false. + if (read2sigma) then + call readpdb_template(k) + else + call readpdb + endif + +c call readpdb + do i=1,2*nres + do j=1,3 + crefjlee(j,i)=c(j,i) + enddo + enddo +#ifdef DEBUG + do i=1,nres + write (iout,'(i5,3f8.3,5x,3f8.3)') i,(crefjlee(j,i),j=1,3), + & (crefjlee(j,i+nres),j=1,3) + enddo + write (iout,*) "read_constr_homology: after reading pdb file" + call flush(iout) +#endif + +c +c Distance restraints +c +c ... --> odl(k,ii) +C Copy the coordinates from reference coordinates (?) + do i=1,2*nres + do j=1,3 + c(j,i)=cref(j,i) +c write (iout,*) "c(",j,i,") =",c(j,i) + enddo + enddo +c +c From read_dist_constr (commented out 25/11/2014 <-> res sim) +c +c write(iout,*) "tpl_k_rescore - ",tpl_k_rescore + open (ientin,file=tpl_k_rescore,status='old') + if (nnt.gt.1) rescore(k,1)=0.0d0 + do irec=nnt,nct ! loop for reading res sim + if (read2sigma) then + read (ientin,*,end=1401) i_tmp,rescore2_tmp,rescore_tmp, + & rescore3_tmp,idomain_tmp + i_tmp=i_tmp+nnt-1 + idomain(k,i_tmp)=idomain_tmp + rescore(k,i_tmp)=rescore_tmp + rescore2(k,i_tmp)=rescore2_tmp + rescore3(k,i_tmp)=rescore3_tmp + write(iout,'(a7,i5,3f10.5,i5)') "rescore", + & i_tmp,rescore2_tmp,rescore_tmp, + & rescore3_tmp,idomain_tmp + else + idomain(k,irec)=1 + read (ientin,*,end=1401) rescore_tmp + +c rescore(k,irec)=rescore_tmp+1.0d0 ! to avoid 0 values + rescore(k,irec)=0.5d0*(rescore_tmp+0.5d0) ! alt transf to reduce scores +c write(iout,*) "rescore(",k,irec,") =",rescore(k,irec) + endif + enddo + 1401 continue + close (ientin) + if (waga_dist.ne.0.0d0) then + ii=0 + do i = nnt,nct-2 + do j=i+2,nct + + x12=c(1,i)-c(1,j) + y12=c(2,i)-c(2,j) + z12=c(3,i)-c(3,j) + distal=dsqrt(x12*x12+y12*y12+z12*z12) +c write (iout,*) k,i,j,distal,dist2_cut + + if (idomain(k,i).eq.idomain(k,j).and.idomain(k,i).ne.0 + & .and. distal.le.dist2_cut ) then + + ii=ii+1 + ii_in_use(ii)=1 + l_homo(k,ii)=.true. + +c write (iout,*) "k",k +c write (iout,*) "i",i," j",j," constr_homology", +c & constr_homology + ires_homo(ii)=i + jres_homo(ii)=j + odl(k,ii)=distal + if (read2sigma) then + sigma_odl(k,ii)=0 + do ik=i,j + sigma_odl(k,ii)=sigma_odl(k,ii)+rescore2(k,ik) + enddo + sigma_odl(k,ii)=sigma_odl(k,ii)/(j-i+1) + if (odl(k,ii).gt.dist_cut) sigma_odl(k,ii) = + & sigma_odl(k,ii)*dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0) + else + if (odl(k,ii).le.dist_cut) then + sigma_odl(k,ii)=rescore(k,i)+rescore(k,j) + else +#ifdef OLDSIGMA + sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))* + & dexp(0.5d0*(odl(k,ii)/dist_cut)**2) +#else + sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))* + & dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0) +#endif + endif + endif + sigma_odl(k,ii)=1.0d0/(sigma_odl(k,ii)*sigma_odl(k,ii)) + else + ii=ii+1 + l_homo(k,ii)=.false. + endif + enddo + enddo + lim_odl=ii + endif +c +c Theta, dihedral and SC retraints +c + if (waga_angle.gt.0.0d0) then +c open (ientin,file=tpl_k_sigma_dih,status='old') +c do irec=1,maxres-3 ! loop for reading sigma_dih +c read (ientin,*,end=1402) i,j,ki,l,sigma_dih(k,i+nnt-1) ! j,ki,l what for? +c if (i+nnt-1.gt.lim_dih) lim_dih=i+nnt-1 ! right? +c sigma_dih(k,i+nnt-1)=sigma_dih(k,i+nnt-1)* ! not inverse because of use of res. similarity +c & sigma_dih(k,i+nnt-1) +c enddo +c1402 continue +c close (ientin) + do i = nnt+3,nct + if (idomain(k,i).eq.0) then + sigma_dih(k,i)=0.0 + cycle + endif + dih(k,i)=phiref(i) ! right? +c read (ientin,*) sigma_dih(k,i) ! original variant +c write (iout,*) "dih(",k,i,") =",dih(k,i) +c write(iout,*) "rescore(",k,i,") =",rescore(k,i), +c & "rescore(",k,i-1,") =",rescore(k,i-1), +c & "rescore(",k,i-2,") =",rescore(k,i-2), +c & "rescore(",k,i-3,") =",rescore(k,i-3) + + sigma_dih(k,i)=(rescore(k,i)+rescore(k,i-1)+ + & rescore(k,i-2)+rescore(k,i-3))/4.0 +c if (read2sigma) sigma_dih(k,i)=sigma_dih(k,i)/4.0 +c write (iout,*) "Raw sigmas for dihedral angle restraints" +c write (iout,'(i5,10(2f8.2,4x))') i,sigma_dih(k,i) +c sigma_dih(k,i)=hmscore(k)*rescore(k,i)*rescore(k,i-1)* +c rescore(k,i-2)*rescore(k,i-3) ! right expression ? +c Instead of res sim other local measure of b/b str reliability possible + if (sigma_dih(k,i).ne.0) + & sigma_dih(k,i)=1.0d0/(sigma_dih(k,i)*sigma_dih(k,i)) +c sigma_dih(k,i)=sigma_dih(k,i)*sigma_dih(k,i) + enddo + lim_dih=nct-nnt-2 + endif + + if (waga_theta.gt.0.0d0) then +c open (ientin,file=tpl_k_sigma_theta,status='old') +c do irec=1,maxres-2 ! loop for reading sigma_theta, right bounds? +c read (ientin,*,end=1403) i,j,ki,sigma_theta(k,i+nnt-1) ! j,ki what for? +c sigma_theta(k,i+nnt-1)=sigma_theta(k,i+nnt-1)* ! not inverse because of use of res. similarity +c & sigma_theta(k,i+nnt-1) +c enddo +c1403 continue +c close (ientin) + + do i = nnt+2,nct ! right? without parallel. +c do i = i=1,nres ! alternative for bounds acc to readpdb? +c do i=ithet_start,ithet_end ! with FG parallel. + if (idomain(k,i).eq.0) then + sigma_theta(k,i)=0.0 + cycle + endif + thetatpl(k,i)=thetaref(i) +c write (iout,*) "thetatpl(",k,i,") =",thetatpl(k,i) +c write(iout,*) "rescore(",k,i,") =",rescore(k,i), +c & "rescore(",k,i-1,") =",rescore(k,i-1), +c & "rescore(",k,i-2,") =",rescore(k,i-2) +c read (ientin,*) sigma_theta(k,i) ! 1st variant + sigma_theta(k,i)=(rescore(k,i)+rescore(k,i-1)+ + & rescore(k,i-2))/3.0 +c if (read2sigma) sigma_theta(k,i)=sigma_theta(k,i)/3.0 + if (sigma_theta(k,i).ne.0) + & sigma_theta(k,i)=1.0d0/(sigma_theta(k,i)*sigma_theta(k,i)) + +c sigma_theta(k,i)=hmscore(k)*rescore(k,i)*rescore(k,i-1)* +c rescore(k,i-2) ! right expression ? +c sigma_theta(k,i)=sigma_theta(k,i)*sigma_theta(k,i) + enddo + endif + + if (waga_d.gt.0.0d0) then +c open (ientin,file=tpl_k_sigma_d,status='old') +c do irec=1,maxres-1 ! loop for reading sigma_theta, right bounds? +c read (ientin,*,end=1404) i,j,sigma_d(k,i+nnt-1) ! j,ki what for? +c sigma_d(k,i+nnt-1)=sigma_d(k,i+nnt-1)* ! not inverse because of use of res. similarity +c & sigma_d(k,i+nnt-1) +c enddo +c1404 continue + + do i = nnt,nct ! right? without parallel. +c do i=2,nres-1 ! alternative for bounds acc to readpdb? +c do i=loc_start,loc_end ! with FG parallel. + if (itype(i).eq.10) cycle + if (idomain(k,i).eq.0 ) then + sigma_d(k,i)=0.0 + cycle + endif + xxtpl(k,i)=xxref(i) + yytpl(k,i)=yyref(i) + zztpl(k,i)=zzref(i) +c write (iout,*) "xxtpl(",k,i,") =",xxtpl(k,i) +c write (iout,*) "yytpl(",k,i,") =",yytpl(k,i) +c write (iout,*) "zztpl(",k,i,") =",zztpl(k,i) +c write(iout,*) "rescore(",k,i,") =",rescore(k,i) +c sigma_d(k,i)=rescore(k,i) ! right expression ? + sigma_d(k,i)=rescore3(k,i) ! right expression ? + if (sigma_d(k,i).ne.0) + & sigma_d(k,i)=1.0d0/(sigma_d(k,i)*sigma_d(k,i)) + +c sigma_d(k,i)=hmscore(k)*rescore(k,i) ! right expression ? +c sigma_d(k,i)=sigma_d(k,i)*sigma_d(k,i) +c read (ientin,*) sigma_d(k,i) ! 1st variant + enddo + endif + enddo +c +c remove distance restraints not used in any model from the list +c shift data in all arrays +c + if (waga_dist.ne.0.0d0) then + ii=0 + liiflag=.true. + do i=nnt,nct-2 + do j=i+2,nct + ii=ii+1 + if (ii_in_use(ii).eq.0.and.liiflag) then + liiflag=.false. + iistart=ii + endif + if (ii_in_use(ii).ne.0.and..not.liiflag.or. + & .not.liiflag.and.ii.eq.lim_odl) then + if (ii.eq.lim_odl) then + iishift=ii-iistart+1 + else + iishift=ii-iistart + endif + liiflag=.true. + do ki=iistart,lim_odl-iishift + ires_homo(ki)=ires_homo(ki+iishift) + jres_homo(ki)=jres_homo(ki+iishift) + ii_in_use(ki)=ii_in_use(ki+iishift) + do k=1,constr_homology + odl(k,ki)=odl(k,ki+iishift) + sigma_odl(k,ki)=sigma_odl(k,ki+iishift) + l_homo(k,ki)=l_homo(k,ki+iishift) + enddo + enddo + ii=ii-iishift + lim_odl=lim_odl-iishift + endif + enddo + enddo + endif + + endif ! .not. klapaucjusz + + if (constr_homology.gt.0) call homology_partition + if (constr_homology.gt.0) call init_int_table +cd write (iout,*) "homology_partition: lim_theta= ",lim_theta, +cd & "lim_xx=",lim_xx +c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end +c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end +c +c Print restraints +c + if (.not.lprn) return +cd write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d +c if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then + write (iout,*) "Distance restraints from templates" + do ii=1,lim_odl + write(iout,'(3i5,100(2f8.2,1x,l1,4x))') + & ii,ires_homo(ii),jres_homo(ii), + & (odl(ki,ii),1.0d0/dsqrt(sigma_odl(ki,ii)),l_homo(ki,ii), + & ki=1,constr_homology) + enddo + write (iout,*) "Dihedral angle restraints from templates" + do i=nnt+3,nct + write (iout,'(i5,a4,100(2f8.2,4x))') i,restyp(itype(i)), + & (rad2deg*dih(ki,i), + & rad2deg/dsqrt(sigma_dih(ki,i)),ki=1,constr_homology) + enddo + write (iout,*) "Virtual-bond angle restraints from templates" + do i=nnt+2,nct + write (iout,'(i5,a4,100(2f8.2,4x))') i,restyp(itype(i)), + & (rad2deg*thetatpl(ki,i), + & rad2deg/dsqrt(sigma_theta(ki,i)),ki=1,constr_homology) + enddo + write (iout,*) "SC restraints from templates" + do i=nnt,nct + write(iout,'(i5,100(4f8.2,4x))') i, + & (xxtpl(ki,i),yytpl(ki,i),zztpl(ki,i), + & 1.0d0/dsqrt(sigma_d(ki,i)),ki=1,constr_homology) + enddo +c endif +c ----------------------------------------------------------------- + return + end +c---------------------------------------------------------------------- + subroutine read_klapaucjusz + + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.HOMOLOGY' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.HOMRESTR' + character*256 fragfile + integer ninclust(maxclust),inclust(max_template,maxclust), + & nresclust(maxclust),iresclust(maxres,maxclust) + + character*2 kic2 + character*24 model_ki_dist, model_ki_angle + character*500 controlcard + integer ki, i, j, k, l, ii_in_use(maxdim),i_tmp,idomain_tmp + integer idomain(max_template,maxres) + logical lprn /.true./ + integer ilen + external ilen + logical liiflag +c +c + double precision rescore_tmp,x12,y12,z12,rescore2_tmp + double precision, dimension (max_template,maxres) :: rescore + double precision, dimension (max_template,maxres) :: rescore2 + character*24 tpl_k_rescore + +c +c For new homol impl +c + include 'COMMON.VAR' +c + call getenv("FRAGFILE",fragfile) + open(ientin,file=fragfile,status="old",err=10) + read(ientin,*) constr_homology,nclust + l_homo = .false. + sigma_theta=0.0 + sigma_d=0.0 + sigma_dih=0.0 +c Read pdb files + do k=1,constr_homology + read(ientin,'(a)') pdbfile + write (iout,'(a,5x,a)') 'KLAPAUCJUSZ: Opening PDB file', + & pdbfile(:ilen(pdbfile)) + open(ipdbin,file=pdbfile,status='old',err=33) + goto 34 + 33 write (iout,'(a,5x,a)') 'Error opening PDB file', + & pdbfile(:ilen(pdbfile)) + stop + 34 continue + unres_pdb=.false. + call readpdb_template(k) +c do i=1,2*nres +c do j=1,3 +c chomo(j,i,k)=c(j,i) +c enddo +c enddo + do i=1,nres + rescore(k,i)=0.2d0 + rescore2(k,i)=1.0d0 + enddo + enddo +c Read clusters + do i=1,nclust + read(ientin,*) ninclust(i),nresclust(i) + read(ientin,*) (inclust(k,i),k=1,ninclust(i)) + read(ientin,*) (iresclust(k,i),k=1,nresclust(i)) + enddo +c +c Loop over clusters +c + do l=1,nclust + do ll = 1,ninclust(l) + + k = inclust(ll,l) + do i=1,nres + idomain(k,i)=0 + enddo + do i=1,nresclust(l) + if (nnt.gt.1) then + idomain(k,iresclust(i,l)+1) = 1 + else + idomain(k,iresclust(i,l)) = 1 + endif + enddo +c +c Distance restraints +c +c ... --> odl(k,ii) +C Copy the coordinates from reference coordinates (?) + do i=1,2*nres + do j=1,3 + c(j,i)=chomo(j,i,k) +c write (iout,*) "c(",j,i,") =",c(j,i) + enddo + enddo + call int_from_cart(.true.,.false.) + call sc_loc_geom(.false.) + do i=1,nres + thetaref(i)=theta(i) + phiref(i)=phi(i) + enddo + if (waga_dist.ne.0.0d0) then + ii=0 + do i = nnt,nct-2 + do j=i+2,nct + + x12=c(1,i)-c(1,j) + y12=c(2,i)-c(2,j) + z12=c(3,i)-c(3,j) + distal=dsqrt(x12*x12+y12*y12+z12*z12) +c write (iout,*) k,i,j,distal,dist2_cut + + if (idomain(k,i).eq.idomain(k,j).and.idomain(k,i).ne.0 + & .and. distal.le.dist2_cut ) then + + ii=ii+1 + ii_in_use(ii)=1 + l_homo(k,ii)=.true. + +c write (iout,*) "k",k +c write (iout,*) "i",i," j",j," constr_homology", +c & constr_homology + ires_homo(ii)=i + jres_homo(ii)=j + odl(k,ii)=distal + if (read2sigma) then + sigma_odl(k,ii)=0 + do ik=i,j + sigma_odl(k,ii)=sigma_odl(k,ii)+rescore2(k,ik) + enddo + sigma_odl(k,ii)=sigma_odl(k,ii)/(j-i+1) + if (odl(k,ii).gt.dist_cut) sigma_odl(k,ii) = + & sigma_odl(k,ii)*dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0) + else + if (odl(k,ii).le.dist_cut) then + sigma_odl(k,ii)=rescore(k,i)+rescore(k,j) + else +#ifdef OLDSIGMA + sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))* + & dexp(0.5d0*(odl(k,ii)/dist_cut)**2) +#else + sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))* + & dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0) +#endif + endif + endif + sigma_odl(k,ii)=1.0d0/(sigma_odl(k,ii)*sigma_odl(k,ii)) + else + ii=ii+1 +c l_homo(k,ii)=.false. + endif + enddo + enddo + lim_odl=ii + endif +c +c Theta, dihedral and SC retraints +c + if (waga_angle.gt.0.0d0) then + do i = nnt+3,nct + if (idomain(k,i).eq.0) then +c sigma_dih(k,i)=0.0 + cycle + endif + dih(k,i)=phiref(i) + sigma_dih(k,i)=(rescore(k,i)+rescore(k,i-1)+ + & rescore(k,i-2)+rescore(k,i-3))/4.0 +c write (iout,*) "k",k," l",l," i",i," rescore",rescore(k,i), +c & " sigma_dihed",sigma_dih(k,i) + if (sigma_dih(k,i).ne.0) + & sigma_dih(k,i)=1.0d0/(sigma_dih(k,i)*sigma_dih(k,i)) + enddo + lim_dih=nct-nnt-2 + endif + + if (waga_theta.gt.0.0d0) then + do i = nnt+2,nct + if (idomain(k,i).eq.0) then +c sigma_theta(k,i)=0.0 + cycle + endif + thetatpl(k,i)=thetaref(i) + sigma_theta(k,i)=(rescore(k,i)+rescore(k,i-1)+ + & rescore(k,i-2))/3.0 + if (sigma_theta(k,i).ne.0) + & sigma_theta(k,i)=1.0d0/(sigma_theta(k,i)*sigma_theta(k,i)) + enddo + endif + + if (waga_d.gt.0.0d0) then + do i = nnt,nct + if (itype(i).eq.10) cycle + if (idomain(k,i).eq.0 ) then +c sigma_d(k,i)=0.0 + cycle + endif + xxtpl(k,i)=xxref(i) + yytpl(k,i)=yyref(i) + zztpl(k,i)=zzref(i) + sigma_d(k,i)=rescore(k,i) + if (sigma_d(k,i).ne.0) + & sigma_d(k,i)=1.0d0/(sigma_d(k,i)*sigma_d(k,i)) + if (i-nnt+1.gt.lim_xx) lim_xx=i-nnt+1 + enddo + endif + enddo ! l + enddo ! ll +c +c remove distance restraints not used in any model from the list +c shift data in all arrays +c + if (waga_dist.ne.0.0d0) then + ii=0 + liiflag=.true. + do i=nnt,nct-2 + do j=i+2,nct + ii=ii+1 + if (ii_in_use(ii).eq.0.and.liiflag) then + liiflag=.false. + iistart=ii + endif + if (ii_in_use(ii).ne.0.and..not.liiflag.or. + & .not.liiflag.and.ii.eq.lim_odl) then + if (ii.eq.lim_odl) then + iishift=ii-iistart+1 + else + iishift=ii-iistart + endif + liiflag=.true. + do ki=iistart,lim_odl-iishift + ires_homo(ki)=ires_homo(ki+iishift) + jres_homo(ki)=jres_homo(ki+iishift) + ii_in_use(ki)=ii_in_use(ki+iishift) + do k=1,constr_homology + odl(k,ki)=odl(k,ki+iishift) + sigma_odl(k,ki)=sigma_odl(k,ki+iishift) + l_homo(k,ki)=l_homo(k,ki+iishift) + enddo + enddo + ii=ii-iishift + lim_odl=lim_odl-iishift + endif + enddo + enddo + endif +#ifdef DEBUG + write (iout,*) "ires_homo and jres_homo arrays, lim_odl",lim_odl + do i=1,lim_odl + write (iout,*) i,ires_homo(i),jres_homo(i) + enddo +#endif + return + 10 stop "Error in fragment file" + end diff --git a/source/wham/src-HCD/read_dist_constr.F b/source/wham/src-HCD/read_dist_constr.F new file mode 100644 index 0000000..4a07d86 --- /dev/null +++ b/source/wham/src-HCD/read_dist_constr.F @@ -0,0 +1,307 @@ + subroutine read_dist_constr + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.SBRIDGE' + integer ifrag_(2,100),ipair_(2,100) + double precision wfrag_(100),wpair_(100) + character*500 controlcard + logical lprn /.true./ + logical normalize,next + integer restr_type + double precision xlink(4,0:4) / +c a b c sigma + & 0.0d0,0.0d0,0.0d0,0.0d0, ! default, no xlink potential + & 0.00305218d0,9.46638d0,4.68901d0,4.74347d0, ! ZL + & 0.00214928d0,12.7517d0,0.00375009d0,6.13477d0, ! ADH + & 0.00184547d0,11.2678d0,0.00140292d0,7.00868d0, ! PDH + & 0.000161786d0,6.29273d0,4.40993d0,7.13956d0 / ! DSS + write (iout,*) "Calling read_dist_constr" +c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup +c call flush(iout) + next=.true. + + DO WHILE (next) + + call card_concat(controlcard) + next = index(controlcard,"NEXT").gt.0 + call readi(controlcard,"RESTR_TYPE",restr_type,constr_dist) + write (iout,*) "restr_type",restr_type + call readi(controlcard,"NFRAG",nfrag_,0) + 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) + if (restr_type.eq.10) + & call reada(controlcard,'WBOLTZD',wboltzd,0.591d0) + 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) + normalize = index(controlcard,"NORMALIZE").gt.0 + write (iout,*) "WBOLTZD",wboltzd +c write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_ +c write (iout,*) "IFRAG" +c do i=1,nfrag_ +c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) +c enddo +c write (iout,*) "IPAIR" +c do i=1,npair_ +c write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i) +c enddo + if (nfrag_.gt.0) then + & write (iout,*) + & "Distance restraints as generated from reference structure" + 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.' + return1 + 34 continue + do i=1,nres + itype_pdb(i)=itype(i) + enddo + call readpdb(.true.) + do i=1,nres + iaux=itype_pdb(i) + itype_pdb(i)=itype(i) + itype(i)=iaux + enddo + close (ipdbin) + endif + do i=1,nfrag_ + if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup + if (ifrag_(2,i).gt.nstart_sup+nsup-1) + & ifrag_(2,i)=nstart_sup+nsup-1 +c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) +c call flush(iout) + if (wfrag_(i).eq.0.0d0) cycle + do j=ifrag_(1,i),ifrag_(2,i)-1 + do k=j+1,ifrag_(2,i) +c write (iout,*) "j",j," k",k + ddjk=dist(j,k) + if (restr_type.eq.1) then + nhpb=nhpb+1 + irestr_type(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 + irestr_type(nhpb)=1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i) + endif + else if (restr_type.eq.3) then + nhpb=nhpb+1 + irestr_type(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.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#else + write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#endif + enddo + enddo + enddo + do i=1,npair_ + if (wpair_(i).eq.0.0d0) cycle + 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) + if (restr_type.eq.1) then + nhpb=nhpb+1 + irestr_type(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 + irestr_type(nhpb)=1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i) + endif + else if (restr_type.eq.3) then + nhpb=nhpb+1 + irestr_type(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,f10.1)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#else + write (iout,'(a,3i5,f8.2,f10.1)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#endif + enddo + enddo + enddo + +c print *,ndist_ + write (iout,*) "Distance restraints as read from input" + do i=1,ndist_ + if (restr_type.eq.11) then + read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(nhpb+1), + & dhpb1(nhpb+1),ibecarb(i),forcon(nhpb+1),fordepth(nhpb+1) +c fordepth(nhpb+1)=fordepth(nhpb+1)/forcon(nhpb+1) + if (forcon(nhpb+1).le.0.0d0.or.fordepth(nhpb+1).le.0.0d0)cycle + nhpb=nhpb+1 + irestr_type(nhpb)=11 +#ifdef MPI + if (.not.out1file .or. me.eq.king) + & write (iout,'(a,4i5,2f8.2,2f10.5,i5)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb), + & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),irestr_type(nhpb) +#else + write (iout,'(a,4i5,2f8.2,2f10.5,i5)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb), + & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),irestr_type(nhpb) +#endif + if (ibecarb(nhpb).gt.0) then + ihpb(nhpb)=ihpb(nhpb)+nres + jhpb(nhpb)=jhpb(nhpb)+nres + endif + else if (constr_dist.eq.10) then +c Cross-lonk Markov-like potential + call card_concat(controlcard) + call readi(controlcard,"ILINK",ihpb(nhpb+1),0) + call readi(controlcard,"JLINK",jhpb(nhpb+1),0) + ibecarb(nhpb+1)=0 + if (index(controlcard,"BETA").gt.0) ibecarb(nhpb+1)=1 + if (ihpb(nhpb+1).eq.0 .or. jhpb(nhpb+1).eq.0) cycle + if (index(controlcard,"ZL").gt.0) then + link_type=1 + else if (index(controlcard,"ADH").gt.0) then + link_type=2 + else if (index(controlcard,"PDH").gt.0) then + link_type=3 + else if (index(controlcard,"DSS").gt.0) then + link_type=4 + else + link_type=0 + endif + call reada(controlcard,"AXLINK",dhpb(nhpb+1), + & xlink(1,link_type)) + call reada(controlcard,"BXLINK",dhpb1(nhpb+1), + & xlink(2,link_type)) + call reada(controlcard,"CXLINK",fordepth(nhpb+1), + & xlink(3,link_type)) + call reada(controlcard,"SIGMA",forcon(nhpb+1), + & xlink(4,link_type)) + call reada(controlcard,"SCORE",xlscore(nhpb+1),1.0d0) +c read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),ibecarb(nhpb+1), +c & dhpb(nhpb+1),dhpb1(nhpb+1),forcon(nhpb+1),fordepth(nhpb+1) + if (forcon(nhpb+1).le.0.0d0 .or. + & (dhpb(nhpb+1).eq.0 .and. dhpb1(nhpb+1).eq.0)) cycle + nhpb=nhpb+1 + irestr_type(nhpb)=10 + if (ibecarb(nhpb).gt.0) then + ihpb(nhpb)=ihpb(nhpb)+nres + jhpb(nhpb)=jhpb(nhpb)+nres + endif +#ifdef MPI + if (.not.out1file .or. me.eq.king) + & write (iout,'(a,4i5,2f8.2,3f10.5,i5)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb), + & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),xlscore(nhpb), + & irestr_type(nhpb) +#else + write (iout,'(a,4i5,2f8.2,3f10.5,i5)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb), + & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),xlscore(nhpb), + & irestr_type(nhpb) +#endif + else +C print *,"in else" + read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(nhpb+1), + & dhpb1(nhpb+1),ibecarb(nhpb+1),forcon(nhpb+1) + if (forcon(nhpb+1).gt.0.0d0) then + nhpb=nhpb+1 + if (dhpb1(nhpb).eq.0.0d0) then + irestr_type(nhpb)=1 + else + irestr_type(nhpb)=2 + endif + if (ibecarb(nhpb).gt.0) then + ihpb(nhpb)=ihpb(nhpb)+nres + jhpb(nhpb)=jhpb(nhpb)+nres + endif + if (dhpb(nhpb).eq.0.0d0) + & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) + endif +#ifdef MPI + if (.not.out1file .or. me.eq.king) + & write (iout,'(a,4i5,f8.2,f10.1)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(i),dhpb(nhpb),forcon(nhpb) +#else + write (iout,'(a,4i5,f8.2,f10.1)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(i),dhpb(nhpb),forcon(nhpb) +#endif + endif +C read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),forcon(nhpb+1) +C if (forcon(nhpb+1).gt.0.0d0) then +C nhpb=nhpb+1 +C dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) + enddo + + ENDDO ! next + + fordepthmax=0.0d0 + if (normalize) then + do i=nss+1,nhpb + if (irestr_type(i).eq.11.and.fordepth(i).gt.fordepthmax) + & fordepthmax=fordepth(i) + enddo + do i=nss+1,nhpb + if (irestr_type(i).eq.11) fordepth(i)=fordepth(i)/fordepthmax + enddo + endif + if (nhpb.gt.nss) then + write (iout,'(/a,i5,a/4a5,2a8,3a10,a5)') + & "The following",nhpb-nss, + & " distance restraints have been imposed:", + & " Nr"," res1"," res2"," beta"," d1"," d2"," k"," V", + & " score"," type" + do i=nss+1,nhpb + write (iout,'(4i5,2f8.2,3f10.5,i5)')i-nss,ihpb(i),jhpb(i), + & ibecarb(i),dhpb(i),dhpb1(i),forcon(i),fordepth(i),xlscore(i), + & irestr_type(i) + enddo + endif + write (iout,*) "Calling HPB_PARTINION" + call hpb_partition + call flush(iout) + return + end diff --git a/source/wham/src-HCD/read_ref_str.F b/source/wham/src-HCD/read_ref_str.F new file mode 100644 index 0000000..8f3cf63 --- /dev/null +++ b/source/wham/src-HCD/read_ref_str.F @@ -0,0 +1,172 @@ + subroutine read_ref_structure(*) +C +C Read the reference structure from the PDB file or from a PDB file or in the form of the dihedral +C angles. +C + 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*4 sequence(maxres) + integer rescode + double precision x(maxvar) + integer itype_pdb(maxres) + logical seq_comp + integer i,j,k,nres_pdb,iaux + double precision ddsc,dist + integer nnt_old,nct_old + integer ilen,kkk + external ilen +C + nres0=nres + nnt_old=nnt + nct_old=nct +c 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.' + return1 + 34 continue + do i=1,nres + itype_pdb(i)=itype(i) + enddo + call readpdb(.true.) + do i=1,nres + iaux=itype_pdb(i) + itype_pdb(i)=itype(i) + itype(i)=iaux + enddo + close (ipdbin) + 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)=cref(k,nres_pdb+j) + enddo + enddo + do j=nnt+nsup-1,nnt,-1 + do k=1,3 + cref(k,j+i)=cref(k,j) + enddo + phi_ref(j+i)=phi(j) + theta_ref(j+i)=theta(j) + alph_ref(j+i)=alph(j) + omeg_ref(j+i)=omeg(j) + enddo +#ifdef DEBUG + do j=nnt,nct + write (iout,'(i5,3f10.5,5x,3f10.5)') + & j,(cref(k,j),k=1,3),(cref(k,j+nres),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.' + return1 + 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,'(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.' + return1 + 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)=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) + enddo + enddo + do i=1,nres + do j=1,3 + dc(j,nres+i)=cref(j,nres+i)-cref(j,i) + 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 +c write (iout,*) "i",i," dc_norm",(dc_norm(k,nres+i),k=1,3), +c " norm",dc_norm(1,nres+i)**2+dc_norm(2,nres+i)**2+ +c 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 +c write(iout, *)"Calling contact" + call contact(.true.,ncont_ref,icont_ref(1,1), + & nstart_sup,nend_sup,1) +c write(iout, *)"Calling elecont" + call elecont(.true.,ncont_pept_ref, + & icont_pept_ref(1,1), + & nstart_sup,nend_sup,1) + write (iout,'(a,i3,a,i3,a,i3,a)') + & 'Number of residues to be superposed:',nsup, + & ' (from residue',nstart_sup,' to residue', + & nend_sup,').' + nres=nres0 + nnt=nnt_old + nct=nct_old + return + end diff --git a/source/wham/src-HCD/readpdb.F b/source/wham/src-HCD/readpdb.F new file mode 100644 index 0000000..b8ce4f4 --- /dev/null +++ b/source/wham/src-HCD/readpdb.F @@ -0,0 +1,752 @@ + subroutine readpdb +C Read the PDB file and convert the peptide geometry into virtual-chain +C geometry. + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CONTROL' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.SBRIDGE' + character*3 seq,atom,res + character*80 card + double precision sccor(3,50) + integer i,j,iii,ibeg,ishift,ishift1,ity,ires,ires_old + double precision dcj + integer rescode,kkk,lll,icha,cou,kupa,iprzes + ibeg=1 + ishift1=0 + do + read (ipdbin,'(a80)',end=10) card + if (card(:3).eq.'END') then + goto 10 + else if (card(:3).eq.'TER') then +C End current chain +c ires_old=ires+1 + ires_old=ires+2 + itype(ires_old-1)=ntyp1 + itype(ires_old)=ntyp1 + ibeg=2 +c write (iout,*) "Chain ended",ires,ishift,ires_old + call sccenter(ires,iii,sccor) + endif +C Fish out the ATOM cards. + if (index(card(1:4),'ATOM').gt.0) then + read (card(14:16),'(a3)') atom + if (atom.eq.'CA' .or. atom.eq.'CH3') then +C Calculate the CM of the preceding residue. + if (ibeg.eq.0) then + call sccenter(ires,iii,sccor) + endif +C Start new residue. +c write (iout,'(a80)') card + read (card(23:26),*) ires + read (card(18:20),'(a3)') res + if (ibeg.eq.1) then + ishift=ires-1 + if (res.ne.'GLY' .and. res.ne. 'ACE') then + ishift=ishift-1 + itype(1)=ntyp1 + endif +c write (iout,*) "ires",ires," ibeg",ibeg," ishift",ishift + ibeg=0 + else if (ibeg.eq.2) then +c Start a new chain + ishift=-ires_old+ires-1 +c write (iout,*) "New chain started",ires,ishift + ibeg=0 + endif + ires=ires-ishift +c write (2,*) "ires",ires," ishift",ishift + if (res.eq.'ACE') then + ity=10 + else + itype(ires)=rescode(ires,res,0) + endif + read(card(31:54),'(3f8.3)') (c(j,ires),j=1,3) + read(card(61:66),*) bfac(ires) +c write (iout,'(2i3,2x,a,3f8.3,5x,f8.3)') +c & ires,itype(ires),res,(c(j,ires),j=1,3),bfac(ires) + iii=1 + do j=1,3 + sccor(j,iii)=c(j,ires) + enddo + else if (atom.ne.'O '.and.atom(1:1).ne.'H' .and. + & atom(1:1).ne.'Q' .and. atom(1:2).ne.'1H' .and. + & atom(1:2).ne.'2H' .and. atom(1:2).ne.'3H' .and. + & atom.ne.'N ' .and. atom.ne.'C ' .and. + & atom.ne.'OXT' ) then + iii=iii+1 +c write (iout,*) res,ires,iii,atom + read(card(31:54),'(3f8.3)') (sccor(j,iii),j=1,3) +c write (iout,'(3f8.3)') (sccor(j,iii),j=1,3) + endif + endif + enddo + 10 write (iout,'(a,i5)') ' Nres: ',ires +C Calculate dummy residue coordinates inside the "chain" of a multichain +C system + nres=ires + do i=2,nres-1 +c write (iout,*) i,itype(i) + + if (itype(i).eq.ntyp1) then + if (itype(i+1).eq.ntyp1) then +C 16/01/2014 by Adasko: Adding to dummy atoms in the chain +C first is connected prevous chain (itype(i+1).eq.ntyp1)=true +C second dummy atom is conected to next chain itype(i+1).eq.ntyp1=false +C if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the last dummy residue +C call refsys(i-3,i-2,i-1,e1,e2,e3,fail) +C if (fail) then +C e2(1)=0.0d0 +C e2(2)=1.0d0 +C e2(3)=0.0d0 +C endif !fail +C do j=1,3 +C c(j,i)=c(j,i-1)-1.9d0*e2(j) +C enddo +C else !unres_pdb + do j=1,3 + dcj=(c(j,i-2)-c(j,i-3))/2.0 + c(j,i)=c(j,i-1)+dcj + c(j,nres+i)=c(j,i) + enddo +C endif !unres_pdb + else !itype(i+1).eq.ntyp1 +C if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the first dummy residue +C call refsys(i+1,i+2,i+3,e1,e2,e3,fail) +C if (fail) then +C e2(1)=0.0d0 +C e2(2)=1.0d0 +C e2(3)=0.0d0 +C endif +C do j=1,3 +C c(j,i)=c(j,i+1)-1.9d0*e2(j) +C enddo +C else !unres_pdb + do j=1,3 + dcj=(c(j,i+3)-c(j,i+2))/2.0 + c(j,i)=c(j,i+1)-dcj + c(j,nres+i)=c(j,i) + enddo +C endif !unres_pdb + endif !itype(i+1).eq.ntyp1 + endif !itype.eq.ntyp1 + enddo +C Calculate the CM of the last side chain. + call sccenter(ires,iii,sccor) + nsup=nres + nstart_sup=1 + if (itype(nres).ne.10) then + nres=nres+1 + itype(nres)=ntyp1 + do j=1,3 + dcj=(c(j,nres-2)-c(j,nres-3))/2.0 + c(j,nres)=c(j,nres-1)+dcj + c(j,2*nres)=c(j,nres) + enddo + endif + do i=2,nres-1 + do j=1,3 + c(j,i+nres)=dc(j,i) + enddo + enddo + do j=1,3 + c(j,nres+1)=c(j,1) + c(j,2*nres)=c(j,nres) + enddo + if (itype(1).eq.ntyp1) then + nsup=nsup-1 + nstart_sup=2 + do j=1,3 + dcj=(c(j,4)-c(j,3))/2.0 + c(j,1)=c(j,2)-dcj + c(j,nres+1)=c(j,1) + enddo + endif +C Calculate internal coordinates. + write (iout,100) + 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 + call int_from_cart(.true.,.false.) + call flush(iout) + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=2,nres-1 + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo +c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3), +c & vbld_inv(i+nres) + enddo +c call chainbuild +C Copy the coordinates to reference coordinates + do i=1,nres + do j=1,3 + cref(j,i)=c(j,i) + cref(j,i+nres)=c(j,i+nres) + enddo + enddo + 100 format ('Residue alpha-carbon coordinates ', + & ' centroid coordinates'/ + 1 ' ', 6X,'X',7X,'Y',7X,'Z', + & 12X,'X',7X,'Y',7X,'Z') + 110 format (a,'(',i3,')',6f12.5) + + ishift_pdb=ishift + return + end +c--------------------------------------------------------------------------- + subroutine int_from_cart(lside,lprn) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + character*3 seq,atom,res + character*80 card + double precision sccor(3,50) + integer rescode + double precision dist,alpha,beta,di + integer i,j,iti + logical lside,lprn + if (lprn) then + write (iout,'(/a)') + & 'Internal coordinates calculated from crystal structure.' + if (lside) then + write (iout,'(8a)') ' Res ',' dvb',' Theta', + & ' Phi',' Dsc_id',' Dsc',' Alpha', + & ' Omega' + else + write (iout,'(4a)') ' Res ',' dvb',' Theta', + & ' Phi' + endif + endif + do i=2,nres + iti=itype(i) +c write (iout,*) i,i-1,(c(j,i),j=1,3),(c(j,i-1),j=1,3),dist(i,i-1) + if (itype(i-1).ne.ntyp1 .and. itype(i).ne.ntyp1 .and. + & (dist(i,i-1).lt.1.0D0 .or. dist(i,i-1).gt.6.0D0)) then + write (iout,'(a,i4)') 'Bad Cartesians for residue',i + stop + endif + vbld(i)=dist(i-1,i) + vbld_inv(i)=1.0d0/vbld(i) + theta(i+1)=alpha(i-1,i,i+1) + if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) + enddo +c if (itype(1).eq.ntyp1) then +c do j=1,3 +c c(j,1)=c(j,2)+(c(j,3)-c(j,4)) +c enddo +c endif +c if (itype(nres).eq.ntyp1) then +c do j=1,3 +c c(j,nres)=c(j,nres-1)+(c(j,nres-2)-c(j,nres-3)) +c enddo +c endif + if (lside) then + do i=2,nres-1 + do j=1,3 + c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) + enddo + iti=itype(i) + di=dist(i,nres+i) + vbld(i+nres)=di + if (itype(i).ne.10) then + vbld_inv(i+nres)=1.0d0/di + else + vbld_inv(i+nres)=0.0d0 + endif + if (iti.ne.10) then + alph(i)=alpha(nres+i,i,maxres2) + omeg(i)=beta(nres+i,i,maxres2,i+1) + endif + if (iti.ne.10) then + alph(i)=alpha(nres+i,i,maxres2) + omeg(i)=beta(nres+i,i,maxres2,i+1) + endif + if (lprn) + & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1), + & rad2deg*theta(i),rad2deg*phi(i),dsc(iti),di, + & rad2deg*alph(i),rad2deg*omeg(i) + enddo + else if (lprn) then + do i=2,nres + iti=itype(i) + write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1), + & rad2deg*theta(i),rad2deg*phi(i) + enddo + endif + return + end +c--------------------------------------------------------------------------- + subroutine sccenter(ires,nscat,sccor) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + integer ires,nscat,i,j + double precision sccor(3,50),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 +c--------------------------------------------------------------------------- + subroutine sc_loc_geom(lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + double precision x_prime(3),y_prime(3),z_prime(3) + logical lprn + do i=1,nres-1 + do j=1,3 + dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i)) + enddo + enddo + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) 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. itype(i).ne.ntyp1) then +c +C Compute the axes of tghe local cartesian coordinates system; store in +c x_prime, y_prime and z_prime +c + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo +c write (iout,*) "x_prime",(x_prime(j),j=1,3) +c write (iout,*) "y_prime",(y_prime(j),j=1,3) + call vecpr(x_prime,y_prime,z_prime) +c write (iout,*) "z_prime",(z_prime(j),j=1,3) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxref(i)=xx + yyref(i)=yy + zzref(i)=zz + else + xxref(i)=0.0d0 + yyref(i)=0.0d0 + zzref(i)=0.0d0 + endif + enddo + if (lprn) then + write (iout,*) "xxref,yyref,zzref" + do i=2,nres + iti=itype(i) + write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i),yyref(i), + & zzref(i) + enddo + endif + return + end +c--------------------------------------------------------------------------- + subroutine bond_regular + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CALC' + include 'COMMON.INTERACT' + include 'COMMON.CHAIN' + do i=1,nres-1 + vbld(i+1)=vbl + vbld_inv(i+1)=1.0d0/vbld(i+1) + vbld(i+1+nres)=dsc(iabs(itype(i+1))) + vbld_inv(i+1+nres)=dsc_inv(iabs(itype(i+1))) +c print *,vbld(i+1),vbld(i+1+nres) + enddo + return + end +c--------------------------------------------------------------------------- + subroutine readpdb_template(k) +C Read the PDB file for read_constr_homology with read2sigma +C and convert the peptide geometry into virtual-chain geometry. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + 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' + integer i,j,ibeg,ishift1,ires,iii,ires_old,ishift,ity + logical lprn /.false./,fail + double precision e1(3),e2(3),e3(3) + double precision dcj,efree_temp + character*3 seq,res + character*5 atom + character*80 card + double precision sccor(3,20) + integer rescode,iterter(maxres) + do i=1,maxres + iterter(i)=0 + enddo + ibeg=1 + ishift1=0 + ishift=0 +c write (2,*) "UNRES_PDB",unres_pdb + ires=0 + ires_old=0 + iii=0 + lsecondary=.false. + nhfrag=0 + nbfrag=0 + do + read (ipdbin,'(a80)',end=10) card + if (card(:3).eq.'END') then + goto 10 + else if (card(:3).eq.'TER') then +C End current chain + ires_old=ires+2 + itype(ires_old-1)=ntyp1 + iterter(ires_old-1)=1 + itype(ires_old)=ntyp1 + iterter(ires_old)=1 + ibeg=2 +c 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 + endif +C Fish out the ATOM cards. + if (index(card(1:4),'ATOM').gt.0) then + read (card(12:16),*) atom +c write (iout,*) "! ",atom," !",ires +c if (atom.eq.'CA' .or. atom.eq.'CH3') then + read (card(23:26),*) ires + read (card(18:20),'(a3)') res +c write (iout,*) "ires",ires,ires-ishift+ishift1, +c & " ires_old",ires_old +c write (iout,*) "ishift",ishift," ishift1",ishift1 +c write (iout,*) "IRES",ires-ishift+ishift1,ires_old + if (ires-ishift+ishift1.ne.ires_old) then +C Calculate the CM of the preceding residue. + if (ibeg.eq.0) then + if (unres_pdb) then + do j=1,3 + dc(j,ires)=sccor(j,iii) + enddo + else + call sccenter(ires_old,iii,sccor) + endif + iii=0 + endif +C Start new residue. + if (res.eq.'Cl-' .or. res.eq.'Na+') then + ires=ires_old + cycle + else if (ibeg.eq.1) then +c 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 +c write (iout,*) "ishift",ishift," ires",ires, +c & " ires_old",ires_old +c write (iout,*) "ires",ires," ibeg",ibeg," ishift",ishift + ibeg=0 + else if (ibeg.eq.2) then +c Start a new chain + ishift=-ires_old+ires-1 + ires=ires_old+1 +c write (iout,*) "New chain started",ires,ishift + 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 +c write (iout,*) "ires_old",ires_old," ires",ires +c if (card(27:27).eq."A" .or. card(27:27).eq."B") then +c ishift1=ishift1+1 +c endif +c 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) +c write (iout,*) "backbone ",atom ,ires,res, (c(j,ires),j=1,3) +#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 + if (ishift.ne.0) then + ires_ca=ires+ishift-ishift1 + else + ires_ca=ires + endif +c 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 +c 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)') ' Nres: ',ires +C Calculate dummy residue coordinates inside the "chain" of a multichain +C system + nres=ires + do i=2,nres-1 +c write (iout,*) i,itype(i),itype(i+1) + if (itype(i).eq.ntyp1.and.iterter(i).eq.1) then + if (itype(i+1).eq.ntyp1.and.iterter(i+1).eq.1 ) then +C 16/01/2014 by Adasko: Adding to dummy atoms in the chain +C first is connected prevous chain (itype(i+1).eq.ntyp1)=true +C second dummy atom is conected to next chain itype(i+1).eq.ntyp1=false + if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the last dummy residue + call refsys(i-3,i-2,i-1,e1,e2,e3,fail) + if (fail) then + e2(1)=0.0d0 + e2(2)=1.0d0 + e2(3)=0.0d0 + endif !fail + do j=1,3 + c(j,i)=c(j,i-1)-1.9d0*e2(j) + enddo + else !unres_pdb + do j=1,3 + dcj=(c(j,i-2)-c(j,i-3))/2.0 + if (dcj.eq.0) dcj=1.23591524223 + c(j,i)=c(j,i-1)+dcj + c(j,nres+i)=c(j,i) + enddo + endif !unres_pdb + else !itype(i+1).eq.ntyp1 + if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the first dummy residue + call refsys(i+1,i+2,i+3,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,i)=c(j,i+1)-1.9d0*e2(j) + enddo + else !unres_pdb + do j=1,3 + dcj=(c(j,i+3)-c(j,i+2))/2.0 + if (dcj.eq.0) dcj=1.23591524223 + c(j,i)=c(j,i+1)-dcj + c(j,nres+i)=c(j,i) + enddo + endif !unres_pdb + endif !itype(i+1).eq.ntyp1 + endif !itype.eq.ntyp1 + enddo +C Calculate the CM of the last side chain. + if (unres_pdb) then + do j=1,3 + dc(j,ires)=sccor(j,iii) + enddo + else + call sccenter(ires,iii,sccor) + endif + nsup=nres + nstart_sup=1 + if (itype(nres).ne.10) then + nres=nres+1 + itype(nres)=ntyp1 + if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the last dummy residue + call refsys(nres-3,nres-2,nres-1,e1,e2,e3,fail) + if (fail) then + e2(1)=0.0d0 + e2(2)=1.0d0 + e2(3)=0.0d0 + endif + do j=1,3 + c(j,nres)=c(j,nres-1)-1.9d0*e2(j) + enddo + else + do j=1,3 + dcj=(c(j,nres-2)-c(j,nres-3))/2.0 + if (dcj.eq.0) dcj=1.23591524223 + c(j,nres)=c(j,nres-1)+dcj + c(j,2*nres)=c(j,nres) + enddo + endif + endif + do i=2,nres-1 + do j=1,3 + c(j,i+nres)=dc(j,i) + enddo + enddo + do j=1,3 + c(j,nres+1)=c(j,1) + c(j,2*nres)=c(j,nres) + enddo + if (itype(1).eq.ntyp1) then + nsup=nsup-1 + nstart_sup=2 + if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the first dummy residue + call refsys(2,3,4,e1,e2,e3,fail) + if (fail) then + e2(1)=0.0d0 + e2(2)=1.0d0 + e2(3)=0.0d0 + endif + do j=1,3 + c(j,1)=c(j,2)-1.9d0*e2(j) + enddo + else + do j=1,3 + dcj=(c(j,4)-c(j,3))/2.0 + c(j,1)=c(j,2)-dcj + c(j,nres+1)=c(j,1) + enddo + endif + endif +C Copy the coordinates to reference coordinates +c do i=1,2*nres +c do j=1,3 +c cref(j,i)=c(j,i) +c enddo +c enddo +C Calculate internal coordinates. + if (out_template_coord) 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 +C Calculate internal coordinates. +c call int_from_cart1(.false.) + call int_from_cart(.true.,.true.) + call sc_loc_geom(.true.) + do i=1,nres + thetaref(i)=theta(i) + phiref(i)=phi(i) + enddo + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=2,nres-1 + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo +c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3), +c & vbld_inv(i+nres) + enddo + do i=1,nres + do j=1,3 + cref(j,i)=c(j,i) + cref(j,i+nres)=c(j,i+nres) + enddo + enddo + do i=1,2*nres + do j=1,3 + chomo(j,i,k)=c(j,i) + enddo + enddo + + return + end + + diff --git a/source/wham/src-HCD/readpdb.unr b/source/wham/src-HCD/readpdb.unr new file mode 100644 index 0000000..a4be969 --- /dev/null +++ b/source/wham/src-HCD/readpdb.unr @@ -0,0 +1,513 @@ + subroutine readpdb +C Read the PDB file and convert the peptide geometry into virtual-chain +C geometry. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.CONTROL' + include 'COMMON.DISTFIT' + include 'COMMON.SETUP' + character*3 seq,atom,res + character*80 card + dimension sccor(3,20) + integer rescode + ibeg=1 + lsecondary=.false. + nhfrag=0 + nbfrag=0 + do + read (ipdbin,'(a80)',end=10) card + if (card(:5).eq.'HELIX') then + nhfrag=nhfrag+1 + lsecondary=.true. + read(card(22:25),*) hfrag(1,nhfrag) + read(card(34:37),*) hfrag(2,nhfrag) + endif + if (card(:5).eq.'SHEET') then + nbfrag=nbfrag+1 + lsecondary=.true. + read(card(24:26),*) bfrag(1,nbfrag) + read(card(35:37),*) bfrag(2,nbfrag) +crc---------------------------------------- +crc to be corrected !!! + bfrag(3,nbfrag)=bfrag(1,nbfrag) + bfrag(4,nbfrag)=bfrag(2,nbfrag) +crc---------------------------------------- + endif + if (card(:3).eq.'END') then + goto 10 + else if (card(:3).eq.'TER') then +C End current chain + ires_old=ires+1 + itype(ires_old)=21 + ibeg=2 +c 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 + endif +C Fish out the ATOM cards. + if (index(card(1:4),'ATOM').gt.0) then + read (card(14:16),'(a3)') atom + if (atom.eq.'CA' .or. atom.eq.'CH3') then +C Calculate the CM of the preceding residue. + if (ibeg.eq.0) then + if (unres_pdb) then + do j=1,3 + dc(j,ires+nres)=sccor(j,iii) + enddo + else + call sccenter(ires,iii,sccor) + endif + endif +C Start new residue. +c write (iout,'(a80)') card + read (card(24:26),*) ires + read (card(18:20),'(a3)') res + if (ibeg.eq.1) then + ishift=ires-1 + if (res.ne.'GLY' .and. res.ne. 'ACE') then + ishift=ishift-1 + itype(1)=21 + endif +c write (iout,*) "ires",ires," ibeg",ibeg," ishift",ishift + ibeg=0 + else if (ibeg.eq.2) then +c Start a new chain + ishift=-ires_old+ires-1 +c write (iout,*) "New chain started",ires,ishift + ibeg=0 + endif + ires=ires-ishift +c write (2,*) "ires",ires," ishift",ishift + if (res.eq.'ACE') then + ity=10 + else + itype(ires)=rescode(ires,res,0) + endif + read(card(31:54),'(3f8.3)') (c(j,ires),j=1,3) + if(me.eq.king.or..not.out1file) + & write (iout,'(2i3,2x,a,3f8.3)') + & ires,itype(ires),res,(c(j,ires),j=1,3) + iii=1 + do j=1,3 + sccor(j,iii)=c(j,ires) + enddo + else if (atom.ne.'O '.and.atom(1:1).ne.'H' .and. + & atom.ne.'N ' .and. atom.ne.'C ') then + iii=iii+1 + read(card(31:54),'(3f8.3)') (sccor(j,iii),j=1,3) + endif + endif + enddo + 10 if(me.eq.king.or..not.out1file) + & write (iout,'(a,i5)') ' Nres: ',ires +C Calculate dummy residue coordinates inside the "chain" of a multichain +C system + nres=ires + do i=2,nres-1 +c write (iout,*) i,itype(i) + if (itype(i).eq.21) then +c 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 c(j,i)=(c(j,i-1)+c(j,i+1))/2 + dc(j,i)=c(j,i) + enddo + endif + enddo +C Calculate the CM of the last side chain. + if (unres_pdb) then + do j=1,3 + dc(j,ires)=sccor(j,iii) + enddo + else + call sccenter(ires,iii,sccor) + endif + nsup=nres + nstart_sup=1 + if (itype(nres).ne.10) then + nres=nres+1 + itype(nres)=21 + if (unres_pdb) then + c(1,nres)=c(1,nres-1)+3.8d0 + c(2,nres)=c(2,nres-1) + c(3,nres)=c(3,nres-1) + else + do j=1,3 + dcj=c(j,nres-2)-c(j,nres-3) + c(j,nres)=c(j,nres-1)+dcj + c(j,2*nres)=c(j,nres) + enddo + endif + endif + do i=2,nres-1 + do j=1,3 + c(j,i+nres)=dc(j,i) + enddo + enddo + do j=1,3 + c(j,nres+1)=c(j,1) + c(j,2*nres)=c(j,nres) + enddo + if (itype(1).eq.21) then + nsup=nsup-1 + nstart_sup=2 + if (unres_pdb) then + c(1,1)=c(1,2)-3.8d0 + c(2,1)=c(2,2) + c(3,1)=c(3,2) + else + do j=1,3 + dcj=c(j,4)-c(j,3) + c(j,1)=c(j,2)-dcj + c(j,nres+1)=c(j,1) + enddo + endif + endif +C Calculate internal coordinates. + if(me.eq.king.or..not.out1file)then + do ires=1,nres + write (iout,'(2i3,2x,a,3f8.3,5x,3f8.3)') + & ires,itype(ires),restyp(itype(ires)),(c(j,ires),j=1,3), + & (c(j,nres+ires),j=1,3) + enddo + endif + call int_from_cart(.true.,.false.) + call sc_loc_geom(.true.) + do i=1,nres + thetaref(i)=theta(i) + phiref(i)=phi(i) + enddo + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=2,nres-1 + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo +c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3), +c & vbld_inv(i+nres) + enddo +c call chainbuild +C Copy the coordinates to reference coordinates +C Splits to single chain if occurs + kkk=1 + lll=0 + cou=1 + do i=1,2*nres + lll=lll+1 +cc write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) + if ((itype(i-1).eq.21)) then + chain_length=lll-1 + kkk=kkk+1 +c write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) + lll=1 + endif + do j=1,3 + cref(j,i,cou)=c(j,i) + 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 +c diagnostic +cc write (iout,*) "spraw lancuchy",chain_length,symetr +cc do i=1,symetr +cc do kkk=1,chain_length +cc write (iout,*) itype(kkk),(chain_rep(j,kkk,i), j=1,3) +cc enddo +cc enddo +c enddiagnostic +C makes copy of chains +c 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 + do kkk=1,symetr + icha=tabperm(i,kkk) + write (iout,*) i,icha + do lll=1,chain_length + do j=1,3 + cref(j,lll,i)=chain_rep(j,lll,icha) + cref(j,lll+nres,i)=chain_rep(j,lll+nres,icha) + enddo + enddo + enddo + enddo + endif +C-koniec robienia kopii +c diag +c do kkk=1,6 +c do lll=1,nres +c write (iout,*) itype(lll),(cref(j,lll,kkk),j=1,3) +c enddo +c 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 + + return + end +c--------------------------------------------------------------------------- + subroutine int_from_cart(lside,lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + character*3 seq,atom,res + character*80 card + dimension sccor(3,20) + integer rescode + logical lside,lprn +#ifdef MPI + if(me.eq.king.or..not.out1file)then +#endif + if (lprn) then + write (iout,'(/a)') + & 'Internal coordinates calculated from crystal structure.' + if (lside) then + write (iout,'(8a)') ' Res ',' dvb',' Theta', + & ' Phi',' Dsc_id',' Dsc',' Alpha', + & ' Omega' + else + write (iout,'(4a)') ' Res ',' dvb',' Theta', + & ' Phi' + endif + endif +#ifdef MPI + endif +#endif + do i=1,nres-1 + iti=itype(i) + if (iti.ne.21 .and. itype(i+1).ne.21 .and. + & (dist(i,i+1).lt.2.0D0 .or. dist(i,i+1).gt.5.0D0)) then + write (iout,'(a,i4)') 'Bad Cartesians for residue',i +ctest stop + endif + vbld(i+1)=dist(i,i+1) + vbld_inv(i+1)=1.0d0/vbld(i+1) + if (i.gt.1) theta(i+1)=alpha(i-1,i,i+1) + if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) + enddo +c if (unres_pdb) then +c if (itype(1).eq.21) then +c theta(3)=90.0d0*deg2rad +c phi(4)=180.0d0*deg2rad +c vbld(2)=3.8d0 +c vbld_inv(2)=1.0d0/vbld(2) +c endif +c if (itype(nres).eq.21) then +c theta(nres)=90.0d0*deg2rad +c phi(nres)=180.0d0*deg2rad +c vbld(nres)=3.8d0 +c vbld_inv(nres)=1.0d0/vbld(2) +c endif +c endif + if (lside) then + do i=2,nres-1 + do j=1,3 + c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))*vbld_inv(i) + & +(c(j,i+1)-c(j,i))*vbld_inv(i+1)) + enddo + iti=itype(i) + di=dist(i,nres+i) + vbld(i+nres)=di + if (itype(i).ne.10) then + vbld_inv(i+nres)=1.0d0/di + else + vbld_inv(i+nres)=0.0d0 + endif + if (iti.ne.10) then + alph(i)=alpha(nres+i,i,maxres2) + omeg(i)=beta(nres+i,i,maxres2,i+1) + endif + if(me.eq.king.or..not.out1file)then + if (lprn) + & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,vbld(i), + & rad2deg*theta(i),rad2deg*phi(i),dsc(iti),vbld(nres+i), + & rad2deg*alph(i),rad2deg*omeg(i) + endif + enddo + else if (lprn) then + do i=2,nres + iti=itype(i) + if(me.eq.king.or..not.out1file) + & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1), + & rad2deg*theta(i),rad2deg*phi(i) + enddo + endif + return + end +c------------------------------------------------------------------------------- + subroutine sc_loc_geom(lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + double precision x_prime(3),y_prime(3),z_prime(3) + logical lprn + do i=1,nres-1 + do j=1,3 + dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i)) + enddo + enddo + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.21) 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. itype(i).ne.21) then +c +C Compute the axes of tghe local cartesian coordinates system; store in +c x_prime, y_prime and z_prime +c + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo + call vecpr(x_prime,y_prime,z_prime) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxref(i)=xx + yyref(i)=yy + zzref(i)=zz + else + xxref(i)=0.0d0 + yyref(i)=0.0d0 + zzref(i)=0.0d0 + endif + enddo + if (lprn) then + do i=2,nres + iti=itype(i) +#ifdef MPI + if(me.eq.king.or..not.out1file) + & write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i), + & yyref(i),zzref(i) +#else + write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i),yyref(i), + & zzref(i) +#endif + enddo + endif + return + end +c--------------------------------------------------------------------------- + subroutine sccenter(ires,nscat,sccor) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + dimension sccor(3,20) + do j=1,3 + sccmj=0.0D0 + do i=1,nscat + sccmj=sccmj+sccor(j,i) + enddo + dc(j,ires)=sccmj/nscat + enddo + return + end +c--------------------------------------------------------------------------- + subroutine bond_regular + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CALC' + include 'COMMON.INTERACT' + include 'COMMON.CHAIN' + do i=1,nres-1 + vbld(i+1)=vbl + vbld_inv(i+1)=1.0d0/vbld(i+1) + vbld(i+1+nres)=dsc(itype(i+1)) + vbld_inv(i+1+nres)=dsc_inv(itype(i+1)) +c print *,vbld(i+1),vbld(i+1+nres) + enddo + return + end + diff --git a/source/wham/src-HCD/readrtns.F b/source/wham/src-HCD/readrtns.F new file mode 100644 index 0000000..84a366f --- /dev/null +++ b/source/wham/src-HCD/readrtns.F @@ -0,0 +1,1231 @@ + subroutine read_general_data(*) + 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" + include "COMMON.SPLITELE" + include "COMMON.SBRIDGE" + include "COMMON.SHIELD" + include "COMMON.SAXS" + character*800 controlcard + integer i,j,k,ii,n_ene_found + integer ind,itype1,itype2,itypf,itypsc,itypp + integer ilen + external ilen + character*16 ucase + character*16 key + external ucase + double precision pi + call card_concat(controlcard,.true.) + call readi(controlcard,"N_ENE",n_ene,max_ene) + if (n_ene.gt.max_ene) then + write (iout,*) "Error: parameter out of range: N_ENE",n_ene, + & max_ene + return1 + endif + call readi(controlcard,"NPARMSET",nparmset,1) + 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 + return1 + endif + 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 + call multreadi(controlcard,"ISAMPL",isampl,nparmset,1) + do i=1,nparmset + if (isampl(i).eq.0) then + write (iout,*) "ERROR: isampl is 0 for parmset",i + call flush(iout) + stop + endif + enddo + write (iout,*) "MaxSlice",MaxSlice + call readi(controlcard,"NSLICE",nslice,1) + call flush(iout) + if (nslice.gt.MaxSlice) then + write (iout,*) "Error: parameter out of range: NSLICE",nslice, + & MaxSlice + return1 + 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 + return1 + endif + indpdb=0 + energy_dec=(index(controlcard,'ENERGY_DEC').gt.0) + if (index(controlcard,"CLASSIFY").gt.0) indpdb=1 + call reada(controlcard,"DELTA",delta,1.0d-2) + call reada(controlcard,"TOLE",tole,1.0d-1) + 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_mode,1) + check_conf=index(controlcard,"NO_CHECK_CONF").eq.0 + call readi(controlcard,'TORMODE',tor_mode,0) + write(iout,*) "torsional and valence angle mode",tor_mode + call reada(controlcard,'DISTCHAINMAX',distchainmax,50.0d0) + call reada(controlcard,'BOXX',boxxsize,100.0d0) + call reada(controlcard,'BOXY',boxysize,100.0d0) + call reada(controlcard,'BOXZ',boxzsize,100.0d0) +c Cutoff range for interactions + call reada(controlcard,"R_CUT",r_cut,15.0d0) + call reada(controlcard,"LAMBDA",rlamb,0.3d0) + call reada(controlcard,"LIPTHICK",lipthick,0.0d0) + call reada(controlcard,"LIPAQBUF",lipbufthick,0.0d0) + unres_pdb = index(controlcard,'UNRES_PDB') .gt. 0 + if (lipthick.gt.0.0d0) then + bordliptop=(boxzsize+lipthick)/2.0 + bordlipbot=bordliptop-lipthick +C endif + if ((bordliptop.gt.boxzsize).or.(bordlipbot.lt.0.0)) + & write(iout,*) "WARNING WRONG SIZE OF LIPIDIC PHASE" + buflipbot=bordlipbot+lipbufthick + bufliptop=bordliptop-lipbufthick + if ((lipbufthick*2.0d0).gt.lipthick) + &write(iout,*) "WARNING WRONG SIZE OF LIP AQ BUF" + endif + write(iout,*) "bordliptop=",bordliptop + write(iout,*) "bordlipbot=",bordlipbot + write(iout,*) "bufliptop=",bufliptop + write(iout,*) "buflipbot=",buflipbot + call readi(controlcard,'SYM',symetr,1) + write (iout,*) "DISTCHAINMAX",distchainmax + write (iout,*) "delta",delta + write (iout,*) "einicheck",einicheck + write (iout,*) "rescale_mode",rescale_mode + 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 + with_theta_constr = index(controlcard,"WITH_THETA_CONSTR").gt.0 + write (iout,*) "with_theta_constr ",with_theta_constr + call readi(controlcard,'SHIELD',shield_mode,0) + write(iout,*) "shield_mode",shield_mode +C endif + call readi(controlcard,'TORMODE',tor_mode,0) + write(iout,*) "torsional and valence angle mode",tor_mode + if (shield_mode.gt.0) then + pi=3.141592d0 +C VSolvSphere the volume of solving sphere +C print *,pi,"pi" +C rpp(1,1) is the energy r0 for peptide group contact and will be used for it +C there will be no distinction between proline peptide group and normal peptide +C group in case of shielding parameters + VSolvSphere=4.0/3.0*pi*rpp(1,1)**3 + VSolvSphere_div=VSolvSphere-4.0/3.0*pi*(rpp(1,1)/2.0)**3 + write (iout,*) VSolvSphere,VSolvSphere_div +C long axis of side chain +C do i=1,ntyp +C long_r_sidechain(i)=vbldsc0(1,i) +C short_r_sidechain(i)=sigma0(i) +C enddo + buff_shield=1.0d0 + endif + + call readi(controlcard,'CONSTR_DIST',constr_dist,0) + call readi(controlcard,'CONSTR_HOMOL',constr_homology,0) +c if (constr_homology) tole=dmax1(tole,1.5d0) + write (iout,*) "with_homology_constr ",with_dihed_constr, + & " CONSTR_HOMOLOGY",constr_homology + read_homol_frag = index(controlcard,"READ_HOMOL_FRAG").gt.0 + out_template_coord = index(controlcard,"OUT_TEMPLATE_COORD").gt.0 + out_template_restr = index(controlcard,"OUT_TEMPLATE_RESTR").gt.0 + write (iout,*) "out_template_coord ",OUT_TEMPLATE_COORD + write (iout,*) "out_template_restr",OUT_TEMPLATE_RESTR + dyn_ss=index(controlcard,"DYN_SS").gt.0 + adaptive = index(controlcard,"ADAPTIVE").gt.0 + call readi(controlcard,'NSAXS',nsaxs,0) + call readi(controlcard,'SAXS_MODE',saxs_mode,0) + call reada(controlcard,'SCAL_RAD',scal_rad,1.0d0) + call reada(controlcard,'SAXS_CUTOFF',saxs_cutoff,1.0d0) + write (iout,*) "Number of SAXS restraints",NSAXS," SAXS_MODE", + & SAXS_MODE," SCAL_RAD",scal_rad,"SAXS_CUTOFF",saxs_cutoff + return + end +c------------------------------------------------------------------------------ + subroutine read_efree(*) +C +C Read molecular data +C + 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*320 controlcard,ucase + integer iparm,ib,i,j,npars + integer ilen + external ilen + + if (hamil_rep) then + npars=1 + else + npars=nParmSet + endif + + 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 + return1 + 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 + return1 + 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 +c----------------------------------------------------------------------------- + subroutine read_protein_data(*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + 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*64 nazwa + character*16000 controlcard + integer i,ii,ib,iR,iparm,ilen,iroof,nthr,npars + external ilen,iroof + if (hamil_rep) then + npars=1 + else + npars=nparmset + endif + + do iparm=1,npars + +C 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!" + return1 + 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 +c------------------------------------------------------------------------------- + subroutine opentmp(islice,iunit,bprotfile_temp) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#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*64 bprotfile_temp + character*3 liczba,liczba2 + character*2 liczba1 + integer iunit,islice + integer ilen,iroof + external ilen,iroof + logical lerr + + write (liczba1,'(bz,i2.2)') islice + write (liczba,'(bz,i3.3)') me +#ifdef MPI +c write (iout,*) "separate_parset ",separate_parset, +c & " 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 +c write (iout,*) "OpenTmp iunit",iunit," bprotfile_temp", +c & bprotfile_temp +c call flush(iout) + return + end +c------------------------------------------------------------------------------- + subroutine read_database(*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#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*4 csingle(3,maxres2) + character*64 nazwa,bprotfile_temp + character*3 liczba + character*2 liczba1 + integer i,j,ii,jj(maxslice),k,kk(maxslice),l, + & ll(maxslice),mm(maxslice),if + integer nrec,nlines,iscor,iunit,islice + double precision energ + integer ilen,iroof + external ilen,iroof + double precision rmsdev,energia(0:max_ene),efree,eini,temp + double precision prop(maxQ) + integer ntot_all(maxslice,0:maxprocs-1), maxslice_buff + integer iparm,ib,iib,ir,nprop,nthr,npars + double precision 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 +c Read conformations from binary DA files (one per batch) and write them to +c 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,ii,jj(islice),kk(islice),ll(islice), + & mm(islice),iR,ib,iparm) + close(ientout) + enddo + close(ientin) + enddo + ENDIF ! NFILE_BIN>0 +c + IF (NFILE_ASC(iR,ib,iparm).GT.0) THEN +c Read conformations from multiple ASCII int files and write them to a binary +c 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 +c Read conformations from cx files and write them to a binary +c 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) + close(ientout) + write (iout,*) "exit cxread" + call flush(iout) + enddo + ENDIF + + do islice=1,nslice + 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 +c Check if everyone has the same number of conformations + +c call MPI_ALLgather(MPI_IN_PLACE,stot(1),MPI_DATATYPE_NULL, +c & ntot_all(1,0),maxslice,MPI_INTEGER,MPI_Comm_World,IERROR) + + maxslice_buff=maxslice + + call MPI_Allgather(stot(1),maxslice_buff,MPI_INTEGER, + & ntot_all(1,0),maxslice,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) + return1 + endif + do islice=1,nslice + ntot(islice)=stot(islice) + enddo + return +#endif + 1111 write(iout,*) "Error opening coordinate file ",nazwa(:ilen(nazwa)) + call flush(iout) + return1 + end +c------------------------------------------------------------------------------ + subroutine card_concat(card,to_upper) + implicit none + include 'DIMENSIONS.ZSCOPT' + include "COMMON.IOUNITS" + character*(*) card + character*80 karta,ucase + logical to_upper + integer ilen + 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 +c------------------------------------------------------------------------------ + subroutine readi(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch + integer wartosc,default + integer ilen,iread + external ilen + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*) wartosc + return + end +c---------------------------------------------------------------------------- + subroutine reada(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch + character*80 aux + double precision wartosc,default + integer ilen,iread + external ilen + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*) wartosc + return + end +c---------------------------------------------------------------------------- + subroutine multreadi(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + integer tablica(dim),default + character*(*) rekord,lancuch + character*80 aux + integer ilen,iread + external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end +c---------------------------------------------------------------------------- + subroutine multreada(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + double precision tablica(dim),default + character*(*) rekord,lancuch + character*80 aux + integer ilen,iread + external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end +c---------------------------------------------------------------------------- + subroutine reads(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch,wartosc,default + character*80 aux + integer ilen,lenlan,lenrec,iread,ireade + external ilen + logical iblnk + external iblnk + lenlan=ilen(lancuch) + lenrec=ilen(rekord) + iread=index(rekord,lancuch(:lenlan)//"=") +c print *,"rekord",rekord," lancuch",lancuch +c print *,"iread",iread," lenlan",lenlan," lenrec",lenrec + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+lenlan+1 +c print *,"iread",iread +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) + iread=iread+1 +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + enddo +c print *,"iread",iread + if (iread.gt.lenrec) then + wartosc=default + return + endif + ireade=iread+1 +c print *,"ireade",ireade + do while (ireade.lt.lenrec .and. + & .not.iblnk(rekord(ireade:ireade))) + ireade=ireade+1 + enddo + wartosc=rekord(iread:ireade) + return + end +c---------------------------------------------------------------------------- + subroutine multreads(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + character*(*) rekord,lancuch,tablica(dim),default + character*80 aux + integer ilen,lenlan,lenrec,iread,ireade + external ilen + logical iblnk + external iblnk + do i=1,dim + tablica(i)=default + enddo + lenlan=ilen(lancuch) + lenrec=ilen(rekord) + iread=index(rekord,lancuch(:lenlan)//"=") +c print *,"rekord",rekord," lancuch",lancuch +c print *,"iread",iread," lenlan",lenlan," lenrec",lenrec + if (iread.eq.0) return + iread=iread+lenlan+1 + do i=1,dim +c print *,"iread",iread +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) + iread=iread+1 +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + enddo +c print *,"iread",iread + if (iread.gt.lenrec) return + ireade=iread+1 +c 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 +c---------------------------------------------------------------------------- + subroutine split_string(rekord,tablica,dim,nsub) + implicit none + integer dim,nsub,i,ii,ll,kk + character*(*) tablica(dim) + character*(*) rekord + integer ilen + external ilen + do i=1,dim + tablica(i)=" " + enddo + ii=1 + ll = ilen(rekord) + nsub=0 + do i=1,dim +C Find the start of term name + kk = 0 + do while (ii.le.ll .and. rekord(ii:ii).eq." ") + ii = ii+1 + enddo +C 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 +c-------------------------------------------------------------------------------- + integer function iroof(n,m) + ii = n/m + if (ii*m .lt. n) ii=ii+1 + iroof = ii + return + end +c------------------------------------------------------------------------------- + subroutine read_dist_constr + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.SBRIDGE' + include 'COMMON.INTERACT' + integer ifrag_(2,100),ipair_(2,100) + double precision wfrag_(100),wpair_(100) + character*500 controlcard + logical normalize,next + integer restr_type + double precision xlink(4,0:4) / +c a b c sigma + & 0.0d0,0.0d0,0.0d0,0.0d0, ! default, no xlink potential + & 0.00305218d0,9.46638d0,4.68901d0,4.74347d0, ! ZL + & 0.00214928d0,12.7517d0,0.00375009d0,6.13477d0, ! ADH + & 0.00184547d0,11.2678d0,0.00140292d0,7.00868d0, ! PDH + & 0.000161786d0,6.29273d0,4.40993d0,7.13956d0 / ! DSS + write (iout,*) "Calling read_dist_constr" +c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup +c call flush(iout) + restr_on_coord=.false. + next=.true. + + DO WHILE (next) + + call card_concat(controlcard,.true.) + next = index(controlcard,"NEXT").gt.0 + call readi(controlcard,"RESTR_TYPE",restr_type,constr_dist) + write (iout,*) "restr_type",restr_type + call readi(controlcard,"NFRAG",nfrag_,0) + 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 reada(controlcard,'SCAL_BFAC',scal_bfac,1.0d0) + if (restr_type.eq.10) + & call reada(controlcard,'WBOLTZD',wboltzd,0.591d0) + if (restr_type.eq.12) + & call reada(controlcard,'SCAL_PEAK',scal_peak,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) + normalize = index(controlcard,"NORMALIZE").gt.0 + write (iout,*) "WBOLTZD",wboltzd + write (iout,*) "SCAL_PEAK",scal_peak + 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 (nfrag_.gt.0 .or. restr_type.eq.4 .or. restr_type.eq.5) then + nres0=nres + read(inp,'(a)') pdbfile + write (iout,*) + & "Distance restraints will be constructed from structure ",pdbfile + open(ipdbin,file=pdbfile,status='old',err=11) + call readpdb(.true.) + nres=nres0 + close(ipdbin) + endif + do i=1,nfrag_ + if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup + if (ifrag_(2,i).gt.nstart_sup+nsup-1) + & ifrag_(2,i)=nstart_sup+nsup-1 +c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) +c call flush(iout) + if (wfrag_(i).eq.0.0d0) cycle + do j=ifrag_(1,i),ifrag_(2,i)-1 + do k=j+1,ifrag_(2,i) +c write (iout,*) "j",j," k",k + ddjk=dist(j,k) + if (restr_type.eq.1) then + nhpb=nhpb+1 + irestr_type(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 + irestr_type(nhpb)=1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i) + endif + else if (restr_type.eq.3) then + nhpb=nhpb+1 + irestr_type(nhpb)=1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) + endif + write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) + enddo + enddo + enddo + do i=1,npair_ + if (wpair_(i).eq.0.0d0) cycle + 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) + ddjk=dist(j,k) + if (restr_type.eq.1) then + nhpb=nhpb+1 + irestr_type(nhpb)=1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wpair_(i) + else if (constr_dist.eq.2) then + if (ddjk.le.dist_cut) then + nhpb=nhpb+1 + irestr_type(nhpb)=1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wpair_(i) + endif + else if (restr_type.eq.3) then + nhpb=nhpb+1 + irestr_type(nhpb)=1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wpair_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) + endif + write (iout,'(a,3i5,f8.2,f10.1)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) + enddo + enddo + enddo + +c print *,ndist_ + write (iout,*) "Distance restraints as read from input" + do i=1,ndist_ + if (restr_type.eq.12) then + read (inp,*) ihpb_peak(nhpb_peak+1),jhpb_peak(nhpb_peak+1), + & dhpb_peak(nhpb_peak+1),dhpb1_peak(nhpb_peak+1), + & ibecarb_peak(nhpb_peak+1),forcon_peak(nhpb_peak+1), + & fordepth_peak(nhpb_peak+1),npeak +c write(iout,*) ihpb_peak(nhpb_peak+1),jhpb_peak(nhpb_peak+1), +c & dhpb_peak(nhpb_peak+1),dhpb1_peak(nhpb_peak+1), +c & ibecarb_peak(nhpb_peak+1),forcon_peak(nhpb_peak+1), +c & fordepth_peak(nhpb_peak+1),npeak + if (forcon_peak(nhpb_peak+1).le.0.0d0.or. + & fordepth_peak(nhpb_peak+1).le.0.0d0)cycle + nhpb_peak=nhpb_peak+1 + irestr_type_peak(nhpb_peak)=12 + if (ipeak(1,npeak).eq.0) ipeak(1,npeak)=i + ipeak(2,npeak)=i + write (iout,'(a,5i5,2f8.2,2f10.5,i5)') "+dist.restr ", + & nhpb_peak,ihpb_peak(nhpb_peak),jhpb_peak(nhpb_peak), + & ibecarb_peak(nhpb_peak),npeak,dhpb_peak(nhpb_peak), + & dhpb1_peak(nhpb_peak),forcon_peak(nhpb_peak), + & fordepth_peak(nhpb_peak),irestr_type_peak(nhpb_peak) + if (ibecarb_peak(nhpb_peak).eq.3) then + jhpb_peak(nhpb_peak)=jhpb_peak(nhpb_peak)+nres + else if (ibecarb_peak(nhpb_peak).eq.2) then + ihpb_peak(nhpb_peak)=ihpb_peak(nhpb_peak)+nres + else if (ibecarb_peak(nhpb_peak).eq.1) then + ihpb_peak(nhpb_peak)=ihpb_peak(nhpb_peak)+nres + jhpb_peak(nhpb_peak)=jhpb_peak(nhpb_peak)+nres + endif + else if (restr_type.eq.11) then + read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(nhpb+1), + & dhpb1(nhpb+1),ibecarb(i),forcon(nhpb+1),fordepth(nhpb+1) +c fordepth(nhpb+1)=fordepth(nhpb+1)/forcon(nhpb+1) + if (forcon(nhpb+1).le.0.0d0.or.fordepth(nhpb+1).le.0.0d0)cycle + nhpb=nhpb+1 + irestr_type(nhpb)=11 + write (iout,'(a,4i5,2f8.2,2f10.5,i5)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb), + & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),irestr_type(nhpb) +c if (ibecarb(nhpb).gt.0) then +c ihpb(nhpb)=ihpb(nhpb)+nres +c jhpb(nhpb)=jhpb(nhpb)+nres +c endif + if (ibecarb(nhpb).eq.3) then + ihpb(nhpb)=ihpb(nhpb)+nres + else if (ibecarb(nhpb).eq.2) then + ihpb(nhpb)=ihpb(nhpb)+nres + else if (ibecarb(nhpb).eq.1) then + ihpb(nhpb)=ihpb(nhpb)+nres + jhpb(nhpb)=jhpb(nhpb)+nres + endif + else if (restr_type.eq.10) then +c Cross-lonk Markov-like potential + call card_concat(controlcard,.true.) + call readi(controlcard,"ILINK",ihpb(nhpb+1),0) + call readi(controlcard,"JLINK",jhpb(nhpb+1),0) + ibecarb(nhpb+1)=0 + if (index(controlcard,"BETA").gt.0) ibecarb(nhpb+1)=1 + if (ihpb(nhpb+1).eq.0 .or. jhpb(nhpb+1).eq.0) cycle + if (index(controlcard,"ZL").gt.0) then + link_type=1 + else if (index(controlcard,"ADH").gt.0) then + link_type=2 + else if (index(controlcard,"PDH").gt.0) then + link_type=3 + else if (index(controlcard,"DSS").gt.0) then + link_type=4 + else + link_type=0 + endif + call reada(controlcard,"AXLINK",dhpb(nhpb+1), + & xlink(1,link_type)) + call reada(controlcard,"BXLINK",dhpb1(nhpb+1), + & xlink(2,link_type)) + call reada(controlcard,"CXLINK",fordepth(nhpb+1), + & xlink(3,link_type)) + call reada(controlcard,"SIGMA",forcon(nhpb+1), + & xlink(4,link_type)) + call reada(controlcard,"SCORE",xlscore(nhpb+1),1.0d0) +c read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),ibecarb(nhpb+1), +c & dhpb(nhpb+1),dhpb1(nhpb+1),forcon(nhpb+1),fordepth(nhpb+1) + if (forcon(nhpb+1).le.0.0d0 .or. + & (dhpb(nhpb+1).eq.0 .and. dhpb1(nhpb+1).eq.0)) cycle + nhpb=nhpb+1 + irestr_type(nhpb)=10 +c if (ibecarb(nhpb).gt.0) then +c ihpb(nhpb)=ihpb(nhpb)+nres +c jhpb(nhpb)=jhpb(nhpb)+nres +c endif + if (ibecarb(nhpb).eq.3) then + jhpb(nhpb)=jhpb(nhpb)+nres + else if (ibecarb(nhpb).eq.2) then + ihpb(nhpb)=ihpb(nhpb)+nres + else if (ibecarb(nhpb).eq.1) then + ihpb(nhpb)=ihpb(nhpb)+nres + jhpb(nhpb)=jhpb(nhpb)+nres + endif + write (iout,'(a,4i5,2f8.2,3f10.5,i5)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb), + & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),xlscore(nhpb), + & irestr_type(nhpb) + else +C print *,"in else" + read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(nhpb+1), + & dhpb1(nhpb+1),ibecarb(nhpb+1),forcon(nhpb+1) + if (forcon(nhpb+1).gt.0.0d0) then + nhpb=nhpb+1 + if (dhpb1(nhpb).eq.0.0d0) then + irestr_type(nhpb)=1 + else + irestr_type(nhpb)=2 + endif +c if (ibecarb(nhpb).gt.0) then +c ihpb(nhpb)=ihpb(nhpb)+nres +c jhpb(nhpb)=jhpb(nhpb)+nres +c endif + if (ibecarb(nhpb).eq.3) then + ihpb(nhpb)=ihpb(nhpb)+nres + else if (ibecarb(nhpb).eq.2) then + ihpb(nhpb)=ihpb(nhpb)+nres + else if (ibecarb(nhpb).eq.1) then + ihpb(nhpb)=ihpb(nhpb)+nres + jhpb(nhpb)=jhpb(nhpb)+nres + endif + if (dhpb(nhpb).eq.0.0d0) + & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) + endif + write (iout,'(a,4i5,f8.2,f10.1)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(i),dhpb(nhpb),forcon(nhpb) + endif +C read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),forcon(nhpb+1) +C if (forcon(nhpb+1).gt.0.0d0) then +C nhpb=nhpb+1 +C dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) + enddo + + if (restr_type.eq.4) then + write (iout,*) "The BFAC array" + do i=nnt,nct + write (iout,'(i5,f10.5)') i,bfac(i) + enddo + do i=nnt,nct + if (itype(i).eq.ntyp1) cycle + do j=nnt,i-1 + if (itype(j).eq.ntyp1) cycle + if (itype(i).eq.10) then + iiend=0 + else + iiend=1 + endif + if (itype(j).eq.10) then + jjend=0 + else + jjend=1 + endif + kk=0 + do ii=0,iiend + do jj=0,jjend + nhpb=nhpb+1 + irestr_type(nhpb)=1 + forcon(nhpb)=scal_bfac**2/(bfac(i)**2+bfac(j)**2) + irestr_type(nhpb)=1 + ibecarb(nhpb)=kk + if (ibecarb(nhpb).gt.0) ibecarb(nhpb)=4-ibecarb(nhpb) + ihpb(nhpb)=i+nres*ii + jhpb(nhpb)=j+nres*jj + dhpb(nhpb)=dist(i+nres*ii,j+nres*jj) + write (iout,'(a,4i5,2f8.2,3f10.5,i5)') "+dist.restr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb), + & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),xlscore(nhpb), + & irestr_type(nhpb) + kk=kk+1 + enddo + enddo + enddo + enddo + endif + + if (restr_type.eq.5) then + restr_on_coord=.true. + do i=nnt,nct + if (itype(i).eq.ntyp1) cycle + bfac(i)=(scal_bfac/bfac(i))**2 + enddo + endif + + ENDDO ! next + + fordepthmax=0.0d0 + if (normalize) then + do i=nss+1,nhpb + if (irestr_type(i).eq.11.and.fordepth(i).gt.fordepthmax) + & fordepthmax=fordepth(i) + enddo + do i=nss+1,nhpb + if (irestr_type(i).eq.11) fordepth(i)=fordepth(i)/fordepthmax + enddo + endif + if (nhpb.gt.nss) then + write (iout,'(/a,i5,a/4a5,2a8,3a10,a5)') + & "The following",nhpb-nss, + & " distance restraints have been imposed:", + & " Nr"," res1"," res2"," beta"," d1"," d2"," k"," V", + & " score"," type" + do i=nss+1,nhpb + write (iout,'(4i5,2f8.2,3f10.5,i5)')i-nss,ihpb(i),jhpb(i), + & ibecarb(i),dhpb(i),dhpb1(i),forcon(i),fordepth(i),xlscore(i), + & irestr_type(i) + enddo + endif + write (iout,*) + call hpb_partition + call flush(iout) + return + 11 write (iout,*)"read_dist_restr: error reading reference structure" + stop + end diff --git a/source/wham/src-HCD/readrtns.F.org b/source/wham/src-HCD/readrtns.F.org new file mode 100644 index 0000000..1fa6e46 --- /dev/null +++ b/source/wham/src-HCD/readrtns.F.org @@ -0,0 +1,691 @@ + subroutine read_general_data(*) + 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*800 controlcard + integer i,j,k,ii,n_ene_found + integer ind,itype1,itype2,itypf,itypsc,itypp + integer ilen + external ilen + character*16 ucase + character*16 key + external ucase + + call card_concat(controlcard,.true.) + call readi(controlcard,"N_ENE",n_ene,max_ene) + if (n_ene.gt.max_ene) then + write (iout,*) "Error: parameter out of range: N_ENE",n_ene, + & max_ene + return1 + endif + call readi(controlcard,"NPARMSET",nparmset,1) + if (nparmset.gt.max_parm) then + write (iout,*) "Error: parameter out of range: NPARMSET", + & nparmset, Max_Parm + return1 + endif + call readi(controlcard,"MAXIT",maxit,5000) + call reada(controlcard,"FIMIN",fimin,1.0d-3) + call readi(controlcard,"ENSEMBLES",ensembles,0) + write (iout,*) "Number of energy parameter sets",nparmset + call multreadi(controlcard,"ISAMPL",isampl,nparmset,1) + write (iout,*) "MaxSlice",MaxSlice + call readi(controlcard,"NSLICE",nslice,1) + call flush(iout) + if (nslice.gt.MaxSlice) then + write (iout,*) "Error: parameter out of range: NSLICE",nslice, + & MaxSlice + return1 + 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 + return1 + 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_mode,1) + write (iout,*) "delta",delta + write (iout,*) "einicheck",einicheck + write (iout,*) "rescale_mode",rescale_mode + 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 + entfile=index(controlcard,"ENTFILE").gt.0 + zscfile=index(controlcard,"ZSCFILE").gt.0 + return + end +c------------------------------------------------------------------------------ + subroutine read_efree(iparm,*) +C +C Read molecular data +C + 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*320 controlcard,ucase + integer iparm,ib,i,j + integer ilen + external ilen + call card_concat(controlcard,.true.) + call readi(controlcard,'NT',nT_h(iparm),1) + if (nT_h(iparm).gt.MaxT_h) then + write (iout,*) "Error: parameter out of range: NT",nT_h(iparm), + & MaxT_h + return1 + 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 + return1 + 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 + return + end +c----------------------------------------------------------------------------- + subroutine read_protein_data(iparm,*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + 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*64 nazwa + character*16000 controlcard + integer i,ii,ib,iR,iparm,ilen,iroof,nthr + external ilen,iroof + call flush(iout) +C 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 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!" + return1 + 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 + return + end +c------------------------------------------------------------------------------- + subroutine opentmp(islice,iunit,bprotfile_temp) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#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" + character*64 bprotfile_temp + character*3 liczba + character*2 liczba1 + integer iunit,islice + integer ilen,iroof + external ilen,iroof + logical lerr + + 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 + open (iunit,file=bprotfile_temp,status="unknown", + & form="unformatted",access="direct",recl=lenrec) +#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 + return + end +c------------------------------------------------------------------------------- + subroutine read_database(*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#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*4 csingle(3,maxres2) + character*64 nazwa,bprotfile_temp + character*3 liczba + character*2 liczba1 + integer i,j,ii,jj(maxslice),k,kk(maxslice),l, + & ll(maxslice),mm(maxslice),if + integer nrec,nlines,iscor,iunit,islice + double precision energ + integer ilen,iroof + external ilen,iroof + double precision rmsdev,energia(0:max_ene),efree,eini,temp + double precision prop(maxQ) + integer ntot_all(maxslice,0:maxprocs-1) + integer iparm,ib,iib,ir,nprop,nthr + double precision 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 + do iparm=1,nparmset + + 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 +c Read conformations from binary DA files (one per batch) and write them to +c 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,ii,jj(islice),kk(islice),ll(islice), + & mm(islice),iR,ib,iparm) + close(ientout) + enddo + close(ientin) + enddo + ENDIF ! NFILE_BIN>0 +c + IF (NFILE_ASC(iR,ib,iparm).GT.0) THEN +c Read conformations from multiple ASCII int files and write them to a binary +c 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 +c Read conformations from cx files and write them to a binary +c 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) + close(ientout) + write (iout,*) "exit cxread" + call flush(iout) + enddo + ENDIF + + do islice=1,nslice + 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 +c Check if everyone has the same number of conformations + call MPI_Allgather(stot(1),maxslice,MPI_INTEGER, + & ntot_all(1,0),maxslice,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) + return1 + endif + do islice=1,nslice + ntot(islice)=stot(islice) + enddo + return +#endif + 1111 write(iout,*) "Error opening coordinate file ",nazwa(:ilen(nazwa)) + call flush(iout) + return1 + end +c------------------------------------------------------------------------------ + subroutine card_concat(card,to_upper) + implicit none + include 'DIMENSIONS.ZSCOPT' + include "COMMON.IOUNITS" + character*(*) card + character*80 karta,ucase + logical to_upper + integer ilen + 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 +c------------------------------------------------------------------------------ + subroutine readi(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch + integer wartosc,default + integer ilen,iread + external ilen + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*) wartosc + return + end +c---------------------------------------------------------------------------- + subroutine reada(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch + character*80 aux + double precision wartosc,default + integer ilen,iread + external ilen + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*) wartosc + return + end +c---------------------------------------------------------------------------- + subroutine multreadi(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + integer tablica(dim),default + character*(*) rekord,lancuch + character*80 aux + integer ilen,iread + external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end +c---------------------------------------------------------------------------- + subroutine multreada(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + double precision tablica(dim),default + character*(*) rekord,lancuch + character*80 aux + integer ilen,iread + external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end +c---------------------------------------------------------------------------- + subroutine reads(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch,wartosc,default + character*80 aux + integer ilen,lenlan,lenrec,iread,ireade + external ilen + logical iblnk + external iblnk + lenlan=ilen(lancuch) + lenrec=ilen(rekord) + iread=index(rekord,lancuch(:lenlan)//"=") +c print *,"rekord",rekord," lancuch",lancuch +c print *,"iread",iread," lenlan",lenlan," lenrec",lenrec + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+lenlan+1 +c print *,"iread",iread +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) + iread=iread+1 +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + enddo +c print *,"iread",iread + if (iread.gt.lenrec) then + wartosc=default + return + endif + ireade=iread+1 +c print *,"ireade",ireade + do while (ireade.lt.lenrec .and. + & .not.iblnk(rekord(ireade:ireade))) + ireade=ireade+1 + enddo + wartosc=rekord(iread:ireade) + return + end +c---------------------------------------------------------------------------- + subroutine multreads(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + character*(*) rekord,lancuch,tablica(dim),default + character*80 aux + integer ilen,lenlan,lenrec,iread,ireade + external ilen + logical iblnk + external iblnk + do i=1,dim + tablica(i)=default + enddo + lenlan=ilen(lancuch) + lenrec=ilen(rekord) + iread=index(rekord,lancuch(:lenlan)//"=") +c print *,"rekord",rekord," lancuch",lancuch +c print *,"iread",iread," lenlan",lenlan," lenrec",lenrec + if (iread.eq.0) return + iread=iread+lenlan+1 + do i=1,dim +c print *,"iread",iread +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) + iread=iread+1 +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + enddo +c print *,"iread",iread + if (iread.gt.lenrec) return + ireade=iread+1 +c 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 +c---------------------------------------------------------------------------- + subroutine split_string(rekord,tablica,dim,nsub) + implicit none + integer dim,nsub,i,ii,ll,kk + character*(*) tablica(dim) + character*(*) rekord + integer ilen + external ilen + do i=1,dim + tablica(i)=" " + enddo + ii=1 + ll = ilen(rekord) + nsub=0 + do i=1,dim +C Find the start of term name + kk = 0 + do while (ii.le.ll .and. rekord(ii:ii).eq." ") + ii = ii+1 + enddo +C 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 +c-------------------------------------------------------------------------------- + integer function iroof(n,m) + ii = n/m + if (ii*m .lt. n) ii=ii+1 + iroof = ii + return + end diff --git a/source/wham/src-HCD/readrtns_compar.F b/source/wham/src-HCD/readrtns_compar.F new file mode 100644 index 0000000..0afad0a --- /dev/null +++ b/source/wham/src-HCD/readrtns_compar.F @@ -0,0 +1,167 @@ + subroutine read_compar +C +C Read molecular data +C + 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*320 controlcard,ucase + character*64 wfile + integer ilen + external ilen + integer i,j,k + + call card_concat(controlcard,.true.) + pdbref=(index(controlcard,'PDBREF').gt.0) + if (index(controlcard,"CASC").gt.0) then + iz_sc=1 + else if (index(controlcard,"SCONLY").gt.0) then + iz_sc=2 + else + iz_sc=0 + endif + 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) goto 121 +c Read the data pertaining to elementary fragments (level 1) + call readi(controlcard,'NFRAG',nfrag(1),0) + write(iout,*)"nfrag(1)",nfrag(1) + 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 +c 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 diff --git a/source/wham/src-HCD/refsys.f b/source/wham/src-HCD/refsys.f new file mode 100644 index 0000000..4b7b763 --- /dev/null +++ b/source/wham/src-HCD/refsys.f @@ -0,0 +1,70 @@ + subroutine refsys(i2,i3,i4,e1,e2,e3,fail) +c This subroutine calculates unit vectors of a local reference system +c defined by atoms (i2), (i3), and (i4). The x axis is the axis from + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include "COMMON.CHAIN" +c this subroutine calculates unity vectors of a local reference system +c defined by atoms (i2), (i3), and (i4). the x axis is the axis from +c atom (i3) to atom (i2), and the xy plane is the plane defined by atoms +c (i2), (i3), and (i4). z axis is directed according to the sign of the +c vector product (i3)-(i2) and (i3)-(i4). sets fail to .true. if atoms +c (i2) and (i3) or (i3) and (i4) coincide or atoms (i2), (i3), and (i4) +c form a linear fragment. returns vectors e1, e2, and e3. + logical fail + double precision e1(3),e2(3),e3(3) + double precision u(3),z(3) + double precision coinc/1.0D-13/,align /1.0D-13/ +c print *,'just initialize' + fail=.false. +c print *,fail + s1=0.0 + s2=0.0 + print *,s1,s2 + do 1 i=1,3 + print *, i2,i3,i4 + zi=c(i,i2)-c(i,i3) + ui=c(i,i4)-c(i,i3) + print *,zi,ui + s1=s1+zi*zi + s2=s2+ui*ui + z(i)=zi + 1 u(i)=ui + s1=sqrt(s1) + s2=sqrt(s2) + if (s1.gt.coinc) goto 2 + write (iout,1000) i2,i3,i1 + fail=.true. + return + 2 if (s2.gt.coinc) goto 4 + write(iout,1000) i3,i4,i1 + fail=.true. + return + print *,'two if pass' + 4 s1=1.0/s1 + s2=1.0/s2 + v1=z(2)*u(3)-z(3)*u(2) + v2=z(3)*u(1)-z(1)*u(3) + v3=z(1)*u(2)-z(2)*u(1) + anorm=sqrt(v1*v1+v2*v2+v3*v3) + if (anorm.gt.align) goto 6 + write (iout,1010) i2,i3,i4,i1 + fail=.true. + return + 6 anorm=1.0/anorm + e3(1)=v1*anorm + e3(2)=v2*anorm + e3(3)=v3*anorm + e1(1)=z(1)*s1 + e1(2)=z(2)*s1 + e1(3)=z(3)*s1 + e2(1)=e1(3)*e3(2)-e1(2)*e3(3) + e2(2)=e1(1)*e3(3)-e1(3)*e3(1) + e2(3)=e1(2)*e3(1)-e1(1)*e3(2) + 1000 format (/1x,' * * * Error - atoms',i4,' and',i4,' coincide.', + 1 'coordinates of atom',i4,' are set to zero.') + 1010 format (/1x,' * * * Error - atoms',2(i4,2h, ),i4,' form a linear', + 1 ' fragment. coordinates of atom',i4,' are set to zero.') + return + end diff --git a/source/wham/src-HCD/rescode.f b/source/wham/src-HCD/rescode.f new file mode 100644 index 0000000..dbbb459 --- /dev/null +++ b/source/wham/src-HCD/rescode.f @@ -0,0 +1,32 @@ + integer function rescode(iseq,nam,itype) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + character*3 nam,ucase + + if (itype.eq.0) then + + do i=-ntyp1,ntyp1 + if (ucase(nam).eq.restyp(i)) then + rescode=i + return + endif + enddo + + else + + do i=-ntyp1,ntyp1 + if (nam(1:1).eq.onelet(i)) then + rescode=i + return + endif + enddo + + endif + + write (iout,10) iseq,nam + stop + 10 format ('**** Error - residue',i4,' has an unresolved name ',a3) + end + diff --git a/source/wham/src-HCD/rmscalc.F b/source/wham/src-HCD/rmscalc.F new file mode 100644 index 0000000..319fa6d --- /dev/null +++ b/source/wham/src-HCD/rmscalc.F @@ -0,0 +1,303 @@ + double precision function rmscalc_frag(ishif,i,j,jcon,kkk, + & lprn) + 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' + double precision przes(3),obrot(3,3) + double precision creff(3,maxres2),cc(3,maxres2) + logical iadded(maxres) + integer inumber(2,maxres) + common /ccc/ creff,cc,iadded,inumber + logical lprn + logical non_conv + integer ishif,i,j + integer kkk + if (lprn) then + write (iout,*) "i",i," j",j," jcont",jcon," ishif",ishif + write (iout,*) "npiece",npiece(j,i) + write (iout,*) "kkk",kkk + call flush(iout) + endif +c write (iout,*) "symetr",symetr +c call flush(iout) +c nperm=1 +c do idup=1,symetr +c nperm=nperm*idup +c enddo +c write (iout,*) "nperm",nperm +c call flush(iout) +c do kkk=1,nperm + idup=0 + do l=1,nres + iadded(l)=.false. + enddo +c write (iout,*) "kkk",kkk +c 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) +c write (iout,*) "Exit cprep" +c call flush(iout) +c write (iout,*) "ii=",ii + else + kk = ipiece(k,j,i) +c 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) +c write (iout,*) "After cprep" +c call flush(iout) + enddo + endif + enddo + if (lprn) then + write (iout,*) "tuszukaj" +c 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 +c enddo + call flush(iout) + endif +c rminrms=1.0d10 +c 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 +c write (iout,*) "rmsmin", rminrms, "rms", rms +c if (rms.le.rminrms) rminrms=rms +c enddo + rmscalc_frag = dsqrt(rms) +c write (iout, *) "analysys", rmscalc,anatemp + return + end +c------------------------------------------------------------------------- + subroutine cprep(if1,if2,ishif,idup,kwa) + 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' + double precision przes(3),obrot(3,3) + double precision creff(3,maxres2),cc(3,maxres2) + logical iadded(maxres) + integer inumber(2,maxres),iistrart,kwa,blar + common /ccc/ creff,cc,iadded,inumber + integer ll,iperm +c write (iout,*) "Calling cprep if1",if1," if2",if2," ishif",ishif, +c & " kwa",kwa +c nperm=1 +c do blar=1,symetr +c nperm=nperm*blar +c enddo +c write (iout,*) "nperm",nperm +c kkk=kwa +c ii=0 + do l=if1,if2 +c write (iout,*) "l",l," iadded",iadded(l)," ireschain", +c & ireschain(l),ireschain(l+ishif) +c call flush(iout) + if (l+ishif.gt.1 .and. l+ishif.le.nres .and. .not.iadded(l) + & .and. ireschain(l+ishif).gt.0 .and. ireschain(l).gt.0 .and. + & ireschain(l).eq.ireschain(l+ishif)) then + idup=idup+1 + iadded(l)=.true. + inumber(1,idup)=l + inumber(2,idup)=l+ishif + ll=iperm(l+ishif,kwa) + do m=1,3 + creff(m,idup)=cref(m,l) + cc(m,idup)=c(m,ll) + enddo +c write (iout,'(2i5,3f10.5,5x,3f10.5)') l,ll, +c & (creff(m,idup),m=1,3),(cc(m,idup),m=1,3) + endif + enddo +c write (iout,*) "idup",idup + return + end +c------------------------------------------------------------------------- + double precision function rmsnat(jcon,ipermmin) + 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' + integer ipermmin + rmsnat = rmscalc(c(1,1),cref(1,1),ipermmin) + return + end +c----------------------------------------------------------------------------- + double precision function rmscalc(ccc,cccref,ipermmin) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + double precision cccref(3,maxres2),creff(3,maxres2), + & ccc(3,maxres2),cc(3,maxres2) + double precision przes(3),obrot(3,3) + logical non_conv + integer i,ii,j,ib,ichain,indchain,ichain1,ichain2, + & iperm,ipermmin + double precision rms,rmsmin +C Loop over chain permutations +c write (iout,*) "iz_sc",iz_sc + rmsmin=1.0d10 + DO IPERM=1,NPERMCHAIN +c write (iout,*) "iperm",iperm + ii=0 + if (iz_sc.lt.2) then + do ichain=1,nchain + indchain=tabpermchain(ichain,iperm) +#ifdef DEBUG + write (iout,*) "ichain",ichain," indchain",indchain + write (iout,*) "chain_border",chain_border(1,ichain), + & chain_border(2,ichain) +#endif + do i=1,chain_length(ichain) +c do i=nstart_sup(ichain),nend_sup(ichain) + ichain1=chain_border(1,ichain)+i-1 + ichain2=chain_border(1,indchain)+i-1 + if (ichain1.lt.nstart_sup .or. ichain1.gt.nend_sup .or. + & ichain2.lt.nstart_sup .or. ichain2.gt.nend_sup) cycle + ii=ii+1 +#ifdef DEBUG + write (iout,*) "back",ii," ichain1",ichain1, + & " ichain2",ichain2," i",i,chain_border(1,ichain)+i-1 +#endif + do j=1,3 + cc(j,ii)=ccc(j,ichain2) + creff(j,ii)=cccref(j,ichain1) + enddo +#ifdef DEBUG + write (iout,'(2i5,3f10.5,5x,3f10.5)') + & ichain1,ii,(cc(j,ii),j=1,3),(creff(j,ii),j=1,3) +#endif + enddo + enddo + endif + if (iz_sc.gt.0) then + do ichain=1,nchain + indchain=tabpermchain(ichain,iperm) + do i=1,chain_length(ichain) +c do i=nstart_sup(ichain),nend_sup(ichain) + ichain1=chain_border(1,ichain)+i-1 + ichain2=chain_border(1,indchain)+i-1 + if (ichain1.lt.nstart_sup .or. ichain1.gt.nend_sup .or. + & ichain2.lt.nstart_sup .or. ichain2.gt.nend_sup) cycle + if (itype(ichain1).ne.10) then + ii=ii+1 +#ifdef DEBUG + write (iout,*) "side",ii," ichain1",ichain1, + & " ichain2",ichain2 +#endif + do j=1,3 + cc(j,ii)=ccc(j,ichain2+nres) + creff(j,ii)=cccref(j,ichain1+nres) + enddo +#ifdef DEBUG + write (iout,'(2i5,3f10.5,5x,3f10.5)') + & ichain1+nres,ii,(cc(j,ii),j=1,3),(creff(j,ii),j=1,3) +#endif + endif + enddo + enddo + endif +c write (iout,*) "rmscalc: iprot",iprot," nsup",nsup(iprot)," ii",ii + call fitsq(rms,cc(1,1),creff(1,1),ii,przes,obrot,non_conv) + if (non_conv) then + write (iout,*) 'Error: FITSQ non-convergent' + rms=1.0d2 + else if (rms.lt.-1.0d-6) then + print *,'Error: rms^2 = ',rms + rms = 1.0d2 + else if (rms.ge.1.0d-6 .and. rms.lt.0) then + rmscalc=0.0d0 + else + rms = dsqrt(rms) + endif + if (rms.lt.rmsmin) then + rmsmin=rms + ipermmin=iperm + endif +#ifdef DEBUG + write (iout,*) "iperm",iperm," rms",rms +#endif + ENDDO + rmscalc=rmsmin +#ifdef DEBUG + write (iout,*) "ipermmin",ipermmin," rmsmin",rmsmin +#endif + return + end +c----------------------------------------------------------------------------- + double precision function gyrate(jcon) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.INTERACT' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + double precision cen(3),rg + + do j=1,3 + cen(j)=0.0d0 + enddo + + ii=0 + do i=nnt,nct + if (itype(i).eq.ntyp1) cycle + ii=ii+1 + do j=1,3 + cen(j)=cen(j)+c(j,i) + enddo + enddo + do j=1,3 + cen(j)=cen(j)/dble(ii) + enddo + rg = 0.0d0 + do i = nnt, nct + if (itype(i).eq.ntyp1) cycle + do j=1,3 + rg = rg + (c(j,i)-cen(j))**2 + enddo + end do + gyrate = dsqrt(rg/dble(ii)) + return + end diff --git a/source/wham/src-HCD/scr b/source/wham/src-HCD/scr new file mode 100644 index 0000000..09d13e7 --- /dev/null +++ b/source/wham/src-HCD/scr @@ -0,0 +1 @@ +sed -n 's/D/E/gp' | awk '{print $2,$4,$2*$4;sum=sum+$2*$4}END{print sum}' diff --git a/source/wham/src-HCD/secondary.f b/source/wham/src-HCD/secondary.f new file mode 100644 index 0000000..4088831 --- /dev/null +++ b/source/wham/src-HCD/secondary.f @@ -0,0 +1,713 @@ + subroutine define_fragments + 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,maxres/2) + integer nhairp,ihairp(2,maxres/5) + character*16 strstr(4) /'helix','hairpin','strand','strand pair'/ + 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 +c Find secondary structure elements (helices and beta-sheets) + call secondary2(.true.,.false.,ncont_pept_ref,icont_pept_ref, + & isec_ref) +c Define primary fragments. First include the helices. + nhairp=0 + nstrand=0 +c Merge helices +c 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 +c 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 +c 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 +c 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 +c------------------------------------------------------------------------------ + 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,maxres/3) + integer nhairp,ihairp(2,maxres/5) + 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 +c------------------------------------------------------------------------------ + 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,maxres/3) + integer nstrand,istrand(2,maxres/2) + integer nhairp,ihairp(2,maxres/5) + logical found + 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 +c------------------------------------------------------------------------------ + 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,maxres/2) + integer nhairp,ihairp(2,maxres/5) + logical found + 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 +c 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 +c 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 +c------------------------------------------------------------------------------ + subroutine secondary2(lprint,lprint_sec,ncont,icont,isecstr) + 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(maxres,4),nsec(maxres), + & isecstr(maxres) + logical lprint,lprint_sec,not_done,freeres + double precision p1,p2 + external freeres + character*1 csec(0:2) /'-','E','H'/ + 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 + +c finding parallel beta +cd write (iout,*) '------- looking for parallel beta -----------' + nbeta=0 + nstrand=0 + do i=1,ncont + i1=icont(1,i) + j1=icont(2,i) + if (i1.ge.nstart_sup .and. i1.le.nend_sup + & .and. j1.gt.nstart_sup .and. j1.le.nend_sup) then +cd write (iout,*) "parallel",i1,j1 + if(j1-i1.gt.5 .and. freeres(i1,j1,nsec,isec)) then + ii1=i1 + jj1=j1 +cd write (iout,*) i1,j1 + not_done=.true. + do while (not_done) + i1=i1+1 + j1=j1+1 + do j=1,ncont + if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j) .and. + & freeres(i1,j1,nsec,isec)) goto 5 + enddo + not_done=.false. + 5 continue +cd write (iout,*) i1,j1,not_done + enddo + j1=j1-1 + i1=i1-1 + if (i1-ii1.gt.1) then + ii1=max0(ii1-1,1) + jj1=max0(jj1-1,1) + nbeta=nbeta+1 + if(lprint)write(iout,'(a,i3,4i4)')'parallel beta', + & nbeta,ii1,i1,jj1,j1 + + nbfrag=nbfrag+1 + bfrag(1,nbfrag)=ii1+1 + bfrag(2,nbfrag)=i1+1 + bfrag(3,nbfrag)=jj1+1 + bfrag(4,nbfrag)=min0(j1+1,nres) + + do ij=ii1,i1 + nsec(ij)=nsec(ij)+1 + isec(ij,nsec(ij))=nbeta + enddo + do ij=jj1,j1 + nsec(ij)=nsec(ij)+1 + isec(ij,nsec(ij))=nbeta + enddo + + if(lprint_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 + +c finding antiparallel beta +cd write (iout,*) '--------- looking for antiparallel beta ---------' + + do i=1,ncont + i1=icont(1,i) + j1=icont(2,i) + if (freeres(i1,j1,nsec,isec)) then + ii1=i1 + jj1=j1 +cd write (iout,*) i1,j1 + + not_done=.true. + do while (not_done) + i1=i1+1 + j1=j1-1 + do j=1,ncont + if (i1.eq.icont(1,j).and.j1.eq.icont(2,j) .and. + & freeres(i1,j1,nsec,isec)) goto 6 + enddo + not_done=.false. + 6 continue +cd write (iout,*) i1,j1,not_done + enddo + i1=i1-1 + j1=j1+1 + if (i1-ii1.gt.1) then + + nbfrag=nbfrag+1 + bfrag(1,nbfrag)=ii1 + bfrag(2,nbfrag)=min0(i1+1,nres) + bfrag(3,nbfrag)=min0(jj1+1,nres) + bfrag(4,nbfrag)=j1 + + nbeta=nbeta+1 + iii1=max0(ii1-1,1) + do ij=iii1,i1 + nsec(ij)=nsec(ij)+1 + if (nsec(ij).le.2) then + isec(ij,nsec(ij))=nbeta + endif + enddo + jjj1=max0(j1-1,1) + do ij=jjj1,jj1 + nsec(ij)=nsec(ij)+1 + if (nsec(ij).le.2) 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 + +cd write (iout,*) "After beta:",nbfrag +cd do i=1,nbfrag +cd write (iout,*) (bfrag(j,i),j=1,4) +cd 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 + + +c finding alpha or 310 helix + + nhelix=0 + do i=1,ncont + i1=icont(1,i) + j1=icont(2,i) + p1=phi(i1+2)*rad2deg + p2=0.0 + if (j1+2.le.nres) p2=phi(j1+2)*rad2deg + + + if (j1.eq.i1+3 .and. + & ((p1.ge.10.and.p1.le.80).or.i1.le.2).and. + & ((p2.ge.10.and.p2.le.80).or.j1.le.2.or.j1.ge.nres-3) )then +cd if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,p1,p2 +co if (j1.eq.i1+4) write (iout,*) "found 1-5 ",i1,j1,p1,p2 + ii1=i1 + jj1=j1 + if (nsec(ii1).eq.0) then + not_done=.true. + else + not_done=.false. + endif + do while (not_done) + i1=i1+1 + j1=j1+1 + do j=1,ncont + if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10 + enddo + not_done=.false. + 10 continue + p1=phi(i1+2)*rad2deg + p2=phi(j1+2)*rad2deg + if (p1.lt.10.or.p1.gt.80.or.p2.lt.10.or.p2.gt.80) + & not_done=.false. + +cd write (iout,*) i1,j1,not_done,p1,p2 + enddo + j1=j1+1 + if (j1-ii1.gt.4) then + nhelix=nhelix+1 +cd write (iout,*)'helix',nhelix,ii1,j1 + + nhfrag=nhfrag+1 + hfrag(1,nhfrag)=ii1 + hfrag(2,nhfrag)=j1 + + do ij=ii1,j1 + nsec(ij)=-1 + enddo + if (lprint_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 +c------------------------------------------------- + logical function freeres(i,j,nsec,isec) + include 'DIMENSIONS' + integer isec(maxres,4),nsec(maxres) + 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 + diff --git a/source/wham/src-HCD/seq2chains.f b/source/wham/src-HCD/seq2chains.f new file mode 100644 index 0000000..cf38c87 --- /dev/null +++ b/source/wham/src-HCD/seq2chains.f @@ -0,0 +1,56 @@ + subroutine seq2chains(nres,itype,nchain,chain_length,chain_border, + & ireschain) +c +c Split the total UNRES sequence, which has dummy residues separating +c the chains, into separate chains. The length of chain ichain is +c contained in chain_length(ichain), the first and last non-dummy +c residues are in chain_border(1,ichain) and chain_border(2,ichain), +c respectively. The lengths pertain to non-dummy residues only. +c + implicit none + include 'DIMENSIONS' + integer nres,itype(nres),nchain,chain_length(nres), + & chain_border(2,nres),ireschain(nres) + integer ii,ichain,i,j + logical new_chain + ichain=1 + new_chain=.true. + chain_length(ichain)=0 + ii=1 + do while (ii.lt.nres) + if (itype(ii).eq.ntyp1) then + if (.not.new_chain) then + new_chain=.true. + chain_border(2,ichain)=ii-1 + ichain=ichain+1 + chain_border(1,ichain)=ii+1 + chain_length(ichain)=0 + endif + else + if (new_chain) then + chain_border(1,ichain)=ii + new_chain=.false. + endif + chain_length(ichain)=chain_length(ichain)+1 + endif + ii=ii+1 + enddo + if (itype(nres).eq.ntyp1) then + ii=ii-1 + else + chain_length(ichain)=chain_length(ichain)+1 + endif + if (chain_length(ichain).gt.0) then + chain_border(2,ichain)=ii + nchain=ichain + else + nchain=ichain-1 + endif + ireschain=0 + do i=1,nchain + do j=chain_border(1,i),chain_border(2,i) + ireschain(j)=i + enddo + enddo + return + end diff --git a/source/wham/src-HCD/setup_var.f b/source/wham/src-HCD/setup_var.f new file mode 100644 index 0000000..f052400 --- /dev/null +++ b/source/wham/src-HCD/setup_var.f @@ -0,0 +1,31 @@ + subroutine setup_var + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' +C Set up variable list. + ntheta=nres-2 + nphi=nres-3 + nvar=ntheta+nphi + nside=0 + do i=2,nres-1 + if (itype(i).ne.10) then + nside=nside+1 + ialph(i,1)=nvar+nside + ialph(nside,2)=i + endif + enddo + if (indphi.gt.0) then + nvar=nphi + else if (indback.gt.0) then + nvar=nphi+ntheta + else + nvar=nvar+2*nside + endif +cd write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1) + return + end diff --git a/source/wham/src-HCD/slices.F b/source/wham/src-HCD/slices.F new file mode 100644 index 0000000..b22ea13 --- /dev/null +++ b/source/wham/src-HCD/slices.F @@ -0,0 +1,80 @@ + 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 + double precision 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 +c----------------------------------------------------------------------------- + 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 + double precision ts(MaxSlice),te(MaxSlice),time_slice + integer i,ii,irecord + double precision time + +c write (iout,*) "within slice nslice",nslice +c 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)) ) +c write (iout,*) "ii",ii,time,ts(ii) +c call flush(iout) + ii=ii+1 + enddo + endif +c write (iout,*) "end: ii",ii +c call flush(iout) + slice=ii + return + end diff --git a/source/wham/src-HCD/ssMD.F b/source/wham/src-HCD/ssMD.F new file mode 100644 index 0000000..ba32ff0 --- /dev/null +++ b/source/wham/src-HCD/ssMD.F @@ -0,0 +1,2168 @@ +c---------------------------------------------------------------------------- + subroutine check_energies +c implicit none + +c Includes + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.SBRIDGE' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + +c External functions + double precision ran_number + external ran_number + +c Local variables + integer i,j,k,l,lmax,p,pmax + double precision rmin,rmax + double precision eij + + double precision d + double precision wi,rij,tj,pj + + +c return + + i=5 + j=14 + + d=dsc(1) + rmin=2.0D0 + rmax=12.0D0 + + lmax=10000 + pmax=1 + + do k=1,3 + c(k,i)=0.0D0 + c(k,j)=0.0D0 + c(k,nres+i)=0.0D0 + c(k,nres+j)=0.0D0 + enddo + + do l=1,lmax + +ct wi=ran_number(0.0D0,pi) +c wi=ran_number(0.0D0,pi/6.0D0) +c wi=0.0D0 +ct tj=ran_number(0.0D0,pi) +ct pj=ran_number(0.0D0,pi) +c pj=ran_number(0.0D0,pi/6.0D0) +c pj=0.0D0 + + do p=1,pmax +ct rij=ran_number(rmin,rmax) + + c(1,j)=d*sin(pj)*cos(tj) + c(2,j)=d*sin(pj)*sin(tj) + c(3,j)=d*cos(pj) + + c(3,nres+i)=-rij + + c(1,i)=d*sin(wi) + c(3,i)=-rij-d*cos(wi) + + do k=1,3 + dc(k,nres+i)=c(k,nres+i)-c(k,i) + dc_norm(k,nres+i)=dc(k,nres+i)/d + dc(k,nres+j)=c(k,nres+j)-c(k,j) + dc_norm(k,nres+j)=dc(k,nres+j)/d + enddo + + call dyn_ssbond_ene(i,j,eij) + enddo + enddo + + call exit(1) + + return + end + +C----------------------------------------------------------------------------- + + subroutine dyn_ssbond_ene(resi,resj,eij) +c implicit none + +c Includes + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' +#ifndef CLUST +#ifndef WHAM +C include 'COMMON.MD' +#endif +#endif + +c External functions + double precision h_base + external h_base + +c Input arguments + integer resi,resj + +c Output arguments + double precision eij + +c Local variables + logical havebond +c integer itypi,itypj,k,l + double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi + double precision sig0ij,ljd,sig,fac,e1,e2 + double precision dcosom1(3),dcosom2(3),ed + double precision pom1,pom2 + double precision ljA,ljB,ljXs + double precision d_ljB(1:3) + double precision ssA,ssB,ssC,ssXs + double precision ssxm,ljxm,ssm,ljm + double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3) + double precision f1,f2,h1,h2,hd1,hd2 + double precision omega,delta_inv,deltasq_inv,fac1,fac2 +c-------FIRST METHOD + double precision xm,d_xm(1:3) +c-------END FIRST METHOD +c-------SECOND METHOD +c$$$ double precision ss,d_ss(0:3),ljf,d_ljf(0:3) +c-------END SECOND METHOD + +c-------TESTING CODE + logical checkstop,transgrad + common /sschecks/ checkstop,transgrad + + integer icheck,nicheck,jcheck,njcheck + double precision echeck(-1:1),deps,ssx0,ljx0 +c-------END TESTING CODE + + + i=resi + j=resj + + itypi=itype(i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) + dsci_inv=vbld_inv(i+nres) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + xi=mod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=mod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=mod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize + if ((zi.gt.bordlipbot) + &.and.(zi.lt.bordliptop)) then +C the energy transfer exist + if (zi.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((zi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipi=sscalelip(fracinbuf) + ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick + elseif (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick) + sslipi=sscalelip(fracinbuf) + ssgradlipi=sscagradlip(fracinbuf)/lipbufthick + else + sslipi=1.0d0 + ssgradlipi=0.0 + endif + else + sslipi=0.0d0 + ssgradlipi=0.0 + endif + itypj=itype(j) + xj=c(1,nres+j) + yj=c(2,nres+j) + zj=c(3,nres+j) + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + if ((zj.gt.bordlipbot) + &.and.(zj.lt.bordliptop)) then +C the energy transfer exist + if (zj.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((zj-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipj=sscalelip(fracinbuf) + ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick + elseif (zj.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick) + sslipj=sscalelip(fracinbuf) + ssgradlipj=sscagradlip(fracinbuf)/lipbufthick + else + sslipj=1.0d0 + ssgradlipj=0.0 + endif + else + sslipj=0.0d0 + ssgradlipj=0.0 + endif + aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 + bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 + xj=xj-xi + yj=yj-yi + zj=zj-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + dscj_inv=vbld_inv(j+nres) + + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse +c The following are set in sc_angular +c erij(1)=xj*rij +c erij(2)=yj*rij +c erij(3)=zj*rij +c om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) +c om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) +c om12=dxi*dxj+dyi*dyj+dzi*dzj + call sc_angular + rij=1.0D0/rij ! Reset this so it makes sense + + sig0ij=sigma(itypi,itypj) + sig=sig0ij*dsqrt(1.0D0/sigsq) + + ljXs=sig-sig0ij + ljA=eps1*eps2rt**2*eps3rt**2 + ljB=ljA*bb + ljA=ljA*aa + ljxm=ljXs+(-2.0D0*aa/bb)**(1.0D0/6.0D0) + + ssXs=d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + ssA=akcm + ssB=akct*deltat12 + ssC=ss_depth + & +akth*(deltat1*deltat1+deltat2*deltat2) + & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi + ssxm=ssXs-0.5D0*ssB/ssA + +c-------TESTING CODE +c$$$c Some extra output +c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA +c$$$ ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) +c$$$ ssx0=ssB*ssB-4.0d0*ssA*ssC +c$$$ if (ssx0.gt.0.0d0) then +c$$$ ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA +c$$$ else +c$$$ ssx0=ssxm +c$$$ endif +c$$$ ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ", +c$$$ & ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12 +c$$$ return +c-------END TESTING CODE + +c-------TESTING CODE +c Stop and plot energy and derivative as a function of distance + if (checkstop) then + ssm=ssC-0.25D0*ssB*ssB/ssA + ljm=-0.25D0*ljB*bb/aa + if (ssm.lt.ljm .and. + & dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then + nicheck=1000 + njcheck=1 + deps=0.5d-7 + else + checkstop=.false. + endif + endif + if (.not.checkstop) then + nicheck=0 + njcheck=-1 + endif + + do icheck=0,nicheck + do jcheck=-1,njcheck + if (checkstop) rij=(ssxm-1.0d0)+ + & ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps +c-------END TESTING CODE + + if (rij.gt.ljxm) then + havebond=.false. + ljd=rij-ljXs + fac=(1.0D0/ljd)**expon + e1=fac*fac*aa + e2=fac*bb + eij=eps1*eps2rt*eps3rt*(e1+e2) +C write(iout,*) eij,'TU?1' + 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 +C write(iout,*) 'TU?2',ssc,ssd + ed=2*akcm*ssd+akct*deltat12 + pom1=akct*ssd + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + else + omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi + + d_ssxm(1)=0.5D0*akct/ssA + d_ssxm(2)=-d_ssxm(1) + d_ssxm(3)=0.0D0 + + d_ljxm(1)=sig0ij/sqrt(sigsq**3) + d_ljxm(2)=d_ljxm(1)*sigsq_om2 + d_ljxm(3)=d_ljxm(1)*sigsq_om12 + d_ljxm(1)=d_ljxm(1)*sigsq_om1 + +c-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE + xm=0.5d0*(ssxm+ljxm) + do k=1,3 + d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k)) + enddo + if (rij.lt.xm) then + havebond=.true. + ssm=ssC-0.25D0*ssB*ssB/ssA + d_ssm(1)=0.5D0*akct*ssB/ssA + d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) + d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) + d_ssm(3)=omega + f1=(rij-xm)/(ssxm-xm) + f2=(rij-ssxm)/(xm-ssxm) + h1=h_base(f1,hd1) + h2=h_base(f2,hd2) + eij=ssm*h1+Ht*h2 +C write(iout,*) eij,'TU?3' + 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/aa + d_ljm(1)=-0.5D0*bb/aa*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 +C write(iout,*) 'TU?4',ssA + delta_inv=1.0d0/(ljxm-xm) + deltasq_inv=delta_inv*delta_inv + fac=Ht*hd1-ljm*hd2 + fac1=deltasq_inv*fac*(ljxm-rij) + fac2=deltasq_inv*fac*(rij-xm) + ed=delta_inv*(ljm*hd2-Ht*hd1) + eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1) + eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2) + eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3) + endif +c-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE + +c-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE +c$$$ ssd=rij-ssXs +c$$$ ljd=rij-ljXs +c$$$ fac1=rij-ljxm +c$$$ fac2=rij-ssxm +c$$$ +c$$$ d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt) +c$$$ d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt) +c$$$ d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt) +c$$$ +c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA +c$$$ d_ssm(1)=0.5D0*akct*ssB/ssA +c$$$ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) +c$$$ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) +c$$$ d_ssm(3)=omega +c$$$ +c$$$ ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj) +c$$$ do k=1,3 +c$$$ d_ljm(k)=ljm*d_ljB(k) +c$$$ enddo +c$$$ ljm=ljm*ljB +c$$$ +c$$$ ss=ssA*ssd*ssd+ssB*ssd+ssC +c$$$ d_ss(0)=2.0d0*ssA*ssd+ssB +c$$$ d_ss(2)=akct*ssd +c$$$ d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega +c$$$ d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega +c$$$ d_ss(3)=omega +c$$$ +c$$$ ljf=bb(itypi,itypj)/aa(itypi,itypj) +c$$$ ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0) +c$$$ d_ljf(0)=ljf*2.0d0*ljB*fac1 +c$$$ do k=1,3 +c$$$ d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1- +c$$$ & 2.0d0*ljB*fac1*d_ljxm(k)) +c$$$ enddo +c$$$ ljf=ljm+ljf*ljB*fac1*fac1 +c$$$ +c$$$ f1=(rij-ljxm)/(ssxm-ljxm) +c$$$ f2=(rij-ssxm)/(ljxm-ssxm) +c$$$ h1=h_base(f1,hd1) +c$$$ h2=h_base(f2,hd2) +c$$$ eij=ss*h1+ljf*h2 +c$$$ delta_inv=1.0d0/(ljxm-ssxm) +c$$$ deltasq_inv=delta_inv*delta_inv +c$$$ fac=ljf*hd2-ss*hd1 +c$$$ ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac +c$$$ eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(1)-fac2*(d_ljxm(1))) +c$$$ eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(2)-fac2*(d_ljxm(2))) +c$$$ eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(3)-fac2*(d_ljxm(3))) +c$$$ +c$$$ havebond=.false. +c$$$ if (ed.gt.0.0d0) havebond=.true. +c-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE + + endif + write(iout,*) 'havebond',havebond + if (havebond) then +#ifndef CLUST +#ifndef WHAM +c if (dyn_ssbond_ij(i,j).eq.1.0d300) then +c write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_E_FORM",totT,t_bath,i,j +c endif +#endif +#endif + dyn_ssbond_ij(i,j)=eij + else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then + dyn_ssbond_ij(i,j)=1.0d300 +#ifndef CLUST +#ifndef WHAM +c write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_E_BREAK",totT,t_bath,i,j +#endif +#endif + endif + +c-------TESTING CODE + if (checkstop) then + if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') + & "CHECKSTOP",rij,eij,ed + echeck(jcheck)=eij + endif + enddo + if (checkstop) then + write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps + endif + enddo + if (checkstop) then + transgrad=.true. + checkstop=.false. + endif +c-------END TESTING CODE + + do k=1,3 + dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij + dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij + enddo + do k=1,3 + gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + gvdwx(k,j)=gvdwx(k,j)+gg(k) + & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + enddo +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) +cgrad enddo +cgrad enddo + + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo + + return + end + +C----------------------------------------------------------------------------- + + double precision function h_base(x,deriv) +c A smooth function going 0->1 in range [0,1] +c It should NOT be called outside range [0,1], it will not work there. + implicit none + +c Input arguments + double precision x + +c Output arguments + double precision deriv + +c Local variables + double precision xsq + + +c Two parabolas put together. First derivative zero at extrema +c$$$ if (x.lt.0.5D0) then +c$$$ h_base=2.0D0*x*x +c$$$ deriv=4.0D0*x +c$$$ else +c$$$ deriv=1.0D0-x +c$$$ h_base=1.0D0-2.0D0*deriv*deriv +c$$$ deriv=4.0D0*deriv +c$$$ endif + +c Third degree polynomial. First derivative zero at extrema + h_base=x*x*(3.0d0-2.0d0*x) + deriv=6.0d0*x*(1.0d0-x) + +c Fifth degree polynomial. First and second derivatives zero at extrema +c$$$ xsq=x*x +c$$$ h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0) +c$$$ deriv=x-1.0d0 +c$$$ deriv=deriv*deriv +c$$$ deriv=30.0d0*xsq*deriv + + return + end + +c---------------------------------------------------------------------------- + + subroutine dyn_set_nss +c Adjust nss and other relevant variables based on dyn_ssbond_ij +c implicit none + +c Includes + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' +C include 'COMMON.SETUP' +#ifndef CLUST +#ifndef WHAM +C include 'COMMON.MD' +#endif +#endif + +c Local variables + double precision emin + integer i,j,imin + integer diff,allflag(maxdim),allnss, + & allihpb(maxdim),alljhpb(maxdim), + & newnss,newihpb(maxdim),newjhpb(maxdim) + logical found + integer i_newnss(1024),displ(0:1024) + integer g_newihpb(maxdim),g_newjhpb(maxdim),g_newnss + + allnss=0 + do i=1,nres-1 + do j=i+1,nres + if (dyn_ssbond_ij(i,j).lt.1.0d300) then + allnss=allnss+1 + allflag(allnss)=0 + allihpb(allnss)=i + alljhpb(allnss)=j + endif + enddo + enddo + +cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + + 1 emin=1.0d300 + do i=1,allnss + if (allflag(i).eq.0 .and. + & dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then + emin=dyn_ssbond_ij(allihpb(i),alljhpb(i)) + imin=i + endif + enddo + if (emin.lt.1.0d300) then + allflag(imin)=1 + do i=1,allnss + if (allflag(i).eq.0 .and. + & (allihpb(i).eq.allihpb(imin) .or. + & alljhpb(i).eq.allihpb(imin) .or. + & allihpb(i).eq.alljhpb(imin) .or. + & alljhpb(i).eq.alljhpb(imin))) then + allflag(i)=-1 + endif + enddo + goto 1 + endif + +cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + + newnss=0 + do i=1,allnss + if (allflag(i).eq.1) then + newnss=newnss+1 + newihpb(newnss)=allihpb(i) + newjhpb(newnss)=alljhpb(i) + endif + enddo + +#ifdef MPI + if (nfgtasks.gt.1)then + + call MPI_Reduce(newnss,g_newnss,1, + & MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) + call MPI_Gather(newnss,1,MPI_INTEGER, + & i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_newnss(i-1)+displ(i-1) + enddo + call MPI_Gatherv(newihpb,newnss,MPI_INTEGER, + & g_newihpb,i_newnss,displ,MPI_INTEGER, + & king,FG_COMM,IERR) + call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER, + & g_newjhpb,i_newnss,displ,MPI_INTEGER, + & king,FG_COMM,IERR) + if(fg_rank.eq.0) then +c print *,'g_newnss',g_newnss +c print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss) +c print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss) + newnss=g_newnss + do i=1,newnss + newihpb(i)=g_newihpb(i) + newjhpb(i)=g_newjhpb(i) + enddo + endif + endif +#endif + + diff=newnss-nss + +cmc write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss) + + do i=1,nss + found=.false. + do j=1,newnss + if (idssb(i).eq.newihpb(j) .and. + & jdssb(i).eq.newjhpb(j)) found=.true. + enddo +#ifndef CLUST +#ifndef WHAM +c if (.not.found.and.fg_rank.eq.0) +c & write(iout,'(a15,f12.2,f8.1,2i5)') +c & "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 +c if (.not.found.and.fg_rank.eq.0) +c & write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i) +#endif +#endif + enddo + + nss=newnss + do i=1,nss + idssb(i)=newihpb(i) + jdssb(i)=newjhpb(i) + enddo + + return + end + +c---------------------------------------------------------------------------- + +#ifdef SSREAD +#ifdef WHAM + subroutine read_ssHist + implicit none + +c Includes + include 'DIMENSIONS' + include "DIMENSIONS.FREE" + include 'COMMON.FREE' + +c Local variables + integer i,j + character*80 controlcard + + do i=1,dyn_nssHist + call card_concat(controlcard,.true.) + read(controlcard,*) + & dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0)) + enddo + + return + end +#endif +#endif +c---------------------------------------------------------------------------- + + +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- + +c$$$c----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax(i_in,j_in) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c Input arguments +c$$$ integer i_in,j_in +c$$$ +c$$$c Local variables +c$$$ integer i,iretcode,nfun_sc +c$$$ logical scfail +c$$$ double precision var(maxvar),e_sc,etot +c$$$ +c$$$ +c$$$ mask_r=.true. +c$$$ do i=nnt,nct +c$$$ mask_side(i)=0 +c$$$ enddo +c$$$ mask_side(i_in)=1 +c$$$ mask_side(j_in)=1 +c$$$ +c$$$c Minimize the two selected side-chains +c$$$ call overlap_sc(scfail) ! Better not fail! +c$$$ call minimize_sc(e_sc,var,iretcode,nfun_sc) +c$$$ +c$$$ mask_r=.false. +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c------------------------------------------------------------- +c$$$ +c$$$ subroutine minimize_sc(etot_sc,iretcode,nfun) +c$$$c Minimize side-chains only, starting from geom but without modifying +c$$$c bond lengths. +c$$$c If mask_r is already set, only the selected side-chains are minimized, +c$$$c otherwise all side-chains are minimized keeping the backbone frozen. +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.MINIM' +c$$$ integer icall +c$$$ common /srutu/ icall +c$$$ +c$$$c Output arguments +c$$$ double precision etot_sc +c$$$ integer iretcode,nfun +c$$$ +c$$$c External functions/subroutines +c$$$ external func_sc,grad_sc,fdum +c$$$ +c$$$c Local variables +c$$$ integer liv,lv +c$$$ parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +c$$$ integer iv(liv) +c$$$ double precision rdum(1) +c$$$ double precision d(maxvar),v(1:lv),x(maxvar),xx(maxvar) +c$$$ integer idum(1) +c$$$ integer i,nvar_restr +c$$$ +c$$$ +c$$$cmc start_minim=.true. +c$$$ call deflt(2,iv,liv,lv,v) +c$$$* 12 means fresh start, dont call deflt +c$$$ iv(1)=12 +c$$$* max num of fun calls +c$$$ if (maxfun.eq.0) maxfun=500 +c$$$ iv(17)=maxfun +c$$$* max num of iterations +c$$$ if (maxmin.eq.0) maxmin=1000 +c$$$ iv(18)=maxmin +c$$$* controls output +c$$$ iv(19)=1 +c$$$* selects output unit +c$$$ iv(21)=0 +c$$$c iv(21)=iout ! DEBUG +c$$$c iv(21)=8 ! DEBUG +c$$$* 1 means to print out result +c$$$ iv(22)=0 +c$$$c iv(22)=1 ! DEBUG +c$$$* 1 means to print out summary stats +c$$$ iv(23)=0 +c$$$c iv(23)=1 ! DEBUG +c$$$* 1 means to print initial x and d +c$$$ iv(24)=0 +c$$$c iv(24)=1 ! DEBUG +c$$$* min val for v(radfac) default is 0.1 +c$$$ v(24)=0.1D0 +c$$$* max val for v(radfac) default is 4.0 +c$$$ v(25)=2.0D0 +c$$$c v(25)=4.0D0 +c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +c$$$* the sumsl default is 0.1 +c$$$ v(26)=0.1D0 +c$$$* false conv if (act fnctn decrease) .lt. v(34) +c$$$* the sumsl default is 100*machep +c$$$ v(34)=v(34)/100.0D0 +c$$$* absolute convergence +c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4 +c$$$ v(31)=tolf +c$$$* relative convergence +c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-1 +c$$$ v(32)=rtolf +c$$$* controls initial step size +c$$$ v(35)=1.0D-1 +c$$$* large vals of d correspond to small components of step +c$$$ do i=1,nphi +c$$$ d(i)=1.0D-1 +c$$$ enddo +c$$$ do i=nphi+1,nvar +c$$$ d(i)=1.0D-1 +c$$$ enddo +c$$$ +c$$$ call geom_to_var(nvar,x) +c$$$ IF (mask_r) THEN +c$$$ do i=1,nres ! Just in case... +c$$$ mask_phi(i)=0 +c$$$ mask_theta(i)=0 +c$$$ enddo +c$$$ call x2xx(x,xx,nvar_restr) +c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc, +c$$$ & iv,liv,lv,v,idum,rdum,fdum) +c$$$ call xx2x(x,xx) +c$$$ ELSE +c$$$c When minimizing ALL side-chains, etotal_sc is a little +c$$$c faster if we don't set mask_r +c$$$ do i=1,nres +c$$$ mask_phi(i)=0 +c$$$ mask_theta(i)=0 +c$$$ mask_side(i)=1 +c$$$ enddo +c$$$ call x2xx(x,xx,nvar_restr) +c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc, +c$$$ & iv,liv,lv,v,idum,rdum,fdum) +c$$$ call xx2x(x,xx) +c$$$ ENDIF +c$$$ call var_to_geom(nvar,x) +c$$$ call chainbuild_sc +c$$$ etot_sc=v(10) +c$$$ iretcode=iv(1) +c$$$ nfun=iv(6) +c$$$ return +c$$$ end +c$$$ +c$$$C-------------------------------------------------------------------------- +c$$$ +c$$$ subroutine chainbuild_sc +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c Local variables +c$$$ integer i +c$$$ +c$$$ +c$$$ do i=nnt,nct +c$$$ if (.not.mask_r .or. mask_side(i).eq.1) then +c$$$ call locate_side_chain(i) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C-------------------------------------------------------------------------- +c$$$ +c$$$ subroutine func_sc(n,x,nf,f,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.MINIM' +c$$$ include 'COMMON.IOUNITS' +c$$$ +c$$$c Input arguments +c$$$ integer n +c$$$ double precision x(maxvar) +c$$$ double precision ufparm +c$$$ external ufparm +c$$$ +c$$$c Input/Output arguments +c$$$ integer nf +c$$$ integer uiparm(1) +c$$$ double precision urparm(1) +c$$$ +c$$$c Output arguments +c$$$ double precision f +c$$$ +c$$$c Local variables +c$$$ double precision energia(0:n_ene) +c$$$#ifdef OSF +c$$$c Variables used to intercept NaNs +c$$$ double precision x_sum +c$$$ integer i_NAN +c$$$#endif +c$$$ +c$$$ +c$$$ nfl=nf +c$$$ icg=mod(nf,2)+1 +c$$$ +c$$$#ifdef OSF +c$$$c Intercept NaNs in the coordinates, before calling etotal_sc +c$$$ x_sum=0.D0 +c$$$ do i_NAN=1,n +c$$$ x_sum=x_sum+x(i_NAN) +c$$$ enddo +c$$$c Calculate the energy only if the coordinates are ok +c$$$ if ((.not.(x_sum.lt.0.D0)) .and. (.not.(x_sum.ge.0.D0))) then +c$$$ write(iout,*)" *** func_restr_sc : Found NaN in coordinates" +c$$$ f=1.0D+77 +c$$$ nf=0 +c$$$ else +c$$$#endif +c$$$ +c$$$ call var_to_geom_restr(n,x) +c$$$ call zerograd +c$$$ call chainbuild_sc +c$$$ call etotal_sc(energia(0)) +c$$$ f=energia(0) +c$$$ if (energia(1).eq.1.0D20 .or. energia(0).eq.1.0D99) nf=0 +c$$$ +c$$$#ifdef OSF +c$$$ endif +c$$$#endif +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c------------------------------------------------------- +c$$$ +c$$$ subroutine grad_sc(n,x,nf,g,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.MINIM' +c$$$ +c$$$c Input arguments +c$$$ integer n +c$$$ double precision x(maxvar) +c$$$ double precision ufparm +c$$$ external ufparm +c$$$ +c$$$c Input/Output arguments +c$$$ integer nf +c$$$ integer uiparm(1) +c$$$ double precision urparm(1) +c$$$ +c$$$c Output arguments +c$$$ double precision g(maxvar) +c$$$ +c$$$c Local variables +c$$$ double precision f,gphii,gthetai,galphai,gomegai +c$$$ integer ig,ind,i,j,k,igall,ij +c$$$ +c$$$ +c$$$ icg=mod(nf,2)+1 +c$$$ if (nf-nfl+1) 20,30,40 +c$$$ 20 call func_sc(n,x,nf,f,uiparm,urparm,ufparm) +c$$$c write (iout,*) 'grad 20' +c$$$ if (nf.eq.0) return +c$$$ goto 40 +c$$$ 30 call var_to_geom_restr(n,x) +c$$$ call chainbuild_sc +c$$$C +c$$$C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +c$$$C +c$$$ 40 call cartder +c$$$C +c$$$C Convert the Cartesian gradient into internal-coordinate gradient. +c$$$C +c$$$ +c$$$ ig=0 +c$$$ ind=nres-2 +c$$$ do i=2,nres-2 +c$$$ IF (mask_phi(i+2).eq.1) THEN +c$$$ gphii=0.0D0 +c$$$ do j=i+1,nres-1 +c$$$ ind=ind+1 +c$$$ do k=1,3 +c$$$ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) +c$$$ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) +c$$$ enddo +c$$$ enddo +c$$$ ig=ig+1 +c$$$ g(ig)=gphii +c$$$ ELSE +c$$$ ind=ind+nres-1-i +c$$$ ENDIF +c$$$ enddo +c$$$ +c$$$ +c$$$ ind=0 +c$$$ do i=1,nres-2 +c$$$ IF (mask_theta(i+2).eq.1) THEN +c$$$ ig=ig+1 +c$$$ gthetai=0.0D0 +c$$$ do j=i+1,nres-1 +c$$$ ind=ind+1 +c$$$ do k=1,3 +c$$$ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) +c$$$ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) +c$$$ enddo +c$$$ enddo +c$$$ g(ig)=gthetai +c$$$ ELSE +c$$$ ind=ind+nres-1-i +c$$$ ENDIF +c$$$ enddo +c$$$ +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ ig=ig+1 +c$$$ galphai=0.0D0 +c$$$ do k=1,3 +c$$$ galphai=galphai+dxds(k,i)*gradx(k,i,icg) +c$$$ enddo +c$$$ g(ig)=galphai +c$$$ ENDIF +c$$$ endif +c$$$ enddo +c$$$ +c$$$ +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ ig=ig+1 +c$$$ gomegai=0.0D0 +c$$$ do k=1,3 +c$$$ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) +c$$$ enddo +c$$$ g(ig)=gomegai +c$$$ ENDIF +c$$$ endif +c$$$ enddo +c$$$ +c$$$C +c$$$C Add the components corresponding to local energy terms. +c$$$C +c$$$ +c$$$ ig=0 +c$$$ igall=0 +c$$$ do i=4,nres +c$$$ igall=igall+1 +c$$$ if (mask_phi(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ do i=3,nres +c$$$ igall=igall+1 +c$$$ if (mask_theta(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ do ij=1,2 +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ igall=igall+1 +c$$$ if (mask_side(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ endif +c$$$ enddo +c$$$ enddo +c$$$ +c$$$cd do i=1,ig +c$$$cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +c$$$cd enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine etotal_sc(energy_sc) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.FFIELD' +c$$$ +c$$$c Output arguments +c$$$ double precision energy_sc(0:n_ene) +c$$$ +c$$$c Local variables +c$$$ double precision evdw,escloc +c$$$ integer i,j +c$$$ +c$$$ +c$$$ do i=1,n_ene +c$$$ energy_sc(i)=0.0D0 +c$$$ enddo +c$$$ +c$$$ if (mask_r) then +c$$$ call egb_sc(evdw) +c$$$ call esc_sc(escloc) +c$$$ else +c$$$ call egb(evdw) +c$$$ call esc(escloc) +c$$$ endif +c$$$ +c$$$ if (evdw.eq.1.0D20) then +c$$$ energy_sc(0)=evdw +c$$$ else +c$$$ energy_sc(0)=wsc*evdw+wscloc*escloc +c$$$ endif +c$$$ energy_sc(1)=evdw +c$$$ energy_sc(12)=escloc +c$$$ +c$$$C +c$$$C Sum up the components of the Cartesian gradient. +c$$$C +c$$$ do i=1,nct +c$$$ do j=1,3 +c$$$ gradx(j,i,icg)=wsc*gvdwx(j,i) +c$$$ enddo +c$$$ enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine egb_sc(evdw) +c$$$C +c$$$C This subroutine calculates the interaction energy of nonbonded side chains +c$$$C assuming the Gay-Berne potential of interaction. +c$$$C +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.CALC' +c$$$ include 'COMMON.CONTROL' +c$$$ logical lprn +c$$$ evdw=0.0D0 +c$$$ energy_dec=.false. +c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon +c$$$ evdw=0.0D0 +c$$$ lprn=.false. +c$$$c if (icall.eq.0) lprn=.false. +c$$$ ind=0 +c$$$ do i=iatsc_s,iatsc_e +c$$$ itypi=itype(i) +c$$$ itypi1=itype(i+1) +c$$$ xi=c(1,nres+i) +c$$$ yi=c(2,nres+i) +c$$$ zi=c(3,nres+i) +c$$$ dxi=dc_norm(1,nres+i) +c$$$ dyi=dc_norm(2,nres+i) +c$$$ dzi=dc_norm(3,nres+i) +c$$$c dsci_inv=dsc_inv(itypi) +c$$$ dsci_inv=vbld_inv(i+nres) +c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +c$$$C +c$$$C Calculate SC interaction energy. +c$$$C +c$$$ do iint=1,nint_gr(i) +c$$$ do j=istart(i,iint),iend(i,iint) +c$$$ IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN +c$$$ ind=ind+1 +c$$$ itypj=itype(j) +c$$$c dscj_inv=dsc_inv(itypj) +c$$$ dscj_inv=vbld_inv(j+nres) +c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +c$$$c & 1.0d0/vbld(j+nres) +c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) +c$$$ sig0ij=sigma(itypi,itypj) +c$$$ chi1=chi(itypi,itypj) +c$$$ chi2=chi(itypj,itypi) +c$$$ chi12=chi1*chi2 +c$$$ chip1=chip(itypi) +c$$$ chip2=chip(itypj) +c$$$ chip12=chip1*chip2 +c$$$ alf1=alp(itypi) +c$$$ alf2=alp(itypj) +c$$$ alf12=0.5D0*(alf1+alf2) +c$$$C For diagnostics only!!! +c$$$c chi1=0.0D0 +c$$$c chi2=0.0D0 +c$$$c chi12=0.0D0 +c$$$c chip1=0.0D0 +c$$$c chip2=0.0D0 +c$$$c chip12=0.0D0 +c$$$c alf1=0.0D0 +c$$$c alf2=0.0D0 +c$$$c alf12=0.0D0 +c$$$ xj=c(1,nres+j)-xi +c$$$ yj=c(2,nres+j)-yi +c$$$ zj=c(3,nres+j)-zi +c$$$ dxj=dc_norm(1,nres+j) +c$$$ dyj=dc_norm(2,nres+j) +c$$$ dzj=dc_norm(3,nres+j) +c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi +c$$$c write (iout,*) "j",j," dc_norm", +c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) +c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +c$$$ rij=dsqrt(rrij) +c$$$C Calculate angle-dependent terms of energy and contributions to their +c$$$C derivatives. +c$$$ call sc_angular +c$$$ sigsq=1.0D0/sigsq +c$$$ sig=sig0ij*dsqrt(sigsq) +c$$$ rij_shift=1.0D0/rij-sig+sig0ij +c$$$c for diagnostics; uncomment +c$$$c rij_shift=1.2*sig0ij +c$$$C I hate to put IF's in the loops, but here don't have another choice!!!! +c$$$ if (rij_shift.le.0.0D0) then +c$$$ evdw=1.0D20 +c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$cd & restyp(itypi),i,restyp(itypj),j, +c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) +c$$$ return +c$$$ endif +c$$$ sigder=-sig*sigsq +c$$$c--------------------------------------------------------------- +c$$$ rij_shift=1.0D0/rij_shift +c$$$ fac=rij_shift**expon +c$$$ e1=fac*fac*aa(itypi,itypj) +c$$$ e2=fac*bb(itypi,itypj) +c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2) +c$$$ eps2der=evdwij*eps3rt +c$$$ eps3der=evdwij*eps2rt +c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 +c$$$ evdwij=evdwij*eps2rt*eps3rt +c$$$ evdw=evdw+evdwij +c$$$ if (lprn) then +c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$ & restyp(itypi),i,restyp(itypj),j, +c$$$ & epsi,sigm,chi1,chi2,chip1,chip2, +c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, +c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, +c$$$ & evdwij +c$$$ endif +c$$$ +c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)') +c$$$ & 'evdw',i,j,evdwij +c$$$ +c$$$C Calculate gradient components. +c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2 +c$$$ fac=-expon*(e1+evdwij)*rij_shift +c$$$ sigder=fac*sigder +c$$$ fac=rij*fac +c$$$c fac=0.0d0 +c$$$C Calculate the radial part of the gradient +c$$$ gg(1)=xj*fac +c$$$ gg(2)=yj*fac +c$$$ gg(3)=zj*fac +c$$$C Calculate angular part of the gradient. +c$$$ call sc_grad +c$$$ ENDIF +c$$$ enddo ! j +c$$$ enddo ! iint +c$$$ enddo ! i +c$$$ energy_dec=.false. +c$$$ return +c$$$ end +c$$$ +c$$$c----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine esc_sc(escloc) +c$$$C Calculate the local energy of a side chain and its derivatives in the +c$$$C corresponding virtual-bond valence angles THETA and the spherical angles +c$$$C ALPHA and OMEGA. +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.FFIELD' +c$$$ include 'COMMON.CONTROL' +c$$$ double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), +c$$$ & ddersc0(3),ddummy(3),xtemp(3),temp(3) +c$$$ common /sccalc/ time11,time12,time112,theti,it,nlobit +c$$$ delta=0.02d0*pi +c$$$ escloc=0.0D0 +c$$$c write (iout,'(a)') 'ESC' +c$$$ do i=loc_start,loc_end +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ it=itype(i) +c$$$ if (it.eq.10) goto 1 +c$$$ nlobit=nlob(it) +c$$$c print *,'i=',i,' it=',it,' nlobit=',nlobit +c$$$c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad +c$$$ theti=theta(i+1)-pipol +c$$$ x(1)=dtan(theti) +c$$$ x(2)=alph(i) +c$$$ x(3)=omeg(i) +c$$$ +c$$$ if (x(2).gt.pi-delta) then +c$$$ xtemp(1)=x(1) +c$$$ xtemp(2)=pi-delta +c$$$ xtemp(3)=x(3) +c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) +c$$$ xtemp(2)=pi +c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.) +c$$$ call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), +c$$$ & escloci,dersc(2)) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), +c$$$ & ddersc0(1),dersc(1)) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), +c$$$ & ddersc0(3),dersc(3)) +c$$$ xtemp(2)=pi-delta +c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) +c$$$ xtemp(2)=pi +c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) +c$$$ call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, +c$$$ & dersc0(2),esclocbi,dersc02) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), +c$$$ & dersc12,dersc01) +c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd) +c$$$ dersc0(1)=dersc01 +c$$$ dersc0(2)=dersc02 +c$$$ dersc0(3)=0.0d0 +c$$$ do k=1,3 +c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) +c$$$ enddo +c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c$$$c & esclocbi,ss,ssd +c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi +c$$$c escloci=esclocbi +c$$$c write (iout,*) escloci +c$$$ else if (x(2).lt.delta) then +c$$$ xtemp(1)=x(1) +c$$$ xtemp(2)=delta +c$$$ xtemp(3)=x(3) +c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) +c$$$ xtemp(2)=0.0d0 +c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.) +c$$$ call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), +c$$$ & escloci,dersc(2)) +c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), +c$$$ & ddersc0(1),dersc(1)) +c$$$ call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), +c$$$ & ddersc0(3),dersc(3)) +c$$$ xtemp(2)=delta +c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) +c$$$ xtemp(2)=0.0d0 +c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) +c$$$ call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, +c$$$ & dersc0(2),esclocbi,dersc02) +c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), +c$$$ & dersc12,dersc01) +c$$$ dersc0(1)=dersc01 +c$$$ dersc0(2)=dersc02 +c$$$ dersc0(3)=0.0d0 +c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd) +c$$$ do k=1,3 +c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) +c$$$ enddo +c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c$$$c & esclocbi,ss,ssd +c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi +c$$$c write (iout,*) escloci +c$$$ else +c$$$ call enesc(x,escloci,dersc,ddummy,.false.) +c$$$ endif +c$$$ +c$$$ escloc=escloc+escloci +c$$$ if (energy_dec) write (iout,'(a6,i,0pf7.3)') +c$$$ & 'escloc',i,escloci +c$$$c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc +c$$$ +c$$$ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ +c$$$ & wscloc*dersc(1) +c$$$ gloc(ialph(i,1),icg)=wscloc*dersc(2) +c$$$ gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) +c$$$ 1 continue +c$$$ ENDIF +c$$$ enddo +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine egb_ij(i_sc,j_sc,evdw) +c$$$C +c$$$C This subroutine calculates the interaction energy of nonbonded side chains +c$$$C assuming the Gay-Berne potential of interaction. +c$$$C +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.CALC' +c$$$ include 'COMMON.CONTROL' +c$$$ logical lprn +c$$$ evdw=0.0D0 +c$$$ energy_dec=.false. +c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon +c$$$ evdw=0.0D0 +c$$$ lprn=.false. +c$$$ ind=0 +c$$$c$$$ do i=iatsc_s,iatsc_e +c$$$ i=i_sc +c$$$ itypi=itype(i) +c$$$ itypi1=itype(i+1) +c$$$ xi=c(1,nres+i) +c$$$ yi=c(2,nres+i) +c$$$ zi=c(3,nres+i) +c$$$ dxi=dc_norm(1,nres+i) +c$$$ dyi=dc_norm(2,nres+i) +c$$$ dzi=dc_norm(3,nres+i) +c$$$c dsci_inv=dsc_inv(itypi) +c$$$ dsci_inv=vbld_inv(i+nres) +c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +c$$$C +c$$$C Calculate SC interaction energy. +c$$$C +c$$$c$$$ do iint=1,nint_gr(i) +c$$$c$$$ do j=istart(i,iint),iend(i,iint) +c$$$ j=j_sc +c$$$ ind=ind+1 +c$$$ itypj=itype(j) +c$$$c dscj_inv=dsc_inv(itypj) +c$$$ dscj_inv=vbld_inv(j+nres) +c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +c$$$c & 1.0d0/vbld(j+nres) +c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) +c$$$ sig0ij=sigma(itypi,itypj) +c$$$ chi1=chi(itypi,itypj) +c$$$ chi2=chi(itypj,itypi) +c$$$ chi12=chi1*chi2 +c$$$ chip1=chip(itypi) +c$$$ chip2=chip(itypj) +c$$$ chip12=chip1*chip2 +c$$$ alf1=alp(itypi) +c$$$ alf2=alp(itypj) +c$$$ alf12=0.5D0*(alf1+alf2) +c$$$C For diagnostics only!!! +c$$$c chi1=0.0D0 +c$$$c chi2=0.0D0 +c$$$c chi12=0.0D0 +c$$$c chip1=0.0D0 +c$$$c chip2=0.0D0 +c$$$c chip12=0.0D0 +c$$$c alf1=0.0D0 +c$$$c alf2=0.0D0 +c$$$c alf12=0.0D0 +c$$$ xj=c(1,nres+j)-xi +c$$$ yj=c(2,nres+j)-yi +c$$$ zj=c(3,nres+j)-zi +c$$$ dxj=dc_norm(1,nres+j) +c$$$ dyj=dc_norm(2,nres+j) +c$$$ dzj=dc_norm(3,nres+j) +c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi +c$$$c write (iout,*) "j",j," dc_norm", +c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) +c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +c$$$ rij=dsqrt(rrij) +c$$$C Calculate angle-dependent terms of energy and contributions to their +c$$$C derivatives. +c$$$ call sc_angular +c$$$ sigsq=1.0D0/sigsq +c$$$ sig=sig0ij*dsqrt(sigsq) +c$$$ rij_shift=1.0D0/rij-sig+sig0ij +c$$$c for diagnostics; uncomment +c$$$c rij_shift=1.2*sig0ij +c$$$C I hate to put IF's in the loops, but here don't have another choice!!!! +c$$$ if (rij_shift.le.0.0D0) then +c$$$ evdw=1.0D20 +c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$cd & restyp(itypi),i,restyp(itypj),j, +c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) +c$$$ return +c$$$ endif +c$$$ sigder=-sig*sigsq +c$$$c--------------------------------------------------------------- +c$$$ rij_shift=1.0D0/rij_shift +c$$$ fac=rij_shift**expon +c$$$ e1=fac*fac*aa(itypi,itypj) +c$$$ e2=fac*bb(itypi,itypj) +c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2) +c$$$ eps2der=evdwij*eps3rt +c$$$ eps3der=evdwij*eps2rt +c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 +c$$$ evdwij=evdwij*eps2rt*eps3rt +c$$$ evdw=evdw+evdwij +c$$$ if (lprn) then +c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$ & restyp(itypi),i,restyp(itypj),j, +c$$$ & epsi,sigm,chi1,chi2,chip1,chip2, +c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, +c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, +c$$$ & evdwij +c$$$ endif +c$$$ +c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)') +c$$$ & 'evdw',i,j,evdwij +c$$$ +c$$$C Calculate gradient components. +c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2 +c$$$ fac=-expon*(e1+evdwij)*rij_shift +c$$$ sigder=fac*sigder +c$$$ fac=rij*fac +c$$$c fac=0.0d0 +c$$$C Calculate the radial part of the gradient +c$$$ gg(1)=xj*fac +c$$$ gg(2)=yj*fac +c$$$ gg(3)=zj*fac +c$$$C Calculate angular part of the gradient. +c$$$ call sc_grad +c$$$c$$$ enddo ! j +c$$$c$$$ enddo ! iint +c$$$c$$$ enddo ! i +c$$$ energy_dec=.false. +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine perturb_side_chain(i,angle) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.IOUNITS' +c$$$ +c$$$c External functions +c$$$ external ran_number +c$$$ double precision ran_number +c$$$ +c$$$c Input arguments +c$$$ integer i +c$$$ double precision angle ! In degrees +c$$$ +c$$$c Local variables +c$$$ integer i_sc +c$$$ double precision rad_ang,rand_v(3),length,cost,sint +c$$$ +c$$$ +c$$$ i_sc=i+nres +c$$$ rad_ang=angle*deg2rad +c$$$ +c$$$ length=0.0 +c$$$ do while (length.lt.0.01) +c$$$ rand_v(1)=ran_number(0.01D0,1.0D0) +c$$$ rand_v(2)=ran_number(0.01D0,1.0D0) +c$$$ rand_v(3)=ran_number(0.01D0,1.0D0) +c$$$ length=rand_v(1)*rand_v(1)+rand_v(2)*rand_v(2)+ +c$$$ + rand_v(3)*rand_v(3) +c$$$ length=sqrt(length) +c$$$ rand_v(1)=rand_v(1)/length +c$$$ rand_v(2)=rand_v(2)/length +c$$$ rand_v(3)=rand_v(3)/length +c$$$ cost=rand_v(1)*dc_norm(1,i_sc)+rand_v(2)*dc_norm(2,i_sc)+ +c$$$ + rand_v(3)*dc_norm(3,i_sc) +c$$$ length=1.0D0-cost*cost +c$$$ if (length.lt.0.0D0) length=0.0D0 +c$$$ length=sqrt(length) +c$$$ rand_v(1)=rand_v(1)-cost*dc_norm(1,i_sc) +c$$$ rand_v(2)=rand_v(2)-cost*dc_norm(2,i_sc) +c$$$ rand_v(3)=rand_v(3)-cost*dc_norm(3,i_sc) +c$$$ enddo +c$$$ rand_v(1)=rand_v(1)/length +c$$$ rand_v(2)=rand_v(2)/length +c$$$ rand_v(3)=rand_v(3)/length +c$$$ +c$$$ cost=dcos(rad_ang) +c$$$ sint=dsin(rad_ang) +c$$$ dc(1,i_sc)=vbld(i_sc)*(dc_norm(1,i_sc)*cost+rand_v(1)*sint) +c$$$ dc(2,i_sc)=vbld(i_sc)*(dc_norm(2,i_sc)*cost+rand_v(2)*sint) +c$$$ dc(3,i_sc)=vbld(i_sc)*(dc_norm(3,i_sc)*cost+rand_v(3)*sint) +c$$$ dc_norm(1,i_sc)=dc(1,i_sc)*vbld_inv(i_sc) +c$$$ dc_norm(2,i_sc)=dc(2,i_sc)*vbld_inv(i_sc) +c$$$ dc_norm(3,i_sc)=dc(3,i_sc)*vbld_inv(i_sc) +c$$$ c(1,i_sc)=c(1,i)+dc(1,i_sc) +c$$$ c(2,i_sc)=c(2,i)+dc(2,i_sc) +c$$$ c(3,i_sc)=c(3,i)+dc(3,i_sc) +c$$$ +c$$$ call chainbuild_cart +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c---------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax3(i_in,j_in) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c External functions +c$$$ external ran_number +c$$$ double precision ran_number +c$$$ +c$$$c Input arguments +c$$$ integer i_in,j_in +c$$$ +c$$$c Local variables +c$$$ double precision energy_sc(0:n_ene),etot +c$$$ double precision org_dc(3),org_dc_norm(3),org_c(3) +c$$$ double precision ang_pert,rand_fact,exp_fact,beta +c$$$ integer n,i_pert,i +c$$$ logical notdone +c$$$ +c$$$ +c$$$ beta=1.0D0 +c$$$ +c$$$ mask_r=.true. +c$$$ do i=nnt,nct +c$$$ mask_side(i)=0 +c$$$ enddo +c$$$ mask_side(i_in)=1 +c$$$ mask_side(j_in)=1 +c$$$ +c$$$ call etotal_sc(energy_sc) +c$$$ etot=energy_sc(0) +c$$$c write(iout,'(a,3d15.5)')" SS_MC_START ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ +c$$$ notdone=.true. +c$$$ n=0 +c$$$ do while (notdone) +c$$$ if (mod(n,2).eq.0) then +c$$$ i_pert=i_in +c$$$ else +c$$$ i_pert=j_in +c$$$ endif +c$$$ n=n+1 +c$$$ +c$$$ do i=1,3 +c$$$ org_dc(i)=dc(i,i_pert+nres) +c$$$ org_dc_norm(i)=dc_norm(i,i_pert+nres) +c$$$ org_c(i)=c(i,i_pert+nres) +c$$$ enddo +c$$$ ang_pert=ran_number(0.0D0,3.0D0) +c$$$ call perturb_side_chain(i_pert,ang_pert) +c$$$ call etotal_sc(energy_sc) +c$$$ exp_fact=exp(beta*(etot-energy_sc(0))) +c$$$ rand_fact=ran_number(0.0D0,1.0D0) +c$$$ if (rand_fact.lt.exp_fact) then +c$$$c write(iout,'(a,3d15.5)')" SS_MC_ACCEPT ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ etot=energy_sc(0) +c$$$ else +c$$$c write(iout,'(a,3d15.5)')" SS_MC_REJECT ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ do i=1,3 +c$$$ dc(i,i_pert+nres)=org_dc(i) +c$$$ dc_norm(i,i_pert+nres)=org_dc_norm(i) +c$$$ c(i,i_pert+nres)=org_c(i) +c$$$ enddo +c$$$ endif +c$$$ +c$$$ if (n.eq.10000.or.etot.lt.30.0D0) notdone=.false. +c$$$ enddo +c$$$ +c$$$ mask_r=.false. +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c---------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax2(etot,iretcode,nfun,i_in,j_in) +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ integer liv,lv +c$$$ parameter (liv=60,lv=(77+maxres6*(maxres6+17)/2)) +c$$$********************************************************************* +c$$$* OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * +c$$$* the calling subprogram. * +c$$$* when d(i)=1.0, then v(35) is the length of the initial step, * +c$$$* calculated in the usual pythagorean way. * +c$$$* absolute convergence occurs when the function is within v(31) of * +c$$$* zero. unless you know the minimum value in advance, abs convg * +c$$$* is probably not useful. * +c$$$* relative convergence is when the model predicts that the function * +c$$$* will decrease by less than v(32)*abs(fun). * +c$$$********************************************************************* +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.MINIM' +c$$$ include 'COMMON.CHAIN' +c$$$ +c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist +c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar), +c$$$ + orig_ss_dist(maxres2,maxres2) +c$$$ +c$$$ double precision etot +c$$$ integer iretcode,nfun,i_in,j_in +c$$$ +c$$$ external dist +c$$$ double precision dist +c$$$ external ss_func,fdum +c$$$ double precision ss_func,fdum +c$$$ +c$$$ integer iv(liv),uiparm(2) +c$$$ double precision v(lv),x(maxres6),d(maxres6),rdum +c$$$ integer i,j,k +c$$$ +c$$$ +c$$$ call deflt(2,iv,liv,lv,v) +c$$$* 12 means fresh start, dont call deflt +c$$$ iv(1)=12 +c$$$* max num of fun calls +c$$$ if (maxfun.eq.0) maxfun=500 +c$$$ iv(17)=maxfun +c$$$* max num of iterations +c$$$ if (maxmin.eq.0) maxmin=1000 +c$$$ iv(18)=maxmin +c$$$* controls output +c$$$ iv(19)=2 +c$$$* selects output unit +c$$$c iv(21)=iout +c$$$ iv(21)=0 +c$$$* 1 means to print out result +c$$$ iv(22)=0 +c$$$* 1 means to print out summary stats +c$$$ iv(23)=0 +c$$$* 1 means to print initial x and d +c$$$ iv(24)=0 +c$$$* min val for v(radfac) default is 0.1 +c$$$ v(24)=0.1D0 +c$$$* max val for v(radfac) default is 4.0 +c$$$ v(25)=2.0D0 +c$$$c v(25)=4.0D0 +c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +c$$$* the sumsl default is 0.1 +c$$$ v(26)=0.1D0 +c$$$* false conv if (act fnctn decrease) .lt. v(34) +c$$$* the sumsl default is 100*machep +c$$$ v(34)=v(34)/100.0D0 +c$$$* absolute convergence +c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4 +c$$$ v(31)=tolf +c$$$ v(31)=1.0D-1 +c$$$* relative convergence +c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-4 +c$$$ v(32)=rtolf +c$$$ v(32)=1.0D-1 +c$$$* controls initial step size +c$$$ v(35)=1.0D-1 +c$$$* large vals of d correspond to small components of step +c$$$ do i=1,6*nres +c$$$ d(i)=1.0D0 +c$$$ enddo +c$$$ +c$$$ do i=0,2*nres +c$$$ do j=1,3 +c$$$ orig_ss_dc(j,i)=dc(j,i) +c$$$ enddo +c$$$ enddo +c$$$ call geom_to_var(nvar,orig_ss_var) +c$$$ +c$$$ do i=1,nres +c$$$ do j=i,nres +c$$$ orig_ss_dist(j,i)=dist(j,i) +c$$$ orig_ss_dist(j+nres,i)=dist(j+nres,i) +c$$$ orig_ss_dist(j,i+nres)=dist(j,i+nres) +c$$$ orig_ss_dist(j+nres,i+nres)=dist(j+nres,i+nres) +c$$$ enddo +c$$$ enddo +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ x(k)=dc(j,i) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ x(k)=dc(j,i+nres) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ +c$$$ uiparm(1)=i_in +c$$$ uiparm(2)=j_in +c$$$ call smsno(k,d,x,ss_func,iv,liv,lv,v,uiparm,rdum,fdum) +c$$$ etot=v(10) +c$$$ iretcode=iv(1) +c$$$ nfun=iv(6)+iv(30) +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i)=x(k) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i+nres)=x(k) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ call chainbuild_cart +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_func(n,x,nf,f,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.SBRIDGE' +c$$$ +c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist +c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar), +c$$$ + orig_ss_dist(maxres2,maxres2) +c$$$ +c$$$ integer n +c$$$ double precision x(maxres6) +c$$$ integer nf +c$$$ double precision f +c$$$ integer uiparm(2) +c$$$ real*8 urparm(1) +c$$$ external ufparm +c$$$ double precision ufparm +c$$$ +c$$$ external dist +c$$$ double precision dist +c$$$ +c$$$ integer i,j,k,ss_i,ss_j +c$$$ double precision tempf,var(maxvar) +c$$$ +c$$$ +c$$$ ss_i=uiparm(1) +c$$$ ss_j=uiparm(2) +c$$$ f=0.0D0 +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i)=x(k) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i+nres)=x(k) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ call chainbuild_cart +c$$$ +c$$$ call geom_to_var(nvar,var) +c$$$ +c$$$c Constraints on all angles +c$$$ do i=1,nvar +c$$$ tempf=var(i)-orig_ss_var(i) +c$$$ f=f+tempf*tempf +c$$$ enddo +c$$$ +c$$$c Constraints on all distances +c$$$ do i=1,nres-1 +c$$$ if (i.gt.1) then +c$$$ tempf=dist(i+nres,i)-orig_ss_dist(i+nres,i) +c$$$ f=f+tempf*tempf +c$$$ endif +c$$$ do j=i+1,nres +c$$$ tempf=dist(j,i)-orig_ss_dist(j,i) +c$$$ if (tempf.lt.0.0D0 .or. j.eq.i+1) f=f+tempf*tempf +c$$$ tempf=dist(j+nres,i)-orig_ss_dist(j+nres,i) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ tempf=dist(j,i+nres)-orig_ss_dist(j,i+nres) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ tempf=dist(j+nres,i+nres)-orig_ss_dist(j+nres,i+nres) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ enddo +c$$$ enddo +c$$$ +c$$$c Constraints for the relevant CYS-CYS +c$$$ tempf=dist(nres+ss_i,nres+ss_j)-8.0D0 +c$$$ f=f+tempf*tempf +c$$$CCCCCCCCCCCCCCCCC ADD SOME ANGULAR STUFF +c$$$ +c$$$c$$$ if (nf.ne.nfl) then +c$$$c$$$ write(iout,'(a,i10,2d15.5)')"IN DIST_FUNC (NF,F,DIST)",nf, +c$$$c$$$ + f,dist(5+nres,14+nres) +c$$$c$$$ endif +c$$$ +c$$$ nfl=nf +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$C----------------------------------------------------------------------------- + subroutine triple_ssbond_ene(resi,resj,resk,eij) + 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 +C include 'COMMON.MD' +#endif +#endif + +c External functions + double precision h_base + external h_base + +c Input arguments + integer resi,resj,resk + +c Output arguments + double precision eij,eij1,eij2,eij3 + +c Local variables + logical havebond +c integer itypi,itypj,k,l + double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi + double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij + double precision xik,yik,zik,xjk,yjk,zjk + double precision sig0ij,ljd,sig,fac,e1,e2 + double precision dcosom1(3),dcosom2(3),ed + double precision pom1,pom2 + double precision ljA,ljB,ljXs + double precision d_ljB(1:3) + double precision ssA,ssB,ssC,ssXs + double precision ssxm,ljxm,ssm,ljm + double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3) + + i=resi + j=resj + k=resk +C write(iout,*) resi,resj,resk + 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) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + + itypj=itype(j) + xj=c(1,nres+j) + yj=c(2,nres+j) + zj=c(3,nres+j) + + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + dscj_inv=vbld_inv(j+nres) + itypk=itype(k) + xk=c(1,nres+k) + yk=c(2,nres+k) + zk=c(3,nres+k) + + dxk=dc_norm(1,nres+k) + dyk=dc_norm(2,nres+k) + dzk=dc_norm(3,nres+k) + dscj_inv=vbld_inv(k+nres) + xij=xj-xi + xik=xk-xi + xjk=xk-xj + yij=yj-yi + yik=yk-yi + yjk=yk-yj + zij=zj-zi + zik=zk-zi + zjk=zk-zj + rrij=(xij*xij+yij*yij+zij*zij) + rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse + rrik=(xik*xik+yik*yik+zik*zik) + rik=dsqrt(rrik) + rrjk=(xjk*xjk+yjk*yjk+zjk*zjk) + rjk=dsqrt(rrjk) +C there are three combination of distances for each trisulfide bonds +C The first case the ith atom is the center +C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first +C distance y is second distance the a,b,c,d are parameters derived for +C this problem d parameter was set as a penalty currenlty set to 1. + eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**2+ctriss) +C second case jth atom is center + eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**2+ctriss) +C the third case kth atom is the center + eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**2+ctriss) +C eij2=0.0 +C eij3=0.0 +C eij1=0.0 + eij=eij1+eij2+eij3 +C write(iout,*)i,j,k,eij +C The energy penalty calculated now time for the gradient part +C derivative over rij + fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+2.0*btriss*(rij+rik)) + &-eij2**2/dtriss*(2.0*atriss*(rij-rjk)+2.0*btriss*(rij+rjk)) + gg(1)=xij*fac/rij + gg(2)=yij*fac/rij + gg(3)=zij*fac/rij + do m=1,3 + gvdwx(m,i)=gvdwx(m,i)-gg(m) + gvdwx(m,j)=gvdwx(m,j)+gg(m) + enddo + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo +C now derivative over rik + fac=-eij1**2/dtriss*(-2.0*atriss*(rij-rik)+2.0*btriss*(rij+rik)) + &-eij3**2/dtriss*(2.0*atriss*(rik-rjk)+2.0*btriss*(rik+rjk)) + gg(1)=xik*fac/rik + gg(2)=yik*fac/rik + gg(3)=zik*fac/rik + do m=1,3 + gvdwx(m,i)=gvdwx(m,i)-gg(m) + gvdwx(m,k)=gvdwx(m,k)+gg(m) + enddo + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo +C now derivative over rjk + fac=-eij2**2/dtriss*(-2.0*atriss*(rij-rjk)+2.0*btriss*(rij+rjk))- + &eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+2.0*btriss*(rik+rjk)) + gg(1)=xjk*fac/rjk + gg(2)=yjk*fac/rjk + gg(3)=zjk*fac/rjk + do m=1,3 + gvdwx(m,j)=gvdwx(m,j)-gg(m) + gvdwx(m,k)=gvdwx(m,k)+gg(m) + enddo + do l=1,3 + gvdwc(l,j)=gvdwc(l,j)-gg(l) + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo + return + end diff --git a/source/wham/src-HCD/store_parm.F b/source/wham/src-HCD/store_parm.F new file mode 100644 index 0000000..69f90d1 --- /dev/null +++ b/source/wham/src-HCD/store_parm.F @@ -0,0 +1,594 @@ + subroutine store_parm(iparm) +C +C Store parameters of set IPARM +C valence angles and the side chains and energy parameters. +C + 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,ii,j,k,l,m,mm,iparm,ichir1,ichir2,iblock,iii + +c 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 + ww_all(22,iparm)=wliptran + ww_all(26,iparm)=wsaxs +c 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 +c 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 +c Store the sidechain rotamer parameters + do i=-ntyp,ntyp + iii=iabs(i) +cc 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 +c 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 +c 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 +c Store parameters of the cumulants +#ifdef NEWCORR + do i=-nloctyp+1,nloctyp-1 + do ii=1,3 + do j=1,2 + bnew1_all(ii,j,i,iparm)=bnew1(ii,j,i) + bnew2_all(ii,j,i,iparm)=bnew2(ii,j,i) + enddo + enddo + do j=1,2 + do k=1,3 + ccnew_all(k,j,i,iparm)=ccnew(k,j,i) + ddnew_all(k,j,i,iparm)=ddnew(k,j,i) + enddo + enddo + do ii=1,2 + do j=1,2 + do k=1,2 + eenew_all(k,j,ii,i,iparm)=eenew(k,j,ii,i) + enddo + enddo + enddo + do ii=1,2 + e0new_all(ii,i,iparm)=e0new(ii,i) + enddo + enddo +#else + do i=-nloctyp,nloctyp + do j=1,5 + b_all(j,i,iparm)=b(j,i) + enddo + do j=1,2 + do k=1,2 + ccold_all(k,j,i,iparm)=ccold(k,j,i) + ddold_all(k,j,i,iparm)=ddold(k,j,i) + eeold_all(k,j,i,iparm)=eeold(k,j,i) + enddo + enddo + enddo +#endif +c 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 +c Store sidechain parameters + do i=1,ntyp + do j=1,ntyp + aa_aq_all(j,i,iparm)=aa_aq(j,i) + bb_aq_all(j,i,iparm)=bb_aq(j,i) + aa_lip_all(j,i,iparm)=aa_lip(j,i) + bb_lip_all(j,i,iparm)=bb_lip(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) + epslip_all(j,i,iparm)=epslip(j,i) + enddo + enddo + do i=1,ntyp + chip_all(i,iparm)=chip(i) + alp_all(i,iparm)=alp(i) + enddo +c 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 +c 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 +c Store SC-backbone correlation parameters + do i=-nsccortyp,nsccortyp + do j=-nsccortyp,nsccortyp + + nterm_sccor_all(j,i,iparm)=nterm_sccor(j,i) +c do i=1,20 +c 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 + return + end +c-------------------------------------------------------------------------- + subroutine restore_parm(iparm) +C +C Store parameters of set IPARM +C valence angles and the side chains and energy parameters. +C + 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,ii,j,k,l,m,mm,iparm,ichir1,ichir2,iblock,iii + +c 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) + wliptran=ww_all(22,iparm) + wsaxs=ww_all(26,iparm) +c 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 +c 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 +c 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 +c 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 +c 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 +c Restore parameters of the cumulants +#ifdef NEWCORR + do i=-nloctyp+1,nloctyp-1 + do ii=1,3 + do j=1,2 + bnew1(ii,j,i)=bnew1_all(ii,j,i,iparm) + bnew2(ii,j,i)=bnew2_all(ii,j,i,iparm) + enddo + enddo + do j=1,2 + do k=1,3 + ccnew(k,j,i)=ccnew_all(k,j,i,iparm) + ddnew(k,j,i)=ddnew_all(k,j,i,iparm) + enddo + enddo + do ii=1,2 + do j=1,2 + do k=1,2 + eenew(k,j,ii,i)=eenew_all(k,j,ii,i,iparm) + enddo + enddo + enddo + do ii=1,2 + e0new(ii,i)=e0new_all(ii,i,iparm) + enddo + enddo +#else + do i=-nloctyp,nloctyp + do j=1,5 + b(j,i)=b_all(j,i,iparm) + enddo + do j=1,2 + do k=1,2 + ccold(k,j,i)=ccold_all(k,j,i,iparm) + ddold(k,j,i)=ddold_all(k,j,i,iparm) + eeold(k,j,i)=eeold_all(k,j,i,iparm) + enddo + enddo + enddo +#endif +c 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 +c Restore sidechain parameters + do i=1,ntyp + do j=1,ntyp + aa_aq(j,i)=aa_aq_all(j,i,iparm) + bb_aq(j,i)=bb_aq_all(j,i,iparm) + aa_lip(j,i)=aa_lip_all(j,i,iparm) + bb_lip(j,i)=bb_lip_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) + epslip(j,i)=epslip_all(j,i,iparm) + enddo + enddo + do i=1,ntyp + chip(i)=chip_all(i,iparm) + alp(i)=alp_all(i,iparm) + enddo +c 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 +c 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) +c 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 diff --git a/source/wham/src-HCD/testseqchains b/source/wham/src-HCD/testseqchains new file mode 100644 index 0000000000000000000000000000000000000000..7cedd57a6cee796ee1be8623d91383b0540b5ad1 GIT binary patch literal 897912 zcmc$H349b)5_jhq2$vlc6cHtAR21Y2DiWd@m_P?78X*Bx6mSR-<%r2dQ6U5;v(hvJ zsG#V|F0Q)Ex*lM5*-4(itTFO48AFT{umD(xstNNBq4^x>Rb1bUef8 z2|Y`1bR8JWNy)k*0t^`PD-`cpDu39azq}Nn{AexZI&~y*(Uwg)oLHLjn1X! z^QE!rNKrbSE|QD?My`~Xj`ld|J{p~rhYl;hbz=r-(RGL*U$U-N zxf@ZA+Sk@2(abp3tS=g!K@+KUCH~VfU{?O^R}L94Yue?r^5+!KyL{fzD=)utNdKa_ z{ReZKx*-qg#^~#FrLUhV893sa&bK@^`P^M;mk#VXv9ePx(M>cEKFUJ}H_om&=^$C=$Rna z;eHg(fjBQT;iJuK5w17koQ(4#oMUm);T9M4JV_dib0SWQU-T#s=NUL%I49t|5hqDk z!FfAQ>qx~7@j`G#Kxg1`H_mZ5FUENm&S^N$#!1H*oCP><#d$8y5jd^>RfzlPI6XLL z;-rJRNfzHp(p|U?!kKNRug8`6e>KkYOjuhkB-5q`^#l7sGH>Z9wms}%ySHx1dUdxF z=2dQzo{hBVJ&hk+g5(^W159vFT+heZ4=3p>9hc+0fbUNJbD9ZC!nF_1kvP+EX5hRO zCmmPf%;dYspCOT3wn1~v^c^;MU)#NPYuV080QA7=#A#Wz+i;(Pb2v`ZB;ZbhEpL3x zGLz}J-hi_|&O32h2k9C04eC22tHnt%9lFLy%M;?In13cq@$`&vkX-tlyR_GcjQ78L z{mX~vZ}`*Lp{qmhTs>{UmlsXXotjuTzULGB?wZ&uvG%9XhQNPMyZR@s*SGKec-lkf zHylOLsK=#H8mmqAOjm)h=HT_{P|d-oM#=vUkT#cpMwEK@M!|Cy7}Ok|iYWLKqU7Hj zh5iepz%D5B{;?>0pm?DxL-!{ZZiEqVO{}O1)1C2*f`3$$_TCo-Pk9tP!=vQSiUL=oz^{x#&)ZSjyD17iH%Gx=69tbFB|rJGB%Do; zo>A!B9|g~QQQ%iafqSCRxjagHp9Vb_G$j)0pQ7YHBMSauQQ*Hvq4RIi;8E~+qvWrT z0`Cxo{zXyp%TeH8MZxp$D0CJ^fnO2@9*6?}GzvYPqv+2X$gDX#ToZ-<3!>mz7=@mS zDD?a}O8&`F@Lv;!p0}dFW23;6qtNqv6h5qslAp#H&GGHtDD~Dv!IKuHy}P5ppNoR$ zxhV9^j*|bADE!|W1<$2X+I1od{6DC-D@OTAPl-sA##(fIhIS=lq-DVcRFeM7@Lp2l zh7t?J*CqISx+F{KlW8<0#)fpg5BV>kn97I*_o3)IVW$Pck<|2b8nwIt4KgxQ@vBe5MY~47_KC|1>Tv3c~hqejMMYH zc}3p5d7iuiuXImgzBf-YpHD8zn>9V0m|cualR=pm^yU>7&Y3%T)?Ck2Z~ojlQsLD6 zqDV236A$kU7cR>478T@q@~7u}q*+CId3RnpM4IlI7R}1bE1>3iL_;S}o>wqq^6gWL^5#sPod==|3iIc9r%(3G zyi=M!w;*qhROBrz^vo>8qgiw3%(!EA0Y581Z>Og6?vx4nJ!KD78cJz zd-FiLXV%=JylMG`0OmmeXv3VTxOfZacna=C$-9eeb>V42;atz`sYQ3<5k%&>lj@l~ zeJbX(K!5(6J0&!278)W=y?t(>7l@|i&ygnQ%>%Dz=glS(!IXmhY0{nfRNd``cS`w1 zQ@!4MrRjNdK^n1)s-H!T%Ab)pyTE%dSWboMf+zSdO((`P!r2893Y%=1J`Xf`(W=Rl zr`yOzQ<+I1Ie!MQfIURm++r^gQ&?Oybw(abZ4kYzjs;9?Vs^~2A)YOo z3W`t#bA;K(yr+`HSI90*l*fB-LEhxsN!zIAyg7GED99opf*>ua=w4{>Yzb5r&dQ&i zFB(&1uaxwiIZYBkeN(+$pLs7$&j;(~5_-=))2Inkr%}S2KO6j=HuYX<_MKEi0dt8& zQUHB~9)U-*h#KTAl0e|pSyY4=F7%3S%&f>_C(h20yxFto-kk?sAU$Q(L_JeIp1dM- zWun(cu7|}?Xz3`ayJPdfc^nxcJ2*2toEkN^(33Y!lpxI0W)a%K(zIDc_s+)Osne!G ze0kGgd_eo{MMZ)-faXk-M!PddjGR2U|KR>tNTWxNoSXvVC$1^sXOX)>gTlb8!gqs) zgl{8vDgB2?1LhWZ2cU!J%^FZpG%s)Pz(H3R5Ax(;0u%F=13YtQ7eK~^G@mJQfyFpt zF#{KezwvyH3tz1}g156l<1l+dCE^>w1SIm8?yP^J2DlA|bTHxVaJ6uB#C>d-5%=Air-a#5p`X%wE*p_uCiAc5yh8Hhit(QoNM<&uajI4PCe;4}|w9UE-$%Pb(SJ8kd+8@$#A zr@2DwIAnu+Eg-H|JV9jJ;a0ptaGImD4lC{*!;H zla5-)KpWgt4SqD#1~*yE@N^rTcxoMr4Nf#!N45=a#gg=Fq74o~hL0&Wc*igl^V~ML zeJ;4b2JdXkKhFlIvAK1W+ThmwFFjjqgUeQCTvyoOq<7Y_+6K4QCFt2&8{9t5SZ9ON znt^qc+u+?SAg&v1aQpmt&;~!#mVc)WPHPF)QEP+KoU?W8v%#%32YOa#gVTJvb?7#@ zwcbL{4%y%o8(YUw8=TfJ!pB_^y|u4JB-r4z)?*!sHh7W+#I=VFe!dN!WP{ts8GUT< z3vKxa+Th7H_)r`CA{#v22EW(_S8VW0Z18LwoYokuW1>gR%To`*x+bX)!e8{BDwC)(g6Z15g7_(&T($p&}X;C*cH3>$o) z4L-^SA8Lb-w!zbFa51tM4;33c)0RKm2DguxC)(iG+44`Z!QD3aOdCAQ1~0I|ueZVH z+2FKJW*wzAc(w(^b+HY8qYb{o1|MsKueQNy4c9u>+Tb}B5Z84!c&-gzZiA1v!8h38 z6KwFH4L;EZ-)V#2WP{h*;5Xag`)u%AZ16f8e3A{W+u$@;V;zTVa9TgNj-xjC6bne# zqKN)awZRi?@Y`+hL>t^=gZHq(r`h01Hh7*5-p2-?Zi5fB!DrauLv8SxHn`&ZE8 zm%IB(ia+R$4b>{X?FrkY&=q3=3SE?gzjE(%+)0y+n(99_3^k7O;NM@|%^ktN$P|R4t=?f@LA(&Ch>7JCP(90;`^y!pNp!5_@cce6h zT1GafV<}A`mXXfs->yTNLMvk+r+=b!XG$k=`ddm?((iAcob)0^K(iAEgwVd8cX$p~yAg4D`nnEL^oYViNG=)UQT24PlX$pmm6`cMX zr6~k5N;&-mr783=3OM~Rr77ewrf_-*r76@gvN`<#r76TQ(m8z}r75&A26DQP(iGAd zNu0ie(iF-ViJZQj(iFlN5~pvbG=(n4q2tv4v6N1tbRDP1P?|y&qn6VnC`}=X5#;nR zN>gZJlyiD8r70va)^hqXN>eCetl;zol%^2GDCKldN>k`z6ma@Cvo~)N>hkoBy#!yr75&9Bu?+AG=&t#p$3*e zr74s!>Nx!dr746kYB{}?(iA!vK~8U?G=&UCIj8?kX$lpLwVZyA(i9>XD>(f(O4E?b zDCP7Ml%`O@DB$$Nl%^2Dn8N8Ll%~+Y$ma9|l%|ltNayr@l%`O?7|7{DN>d16Bysu< zN|Wn15;=W4rOD+R5~pvbG`V`?(C;jNN~cr0j?-f(O|IRj<@5+jlS?;(oE}DLa^*%j zrw3D-T)458)0a`2T(_};(-%;hT((il>7JA(S8Wt<`gBSwl%B%rj+7?XY-DpfmeS;s zjdV``mWedEVq+kuf1)(GU?Yjs-%^@fuaU^<1C%D0Ye<~lPib{*)#cYt(W2 z4N8-1HEKD%mD1!=jUcBtQJP$-QO@aqQ<_|;v6j=%QJP$*v4Ycoqcpipqmx%^5~uH=^sSUmhE5R-l2yJmZR*`HF2!f%D(Y8y2^d!GxB-xuTemU(pSMk)-e2xr z#*LGEqbl{QTkBO+Eu~%|c z*~l@{qRz?bC=5WiWc`9SW28#507_tUauAu7O;V`LmjnbG7b9~@&>e6kPpomMavD!V zDK+G!A&b$gvt#d;^xgY`U>U-H~c zx@1?yN{NY;YoRNfDCF1}i$6}L#JTZFZj?T(6t(%bCn_F+&X@%r+!2!vhM{N@GKr$Z zKdb07qG)JgW_aJ zD^&(XH`0v(v;g)1?m6vys6jz)d8@EPqH| z_B`&Gscv;za<)^g&QcpP)eob!sMc(eE4d(|L**nNNPojGM9Z@~K=VEu%`Wwxoum_s zkxQ>R5GyLa9&ux)FVwDNz#Z*c5_KKd=$xQul?aKA(Bdne2k$LatvtkatxR44{A#S8 zXVtI)WN{7sSa-ORJK9AwDpTF*+<4SN|HFbX`s48sa2S088b#!<7Um#CL8D5{f36K3oxX^Q4Hb zbpTG%wL^HQciG-Z1)Npkp1c{^SO?H6segx?&T1VoB?E!R9T0g^f@U@P`fa8}>(I?I z7lpVF59U7Hl3a%}!Qf2s{4nDycG~6YLJnelB1nQ<19i+9mwMDR9`4lNC zYpkT5+i&+3lHj7PXOU&R76eB_o`dqvjoBF55hoLnGt5bsx=_(SEJE*@#4Q)59F}O@ z!?BV}yJE;I!>JD^qYVB_8UDlavcKcT?b$38h5B<}n8~&aVG1`DLO67v;K?T9(3rq* zmINpZyvp_I*@$v0XW7V7M^7Z#^Z+ILD-VGkf-tu1M4>aaT3&WLgyYf#b(LOQX*8+? zg`A-pmnt5+NSHOya_!u`?_Lp=ee;-Ll1+NV{*=-X4fbbow+sm9qAktnIf)eHwqUJG+?rL82mmyQBWxkqE$Q6xV!%%@#%ekLGgkhmke|Ak@g3swXl2-;Z!EXU%(lw>1F>w& zWr9|jtF1EKS}21CL$IUcds_)PVP*4yp*Ig7ejKkiW{PBLrh zP_~mJljKp%vhn&~?h!1w-ZNx986d({b|z@a@?6WF_Zi%yr`7^}$$*H5nn{4lFmiTM z0|n9vdZvk#2}>aaz7sYN8ZOl+SW34@>SUI_F3@eEvgJVB^`6cDE|`4kn_^L*n#D$F-F_t}+jswnxL)jT)qP4JPiMuvb(~ck@C|t zPqh33f4POfgz|rkE)^b6Q2g)AaptlPBK}`Y@>Nf`J^i!Pw=zBFDZbxhUx?a%TiA$>Z;Ya8{r%N0yhZJ5ayUNLp$85_0*>CsZGbZe}3F*n_d+p z=ISSk%r^a_(Z}>&$??9+{;_Y8Ah=XA@izrD5S6Y5N-x21#%nay-XQ!ll&vzu>356 zdBZfqd=@Zsw7;PTz}(XnbS6bzL+(ORx0!r)tCr$4Th}L6UFD7Hsx>43ee7+MV_JQbrhcBIq5BpWXcG~KaelWe^6eQa}n922Ag$jUP*sp z%A7g+<%L3^Fu2b?nLpcNWn}|bx=H~RE_JXziU^5U!mI`%hs1ztRjocD9y=ds7B!IO%FEXfGt_-4yC8`vAjGX! z^a06P>XA&f+8vl0!$qnv`^{V#bVoZSw1org8!MaVOb@PI?{3!Z)RrZ@iuo0xN0mw3 zv{f`wuXfZ2zK`JAR~_$GzsO4crf@kFn~Bhv2;)-_m$C=sxzrbiq6E}O^i~^CklDfg7m_}o%7wNozHL3g4tbf5$rVN8F4MT@BevR= zvWL6X4{!)3dz|XqruZ_|ns8TpuW?t)^8A_=m?6Zv7?bua))aFvoE4Z56JcK?cRob0 zajZUku3+OBPkhB%Qh0w*UN#6+j0tojZ!VNP!3hCO_Qw%lm64Yz1pJI507Xowhe4Fwj(ceGtes#{w{HCe;) z#$vu9FsXZtHC5vh*v9E&O>85yvVSE(hvCmgs%6gy(daDoS9j`qYK!~;d3U2XdRNL} z@_6chA%p@vF&m3%4YO}$s&6%I@2@TEZZ?w=T2JWoZL>w=!YoSY^*^v^fr%v(gBigi zKbC&}XCC!8(M5Q)9XxueDUZ5~9>Bd<^zn?iA6U=TZ``TRlF5-Dn2NB(>?Ur}Kblqk zWP8A`*aR%b+Me0*&AyKQpQU~UeZ$o7rlgB!OPLrKl6RsJ z;`%8-s25`aiaMIV8~ie(+0&iW$v!pKd_(4QLoj+DY_>%4_z9&`-J0cjm8)UbpP}Xo z<1h}!f!@aB`j(xIY7}ij;znwOOI<}ep{Td6Q`Dc)W61m~frUL3b-`)~hk6*BiQ=_x z^#u`QzRlGB1*2~(rnHY^n(+W-7Qu_|5UdB8YvREbHZ&IzqDJGH=9|4#U>UEcT39Gv zc;yTtqoMiXR2UIEqLl(cj{aM|AcNKCS|DhP`aHv>$LSSTVQs-Wx0bbflvegyJd9I@ z>U#VjR7Od?b!~}D(U_BN4Sdrw65&+bsde)5a2<9HwEGTEhZyZX$FF&7~bZok-t~hVAH)8LD>jbGK&^N0;Opz34%1^dPso ziZ(2`)r@j1`M zMSb@QEIZIZb}6_0bng4d+rqpCtNADLEapMdYgp2)Tik?9 zb3`08OM~v6lDw=B$}5W&?Bqe{z?MUaZj2*Tyi>p5LZaQeVT|X=*U1vHDSECe(S~@q z6;IZSQH|3FTZnuMf}my?6<@R<$o#NVLx4zB$+j@rq$a3;Kh0tYG`l8|3Y*Zz z!Kh%!c>N`_w4xQSL-2*}qCNQ+GKWreQu0Az8Wxnx%iK_UO93Je}R?S(CU{0?7u!+IwN@Zeb;6^KyH&!-3jWUhP>61{( z81WPHiz8+#b4N^*LX9HkS)#^qdJ>i0^-Fj*Dl34Pz4_Yai85pL?`}t#(UCGy@|SXc z_&;RlIo`uZ!quEq1PX__*QKJ099=cbKolj98*?xL+w$bgYEf{4o^4h3+F{}cPrhWR zdol5{>CkZDNvp_iXHY264gp!F=S+^!6#pK1*{^XRmHk2mg*E0VEmPg$g0&`v4BXoz z(}NgoFU&HUF9 zW?~tsxnCm7JVNcf{u9EM`klO-SLw*9(>Tvm=Y{P-Zb?ynO3PaPDpxR0KQTp6NrkQv z8r=mJzGZX1-D+ddENvVBw_29rUaQPftIV@4lo1MZ&?NFE8{x$Z`w4S}e%KjR%qZcG$Rr-ZG zh-akgdP&EiG%NKN`GG>Bbx#wjmN`tS+Ay9DQFuR?a?e$-`-S6y%@RI@M<%?>1oa9NB{vym~f!izCHukb!Y z1Jt@_F#9(g8N(B@GcaIVMIoCWkJaC15xXqJ)b_}PY-wlW2$mNSbj=tc!t&U0>@hlR?Npmxthvle}AE;fJ!?i4dN zvw`%wK>TnvUldMZdYt^5ynHbzF$btAA7`rD-GTd21OZS1<)V1bQWAGyT(n7^Y;Gn* z_4*{CBu=gKlh(B26z16~ih(hDe!K`|slR8Xo+w;t&LmLFj5k3C<`YAheSRScStGM$ zu)!_s_)M;SoPLd2c~)RnGTH#wTnD6NBT9yZ`)^KitBp8}{dT13Bel-|Xuc79vG$v# zewUT{gZuyuL=X!z&0=PR+EY1?TW!rAK8*sIz8VDn_3qRcNU-t)14tzTdHZ;U%XzDF zQh1e%Io-T#o^NsbMi6N{1Qg+(K`m>gP%kQUK5CE3>1c*q7~!QRr}tuqB5}y#bV>fH zb9se{BRZGo+!f*SG!Sj9I>qK*jwC6GK$tBvX{?cE= zbwtVks>q+Kze4#twwga^s&5&x6Yq^>-$k!Nn4nrwMUI|rl{veGGEh+rHtMWq^dho8 zsc)?gUF4sjf0t|0)gNUr4<9Qpz2JMki<6i35O?wN($jFqOW(-ike7x)kZtnRK2^$- zV>Ih$bZwRDLlza&Eh>I9qEjwfdQ_Cj)dyQ;UIuL~+mM9oM2Hy50dp??FPf)iY*4h^ zQboh0lqM#nFj=XDwkp0LV!Ku3>)>3enPLJEv)Kyf05PLYV|8;55K%AW*Y3EVjAvSqo!~%H6J(b*MrPa@=_pZ@xR1avUjJbn7&7d~ z*7!G+^M{IqdIc4D^M~jK1c?e47^g3z>=RnZE;K&d#J^L&6$QAPJl%p&MI94GBPQsV zT4e^bP)1ZVO_a&ie;sSqv#C`jEimh`X7e_os5O~G9s1i=1vbyBb)i+O(n1+Q>0(i4 zynY?Z7@d%xCR%BBmF82MOs0}b8aE+NhL)UceA$9L1?yHb@^Si)H(FfyiXuF*M0pAm zE-#_HG5=s#8(Q!g;R%=fsm!r2Y1iJVuUEF*&7a|Bnd_Bjm~9IWjK4YsmlQjz@Ps?9=%aTTcW|RFn+iJ!sr#T7rX-Be1!eHP{^_R zCMt7p9SNPbE$~|h%@+|R-<aZL_5lXP8Yfl#g30v)wB5xmz^fn71GE5;VL%j9pUJK0EvN{^sY?-V%s% z^+!!av?$=K?tw`onxE<6+)PAblOpfwqkEo*n97xicL-WpOx`PMn4k}_YVf>|s3k*v zk+(T%Tu)}|r}DCDV8@Iu&C1YTDzUK&yFs|d*D-@=Enm0ZtWT^;tF9CLVb+WU4o21v zH`r-e(tlh_dzcPdNbWO{U~8k;t0^yA23pA((02Gq5HTjQcqUCuHc*r`f}^bPTQkkG z{}-!@v&ZHTS#Vi_UcDjgO#MvV#SC5lea9|#vcTrw8iB6hd~-OgrOhMKfo?bg=N1188hK7vb7 zk{RfH&W(byjr|z0-q%D6jKog2<|kHa^B-?;rp{m8P@KrS64nsct^q9Q zy+Wx)oZ_`q`(j2jCVx0153Q$dOL{-E0&JHkakgdas7sKRqyIEokd~oV(vqcdKQGg@ zt!(brJ4KD=SQsq+^BY>u7EKcRq;+p6)NBr2Gok2h&ER0yVJgFj7_$whcxK*AJ# zNbd#=&?V|mr2Pn{=&5l@3-|=xUW_dK*&3`Vm~(VlARKl1X;02#v~*iXVNXj^KwRlm}t&G-c~d70{)EH(Qo zslB_PYk{gKxh!Z}Of>zP!8Fl5(^T53@Sid3cByOT5r$WQ!KLv%WBAtgGD`D&c~xMT zpwB~5E>j(uZaS&Of|uK^7Q3u6YO7`TTJH&C7X26B6D`*Z4}`WjZFG4TymUVKTXQ~j$}Z*7`a@VOi3#qK>X zG8@;S16VJX+xUZb%j+WVg!sN2>c$=>&sCY~8*bH=+yg<32&Br{|+M{8rH#y0z&QDHoF2=*NV`wh(V9KC#mV4b3Ys*J&*QR=L^qm1SY3K3GjUf79K zkAqwFGfXcVLDonddo855m`J(gWRz^V+(E0{g=V=CA=lFl2&!r2Ca?nK$)PPz0H+Q5 z%?4`R{ZPOh5vzq;)`*y27^z#u+t&J6$2RGbQE5HadKx_X}{dAjXNv;hU>LnnzWFVBQhrEpNDC*~UzlT_(f3Pmg!w^HEr?O!cD-wa&N;w-$II?iI~T>PyeK>GvRVcELorRd;fqOwZ@op@$$rUiKj1 z;Do%)2c6FHd?n^S-W#Y({ib4BTRBK)cH>~&}OO74kdL`azf#Y zL=sbzk$SYKXSgEcIru4%0I2-HQrrUzG-7CYHIhF^VcDxG(0OitBilB`Qi$!>2xgF2 zmgkeZe#GW7n=f2oQm;Q~7B&{aT@&+?#suPN7Ylk8*n?11fx7llVBHdZ^V^YKdYJin zP+oo=SA+h_6D`eGG>2Zu z&Mg5t_K@|q2%%{^$a*_BuCvOFx605bWyn0s{!76+=WDR|FbQt-B{F0!S?LWHu8tykzEi0vN6&_#~t`FQ16HP+|XOG&bKbC5v z-iWnD<;_ba;YQQn1yPVCNujKz!FHwnl!D|ZY{6FZ2zyuv=b8w)Q{_R_#!`}Z=q(sq zV;OE?Y!l|g{U1u%v*Y-WLB&^hbjOK>@sB9JtqDqMZQ)Ouc;nvp0CLvEldZ&C3qgPi z|7*+vEG1a~In13I9K(86Hcw9KK_n>skG8ih#uw`0j6}yb0@xI4l`4nF$ zL0;B<1Eh}fAH=uqf`uTGqH^%b${W{+qc|1r)K+s1rvi{ zjO!sF-wG6a3jga){jjJjg1Ubq`wC>=3P9n{WD9-2pmkXuNU#^)v+ZjPMG})4sIdMG zQL)o^;3!`3^6aT!+ZO)0O#YFTe)4L;LKdkLs$lmW#vCY4bX7&Kh7rhNY@(xG4{Tvi zZhVdq+YIy?X`hJtgyHo6nc{G*CzkQa^Dj?DC~rImy)@&?afV(j?ADEq9 zyW{wYEiTCEhwWc3xVkoG`+@xQojZ;de019O19zo=iM#Kv-hSYw^j{(MlAm3H39-)9 zV@0PyQ{$+lrX4X8ODt*)W}C6$9xIo>C~6kA>eK#wFYO+Jvwn%< zqSRkYu5#wG|Ifk)c48_^ApzkE*?5>?{o^3UcXF_K4zE?@Z2*TevjWN6 z75^@I8U1t|c5<&1ySH9MJ2FxZX9Y^crmc2(nw5IIvusGJt`yD2^6|bATIceSs{2*!dprSp47;RxOj@XT9d*15%_7{u3#qU`NGpo*`V}<8R8MFR7TEJ@ zp*a{q{8u^hk>*-2{J!KJV1urq zw3-p54QzeC&I-&=785Qvo4S*lrG6{)z3&H=N#pPpl-$hF8z-xLd`?8=w+#{8;gA7u z%0jGP$;-0A77Lj(H_JqKGNuF@rh83H#u+G#8G|8_K$68IL98c7qGhHY>cddnxH~de z)IymRHr9YfOBW zZ*Iyehy@;GrM+KtGK-*JluY1Ge=2?A?ZGYdiT>2%zd1GO%?HBz7h31MU37{`gz*Nu zPmX7VrEc1O;X&8h#NOE|+Z|pWt|3Fk%Z)o}B!uOKKwcev6o+?aD(WY;I(6 zYtb`KR>aOWReo`hDc>K#1*@=Cl-7sMPKACK{uW)Lt^6FT{B)ETJr}*!(~zb9Kz*3j zgtWYU>@NPsLwL;L-_AbkIEIeGXK@EUxyN-A)l4AU*xsyWw3f43OghldYLVj`)-sYF z0?Bxnn!A<|RSu+hBzG<8G#lCpjOX}52WYHMYZ+NDlOhY*T|h>N2qB7()LgGNU?=_N zh7yIH^JcbItj=-%ubhb|0D7EcF}Mvf?ua2iIYE zm4`S9-niWO44s_(+bGSumWnd-JF#^I^WQZ6Su4y>wlROn0MSe~oH@d9EiLh>k7}8DeFVlFlEP3EV`Cih((BP5)eO94m?hpGEk}2Nm2OQ_`q@x_+TS7; zjlG)7x2kCaZH-+ME{|dARyK02)<48n|E*?uh+?0Xv0{YkdI|~~Dj7w_vK6Kewb9W% zj3;BYOD$+94;g1hj7OB7J=}(1@8yCK^?$N#ZS&S3-A4Rcvy4G|Nn0-FvQ?FD6S#yH)H2S*k|LD=&SYtyk7+k{XN5C~K9b z9DzJ+T0E%0GA)J!2wP_0M3Xklm?Yba-+^&x%f%-(sr{?Iw%Wght7y6S6dPxrLs9ne zGf<2ztT71n+vfA_bNQI$`q}NdHiZI7yxfY*_nCnkVEeOn;tL+HV{;qALcBA)jm_&y z^dP+JcNJbO?siocO$!g!!WU2a0HV^f|Mv^m@aL+ew9haC~ev+ zFb~+Lawq$tA6vs<`ZMf*yi_!V9nEj-XpWE*3)K&9nFiB|jn`iZV+f7VT>ol--oMgN zlE%~&Gs0G>F+EqVKEuQ{N}cvE_?&9+56)R$`T=?oTvd6N`Zc+#uJrwgMsJgh(q_?O zhhQhZ_9~{J|ISXPRd$+AYP_!Zv6um)eFYc(X5nd2$5*rw@J>7Cuc^PbWv*D>Nnc~4 ziWHWYPGYx2`!>tj2mY1a$~Uda%5qD3W|%yvN`EfgYTHboG+yrVL-TqpdO* zql{g(VvrVFg3FBwtz(3j6QP(ej?^dJCz;ay*LPgO{D z3`M%Wo#q&bYmMV>Du<)~P5M0(3tz;CF8WUIMrhu2sz)#>?DT~eI@R~5xwXz0p|4}| zvB9N1LO*cglvi$3v{$CUVr0m!<1}-Vf=_g1)#5FLiP$V&?VpLin4MfR1y=?0fn^Pe zg!v~$-L3cz9GWiw7@RJ9W2eg>27O=1@9Fa9U~y*!^P_RQL)|xh-B)tSRaz2^y(<-8 z?yGnV8_%8c=q(!u6B?`}E>KrrLmwfy4tj(NC2*<*xC`T7Zx{v67sKoorMN-&&%lo1iUtP1cj>R=?2~ z$O)*cxEgN^6DllWBQv3*K%gu@Iol}y*AMoUHm0KhHpHi!lqvFvogh6~@$5D!s@{ zM5O%muA=ytW9nlE?{Y2ChEbNoTVlLdL4ZBHgYY-x?dx0=%7a9_7nJStwgc!KZx4Vv zLug(Z$rIiVNFGLxV)?Ky4JZ=4X9Iq1@fk{ukEBXRhWewi30I(x^-g5OgsVsK)wWD{ zm|ooBu4Ax$Jk4#)O?| z(b>hMQ1*Y0XH9DKc3#3Y9W`J6 zn*@*7!>MQDCF=kg2z_!dDp%cBi?HrMUv&GOiuMRsnEFQHX^QsxI#90v+9g4%PgT@6 zOaQ3iPW&n0*ttpfl}RANdTgSIJErvAtt(I(dU4#}8|^Tza4?q^%4M_(!&fl{luEL{ z9HkHYMxrH&vj1r$s9hvP3K|2{ERC(6zT})!YSepQL~T@3ltv}ArBOvtcy81f@W+^f z_+8P`Do^hx39}qi?VpE+b<|&9O)nRu`Uavc^2)6#L6=%_6zp=+hyB*4BTv{YY#*Tw ze^z=7uO4_pO6u!mj*64f5etwhV=#tWpC9&J1qLN~3!xNb;-C%1Y4y`K%EbD>ddleh zPYmAqC&QtaWB3JQkpZJbPYypQ3SXvZ%gw^x^Gfd>C>6IWy?2o0?cz$UVk*lLJEG&1 z9rkw8s)z`E1{4mf?bx1*R|zMOYHHjDY{2CPn8rxhQqoYr3mAMA*{C&QYE4CkbtaWk z)GkLq=?AUtV&FoYEbE23oW2IE#~nik+{Ma%+7O06 zIlSmi@FCXQThZ>ts-V!&>m2wNp3qRG#t9P*F}$W-05;u%7t^zUIBRV7T9m2(}JyM5@ zYssHUxzYL{5D7u{@ZPYo6lH~@{=i2L^=EluStsfYe6!ZNSz+Cj;zscq>BS!`(MX=9 zUwl)#C1Ek&*Qfqpp(Fa7rC-LnRi?P~i{se#N-TGFd{e6+HoH}(KFfmd?7VQuV zx+y$rL!fozr+uYHc-1XH@(P+<--}uU1vtsbts;it+qK>Ieni1%_Z@W6a%+{8_opeT z-8fQ|{U0Hk#ZOB#8C0t^OyyXhFz&~+aHhJ8_PL2(7g$BcM^VQlWCrey(PvAsFcIF< zsxBoWsB!0@nBq$-ibWLb9a{Ay#cYR_8pmV;;Lyjcr1Fm6dtXDLLr5;Wht%_Xszs26|9#|E`it(0=H#gyhI2?yjNIV@cllvR%aqnW0?> z5f@^?TjUiH7?vxQIDx~rrCr~h!i>m^RkHB-%?_>^Q7NMr(Wp~>BO`S;cB@kzAjPfr zO3skoZ@_a2I|=)ffJgddG7eZVpx8Rqp9E0R`DPa3J>!llNA@Xk{0Pyvep&+DtA`Dl zlFC)e0S!Wcfc8jD1XM`?63{;%MlGu2=JPB8(brTUpl7WNtIswCw1@??2!-UbT?HJEsNdKPMXU<0 z!nb5DTSnwn^LS+fQP#$Qwc~y$K`1zQSG7NYmwxe^TMm@Irzee40u=<>NC17)3XDwx zlqS2e8!d3Yj@fkhM=qzRTQC;FHV_&f?V0YB=e#*xp0Z1v1-oF2=i>C%;@mRbC4ab& z{_JtSSMPl9TkJ?FZlB@b<2|?jtPFYc$2j+R9T}Z_QnZJkjiBxNE!6U#;*t_1?yj0imd+w>zD5fvwkt8+l2K560E;= zIkBG7C$XM@e+cXU{9((iCqjtzPlFd0>+b>G&9Pn(?MTF)Ok#Zju}|v~gQQ^nKLqP< zIL@qphFDL3s{K?@GFk7^)a@{XF11Uyy)fdwv?R*zJwwsdoq!`wNkDG?aYkX)7Ll@Q zX;1V-H6o9GCFzFh=ZrI`Qp>Jz$Al^6PB%pZp0_dC5~=d3_qfUz8k(!}Ud*eAD#`1i z%1dljZX=$URniatS*lA>t!wdmQf-%3QtH<3-s#e&*XnWC#z=4n-r@AB4)SDaOBxTt z2VxLDXbIag(vEk2MO>k6;`p-tvv5@v093_en5_3e)%6?nMQDx{#pNxbMss1#qbBG- zksXN)^o#(?gS(r4r=|{xIIh1F0Ehk%^&HhP;%s3Ty|=+8K4d+lFOjm-5;idgK1wco z751d5O+-kLw5Ok#)-dNxHqm^^#+@*3u!;ABc;n6=tu8lQrAklT+Vy%r+~pp|XAzoo zIRc3;_ZFD6BtYqtx*P%jkS^C}Z_8bd2%#=F5WKLuTs-$BAy9G)mU;=I9c#`KUGDf| zv_b2#3`x=D6c{r|`IBQ1s$51N1vcnUwVw)}+~uCC75Y!vy=SI`V%Zc=-@dUtuEIZLS zeHgl?OXGX=u7ll0?~==8;!2HUK$Gm}bVX5-9Wi3imAaUMM7eBQCrP64BbaDLi1>-h zwC|5l<+dpFBLd*iw{yR86o;$339&G$3tAaoL7z<7lM-CCf$;x=o-CJDB8=xx#3U~I zjib;5O{XY_fG1h%QS{?i(6OBSxJpW=*chW~(cWKUFi9Kqr458q#V$BgbELo1kH*=_ zHIBi!LrqeBkE#u`W`jlkAhD=D#*Qxhat!V@$C;d4_HRSJs-dW_#u0j36bt9~6H7V2 zWjlVMu)K|tQe7?Ej`YFk7Tch=mhre$gh~Wr<6%{|_`z^>=}Ri;ae7(EdvRqth=YkE zfTDFj5YsQ*pua~-)Hu>WJslY|33>+T#J2%i8e`_z*UjrBbKfMXlq^@EGc@%JXak>`+0nPC-J?={-chOzkZ!{h_@jK;P zPaJEjGQ9T=h>5Ef0>KY^m=ow`1phYdt1qqk7xXIGf0%}onj;_eL6+Wer&v>dvo+E1 zq04QkK%dIC+_AMwe~h(*-gYi+UP65w-mh|NUEY6#_>8bX#xRS00Y>LeFDC6XHu;Xm z+wnc9U-0f}xY5W$c78#^7Ao zX4y}ZIZa099EDqU^MXY-yD0*M2VpzfD%aoN;!aM(p^bZaLU5}>CPF8mC>ga=0i{6oTpV{d|TVHrse?rJpJAu3D`Rm035FO7r@yCY42qq$$c zM&goKmLhRLDpZzrCyb!Kz8MHC@1!|Kp-_E$MRTO#hG#GQH_)CJ1MBV|m( zACs$y;opP#6T_#1g~TBts+?00RW>zPj9g!Z5?P`$N3H}Cv7Gb(#d4J90NE}a0{$Vw zne;{@;kX+Kho~T_%m5>-KrR(TLmc0AIY}Ipo5fKr_1A|G?=;5_WD|VP#)JU)e#Rl@ zdlpg#{i*g-F$(04g75kQ6!TS3L?RVqameb|vI&#@G-q6YAx$!R>xGwb(07($D(<-~ zoaqRJrE$;$a zd%LkV0s^E>v<|AMA0b{D2RQ(&cPfEwCK0*k-_OC|IZblHqnz~{%<%;zIN_1?i+_lL z$v^DvNQ{)r{t47o^9jeN_c4x(s#Z|yU6DGgYAvOb{b(9&a>htH^y+ks|VZueuu|3xaSV911(py~$Um-G_i#_e0pm zy`apD;1J6hGw>C8m$sHB6VP$?e+N3eo!#078qydk82t)d6zT%aEgfkrvzQ+0N1#`D zlgKy?nIafgH^$K2!r-D+zO-{}R{+yJZ#%w=-2QF$f<_J2xuQT609eV*hc=(699+)*a9NPp>z<&$9pRj z@iFV+5=0zgB*G&FxvU&5Xgm_BcEksv;ZVYTjeUG6vTm4i2gL+=y4Z?;>o(ymM&27S z7S}OP+O{p@!X05}Q45Y(w!(B41QNF5z5B^oP@0^@4m30D$qD#}IEw+>`(hykyY~)z zM+;vZSWlIU0Is^7q^E%kmZ#{7E_zZfh~?$>*I*k-yZ(A2u}pJ3g|zSyxzrF}+K&e0 zD3^^z%Ah~h{3#~#5i#iS`b{XNEv9avc6k|cLWv40;qBnoN=g6g&*PrqQh$S9k0k77 zzxW&!VT{iKeh(n7+P;!L^;W&)tYK#s_bS`t?Y3k>%&_q>_z01&CRXuP$Cm9WK7c7+ z$2mdY&KQdQ$P8uRy`{_=KN*t9C?p;!8iiokn1owJ9ic1g*h7`HuILT~D03BQPRbsP zNY(%97eb!K6Trq$5W%Y(`qFy<_5p0}#|`(loN?%EwNwFm8Q4I*j4uJQf=zlE^#h)A z$auFcT@3FUs=rsoCy8NiuC9;zT5NIo6nIh&Z=xrPwm{eC{McTq$*848H6D9q>=jL3 zp9C5(F@bl&itCv9=D34?$|#Ug%Z1Me_pzp>`!-3yCwb4WS`OZDZoF(3)E~k+4?VAW zfS)7Fmfw5&eowf^b4@7u(?qP3S3QOT^;cHWCmZSqRFO}{+Tu#OoL@z=kM%vP9-+$_ zRS(mpbJat1aa66qg)2femvJ>{%=zEILk02<-9q0vSJV&nL_44f|M8|Nlp-zX8?d%` z81$+>{u)UyxsP^VV2|)2eEn;THe8HzcY=Fj`P?!8TkMBD1oP7a1wjO)hmB=4vDEB- z>qX!7!6;%Qjh4eU&z$n19oPr4&l=({Z@_$Mdwe2}Zk+1p&P6p_fg9w#fIVJ~=1(3c z01mxu9tp^C1*jIQc+V3tHI7m%LlGnhU%AVb%8NvDSw5UKy%@bEaZ!jTPrky(@u@}{ z9<^mCl^JAfLEjC<_w0Uit4H)7zKlVC!@EL1W#Sjtc~aodUJyn(mHihewybP87bJaMtZ8MRBbI4hQjr!@s_m#DzBCmZ!eC|NkTU2` zwV#SxRu&niPzJkybrXP;=_=HTD)bnkOx~-YNLN`8FN5(SMG_P1^d^#A_5h^VNS6*6 z{~^=I3xpl;3nc%GOpS`LOgBI+o5++vLZ**H!aSrv#*Tc$G0nKcpOav0jB6Xra)qW~Z>J&msuSGF!1?yDzKCiJ(4WSaGQ|nl#1|gf!DH1kxYW;CkVMb#& z!Z2Zg%S$bmYJTw_M)UpWKvR4n7ZqXLd@jfo!F`kUn(@vFwwS38 zd|0@#ixG&v(f40+qHqlSjtpL*+HAL5YXi99Dk&{`@{DAbwVD19xHk zvTVgp-0=!p(>N^4b5wsVpBB}El!X`7{(-bpt){PDycCm83kN@97*LMqdc%HJghBYu zpZ6?ZYN+^hdZ(!DCR9lu8#HL=ZDcdnvM;faE^yFy8@|PS4P!YB#^L*;L=^T%BbYKD z(8LDSGU@=a&`){MquY1HY>VuF7O2VE`YMQ032S`>cI~7|Fcr^yX}5i5u4v79g;%uB ztZ_`i9lEMi-;r0e^x+vXlI9r8&t?Ckcw(+$rJ5P_F?Wz635%Nyv~5+E%l;F#xWx7* z7MDQ6;_jct?i*=r#O`5Dk+Gz-?r8|C^@Q0F1kKphIG*}9#_c#T>(7jPAwNRgyi;%o zf%QxrFR4|)h*{K`Q+Nat)C~u9SVSWLEuw{|@Ccw!#zS+w+#BJqu!J;)=T;4jL{`ip zlXOH^z(FyEciW7nQ+S*chBF6ox;_~NES2y;u}G;>NU8dhFGz6K!1Uv2>Mo1#Y2qq* z#_qs*Y>_Yg<#Kbzt}9`zahwJK9b!W8t?5kBFfk!mDN_B!gkZTyo##ut;$^VCxI57k zucgwYoBjxdqQ40C>*`GQ9K=PM)_NZ|h)YQ1a3p<@f@X8li|x7mz?`^)c9Rg^XB{hZ=bi^_s4wpKlT0FvAvF0vkPCc`u;TB+53LFlluO6e%`3>Uu$O6ub&?2 zUZ>Lc`~SObeg8A44np_l`@Zu_bcxQ;FthJJ`(oq1|1y3G-7-w4()S;Fxs8249n?kb z`yM=Oq3^FmpQpa>1_wpozugn9?@vVhtb54Jn(ko62mhCS|LdOI_b)kQ_5JRIvBq&a z0Fl05d%L~wZxt!C@4qTi==)c{a8loYjJo~5!G1k}Ur9sM`2V`^KZ;M8bKhUl$e(k( zmvjbo)+3qfaV1bO=0^meeheg|DzEPjtbMx1;Z9N3X+o zv`cY&CG_UP1Kv2yPo!Yh@L)+UcA6*3OK-#gDNEHeeRZ-+tv>RZuNt2%4Z7rvYG+_x zqAN8dFYS*kF7*UH%-Q#l?`!$UXU@1Iv|-{;^ob~!S~H?_cpu5z-uMfW-Z)<{7JGzw z&&g2iYf=L9<6`tJduZcHjW6xB56rGw^DnEbZp59vtFB6;uKF*2F8d!R^DVZTtTZ#~ zPv0Kt4Feqze;Z>u-;0snkb$YQCZ3Q$!V?aLywMv7K%Ow{sR@AXB#$7Z*Kb3f8b`x( zqN8HPUiO~{24GKsvvdI%ab8wx!-BJ6_lXN5m&6Yku{i!3eAHxQ>F@zk@d5I3N$?T$ zl;WIW_$nTD35ujkj!D8S65eK@wP6yc5?8_8RQKywQ0vWtai1%mkMWv~M4ZNsN4nJb zlW-x`FAdOL0==SvH!}Q*NRV7Ag5RN`Ycacw*qKUV+Ak2Gr;0XV3Vt|q;;Xc#Q!_f7 z-gnd2AK(epvK2_Ej5`H8t&)*l_4nbw{rK-d{Pm@MfDLux1;cct^?g@zVgC;(j0H)8 z;mteof*~d71;f|r1w*_~n1r<4HBR#rCUqpeOUU^H>*)y<q6@S)VxpMo>OGlA5utJ>YH4d94B?v{=7s_iuGIz2H6j9uF8C6-wIo1k znw;2%)`ur22>6FgPIMw#F-?t7FvFU4pvpOltB#ZOo?wDCHSq%oJ}DD~we0&esXDH| z{=;p=UB^Ns#l!?HEJE6EW5*RFm4=i-f2#dd1;vwb;Jh^_vGVUcnXr~J)BbB-9L0NR z*?=4LTc;u*C#fUC?n#xHQxpGTW4Q%+lPRy59%buC5$w5`#y>-h!%RZr=8HDsR)h!!#a@XFqsSALi z?tA{x7bMDM@CVX{edZ&2;W5zjo2X4woHYmcVKzO=5`S=MM{?Q!hrq652^h&lQfx6x`n-=hm? z-K?=TII5dr zWw;sjL?&%%w}D(Xfi~9KH}4)$v@4GNt)H}sVl8OGwXo58@MajM-e@8GaS}MGmGr{2 z2x+hGxS2vrbjlik4?IckeI4z_H~vnUH9uum>tE<>y0z`aVA!5--N#j z1gJjf2eAQOFdLUlZC+5p%V+vw5+YtSV@-uD)-z|)Z=%*#@cocC5KNXH$Gf%zP>r#T z80|}2fZbn>)FPh%IP{!J)HsJjx3uti1j|s1Y%9Y^OjSkHLU_(&heR@W@0WwsF@g&Ti7Jr~v5-6}Y{*0==6QFawG!YvCwLV7B#M;0b#i ztJi6Gzd79Nglm3~)TWK$@wBJIu6dX(IySdu5{O;1Ra+Ny3A45(0eVV~y3w{w0{$V6 z`u4w(qxMsGJb7CtQDM?t4Q-eXCRsjvSfmM1kb_^Pg|}rgs=#_G%icbWpuc{Rjmw(j zB^2UqnSaNPaO~$mI8ex6YM_5|Sr4R)i}9!0PuR$@N48~tgvii}qH<0_R2!cPi|PuB z78<`$NFWhKK~kv&BP^*rL%l(DL|3+<`Yc>F1E_ z3kEjZgAh^*)=LjTp z?pMfV35OdeEh|!{KSbwl{0l8B@`ls!vLaQ^%HyogfX3YhHdq=rc)V#z;oZa8Aj3Uh z(6V9%lx-j}O>=AkKqy;Z(j{M-yq%Serha+;x0>TtQZ`yvw6=DA@B~Ni2ey&UU}ktV zuPF9Jjz(d-hp?Mrdk7>U95#N%08@;(UbvAUr!Kd^nzqR;4QllNTW*g(*{a0@A z^?5{YquHWwGu}ZaOZ*?MW;9=JAv74gm6P}t^@>LTH&*>>VWW5ygST64*p5-xhRoF~ zW>DUI5SdJNi3%j*!~`AFIys~&c#_@w`F{e%CK^=aF-snh?A?{uXeLagiw@)~cJ=de3Y zclSMnWkp(2HEJ;7k9}+OA!yo5R>mf@>3%i5wcZgzob?#ksK(OAE-0DDNrb}f6g4fI z6OJ2k*#I^oAMZ_T9^azxl8`4nt`)n|4*Al0Le9L7a2e2GdI@WYy>LhPtTn`=eQ0v> zG=AP_9pT8MBBS2!dLc6UsMQ3LXd9!iuOAP0Qyqq(iFqZEFt3khQ#YlweGQS)n3+6= zkXGN09OjFEHI7?A7aa)l>ySsk3R6NDt&FasFqglY@#`K-0qtA4Um{GK#uCA=O1e>moPhQgHN!%^I z{$g`4JJa;Yld)nkoZkuH38{go9@C-xcnDKb!S_R9Fbzz}qr){bF}SzOzq3zU@}GO}_sDSEI`JY`l)4 zA4HC@eD7b`SiTdm38}GsyYFsJzVGe?rv1>A=1eQ$-dx zp0-ITwB-h&SX|JqMy&!`DJoK`y^z2Sriu!R3d)KixVoYw!mfOz-UM=c3DyO*E4quj zx?6We>!J{7p$Q*N!4C>37I7sl2scKtptc3H`Tx$`n>77!)m{JlywCggf!vunGiSce zoH=u5<_z`kF1XbGr7*RBtKsU>zw4gs*1waGeXM^cvr?%2I~C6qcP$a;egqvJhH^Ba z*AKB??{R#~hV%Ci*S!MsFgTbiXAOb}9OUepVdyP3-(tzuycJB)aQXv^hhU2L4LmH~ zr3vxsSiHR~9u}JvZ%-`V(1dtvSiHZpc(~U|@z%!TU6K%Q0gLwpiwE_B{X98KQsZUS zfVITR$IgV<5Le@4P8z~-e#}k-;cY@}4au2TAvrI#w+3SMy(E@zVtsX#Z)P8W5E1!M z0rjzni531ZKoJ{ZgBuaG8Xtm>wM=4-Ut|YtL$bGpHw4Koqr)`J*`IU zmsn?I8X|6@iUtkuKBW#zyn|y;H%qP9ep3ErssT9`UW=sawVYv)<{(#Jf&luHv#LJ3 z9OdL(S*T#p@CtnNr)_^&Dra%~E&iZ|-gp5!T=c$j=P#0UIOvT_nhyPlgOMy82S-YR z)hpMjuysj6%f}$RsPdcD$ylpDRJSQzjS>>Pj*peu4jevN^f6Q(YY~irmm{|2+7Bie zi4xv~ktjME1FHL-pGK4;WR_ne;}I=ORjX#BoGS`YC?_(mRQ`%*dw>TzOiM@#vI9WO zo|9G8_3+L$l<1Ih8F0a>ld}H-$`_Z=QOK^@KA>isf~aBA=R0MKufkqO=jOIw%>2xUQ(NjX5-cuC5i2++_JmTo;bk&%?$LZR9kYCGAL>H zx(z*lY3MI8p zltcNvx@-PhC>-E20>8_^TS64%b<_(bK?-J7P~HHnSYApnp4+e>S!xGijzZ%ciw3b5 z*<4bq11+jy0VO@X9kB$xcx*SfE-;Ii1U-HhB!@jn-_ZwS(IW;U=tpepJO5(P&5m-= z4K*#FhqfIRnTY=G=pA%T?W4n^hB>=2lrZ=cg)Yv0Bf7^o5%_5sYVW3CCm*i<2InaU1sz)NK<>f|Gbh1i2W;2eu0N@8S}3LLlK%AZjcY}4J=kGRB@p`7` zM!*u=pl5mpC95ROs5!m8Gcj*RbCJ$j5Rdf|0>`M;uc21ICig<(T!jtz`JR?`LTT|+ zT6zSlN+*`0w)CLx0JWuc-2rM#AMkf#w^gp}7I<@pl2JX3~=L7b0v^2GI z2<_a7x-Wu$lBoMf5O*e`{*)%K+0d<>)F%IHcYxaD-tGXk$?e?%YLnmD9T0Ew>$<@@ zHF*vL_uS-qz(lwM|7OG7C+C$ zdvdbjo@K+JZfudxkSLigo=N9iA@FN(zlQjWztgu#hk}NYh)JAExo$13(;WBEqZO{< zkSW1(&n$%{5!qb5s;V1c()F-_JIu)-ImO(`Uqm z3Wi(?mt&x<;KEDDk!dR^%!Pw<{T=aezIGn^fobPle<0Ka-*O^N%{Dw3x^x*F%K3#L zZmE_Y+Cvo`m3%N2E}b&E2wU)e$1Ix^VleB_Ab|zBuMo8OFg4)KP8QSVbtM(Oio_{9 zttBB{Gtd>(*|@O*o0O`UuVq+rqJ}@aNy9YcaeQpjg$voIa1lP?Ly)J)d_jg)?H}i; zdvHj(`ZbgylFC;dYb3HrFHLivS`A4Mz2Q9d73X>uxjIjs zwBPSM)!?{v6N1r5i_i-5j8L!PPuaV!m#$<{<=TI3f<;ptT+xMBA=r89Uz}TpV-sYX zcoIQN^GBo+d`N$rVZV-YqHE zTCPFARKOHZON!oJR*^=bX}FCBlBzJ02Qv1Z5#R;z?jh;KBCvTW?0$x4GZt=XLL#M%;#<>Rq=_@2`!V7ESt(b&g(HY^@SL8UJ zL+R1+h(a~6gD<1>BN9swd|*6;w*e^$;STx&(^~rGaBgg5MEUCLQ5+)N@%XMwf(YlB z4!Z(RV8G(93m0LgE|}s(={*K3;d?8v|6XllDI*v0)hH~uLu4>tU7?1Z#aG{`x-dj6 z3<}+(dpnW%Ui&$`*KG2MZOMT>h z%jK}Ck>(hZu+VM5SlW1e5L;iLLs2r!(lI8;X26G`mC5qO0SzP-$Qu8*6OmyNl^V5uz|w4L(HQN7WY1Q z`0DkD6&{10736X1n)x$KTBT{>!}y@?{aBsAgvhq%5AYKjSd5?0fhOW74}32_dE)g1 zeu4|M&@KQ!<0l1h^vF+cK$@=n1PvJt_eP3%JN+O_Nkfu&bFJmvZ=<3mthtD-aPBJj z#VW1EUSl4Oy}XBJV(+=cGyCzKavwvab;{JlEJ#R*aWMC_@MxXF?5oB)&yvMPJ@?x5`t+^h;iU8c%_bP1`4E%oWOr2pPXsvvrmA(QS;G6!8pV~#a3M;RRI z^9<65z}osD(CC~Hyrg#N6c0@SDp}G9`{Y2on z-kknb$uW{z%;_zGFVpZSy*a(rlH%vZ#v)$Y%Lf|!TGE?&u_=d__VIzHewOqTym%N# z?ce7EhqEl{CwcJ*l6}Ajj==X7FMg`Gq<_r^KJ70yC2_C0smCno-vpY@Hm9Ey zjh6VnfFlz!3~mvt?+b5JPF#WJE}eqsMP8uhN7uk=2l{Tz+}0rLyK_AKaWkg09}Hm; zumj>a3VAu!Yo|dI;mIJ0PWtbT^IzsPf8{piOSeemV?Cy(#0tkT`t~!R-@^#{qjTJ1nJFQ?w4C<1jlF zgB%#1eyFJAru(>fAv2kGUUwPZN`TyYU~>pz{6-R<+y~9v1~>W5lE1ZH+R95iaI;Vf zSfnPrP4TwaWJJHE1wPaB;!!;x_yV+>#HW8?kv^7Zx>NDN_NpW3^bMihDs!*5o%ZybCks#PB;Wn!AmL_3{;{P_s94x zvQHI@>xv>bW3&c&~;$M%9zVJZa36qejy+k5ly| znWZz>$7|gOPU0l4^0CywmmHztcOhdcA4v!Jz~|{DO^m51y-OMqO&9nKOeGWugQ+xu z-!P`q7>K0d`4Mya;glBfSdm3)3moffPCp7d$gzM|1w#GI>Bqorj27uMxD9wn2;`Jz zk}*T=VeYjlb(ZvF=HB<=`ILw1ZTVl^YbzMW3|2eN zlA$u`tk6-OgH~F-lAg*fC)<5t>VKU2W*_fcG?sYS;Q~v+HFq7xi+%y$>Sr8huxFqU zt&MS<(}^(0k=j%uZZ;H`=Fw23K4xztB-mSu&3B3XCztV`^D(eWb|&y2$>9U%X|zaa zhEN*X$A}h@7U50I!(Apm@FAi*G<*+yNL*Bji+k(t*^WWtIpMfI{W*li(j3ZH-Bygm+8Atj_+=wdL!HuXWF>Z8SoEuReiHm$Xd-B01 z)+?z8n3VwHM;dq1*bbABX1ocd@QpZ|?H zzlDw7f6JoQpcsrrmBk#+m}4#+aTZ0zZE?SY-yddC{|QdUqB^yQg%$q4VOPWq{?BJw zKZRXIa*170Uw~b`fKT{!{D55%jp67k4YvP+U9qwH;ZPc@lt*|v)+|g=>Y_i#b7Mua z;fa3^*GZ{jG-+|ZZ1^pC#_O?fzxYDg@G$eGiP4nBXXBh7^JR!p{o>xT;ZEkmJ+SXT z-^WkBRWU;M!<0M0k5MOSdyVk=Z?L@?G#q|oI884)r5yz|OChlIHZq!*V4sC-?MVBq zQY(zGKrYv9`5dwaY^AD~J)XIgUaXATuTWv8_3Y^kCqmVLoDCGf%V+cQje3hbA+1=x z(WuM-9QO!0*Q!h?k{H$^HRX7Mlx#0*qn?gEZ1SC>Z1Uqpf;1BE=q)s* z0Vn`C$tF!U;d0D0Q#PVaMYI_~~KAXS^3IN2CZKAv|`;8K$H%)8cCOni6 zw_$EF_Tu$~LCx@a6J>_DlTvN+R7e2TCO-mf@&Y5$Qf>$#?DE`fc>x|MTV+x+dEOL4 zC?(9n&s12QsWvHU$O03RHp7jeHhhrlMaVUm64OqN8RaJ3Bqh$H#3LwMqZ+bcBob%C zji4NSkoYPj9z}_BDGCzjsZl2tQR1Q`M-G zCQ;&>De(+7WWi)4o((sG=Hi3Iw<7UWO1yxgAhA=8I%x(azK0Tf)Q|=DB5@hq2r9=1 ziDx14Y)ZU_q9AdF8gt`{pk}%3RYD<`6OmD=RGG>5l8T7V;UJJ6VU;V_ zAWZg=T7-&JM9G0hP|+}Al*>t@LTDzjP#=*h$}<%{1kS)muEbIfXox@w&1{MYG;>*k zvh5Tsm-`vC+O&X$`aXsiXq@l?jRzmOl89OMz0V@9GL=z8pebhw%82fP=5q$EHmzZy zKB97N@CLcuv8b3==_ALd=C@eu)8U@ScdIqgFHM3Bk4ql*XgAZtQ5aHy?!3dLm*(~BJQyRhu zjgh``*#HWb%Z&_LZOUe$K04S4G<4+=XvoZ{T$zh7*=J%ASDErCBGAy=%0QDt!E*T+ z2CX&~u~6SAc!5TM4`?RgBUg?@nC#1A5m%X}QbeGc!4j0&C|E8R7_{0nn}zz!@B+ zm*yY#sq*226h)K}{fLh&`Vl6t+fESlDS{}gsSIaT9YP7qE_`V|nt@=N3T9I@Zo}$# zRCv{Ul-gyQi(uegz!Hn~2t7}b<3v+0X6=P)ovDt&?Z92H(g4J#bOuYdvXX-3)vq!rMlU7AXl1~v3Q8$% z$1iX$AP@#CJ`hR?QdP}TVc=49;4EXwR{AJdUj06UV%$c^g zUXT2gM+ebf)hH~wZQi%k&&y@lR8{^k1UfTm2W>@JWefOf;$}c?e6#9YiqHY1%>X^y zt71s>gRz8mUW=`&8?aUN02=GS<~NZox8W`NNME(?6OZ~;eXe-K2nFLTNrij_eXd?Q z5Kxk#%jaHuflRJLnTve@D05-slTrt<86Y0cDcMa*b8Ls~iQv#Rbl0j$c&KR!Cb9x)}IZ%p6qvw4KKxAz07$q1R+0ks?7b9)T&g} z4z((kAf{Hm48>MAd8mnLlZU>En>>ti@emHEh;8#w>V$0`Y#%_0imud~^U-lx2*deJ!$bg6cAQk)jMI_ZE5A|zdn9rn;ecyH+o@NUEX3~s+F zXqW;Q{o%xam*?epj4we}nP}%7l^P5$sOfN7)qe&wRtjVLq@IME80NV`kYUsgZ^a;z z;nF`2*G1BC7i38_^(F+Zr6A1L9YG0L z%Lqu8p*pZGq9Dv4u^==`E;Y)12!{z-a^svLoq?pYid|z}*D2O`99 zH5C5qSU8nO`R*x%`zZXDSUA;2`4r*#ex)yx;XL#mDiH+@7r{k;UCG5UuxC>-0F=tVbEsWh45B(5tg+hgq4KR-6!)V=fKfou8haR)G z9@2_foN`8xR#N#<#0z3YgpI@#!k$w?AdDiuCj?HRh%yxm_J`E+2}Ac&a~K7$$l5@v zRazIZ```n7m#`7g=|X}a%Lz?|Tb#SL(H(C+_8Qg^07b@VtjF!HI%*T-DT!2Jt@#8= zW|b6Kd+6+aY$=c@!NPF2VjX!9MwQmt2MgjNf2_-4|2jy>C6RzQK%`Ov z-{LQ_Uw|zLh7ESp@bYC9%X?_-wSXq&AMRdsov!l~f{mQ-li#gU)FMBuw_;NU?_O~$ zeu=ijL)187f*T*3sB9KIvWR0QoU0dnIAn$`q=T>wwiia*Y*KMOb(R@-D2k=Gi{)V> zAt>EA^uf{DH*&8(I6B9gvZGjjaAX<<<*}eq#cGg|f&>;c$(r&V#mc6j87yeFHRWFv zltV!a5cKM3CyHWCd6zT%>X$uz_k5s zDrE3(2B5O#?<}7A1wE%Y_`Qh*(?%N?p6}>AQJyv$3~TUvbP7z|nr$t3ci|@q7kGrI z{=LYTJ)9>bPL~5tXD(ez7rF5O1MdvwbY2-+6hSVKuQ&331#dxpLhZ@pzEB3YY%Sb) zTnyv-I%~>1G{W6G7ynL>-ex2T0^bv{Tdm%aV_-$aT$(WfTtx>aXf8Dmj9Nz2nLYXm z<~-X#90{8|u-#lbZ9Zv+oRi3{CL+H&pQgyU0|IBfqB`s zlw-D`O{E#5`BJkfI-<^_AI<04Oppms)=q|W8$k|iplJ_`aa*3DmAaQdCbp$MHqpz! zN5}ccdU@QXPkU^1nAEnTQAX0|twyM!+o1 zsgazU?gt6pvESixP!hN7dDc!LuxPZ?c4F3;#a1juC@gPoB#OoRTzkUyn;6UW>d{^; z=F-7m##gzb+xV zVBozV&htaJr=`JS8)5dqgw9w9+@3JeHF_t3quu~xhh>wsmO{&=fV zN{-wNe;S_elhetcBv1KRx=9}yBgpyWPbL4YdR)AfZb*}-ACd0Lh~#wbImb}n-K-3; zm*KkftRp?4SCx0tFtvA$5sp;%e0~>L z-bN9M<-Vv6X8ReClZ&O06`fd|vfa9;jb1QZ@lPbcyMe3|!Gnc8$L;r6z52n|dowcP z_iLX}y6~o?@gDmv=+kyS zy45^lVZU~>XQ8p(R=RuTkCMYjuS^9|FNYbdl#p?V;j1Yz3bA*m-1@= z4&p~V66HO1Q#4GvaJ3$Prg08k8|S(olm{2C+^j}Lt@2e?sTt-U8ssT2S;mK2b$+IKv?)+!yaij66-DxDJk3ymM~FcR*xUuvb( zlAFM;aa>_1)Cc>TY|>7kG0Wrh`;J>K*lJF%HB004k=~f4)QEiRUc@zD(0^aZoL+C1 z`iE~)3yJ$cFDDkVmjf@$rbaG9DXAmu{X0r2;QE@-shom*m9X!)Kt=t?DmL|UqzNc% zD-oD@7|HkAhgkznDf~vYtb1U%ir?30!<#{^2a0C~Y!~2)%D&^abiAN9E{#gNSB=WI z;vncAii8VlQf&V!mx)zKl@B9p70+ zm|9)-EF$5WWf$gKf>7#aZQx?6I&Qz->dhDo%j)Ax2aLPXJ5pzD{bYQp?Fx+5J>xwY z|}2F6L7Y$xjV;xo`5%DjV(*bc!$y6%ZI+hyPG~DYIf?#JC>&H$8IL+hTF1K z>(HlFwvP@i!u+hU{CWZ7K@h8VQE$T7&ktZmMd(=555$V|!^HESJ=?qrF{SghsDbiu z5*1&y9!Pg2f2>)u8;gfxdfj0eaRkT4Yu)doQFYdm?+idO|6;NO=iN+Us%^5t zA`@X@Vut3@mkG!_zn#pv+z5c{cFy&<>ayD%@c-8Su*G%6{;vIP+_Rtub(ABiNW!gu zzw>#~vn{3f(b08+B&e#xNbD%v;`|81MJ)=E!_)MXZxGBHHNOuwB5)g^dqjuVR3DzPAtU0PyUY0A(v0ORH-bXIN=g>|~C^@h?VmTJ-OoA0ZXarngSf zt^07q--lTepGw@Pz|9PBe#>_8R4+$gp6OBe&7>QO44?-jHur{8Jk0< zJkpEzj!$Lpq}{hhkfxUlGohIi+vae~R%c>#&j~e9wuSu(@t0gQ*$&eD9z|u zYk|w8AOM>X=zYlhCO>@2(;unYAa>d&Jer7YE5*i64aMezDjJ0AB3bcNce7NSn+S=b zcq)IRqbSN!q=n&2R<=2HR3a<3YsvuT--NNhjZV1en&zmMW#ceH_4Z65SVDpH7dgLl z8JS1IUD-Yr*>u_SyHq@CF4p)7%DD^~sHaz=a>J?=?uz?hTS@R1;{goIcID2SlVQwh zyUuw=(@nu`7euaD5<`3#)41T`N; zMZ>=b^=Sa*0}3cX0CLdYw`}NxZJ}J2xYGh1Po|hXFE1bpl%_lJ{O%e-o?ec(M(k&q zC9G*WMaHVyhblgU{h6TQ)jwU%np2P$`CyQZ$l$wFt2D;MbCz$|+g5_~IOgv^k@zjP zbM|w^_OtAR#P$qFpVDQtv6hh>F{&=pcac=hb*#vGw+N4G0%y>8*-mu2H z%)K5yzH|c*q*j>~*BWGt2Bg##wbUlrFX2m{B@L5jkN>k&XX7DfQ&N%hXuH43&}SF# zd6Gc9hao`pWIN`MXGb6malYd{&tB09tY=`d)dcVvfG_C;PP6ACHElRjX35UR@6^m% zllQW`2-1<4ks+hqP9Xad$S&^$&S7BMA_e#m!1*0uNE*+c53hUg;vvdB9nEAlAygPF zJeqaz$wH>rz8DOScm9or!FOmBg43T^c+V#Z}18<=Q@ZO!pteJ zYJDkqH!`Ns{2@b%+tQESiua955$pfyP8_7X*52N!69=xKPIQdzu>;EVnZgS$w8D0IG!R0vP^8O+E_A~cu=K9(Cg*fA?{`CyEuNNa3YFxHG>$d=q(a3)v`zyY-N-wbL&-tZzM)7PcO5{1&kNb@vDxp$UPYV z+$uk-pqPTxzgXVDrb3l35d%x$O)vyvzl|?_hL*oATa)d1R(Wxnvk5$h1t|}~$OVlp zYj8a46*^R&(UI2@BZfR-SIqH<%g9fE9nlsKQYL@fnX;;7Mp@VPNLg3?`g zIiq>tRL*D{C?wL_)rR@{jjZ2`~PBIr5K0O~@rYoN%c^ zrXs}xvk{2WV!oY)Mxb`YvcoJDjUtjV!{8u>5!N3kgy484mRcl!BsFt*6^(|OQ&5k+ zRFB{j9a8QS9a652mF|Mz6CG0SCgQzuDOZPrgy~wG;AH^iOEg<}0|LHZhMoSy`Fdti ztNfdMJ(NxJ*B$xJr+`Bgpo+uGFz|wg7glNFFnTOJk9aslBaL(tMQaR9>UoTJpPMM^ zR7+=y`qffKQPaf2g<{CUNKCz)avLR*i_3%p zKG!}Og)UR{Xk3s(8edb6Do3U&`LQ@K6dL4J-j>Ot9zc;GLJo$~LCK8ADhVN-Q(`_c1h?Hql}hIlZVKO|cn4 zOL-2e6MhpvY(lnqHxn)8w?v_rKCPU67ukd^7Z;V|c!R_$&e-~YFfHSV4PnNpB&xJY zY-FmlGtN}0vol7u6HNQX>G53czZPUxBE@z$&Cm=7qC+!LuCre&7TSMBLXyh}Mx~M^ z8{9FzJ0Cq7YiQYm)m&#Cfi`eZp707*Idve(#m=8|B6n&7SCEroWl)eu2$G{LlG9}} z{~HPrpUj_Qr2!oiGm}b~Y$Xq8rwkPse8pq`l==Ng7%MPi}*ZW>c~ zL4!C@r>76!b{kh7wKCyHL|#T@T6q52U}!_gke5Qx{V2khYnaeI52-G%@>e z!uubLXC{_*5wj~$>$sTBCM)HG+haLlZh?rUxbEyEX>;y15KjnMWEP`#nbFVBIQ}$x zq=6KdrO%68&xT)LUaW;$v>n297N$rTdWRqlM@$-m*mJ&;e7v*R^S~mSh3t4n^2*j} zL-9l**{%2x9FwQ5kgb8?Ey9pZvF=1H1iXX* zOhN+`nQ%zULTJ;Nh>emaFUrC%sA)C2x`UbqF>0d89cQYk8t$z~r_xffuO^#$QZcv~ z50U!PJ{n^y%1EqIhytJd3`0lbF^ubgQxPR@W+}AwZE!*wFwuTJ?9mg;RgKfrLN_4D zMPzi(0j>UTL5nxS8tR94GUiO@w5e~+o{C{a$k4ukw8tS*IT5UL4K3`BStY%xyT*k` z<|fckjEk$L_Y;*e>SA^{>MLj7j|{`?2q&0;%I(-fHI){sIKQ1Bi%m|Yg=#7-R1>AK zy-Er&#b!-<5)FNWIcW%bgX)kUl@_pNg!Ef&7112yaxi+Xt|Fd`FR`BufGOPymPt(M zKP=BY;E0uHJ)sItFtSdNw$Qu~ei~sxO9iMFqUWLtW#vW$8jeBPetQX&jmlBD&I1Pz z?}5vg!=iPX21%BTHE$QTK_fQ2OThu{GWH&>dXkZszJmfC765SW@GGmd+v2sPTDTi_ z_~sp5d4_Kd;kJNz&aPIp!UXT+vaMkxTi^wpQ4C@ zRL0^5u?8USh$_Ms*4^qOOMr`fCX!*)Qfxm$Dszt$rod*>uR1 zy&Rkgnc%wa&%`eUmCKvn6_fZ)MPwK;Bx zvKa3h#mu{t(*NjubtP~%2!nV2mAV~D|D_?;2t-`dZX=EirGG0Q9Iq+;)y2MYj~_ku z2^tJQWeR!rz#|>P23P}TN31Q2>y=DUFR{fP6i;Ry0WLT5ptazSM2z+kV&SP<8U4~N zT*xC0UF4B(K^M{?a1IfdCBt+P`Twy_8>H+!+PTxNc#P=_pycnN!~QXaIt)tw?j82V z7Kp}B^0z8~g9}p(He41WI%dI@=pLXlRY{tXJ&71t7YVsm*%SnrGBGy3xN(By9L6ocOs>Iink{wF?CGm)fO8gGp<&#H< za%w_A%J%qL=P}CZS&9G1EgI!?-`|^Gtx`@@c?d4dW_5}lSz~rcP~xAwO>Lgod;!Hh zl=x8Gk0p7AWSd}zY$MNy*>RY|SJ#UZAj9Bb7>-a=Ob9h|jmlr3{Uy#JgAT;P_iqNB z+6RPx1D`6Xh%`Un)JY~l-+)q}P){N`1qRX*)?|~DNKQ#2IVEvbwpY0mcw#hXB$_M0 zy5kYn)l@7tuZ4dFzgT!96$0k7wM8MLMQHWVw?8%0qadkRrgUSbr}O1>{?~}p9nzVO zRR_K6ysMbCJRVol4q#g44AXzG^03NdOyI<{T@Ox7ld5|a2qnJom=aR%Mpn``$eDvF zvSPfkLx7aP#BHhK znFkhe?t=>xPncqAsB0oJhuC{inmUSFL%JRNVgpP?QVr0|3cZ ziDBW@6D&ApKslI>LD0~rVL3!A27OVV{k(@2vshx~E0$QXtP(2-Z6S{C;B$*F!DOMxZ4U3sY{?1dHz6rZ)yh_4d2W1T*z15xBMMk#E9rEESe*2 zbJ`kEeeD0R)VK2TGVMfDwsI~NqhJ{wQF8QQhi}5?5M6j{n80517NN5DQBO7L08u{w z1Suqzf)6r8=zCqn7)!F8C2_0+Fn*fJ$I{fIA80d$x|;fEc&usAF27V(QJe(U|LsH6 zGxjt&vlNH#B9DlLCHQtMw)+$p%*Wec0vH`NdzM<#OgZyTL}TTRTv;s5@7Tv;yAH>p z@uarthh!RAz)YF8lO<=KhqMHyCoHJxa0q)2JNJae1P!HxZ7Zpa>H;m#!kq8luKE(C zie$w0sTx@sIX9VEh{={0q7h=^?jYsKe^DcBA!=3UzXxOUUk{SgBQ}i~x=T*;DPJZz zJp`9J|4meA96v9(y?x(L2HWC)Q%j~G43UMa|l3BINI5Pa#( z4DVb)15Pi%Kr^<&F?k}TRbHyD&Yqx;CL2R{C96vsi9xLrTiN{IxvCkYR2=Nw&BkA| zZtht?E}i(j-CVXV*3C=df`I%hvG7hrM<)e{gu1Uz?m|4MGwOmxY;8o8Aq0!qq@y%V z=qe%A)7!R*XJ-C?7N?ztqLXe)KksiJW`Qwda z>kkRrW7eu1h3?P(J7HTrGxIYD+Xdr)q_BNfJYvtn_W1`obKKI|F=o@lVLH9=y)#cA zoVZeF9vxha**t6MN=k0_j4tF|O*!*l3fot)3^?~g=q0i6{t2qEJqbQl*dF-W&m(Lf zNAJcc@+67T-!E)8jc3C4f&X6E{%u00rA*j1LjlyI{eH62iTAg7=|jBZYo;~TpPtdR#P)zMQDYFVLLCVSo zFp?8Ayc7rgSp`I=P-=FIQQN4HyNZpYIz;g5;`&;ygI zV#Tk#8Nn9zHhED!3@$4{9L6og6uiWqF1DRAduODYxf?(`$j_;PurE3m_*+Ca`EV{1#gJF4vyK`^ znqCLK#A5({%JjAb5#L=ApW*+ro<6r@Ct^(66Mc*^zTsYF&CO7$hIG z;3PG6b4eqfxS>L%(9txoVY#n!(>!nwqkwcdvyI1g%af?IocRTuBm@_$M35yFS1LRA zwnydSN}*sJ1awph1awHTL*EZ7fq=dVNj8-uIC8!6M?}@A1Uo~ya^?#Fs#G!#3FJ&K z{GgKi^Y;R?gp+~~67nfN!Y{F2(Fg}eEsNQn>B4xs#q{-TDRVChLUR*6qD=~ih732u=NzCl6bcaQs{z1=a!B<(^efXfbZT1SR4cJn9IcZK zH(xgttacK9!D`n|g*gebaS=3Jg%D&1hMWf%brIlR!1-$OfUDxwt~uP&XAzq*;T5#^ zOgOIGRZV`57UTl71cLW^?1J5RfS0CsrNN#@S>b>pqVEg7e`zxS-4k97 zdWx-XQYfGl0U8Z~EBdHlSlyYF^|*PI$W6|jq0v&-tEg*OMzzJlHE<>`yiuj3fyxt< z1~lYI=c}n(!r07Wq;v_+On{X7%2^L11z*i*X}oeX;wREl)=hw_wAA`n;y66~prv`z zluDR7P|inuc}f>DqDSDSvIEjjQEqJfb)uue6+}BK9ZdpPk*E8pfmLckGxyxeY7H3P z)eJ9IMC!ed*x8`%s1$bO#Z#wX^2&P?@a*EH;;y}=NyJF}bE&X1UPgUNwmVU(a3;~5 zxZR1POUR+qDWw16toz?z>c|1tnn>mb_E@9pFbOI5BTASa0%N&rCpZ2Jt@+g*SyFD{ z5C)0Xbd^6})9v|7ykamAf;(;D&CD(gH6T^-=jx(49r=XMk2TUvFeSX1Gv@^HrH#~m zXs^EN0iWf4wSA0qI^mO!(><&DYWo;{wSA0qI_Z;+lRn`hM=kMHJu(45i;+Sv$|q>4 z172PD0M6Bt(xNLhlD!++AKrvsT_ViH;ocyXMv$Fss=^o@BFG-bgbH>EGfx1Z5S+8^ zhd}2z3=<5h1$#3}ugSNu{bssX{~a&2Smme7A=25k6?bs2z@Cm|4 z+?5bJe>Vb>*C%j6tKwEg8ScsV$nPDGn`XnfWncvC@lg-1O4~lJBM5iWITttq%Eiw~wm;5G{0#iR7hu|w zr7P=wakaZxx(QmCl@x@D2K!KWiV0U+qhbR>oPQ}q9%txS2i<>mQ#ENj;g_{VBXp5p zF!NelsMR+$AH?g9f7H`1wld~AZR(C;m4sj_*~fk7vz;`$hvf_VGQp5jv4AmuN`a9#hSx;w5G_zS|*I6kx_t58YptO zlf5Ih63K!64?%2)ZI5)6Tr7O|8nE<517*V(GcPCJI}rB9;6ip}F|95zSEu}A4V`}} zG>-x+FNx~>(dZ&$&~OF3OHdcShJGQM!0gO@4X|ku!uGg=XKxho&SYTZT-YF^85`H@ z?xyQ?huCR^*26fApq@oYIbfR;A+jv?zMR+lVJK;j6?@;Bdpktx5VDrDE=3s`XXa5X z=%G~FJ!qd`E?@>^xuxe&&tOv577@^h4Ao%s6>XVeAHC4bdAQCRKXuZ?gDn_lpx$sSH%x+~W0wg*s|-ad?0Ew< zPM6)Lt;!dFM47eeVHEX*EK;qYprd9ApNk-^1sq4hutf$th@0mEk+KR2<*fIv#_V1} zsu8iU@mHt|=fXUv<7+Nr^i10R{;UXXy7%3VJ}c=hWIx5iB41UnNFjB&@e=clh7Ro z1Hx#B1RF;vuAybdp*VwZQ0#jL7V3y$8I#(CnCS`q!Au0_yj9*gGcQ!sHAQgsg;-WI&Uo!*c z$ZwGhf1{L!m)Y-M@T&~GnpkyLBq`mI1P%8iJ~dnS=D^!=#8XJRL}5QENNqIdKEZmxDuEN#IH{Zle#zG?_n%WGMq;_8-}po zU*I=r$kO752cn5P$xH10Rnp(8{1%fz7nWNu7JhOUO_}a=h<@O|S6mMM`)YLu|6TkO z`0w(x4*pw*>UH726eMNMLw-`$BkcEK{00rTBl#!rV6T>J@=r@<){;&AY01v~&sq0# zsnk=9qG&lVof!2DVsRyZ93mTr8b~)Mj*6~~D zSCF5kdDP~8;D5~BYYd51<6M%)%jZ&&w}PNp_2y`yb_#tp7HZW(7f|RkTBw^Ack27m zvRAFsoFv$)^z#M#Im^}#?oaE!MDBkVxc{}p{jcfD{c$50mX5&v9S)WAuR?&v`RCu$ z6W1^9;QD`3xqbm(>WCIO+lSe&!0&MTP{#Rlfrzo4ZQ%UbjALzAIe+vH;#l9|HekrSo09hgS`w4!P!YgQ7ayOhHjoXEpS#@yc@5B;#agMpb35hCA`?Af3qhL4y?`sYt_b zq2CBrYgZ$r7Ym_ZEuVxOJP7T6f}gbj%B%AACyBG5k9FbK89%|i2v}k(9k`uZ=|lX6 zqZEZEQAFXE?~Eltl{F6jYXo&Ghl`l7@)_oUO;mDrRd*AWI84u$s;(Nw;%6a~jw*)V z2A2;SZbD#3EyMKa0N9z?^OnW{uLK+naD@7~9G{?J5Ps3^y6`a+===CT5e6@Hc|^fd zCl-D*mGS?L7}?pA9n#_^7k2<7k;Gty*#;t|IZMxOM%1$gL-%y*hDg7|ZX(tzWWu?^R{=8IaMx?LGg;a_fOW1U{EPCI zX>xku6yie#`0c{2a|n=iF8dvfU*$=t*JMK`oEo=Ig)`2r$9UNq0Nffb;O15w#Yjuw z)>s38Tko3OiCZ%bYgcY_f)w7 zSE^O9`y=AWRO0YK#*zKEBvvD=Fy`wwtCBa^&P#yf^P>9sBR)Yxxt1mjTY6x=PGG~y z-g8eg9rI+;c98H5AsU7dBu9gf_Ra-q3Rd1sk>fJZnSN+=T!v80Q6F>AYq1Pe2?x%w zPI9~}NVuu#UF5UDt{u)k;Qy2|!RuA9`C#+9kKm)+wK4^qe!IMAjSUxIi>3GQ^eYbW zGmf^o9x<@_10^RmrCw+QUfPNN4S;5OEhWe8t0Zp4cNl1J-Nt#pf=i6Th+_&zL~nt; zyUEcME8^ZY=*#dQ;$Bh_hD+n#9P&OM_hys#L3nYYI}L8?UbRG|Bn!jvoaQYf3JJQ~ z@L?n{Dh_F;{4R-m74p(cYATu#c}erEdK<_~@4ne2Z#}u2;Z{L3Wiz8+s+XoUc4kra z5^oA`(;`C=XGCE}A*?qF940jh8j<|rKgAK|l9vcb#gIeZlDKyPc^{2?iD`ys#=RBf zB~GTMEhjGyIH7OT?VNQcbs4ot_=^Wv znMdxKsymz9w=r7vrm?7-jTB@iFt(K>cVg&eHkl0-n~ZTHvvI;#=b;3!CgIdMriZ_P zTScrRWEhd(GaBokOwn~7if%e@rQydoO~`^FxBnKGV?Dswpy+YaQoVC)H^@^OBBL>& zJ#bjXQ`r4z#h`_&7w6g!7oLis7SLhy3NKH?l>)mITO256B!x`xLrK?bV;}Ms@f%6P zWFEw&!Iq4-%6CRCrj6;dV?mBgl6r5_kW*ulhs8zm>3d&sqB!- z^I@O)JYEZ8SmsMe?WJzibD-fy!FJ>iKqyxZ1`;(Nh7&^qK!~FW9J){p#FLFig*+tGM z3}T9PMh}aIs*+9KNUG|!$=*qzC7b-hRQgC#1-JvAW|3%<)F%C55_qNsdzx&sv}LQ2 zbEkq1L35nj4l?6gw_>TGv-jhr6R2o5RHkX1YcOyWc~}#+*5&}txwC;TMx>nkUPKVY zjedXtyA{6H+HB?~C8&&1bnd%EmyR^hWq1M_pXd*x$|g&ci0!hbA}ZTuSj-y%IS z1OKtpD$NF@^G@qi6r?UR6?WAZZ<^cW62hewlv!d6QI%SX=D=?G8*uv0qAaAM8Tbz! zTnQl|%}XYZ|C6mYiJ@h&ASJ~Smz-w1cHVQrGWadDp%oqhr+C`AusPhD@ezskzO7>5 z40r*|NAJea7mpqjYmHiI!q~%zYGVxc<6;}Q7_k5krF;cLQ4Bq#%CsW&AtgepmpNYIt6+Q zbh#d!rUY}vsXmZZTQB=H`0efJrM?s}0-kh7ZydeA^~>bQ1qu7-9x%9#WIh92?%VUg zi&BwfmXxd>XO9s|_kLg->B`>=J9h(nREf6Il@M-ZCYBXO0w{QAmtbV(NsjzJp_e{1 zvtGKDJ&-V($gN9vF{^HLw19Jwfvg_dtK)b9qt3))V2;9NW|bb^h3cj!dcf(xSckwe z^iR&fQr8nPC{aI?SzUhtDR!;WA%tlp@OyH0CxL%cr5d!6jy3LseLA-}Wn(VIgyq@C zI}azBOJ5}N4U;FoyWpM{!l9KKhmpIW&C~WolR!|T*CL+Z|U>Cv#GU|&5JzUp!eh2 zJ|-V39MBjLrcM{0t+2C;se{eCo~`E6KhV4dEJ?_|9mTQq`6ziW+^0-VvpS8L`{0d_ zt@WQFjvvJ>eM+5^np(|$_Le?HGZM-`m0+kmEQAN=cML{rp|(wE3RVieg<`SfG$mf!%kvbQkbr`DVHb*K zB&eckM#8;SVk2O+#74qHar#K(UU9y?(|(6~*yak0^eapOzxuaRKqzrQfUknPZb3fa zpp6zOr0l<@%a|tmGD}DCqNLIXOOwRZ-6jzGJ#6x@U+v4HQS^fo2gOQ6h_Y;?uo%1N zr8>pZr9fLKf=cx#l?A;zmxvJ1oRx?`-xUExh#|PT3j$2Bn5C)xu@(MK8)P8}i*J!o zqzv26hOm1*LZPLhFo-b4(48bogEqC>AP_>NAUw_&>4-I+A7c}@Dhb-u-h_BTeaj~E zYffoQz>Z%0i4%FJUSt!b5$nRlhQ$&jlXKB4c5n^lTyLqaJ~$)G0t;&(SdzE**ZFeNt;X82_Qanz;)ujEeZ!V3ndPy*QA$csDL(GWLt z%YvZ3YsW@SUwE1(;5Vztx8l|Q02o$vq-%Gp70e(n)kORIxo6$G5QzR8Q5jX$f_=0;2jE;Pa zuZgm~AniwQO4=QQxGj6Eb4-EGQH9jXGmJPK7sr;8)x%M|K$WkKzB3X znwH1r^^&>?2f)g(I1QVQQ$ZQgCN8-%DHu5oQ*+up5p-67l`(m!h+=N-cEr;-WRsMGZi4NbQt?ue_Onq@r5!9fpAzh0f_~ z=D5Lrv4&nl-C5Vga6Ss0k-rNt8HdtT;Gt+5R?x(-VYQYGD^|eH>+EnNlO0%n6VwLb zA+VJ8@Agk{?J2&0ZpH2H{2j2OR%eyRXOk#@2ZX~UM;{o2CPO%fA`{_HCO0W}+MbU_h_m%Wx9 zI}2z$&(aZ6f=tFBUv?op>_v)XyBW9JsTdV$j%zB6I09I@>{{|BIWDb8c3gx4(D@uE zW@2Xz;YhLf;cJ(f;7X08X)Xiq(S}f3s@x39HD1NqWwf(!apY!%rl5+d|NO|)&*{o-t`zp5C|n%uKs})4udwAedebh2 zKH*njJ^K--(YNvCjK07PU~t6j5#pY07~*ixwxtO7Y>wZj?%5vYs2`_{tmMnS5aGwG z4JEe`DIK?`9^*u@#-AwF{OT<*i@W3(6axUHr=Ir(_1Emx*He^eT#{I zFj`mNS#O=tw-|25eqh83eT#F9*zgZ%&YD(jD&1c8rt+@j{77~kG$+&BqH@IPb8f>)BUG7mt)%utUl>8Tq2eY7wcL6l< z1_^!dM^KMP*{)+(ma|;wPMo9^-T6z*E__lsV}sIdIzC%n^o?bXZf@~+4F0Om;Mw44 z&!GrHzq_w%TJHG>LVN_{r_&r|{dLdb{sW87krwgVPl@wF zsQ3%)-oNGO6%8R=EG)r{XqPxgUNrF&@#P|=U8uwntL45Ei zkj3(S1prZyV8=GW0O=cLG&VE1QAYu10+K?H;$i_?A~?p{?!)$AQ7=;Hu+gBFOPEsj zhzmp`g-3{N3+?y-Drns~7%L(LOCEG68a_0cREY>Z$s>|Rj|ZJ2B3D|}8JTqAcIm{; zol~(Cu21#LCmH+Y9@L+y$I%di0J`v$VbV=z5EmXBM84l=bYD+L-wQz8w`TiIn#l}A zItma2E9}e;gT(>wySVyZ1b0L|zyOjnW`9P^sH~N_`3q^ip!dK}%$SCZkf$C6GC*eg zk2Pa5gX?k>aA>`ldQxaJ6%c}zD=`=r-^E6+WF^~g;Wd66=1c{)ir=6_E9Q)e6JV^E zQ%m#^1_=9J9zZa=s1L}Kn)6sGm03g&AAy3&J zA0Dy(ES32hA|h5N_K`6Xr(q=Y_O?;a*~T+TtC46!4bLG{#Q^q9%bXx9&T*ZrbWU$B zM7=W({xky0OjeZGm=knr`UD-E5z@(ol!1)U)nZz52r2nNUu0u*rk~4le14-xhGzu& z252}FP#idm0p{>Yjpzq3ve(q7KM@_kK9Esw|I!;Q}QHVP7At%Vedyc<7Cj6%{ zEE&7Uz+4LV!kkD##&s<|SK%fXG9)n<^7)J9(}G{n&MIJ(#*+Ld?TpXZIyx0Q3hk^0 z91L{U?6LTp<8$IKMH4z&IZ3!zW`z3=kjdDp=)$Q;lA{mL5I;+}@0Fu}xQjoLMY_LX z<7LD9bqB*w4#5bB>#@=wAk`UcNOf*Si8k&qj@i>?D3J*#qfq9hfH&F4D3p2i+=i|@ zMxm)0yNpZ!F$!hc+xc(KRG_t*p5NJu!>m2PQU3|KnO|yEN}V2UY97fmmQepb1hby* z@INOG0NMozC68rF(Vl+#X$(2j4rSXAt1U&&k;cJIT6{IXj4W=vcdmS_B_PCXaTe6- z5hE05v@(XUI9s&ylc7Nf)#Tm;*x=3j$xFK!l1k`7BaWHH;Y;g>IQ2mVoO~KQo<2hL zG>Qvb$_gQ1ZmzfsWm-4>s-GzM8BWcKP3j;$n*d={qJ1LnPsA2A%a`IqK7$W|Pk;}N zgzmvHsh0|v+L`Ds%s}eh*ro6@c#Q#Hyd=cga0R|nVzhESjq;p)UuWdv_7S;eGM9eb z^kpQ&Zmeew`qZq)Uu)LkuhvTSO5*4tixe(M0SjaVwi$wL?G^wtU6}f7wfDb=_0`VE z6GF1q^W{F2ioGQMzKFjyxxdF>OgfA9PYf8IjCQop|J1$OLk09MjGw!${S_X69|}$d zd%xX)p&v8u;xQxe=Mvs%z9UzMN_eSh5$>+!@{ouww3Wc6xgIui?N~W-btSsM zVgX~ISujUiz=Ex#t%+NY1uQEu?pVp$iSyb(Z0T`8XiR*7(-v+@wl+c0Kf10&7nP3b zEkvc&Xf{Np4>$C+s3$Mv-b#N}dnp95$15s5v<=cJic0Um&{|w+qSEIXqjan7MKR0U z;_qAdTa#OjzZ}rSI9*iAe8L<-h)M$y(wunx5M-!%;$Rx5;pQ_)4-&y7i%CdlQ6X~Lbj0${8#P3ULD zhF?U-!~XM}bOm!rHVMZQoAF<^Q1HJa8Zkp}gcSM*1ph?YuuvdU>YZSqus#q7(&~Ak zk;kx55P7^U^Mv05ajga8#+6%`z}d3WEpk~cF6r?Qd74GppO6zSJ|NZfQgzPP#-i+P z)1LTmHV~|^D7#aaWqyJPId&&)iRWAki?UaoG2flSj`&WV^MaYVMlx(q?fui znGZl5WrLIU2?!bX2~U)e5B?s16Mb4(lLeU2ZNB(B7k|}#jqIV^TM(v6GzFJ8AeJP#)cZA+bns_9iLue zd2KHKxFyF&PJ?H{xD@IppHp4Lqmr#EJJv@)c6I$Ju5_b-*$wH)`{@! zxapq;#`w1t_JECk({v}T_MOtNx4?#f=B^(2+jIyZj!c)P{|FO;24uax1{pr58GqB8 z__OmJd?q$C|93V~%7)mRw=!u9{``ia`HOS?SU6q5c#f;AdM2Kr+V3j+ZdNacRC(Iz za%|L-!G@EavCHb5(rBpoJU&EZhD(gH?`D32yz5t^Z*eQj=<1LF)gJ5Gpx{UE7yyp@ z23!i2qTu?)sk+-y^c#@L`ei?>C|^Zczv^cd{WXg|_p^$g%A%y<_IJ}35ajwl|BRx( z->rZAXB6|FA_wBd=3Fu-SB|!t69aCmTDlonOo4p{K|&@N*2L|Yv-?bt$@!YN(u~SW zc+Frg6f}(8QdZ(ZGnk#|p9!)h(T$K>BMpwReqBj1)>%Ab6|5PCbB5oO5?$*!nwbIh8c5J=RjAeIi5^+P21{1I#g@se;T{GlWW>`zAezaRa*Q3 z<#Ewa2@jX$g|@(<0eF0eankz50<^1ni>qv#6#63~p+H0EWX&BHx-Yrx0W-NQn@j+Xv!!Kig8=Iy% zXX?8lM(M_xv+u=Hu2)zdV>I614KL!5PunP0J8~`8wLs^JG<2STi2r!ex$rpA`Eq_+ zbV7bE3FVLLJU+IZSO)fd9(Xgg0>}{~^>`f2{I#a9Wo_CDP|FoyyR<|&y$Cj91y~1x zJy`m=YsPbMwjp?SC4;e-SvNk1+>cLl5qL?2^+n)S5uP1)1$X^uE(C@>85s6$g#-U< z>p>OQgUvAKo;3h^Ld1JC6n{F(F*}z9D40>RtlAL?75R~-+Y)kF*!(|S7M7B`bLnnB z$AcF8&s`V}k~>3f;$|KWlL~Ik2(VoMk3c z&e3)P9yZfztwsjddX1O?*+`}}A_FL^(DMuINi7m)Wr=&t>hiFR7%M|=;s!IAmAJ|b zW+%pF0BuPOC0v6;n0c`w4IDa;Z<~v4f26R7tNBfGb)_%$-*k@1rv0FD&G4NK0T+ED zr1>gP$kkhl(S=GU6mvMG*4oiIYnDPpQ5tt*mEfsZ9RrDqk*;={lVa^Y!a7dHp~Qxa zto@YMto`?QH#H}DdMNKd%S5LGiA+rN3p5&1YB15qP$8M9Z)}o@-pwF5BRQxSVUvU2 zDZ)Aj^^5TA_)_xA#kpi$|EoOHle<>mKv&I-84R;Ts$5sZieqEQD`Rt@Een&dxkYOY zHu-sqP5RejkzCuJeKVbw7!1@q1+9c<*o58Ha z5Hpya=$n!Ab2+Tyw%EogJC(U#$f>$sK-&!OmY1&AvknjfF&Yqh^i^A}*qi-TYHkd=epY5O2D#!`Yu3Yu$Zcnfc9F)SvEH?DqI zr=LhJK(FD!_4#+hdFL8X4kRnvROtUomBS}_KwGg(p9~%{IFTF~J|4oPYbL=Oz+3B# zjfGDCp|pekH4|V8K&`Qv@tEg?teD&^m(|QV!!>P-E9$R>A;6?FVL)&_O8sbB0!%ue zn&Y)%!w*{a){YF!?E^c2)8VWxYkrTB)s8-}0%-mxli)v8Pxb8%Zfpu3h7rIj$#1tJv{QT;n4oCG`0WdmL|3TOWUFSk6Qwv{a9?tax0+{-qLDsr@nc4tI;0aNavld#@98BZ=S}rKcv3x{9cm! zUWpFU=BK`gGX1vHcQL=OO?~&^_c(mJYeFTw_r`x_UAzw02Bq>YMG~_$;FsC7?y0o> z{LV{#V_#{}>XFO9yN=)gN`3F(_Xqf9=hX6JODb_QzsV?!!f}2-oBFQc_oMnZWcU8g z?ixqQP#kM5S`e{r1z+0TW`0LWZ|#=UN3nKY>f0F5vmk{RB9zdS{TnYn<1 zcO^OLGEcbcy{#u)`1hQTX)sgZf`^Nw(6g9Y!NV|Qqk|Z(*>r zuxgFd`3;sRhZnlt-W6@F+1#{d^J4v)w<3cn+of2);D~PX%ylte$1FHxm&>ZTe!-T_ zyMpW20IXlX#rkz5xqfvfhhBlh9PzBq$p^W3R|MwfV+}hE7bRKqyUWdQS3B})%T}FC z^X+ZDg5@WYR%~Jg)2-OV3Z`4JRiU*oFryWlSi#n(RxsU)ZKcSNTETQHHnD=OpPF33 z)*CC>dSeCCP1t?|$odMVo3LGBn6O=Hn6QnJbrZIW4HLEt4HLHW3=_7atzhTFREmvG zw_o%9Jo~jfTG_9C@R3--`jR;1*SYwZWbY2HDTzk-EM8AZntJE zVoQ;rcE&RQ(gcoa+R0Stq`vt{{8u?C!n9Ud;$=JyIVTruyg zV8b|EuY92+@Jomapd)b44(JH{aAQg;GPfO4k@sH|Qjw#ZQ^h;*PP0<{U5CFl zxzFG)2{dtOCUdH5W*9mGDSIj$2kt=`{LImRd;-q31{|RzPzMfdCD!Wmvou*U=!OZ`=rc|H3fZEERW|SC~?* zF=E5qCe`GAoNG8Bt;olyVlnu?v8A%=O`}PZpon>*bHA*lEtTo-uo=Xa^mkY%g)TMn z(6Y+Rv$Iv6GmSj7voiC%+A>f0pJ=$@(n`35S_y9m@83z`|6)Qap@mD(q>xtQ6(qcX%YGyP9CJ{vG{%V^b!qC0c{yQ1^ z0il}QSF+QarhSOzuO|18h)lIk+rS0$n_mm|2VS=bsrU)$KMU|vlY2A%V*K!|4(e=q zzQi+=#cn)7q8vz?S)*T^Ma!F?5kr_KgBum!hw0ihG;jEJP;+Q;wvE7?X>g?@c^ zhzcB4bd!m9EV-+o(y+AnPpF8J=f=U5Jl7z2b~A&)FNNg!U4%`^^Fa~TCC`UNmkkStK7?=6I1ql{Qcs)#gsiCe;I!dIZy@d41E^qGbcxT4E2NYG_+(qPaswoJ@e75 zw&kpe8|g-_)%;70HzM*9qm58*Vz?2?f}0Gz((FX!93T?HEyIaSn=ujm2JE`OPI3?#PdOZu(A;o8r_@kpm6V z+}AY+kffW)(KumW6s&nI*leFQ%vG@f+?xNpq^BBY^=*x|6ut_@GNC@QI;Rx67t6V? zEMM?fU>DfkRFXy44I)meT<{m74Do17opyR{ZPi)s=65i7?y?#Tfh;}#h6dGsj6NQ8 z3xHt3v6KFGlls=HFgEZ~DJ${4D1JCCH?X0PIuR@ z#8s^N@KvBZEZ;-8`-sR$Rb}v)$_}2&)M$ zOo-RuYkA2^WUc%!IAejR5yi`JJ6m7A(c6tS!oTHaTZt?vou56*cos!E?0F zfl39x0W>W?zC?cAK`#vj`k>-a+;`USUj8D0v7vKWEOFZKv-~}b2xPG&IvF3pTr{3G zA;mtHaRCFyiY)v6K+A=cAk~y|TDO zm~Kh0JYFJQ-c?fru9FgW1gi3}Udd|$TX3bRIQLi7y#-h3<++VV2H=ta z{x6%GBSkR)fC}T6gjy+!@ci#35mnA6ITd-gK-ke85KNOwI-(fz0sKPwRBLAmAu{5h*> z0DL3%yw8FY+4QU7goY9++;8UoI*;IUHvp#EbCS;B1|2Vh%UKBq2m4ol&g!g0_UdeS zOC;FxZXW}xz$dW#OMz-ZZNkcfdrG+5mNhOI~G_?_8N z;CCP7H|o60+KJx{PaXxo#{ji8ewGi3UjQj4ez_X)Llc_-r9KKQicp!tHjz9xT`Tq2!+@Gs&**-=8 z2)n4(^FesW4}J~vHW<<@;%%8X`YJERxSZvB`t45?AU+=v2)kpWb6~e`$CQ>9ZNcc^ z{nbThVFKd>cRzi{(*srszJm?<(xNOx@Rl$FdNg1Is1)L&f}P30A|n!esDW7p?qGGc zrlFqntS=|CHdkwWnk_x?IU}*ajl>s3;;U=`URjhvPazSR*%B`l>-)hGV!SDm=dMyO zc1J}vueI8Z4P%v>9~qtHEvv@5ld6FD;mW*PyMl4Lr>RcNb zdR0GyWz@k4j;H2gUzuB}aw~CnmDU3Yz*A;t0|y7HhDnt-`iMZh>f3xdGBev7eUhJY zWRx{AsN7i>$@A(%V=wpbk|TFyd879;gQMKJ+ZmCOUlfOT(>>0}CDvrM{gJ>9a7GGH zLJ!F(EP4fSvVjF-BcrW}enwt7f>@Ekj*5&7KogaSSUBgkVyJQwvOD_7mFNaf*@0O@ z-2FblbyIXbp{ZG0@<>EXZ1KEpk4CuXor(^@T$!>Nw)FZqh~Xm77e2lYsMlko0S9he zZ`TV0`u>d2yE5PBYH9EfSLo_@hO~ zDI3K~VT98$*~vE1+t>kh2TBS^e?wf${9;BJMEoje2Z;CrgNWf@opVW#C7FYaxYVY_ z36lL0D*F%{Z_1ZFg`N=~Ir_L7;EL@?4ZiLKXyycY>M?0`OuF zV>3qD+ixozQvaCfgfsyyHtt8S^?vI2!Z4f%f>p)76KTOHKHyCK;0};%BFCY4Q-s^s z6?5*fmk*R9gK)*L+fkn9jEu~}O~Wo{c@Jmg>TG!4t;4T1(F??gP&U(K7MPjE66JYv zWMnp>I79)^&Uybsq8_c%T*>o*DjAVQ zi1e1dO8!5mv*F7DcXIW(=mR&1BP+Mj*Vm84TiK-*Bk`?_oT`kx0hB)jm~lxloUH>T z#)v$rIf;GXBb@hZSQLI>i2x=JoJiw#%$T@Z_UfE=SogC9OM3AJE*zh?4shTm{??TyGA8cIMtZ4^=ndf+g-n}g7Se(n49NOE z6=H}t|M7CP7-26IeK-kuY08}3^b3=6UlF4kkfhPT%$xO`{xMsCU0kvPDYVxM-H3?5 z-F(LVS1d2Ry0}E_Bk(lAB_eNzUhK`9(TfA|+ol&a(TOL4cyMG`rGDxL3BVmGJ5g3X z)%$d#TX_q;Dc;K1M~RN)c~6~o339RzuR~e(pXj@LKh$0mc;NUZaNh1a*;DqFud7@6 z(2b$vT=n!jEQPsM6coTd5JvVsCxd+RJ4ocs}u}BP2W)k^36S zPe$z|GB5NPsq9gMurhC@x*i8N_?!imp@aOmZvKoNq#X8^VHNr}N$p#Z8aisX>Oe;# z4=B;UN_0~>U?5_Zr(Xl&R(hGcM%@`e+ekVR$Xl1`bOq8N^2gwOYaZGKxR0-ZzG%<&Q`49ra?GvIFZe`#@-7 z@`B1ZtKG_{knniR{)P79A$#|1lHRRIn5{pA|=K(E!kUZ9}7+iro91~*7U*bfwtPm{DnyW_+vS?87ZJyhiZ0Y{H zus~_ofUgJ3a(pN0#6s?5qN+_qn#ehhIS1iOSFr$NM9(e$BbrybQ+pggbKw~lvBzK`8yzNV>tRZ(joY(FW-IeQ?GSjq5un$x8L75xpCrK$P=G8c4LmW z>=`@8e>SvJvV1)~%0Ycgv2C!fvh$HGm0cVV`7#y{h_yH%I?I>PyQLh!11h1@8LD5% zox5EM+wenoQpkAks4-;`}ss8Q9fMdg1)M5^+K@O8YE|3=Tt-XhtA9!XZ-j2l$ZK5bO%>ZpI3 zs;;CR)p3p)%@WlW8P(x%k*w}L(RL`e);g4L z#mxOT^i2)KihV<%1XiW?h-5pIue^F!R()lYtG>bEWIXoPOIX?&xe3Qa0SG&FYhp0= zy0!MmAQQOs%B|ZRk>BD}DaHctPi>EkM+xH#4^KtxIK7H-FZSW|x{&lIN7zb+P!m8g z1SlxCL{Glcn&_L%JJ20{MbB{?(b98Fz)?Yzi;T1y1L0M^&|bxiMgn;sR@+%8ah1i6 zlRQ!#j;nZ3KGRILI5 z$60R2yD$yV;+>Cqh|oYO)Je3l;e07HQ1G^f5-H3hn$d;0o8emuCL!oP3PH*GxB<2c zY8|qm90z{%A-oGicnb7$fWTq7I;RAEV;1liBu;P#-@qAsMkAiaj@WSwx1TRp+XrW9 zBhdiB7;N$50{FN<6`7y_0Ha=QKR?T>+)>O%hxdVnX#A6^TnfD^dh34-`ys;SA7=

3*{_%b>M10|?r ztKR*fcJPO)9A9@4yUH9CpTyxz3=y#p>anTeK0%B#a~Mz)9drU{M1H-E=|g>mpfwCN zop_051(ZmtAN1!+H;IKo8%KX=9GQ6y}SY1_g*71`#M2JXt?d(k&idHp;<6 zP}%Hhq+X||qEGamo*`o0daT~lcVl8Xop{n{0BGRHzZapun?)bNuBs%fP>xJ0$!5@6 z%wUdDed1*1Dbxo?kYw86WFSB?S)d6-it!8+ZcOzN&=!$`(gz`N7qX==8zgdHMbzZg z`q=4sIU^1eF9vhQL>&FCZe>$qs3_43C5{*+3Yj5`#j=YTv@$QbMKj#1vlTin8Hb-b zHfiJYeQOf;*;@?%|1G+{D^jQ?#v1JrbBj_IAc}d|Gi@#IVp0}N=EyA*Ct>+sJd=`AKTF8^-X-7XNlK|JdH#mtggW*jock!H7BOo7 z5r&j{shI807*guJzAktg7$?*^U3Hr#CqnX^_6^*))EnE{SM;!BK+A3IPFPT;WlY}_ z##<&~?kBg4Pb0}_M6u6~y%B-)Nze$kTVlV@O`9B#Pj?%4am>pdA8r<` z+K_sjTl6A&oS$1QW-*G0ZJ-X`+y#zZ{*al5{XCJ!j_ShQM8`o4_a@0rdR|w%W13R|23{rkWCt{ zbMa}8i#8KdgcgKGrDAOx1Pm=!&JAKbj01A`AA)hG_D zVp4oWdk5@+(hlqbUq6Awjru2esR9{+Fsp_{i{Ly~jEq=Jyo!hb09|xH$sJun5j9YVi3;8pOE>%@2@kY&4HBKH=!9YY4m%=t&tbRn3VX|4 zvruJI@DDxB-1uog3l8sk3oO^) z59+Q&p?(8i4Rc4I5NPy!f^s0uNtB{b)H3`_{DHRyq0o`%JD~!&ahnDh`5wtp2V2W^ z$bk*u8@0H--V6s2a7GuKTmhTMbuJ~R1ozx=Pt5ymgVmvT)>z6VYrJj$dJn;^Og6zOCySQUr3*BYQ zha#gCqG5G#-g_3`Z@kg49Z`v{;uGiJuwYx(upOwcg`h@%O&$&C;Euk`(k|tDywv0_ z+b;z-Az7+Cv23fa6Rb_#Wjkhmhfi0(&)f$;@mTkiZH@Zh0yTV+up$6e3Am*fy%?Og z&f@PvMNUxd4o*_DbNwKZdTjdZ!{kT#{@c(tB80c$pj^xmDBbQ>L@V&a?sqF;F&N5n z_5mW<95Ij5b+R!&jCc3@#MSSk;JmjizG#gzju?wJ1Cv9l?5=UHCHL2_bAPRV3wGvK z-oTxn5MsIdeJ@A#l=sN!KyJQXKv1XG{hof`dzF`Ua(tQOXf#V33dri8&gG5QzYGAN zO*R9Slx|lS0hpjv@XBE!%LRWm+h%1<4 z9pS)FwA(oR4R4=68je}Z5X3}p5Y4%DKa{6&k)cA38cYDw9;h{|qtG34bG6s{qqFRX zx!+)p;x6vi{kVp}JfBx5Dl`?n(&YWP`?j~1|GR3&^hT?jYsL%)P#srhGx3!TdrSaQZY@ytNz*n*@&Mg+d%W|nIB-tL% zrL$eBiz9Ep)WwrmCv};WS1Wb7CNB|J29&gY%%8LYHC{Y_8!~Q#P(=kAbM6P>j`Nzq%X< zAWvr(-)t0=!d$NCPY|2qQG(5T}l zpnfNifPSbW{v@Eaj|l=A*OGuHgD7iq-$X99D>!1Ao{O)4L`SSfbWQGG@R$G8t2kaH z6c9*%x8g+h8=0MFF0hmanTGwr_zbhpl@02`bHELDnM6hc8~m^!Fq^x^DWE0`{wGQ7 z;O7R3J%jNUB+o7M(L8T}PjPb*1hUalLouZ; ztr;~GA7EwOdOw1#Q*0zOr*nHU7;Nl1%i26@s7v`Af7JzjnwrT|(N-2nwVYqcmg|{~ zJgPTS8Qnh@8M1)Ese^D!due%+eh~RFIAZg|?C{Pqd^L%RHO}f*9qf)xDnSq5inVVO z_I23MeE{{KBoVdh;crqKqkp#C7=0r)M#m{5%lSu~eL41o$=6q6L0xaa=o>xq?R`XH5f;)&}5Frk< zf=(Y;&Ti`#wQ{`0#(}P!b^9=V)@_0M6*diCY#N^CdL<^|$H`86FY0}-9b|dzUBkc6 zVy6*aE3yUx%tDIQ8_w?|GS8ilI#0^IAuZK1<*uS z?B)N=@_T+Rm>j;EEglNXMJ+cm_u}9uli=7vMf$fsh=0J%As}{L{e&)Lb0yaB^@@i`|7tm-QoO+0#s(yIXFmfpQFN zx0|!)uEi1IsRwaHh~tQ`1cBg)NATA&zXVfRxQP5xr4(Oo-sGCr&5tCHb+@DJ+*t_C z-QAq~l~IsbGlP%1!3;X zG^T{yPq-gZZ$AysC~XYyltN^kHQ_ppYHv}q*H#nWi!Uxnp4jqY0rC>~nVMKzA7%wO z|I*V*eb|bRfE40{! zM?_@SZDi2{IPX5X3OVsJ9_+%SDEsjxAKVZ?niLw+qT4adY2EIM#n|mGMTT0xyEYnT z-zviR7A83G2P#kvC^G7|5he2s-IYAuiXdpr$OO=E`~mzY6v<2?PoJ4aJH7E7*|Z^FgQ0}LwiRQ!JfvdqAM z@J_E2CIQ24<*Iye#dJZa0S{PJcMfOQ>j)`W53}H zW{55zRGxOt8eGbi`4!C4s+#%*;+DyO6S<;q8Z1hDoupS6@X{Xl7AutSz6VIrr_=R`UM=K9Dj=%7AI?%pw}RH@Uh#(EUjwrMAux&*p_V>Alzlh(!CwN z$Dc7a@wZs~9Vq_V@x0UrW6XhcD^il5(8kYJF9rg(NssD1yaH9gTZtHq7r;*gcfpx) z$NB{%m296?UY%9HfWrG6DO?Q26i@U4ipgEk7s>AG1y9VE!t0R3eeh$9SU#dX)>@DC z1CR9q8#!ZCp_PAtVm*p(&^> z!yN3BLV})m+lPd{Kj2cVj=4bBysvJ+`k^lkSm0t@_vPTOEa{a8xFQC3H_4s0MMT&e z?TSmu2e`(0qqx;FmPMn7Jo+NYQN3312w$nJTm}AcRXTs@499d{Wde2w4{$=aF}T6K zHHHBk2+QC{va&-R2p=1*Wn*)~9gY)7ev zT7;maTjMV9~Vq=4+G{8 ztJ=02sg_FS(P5s|7N)!Gz}yo#doj#zE1b>mmlpS@R?PP38gZZYhm+7Y-kQxcs1upV z0Rn#{bHKJqOkB*t21MdVFbU;RG5{#}a(h4>4Dbp9iaroWyQoU>TcJvEK?N>>4Es`GM@nn6bTG$JhiDB`O&X#i z#j|*1u2t?z<}vI{)sOHlOsjM-#yTK}vk$NK>oHC8iHGDk2z+}W=rK&)pgxDrmruOW#1NpLG#U=H|{(uBSvrK3S*)xXLzE02qvIpcAl{jZz@4d$T1h zIE!InfPjiZk8^q`HMd$~Q@-i=$+|(Ape_usk69auCDt0Ryyk+nEE^z5px|EL$ z97=b3q5@_GO2XVoK*i%a1nG$ic!{e#(IC43L+h0s)dEd#zun%lIIaeM~9ygG}az=Ci;}x2A=4nBr>=4U9c7Qtk=3tr^dsGpghS{vp{7hiSE&tE#-j* z#E^~)4La8PLRZJ^^$IE3>*<6h_Tw4o?HoYX?U|28Z_Lq(LQ?E%4O7$U?Uzrtr8nj= z>Fp+%%(aGQZgQk0F7R~CgFkw9a=D>x3qZOD!$UeVI2Be2t)M|GFZ(hnJRTZPYcCV1 zi&KYOfjJIEiM#XV==mNna`p4aIpE^h$IA_zIC_wlf*W%5MMW+T2=6_C2)Crrj}8pR zuN;XmR@;x)n=>qO^mS%zG^sw>zD16xPmsbEptom0YsxE*Mhv--;&`{_*Fd9y>|FdwdC^OCkGyvaMSjo#Kc&B6r&C3ck+W zLbgM4RLOxThcMq65e2nkpp{|lB9J8;ExrXL*!~umN#WP<#`oH?pK9?9k7a1_RR&7s z3;F=r$b!E3s~@0qTv7d8OgDh13-#@e)go7~M0b2z{l@26i4J-^bX7Oxu)nmvKqy07 zAIF+xv^7BG;&vT~NT(BVvfYoiPW-91-t}mPwjPyEh2t!pPP0L$gE-ES2xGO&QC)_X zY=`!!(UMo7H{Jf0Og)!s)wjx7IrW$k#%tXoZpg1H(;yA72 zguA{3r}aD>a}65A`MvIQ7j42$#NTXxk^Y3JC1C(kF}Z!a9l4H;8gsOQleU~PHGMh#>WQ|?Df5`i=_$9g zT~74_5Y7^7*uUw}9?t-cc}!?;-Fz%)?9_B<<1#>F9uwO9V?i?ktzo|!`~D-3w`r_^ zRmnX1zQ1ocew$l57*rvKff;Q0}Jv=BTm6cImLc>Es_Ja-U+XWxJ}Cs;%1ycYbl z*%UiR@iwFu($GAiJ4 zwSjBLLVOFCTcumP(Rq+Y`#0MML7wsQ3~V3V(I>AY&D1ZVjLeSM zI~XfDYhjwXh}$QRGOITZDJyB9fVe4K~_lcMdiU_I0drt^^!QqCi(!b|^Ql z^h}FAhl(Jmng3f@H)l(W7s1Zip=^as6U04Gro1%P)&BiRX@2PaI5JKjDRmFM&qwqS zcW-D@fI}CIXM4&v%zPhumlNGpbyj!Twppi*i!RG$38eP$D9hewPB@@N+RVN1(8=b3 z_8F_*^aEHVT+C>Vkb9xchtcLax3ghvGuz`RFJ}uOwa%7n;lT%%5FYqwGdrPU>2{be zK^^q|igCMtEl`XML|`Y48izte2eAMHbgY&Jgs@tw>JvK-a-Qn^zS=GA>eZ z<<}f+x>yR$#$l=avI$Tkm%{YK?}?5ocEc7>3UUo7A3I)-Yys9b$lY`5tFnB3Xl6AW z&c`AQ^!Jqc1OC%MP=Q_FlAfUG7T^#?#*SzDiHSZeG*tM}WoSTRYW=8*Hh(_!PnEIb z69xKjHR6~ol~0a@wgVsEFEw7)xuWxyQoHstJN|d6-{FSF75rUqixgf3T#=dR!jLr= zMG`}SEt>*3=Q^U3D{xf@E%!sVIVa9m%5uF(;Zcu=<8sA0GRI^{LS*8f~MsAacwnksjFs`o$Xe~0Y$Sv zf1Ae^j4j6YY4&xF@=C}L2F}&IwGScCI&La zh{f@4?7+n7t@4UkkvE6=h&u$5xR%7#ECv{F53PXYgggsBWG-XM9S>N?;7!H{vPa>4 zst2;b6mCF#b$BZN;wb^;iK`K)A9Y!lzfB{me@tNpg1mxg`!|0MyY0)MSGa1?Y z`G+q-d&k#rz^&F*h^*fL9|AE1&?CKh=3%?F03sa726HL6@fCxNhm8=42;2isVF;Hx zj>u)>MgH*wfLr*A^=UiCqk?SRt}BS&Nd%&cK$ zT|a7q&38UX4vrScYmI0Q0!BB>-yKQ$2{?>E80r+8bN-G#9yJlMa2*lHje;M$57A*Z zDa?X%dLwjfOx3dmrlc$>B(Vn0BPpCC zO3qta{s>P?F1V@$%|({eveTu!yb?d^H<(D&N1{dtIhI_(QIps7$KSx~%$e7t-7)P## zj&meHbt?+%!)x+0_h6D685-a{|3$RlsZ`-I;B&xq!mCa&z7FN=v&OjBWEI1u4*vH_ zPgTvrF%%w|2`gg2npNUes(!LA!3Om1P*-5)L-GO#_5x|b2@LBag>uCxEN92NYDS9r zA-X$p0z`%)c3Rw}jO>l|!6O(3tlP(6RI`1(S`Yv>yv;czRrT9n;BBv-$bx&UY;;;H zVtVZCW?joB_N`01zONbSqhIgkacq9$BqXQN-qAKzIF=0c-s$V)RbFKnTdI7VkWvqQ!3pXNQg_WL zG!d{TcM})AEnrhNr^B|i3pP}U1<)21vLWjIH@9uU+dxCF#-HH4m7HL4Sz7)E;}hreON4r%jQ=e&kG}5_*^Ir4aNBNcXQ)S1u_Fs1@niu`#&b&^!dIDgGDBK0qSZo=X?7) zi-})|UeU6V8ho9#jq__p4}h~6o!}_X=Jry*PKH;VK7M$`_byGWmn+@_&e|A&z)WRF zPJ;r>JnSv?-MT(uu|epqO%nAd*EGQ)-a5l-(HcZ!b)TcKt1=JTV2HR-d@Lr8*r~aN zJ4r~{;T}+Z=U3wJpGq>h7z6C+c@v5`cds7>Pq!y}UmeZ`R{Z__zi z3+|EHB!7ln=8kO(!rCF+5*&>!Vyn?x`xYa}9k2nI8{M41wDJ3d!f>jq3>XHpOHBZp zoetI+2KO1q&oK1fG)86!Hfk;SlYxy`Pt46%iwuT7pE&zMmk+9T@c&vG_rj?mCm}uf zk&8R=d;)LsJ!RXa`zW};z9rzBA_u&e<;dleCt?fdztjz1jT|p`^Hxt;t#sd?5XR&f z6l}83vbok+aJz#TKI8J;%$))yv7wLy>%=n%+1N_R!wUQz0$a1-V`Cz91-^v3!qjtx zxdjow#@!v!Wi`ZdzbEsqo5sm1G0<(#52Hmn1US%76N_X(~+jdE;@Sj{E z+y_5$N8vaLa?5wWwM(zO4Owfk52Erz9l;ZWhl+d!_>1k0#>~xI=;;{i-o5WZteKC_ zm<2!J1@am$4ALv#xq?liaFZz9Bnmg7@N-CZRcZMEaPJPI#|;28*L&d?lwB=)^r{v; zI<{qx&b;nuz4`g^_vQ)x*_&{-1uE0l;*Y#G4sBlz;z1*r_&Yj?=$V*_K@Xq}$ARLc z{{V`&_tR1AL=z=gi z5X;1QSc7L(@MyW-IROXV--{sJS%pUhFV1Idi&H*g23fnC`)c zI_;0VQKy|+H7{;vg7RW5emu&8RrmpX?9!)_B%`Bkct!XJEXA|2*KO$HKU=QAi4c(R zFgc`1@|r=SoU;}Zn7SJ04t^$np+D(|OxXP~)4-OQ_&KuN7qLPk?hS_VDsdzWe;twR z>B@q&h^k%?$6wfS;@lQTTm?ROZhMgdh<&jXY)03()YnhuQK7~OC!%3WBIW2fTd?YI z@KE8LnQ&40&s9G{x0JT1tJMQT=*plwo^RL2qj5&;@WIJg9t4o#fJ^G{jVlG>H64B% zpQjqh{G5*DPHEqf0_{iCj-8g+X148aJPV`D>kY&8^g(cx+k2rgSfpKNvqe&+{T!I1 zuV%~S*RcJCzr+RXA)I6tw!CHUc$5=7$`o|{6m~u2L>BdLJJS6!_ zAUW{E{X*yHf7rUhI)+UW{fzVuYSN9qEHiDzeF-fnfZ5zVNr`6>MUF zFZ}=m!+`Q8s?1S`>2`my* z25X`4014-aJmTrzo767c*nj~DEjHanq~IQFdAO4Ul{^&UGPJUz7T2=$^QRC)xGDko$qwZXd2gAJ2>rvw{E`?>`ir~7Q8wtT&| z2au1=Pa$A*f;I;!*t|($idaPERW{$?l6`VL8j<6(t;+Hj7UC+AIFDt$44I&^Oep6g z1v$S&2g!KQa)a+v%;>&;+#AfrLOJUl_(c;-pt2bPB5zrhbYDJ7z(+$5Id~Y$pnI*k z4B}k*@yw6qVK(1mg;2u1q2#hAz4Et-pV`M}vwMB{0?B+jCUBIDUuE;3$cTwxFo!T` ziCiNZ+)70Ix>4PKJd!M{jTYTa0-)(rs_R`fqs3wK=-m&+9$>;jeVU>2NhOd8+WhBn z+#$A!+x#V>BLiD)&`XB+nf-@M^kf7XA$yX_UB|4K169o7nqU{Ow0A^RC|ej1qi7}y zaDQha7v#_)ft&E9f@9(#%&8PMOp2v z&KS-DGj{e@fnj}p*P%Vwdqd7ycd!K>Bx*MBGJ_-%XBuPQS>SJw5M0W!WmzI_Rkp96 zb|bcta)nrHJ77(7m2LAqjym#1KAn06*u*yBW9^_mLv&-c`qAUF{JP!xS!lNyvE)eV zSpwt6XKjJaSqSMCeLZYtn*q~(G1299oaua`goGAYFD5(=liY+r38D@UWKb;aEWdVq ziQTPS?vm>_+I)DSZ1e=kXx#?YATrxG4&BBL(?#4b{SxEi8w@7~zVm{I`uO?=51r>b z+gtwO%55 z^u&NedAbhWCpkZImVN_Ja^wveOe6a9osdGdH4%)Loin~;t zY1Oq*zlPZ3BX{#6?nCkN3ir#0f!joz0ZqFOD+NFT@pP0EryZ+evjfY}B;2?Uj!ig- zi-g(z+3mg9#b*T%_4nll50&|I+4m7Pt=D zX@51#36m$hVWYp3Gw2(VnOu&N&15j||NoYjKu+?eCE|6KXh+zBNF; z_Ykrtx`5$zq@R{5c7EBGnH%kcnzaOa8qO)Pl|~*ruQ8rNK>m9cGHEd+>XpmEAF-iG%Lp!A~X%bcxhXDgU zco`hDT{|9ly_Cfsx$ocHonDMA&JZrWx-##}M8^@?hfE^NHe^XWZ-D%TiDE-X|4Cdl zTroTnBRM`Gx^VQptU8gLT%n!*A~e?z=I|ygJFXp%fx}c3gM-%l^TPH1lM|!N5yoyP z-3-AUoZs7mO(tfO{|t9@whOLsIFK&u2Z6G_x=TIy!Eu#+Jab>GqJmP=D4dVN=|d6t zWglMw#{&)&$iBq*XuKhCl;4E=$|L7WAsfCB>L-OuLFrl+KGP6C3bw|`oWi+L_Su{w zGn@7$x+N6Xck!~geT8nO7dNWHwaO}2Oz3UlrgF8b-`g(bB<%ev@22P;7vg|iBriZ z>d`toFtMn^sDcFMP;AUaNd9>l<8B^Tto;T7aoQct({B3En*80gH|G0gmtBr+pF8>o zvU8X6nX_DM;nY6380S8ZK0MMlc+KzzF1Cf(-wng|^#Y`0YlxC0TYblFW{PurAnWpVil0kyWe<=iSm%wX;sa6Q>3$ zC_k%H67p>LDrLjeo}xMa5~C@Bp?!RlMW3X}L{wNN^JOe_yh|Cyj!(uw?9KZRy+qsi z^sGrtO5=fPkXk|ll=xFi{EC5}BQ{c8P~fo>u_mP9KeG<$8m;8kP%McXFDb-VuE0Zo z2|GW?B+o_=TiFeUJaPkW8#x6&c^q^q}oFLjw*C!P24?2f{INb2IO1N5)e3s4dA^2@Y;-4{2*hPl4Je@fze zx$fVfDIMQ^FQ((0W#D_o(eRyGMa*nP`tOys2W06Q9EXA8bm_dUI*#}>aC{KJk=wu# z^hmG*M-evmcS-!9uL6exD?y!*ctGxlaGulI=l^ozcbQ4fUrFEbGg zbSi$-K+ilzU8zUi!KhmiwYJzg)`D&eK%qfIUI`z+_+E-{mIJ#Ds5jh^2N9nw5Amx3 zdL^V4NT0k?eG>_2#cHFH%7Fle4DjL9LA@8g=CM`khje_02@FYbz^GFnS`7~+HYY9} zh$uyULeRoaNXwdd*JOmP=_@r}UmNuGwR$mNn)J0_ov>TF9yN&d=iG7(Q!G*vRAT=v&Fh{!(pk~m4}#b`faryvR-sR z>iZ?Wwu2`3fCBe|0&i4FoZS(-g*2yrFI~NPx-{VZd$N5!G4LQ%Tkd2)Mv=8Te_MZE^ydKj z51=U!UDr74j6tu16k8nwSRD7)Nxq76uX;HK8mz@%gl2%8oB>c-P6=qA89)jF)pv>@ z+kjCBc~+};e0Bue7?Ni|j=FN>o9+M| z5wj6VUVKYx-~M^<0?@^&63=AktEHksCo4p2ZC(p!D4PZ3wzEEzmAZ6Se|M^wlf8iy zt04ZwV6U3}d~!mftCF&J<|9miL_UJ-Aa&`i{`oWk=3FBgZ4}7>2NuC*7N{=*aU`Q{ zdM$|+M&_k!?SkW=xn1(q0zI3+m01(dW%j3n(O)4(zgg|@7mPQ?QLrbH`gD*wu9ovk zLNU|Yi+a_e&5YNIE%aHzhQ`fkPl_`Mo4_UbqWt?19M=@V4UOHd1j zVcvfA+rNrymIk^qY2^=x)TrZgM4j_&D||ix{T&xRT=%fP^#woZyP3punvTb2Osy^) zLm+XJi3H@(DgR>P%nuwWg2s$czh7nGU`I>298A=4$j2cRw@-=F9MR{Qp9CeH@*&bdTo#VVQ6<*1aZo zDMHv~Li=xh9elE=j+b%KoO_>0hsqIl@-?}47v<4R*L5SE`Z}*K%H|Os zR{2{eHtDuR>Pj=Mvzhicra^XLQA1`L^=U-82bpGL+6*&|iVh-eHqu~{G7D`|HV5nS zt5hozfYj0bic-DSPGDspA8Cfhkn#zy2=VrsL)n871IpL0 zFEC5>VyWU4X{B;eYONjvU#-eES8(@!lJ<1TmpxtjFdp0`y{k&=;(mDLt94noHFx{f z*?nNuINK?)FBifZUazV@u3hQ;d<0mnGepuutU#83crg1)pp{KRQXT|pavW9`10vU zg`DC2069uD*hA0k?|?AHv#5ktbuJ|+PB!IH3cOq~pACZfmniqp^7LFuRGvcxIw~~c zub>32Eh;XeG9G_YRr>Paqb>)}#TymlsHYA@$HL*b z(W$=9^};qJA3~wVEMG^D5@d@K7rJ7T1~$2rhs0MOLC<2m*4}|mS~CWaF%33e+JpnW zUO`m!jsSkD3H$^Tc*nqN?CmVy^TZAmvN0n&3eE@Lym(s{*;vtF=oPSypEk zL+WBEo3WTSmx+R?Ha*jpsBqO~j3l4zJ_=FIN0PP>e+;5(-WqJ|AT6RayeUYd|8@YIr1Y zMPCvX;E~=W$-E>0TMrnNBAUzHs8Nje!63K|g5Y$N@Bu(NwYNYE)TWaHv<&r%AXGw2 zUTQHxGE|s2qc!b#fjnquk(bkbUL49n^M8wXJl3Eg@Bp_>^^JgH9-fO7@)5bba6+UI zJ|z5cxqR+~ERXrl+1&9IpHUp2M=1ZFy?23+s=E5WbA_0ICnzXZE2*XmVl5S_Xi#%- z24-{y5y4yakw+}mUM)`4wkks>19N5=#9}N~QCnL}Yi+6Z5=3wUngA9ISP`|BaH-5N zDu`{k74m-9KIhCm5%~DL&-;Hre?FSo=bU}tYp?y=YpuO@@(uYL^&D4>5WeoOcMQbY zich|f5Ym;qPHc*iyQC)~F0`sdDVc^qmy>m)HVUu&$ES_R2IF-YbBCh?Kx zTcM-)FFz8*vTP>xkN-Qw3a3H`-aZIlY7&QTSo$2&+jls^0n>UO{|)$?aaJzpyDYWN z(A#=!XPG0kKDGnJ+V*1q7QDi2FCi9QkQT_4!&6T0`tV=GD~_{r1rBNsI74shm3#2> zB{6xiM{Z9dTDh~bO=Y;9thVgpiEK0q)5(4d?>YwQu`T6cutnwW&~j34YTv?Gmc^}?+$YXlRdZ|Z9)rimB8MCgIvl!;G8Ty3d0Ynzx zHaN;r&8GF@w1l*K!t=yb!CBdYTb|1Hka|+exl`(6A4{uuQmf+n*au~f%2tv~I`NC6 z0*VnaRxhz?72z6Z_+2K^!nU&r)_0Cctawf9$|Y7Ucm?C0xJG2fBubpRmtkfoiwtX+ zANxAPJd)4D@&5XL_#8elxPvzwL`u}C9#Zm*44qYoFLDzB7cV-oRWOv$!fCw5MbE~Y zBCh?NpBMrZ6Ez5KQ$P_b2CR~I1}-|!Vd2H^QzQZh@Zw}bkZ%ev_J3ON;so_w3*OAR zhqm&1D^4a}oL!ZR7k}Y`G$pI}?e@16Uc67fDZDt*{+7avH_JDL7f0IPQh0F;-?SIJ zE5!D>qGgAG#hc{9o1Ix;ao8ks$O4PUwgdajHa&AcbV( z&V>qhic~5CcQ&q7xN}e^PVu$iuM2_B;;{;JE_8(FnV@qypfi>UI)l(ABoFBP&0`85 zOn||~7)rGg&rX5PiQR$D9PV7uCw>MP6$!hbhKjPo0;BVUt$Cu3YD`rXbW51)N4km^ zrm9#XRV)NXbE_zE*u7`2A!&qp7$7xOsl9fkx&f&y5GF`fDJ(QMF4_n5FSp{@I5H2U zni%o?%c2vDJ`<##>J*S_7GQ%^GXLKIsSA4msf!qQS7eregVrKIDu7l!fFBkn=E+Az zgyNrp6+epzdqV=|cH<3*wIE2%9pN+bM_5}H5RBfnGO!o$T4IvnYvT`x45f}Pp+VXw z=smGjvN!i6>XHdg|H!;mSY{1%X&6qn+3nq58_h+9; zhjy*NuI8o&?5glGGdBZ;cVA$)*!A_%3cD^8qxbv19dSO91zvBQ?@EE!tH6@j94~Z+ zJy&sEn6g#p{;mm`;B}z_uM17^TIYSj07i3xAZUu5IF2G87K-weZghqwUQVek*tjdmyfC>^Iw*R>F~wc4 z>vey>V~}ggd)6+=RoV`GJr($h=c9WUCd;HOAgsF-+kQorY5cmWQQ_B(cM4r?l3J+Bg3zKf@eoT$G<7lq@J0nzrz6xamrWoy(qqyQzIu;!6tdD$ijU z^x1INw4c8|zhD#kimRIF*?DaM0WY)=@Z(!xZ^p+FtS$e=v1*60Gyb2y3jDnhI|R^f zd(zsWW1Il?-3+FDosTQTw__aK`!2Y*R#2~U|F{{@doPX{cj7fNU?Sc(0EHl496QEB z?J5#BPO&6-cW1eya;5SS2`t@;U&xgb0RxiF8faI_0r~nj4WW#g5AL7UbO`khj)fvK{~`wc(2+?8INATCJU-VQCT5Dq6%_*$AIt%M^k`o`0aRJo$fK;9+@c~KgR64=BDv*nH$9`8aUUxQe`$n6D zEvI3Rkg!3&3lmM8aY?&gds1#O$fi~S!5gPrAo%px1q36xKXt!tgRgY@$VcxM8Jz;Z zZ7xHp>U3ib<_}dLcWdiO(Eaw?QbdMd#ij?$oFFVTMGGl_*Mw{&dfr- z=Uqk)S;)8lYiZ=mQhXT5_uJKiJQpeCE1E|W`O2XuVbT6+X*q6!}=FFfT@g&Df$gU-J#+nE`MCny z%O@gUZO_HBL9W|KzSIMJ?Jvn5&K2g4lVpJcAoaf?++2`4sRxky{8dP0&nHnDn(pQT zibSnUfQYl%0;I>H?HewTG=2*{76p%fclrOtqoB>t7mvQk@F565@|sDLNM6-Rcm()) zcvK61m(fi$@JAN@#PKP~tL!q)tYIjxHUXR0>P9Ep_$MHG z>;?`p_)j1ZoZIPqGNp>|5S-Z|5ds&zca8-xk0)CbV3reNLZtxa;wAx@dwlX;3w{bH zY%BjKPZFoo*^yGkf335e7@4a0ONIlpBwBoc{VfGBPnT~BVD9_3l`aJ^d&@TkFyFVo zr2uB~Tm>-aIZ<-mtd8bI0Y+&J{Ck&>HVaxVe(7MBzEoa$j2(vsEwx^vOZU#xjaEdN zy4nPoI`obDo7=H}nXd=hOcgp_s^iUz6{4%@bk0SVIRIQ`A-as)97a%Wjtp;fh95VD znQ}m4D^YPYWvS5ptWnCeIR3U_F0vdqh|zlru6>xoPBFnwX-r2XwKW&{^1~_Y?=8_ApKwLo2-Xl6vcPF|4>Q8X*|el9(w!6@VA$*p1&2o3*B92 zO}@rsv0Me5j(5C@*H^{sZN;Ov%B^Ms5H=DVEMwF*YZyQBFQsjNiWe^PXh>@@f=nE> zn8#^ImN58e(%&_+^6Brpbg2pQ>Irp2e<$(D1bH_7_2!LDe_d+>htlH9e@|8v_@YUH zXsj9VjNu~#=~QVDkEq z-J-lc=O~o75%zW;E!(9;9U!i_ug(>DMUh$9=f%Qc#1+UcVJ9AMhV1e(Q;N7!Nf9?D z*GSu5Mr|(PAmhb*cZVkE(0p9&qP?_VdC_Y zfJ!ebgw;*DKTEn_WI`-SmmEmCMr$O6Iyev|ql2vK0VjT*?ZJXV67TeYu&yHa#06Oh zYc5$QaEvGjYomp*{(xRkjU;1I6^T;5Xdf~;G|ly)-RQ2#3gO*PGWUT%<4d{hsq_t+^F76VeMsq(f0YHmObw#vI6 z9U}l_WHzPxzGhJ=Si6AZTrGIDAg`PFBkOZQ{6MFre$Sl15MOE`uMfXtA+Pga6j`4i zsxKh#oAKd5_z*_?a(~xb2-C~HJeY`b(eQBYAmgUz!N|g>=a=z}((W2gl)C;Z3P-tF zCUb<0Sds`+T`$&u&U3dJ%By~Jj2w-o|Inh4x=koFY2~NdbaifTsXbvABmsK&;}2uKIu=l+EL!{%>Sc#$)qM0Y74oe+&s-l^jJ&{O^T*Yl!<6KIy=Jz-W8um3$ zky}Yb6j5PW*SMH6#>kEI+57a_Db}PLOT?TOm>x)3gSDX8fJ4Ko3NeODDrS)Yj@j#$ z-|MIkKUXfzV@)23ZrJ~_dMawzB45vN85>+fci~WGvNlH$zN>VvD3FJ?FRPK9yOzfv zKBE_QVH`uWa(4yRbJG4vDN%3PUZ#i2`fD%zMLZY>)>Z^Q*r`|T!N5qKGpXkjqMOw7 zJ3=PS8KZ4Ww6@Wcr%Q3n&}@UWToP&+)vO|BYdZW-N^v`L8CHXq({J&M{&=u!u~05k zqku`U zg5P9x62B(pGD(?H$XeK0ZXq0`l;{ma&$oaxRf1y+meR#6Ph3p0lnh4N@tuN2yeV;y zD_F#0>3^KO3DbzbuNP`hlcfF|S2U=SmZQGYSYb<b>6_zrO9cqY9t$+gm`5#S+JZ$Cw0V6{et4B!BH}?B9l7w@XNJA zsr9j)rS8b=TA4$*asd!@xFgTu$wan=vukD7q9@9->YPovP-?10?waXcPuogd|MS5k-5xVlqT1{T4 z%M>bGcyX;>xkBEEF9T<29aZgBdkGaFX>sjzfM1Q|E0=800!N7d+GtV<)h&~Y`06V+ zaObkOBuIZ~>7t*ieVnK0l^#s+{E7yA?kJg4%x9c_XT7ZGaxNevd!#~E* z$yIH>a{uc3B%Sn%JMwa^8vkIIufi1>JDB?=>vddC6K-c?;6e&uy?rXQ&<29nzuhPN5ufh0|q@<+0YnU!+MZMw6~C-YPy zM_XWHaz2reuD#e;E9*JS^qd=n5lrAu`n;OZqubc48=tr%%_>V=Ej3Pru=Ma;lP8}~ z&D_Q!p}qR>UDwx#KEb=P9(rBuKK)yP8DlHtO2&|i9=-t| z;H7#Btq0Y!&%iP_?3Wo(I|vffvA$)mQF{r6lbkVp{dHC#k6 zp(1?6_3#HFg7C9KttG3-{$PFOCwfRd6W;|Xm}L6ljfs*Ig-NBaA8#a0;r+(7>>At# zUOd;s$+@S>WpH4%sYRU$N$o$}%^vqv6CLgeP7tFwz+)%Et?h`2@m1E+=3I5@M5m+G zxrWIa^|Ky(jHZzJGuQl?&yTAu_yj++mS{~2%@2#rpJwwX#!q|<++J|*Tq07ThNzz;;{IoNJoek6A! zD8rrFtPGEtcbLfrD})dG$Wj?i+50@f@+7~DtlyaR+iv}K@N4h3=$VB)(ncz!Qo4a^?3(hAZ9n_WVWvFml@X=J#Nr>bQ!}#HQJBJia)w_bisaSO- z$6M739I0brY#GnOs|GQuvi3xyvIXk8YM?9dYBd%T{-yE^$u5;jM;1u=;`Ws+qmrf9 zP@UisH*!pq$`QJEEKs7x%SUWll+zd8(AD_BBUY z=5bP{f|}W2n4P0L(j=@?1oOe=(%fj1bm(CX-LoGJVYUWUdbPoEN1GPXXf`-k^ivz0 ztl6@Ua?IHxr<{&@wm79*v)f@cLRVrGH>4nyh*_kOvA2hHs^7zMpPC~J+P_*2i`j^`fyhL)frMB6fIpR-JtI8 z=})MwUTtS=Qo8o=NvYwILi-!t{~M_S8=UM7bwj_r13U5Se~CJY>$PRwVqRn$3w{L? z@!SnX!(S5L#X<7l1;iBFiB znR_THWoK!ADL8nS=*x+&_EFuGbW6dK)D~x!l$5cNl9GZ2OA2lq>D+K-bNWXe@?_-EGg7)yzEMZ z)y^er3w5d6kcC&aP;;hNFv~`abaPx+t~Dj7eQm-)m<#{ zC@64EFbQvgl`IMEs-#t|&RrB!EOaIJ3i5w7{||Jv={3wti2BOG{6CEUxp?8qdXLe+ zHeM@Sj>QA&+nXt~Y~Y+H7$xp_OhlrV|JIDNKP$=6ZR}yc7Pz+>JfjvOud%isv6{zN zk*>V)mf#ZOKT1N{i|hIXKg_07mYar~-Rvr2QUzIT?qEeSS>gynutbF%9<9BVvIIJ4 zmeH~ooUh*H!2+>#%i)Ik*gtd{mQ951CFt4j6t z<~koF3~cL_Xx43*W$V;IU`KspX9{-gA{qpxV26a!hPMU9`5FDn$Q%ah*z>`VA_X(t zkxM`wl8Gxa4g%US9^_!|n>oTA)1ve zO|rxALEM>*$2H%B7S(01C0cL>nHL5zoekOLO-_~f1u0LVn9-9F=N(ab{iM7C0A~1m z(zq0WQLQ`z3GFA_1i(ONWUtP`w7H`XDp3m%1{o4tXJ7V&O=FlBNOLq3c8pBzT=-(P zK^?ddF~UMM=Z;o3`;oLJ55F9&7W`7T!j>Khei2?IW$7&+l!eNMgI{JVp;H>bAZ&ng zoK@(_%ufo!e1j592s40?1z{Y8wW zT!hi^dg6`j#dvf4!2_av$q~;!nfNX7EC92e1=%cQ8H~V2FntQ-&t*YGNPLI1*$8HH z{3`{D(Sjo-`Y0(%sGBwvEb5my%*(B!ro^g=A}J~h!fcK&-=E(iEw~2Ol2~WLi*CB? zf`a8dC<*7=;KICdVRQV(f`!~FalhM5AqvDejd*+=_SpID;Q&fkVwhcyk_9`A9UfzI z{1bfX=EwgJOG%=L_&I{$3>35S&Yn?BvJi^dV51ldsN~=k@$Y1whnVr93!a9jLry?6 zyX7E61Do!rWW{txZm30f_nz--F5}(9T9LllA-t#!{huh^-O=f#pq)kWUM$_<2XlML zeRQow4y+{>>8-q}Vz}d$E7LzGrz+4X2=`Y6adm#4-87Gv{B(fzVKI zbZoI#bL>TnsVzIvX?Y>Mt1>#`1wHDU)}A~8zO+0uXVXs_xhL14i)`S&gU5tR(H&Z2 z8@ZZ@>H$J(lc_!`VD*@}z-5YL=BQWM{8%#mFf-F>sZ7Oxzr@^WKDhr8=l z-G9m1?&w{`T%~u&Q@2I?=@N(^_sT1W$J9|qu+UtgO=H1)^%H!;{8^}eniiQ)&FW`C zOn%yeEBRr~0su7$JQm!H!$q%=057Y|+RAFFJ`{ob{>Y?-RHr$9!oM-$Tp@T^E6%xhW80NkbZ-Bp_$5{Tx4W%P>Ln&5#y=3+ zQk~vXKX>HbqIg)<@l_$jtK@@O&533;8-_-{=p`t9RXKdB-uAPD z$n>`P?)DnrBw`M|pl6N0NDMblrHEAPsrwXimwPxonwQ}2xVx8J89_~o?myU-_>qii zsv2ut<{+IC`C=OC3+D+o5WQJCCa2iE{+M(%1LwQJ6}aejk`^^g$Q!H~ za}G+$_CQS_n$X7(#^^G_Qub(mjq;KFH3#ToYHSYBEe{;*Qf=QW*MX$Iwzk)Zos{p}=@$2$Oaf6ooE7={bp(g6GWuT0uhDlb ze-YXq$4VQ&oL(~8U}o_jLI9o4mBqgP&3}>FW%G$wt+z~o(Nnp;8ym`1N= z?ddRIIJ6fht=4C3>7ecUn;qUMF)op;;WEI^7QgRUZr`lAqmSNPLvG2w^0Zij9&L0B z5h{HBUcsoNDE=F|AJ>ekn9i0O-^r1_zZgTMSNZx0bA9O6rBJ^!mUxKB+Kb-RGd4?c z;yPWIavJL7#B12gMWvij-6zR!N+gnZ4%!H@$HNWd(>D_!)apf`|g69w0|xSuF800(NzM z-BtV+Qc0@|Roq1p2@Ly0t=rxFW>zz|-GPgXd}qqFrv01cI-T4(BJb3|OhPzlv4mV^ zaN!}$$P_aeW`??922Wku6Em1?eQhiM;Gl4uJZ1p>D~2#RO@)20Ad$roTm*$7)bnff zJ&(UOL%1+(GlaXTDpzQOt_)S?X?U6@X0kYY%T^f zAco1=+R8t^#GJROcUfQmW_@idKZji8AKn%8&}(|oXYT5{WgH$17mbGg64smDIT*V(#Smdm)Wf24evlmMs3oH{=Ezn69;FXYl^`EY#3 z2TeYFNuo4uC@)H$80mZPVl_J_3727c>56|id8vRft3hk|Y&EEjpfu60ycOf)E2+(kb)#DFm^tc&S-l!h;5H%N>M#|6IYtz!%W~dul z`qf1}(Nf6z+E%`0PX;Z$s(1cP_iqzgx-QN9%O?=q>if$HO5b0~uTg#he^uYtH(GuF zEvQO0txA7cXeY6pKk4S*jS#LoD*Di-q7EUJ9i!4zwB^4tsAx^bhgI@HQPCBDGpXoB z`MSz?Q;Le7B1%S6X7Qb-$ewFka!BNhKjE36!}#(K3Gp*kG7xh5UchS7gV2@3=&btD?3JG1^VnSxvQ6P(cJ_s z(TbT-&iF?9?jEToac|lp8Knv+z`Wb8FEH7jC4F+aU4Bab0pV1@sk@y_j~~ut!a=#w zvO=I-+PFYLak!|-zZvwwqQGH zWy*P?-s-mC-%?LarXn@EkvCYxb@0;}l!DkYwh+HF_$d#5t?^epI3m%1@r1ZphVLQjWLuO>g8ZN93r} zo~HZnEgIRt{dV`3aA{XdUuvj?QklL59mXDI`IYts{%w&da%wZSaT~ctR2K;&>+g!FzH`CBa7HiLBu^l0sF768fS;F4 zU8QS1k&})xT|eDl$BmgQPGZC0udC7;lP9PU?>-)2hfYm}2KTq$oqN0;y7@Re^lNOt z$fekKsyY>~I{l?Z9Fbjo8~btg{<}Xth?xj{$lGl7J9FZBp*2R0;0%!v2k@B{=s4ss zIvrK9zy~GT3&GvQ;N8J>aYt3FZYs6m}0j<0@ zHmv(N@If(`txA@XwV27ad{9a@dw6_6?2E~a2=amPT|^c6iSdITqecce_%s9T3M>{Y z1ZLR+o{SA#0@dL##}LvFUgZpJA4Uwa+%nFcsv#BZPun?i_8azh#hACsMdTiIP)bP7&Yl zoFV4v6~1qF&X8d%^Bv<~EN1q_4OykXlq!9?S-SX$|BTWlN>1sX$e%^ar>uR%{zuHf zW=a#M>e_~x?F8hFqnEM|bM)#kpXB~4UdEJ>&p*OZp+97q9NtCb#btPpts^1Sgp{%J z9X+HT#ZgE&ASVClBFBs>_6-|V($HTI&lE%8K4rDr^^giC&l*+QaEA51Hrc1bet(?( z?$bWi);sNmz*or-^7^4T8!fx*+xUujtsOQ*T&aBRiazzkm0)t5{qD&=HTJs;?RWE3 zo+_S{ts(&aP`PJ)U`rW%Az3nfJ!XWg z*Nfth|91)dfP#}jJI0<20-}#>GH@XdUF$Zu?b|=+bt+SmEaS4xYV*c~GOe+dcbs{Z z<;+#b#)N(3eVu_iAucUAjgp72k1QDmtJqA~re0B1 zP7|t>No?O#jRA*}0U*G>*c_)&o_(-SCgJ2eE zXU5md1X9f6G(s63BIv3NW}yyddJLGw8Pbi}S_f^}UutQ*@>GJ&rt(y>7wRL6fjrVa z@eZqedeXPz=7avJ=8GfzNXk=*?bvvbq{ygXWvYVf8KVqOCEZo<$bBt$Q>B!zWiesRnteYf~XXoOFJLpjG!?Q{8M4$>#Fv7YM zg#3GOw>%l=`ob$QIly5F4>CGDeS~a(_W4`&MWR(sn@-B z$LX#qG1~lu2Y;y~?q8utr#&7xM5d!9)Ali;{sSp>VQZOqlJ+k2-*Zw|4K7{-2aE4J zLGN1A>Nu&ZNLpck^KE;j?0xRaG}eYsyzqpEQySO%`iHM6zVPbehH5d>!4*ph*XeE< z&V>#q#{w&hVR%=*QgMVyP(!^e{gONhZ@=+}?cQq`&^%1u9*1m6KKShq`B+OBq-iiC zobAY#7f@R^2pTF1f#cFN;`@ToN0L2^O*P_H;oM@E;TnjH)v`oc8J{fX;@SLDHnPtv z5;`7znTXMch!L#0!O>n=Alrq&)?zTc+AVB3RP|;^1-+3zwbn+>8<|*JVQt|oeCaVB zSV%i%THYkh_Kk2DcTDDg?6X#wSi=SNu>}p8blrr^A?Hcl_Kp z*=J_A&Z;(;`kAg!I5Zmf)dH$SUo62~;F*&Tnhr`+s}77HrX zn+3PVPtMO!<+V)WyriPI4l7T=npU1|gmb#a%v0i+dH!o%UaQR}h(Ecv^FOB8o;Iff z4=9PnSV+ci`d(_Q@0wEWG9DPIc$vLF@O@jBd*69kOMPLOUTCQ|X^_EG&VcN`lR?;y zsx7B|neKq%C+625G*Cg~Ve*0#JVQSgTI~a??~p3PyUP(sl@xjE;@ZsLFfJY=u3~s1 ze~}nsQQu2nCQ-PTUM3LsE*@j42o5;D;4uzi>0+%1`*79gHd?%OYkdQ`Kwcult344F zxml*xre2k-G86!k~|;#c8#t}4l)ksjP{ zHWkQF(494{CBx-w^D@ks6er1~=)fbm?*B>2Ra)>$ZexDwDso`SUP%||%>X0JpnhDT zN6z&a3ltCj0f*&~)>#z7*q;sWZgvM<omc@J!jg`R9m4pe8g^&UuIC$g9NekA!Py z@9#&kCp6cbe=#|aWX+K}U#SJ>k?BiUc3Wp9ceJbi+@8#;TS7@%Ff6+T?!fZu@J!h< znysh~&6HzFp*iv@aaw^^+{tt?TXD`&v|^MNT=5~T7v&eE?0V6E%ofe#KKlnQJvZs{l~U4@+KgM(FTU4f-C*x1*6qWf_khFC!lEs`XO zv#D0@h=pmP+1Ak*Tp#I()nR>}q^)&_*VdBm+A6gQ&ln=ZGDD8`n?lnv4&q2#T!FnM z9QI_B*>Fs&igjl41RhK6$J3I%&G*e+L~5+f&LKzU5HkFA`z(=-K^-ywv+^80-G43VKk$;;BNVhU0HfLJ|OO=9HalZMBO zcfTqomL;N-zNGoK>)I~JQDTcbHq=n51V+1ED!~l_QHGU z4z$JqZ%`;o&PsKU;!tV4+|ldMcr8#GuM>41Oe~^Q_)0&C7T+5=>1dO>BPWU0tD(2* zF5j^HU7oEme2JQM*%t_Z{T)ohTes3%^48v?{@|ywM{QVQ?N8ALMR%$8Y|hxB>Q(E^ zEvhGSJo``?4OiqFwDDmz5~ixr+NXlGwZ@k|u^C!~(9vvE3!FE|)JM-pAB_f?v)85= zA$5q^dG1FXV)jPvqIO&dZ%hhdgV8R>El?!8hYA@zHXiapv5S9Is-~_mcZ8m~nkWM66eH4W=gC=u_s*>c zag8@$o+{rB2VN)OF@7=_nejq`j*yBdx>C`dEv(TR*GP=WB)>C^i{gEHLls)*5|82K z#WB1L$bS=I^w~R(CHzXr%6CtE-O3Ua1xOfpZ)&Caav>O zG)XP3s5@DOPSF}S_fesKTJTAk)q($%XwfJr2)h@n(RlDan@^6g8WeVQG9vEC%=wI) zh}SFqcZ-Dl1Rn7fHPh5%Y4?lK;IlYPTSom*2lREf%~T;C&Rx%I5f~LUXwJrud>8N- zQ?b5^5=7LWL{{I4ve56V!dp^Ey-%KCN7aI|X>G*Cx0n+-!!t!iz}=wrzGHR&GNsMZ z8n>%H-xH4yRDMuz$~=tqIN!`w{zgK^rJ@|<`>m=~`A56*PRw6I$K@R9g{DeE8b@N-a!PYU)u{>i1Q7m2$ORiY!-H#HFUo zvA>aXW=G6Vm3j41m3dx%nL=a@U!~;1GOEZsbDVOPk|fV+AJcY(zkU{uQ2b22gdI49 zD%}7Q*Mj?CgNeI2s!86}4S2AfX{s*2;El`?N)*SID2?=Ui@mrxORN^I>7OG+QJ+}K z1C(8?%@J(_jNYY`*)99Ts`)OLoP6QB<>0kK*Ij>g6$izFjXUWR-=_Nf2A0Z=MU3`R zl~8MX4SqeIOyf6=!!L%R;$xJ8yQ$zutU8jBQ*-X{6h|ee3}PmGY9&Qvc~_ z?Y_qMClhPxXzhf?_wObo4jx{UK6C|QCGNVGX&Ww&mbqOR9pD_~j#E65N6RGvUk8pe z9$h0b-Cc;7R!`ezje|V~?|D*VkkQkrZhnfYik0NmdLVWH`F`@G`>Ekls~qWt)}Sm^#mR9}#zl;UbeM33Y790G zqHB0WG5Wy%daZGHHN^z>5!%jjMQF6vSWd_p{ZY&ry>gkeYQL{i4;=7mjWw)Q;0W9t zJ^4D7+oN~>RCe!v-(at{?9FkJ{%>_$cR90bz3)U2(^ym*l};WiS*p$A@y`qHCazu0Gl<@j9HY z9C<9h>x z8v1b@dDNOwe8jW8ddrJGYc4ilMCABT;yVl)dBvFp-nDZr{JWt?;`WU_CBHs_xig&>*Wi99`4 zQ!>VJ&4tw6Tl$7QfX|pQvqvI{Ufqr`n+STKg}&cM-wS;pl9eBtR+RWYUsH{r73LMi z=CmQka!Mv)QV-Nd{dlSk{23293yW&>gj)XrWn8? z0X3<$##?0QgRAZv4w*b6snvBL1H93zdU@;C-PZ?Yy~@m3m&75|JNJRLFE6%g0Vk-x z3;#>O+sT-uvQW6EhI)tlNUP=z|8#^;(Ea;|a^BOw|0^g~)lOUaW1v+P(@tL;!+ZlX_={hv zAn&dLcRVIXA!Ms@MX8mEaQ?wCig_lZSl@86iwi5%VMA+n(6_Y3tWQMw2=PW9tKsbx z(f${B>)zC6)kA5Ze;Eu;g0a}okt7!9@^M#2R2l=07sCLyH;xdpsF?K{#fgj!E3Vs6 z5!j%q=v}LQeXW7h{TI|UwAw}ZHy`9KQYp=A`SE z9+Fq_A8@IPZnVK0edxry7?I!iG$P(om6O*ne^U#JD&)@ z|A6dsJ<|jdmypJkD4_xM7@x$~KZgh?C!Q9(hMAN&p15K}5$r2%5-5FtDWN{~=3XXo zXqWYUGXeAa+l2bmB-ZoOZOy6+)JzNhlkI2XmuTs;YB!=_?YL+P&*a2~f+`r)@aXbU zHNHWkhBj2SjxJB_3;i9hI74cSnD~%-^QqR_GA6fnTf1rh%= zCrjM7DX`lzjxAWmR&h!5IO(!_;M{^`aPvl2;tnYzvg}p`N1hT(hQG7>6d<=JKJ+#@ zi91%9O&%F&LD^CzMv&ax`u_|qo((zkh&Fh+M81@^qj^nupkQn5&|kq;yU5+LxfB-H zkF{Z+4VRul31UUMB09>gFNQ0D^SXKyDFqTjMC!JOKHOTU+AZu268Az|Sv^$!Y@tzT zlDJn2VWy|rkJMDFJJPA9sjXI`tS6$bD_G%bsl;D*=2ZBmKNqU-HW+i_3F3Yp75=$o zb`_a*+r!~4g?jiVNq2H?h5xvyP=$v}+?_%?_{R9g)RHXlV=&^Xw=Z)TKbg$`MX*nnx2fl^CqMrlcvu)9*v-O`fo11G7V=%;|&0k{i{t`(hc4+IA}TVn?A~m`zRz z7b@swlGL0zyQLd8{;^Ou+$hmcB6>Hi5&V0^t*MaKNXp#S$h&S@lh{7n)@aCQfBs2>x*LZQ4& zl4i8)+-C}n(u)%P4x*dwI*E35BUPGqrXbyhGqWWJhQ}X6r@9f z^3@5};j7{^pEY+0Q^5#aEu*r4?J7aD~dB;7#LWsSnqzb`Zj!zAv9amwgw zOKb!8+eM z|I_aZwS9!d-Nkq!V;}qyOM~b|Tv1oCi$nM>1^;v1@E1#xePsW6wDCF6dE$1Vr|#PL z+jk4K@g7Mxl5|;Ze0^b|HjbCLeTeHF`mVhi9+1_Lx#mtSh_7cZh|i8t%FN@lcVCJ5 zCR&fFZbE4qhl5;mmYM~@ z^F*0?!2OtCTq_75iFKk+Pn>xBtiI7WoD^wHN1zJ`V>g z(<}7W(dQO%Q=P55^PQft|D|C{tI=?5T0tjwx;ev-nToj;S&F$C?CK$$_!T(w6Zuh$ zcJeGv0kc$S@qhF)`Sv=gg|=)?Ex)W)T-$pyY*|FhYh1mN97mQ7d%^JXm$KYMfD36gOs7A7#Wdvgp3C4`nsB|B33{%oi9Yb@tF#O~^b1*o*Gu z=!{iB@?v`CMDF@k#U+R39-Vm^`sV1&UCmhEnmtKvM07*{iBLrq!*?9T=^@ZyEtfc!s z>9SVx;(`^PDRD;=7ltqV(HXvsTWoP0i2H+mLmT?Q=S6U4@@@ZC1ZOIk@USbEZ%EG6 zi{uuQtX^eD*F9Mcl+vnYu*I}w_6zUx_%l*is|~l5if*yT1;?&SXZ9NMQ*+ITS7Def zYe)+`rQjO!iz;&s*(~h8@ES7rb6-Q86lSg=0+Nny4f#9J`~Qb)$PN~N){x-{>;4a0 zLyTpL@$dVyT0d+HCDskC@w#_}rtP%@<2Ig^IZEOZLOt=+sy7PF=nkNE;?ei=dFt5< z3UQ%7OZ4v%J(H*U;a?WAJ}RDigJh~4*h}(mmITk*Le>A0Bz^zgd?xz6M+;SdH=sK4 zN1}foO!POB*?*H+w@h?C3fg>5{yj-IgmhU<^yNniRalp}2i2G#5fi;!1P)nDRQ8N) z7w_zi!pUV2&JzH>^-s!L^Eq`+NHTK>adx*?{K;PnbH< zsf0XlE9Q^NXfz?6doC^O#l%HCE3H!hRFq0W7?ivYy%Dn}QO>goWpu7FFT7d$1s7l; z*Yeon7U@E;kKXVGh*9iD#l%SNb;tJ9?+mF|iI?6|8Rrgo~VBtK6(w^-sfn4Of@RR9-_FKt%HN5wksINO#0l%?pEMU$k06NPw)=jB zZ#ku)9=?8E+~?4>Wuva))W*i>6^~;^61}TK8*@kxjT+Aae8V-|hwk0zj9&gYdymw4 zYe(pYD>+fU+*Q{;Ef)10R~*&5xC8o*LCQH%!^Y9tvWXXTIif!%Ro6+Jr{*|yXyVs| zJT_X#sW+yMQ~yUDr~a#Tocixlp89q)$Ej~P^5fK%w!`$~nH=YgyMB!%au_rXPH`+} zN2pvnDi?gVdv1yLC8A}06tipF|Ch0A_^RRS{g>2;)4y2q1RR`2Zvk4+V_hx&Q5V+u zKH{XPYs$L1wfAc2mt}Qp@A<@0*QzxR5%|MA`EK3X=$K;8N@72TvU?KV*oJrN&9X-s zzDnm<{8^qU%RQxSW5N@QyD)JW6TYGN5a-s5$AoU+MWE%7yY7=|n;mlKUB}BG=6e0` zriYtrSLxgCq3z+y&}GG~y=xM3GlLl1X^p=lqzaIVL?4m&(ecH5-YwnGwLGxDmp11# zUU{c%ba9P@XUYbTvCcj8^>NWYgWN;cx$4&4+sC!%U4FIMVw>acTHzh~CYOa_ZCI_% zzK*0=cenyuG#7s5_Pj$4t5LkTH0L^3bQ;$+Z_s9oFxSAJ+`2s*>AX^O@@oSf+EBWy zg{XI);0T}U4BarY*xeOtRhKz?>XuL2;fnfBEOzZ_#d5C5H$<*8+jLSzkvlq~AK_!M zVDwyA?BWarA@=gE)k3-dOr9wbU-;~Z(b2_2*9~0`b$d!zx$9PIfuB;29xe_!E?^$C z=&i*yVt|3k;|^nGS1dVIAG%9PpLJumjMNU_aQBpU{m(V@yCZzcWlW$euztVcG8|R) zQBNg~kmoYVOEUR;)NxF)u{?TNSKZn>z97Se=d{wc(P2kPSE%elsx!KkV2yHChubsp zS%;eUhAtSGu`+ByQ2JES(O9==jT>l;aj9u-|G3h4 zV)>H3+xC9-DqGv@?wYlc!PWi0Rd)3pINQr3HVBqa2E4z?5VkqnDUPc3;ABrOUP%*) zOI(Ml+u4LjSp0-YxI=rR%W!u@fcuG^W5vn_}cFEgdAL^dp$)Nrh7e! zA#*&UuDx@Yu2k;zjw+qyUhlROr7y(2-W<%oaeUPm9?>-`Em!2WFBuhj{AtL0W7<1+j>AMk4wHCC4mk+;Kj>FM@KYC$@uoeIo<~dOSkSJ zZtv(Qq;Qjn9xaY-DdSYsXSvrq_{Jfz_F+DI zElS8dS>{LaVNUDI37ONH@AkA#d&0Xs-@~58rUal@`vx$n>jljiGemIB&p_T=F8H+I z2H1xqtlZXd#-~~fepUF1a)kGkUE#aI z@|u_JEN@_{g!j!7)N<6bt3HX6Q-UY5_*&lDe)4*Y7re36>TiwuJ52qp7vFhfIm#Op zUhg*WW2P2HOWe+pV@wN>$_wIhqr*|*N!0j# zUoj`W^2_!uT4H7FHP3s=Aqh^|;Ec!4+n6cxEv!VP2u^QF=CubAkyr4V9~VCy-jdfm zwG$~hinQ`o4v(GYE;ci0Q?F!BS(#WRCXda2Ru1zdw`6ZCM&_Y2xmQu@$jYe>rLE^# z$pqs~NC{0k9-k>9nTT1ODW*G_P=?!%3{_7R6&H%`&P5wrnwd(65!j1f>U?5~Uh1_D zB~zR^kY`%j&|6wfm|6>kTXwa2_#sh8jf+k!0`izTo-YwAvyLUHI<8{K3X2l6>L>#I z9J-=#t0F$2YD}q}RCVN`+bZp~t0cC==`1qZqSQ=QBdjKki=I;5xxCERjj{=^<;Qpp zWviULa9q?;eaLIf6xC6dpEk7+U4(>}g{YF7bgd#7L8?(rY$>5-7e)QuCGrz|LNyi90Awu0#f3C zsFm9@R2VAmZ|6MRnpYPAv9bE|7$4x9Cq4+s;f`E`Kx@6`l#OnV=Vb7^%5;{~l-Zww zNeIh|ykqH#DrkX+k+e6iBRuPzcE)8|8fL6THpH}?zUJd;^ek+`m%&dlI8?TTKU|zQ zkHi_57!SsOGYhDl-9E%TKNnB~HqO@B49U+YL$tFmeqDZEY0m}OS^a|@OHQ$A$6oyo zC!b7LTyqQL21OTTxZ+yMO$a#!=GSeptYo_B-fL8Mc}g79*T8N0dB)36OKn}4p5K^6L;$c?vlLv^2* zs{#B^$(nw^T5sTFaj7EzumMo9jfeK~M!a(Mu^40Gl0B5YW>5~@kYJPaWG=ehhGWmPxXhN=J0 z&rx|*_`!a*J?V4!b8g}}aUy@xJ(6;&GKefqO?!7eAu)35ou2-S<*Ut~#7$j&foe+} ztJ?9~f11||1#0!x&#aZi=)P9+HM3T~N6wKGJIjONyEF1?C4v`xn*Dtja@(s^VM^|k z;WU$Y-kMBc{A zcb>Va>fCo^{)bYlO1xL$HsSN^5caXQ&odEIJqakkN!ZqL|J^X8ylwUV=KQfLXc^tI^z`(=||;S8yS ziMetV!ju?g?v`&9KBRx!N`+mYNq$G;`s^22 z^Au?758H-p`;@<^HS{ zOP&HP`7H`DvnAg;3U^?5K)Z!}Z4YSOw`AgP3%6vlMW@tEB@WLLyFEP=!~L1gxi;ng z%uyM$Xt0=fn=;*>>Hb&^bZNRjvjQpiXRENzDbVES&{CUC_5sk3bnx(i_N{cjN9_dd zbd|>gF=4-KC;qP!wDX#OKwtE{UQ3LewJu}5mamyB>w#m;hq7W;AD%9xQ`t`oG; z1#-)Df;O$k+`gAnw|_mIUpI+kV~N_Ha+Y`{0voI8BWmJf0Wl=;YK(?n~kY{ z#?mLw`wahhfw7h!G`A622$aJ?`mW-<6LQQQ(&c^>PKt)`r$@AwTR?r&d#HYy--vV{m2N{n< zypVT)_e9;gadXCpw<2i8&yd?Vgcq5#^R(gXah@ikU{3nq3O;e3`<^@UUlnMu*?Ha0 z3w?2n5yPwnrP7jXAvMnVit-bqf$6~xT0d3Wpd>eV;F;dox0*L*h=A5t#%2B}#dSdaR2>F)LkIDzxmq#I>j0bvoBxkG&E@j!I}Ds8QIXj@hKQhO zEkhjm04GWPCol;2HNLf%SjtJ#Th(mY#7WXyY_0)j%S&8!8>Ve=Mf=~$HFu?$V2G2X z2M0(3zTyV|!GEimU9DoCAx@H{ZFG^mjlaO1*L1Gxr?!BtZ1YDBn#8{#Qa!3~3+z=slIX7rUES-H#N{|C#fL;r9UaCq*V5e_@kI)u zXarv$yx;<6Kc#EIznv*V-DD26oZD*}iHu{)>Py3A_cx;VUVOfc{C;$$$0$l(wh_If~618vUX?~x)-h#$pT%)3MMSh81mp1H-_ zTHLDU9Y1Q8kW^xFX~V_-{l&gB{rkC)DBL8O_*a+tw`>ooaI(g~zqH}x)}VZ-NFHa! z*z&1=b+s9T+ka#)g{kzouGNA4Wp|C`8ltxbS1>{SD=?^2#U#(=p~imrG7r`E!$2M? z><6?XE6S_~XY_hZEDj9UX5D_OsknH5Jh^(NERcCXODiBBeDVtAgcVKpm++_vZf*n=}Io4i+#4aKSyx$F=1N}>e&dR)cF{g%-SB#y|3iD3!h99&<9!?!W;k<7&wlHy3lfW)vyM-L=Ll-zqpU zjJL}FjI`f1Wl235!Lh1^8jYrb{KS8L58;Rkvx~$5f_y}qtp&GZX~3jVNsXX%4L(_< zDjc_JEvm7)k`hv}5Uf!SUM;2T9HCQ6jCNd;a1HiywxH5mMfWwpDP=M+VdVu&pNvp_ z_=5TiRfjj6X2kGcB6=sS@%P9_Tv-2fEoWyT^}sBzH@2tt_czXw?onUpbTZ)^)<~gI zCrXmKf86t1zN*qvDZU~(wp-20s3{3psZ^B$OQiIYJNjBftj#X|vXo=eSKR`k6>ZKX zXnb7e)i$oWC9-gE{#M@AEs^y{Ydlp&2uf@!EK85?7;Cxm-D)wL&U#4cWX266G&{4d zHkYAp%<)g2uoF!MJtcjgGi-BzS}r_9hR_-_&k#kBp5kXz^x~(5B*Fn%%);|Tp%e

(r`syopApJXcaqJmM7N~1savzK|6B=9 zy2Vvj_GJM-TJT?|S?O|6WJYCs!9GxeT2+<(uvJNGl4sO)uU*&I$UGy9LhX%2G8$^N z-W@Hgs_$$qd}|ep0{6`Zlm_xvchpgJ$bPy$yovMMx!Ry(X} zTlAo6GpI9Q9tAwXB-;vKU;h#zC$P~^=|GdnP4ea%y_3U=m`C;YT|BCn@4`_PzVqxm zuD;@5DzsVLP@9UQ5vPhc7_~>FZFF$C)wBEzmQidA2p^SyuCBmFg8nBh>n=5|O^OxN!zt`m~}ebH#8+on2PJ&hR%T06*f1SE#-<5p3Ql-?ZRUd=L{Dt?^Mp z+4DC<-9t@&{&qKi2U+u1_rG49n!}FJwG*s)oIi)}T3&b#OIgfeDeQBe!_RN%VGiE` zHYz-aM^^ri%;B+LvgdFqp`)3@!_XTPI{TC{0sjx2!?Sys!>8Z-xz6EF=|Fo93)y|< z9F|D`D|1*CY|mjE9z?5H>DlgWq*f_(qgL=-4)~jPi4s|=7HAUy$yE1UXKmMf$Jpp^ zq(YTLfCa)l5a$T;bal1an^O}ZIK$V%O}OnH7&(~5kDXj<{%_qW)816f#&7;HMj9p} z@RlC*4*j~|6B$p;5i&E&SmUi~q}O;0-FS@p!3kM-U_`?^ z?N$BB^(l@Z>-ewW>Dn^I#Fd@WRj^!H#r<#q@)3CDHV&d7mir_X^s-h&3piOfC3>Qs z-VBK1>Is3#IjeWu7wwrJAapb{|Gbkwd*-{N_p*B1_2lGyw{_*BNwcoMl$EAnJ8^a> zoo6-BYA&Y_%ro;R+Uw-8_BvUPv_S5fRQV=7mqi^XrdI8Xb64#@su^#O$t4IF?RDC^ zpVI_T)J%}2IzHdi%KYK#muAyz|HCc*MbBa|MINC74Tleq#sx5kTFrgB+f!M93ndxj|Z?##mfVKrZ<<2iP zoz01FZZw29$mXeWh?p(OG9HX!1I?V535;x_h97U_3h|ii`zFH~W2`w=tTp}tTGCC` z|7`@F#$}WFAJ6;q1WC%tW6Xly^BUKq^?XELapMN!nI}L9RLh;xj4rwk zUpca~WF??jXo9dF9y>vFAi?`-nA}$|ONiOtQnBw*Emm5R(`csI;D2yrBEzE!#i<6e zS?DVuW;`N1)eHIf`8hhbkjF8ykP68*wadILRqADIl8cSUP8c4`=6?WLbFULIIr&HfowQ>I_Rb@A0R@IOkyS+r%PGN4~JkhdYdS^@bTNvv$ zz2y0>=)_?#L$$d}4#{PPO~)vM&I^2SK~v0Vk(A23hg)|ih3Co2D&n(K&3(6je{bI< z{{3u4{QE0>U$>dw*@)R1&P+$?CsF!H6niTo2AtLi@-tZatGlg;J2F;|=K5~N0dS1& zg1vAlH2gsC)a5A4ixM>S$@~vXQ5#a>K(LhcUPBBitofD8QYLb2BWExpOKxQb_@5N^ zG2Q>9^5E%z(sbbY?Ewl9xZB3CmdK#x=2u334kSF;EJ}f(X?Y;Xr9jXyYrzpInutkq zK~RQdO}KCJB(3o(T5F{e;kKXz#hy$UCC3T`8>QZ-fZU}D$aN!eIrWF-S=%vN&|-^S zl)NQdC=m+IWrYYe&FAk?VytWk8DI5W;oX{)!){FqI-K2_-K7X#5>MIuEW0Qh2lQT* z!e-fx6Qp*LtT_1dm(4h$S!6C(LZxC;{(f~;cVLaJy*c64pqP_uT=a%PV6{gSYnn

m10CuYAiBz2QWzEmegiughglZ}+e_oArYsb@yTN}Z@! zsS`ELcN3>y(tBfXF~r!S0A z-7_sp5|1%1jz&_HqYmThU9PA%6raytJTFTtCzVCAj~HD;_MHKpUh=!NWicvTL4FQS zYQr`p`2Vo??eS4n*Zz|iL?E1qM1!J6jT*#9Fg}ogW?%-+-~>0M8wyM*>{gOBfCRn`d3xP9A5$hfe2hQ>(dns_Xc64D+ZeoSTypmUFQ&E=Wfdk^kgRa}zsPcRD}30hf)^<;}(eKOiGaJ|Qs+Pq0AI98vy}cwm2QF--cc z@f|+$J{AB+-p8)Tf=(2R&k+}NT<>DUn7nScxsP4ny^m#4);^Xi8Idba*+AGf&p=<8 z=d(2}xmYjZU`s@rBL~Or9Q+RLT8#LW9Q?-b`{L>BEPTXsK8zw<;XS>}FQ1vftM)<= zMYWFBnu;sX>#@Ex@qp=T-zbj<6EIngRg1A^t#JE!M41wJ1T!}>*o+d@>di{{e){p~ zKzJ}L?p2q0F+v3UOXfE7Fw?=$G$wOQj=c%7$s@#*SS3_)l`snR%UC7+vmNElSomkN z`kY*jH&M_y%ZJXOIPWD?#gn zEbd>#TYnEZV(L&OZ+#wy-;sr|o`XjQ>f+Vk%qxRxTQRjL zv;%5<17rIlQS~=-zr_>H8iPnr}mC$S5?;= zdpxRIhq*%LNW(Kybwc~vQ9l>Q;PDnmXe4g%&&@mR2rrAj>(NdjyzbE_)xJA-GIG>TDK3v&U?;5d7`osz4fQqLpSt= z4WA8`4WIXBV-p}ykFDRaIj+4M6yOBXqMQb%!>q>-Zq)xM4@P^6a^CDs%}GZeY1Ic; z@B8B58kKry_V!p+4~brRqvu4Vi=l0fq3^NFszo~#|8`UXB@^H7ym#Gs)I$><-sTg{ zchsK|3j#h+x?26g?Ds*b1a)cKEhQg`zj5IkPRem; zJHq$ItG~MYB(|px9C@{M+hcj|x({4=+swscwX*}Y z#rtvcDbJ}iv_A+bYA~6);;-QWPOi$JR2%&ZY^34q7Z2P)S|+qzOeIOEqiwVlCByF} zcKW8iqln^(x43=W>Wn z!2!o#alkQ99B_EIMt_Wp7Rd(CRqb7)Wjr+D(?Nd|9Scx#Z!voTHCYN!g14du(S9t1 zQfyOypM`usOCd_|5`zB?PajyP*PGGB(M^9#N7g(OSy>l~M?_ZeEzAhfJwU&>)tS95 zp8GSAr34>i${JKI`Gzpt(%{NOm=gQ}!H)&_5s=n5YeAJv`3?-grX%g#tOex|d^x}^ zq=ksI$sI>5`Qe{rYvL+Qanb2nO8##(TN82TJRUtC;O6O1^f}laG>H$GwQgcKv@K5D z5IrSpkz<(0Zcwlw4u|%d0|woI)S9d%mJs@7KnsKa*?Vu*ec76}9fy$72az(J+}|0O zt!d8?{2CTS8p~c#ZPtQjGvy!_#FR-S{~uWk8bk2iq(^bilXdWZG$&h&j$z6bNSRJ1 z1z8Jv4@;xy0)S_BkbI8ifvlzcp2^6rWJ~ZI3w!5xW3wUcUc#ONSTZ#5czGl>v@Lom z=)&B)szZesBwCIjQ~5#(`~Yd9zrxQEkg((4Y)Hswk$=Q>m~9QrZX- z`DN#&ulzV$oxkM!N=vc)N#mtoT#>EH8wmXaKqtoVgRdgwCHx#=GP*iz$@em^Q;=8s zWOR4dqE&+L*}>Zy;zT7n97`#aUO9u#7sKv~?)=ISTrje{{GCA(@?E+ zzVYnk*%0_3!G{2xa_6XqCb+b>q6_d{O?h$lF+Lz`$(J?aN2Oqn#stFo3{Nbu(X zegxL|Uq8y$#Mk(mla~dhtUoV;leM5*nX(@XO5guvE$9-0{|%jH zQN)A7E`eYJ|6_`H7mq(h|MA`t(e;!6$c8RHM;jfBYNey=S0l5bYZk#z0C-g-dYDgX zYOkBS-{{rtkjL$du0*q}GmsN9&p@JQA|A&e(UVh}FW<2igJMD>?owsWMgQz9;_Xh% zMogJL8;P*2YwwwNWy44q8AUI89~fcEBudq)vti^$f)@bXY^%7YG*TRq4>Q%ETwyP` zro1spCA&yMGg%yKLM!g98#sK8JW6KkZDl&={}(v!s*R z7YvYVhlKrUZ|D|Pmlun0$p}}iVXI2p444|b@3&jjdC)YnYI$E82PBSx1V zr2Lu2^$Oj2U%Q8P@GMK3S*pQW#JFrvjxAQnq!XD`neSY}pJn`6!5`cj zdJWe5m&iopR~WsK!W5Hf8*m3Q_$720ob}_b64q4%jr3JTpvPwSjVv$o6v5iMJsuh3 z8+m$}_v=*>@V zUXDa2*tqcI0eR!X?$UfIv33r9!`>AX7tm{kRe7kQy+_O1+7mO;SePZ8h0nzB7K;H|}(D==FND{NsWbVEnuvqH`jsfKa);4^5SpVTZ!i zS~G)_0W8Cg#s_dhstxr9lc~701}W!uraiV0?U()F(OtcgRaC-@aN=XH536B74q(c;Sxl9ouM!bbcPz37wl}GsMc+FX*X4vH0#pWkV>ObnWMNnAo9HZcZodF z_?a%fK_Uz))qg}w$$pi<9afv=cHmoJ>!rTgu?0)2Vb&B^=%Mv?3#ukw_%m=eX^k>5 zpztQM_GPROs?VY1()QQlj1{h0JxqNF;FhvntD=rBO`txhsxY=HtNI7jB`FK2xuCgUB{laO zK+5Jeq%?Q%3Co4q)!=ZnzJ_o7392geK$C!P{MEu{1JDq2PYAnDfZ5fs@MTL5Yr#AWu9rCQP!*&gRp9 z(09Xoe$aQrdw!!_aal9yyK#sJtE}Ci(02nU^xXgotE>W)cNt8K;#0xCZVguA!#`I% z*bb-N_msF`hz=0^K~U0Ayzc!a72aO2)m}4Mvsr3wcmgh%JHCvzqZwe97OR=aqoi7J z>Tn|>{&&XorS*yN_b(gMKmTrrEXkJ-V7uG)!Uq22TKNRRXj`F03fOXB;yc@5{;hp&raY z>>TZl)lA@9Lu+-gJLqf~A0DV+Ny53n8Op!RJya|<%%sq=#p;7A9wmGxQkYeA);}fI z1obP$O#2-c9>!zA!*OkcGbA$#iHxwgIL=&LV47u(qQAFR6-MbV<(;1733ym9i|2fX zTV3Cc=iH5EW#c(`eM(fye;CV%38)J$_55QFI1VbnwK}%Zv|-*LRuB40PNEhX>l?Uq zaEBdum{JRhrNbpikzDhgsITOfkF)0AiOsA=k=fWxcLjN=XT4ZDh-%W~>Zz(&I>@T( zAdv1X5^b#2gKVQyHqLA+Za6|u6lT;1C8lpBF?|={jGYSxIT2qv9xAl3fwWRA7&5N) zLAl zo!)z3WFvLHwfi;~J455H!uCC7kK%P@Y~B3_knL5drd?md>qmxdr`R;77IADw5ys5c zgM8GkL0UWCW1aB|5u9CUFBli!kfpXQX>}EQb|Ft{8V$;IYf+>2oGevX9BUDIW7lI9 zyB2)S(regqeP&roa4G;|i<6~Q%>VNtnfb$%EMTKI;YSGfdMM`Rti|j(jHKmAnk?O8 zN&c)QMF{>6{G`sFQ75F_M{488*JW$tY~}{Tp(#Q+7Tzms;bRCs2R}z@=KWbqDrC}8 zEQ$Qi6n3$s$1AcS^xZ=M?+@^_W?s1O$jvJT+_KHxT?`{2Zy7 zk7O2SxXzkw;V0PRdOsLr?K@6FA^dNrZJqddw206?~ z;T5-wu_NJ-choz)OE8cBxE4BB!av#juroCIZfIw9RY347z8QCsDViErKiEAsG*~q`HY}aF`NH3L z=+8CR;<>nXvoL6W9g|~^Z*x|+EB?E100+&karNbAj185aYJxoF|jt2_F`N?KzD;;SOH`h?<{ zm2eu9(IKjTV_8~3>Vl0NqR6FIpIXTTHx75{Q)|@L{PK}V=hh~d7pkq0%GJQ<(kG~H z?S}GFhLouy4P6_>HsN$Ymx&W_b{TTFqf?=BTZKavxAU7lCf=@$wMd3|oS4 zfO%+-lnbe*{wTp1wG7`yX4G=H@sNR)Y6ZNHm{E-~iiw#jg74#I)MgpQG8ol{?~`U! zyNp_9Ms?u(j2UIXjj~uIQ+49|f*G|>MzMHC*)RZJHlyS+?NQc-Q5+i^%_y$sthaIy z#r4T6W|Wxq^+#Dzrm95LU(BfCaGTTtf~YXmO`wGZ8*31pMh?ikgBj46zz}Q=0W|}I z3gm$|%C63Zm_&K;x_sru@x4eO?<0RlfYeBEFYf@*I($c)hKlk!2y%zv67i+;j)gGmyl@G*GKVBwG?Q2{q9hr$Aa zEG{zR*ljhYo4q^SbT5OOf7+sQ_7Rev1t2NyWWS_%18cy~%oHcN= zyWyN>b~P4D%z-_P(5Y~;cj252rz)LS!#PPhC&4*QI%gt>8E|4<#2jYI(A(ggC7rjx zIY&BghSMjVGvEwK=N#m)1WxP@n8Q*TdJmk-q|*cEa_O86=L+eZ1!tph)`yT1nMB~j zHi?;RmJti3uTA;_($_A14@zH$^!cREkUn-YGVFv8RLl(b$%sd#&jySuFV;UIeTCBZ zGwCaqKGF=*mBOdjKLZats|-H=A)-P=kZj|L|g>;H=jsYa!Cp>?b9@bB<=RiSBq44wr!jQZe9+NgG&eZD*5e^`}=B(G}OHYOH z5XFe$n+$sWV3~Y4JSHX7i11PgqzcbK>6s)v#nLlPc+Qo{XTVb^Yc*4ZS4f~)!c#6i zbA+c%dVIno-roc-f(Ifx)@q3eA1;BG3XgcL7lTE3DrL-a;h}*Jw0#9U*mE*@qX<_e zP(*kf(z983YNV%4cy5r%+u?ysn#nsv_%sP*2+w5c=@gzx(z8!^?v%;d>HTE#LOAvM znG&d2cz9}oj7x=QhV+yP&s>?j0v;SS5vWpx&yhgGg~ua3HNrDXdQ{(DG zUuokS0&a8GG>%^@X3S*>>S4xAOq5RL#Yg{u+;E<#y!h*9;KK7Xi~odg_9+u@E3H6e z>a2;kgBlT-GI2WfMH*zo*aoe@~y-L;bH! zpV_9)NJ;wCiAiwra!gLfTdR7SLLtwDk~ujz&+&?(pX{zB$$u7oC3NVf zy0pLAwJw)-&{-AtkJ^B=HYKnfsn->wBc-JgPQ-f}X$0 z_QC^Dnu~a@w0HUV(tDZbVz>6GOJBj2bo~h&%A-b?cQSl{{8bqu|;-$=}c_2@Xn5` z)TWWuRFFE8=Geb*XkWo@Pn)Z?8MTB?v-2;lBxIYxo3?mcB=hmub?>8TYa?sN*o+u- zH=@TP-EGRL4nD;q$DhOxMq!0`+?!f?c%8-BRuyq+8z<-&eJq>a<@t%rzc#|sJhwRY zKXK#f(DpQOzk;KrcC${XUWZ$|1XcS8y@+ey^EzzaK2|m{D3p3}Ff=dX)>jb^zQufA z(`P7n3<0?b&SLxy`#-*-Eg<-C$3lu_UGa^s1qXddq%7jiO|TWiexrT5{f6lq7@yi6 z`?c4o3qB)l)M^`XNu0;c=yp6=Mr zC??FTqor`0RC+cbbn)7a|C{~c@x7D@Tm3udtNOrKNj*YJnFE=ES{EkP)#`eZj|Y|f z8L2?T?*ykeBfOugeE;HQhETxC&7SHPIJAKyrDVdEirzJm)XHwLMMvY;jF3Y_^jYu~ zP@9EKu*E@L4{|Vsqs7A8pe$H4ZN{!iws{*nJ6wn3zJ)C&;ZQTjz9O4S!jd~d-GNT}ZG zLSq<@1AD(zH7Suck*kRwN-2B{3O5^H2`A_dtjVMWRbS24gTi41c8Z{phZ*1q&7KLB z1Ss2G%MJk}yF&FJhMZ3SxvANaTU)4SU4_sxv6FFp-Y!#B)7q&9z;U++GyqN_RA)7!W6a0u>rNdT)+Wx-Cf-8kQs~>78@l$6SRQ^bSc^S3B&4Vu3nxc?%WVu~?6!8W$Mp&|nNN$e1O=(Y~XyXEF6g9!sTOK_rJzOWi@#CzX7oe^CoLbIc@WEoT-=8>&qq_|TdW_3+qFZYdRSy7CRI73 zw%68u952a5rCt7m`|V+8FNZP_PuPBpwbi+w%LT^gN?;JCh}!C>6r>aOMUASI?;elgb!Pk}G&jIPG3o=Ws1q<%|;i+Jk zZ~J%6SM`2>6_Zo-0>*mJvSKHGMP{n!n;bJFIHuN5cw=MJpky!}ixyDk>;V%rZ&*{C z3<7h}ACws_;0FW_MfE()Yi5Uja3PtNQ0s?=Fa@{#<8A>9>zYD(5FNosDXu9~iq%S0 zpH$=4XG~L$b*@m3#X4J?(uQooYOe(M=ey~n>}zM0I*@K)Im~KL!(!Su{XCniy2abi zrOz!dG`{x>^f?aY;f}YN*)vNd_HKbu5)^?){kk{@FMb$Bt9qfm%hA6g-*b;kcl0lA zwXvQ!sAs)Yz0Y`kJY+)r-gLb1y73{=}k>O$&{`ksL7c z!gxvRFo71C|D-~$0sSqN?&@92A~D+hbBb-As(8t%;Ds>ZlSn=X#&N#!oY=_rV-Xe- z)oAnfHg3bYQY<(AW&(1!G3Gej3Y0WuTne{EJf2(8GOooNYk*Kr3AfqtY#}}3{!2lp z{B+1qoBTvnzft4;0P5GI!17P?3+=uz)8yMjA_(eV%oHDzT?`xQJw{{zSVMT;ig?M} zm0;>LiEGkD3;d`n38H7Z5aYpKALg{LwvH=CzP7GrJnM#9@cKq*eZ=VH+qI)S2V6PQ zQP8K&9%^8OJtWeQVV44yj}H5G9zsRMYs6M0OxPmw91(c{k$mqfk+RTp79wd7nx*9W zb{%3VdvhbA5QZl}i$y+_BA-3ThY!akBFjW1Um*AG+<{2(Zk?<_{kS{I4~NFxu{_s1 z(XHQ3@>BvJpp7m)ACx_A8Y#FqUh=yO5`Kjc9kgt$aBsLeKxL2r4vzAoN;Use4n2ML2Cvqw1h4K<3tJHY?k?!&^vP5|Y&QH*? zHOQWi!s0lVEHl8oRIT8R@119h#xPA7zgb2B3O5OxkSaQbGmC%J3dGwy7sX2|3140C zTlhU^nw0W502?KDFIj>JwjT5HycNcSsEi48FLUe7+(>P2#*FU!X5{B$Bc+_`0}fL5 zQjGTpxg;R|eoQ~4tCH)Wr^x}bnc^&aK zxfWJ}9q3@)`O)%1&oq3RjRJp1o)TD#P{>|9BmMhwy~j|3;Ls{!m-zSPdHc~?VE1^x*V5-mE8(}2m}=X^5VNBf;8@MKbNYD-L9*7XFfC`X1Mj<6ZIPkOP$(rZv9pO zPCA3Yz%9CVh?03WMFq8yYk(2qfv-5QF9zy z>ei>D1X=G|{r9p;`88(sU3H%FTUd&!Up8Lz^e&5?Y5`|9(s#?{6^CW%qG`UH?>J<& zHm#Xx;uxR1up$>1*VVwO{|MM#Hy>}($sQQ004SSAvz@ms5m;Ok( zsIY!B24=oBRz_p2s>5Wq|$~^NXB{x(Ddip&-_Mz^K(aAUS~p(fnbfeYf_C-*e(}wM`*Q6ADI^~8IAg|Dq^qg z)(Zx(36yY!FRD?SKgoAjulF9W>I+2qda)`dx=l;aFbK|4LhW&kAKAT`ZNe(HFPM(#e5{WN?$&(-cWN_d;Bse#Vjq3VN9ZWTOo5>IF~-*FzvIWQUpd36 zJIZe{mR7>2ZHm$yQ0n?p%5!)Sj?1N`C zU2HMjY0LBWaarCA)0x((kRZ{1ac~9q5}S@a#H-bG$9h+7xy`QCqO2V)!KKjl!#eR( zJm~XOBVx@2u;mtkPw;bh-LtH2ykvPrHNSu%&l;@;c{Yjx3C8G91f@ei}KX&LT}QLuYHM#`hpQ2>b~XC{@}RYM`5JE>r{=p8AyKM2+gpIc=pnRR z)yGfcW_^I~zOug98K4Ag)wxao!o*gs_NiN!n9&7F-1-2hl7c*lE%D0EZj_CT#18nB zT5a2yF2}JIIi7y7#OU%jV;TAG+|O`*m+)$}NTvjXtTklPoB_c4A)7W4uZD$)!^kg0 zU&s#Af;7A7U&CJ;Ub4b+9`|CHolAcxf{Z327fv9UY*fF!FyEE;rO3pTFF5*lLZ;y8 z-ywe6#4py5cKlLI{%&H=HyH*&xjPz;+xDZg0PO>k%3+c@iM{#S8lkvH1^UM|eEy`T&tfpz1G` z#rJ^@TZ33n#nB;_MDt!GT0IGy1F&&FvT;)dzvF||2{?^i_%HSBtx5I3W zaZEji_uwAm!PRMcwH=99FA*D$i!VT?5RiBWBs%B5QX`ky6eWek-?ju!H6VSEL2#1! zond}wnO`5id^>#!zApVm))NDcsZht6{AdrTsy1O#yyTH`U{Q*v7r?o?3~N`k_ST8A znI%Xk5`9401g@0; zwUW$m8^TSrNlvoo470!EC7;2GF8+K1x|nN8^e;1rmuwRe!UG9bt;zTVhv73_=^W;n z25=a;7=6sj-L0S3fPCX6^AQ56+Wclb(j7tWXckG=9{)?)7;fU$OcH>ssS_!!5gvF9 z_=b?db7S`;@Dn89Bv2!U6%^)~EqHir1cy}-gw+gjF(hMLm10O@`MSO@$CXSf`2XGw zHsq=VKW6vpn20{iQLA2s&c2+jptFyNjN31qf>ZZ0%K(;fxdvpzGb=use!YtGB#0{f zyE?`8R`KNCro0pJ?^ND0l$Rr53V697?+wf^A5_?!%DSJHVg7YgW5KhAvy)vJ7g^0q zXzscWSbi|-A3Yc!-4Zxc%v@&A_d1;tYodS$$4C^{-ovq)@uvzf`X@$z zJlBZc&fDwO&;J(bz~7n9mDlOk&+>`JVv!-HKS0oSVga@Kq69heYEbwZpGb zcmi%&K+bfOXuaxh6~J9*ZS~)07efp{96nuGV2koji|~JCJPLnp-WRn)KS99SGT?+z z#eD#^i{(ms3)R}9t?<^$X$Pp*nuXO~GG@Ex!t%;~i!tJCP>q=fjrK*z^!~*61RN3jdoVc9ebf)b$d*Vck3;p5ne(rZ>BW|%XvJyaN-jq6M1tYs}MpE-Ou>pI12w`QJJtVoCf zeb`YhO0c|&dT^!YyY%s`?;TAa6JP0lyy4{Ref-06^zrv06BkoLC(w;4p@0pt7M+iw zuT4Jm05VBkbl!=O=t@{Q!$Q(*kU2TDiZLR%(YIle{&$b2g||MO*}|QJF+a1sR32G> z1{xSfkBc@y9&2B7D}dr9e+E2`OuXmfTT`=k?Pt?J*gK6xZ?i^tjEt z0^{Lmwt05#ACSaILrHweqzbl@w&9d!2GTn({0Jf}NSFSBEB4b6fX@x`vj}Bl|2J0b z{{}&#YNF)wlR!uQ!#$s2{02(Qwbd)z&>NmX$!8b~yCYK1FsczD*BU!d#HvWDeY^%I z#LxS{OK4~3sWF&&_bRJa)}eYZwL?WMd?o>35F~fPx3|TIBJnaX+^s<_>B`_&!%j@6 z4*2AB+OP!e0&`Lk!lNpD^x!S{U0&v)pqdio8b0K?6N&W(X5;@xOtcLmNq96ST9FzP z?dU>H6r|R@iHVqbsd;$%XT*0*cOewEhbw`-+-&=bpNCdeC>2tgWc$_&2B z#%0@h?S@{(_7|v7P*cjE3jPe|kIJ8E*f7+S2Q}sL^U(==S7_SYsP0&2H z!g$F|r6fCfz9u9+V-e8EtpiR`&KV;`c11A!gF|a$>pW~3aDG8g951)-z&;M(dXUw_ zG*@AXqjSuJ{lO|ih%-8wl9MNW@i%dlikiUu6v?k^L)L?f57Q1VOxUD@ix0aGF3iZJ zgNqNl4=&8etOpk#rXF0Fph*W8A9f#Hn2|{b7aw*XT!=_K%NgXknKST_XJX=*>^cZG zs0V>A(C;tCYh;j&etLYjWb`GwL^F2U_m>*MxjO~+b6?jOyfsj*jhUg1xdq`o`eHa)ytXygUvg;=DdSeK%Kbsa6e?Aa^j) zKj4R$xC-wcV|UVYRZo~0G*Doo5}4pwS2rebh>53(gFFf|u>o%bVWOju+&B52cpdaTfN2?`{JqZ_ba z_*YQbpFpkAU*e}ntZgdIhP8W`?q>X?U@iJdHmr>&>?JG%Si2gpFk%PNbahWyd#X4w z=6HymG3I#2ZQ>9w%rp=t`bV*+c_P9*|0f)18E7%O2tPeyQmFGk{de!vlG*OX* zupQ8sk|gy_4s0g*@uoG5*R+67uVmU-Z_`1P3L^ReivCv+(H$5D(JA=p5pBNXv!QJm z)18c;6tq2wk(|l63kdrqsGew>s05#cSrgOhPd;8K0RC|KFDPHnnqTJ9d!dDe(38g^ zo2zRj#KRu8Jo*EqwB~Xur(TXVxU{;oA0Ukie!jJhy4z7Pkuq(vHdRr|yeXD0FG-a6 zB}=>umH*Zy{sSa0Ql^z?>BZ1cZ#B!Qp+(KFQ4UOy!u~Q%ke-TMbTF;`G zG@~fF?j{l+LNt-+nb7znIKOps&SDu%nO4SXhGCgwQPx^44=n3ELkDIfs`o+E(arc- z%cPRBU?etbxOZivt7i%R7=Bi><9jHn`M7K)&1TXYSrU^bm9%STwvxsW`~sH54)39) zYqOSA$fSP<-L7TQq>|=jE$LlAMmKSQWG)?6vm@<|BmrahfNahB6;uBdKcbwqgl{4^ zaafqOygQg;3d_UToS*~`!$h|jf#5Ud9#@}QNS1@W?sDMD+7Czn0!VYi{6t?afzu`6 z{gG>i1RP?I+b%f|`}2+Ql1~&N_P7>)&q_0^tC5wpbs38YYSM7)Lgr{({9~{}-Sk0& z#@8+IFtqPMMe;2ee(vc$f&n~0P(2((2r);E_(;3Bsi)aPi7%dJJ6}Ia8HcLv!~F^B z077Pt6H4ss)~|-x0*cZf8O=YT`g#l1BZF)Dv(p*~g7@n52Pt9j{Z5D%RPC3?%d|l4Bd`jS4xLSjqSfF7##~`Cr;qUNCsX~|@K^FpM+uvdggfvy1w*M)@w4q;P-n1Qjs5@H6rJ{Dqz%d?0Sc1w}MH(zqx3e?ur zd*7^ye8H(UrzY}AZhdWAXtSffo`%WFbL>#V^X<%a^w|v8AxEDr_#ANbdCd_L0B(6n z0A|aTzyU}!pn~brfhF+d#a|%<7i=6>y;-YYW?zkNfxb};Qy6X4!7epUoUg`lap9PH zw;~j=2cy@$3bg_IjMF_z={Wrsr3~ed2?2mm)2RKI2Bi{ek_k0!O#LDygn|foIU;$|<+RYRl_?l%9 zk||0_otY^L5zI1*@ikKrk}1^eDTbRVYPwSpk}2k7PchR>F{?WTA(>)%_7qFa6wA6( z5Rxg{v!~c>rfBO#mwv}D4}JF z8Qm!e$rMYorwExTmUO2eBvWk8o}$rA5$R4rNT%4AJ%wSW=)^SbQ%JHfQ4KK^N6cj$F_)F$ zG04N?LWGI0m%1ZuvvGN(DFR}Y!rQ?GLIK?aX|v#bZe3%f7{zbEAs!%50#LID|9zMg z>3MMrA4Qk5+kj_W%zb z;6GHIH0I5>5KxvV$EAI*Fs&eE)x%^_s`k2NJJF$i>C`%m!(g0guws69Xk88*NM7(R zSYPUWip;E}5axxI+HHGHiG(Nl|8fcS3H3`c8#1m4#bnRqdOs zZF4jitI`D&{dCKZ{5x|XGs@cnkSJKBPccx!P~MbTMW1!V-QRX-vJ{8pTRgau*ChuAt;!j{Zd4Udxr z^+;G0u1Lbl4K1YLCA3(`TNWeJEcLyem6W}(j^dtgU0;YphOoY-I3%;ap~IrSGfcul z9Ry7Mf}VsUqHCmZgbEUnial8OjNqBH&zTaGM^t7nU3<91Pc^Q{{Pp~dL# zth+>&vF`J6J|RZlkL?pw`dj%q-_+k!R zN#YBrEOWx(4&RzERBc*eHZeul0&ykYJ1IHirxF?8#f-W0l-v5AGA2YC`v<73D5Mcj zGe04X_#s@W(ukh2%p!H@uA=7$LgH{qlEk5>e6mOux~DfGW3Z-6>NdRzN>6J@vM|BO zeKTX8OUjMHfaKf)S#nDf7#J_SairXc)a2Y~L_EE2gfWEz#%)K+&B`cQ2=Fo1S!o%j zZTyV^nR$}CV5fgO)B%zvC70e?)fRH|>Cz`+!{3V2F=3O$_q5ocMlS_?@-}pO(l*o` z7TZuPYT9eD4TVLBHa>5U$rVdECGZ>?*%id~t~j={OW@I;7%1X!*u4N=JlQRH0r#fI z;kcC>Qny~{3S*6=mBvo6!=XJv5We}NH`tK4Hg9XKKIl89bm@cazUtxL-ge*pxf49+ zXRi8$B8NlUE3`Ts+HPnF{o=!euy))@O@%#Fjze{fw{YAFCcMt%X3&_Z#YMoKIcj(T z*K*3LV*jqg_P%d~irxBgZtY>>SJkiQYI8Yg%{Swiy{gp5r||nmar}0XL%Vwh{$nvK zmWs&-aBfYkBs1#^^1#9o8oYQW8H>hFV+-(_MjKVAIaZ8c8HZlWB->McNMPCDP3Zq$ zdyRI$U3b7g>ew^SgV5$?Q%du~{t@74@%`a3Pfjn9)A-TI>E6@+|`Y3$jfu4 zDh+Ocjd^2c%GpTSh?cW%o!8rMn!dq|_#Pr)t;0wX>8u)u+q2=G0cCD6nhqhzkY0M*tflhYooh_&w~oJXHs&bKeN6rOrJY7n~9*^?IL)VaHwK8qw%3 zM-Hwi721Vij94Bd0d`&5nuG+33o)U5;L=|ZmO-_N`;3e4f)3e%!%AQ<`hLNIeyE`m zC>HK6bi5MChZ|S$mB3U)`45yTfm-1>NeMXMSa9H00mi1$4twxdK$MUn*t-Jd!gw<7 z;{rr)V4ESlb-u?-1EebCPV;$!UU4+c`c*}=cl4|F8DD&k?ml|W$V*=knvui_Gj>;h zr95~BvL^aSw8jHF@@-K&T)ZLS?7LU08)vW6i9OWmx^Gvf-#?#Or-#t!M4fhjfI2;k z5Y(xUs1v0ZFM&~Ddyv2oukfT|NWZUxDB1?K_-}!tftl6u{|y*-YhNX5Gz~SfJZsBP zu!T@p-eK3!w~fufBI#0UqmWLO0A(~x6Tw&RY)5yEz#W~Jg^5$cy8!xR0mNA<>!bpz zq_4m?kv)i%-ISbeMh%vl=%jw4ld8}^FQKI5 zPWlx7tetdL>|1rxkN%uVGuI<;t5b|s?}KLULkO%(NP9fp%tzHen;yLww((Q!^{B0_ zq^Pyaq0QP_@Xe{`*??%9@$3&!F`n9#z-z%Y0!Gyea=_P&MHax{*|BCOn>BKApuL#F_sPy%>7R%E}EL`{5KjcKX3@?y!a;DTEAwfWL! zTXby?Yo}qwv;wCywfdA9 zYPg|8IH%Wur||L7TKz5+I{xp&37xDqw>G}rtzF&W)~++$+7CL7SC9`D5xCPTCtL6< z=5W-uzr0tVnMU#j4R3`wn(CA`tia0yz({cwdgKFcoi)pnuyqhNlg0;%sW^S}-Z?FF34P z1{ZmKVr`>pUyHTPVX?L`rGO1f00wPC=L&~5C4y_%Q#Lw6Q($qU8W$yNaQ+8Fxic}7 zyZrkODuFMcRtDE0&xQCs>^;ujweSi|2H4J0^)WgF@Q8?eA>6YfG)7#62z&iv!ge(S z`bh)=gqxZiB?!|FHt$^T&8mJk4ojfl{~FG^?2R^1%7Xig`EiGzEqk3x#qKf1t8*Bj z?Qzv%pU_bDve5pWfmRql1F~_B!=RQx2@_y<5M)$+n7-J3>z>&$-e&ydCMbDon}mgu z9XJb(oxg4w!*5Ose;)_3vE$b@GJJee`1X@n`0k?`bm#oB0q;nWw^4x7mre zz3v*TtaT5G+xIr_K(8yogFM^9mOs7)vGaGuY6+ye;+qg?_sz4Fd2s?5dEk=dkQW$I zo*eQ!h73p!S%Q%HUns%HnSY```rmqt)bW8p@R=0@OCGc{68eTr)`CbxU zsxz=4@REWBftM645HG~SqsVPtUr=&Y7xrT(U_WNE)-{#rg(e@`zq;&Hyn>-c5dTwf zF0dL#9aUFf@n2{>-pm5&t?P$EMBY#U*B|BJF_!NF8_>gymZh36i9GTH+(}}A5M(4GWe$igM6_?`y6%i>k}5gBJJ^>L zyr(<3I1wyqMuTO#i8En4t5r-GBtf%q+;(XLS_C0#6Q==ehA|aNnOyZgO>)!M5POoK zj5|RQ2ocmV18!Z=nMH!0ifrV!6y{h`;0ipa0FDHmLZ-74aHPn~1Tm*SO8zw_pT?nL z6r|c2(^s-i|DX18qF>1?tbVmRQ-gLS5xP`iXNJX4sB0ikf+UYzLe<`CSwKyPJfFth zV-0L0OhY(cL>H?gV_bz~5}yM3c;GcqUQROh@56J8_hMM`)#gpJun4EwmQn;zy4}a6 z$+vrA#SAV)uoY4Z|1|Wjv;OgN4j#NuY{Pvq`MyhZ5+L2$&Tfga5;(ialBVy6#f79N z7y&d>l=mj|<+djs_F~zWVwz3~HX&u2)GWEWyP zz<6>-M{M^aY3=UE6Y+e{UEscJc*YsVd-_-<#YRjBJBsm+b3nX<6C0Xz z1*Za2A?HP}-UJ$qW_7y_h7MG2WT?BuQ_xu#dfdaC>fP`r=2?>1Sg+^H!ek<5(;gw z=VS+1>%g*Q88UJY{VfyM)_sJVzAz~ya(W1vk7>z27ditSa0gO*Jb#vkO;5HZ12{tUuTp~*|Cw;Y81{D8DyaUX<6U&P- zV2X@574nn+NI^o%YC!9d7JaXj99Rro2UoSXX%q&ufpt;9k{Zac4iw`j)lSXTR2ig(I)ErYnZ*w z6&~5oQ&?X#thTo;q}0}R!sNC7gs4*90mwCt5K`9Wed5l0O4Pe0{|sC7=NN;&HKOZ1 z9uApsn4YfYJkN3Uc%iU45DDc%A2GfjLEg{fCH^NWFuIU;2R2}}T4%guHA1jfWwN7M zr9Z|T@;<>9qzs!okr$fz1#9@pW-(CDLIZ=#M4N{@`mR|57cB1TVp}b(CdP^qUdct$ zQTjYqJ{hX3)?S0#&?XY+YTtfJa*R{1SThI4n69CikDq#Aiz&x9PQ3AB& z8#@bdn+f;fHOYAeli*(GR9XeoFP|&HcqdrP+em2CU4>~tU(1rQI)Lp4AnP{V{>3L0 zZo;o#)Hc31UIDxKReZGC6}M^L7c4{&xLc%!O(SqIfFl$;6+|6XcW(U^_Sf1bH9T(> zx8x8KA?500(JjV{Xp3I-eUv*|bDy`0c4{Hsic`E*bUi~u?(>=`-ilMaRWvOT)Hf;K z9lmQtG@rY&Ip~?>rnaFVG_@U{Q20Ik>O~*BL{oR+lh#xMr#JO%T%JQy8Ff@m-SNw` zrZS~$>MK{XsrR7V%%;v_XlhgMN(7;)iFnb}L5Hd8Ue4K})4G2?@oLlhGInvZ$Xu^SGH7`jKra4a+Mu9K8G89AUqV2RO3g{9Sx z5lazMS_H-Q`eULGqMVi>v#_K{(LD$`;S=$z7abZakn#;aX-FY(I#R9x zaRMofIx3{>{Y4s`Go?hzM-z#Z#V9wE&O;1MMM^Lc1f(S51yYJIq`~wyYz9)k02y>6 zWeLhKC4)g8B^mSGsR*&5IzUJvKA~_Q{OU!YIR!$Z_@p6(!08A%A50SnVboC}z7ikFTpy%8$Mtn2{a zZvpd9e#qF^^C##vtUzdDX=(1_SDl=^vRn?IwX$49&c?4oLu&LJbrp z#x&$%HVVS^3%68lhqcBWW$`F55jU(xuxWC46@b-%ji|p|`N}1D*fXflg2O$nzC+;7 z*+flp`yy)%(c&zWVJ^juKe0V?zH!YT&0%lxI5s)siYU$ z=U4VIi@^e1u3ldt#{3)lV(TDqzLF(dE7PB@$>$2PHMj(A0Y+`nN2t%JwWgxbxB!{R z!K(u@9>zJSAWaG%e-E`Z3)doxx`sId z*8=6%wr4viM)oFD)d-dsCf!>5y)EWm2!?OiQ9uh}Y|*jEeBESFy_HWM>{^+y6km-< ziTuRT9f`3J78@h6Q?Qc1kOUDAvZ%P&YDNzpCMHGU<|Z`yJXl30?gl}BHF{bs9=|YR z%H={h5*CsHr?zn|sT2ioN6yB*SU9kf*O&qXh%Zbk2T2hEH^v%ZWAmuyu+x_i>BMaG zH{i&JH~0<|%w3X^b4!pJpWhOEAD;_af`7xu7JCRX0Q7Xw08&#h_QIHMjAfwn7fF%X z(Rph(ggi8hE<_1f7Q7t6vfv%Gzk6A5ABK#zENFwGvN02Vk-Q)1d`&D1_Tdu>e}iAW z=&z&1vfxd8(v}4TPG1(Bz+sJ37epNuN?%``wk%*uxh!}YRo9DdL%EsDf*A}=T^3AF z1Yuc_h!@L(kD<2QeQFDiX`R>xF5QLB*vPZd^GA21<|Bjxf%mTi0v`pjcO!5(>SQ7C zA>?YD4eTc)umjb{y2`*O6yA+rz37pV0)Y?XlZHS7rz7xfay94%AnK?PxHz1KK&F%k zydPE9i_S#3nFu_Up{WQQoCpE}6Y&CpPlCr;TPP*?-&jFq?sy`96LNs#QGa_Q?jt64 zDK;#~6BrMU-igt(9XWIdjbl&?g8sRFz;JAeT}iKd*k2|OhE4;NFoYtC?AiR*U?X`K z{v6s)W8b@fMUfwnKU2L*qCsXgC9Zai-w$ zOnp>c`@D{IfwFF&EBq+8tk8w)Q`LoOYay**8nw^yq`?FI(sUa!|0&8zIrDMpGK+AS zrS~kFGU_XMp4v`i07I<{>7oZ{3*lq)KxVy|Tj`oATpC?Wb zYWf^yH&!CTB&aeK21^xZit-7bVL|e=lvdG7@B&0yO)w8-{x_PS^wb2}Ir!&IXglKw zO&E(vvk6Y3wm|vmq0_Mfk7(h8U%*fuj-84J-IO+b_UH1A%8RFXt z133c~&HZap^rX97SjAnM7h-ev&yKn+SsC6A@&NGFjmPqQb0d4XWyI zu90<@V|f**F#3t?W zg{)be*;5u$3|Hel-K3#jH9@4mU z=S;z=27{-NKY3>3H`jZLNjN@OFOo#%i_L)Rav(h?HWi0+hX{QyV;Pnk8{KqyF6#A9 zInc4FNje9TCDdRPECn95^%xaAMnnlXFMjS61T|AozMLIjFGg-xbD?)&S939M)aRp) zk{oJ0d=Ddy%$Gq|Ei1ZO7P651rhJr%bIGoSf+b|b-t-=_z&u##)HaK&#aExp*Ha;NMJ34b))?apjZ8}N~> zJ!WE*oadR?^wm*yMgV!Gb%vRZRdpp;KpjEsNKq%;Z&L!3p-X||3p8{qgLo0ondlXC z2pV-JDdPFuC|4et4N!V$0J6&SPE2G~=p6)m1?=VgM5cMq=SBaJHPa^4G8=W}pf9plS;zwZDR0Vg6I zDYpQCo+1E|05Q|=!q}=`$Z@nh$2$nmE0vghq1+cSdIJHT;{p-S>1Kk0rUKMHb{>L= z>?9&S5l85Go^~^^m$-i!D?rhnK8a$h(6;p)=;vpm#tXZAS&@h&n6p?xd+04(!O!tr z#=b#2ay=Jdmd%EwiXJla?*rG~T|uInjuYVR9z5j+R8PZiu19SebyS4A4MR7WuaBh04`lF$VyB9fy^6cWl{)}1TW7K zODw5-F-SjoW#k;(&%w=&TBO2#9`DJ~lK`Thyv&O5$p}0%hj0jST$-o}YM}%=StWC^ z?iuB3!cA|nTz7}BkHcib-C2mQ?L^eh2`r_zANei*0+BB5*E0}pvK*g>yqp)%U{w{% z*L^4vdy;`q@as|>@5ML!_w~Ma3}@C(u{7ETlcZyERK?LAQ@hsZddB#+_+GMsOJW_& zjJXmvaT_}u5~BRrY4|OSC0lqE>Lp)Fb1XlEX+G46`a99Dkeb8?$|>}WXtE=$5zBN7 z2iX^`AJE`m>T=f^*bZ|h>vLfsLeA*u8_(e7K2Iqs$&%9Q8=IZL@}T84o{~lpuL)3> zCYlwSn4BEv=w@>dqt{|2mqgwD+T2Curq7P5j{9j^FSYq7Qn1|mUvs5jz5&+m%0N9nT(P9B zHc>}f2ZTQFnq{c4&3iGpG7M%AXoD{wFCB`MAT{O_?S*ixF!Pn*JOCrnawhT&H{(s{ z%$D7Vsx|g!;?(+C#d?nE+5k#j3osOGW`iJa|9q0UD7zjdu|mQZoBz*>j6pLk+a#T+ zbYHeKa6H&$tUOVV6Io~pn~rjmn;z?*TA;oD*JR+KcYQl+fK_frBGF#7|8jX?i+99P zQtVh%G7TkIxzc0@@|;P0eaj60F)&+(G}V9%XMKkZpUj$}um-F*%t^{{FX zThQo>QAf{}))>jf7=fiJ@WOV`KB8<<-rB)qgH{-VZP7-C;oA2Kd`(!eU0ZY+e!4dJ zL?+jmdu8(a0&YG}LC!@cG{tK%ujzpfpDi}CYkgrNx)(#HcC9b=TxG)G&VViEFtdaK z@XHd}T3L#v)#=H(fWzBj#mq$rf>3iPWMNr5>Ka^-FdnFcoKOEXm1e5jp&Fr&x`DyB zBe=R(QbogTvwVeRzOeO$ofj%&%av0KQ;yr(3Jar!nu{vou< zYb+Sck;wzD!@Zhp12U}?=%y+GKbo}ePE_3J7z!z_*2-r#eynQW9F@3lq4yPFNW|U1x@cug!tD`qKUQSFW7UISoAojzQ&Etb813MD!KrX zSXZ{Ord-Xv0kN!I>bjWXQ5e)?RgdOM-z)b}f*rw$jgX9nS5jbwY$(A69+*%3Eu4&+ zg~xiE@^&g$F3Q0g6ZF7&V!2NV{EoFYcNF=ajpb56vAWUP|;DXpw zjDUihj3TuI_`fA^qX}$`Lq}@C&G0(#d=Li~Y9BXv{1Z`TjuLoPy7Ih3%%Xj;gW`KyR>l;7cOS7tpOxTP$ZkWWy9>xWj<^w9*+STnL0nar zm?f-U-UXsWiQq&(!)#@iWfg=nxd=ci{P`@oyS8wjC__xWXv8p-ZCBO`p^DfTD?g2a zC316Ic`{~VUBsLjx5aIv3b3-lJ14M>r{J1fyV8 z)_)-1Gd8UarzG0&ATrLxS7sZc^H4bOB2JAw{eiDGHc<)8L&QV{2kPVHw8AKtmckF*eqtLecSxsU=;kkJCo=u zfJ?*H*(^<93ntW3vDJ@J0$ax@!7qu%ENy*}ZRP4Nt*x)0nbg)tWm}K&&Qw-~x1esQ z>{jt<*d{(tyn+w1=O`}o9NWCBu(_kS?|aQVOZ&F>eK)3{Rn5DK`)+Rju(a>izVAY8 zr3BALeSK>-BjJg7KRcs&h-pCHhk-GE7hAxq~j%gp7#*;X!ljy9L;WG+cW z_Jo0gA8*vyzfr+3{b?*ljl{6$uISDhMduWGCUrRW5^`{v`dq)EHr$<|(&8Q1h z*uo9V$ksy-%j;s-Av9a}UWaUp7il8?nmzgjqk%y`RQ#B~br7iA|1uEis)^+WI3^2l% zbA&$~?nzCNN={#Ag~lZVj*hSWUorQsTJf|FHKZ@KIIw{zDc>GUyG+66!(}R0J0w)Ga6(ozXio zqo@S67Nte)rmd10&`KcjW{Q`~sMTUyUpH$P?W-+qpBhnMCeehTLKcJoJ_sSgTrNd6 zlMpcT|NhQ7clMA#>HD|uML%TDJ^T7Q-}5`a-|u9A4FGFw9nc#J1($Pm`l*!8JdQie zspKid-b$0(;+;f5vHDFmi&99QT!x-XXcDL=>m~n-Sv0ONsaMb*`r)#kI>kU&Cgs4A zVt!IaQf}toMna%!NCsxC89*a0r&l@E7jt>b^V!dfMfee@%`-l-`tlR@;8)JaA_du_ z#X^L#2)}fo%&*O~Lr5HXfUYHSJ#RpfN!n4#gy!tz_9RDYM-d5)CgUU7N+FmE^@nkM zO)9<`Nh)!ln3yg(=1(c+g1*H39>u)8FEJf`j!9QSsZNo}^(2IoD(1>-(S(DF zDFl4}nq2RdQ~Qw8yD*{W6Km$Zw=aF-{c`G9@w-#q|0nxaxkHP}N z`?GV?Kyb=_xTZmH6qGOFxem<6T%f@2P@J|-!%;WzCar|j;f{>0=E;s z>`zpq_yLrBw@_t&(G0Os)Cwk`(QI`~XvISGKvLZEDDFJOMa77);5bkRm@npW84lF= zN+3of(7*gZkOUBpor53{2G1G%Sb*$)4dRdhIX)J#B;Q*Q+z!=@M54KPxa36|7+N~9 zR+%IpUgii_KAt=!LjGP7+K|wApN!C8a}|?A#cWoq)g7^izmVOm_EiYrCo*Esj^iy?BwE`g92i! zYaRohK~orV^IcC>Slmm-1(fl3s0zis#LT9cHpGnYx?8^#={j~2#9&!M*`gAjn69J4 zUg!XN#O%8Nf;(XjG$1qGLiMg4e&P;!lGG6XMt0U~Ym!c&OOXxlgKHs&A9}Kvysn_U zzJa_#xAzh=lVbh=6DV|XFEO`~sQ+1%=NH3H+>*ag%*m8zQ!g=>P|PgEj30pyF$K}5 z;>-iSBMya(%@TTw=o>A(Lh|LuG4mYu5QZD)Fa%&0UxJT>p|}ZY^;t9&Q+uh_0kl#l z`|zQmy~M1cnB5pIIlWf)-!%a514+s>lwn_*X1_Kl`6j^)eRKHF+oxYdg|9j5#JyKS zSsuZ#gqHUb(@8PQQF!P(y~G?%G4Ddm1QJ((j;2eDiZqOV-~gbwfH1S#Bnyo+>YtutaaoQUVoeZR9f=E`uYY) zuTu$RISZR56tx^jyV5)KM}M3ePf|Ct z$LSBJ?1)8_?RS#1#RCWI3PIVG5j4^w%=L2%0&m}r*oD=yvIS5+h}W^6q2nJTHF1Gv zz#h;IX2#UqA%2hbPAh3){G2G*7CM*crdngt-)^h{ig*>qnoh7CbkDSWFZE91mi!hp zS(41IhCa$=(*buSBRubj?eCq7P<`X|&|eUyTz!V*n~$v^xw{`ihD?Dm0d>gQ3v`HC zdPC;ae9!2q6TH@%8!{~>_q(iRjs0oH2-h6P~&btT;!3(%7qynjwQ zbn#`Zq%&P5ZFVP2`A%}mby{gX9c0mA7h;YcQGWcz-oXbF~0KCOzr{F~84lWYcqPPgBoas{3 ze+c?ZqTCG6tVq7=2c*jP<00|+vg?V@#)84Z^)XW9|2*kO%}v)|#~vDKU&T|K0jqZ6 z1!^XJsF&iC#4@Fd!EhxH$^cM0ef)YvG9{ZKLwd%?@O%q@BGn%Y7l-#>f{R!&MIKXr zIL)>qO}}R&awpkhlFWUji5_>usre;1V26(4+rYb#d@4L}YG8~|nB(_7fp5IFB>5ht z0I-XsiurJH31#UAUx8bHkb)xOPlI30^=7?_yd8~^`T@g#+<=%{@kdN2Qk8Q=*S@`o%oPA|*72@pgR$eoaPA4$Qn_53gt{uc< zYzQ}sv~l@W(m~<`>3a*OJWFBb*V_rwdjKbhPPwo_`Vp@s8KzIL=h|C-|3Aagg-P|b z-F2r^U8^?Xei1fXm#qa&=&1hV4k(M|RARTc=syFI^tCU#XX&7+*`AE4`QF>`HN9+F zzIS|hy$oI8_C?px*E#0b74&tc`E@?NJcrb+cukse@UA9gLQGB(VX;o8V*dz_r6bF_ zCU~=vWq5r-oiVDc>oWhXAdEK;z)M2F510m$y;J&8(E0X9AM*cDX<5s>Cljj89Xp+B z6W-!Wr&gq)6^o{;TbB+(v7*{jQPJ^nRXc}Ojn!%!)#_WZwc>KSC_q1klBte|@oOV# z0oeO(ke+FSL){7%DV>~)n4Bn;J;Mp@+ch82k z0~7%lcEJm{D_^QOj*J}s2k~gc@$C86!LtM_yW10SCm27kmq0pWo&m_Pk5GY;49L z%WeL#L){bhy9+;Ea4WoLxeC`y%cf(!P$6diZgkDEXOV+Tt(QBReRVF$QSY2v6|6;84*!g9o6>dW{G3YM7h81F{=uXg zXwl8`z^(dS*0*tJ`hrHk-QDrtGF!V^em~v}v{} ztu$@wF>Nqq#!hpFYiUAA75B1{Oi)?mgUIh!%I`({_$l=o=P>~j=`BtH>tyoez!`#l_TVU@IG89Ags z2Puk6yYTM=23gz_K6Mtpx4;Ygcdo*2X_*VXP6c4B>y7KtBUfT!NxnZLrAYntDs{W%_~+#F|Tau05-3vx~wH)X4UJHVv6Q7YBYSv47%0!E}K&4 zvTsbB+u_jZ(NqT}wC_gxqDew?>Pq_9f)5%Q41hVHzAIStZJytl#OhQ1F2v;%>kR~A zVkOXjTd{4HQ?0}Fa`HCNeEKuyldU7b$f}i*RhU+vJ-Zrx^_2)+oq;bGdL>F%ucxmF zU7bi@5xRN-zC4HQYL!V?R}l%Dfr8AsGQ#>B^kd%%>q?WbVqv9Qh^n?a)sLOQzo*AE zhJ+~=xlr=SQCE5`BvLi0;wVPmQLv5On-X=^@ogg!8&KD+(leXkKoNE|;81H4=<9AQ zlu|61mI1Oln+WXKYn|aLzFG#M6u7Wj7`axCW3@C;*8Z=Ktyhj^&%cUXYm{T=TA4uK zzcjyJGtOqDixb$=W_rem4;3vFr?mPLL!zNG4A~djgKuV2g!bU`xeHTdFYYK#)!B zv|mU|Mj*(Y-t8*fEiEIRPjibjrbS3+0NKQo&OgQYaMJm+s1Hb|M27v;YdD!izeXHp z?raoA|2m)vWp24sPy zK3G|pAMEm%5PN>!Fxe8l*2t>Xx0riF1j zjf7H3n7 zUGuDJajS>jW18jHa^dI6w5wZ;1x^*u>b4GWO0TS+mraPz_c|rOwR_JDKe}s z())|yG>{P`obEXTvAn~Ke7tpGb?>vf58&G~6j3Kk_Ybxpm2m;ZI9GlRV`K3QqMjOL ze1(3B!R~Wex1eAUC3(7krX?(QG`hwdLdu&|*QyreGE$zqK@M-wX0B=pSE)1opC}7g zwOBklWXio#t)mTjmTARDG;fPBkpIf%-H--aEIk!OnEZAbBESIVB;SIeJjlU8=IyhrawH2| ztn146;KyR!pt@UZYPPN-Gn;x1lZKD$?vm?erNyjpU}bU-Q-uR7lY5czyNn{ayk-%N zZfTo(5XA>~jw}b4Z?T2ydNiiClJ8bf53Ebng3WIuQ*2eUs~?KKR|7P50(vnczn@<8 z(~Ew3(N8Z-d@<9h9)M6BQ4OU9_@Wc|B8TurfW*O@K`-#Y4#yYk)V0CAgMuMRdb1Iy z5o{4KHt(0SD%oc22pZ?d0E((OKw(0OSI_j6LKIC_i(6F35h%Hhc6J2vL0T&bPOKDg zqF&1(lKXvt05h2A{Yrr+MDV=`eid-y&S*4byOPiZ@~$Lk0cgS_GgLtU95GfCu0Rag zzcd0Z4ubYFXt5pza%@3HuhjK~ExH-DXlK}>hDn0RO?&Lx18)FY>~f9Sfh19EG2b1* z79R?1@kf*=`)>ob_>g0ZZiX$o8Mf#?0k#+~`v*@$D&u^@7U!TG1}+Ao-v%1@;BP#% zkp1>)fEM+xF)dF2u!ZW(H-P;JT5OWT>oq%Up$1g@azKkWIJ9VwLJP+ct(c$%`<2VP zIJ8(x6_0@y>m=nb=oO5;S(VG7+7TH-+WJ-sa3RL%2}DO+hAt%IHsSP)!TD_rKJrmO zCGCtW1-=l;Za}iwoC#p86aYg+A%J1#KnP={Ko}yJ1o_N%2!zqa5XNmTH7F}P^U-?% z7c`X zR|9zSLkiIt={JE~2p*S(apHlt!rnY<74j|!-~dC3#o@)VPjwssAL>jtY8BMId~ti6 zaA1O1Jo$1*Z9W{8Su}+#_(LQ^*6>L132^O&rdAwl zd~~dFjoFGMjP{`2Tl6yI>{PoFjyA-QmHoFwk2bJOfuju!Cg5lTODa7cZKiP(*?M0hT4t%fi2jN{{k zDB#T%XB<0GARKZA2?x#v>Bs4mQ%{W`dlqGI;FMD%DPz%Bj4LMUHIXJzWI)H!fab>! zXo!eHM=hg9xyGHs>A4UIy%*vuA6ZxCQNrB#grtTQm%B`nisB;k{42Pb(Wc4VKB(pO|5&cOqA&rp~kYXmH>P4u!RPj1;?FgPNnQV~Y*usG3?~li1pb(58?Lgv@3Qh(7V$ ztJbPPTDpzFJ$c~u2KBt)?kwxkU?{76H#;tMU&v@#r&@0dw$gD5Ib_+b^})Saw(=H= z;;`1^XoVw{9c7fZ;LXN1y&bhCqEOtT8*s)AaLLWGvM07r!j&n;l=>u`YRnk%(_cld zXdt?w8z=z_Eo2Su9(Ex(*%mb4S`*xB4elIHt+h6wy=c4H@Ew|D1@vhWhC%h;=`GC7{<&U;F86KYgYB8IEc!NJ~5vxO`1#C)kK#3}D)5VcsGnnf?3G(ttii%@aAoQe_{LM7pbe*mBc_l&mI zithNQ!P7&ivVf<1;EWsC5(gd1&HkVRc#6R^Mp8hE69qq-qYHWmr_|C0Yb~Iu+1&p@ zXiB3Lxn($+^Z%t0650t8nsolpp!0wE?(iUfgzGy8z(S|NCpE zKtBfnt2Nbn)cZLA{TzUQZ4N*m`KwX-S~jMiz7o5(p99d(0f>dK{T$YQ4r>YyYYO_B zbp9V40k2tOlh6MdIRA6#iep_*9DqLH)P4>?KL;QsNbTnU^yP}Gp965(@8eQkP9<;v zlJq}jLZ2>4;BX1JZ(Kn6IS^0?D9hSNTpmK~r(O>3&3C9xc6F13?h1G1shflQ^V9~q zFI1awy=b>?$MvGPGz{*-Eu#&Wh~>NJ4iOHAwb{n+5v|Agufw|4+GU44d^ybNgcsY@ zZNa^xgGMgIzP%&BH5;l_r9pARuFl>FJqm1!#+`o6f*0sup{&SaDap2VR9ng*{yH=o zi^)s38RONX<<*uzcrhvpQ&vGeH@GL)Zry@RqH$I4C*YN)6p~IMU7|mLi%2einnK1z zzX_pCNSaK~iD)Fr#KfB7#hG-n*v5pJWWSa|lF1a3eha85g&`s_z;3j^-M;Z2{LWOnZFGBD>&dnkcs`u<;POXNPlnw8R--PHoeM7 zrx3o;<7K2Pdk|p~L!3f_iOWdy1_%kJW2THWY%=UJMUJ;6$ViW}siR1QXT)w?kwBi$znruwLi^rR#i=@0&K8R=>+z_d}_5+}ffx*m+F zt&ow15|fZ$5;D^Fk{pv@UshnA#OPP_Lcj7Z?5AIIKz|~nr=NbEjE+Y?{bB^TpML%G z=$Gv-r+Uz(u5|)mMI^XiAOOZBxPJu#27P?oVB26bMul)=FqCgsx084i(3V4O2HH}q ztVbb0NMfq{ndFvrJ=9?Y2D1eXA+ic_FPn8Oa2AvG>S7{aHtPr0PIYZLp7jkchB#(u zbZ~DjcI#{)uS_M7W?bX{D+62I3~Xg}1R2&sP!@#Hx*a66nOj~(AS<|^;FWbfE^t1< zzm`|elqyIl76Rk90y)x6oSPsVBw-X zxeyy~i-?W$qDT-uhhK>^{Y}K=;^U|Ysso+X9)!q)xb?N*wV+&X>v5Y&`f2oQ3SU397Ny0BGfT=F z=oKbJ&Z{DX$bJ>s2x5S1iRg()}2s@Jf{aC@*GsY2pLHg5StVi;cQ~Xh>;Tp<6`6+ z5j!98`YJ{a*ptJa)wHRTbsrMO^?QlUsc^Y>ys(g>pGl0oE*Z(@@VjbWOH+`1V-JGl zW{qJwlL?ZeMw7W9IZMy4l9|&KbWGyM5j|^kX#=5@5<|}-9Jz59nH;$|dbUHY0zGR5 zJ=;R`tj5|P=-FqWXFId38;FY8U}zeo%Vw<;Gz>zlpkEOwR-0PK>6mpBqiyO2D~_o8 z=-_8W(MHnY#-;?*)Y5vQ4#mxOXv-Qi{7Zmf z?CT?sf;w2*r%;Ms+^o7kAzgruV64PCqa-A;9>i>f#JVX1k}M6Bqd$nHZH6aH1Lf!r zgd-zbNm9ktF_GiMftVl=r+WHmL=qC~&!&)AM`4`MHK1}SWPphNS>&eOc5R^#bgtVq zrX5L4I(N`m>{hE2=-gYB0+w)`V+5Uxh^ym}32}8CGC7@VFb|oW&XKhGl}JR=>f5{* zp%_%1NvrdYW76u}$)(i~+SP-gc#u|~c_r7#?Q;4DFHl`RaoQBpl#$b>kDoS~v^qa+ zme$)f4DBF|JLK|kYH9UaNjV?=WK(uVqUu4>AyHYNhQ5fZGtFNvst(;Y6Y)5#YfVx0by%5Lpc{31)>L(1 z)z|BtsC}#~P;JT0BnuSjkkrCJ=#bRHK%BtpZy;B@HhUvFfn?Q*p%pZ&!9BwmUkmc; zj%K@c2MMsZLSTL8Xls=Nj3`I5+3@=S>W~Oz&jwljT2iywod?wzqJD>vAdeHj;AeT( zgS^FpCblrn8lWA=b!fZ*c8BdCQeM`4C}a@(j8tP_4M|OllUu)^c!Z})&sX%*^FTg^ zK83^@F$5EfQ z{$^7{4SBM!ogqmfZWCE;+C6Hy)&rNV9JyT6FxWj5KKlNe26GMCrdfF1Ufl<&a_Dx zKIe!3p0!DJyQ;_I^FzSr^G_C^gC)W7Iq@WV#^+-gJ}1p~UN5dqYL0U%e7+lq5aCgL z&e;-No77C0Ec>0Kla?maCN(3a!sk!(+}SKkh0niHwYTl8VOu(*Sw~YAXOb8QY5o=rXZBB0WNUjuazG0KG2NiAqT8Qz!Ht zp@W43gx<^$IwJ<2|9ONitlZ%^Vc|{~AFjYh%>7p?dqHzRl=$_10Mwl9i;aXzmD-?g zQa6+KFJlu2_hebugZyT}P!gCb;IKf?7wWy>5UcAs8zs1ZG)RP1sYxRihxdqam%2_~ zgVM{W3cQyq6I9s2Oe0#oyzZ;<)HJn1bqA`2A zh^KeK)ka~jENWCF*=5bWSP>Gf|YtBbCKU6F9YrMzjlESzvD zA8WX57joq6kWVS^h+Pq8xNP@mYxk)cE+f4{GF(RMK7k(${%TB}Psw%}H!K3%West* z%TV2;F%_14WM&zQHihjnr3R)6*=qJ4(F^ci4!fs6q5Z=seUiuZ)2Dv=^p9Cp?59ub zw0`<@s`M$9{WMa_=C|+lpig8!Z4j=r!IiDT6LPf#pTL%d{gicNZj#$iSsyVsxlUlG zy@Z`IA-ibca$jBz>RpC^mSAW^L0D-yp2;y&O+mZBOvA&qFjOi%+X{LRK}^PkT9gdT zq#N!&pl-k1@u!Rv2T08Cy}8 z%OP$V8O9WtsYhdMz=7uQCf%cF>&zHiOwJWFLCWG}!un#2jW>f!0$s-i8O2SKF!p*n zY_Z|F`G8doa$9U%knyzIVq05ML{~km#&nyL+{?WiW6Lycu?16#GMe=jw%8o0ZLwih zLq=J@JP9w+`z8%?vcaG+5f0tmmk?$mgKV(1D+GdUuu_K$bQPSnLtxO^)WgK1gYY%u z(d}Xfye4)nWUW^ZfJKLcAO1l`2y8iav))Q^Y}Tq|CLOWp;`no4MY;6ANg4iGg8N4l zY*Th0FR$SQ?ci$^;2jpOR*r$1J%&}59$@ z6W5$^H~mBx>s)#}a6$)eIaN=`-g}GUF~=e~H3PGetF+r1)TryP=p- z2*Y;wH5iB27vfJ!0~wJ!aaeGpJ8@WWqdW2Hrd{emYm>MWk2BwPH(&=_+x56YfW8G^ z+6Reuvx_b5!+dEUAdL*L-(d`U4~(}3NbiC%ckI?$^Fq9e-3U82>K~x0g5MUPR>WF8 zDT%hF1eWmi-{X%RxB0>jn_X>$P6z2>LzRQsVxzn5P3GM;=bVAT-7NaibFZB=MjGu< z6Hx;UL+vuJwsA||VqR_U&$Dh}HLqbRBdqFZq|g^ZBgDn_R)h(On> zD0FS*(6zCtg+o`<5*#5{VF~Vb@O;_+)GRDb;pRDzkMI;X&)NDzDAEj11zT@IxM>XT z+Gt!9z%HDz;j#;8()A%;GqZxs&g=Km)fbQ}BGQ#JRSKJPj1A)k@PC>8^mQnoAh+aW zR^ir>4dX6m!?=;zFs_OM*N2zm#@PUHMUp6REsdVpKN9xSxm7pp3gcdKxO zj(f8TSH|;Z(<&8Wor7?*ElL*uV2E|r>9PtJv0Kb0+Nq-6V608Je+uU9rpeERK8`O0+^#e%qsxZ|I(q08c>?~^+ zQEJ9+I0hwvpq@o~v~;`OtsDb9)fs zM>H6O9z;pOrjUHUMNcAsBLALQ1&uJ~k5^GiMck5w7m^(5+wk@t|H3=3^-9%XI+T3T zv8AKg*7WzxG}xyjW%gZzoAx-Y{|)vE%7o}FP8rZ?f}Lv;F2aH=s2m0dGMA;5dq&T* zriY;`kW70M@C{0R(Z8{edRbO*oz1aZA>#y!_jrM+WVT_uPCp%Cj1 zM8IobxKcxmtCX4y`n|$dj>8&E<#nN6R+cXe=0W#hkJWD7iWq8_nJ-g7;J4{g1wDC$ z2p>q{kHL?V8a&|~fR9ZL+t?dsHk?n(7-i%;h(kSQeBG_S z?^He=fX7t5P@Vd_`)zi~zTE(S z_wP~uZuDY&x@ggj4(kqjQLd03jl+;6Lt@LkE-7etv<>hKMlZeD$U4!;f&16ojipe8s(S}dBH1h!*-Sw;-x2O{$cT-~K#JzwA~q5a`}Ax=%u9GoCg@_mD|J7Y zcfqMW(^5ooW)0BP!@)Wi@^jK##W+OQgU<>M;qK9DJ&x}-^<$g58MYk&!t4+f3H}}0 zIAAF30h923w3x<<7A@AQ%~~sD{79rdB6rVD?aW4ejFkrn(QF0Hm4hw$nB(f{Cc7{<3#xX z9eQ)q`Y64b%-yF#ZzPco(VJr*@hp3%H*fQp{|o5NEW$TQ2iCtu@QvltD81Pli*N4b z_-3uZH{gB(-+(U)eA5|=Z<>0>H$*sFiKc=?@&m5gi5*=4oXw!hqz|+`xOW(iv)FwJ z;ou_RIqV!J!f_V_65&lC3U8{Ez+ieiyc_UltF38&c@@JqK@;CV;i&i%lu5v*9JvD6 zK$76tO2RfA*qjMqQw1-MZ4N=gZ!6%8$fvZWAYixvYmA%AyBL}oCD4p|)b5`J9Fqa{ zOq=95WL#uom`=hlz%HTTJQD_DnC4_BbSF*dvH}$lxTSzp$GvR~HaP%hfF&$AIBJ=W z4>(a-#u3Nm;n&9m2^0gj^}Y1g~7wVWXf90JVSUAiQ%562;q2SNe5;vGq`Rb zAeC7kGEYYYhsOrOi3UNtxQ|$;#tET0fpywXgmv0eVx9KWjdh9>u?`wu-o?O9VFabr z)kTTV8{BOYAFHV^Os1!;k=~IjqoAj%!C^s|PT0 zw5W!bghk(*#?DmV5TD!d*sFzGeDfcrL(<@UkjL%?;x%PygDp^X1ChlY-)3l`7ru=@_J(qmv$xF z6zk??L)KOD(SzVlzh^91bcbLO^BfK4zYc2d7VAL-!wN+^J(E0TEJBS7;1lyqG8#X~ zxR?3>Ot^Lz8UI)h8C@p?j>q!5<3S6+QwNF6u}4@wG2qQl095P?1)S)9p5iuo34 zTn1{=`5qq?Itz=pkq6@NS7Kz~FCE+V@Ce3t;BFG``=f=HOro|S;_zRvz+5`t4PVOL zra7(-WX>gjx#mK&mcf#9kzVr6!>U06U*`odilu+VI=vi!%hcM2aPYJ9(mR9UG^Msk zX-)Tx1anF>wqvWaFsN*{U_}|3E9sa`uN5{o?Z*#Y9YbH(*0d9=DunsU=)sZTE!)u7vHtbx+b@D~^lgdwOrmcu ziU2|17K_hB`ZkUG_tUq3jK1XsdZBNFcmzh@4zFR6jg<6lH4EhQ?GN02()8^qUcmn) z`gRwTM-DJUH)<1fDe?O9b^>pVH~tew+-h8!WLMX^RCm4HQIiki=(!KFG*HCCHUo|u z3BZ7Y1E3M1-UH%{6I)PVPCzvW>CwXc17oZq7VemtkPOaH5%Hc49DJ&^F!^BQID>jV z1Z{w6QLdegdI=6WWRk%le-TxHDIEsnZU>Mn2*dORLvfNLy$&!=e0pGE1%fmT$2rt$ z#v%{y9PB_f8H%$t?cx0L(oY=L55VGPXGjvTn(R=6j6v>{R zkwAT=pRnX`v>3OLptOUt#D}xWNf!V2vy`d~bcf{FY+Pb1uOo;?r3ZIfQRm=i!&!QV zbp!JRMq`Y2CLv9Th9smX5&yjyr$;wf_@&Jx_(^BShIa>AWHntMhjTtYSBlS3_-wDr z=qc4ZBHAGi(S9R7cj1%CPj4ldMm9DwzlNZgVo{X1hb8HxS`Os)q{r0FfAcV^AI{2n zMYe_@oa8f+9lLVv*y2`?0@iW9xw8r8UOzxg^Wt@bF$Zi6++amaj$xoVta}ouE)3Ad zP~A~Nbw?rk3RD;NUOL@B6*sJ5VwwlM=OI7FW*$V{M6eD&fOTP)b%R~q03--lXWp%n zb+P-w6$W1%u&xKjIdRP+untdoGt;i@7c<<1b&tzyqJZhBq*SBvO6vf#G8a%D_+Zxy zzUL8WT#g1`{+s*8xP(_$}O2p%_9i-o(Lq) z{R-|zjz!2=svw;)2JM(&SsVZbw5tNNdz3@FB|IS`eJrliPby|*kj%9;fawuB&z=sk zw$3z2rWGkI>3F?5q7%^33_NR7>MdZ`fP2pnUQjD-Zu*Qwp&7zENC+?3wBJUzVtzTzESkk{q)syB5b@ z{F%%!@{(hIGEohW||iHI197=zj%?`KsDq{RIUv2Qv0(&N{9!t zm^LR;^MnLd%SdY%M$38tmZ+rPgmbM2rQfvYqBmr$d9ogD?RKiy7|$o`oA-Sy#2Cp-+Qy=%xXt3b_ZOz*&ZpR4Vs~%D!0!E?Q)$C(*565Tr%m$p zuzRt=pK#+_JW7M_NW)i@+$R~qc{6OhZOp?$r)3LRetExy=| zy_jw6(EVv0Y3-zq{m=TTttZA_W;e%SlK;*{W$y%*}Vk(9wWPlIg|>*x8@a^wex#o+gh#2Cp-x<~xZckd{E$L12ddmAKqpMc+c-n~r- zAHRF|8N&B<_f8Gr+4csB}U7gvHwLfDL-`nw;Bh$WYL38o}={&Qb^`>@0 zjpQi1TR6mYbqJ zq!rhYHOvVu9Yo2%+@V+SY&MpTf(9fBNL zZ5BoOvQnEtzn7J-W12eXDJ#z!Qe?pvtF?jGvGho6HMzp5=Ps@+D*09saj3bY+_XU+3=+l_@J3{MivVrLK^eEj(}=$f#Y~Y&89KPmE;$;E zvyl&F=gASub2-M%!Zi(9dak9(Q5Fu{@DwLfLH_Q5_ab?&c%7q#y#@J+ve4Ipw;(ld zi;SDdLA8!HeDDOG23e-bBoysL~$%selS%d_Nmit2qEQG+5X-`_8W&o6}!vMoZkran&`4_;RH;Sq)0 z%o4MpZCdF*wNooT0HYb`@-hrS8=24ED+ODIKyg`uwQQ|8glUW^VUymf4(`si;(&hy z&r=6?BF0{c-SrKDl&Zs8Z>>>_55QU~7*v?3ZHJ}rIockQzPI)vXQb7o^j4L3- z^giPUUCY`_*t7^38`qhMPH^k!!7 zicvW+H;W zW9Jr#;BpfYkT?)FnywcCErCJ+DM-F)b|?Z5%&n+7Rg7d>z@o?Hgn68XzWrYS92UiG z@{;lvnuXRexDo{pJC^rM7+x^LB7|XlT%IN0hyaJDMN~!@%t4qdJWbk=!^CJcsMhe4g|*hmBy+26kn_V6Sf7n7lHP=@A50L2y>9ksi08_J zuw8W=DX4>4!6J*7P<<_PdOq*i5p2mWuYC%_4pbU)0fcw&Q{4xQuR`z&Pydl8r8Zo+ z2SUZX=fe;Al5j+uCkK(TSny?VWiZ#6Gk`=PE<%}-xk5)2FRj7vJHjsqh3K#F zl!SAoirGBE1tJ0|rRgNDgWl&WnO=a?+#yg>hQ@IMAb$j#0)*R*uesHAPIe5~Mz?o3 z1}s4oyalkEY2BZzdG}ep2N2*HX#-6r#is$V$8MAC2aF3z(k~y`v4+IF339X9rt6{c z1I3W5*l99c9%Neg?hu^>4#?rPn#ru-HXRJm{J=w_>XWoz#}4v z)-hm}Q)iYr@j4t%1Y%!=s4uk1q_^CAFJvki>tP22#x?L#1BCuas1Iui`ja7Stq8|{ zYVGFxsP!mW0t%8G-|QBr^_Z+)t53vQHudd$UcZkP^sirT(2=d*&CkWH-+=h+asAfv z2yyH8KZRe9>-Xy-!vFR4`~7EoT))#qP>S_CMFi3M&FAiuT)$n~@SWC!3;_XAw51JeBHIWUtLp_93JAkRLf>bZg=Qj0o96d)mq&K(0!p~?(UU+8# z;Q`xvuEWvRu08^I+fl=iHB;)Y<{zHJwvKJV-Pz#c5)cNQ01q67ckw{hCopDi%(W@+ zrwL!m#JIy&evAR^G2}}{0AhPL62yKV5F0Tj!Uc#8*F~g$T}B*Y2C{c&5yE~1I6b}) zTgUrE4?GLtpoQfb0|%Ct#dC(1x%Fu*$25I40<_FJ{_z)lAPSqGv2j=P;OAM~*ZGH! z$K|X1aTcoE}Uwn)DFPzxyHva=nObllL}DBUQl z-Oi?+&M^lOjl*o4+HQQ8kL>_idIgrf!R?lOe?T5?|6^g-m<|VYtUf8$tHbYm( zPAb>|&spR@T#W@5(1EB0?LR-pGbFcECGC7`w7-7zb^3y^&?QV3CA)=ors= z^W{oYb%*igtI-e}Om~@8JD(&0C48}7<;pvkf>tkKLq%sL5#||$m>#c@Nk2KD$t;HP zu$C!t*Vm(^mP|HViHL1Kpsb86EprodA-^JID^cB&yvw11FpQIWxm3a zGE$*0rP%%-;BTT81}OmEP#X7f-Qe5Bl&KclAUc-s8cb z4{tKpDbWXoCH=Rd52ivg(?%YQJ%UT_J_q6;<9{L0!HwI z-P&O425yF-eQhKzA2-5Gjsung6EK7Wj0y%Kt^|kxJDu+D!JC8TFK+Xz#i!>WXeNp> zK|~Zi*a?dYwnOf7(9o&Cj`hj3~no?7g z5>nJEn^HrH-5gTX5TvLjlU3Ek{Db8uf)w2ekb)a+0aFk!O<&6(1+NG@2AQzJj)o=J z--I>1#zdwdO?FO0@~#BHP=dKQmgS>8o{5?S!%biZ)dM=_e#EV)4z%&F1)6zw8Bi>JE$v6 z81PXl-&2N9bg;>pKWf}3Uhx)I;_!&KiYRt9sO*GNEEo$`_dcr|tod!8;pkS-Y~=2% zlk6Kvv40z>)$lWVR6=LEkkGl&X59e$vr~zkkKVVH2PiEy*n4SDoOv#zbB2)7F>r)q zFZ_VVvv}UuWA$nvsiUBxBsO#oJLFrn%#!c3UNR%*9QrO&x0dIp#cm;`Q*W{`G+Al6pPd^LWyFxQTo9uZQS*n7bgd9%SL{bv=aV z^PbJd?5Fi0zI$H}n|MOwA6O624n2q)U+fZ52GxH?_J?s-{nPe`B6EM3T+n`k&4Km= zu|Y&6IBK0$zllmidquIE2Y$5KS~U1A+@$<}Ha~$*X`OVpHHb#BL4mi>={PP_WpoL66xQ zn9Aj8-Wu>;$LZS|9!S_42)xB@4R?DYOW``<>~$#|DTyux-p_})kGUAKdDo$5Id~&S zI!fk|-$&%Q0W-)*%}Hz(FDK%snKo!x-6@yvdlaSE)FTf`p9P$1H@$TO;Y`P`9+EaW zRZp|cUi@3mY|HrlkK&a`m*25A^t<5z zV%2udT_$U*C=jm%+LWUMJae$ie^o19t8@)mbeqz3SLrSAzFMmI0)SrW8tlz>YH70S z_?0n4>AKYm!-$TjWwrEGc&(r!dnoQI6lXm9&O}tsuI@pkfJ;5}wiTbDpG`gvYninU z|FW@V_(o|@EC5$`Pw18JAwUV|OBHvcY#J zZRYVXSdQ~$&HbG8=InYHb(G%x;kD>MrM26oxmQ@5Tw3v~WiQ_duMS!JX#k0zW)WPf zIs??lrT*|$tU%efO{#bp-|aVkD^04H2A5rZat{7IfK=b)F+69&Y^h6~o`tmJWmh|8 z|AQ?s+5=b&MQOVlCMGicTi-7GMyJ7F{ZyNQwvdYS*R6nFM)$Ro$4>T zj&&1JG2TtjQyw?YQExm!C&ibbIRdg$Nj1hu{us$IlB@A!2@PA;jiF2~?XE~^V^6j; zXYEaN+QT>`RATlD%wx>qpHeTHO;gLMYgr55j+D6+uFA7w3NEL9BgXm}1&y*gBTMEz z$>PM7qO=Z@)eWn$)F5+o)S-5UE~x1a$3-D&q;9*~6}tOJm?g0@DJC(!dfFV?{eD7P z_5w1@_-+lIotRjx0F;hwSOrK#BoO*_>O3Hz7~1?oLIr3+-f+k9u>LJr9d390Fv~M+ z%@A}J8!OCjOzo22A4C23gw94Z?1dHYqNn4hisvdmO}>LZIH_q;5C-SFDr8Hn6`J%m z4Tjk+93Mj;zL(H5t0@NWoU@Fe^F-$XMs z@6(|_yn8&XR)cPy1-j|-FDHMe_WdmVL&WAp$~O>i;m8`%M^1`0qRJ*Ye%0l7uLxDw zpnJC?iP#8I><8Ekim()&q;peRkF{A3OU_uc^sgB7*S~_(_m)tN1QbEbv~&e7kBG3} z54w1-R@_2_eKryHyFu4IUniQL1*_3cbs#6{HY^2zvPD@=^`=}_M2hUck(j;rWpvg7 zPWCE^%tt@5Pk4T6cAEQD&AT@A_&Y@N-*fodyt$|n8t^LBR40~)Q(2USYdE_KZ!<>( z*1P>TWjU1^RH=A{TRkWmE5m$kNPYi!*jS&~U%20pm3{fxGHK_eEwi4s%obc@&3CEo z)HGY!GmNx3v_E|llR3mry8-Vv?CNKsnYZz2Og0YP+A{(AA)-ppz6qjAj2N4015vd- zfGCMX)vdnBhy!m1Lu9Pf&`*&L6k}R6ThBu*OV8COlO3C&)aS_BCcXJ0ZF4TQ!(0q} zk*^A}J%(I|UIEZqZ1uvjI>HbkI+&unF@F2XNR#RJ&kL;N7Z$@O=mCHQyQPu0=BAbsna;+nPgcf5+dsVJfaUAf4yzpaTZxt2P zJ){<|ct~~s72XV0hBl2q7FHc=SED=G_EfyWrmdPtb8;akZA^-&`FFEUAheCTC8r?keO zkB% z{mWQuawDy=qli_a6P4QYs3Sw4zepu`=f`C`GbUTgN@N`xM>$ff7LOB-`D_ThS4CQs z;mxGhjCX3QsJ0=;#cY;*DRe0un81}Zk;N=F(mZKuwHb2)%gU3XRvW_$8Zi}EdJNh_ zHg!4G8WFQ7%d}`jnla=@|3wz?y>9IdvV7_W#lOwA^u-SlNS0jBc4~{V%38m$JGQW4kZu0#5>>7j6%qR{zD;b=a774*VC>2JOod-w)_D5@wMQ` zvD8ne3{a5(q96fLiagH)PR&o7&B`+Tp`Ga=o3zPC+xlUfw76pU3MA#OUqxKcMOBFhAtc{}6kU7=eR<<*ZIx45Zt@0MCtc56!g54@>s8eMv zG-zv}TI`5DM$jo)-~n+kf{#;M&M9l7RIv<*r|kO^E#926?@z)ZU?ILiuL#s|s!+J) zxFCQB$0iZLD2m=-HB~RKz(&m7& zQ)&uH?*_bsWyoEnH-v|O`n`)WEbrI&+5ns(o8ukeEbq=hB^F$WBe3jWMgDJ-N9g&B zj)gH-@j6`QohY4%mEp3h`$Z(SbpZCXAVKKLQDIuHLo^?K`T`3FU1x!Q>msBbiL~$w z8@ZWbWP2ffsF|7YUGpflq;O2MB`&nDuPr&d?=4w-VWcJgKZ%x1?V%+P=dqSpc}tYe z#q-gIyO4^tVW66M8{BIusOIGtL~H&7G_9{S|Jrx^JO*b*YhL@hsCi)zHUH~KR`a2e zG00LgUqm7!r#5pbeyIU#enb^tdw#Uy@6jyl}$za57nB#_m!WNorjoibKd z(zEnuXew%FY1hjB8?tQb6B#hlEo+GC#KEcnGFEPN*jQOhm;H}|Jy2j%IN5 zxo&kKYCWKOd#i zvvf#ICbSUMG+XG>tWN(E@F=9)T9-D+O+DaJtvcBRkMEe6WYjUn<7hrTNaVj&^qV$< z`WVsBo!2yP80EJw0nr7Q;fx<23mc~z%3d2!q-p4f(B{hYvkB!@{*(Enh{5X_CK-t*0t z%wjF!4b8y_pu#RTfGLYiY{Ofaj0J&6p)R#J0QNpJ=pUN$;xV9eH&prIp%n-8o7lRE z?q4zMWt>wDlYKPx1E>12Q$6C;24T5m;ol4_nWI=TccUct+#oF(H&)D9PSs(#L0Wx| zgRdAz7V$SnB9d|p%Vhy`V6}W14tZ|1&3}8F(v`blsJb<{cXWDFLzfK0>}qkI0h!yQ zQ#>JLhm~?iSn0w_*~eGP$9dOaF=_zQ=2CHBUDM3}l2e_H%l-_^wf{g|io>JW)EhH+ z6s)F_ET=YgESq5t#2Gf$h2`YNO1CLpSTIg44<6|6*?Hty(9X`X1$Dl_qPt@44?4A6 zw|_>~E$Ylsd2YXq6^1H=YrwXKvGBZGRQsr0c|w(&Kz|rm`4+4g*C?!*V4f`fxzjoK z#th0{EN+a73#geh4M84I1-IhN#Vb8Xi&)rWwG~4z@1fQ4o+;4zuEm3Va_fF~2zhR#Gg zT-xllxVZ?x=tZSVbF9#B!Af~3iGLAUFXj74mz2<&Hj=g&Vs-)Lx$E81>M3I#(rWwI z0ZyeGtLE#NowTobX_XXgW19*cEBL1JFn3{@+zOXn_0@yh1{IXBauloJBKTpy_~=nu z13uOMESEES}FNu6*RK57ATLeZqfB_&5;GV?nIzVt;lR4M&5*4 zr#3s+iT7F6cQZrqK{9L>Kg&D-x1jL{Es3}vbWSp!^I+1vywnTFjSIX#J0I(2M89iO6&AhLIe{&Hy}UAXZE z&KM6oax>^FNKiQF*79Jx0D$DH;{iyv5<+u^tKFJR^mRPwYZW1q!_K)5P<(9sg=+gh{oRD@P;|b~+>;}{` ztn;)q7luo8kV`$Ali@pvv|<3VTpAW+I`_OTaY~9s^Y}AZH2I7etLe95?YL>}&`v-( z+~yy)mUbb62zKqxT$r<}y^&E@>}+YC$@q&!^aiSK(;RrY;~1?UtE@bkh2!v3ply9x zK{0uP0=uz^IJI=Q|3+%0=sobyt1-6IF<}sj+UTU>l-MS|%*^bt&Q{>TAyDArKJ#-jk*#@{<*>!g7eM?o8|KGsh6pL2PQV+9IX%$`pn zt3}9hv7?M!zjCR+rDL?}2+&Qqy6SE^*r==Kke`pPX;k0C+^dLv$n5V7{B;!`mXsSW z#i{&KR1#aPZ7EJAZw79X-Wq%Zy=s(C7nW71r!!oG$n$pC%B~;habnBxj9WQ_{FN_e zI3?G|Yp%ry!?EDG1HihL(GK=oD$s@7vg>?bge$K{lmvnpGb%+kz~8$7hmrbBq^2?^ z;Cxok%L%WKD?+A)cx;9&xtb7vyGFHNMWuxrD^eFVb)4k0^EQ_}9hy3duJKk~4G(OS zE^Ua|Ecu;@GF#L@(xEso?6erpzW8>@1`vj3Jdho2o(*Gh#pW(T9 z>Z6`9Q}0CSC1&Y#(xTEw@q(Bzm?(4*4n_SB zR2h>vixTG}v9gNR31;hK=q;MJo@^5KsIXG!kt7LAFLyLkSnbWZ*#9jq$<>LOnO}SJ zU{WX!-H(jT3Azk<_IZM$T9x`sL%<77v2ve54R}MoghHY#cQpK?)9<&q((c2`U4&>c zt1IQo9nwQZ{uZgoC{d9Dwtnq#6*;Hpis*0U##Z?dSi&jmqCbmxsk&lEqz1HMN4w(D zxEj2KeEZN9B|Q}%L&OI1ikMX6O_am%GKyxG)|@y=_D;x&M2JP`_ZPAYN#B2>Bi-p8 zeVzvTkLe;m#T3{VY4^yuo-d7S_pguk*lztgpEY32N{TsA{wZ?VUZ<;045sbS2+F2BOv4a-!s9y`}~gh^*GjQJv^KsEe!3^C+Va z^WZx@RfTBgO|(he>bY#{cRiN~GChTf=I}lA{+m6yX67&WQQaXowo=`e3$K3-9n20FGJf(Az=}|x)UpoZ?JX?tp z;M*6ThydrK2z0DeF$T?oEl<|{1d#KUu5@oUFbVCm#wevLL-LL5puKh#ZMnuEu@j@` zG4b{HuxXw`MgQxmXhmOrGId31d@^lIM;K|78_RGCWRLolb5PEuDMdh=gje_ zRI!gaW_mKqx;)-FG-LSuO^cf`bJ}~HF*+%8N9XUAh?#l?J%xCw*6>Xzi4P~XoR}4~ z8K2R7w}0Mq4W0meipKme#7td-+Yv7w?aT+kW<7K-bD(4HU=DOuHR~Ak&`Rc*>B&Y9 zaZ9n7-PFYwI<iEFA%%7HI3el`(@<)?@uuN(lnPXAoeE3hz4 zCW?ABlw+S0q+#2Et?_|Ivaj>xW{=D3)~kYTFOZi zv*!)%p(1UOiU488Oki(ZMb7QHB09Z*8Ljf+Lp{_*e-80D<*!BFCate16UAPuvExZN zpt4`3lZaAh98u~7QF;OSClVzSHNSCQ6sfhMv_5aqd?c{1$05pxkexZ0Z=(D3^+4+2 zX9lMGGuGG`JJ9W4SX8gS3IBx6tuVHUB*R9;sgF%uaj@qmHl7=8BAK}^2#`oDJE`G^ z&PpnijZ~Kt+2-_}w+_hFVvLBosX|26??ybc13fXhzl_}b+=2SvuzEDM%px6uUA>|M zdpz53_QSyk|8cm$$fSKAYd1~ue*+#soZbtRt~}4VO4pY>c}mv=&sj>>*`70%t`VMW zrE8?*E212_u-2cUVXB1TZs;4PSzwr>zGRW0XvK8;0}G)ZEQE9Juys^(iuP3`O+nGd zMb7spINT3d7$s+)ds34#TNt#9wJ5SnhV_?09 zj2A!ad1h3C17IFgK1CUQAG;0+&GDT@@*M$CS?X9(5s)fc;O$h7gKf40o_Yg5&GuZ# z+ru~lZ^NIb@I44`jD)06hZCKj!k-Jjes9IA+}_FQMq@#k>fqGR>9QL{ex5p1o1@!}bBgYqtG z08W$}&?&~5sP>|4n)1ugB+*?TBZRLrbWI#Z8HTb=ib8Ub&hUr&6Sy})E}n(vr0|uZ zX6Oa*P)gupCle>G9bzcFV4p}g&_Oj12UX-@3B8Hk-<$!v;M3>U85i;D(y)kbVtes} z$k43r8#EijcyQu)mh|jo)QhciN?{HvoEDvw%lHV=WH6glQHHRSpn!kcmpq*2_|;=( zn63N*rS-X$yp4bdacwL|c4iwJ&}q7kHi4PK83z$!CjBU28xyoTDka~wXc(hu709Y@ z({sC#+#XPjiJ1LnvyLKHkVWz`TQ?f5>kECynU$@&TQKj483a;iD-3uIl6{)6Ne-_g z>R9NwcA)=;0g}BQVt14K+-dr^QFUMAqMOWmzD$J(cHJU$Ro`=Z4&6n~5ty>KU5gQf zuj~cId=!690f^o_KT5d^zn7YFQ@=g6B$~gWoC5)Ym~6+NzHE0q8tsIpZ=JSIcseHAg{LpuNio@8c>1#4`n_l; ztpDa|>jWhx+XbgD+e>4z%|CtFe*E2NC)9o8v~|Lwm~7{rzHBd!$@c8imu>wc(N1{p zq12tgq39R@BK^Bj@NqJCZr_e6<-Q(DIfZ@tte9*EoxW_}eK^`DD;`YUC#O)`2V=6m zr-y9$DbQBdb%9jj173yeVyWUuhFk+K)i;g+cUjjsiEDC~bzK6Rr)6E2N@KW_8mEG9($-Ts+FbM1xoi*9qN{#?q*zmfuB(+Bs)vi}Xb%$4T? zn$2oeZ`Pm`kQy5Hi7X=K0qJkw>cO))zc9m6 zaKl&n&nqhkCa3l28?H%BIbUuRvz``8;J8uT5z+g%bVQ`!Q2r}Z!)v`bt<4iUL2TEe zvZHR=)R8-=pa-!4+d}ZDqC* z(7Q9w562ob`D+-!iLJX;%thl|b5Z1aCvnnSU!v?yx3res`2EhyhP#Gni3?$qkg14H z2f9V!`cT(hkL|CB$lq^9OP#7{@!N&CL&ZJhgh292f*Ks`IkmUYY+)hPnzTD}GR@c| z&A^VYtX`2D-Da!_h%x6og5V4IwDihr$l)71Z-_$tCX6l}_D84YLn2pF^E0CNQF_?? zm=rDk93Vk+Gtn=?6)Q(*i%O5x7N1L`wt{kr1w1AhIku26$zk96NxO0$rjqf_56Ng( z^CxWX$+^qC5vovwHcOgochj`*Wqk>>7v-TH`qiP`J+Za6+s1cJnJ-b> zyYtW{zB;t$=b`;(7ihEAq~4PLwCEab&+9mXkQq8_K~2jERTY+FoIzX;)C;Aum>mxW zxr8uRs7VNS*3KO(!yM^~9}u6;4LDZTe7}{#cYOD&G2Wb$hw~J0cBUPCiC)`!V{28{ zUiX!ujpw1A`qiO5BM)u)SBLhs8(N95>e{c22-EY>PU-?J`+oLAuc{*|{(^$BhWU=; z>wIO<{6sfjC%T4ig*X*Aaf6)OR|H`fzXZ_#VD3)6WcsEBx3H=?MV`dtmZ%#AxlGHonone)F5yoB2^>KR4>EiWQ@RIzf%2)n{!yqe zVe6wHQ#^DVF&22D%;MyoxwTCoIhdu*j_GHI%n$VB^JQ&l!cn#K8&^B=66ypwb(R7I z2Wk2<63|t7m{@@`^qKpm1_5jA=~cDEimGb22efd5KJ%b__1F4~iUL|_byaG&x2kqp zQK7#!ROCr)icZoWwHZTEVmO$9|A6t^V_L&?kCbV(=Q0>WdS-Iv(#Iyn#o?!-fy__`BZtZcZ}p-lsQwP}H#71Nw(myChruE#kwGlJNlX zVZ&}OABn--u)7=Y+j(hTUdSRPzRsH=j8IE__aUM_5cRtyzKg!uug9CJ_}uWGM<-w- zn^N}=evy)?=zf24_+B>t2WzvV^qs%9`qjq3da3tC!*N_5hadjZD&A(UEa0PkFFrrn zcP1YDPTqCvin93fL-B)^Q)l4p{90@{zWXvO1+-;}!NTym_0-^ceuLHp01rx^v5~Cf z@yB^qw*R_>O?w6IT!F)TIe`;ObX~!TQt*8OC+#&ibk^eZMFR9Q0g`dwHL`&MHxf7@D8X{WbojSPkGWJ{#exO~3^OPEoweg7>Zi?j(T|ig(%K^eTZnKqDNYcZu&00=EIU_5@7@ zAgB1kSs#!h1bdgT>5ByJX96eax*+^90u%&52r6)05%jWE0G59SwqMD>IfTcM zLruZgSu@gqS_|AJfm77%67E+5_g8^aEZimBl>!$RPbKS@Wqz}IVIVn!vym-5wAq`< zNu-&F)tFRA?0CC>usB2#>Tbf4e-v`sif}hiDF7axS7`)%M7A&*2->F2o&gfR2*ckn zN=}>gdzSIiDXow->Hjb-*#E&53P43qgl`k@@txj=okd89``bte$?~L-x53HMC2kQV zO^pCP^to|MmPcPA%S~P3))pfi9XXl)u^{(-HgauQYo1Ypy+@bW7qvq67VQ7R-{mvN zqAhLBW4}nA$H=qfLI}t-+IG`c_4LQ|v{#$`j&vzEo4S3S>*mfn`6<=O&9QGYMV3W+ z#Mc#8F$3jy`qVjYhc~$$4t8(IT$QDjbXw^aDp%?>NEk}eWlaOovta4{BGS_c7h#%w zn0y*;5}*~G0p*e6Zvyl?fc(VogTb5RIOo*LFVn#mTWi=?PiZoWo&A6!PS`U%w0KfU3i!UFr7H2N#VS-q1E+=9gW3US&R z^;EYUiCQN@#(W)>POc1w{BB1;^5nTsi>U3SKRlnWFZRt`Cw&)Ix@ceU7R$v z*%Ps^ieM}bx*b3uj86KXYrvZhGpD-oDzjta#s=k`D(7$I_uQRRe60m-tEf> zec5dXbieT{LG??nWVQ!_YAK^W$CyXtd?8nk`yrYd0H2TOioPD~&_drGUoCz2yvd?( zjN-(vro*o9T_}B3&I06zMD-!u>HgBl1lBM_V$ikwU((|*U7QIAvnsg+AG%^tsA6j+ zKA+pBpE!J_S1UJK2*cp&>^Xp-@6fcJhVLVe*}fk19FXuR*3k3~V>|_{4hIpK0!Mr1 zZD&s9;Vx(Ro9TA5MaQGvXVZu6fZD_Z>TG>>p2P*WdS8CHoA|sD+F}85VThe)^^uUB zy<^X)Raev-3qRu3>*kN*v!1^y!bQ_1qYIv`;>8K-syEM)AucPd zl)5XaszEu5K=o=#{$~$|BGkcIHsnKmS0J8sAp}P|n*Q|_X!;vBUC}hJ8md>05e&Dx z5Yj7ZX##B?&sNqY>mF2dtNQUg+Pq0F`vNzsBC8-LYkj+{Ppho;d08h*))sWW&q>6x zF%A)h2wCJ=B3>hFhDG4Y@n#;BYU8&A;(jSjQaX@%pd@oogF+w>?TC2u%Mfv_o34o1 zzJOO{1zhPuC?X03lz1dtS(k`^1<F5x(TxMX@|XN4H@@B+#_LszY(C90TNo}WB0!f_J6nuE_SX?cs^VDBgDJ2s-MrJ z-Pfs#J)Io6mJqBbuO&t@{BpXQ@-p&0zc7^|`nDNZZ&kmX#hE@^FrLw&4ok9iC|7k@ zl7&Ys{S09HpwgOMYIdkYQ~JQl&g;;W9+Ry@Qx<1>nqaI4V`qz<)t( z!wFMY3KtBz+~I;e5=*zF-xm8aDE7-Ja=5l^pfQlbN zqdv^4M*1;EKW6zmawa|>tf5+##oyYF%EXY49~y~q7X>R|o*poNo>0&>`k9_iPGQ7>~D}gSL`X;(t*!# z$ZA=9*Y?V7G9kwgQtTFr^_yp!-}Bnv`ckDmS?HGbyi~^(N0Ae>rQa5kEQ`Opy>gX= zr-~n@wAF+_l!fFMZ`1{6ImKkg1+6*tpa`mI=cWQec~zf?DoI=zqhht;S(~kcq51cw zJpoTa=Ih49Et1SV41ViyrY^L8Zk39F4=kEHlDtUS3HEkE9#><`5+D2NW^0=`CHW29td z_kzYE;l+%ns`esvPkLwYM{A1(ymw{lX0v-X!_8(kLsd3jXbwO7OkV^);rx~zsemm0 z4*E1v6~pF>>Sz;j7|W}MHe)^^3}2Wtc@v0$`O~v?)5DESZ1E7}N;eC2vjG1mvydoJ zjRD#XPso;+2+ol8pu~?0%X!0}@J;}+CkE3Ajcmb5>S9g_qHd2p$iA6jJ-D8)+5-eD zBCwHnC|4Rq`xxM(DQa%^~XvDLBkE z+Ec>5_a==E`O;G_3;CX?;_IZ|gn&9-Z)CvG&sUQaxg4N~9rD?ed^}A#HeTIS5ZMx_ zt8QT*C8ft&dPUa6s#CoqFNJ)W$jJaseJ(OUkvT6&r=<08@dkabPvvG!f@ZW7Onx0| zXo;;97fKH68}jYf5?dfh$eJtl3HuIci9gD_?~s=GF%Q&RO9XkiG<>u|I~7@P3@^S(oZz*7b>lH7Nu8!%r!>ER$4Hnm*HD8 zrCZ3iX;S~7Z|h`2=7$HtFpg%H`L?1#@4C?~u>-vb1aP2t^kgoqD8n;O02{jt^;*Gu z-R^jC66MR*A}UTBHmQe3`E?WtK}oSIJ-eT9GudVw@Jq!$p`QdDGT}zMoK0Tgp<$`zXL>= z_eTgT?asSZ2Ih&`>LIDbc{c`4#t8bFA|n8b>}5uobf(C*{`9}d-^iQJD1U>oyUFma z;}Qkm>Z!~^llq}V4+9mJEZ;h99+Our3JG%+KU!Y!!h#5HH~P^vmsiIzxN*t03*o2O9ZKK4~j&Qe8I6$0AtlBEBbY#X%1eCKoYQlef+cFOxF zYYVqQbp?6i`$V^EwL~?UvJk3CKc`7Qu2Zcc!@$h-+2`okEZ)fJ@V=A~uGkbr${W5F zlLlm&fj+6(OMT(7z4Z688GbUagD+pC=347+tXaj`1TPijH!un=o=4_d9 z@P1hys@Oo35}eMDHhc%B^dm^X1wEoAM#TZFz1(D<=@GEz$vEb|cVdhprH-m)J<{0+RTVK&5 zr}haak3Tjf54=q}<#?surOI5!X=p$@ohBDlz}Gyf}X8mPJbwEp0hVmDM)+HC_9mf;&)Uwx^(&iTHC@u~|i^j~1W^w}vi z+KV}PGldsMkKsZ~Vn){z;&p7wXbCI{wy3&fj<0P(5gTa0nKK4vZfz}dn3N#=8ibH{ z3k9hm94p)qOb+uJY-Kn~KswTJkdqOxkkSc+J2;P{)$GJED&*P4bL1j>F}YP$mx;R+ zRh2Hn#mvDwCh6@T@-&RRpcEA=o_Tbjo4>vY%KX)cbZ$DF=VUjed?4z3GQrvG? z3L)x*G?`8lZkE2|M=R^r{rzqQT3_!a(#>x5RTN_B4(D2R5l6t%%34a3NihIj(dXe} zZuF7bcv93=cq`~@nA+1VBQu$LtK`n>EmKhXw6^trAJ(AWYIbsPcUA98|J_YEy1rfA zv(yy&W!O7sGW@>a95S}v@N6R5dtbd}oo4nBMV2n(E`hLTmk6P7#k+MAYPn#|2UDWn zgqOH7DVU6u!Vij%!&&+Cw6J`FN&I_?5x5#>tPpqK7Nye#J$sFPZ)UFvJ9qg(v{g~- z_R-zqho}Zj7NzBgJWiZ}!DdI3a5?IVrFtUPrOClfKMS&@JdBnHMb^_F2t0-@og>4N z(d!P~U}23C3Fdq?T+R71T+?@>5a=eiA~1vm8DfR**8GHBS0f?pjBb7e+--R%d2XTG zVt&+E&sKfDAd%Q1ry&5N<6D*GEohy}g|*#IUi!@Ep#ryGohB`E?r>`d!lhN^V5LSv ziJ)&SD}7i5YKSw0Jq80kt(AiHWmHlCg$^npvSQ1y+!35qQ!`1x+5b^sZXU7BxOw!Y zm=Itel}&#hP+r>P6zisnqVcvXeqvFLn#fIe^@UL{UZ%IZm0{dUSuQd>KD9(Yh(M~; zj?bz>MB=?Qi2lW=Xep*UpELgMU!hLtC57Q_39g?P>1;ik{4+u17EbqNm2!!gRuhmZ z&mn@_lx(?es?QlV!5D^y@%^-fh3S;*;3GAwI+utUzQa@d1e4zL4c|(csSZy%iMMkM z-~P#ixIh~*B$Gq>heKrwQqP&Q^1lC^jn(Y;qan<22t!lqt0FxI&(LetI|Yi!5kuuX zksu6{;XH4x5U+T(zYtZ$2%|fkN1a@uOHW zS<2lIN#Pt(SrYd#vXy%M9>YH5QMz+6oVZ5r za!<-t3v|(4r^9CuMD8^kyd6r&gG->nhus;hB>L^z<*{Af)O$q{4Vsl4PPsJ8RMYMq z5KD&x38Yoi9MS@>iyrRfMCRr!)HQMwL3D)M5b9jmu(McObau&JjDKrY*#E@e)n?+_ zaPpc$qv3;#4TMts-NS}&uUnh27C4yc0~-lby5IEL<(DMSJztOQDm2WeWg-gt_G+{4 zg$n}-0)m=604f8r9>?rT+R9y~TH+f#1S|Hju#=7^t1wT{_tE4&5LxcDtkM$Qf#Fiv z7<1xTG8;21RMkx>tco4(#v+?plBXV8;z^k=a~k>z8Ufn{37O+A3+_A{bQB~#ICR_S zKUZVV7w$*dUnvW+VH8#YYNLDwbWy_ zlGJpBeU}Wzqc$IBoQchuAx)vd3Y1w@f~dl-L>!{}pYYs*0v5w!kW}r)E222;dDreH zIj#A^vIfU49kB}n7GXkWZ7y5K3<78A?Mwininj)rhdevs%k%l~a$(SG@itf#^rX_= zBFD;3h;U<|WR2di8+KeBC|MVVO%?l+O3FcYR7g1#C^-y9BPux zPLBhg%TAA*32Dpm476DxGgF!|@s1l@F_2#C&U}iDH6mBCbG18>X4hv%vb2cdsAPk) zs)(@0L^9k026v8eSr|q2c4{R5LcYC`33}apF{#83b;o9Ts5lzZW7AuD2b14xiDD+^ z%Aq$y+NizmlsMR%N*BT1GQP_qr$VSPAenNK$`d^{*s|6IF=_Ok}1u; z{j{QWM3{}aHSyuF=XF<>hs~Em73;$lyWP@59%o2-xc5m7HM&WpdHxEbb-h49c{PX0 zg5U{Ee6{mMri9E*nf{J~`0L8$70aC{i=l}-LcX`y8{$S)r4?zRS6fx0^u0ZmXiiM! zEI(>%N=?#2d81-;$g@9Gu|rH;a|ZB5T}}A(cuErf69vmz5v4D6aa0P9cy$UXCO&*t zjldFAK2Xya=4(+g>@oily!jfTJq}jb$MsrGjBb%3 zrRDZocnc^Q6S3Qij@4=|+|P%Wn$3Jr&BqKalggoXl*|%ItC>kT=@tE5%1`F4vzE5P zUoPM4%Ss`5+`y%p)C^1JG5 z{b`7-fgQgui%gan|ZP)8pkO-j|gF zYNx22;fl4RlckmJv_MD>wgp}h`Z(sckY_WOLIgc4!xj6Ou)>~?UG2-QsXJ|E^#XU2 zw+HTrU-L{-PQBGa)UAB`;nV@xg-hS^zn`^;O^@vB4!->ejLrt1iwmv)iYyt}Usp=t znB=*~1U)NUg(lma?D`ksfcm1k%k#9T+3f(%6o3lm-z{#-L3g4HWA~M5%L>F|=P{d1 zV>*RTZi9z{No8XVR_tw~l*OLRDrF<~FpoG|PC3RbdPAm2b4x2{Wi_-jq)N_WI4cC5 z)f(B=I!neXZ4=E5-SPzfySh+YG?FFP6qZ~KJCrh8vInJdkY4f;#}bT*&6$B}DYgSu zc5B1CgZw3%S$hR1er)dH>fd8r(V1IkaW7@DeKyS!!MevyEiKRN=&H`Q%gAp{z&>|gjnKbSr#Xg#n4zC&q7Ya_SbGU1 zZ{M5-37sx@|f{5)@TK1IyYxMJ_NbYllE_Nh151_oaER zKE-H^p9iq~V{eGN61l4TK9MMfd7ok>xfYwF<&_()=g#IaeY*%eWxKqT*Szdp@`XV& zL|M&oS)0V7{p#Ybb*vc6Wul2PLe_H&K(21C5l6R>?@zJ<)N209i&KKWs1WBhBmSJ* zv6quB#F(S;U{*J!oB!t^-lk0$ms9@Q=z3lJ{qM_mc@MgLN=fD@x9g^MqxUo2RR3{M zn#DkRv2+J!nK|N_f}$Vtq|x}Bx(y(%zYwEQTsSS$gCgYtj=3EK@~^{iN+0)U`o=X03j<0?Z6${E zg~NWgGMlnhuhj5qr37#1T~age$;L(e0&k>5jiK}So@r8#;w7R$8l_kM*7K0?ky?@b zmJ~rY2w=ELsHQFLwXb0r15m5^l&?z$Q{yfxGZzTSU&pUh<|q7iR+$NWcPn$CO=V8X zt4zwR%!L5whPFdmXN23ABj2?XTm4tu+rwx6J4Pir0P_RG@}6?KdVYy*l3bicBk;Xrz=X`3Qb3Ed3qj02nBI#U z+n;2JzMau@aSnyA-sAkxi$hlhtXU!=Wc$#315%`2jO4*@-t`PC*r0pMS}`R`Y9UsfGyAOs!%{?7_ zL2H)CfaVodk#BG*hUOJXIBS9QB4&OqT)0#uMX;jLzDK@Q?6(vAhOGzWbJ+Tu42-b# zyDCuO)>Aen8TuNYISrAEtMFbpBW%qQsUjPqI1auvn1=%4GxefN3ev@MTr&vXZ^;!7Lm}H$CSK;+B4tI?7R|dw#O9)! zTh&kU$NW$|rSV7lqt#=fE@?t{FIio(RyI-k$==G2vXYOmOqc9o$714Ivk7g!FI_4F zQjh&vD7-yWs>~zqSMK5Vs&2uDLbsg$+A4BOYIR$?E^8nm*HJYQckoqi3zUt7tgKzlipjT^vCIIJLb4ia=6yD)*RDHxOYkl{TH)~yRpF} zsnxu~yFHsf>G=*$ZLS!3Z7xx1N!R@jvSk}G5j(&G4hMxH!z(nWRB@12^S&T?nms2(s+I@AoeI z%jp(p1_*g}WZ7R!e86WJ0=gOkPePw2p?%o1RBAx~Fxg38b}<^Xnv{yg_uyGC}L=lW(_X^^**dG35Z zx3+TO7jLDH2HKu%E8QkW7E>`b7Ls1>hj*oUOXPNK(NJyCC9KVd%O=n-J-Ok0v<&B+ zY=7=oYw-jAlEcA?`!fC6e3TKrSGJ*8z?bY}<*ruf{oM&QJErXqFvh6Gc`m`xOzhW4 zP%~t9bg(t%fsau)m`Q*nMDh+Yvng_3sg&3e{6`4Lg@W-;}by36oA6sMYl2S2f4sQ=7Pntu1vYwnGp+JqFxebjUIRx)vZ|+g6F$xum>T zfUo0^qm%s>BY93DIbAITK^8e0uU2y-uvue6tNc51o^MJa|NR^c=M})8&?D)ef7)gH zwu8vN1E9~-zP}6bFZr|YO~!~j2<*Es@N}ZMI&$bj5*HTQ=kYV`IIX6%bJ)y3A!w7k z5JKbp084!4uZkb$@z@FW%wNRYo!iB0{bt~9baYYB)3ZJiCK+3g4$Vd9xE)s4ig8PE z%4r~?CV%56e?5}Dza0AwF7$frf7DDEuojE<6SkfZ{V{C)kCHU;W$r@XazvUo=UN`p zWe-s*icy%%lh?G%V*U^0bI4X&@SP3T93$o>^({tVww^~;H|9u zGkM6ok)Goq)aLwX@;dH}1U|3IHCLLgnEE7k`#C77_VTOs6hXrN@+mW1K zE8+at8R5cfMzhc^4Hxj+vMNyf#EZ}_exQVCLAdyGdf}BF_&gcb=wc&zWf|8JHFM;8 zwpfnj7qbrf_Uw9owdYgOQp3c; zwV`FexSgkxq2ZF`RVApI*OY&*Oed2moQxE93&!7Nak8?^zJY4yS4&@7PE9(gTLy=-1{x_yv^g0^S`tL|0W zqRB;$vzoSOv?pkeqRESe0+cyd5hh^H6~fprxtYkbIGd+4c=9Ruc>)ilESwZZrx>a$ zmIT$Ne8Sr|DfkgZ90a8nxE{Cmgp)H@qihM4G{8LYNk>~2(rc>>n0-16!Gt}C& z&&9USQ-G6L`+z;s~FZZKT?BYOc{6!BcYJ^$iI%;cM3auQ+gf!jh!83 zb!-ZWC2gvTp3I5Gl1NWI8Rl?#;nWflZg;&c&BB8PIk$yJDY$t=VNs+CjKSn2qFlKs zr*($%C{Xs&5_8F^ut}skm&9N}4-%(Cz3!4;0d4W{;@AOC^itkRVh4IgOGjI!4aUSm zTaI$X4wSebtU?<*dA_6K4d262@z<1&cXPHf*Y`TqVy^~{1ArXF;bC-qSVKXiGS9(L z<$Ki47g&mwBZEml5B;J%|eW5xe7lfmwLv;ROV+=y`wu#&Ro&H#6@ju`ZTt< z%*pM6o^K0uH$YM#EzIw*Qscsw8F1C?i*ZxS@)L9|))HqrbnPQ_EfuGRKR|~p=Wf;XVH>{jLQ^n6t|(}!fYjaDH;mxMhfkEsMpK|?MruP zmA(fond90gIy6d0NaRRxmWhQX)Ki;Xfy1uQM9FPS$(YR7+vE5bK=`+w4UV7#gE)GK z{CeZ;1^mcASU951_CQdHM*4o$m7|GJx+^5%!`KYCw9I}K`JvZ6CQ7?3dgLeeB{3U6x6OR7_BtGzaI`0S3xNfM>Np**&y44m2VxIE zD;FT%=)v0NHHfzyGG{FW&hRuUI!-`{JVi!TFSQXeb?mJxod~8UKT5Xu>yXt_GfHth(+^#gj zZIM+*#hc1e>mB)Ss_zQ!fB+zT4eK7k)I3uaV9Hb4xGP{vJ~tq0?ViPvx2rD zda7aFt8_cx)+w)YxY;m&t;#d+$z}PCLZ5>gsGtO?04k(Tj%+zbLni=1DSmKN%WP3)Cg-n&l?(Wn{ z6^sWyr&_R8c~mo78#J}Q`kdGLbrhs1)oDY;qRAGin<>}2-|$(lU7X6cr%vAM9&F-0 zwz@2~>tlFSUQ}acTPmBlD-&BS+?`9jEH81jH@0hceqv=_Vs;ega!Qo9EZXcS&Ltj@ z!nLJy8&oB(T6Z2hwT01sQlFMpdae3yze=KnqZ||Cf%`XuCV+B=%5#0Oy;u_K9ux$J zaYgwbVfXF9itDBJ@)1{*XfeX<_se-fpWPVryvggs*Ti_2z73k=-#AYS%=}ypj>Bm6 zj6wzOxwLrYEWskq1%^4YEU_`#Blc&R^S5_U{)6WA#bTtqzARe}%6U-m4Cj)T%GfZa zMN24)*j&L7qbB4jv+rY7rpJbzz>V_%V2Ma%^%F`tSqx5LM{ULQ_krJEMi@!6p zIk)1SvcxY0YPC3=WfS*m<-L2YVrxxO466n zh>o>-EyLHfV% z9fVD_IWM#J#KZY>tz2)}C}Zv=oHPb%@t(q`)`dyWX$9#e=0QyLPYo8!jNiA1)7RF8 z2@*1A@?Z(X13>WnbDjZ+3^dH@1?idUWAy^QXf*^NDoFpFFS>7KbX?doW2x0ko)x#sbl+K2n={LO zf)Y%=95!6(@3shrnXu&ZlH_WTLlVwj1d@S0ftu9xflG?PO?<0jzcvOx?^Hl`*YLi> z0c?3NzLP!4T|FX41sitZRJ6g^w+lGhOpH$xXBKeG=wLJ=OOw`|;p{WswG$ZziX zwZHNsf5k`KbP>MggC^P)PQFmQ{WiAi@dv*Cla}~}rTb4Mw+?mW7%lFUhILt4bAu;xR9&Ib z(vV2i7Df7S!kJIe_ge<&YpI}|w>699M+lD{QZEjfRa`rmig4ssrNc>PjdX40w%T!L zo8vg~6sWHqcaF5H_Bx_FgzIast;C*NU;Djtp>ln|{Ke^di+)Dfyle17G$4NAJO5R! z`G}ed@9g`YG^OnxOSEqXttEXueslx`i#;2YCYn2Stt>I%JZi$jT?0<%LF?=9yGQFA z>brwa_YWB4q&+-9xK!(VRp0em-|>A@M*O|1=yDi9|v_~&=q z6i_A8J_Rh1;tX?_w4htI1>M{h6iEw;R13OgThPsIL6Nkeh!&)2L3%pavvvOmsDsHD z3|g8V$#?r#s3o75Ip@E8YJokR?UVNN2iEqmwOD#h0xDb_oH+9I&@E|a>^~}XB3xR! zQ5xC1?|)9k&dTUtOWSm7;&b(M}aP;?9&%txZy z40nEEwQh!4CTuoO*bF0}lrR54A308ty+pqSt?6ay@$5r|%zf#r_{}W%3Q2qNbve>z zl3BWbaP24PywWnO_t!r@mDA4BK5fpqC|c6=nxlC53M=tD%FFie68iV%yW98AmBbg? z4`nz?dpc#ale(F6s}iRKmyoYj$WO&)BN=$&BE97;ZOH9=wIR3d)Q0?MgEr)b25rc= zC$%A${XrXI+@lStnyH)n@bn6roU$Lw#3SeAjAV4-Ggt)J;(jSTX8NHPx$}!N({xB< z%?_$0DqAQSE^DlLo42#o+q?p*5;iYMhs`VYGzU`fgjfoi11n-$;`coHt?-M4X}mZu>XqgtoV*12la$BIpa3r%*b*SD*u)Ewy#`{rgspE7^yACs z{kk5jE;uh*!cWnqS|Wwo(BZ0hbNfaiU~fx5Y(gzK@LhyA^pv_*jxoHf=ryvK)6_4uyBK(8j+{d@8H#O0hDcHY{D&w1E- za6bffH?{T!Y88?|t%75tXCZ~V5u$mk2b7=7_!u@H+{4>rF-627Z90Wc&+8N;nUqd3 zOg(Lw!97;sMK;1PW0xSV7sgD9^qLo=w&D z#zd|@sF6+xa@x-7`6csl5cvG_h@e1dCZ6yqsUwz<^X+$Vhx4=z!@Tp<%#my7sZZ`{ zG`m60x5=2!c|uI&>CII)Vmm$wdeLze|8Y8wg}B_L)V#c$L&Lqu)I3|>t0I@Ncb9?+ z2qrD@0{XBl%d|v-rzL0c-B|>&vzJ|(mCzaL*&J7_AlfMiU>0*$Rpd%CIhfhNS|XUM z1oJeW8mn$7klw5M!HE>n6>Th18j&8gzZ&nQV;ZN1SS;Mx``#Sk%Dy!C2Q zGujkAFIV)nPSIjI`;4NMb*-)9!!C)iO?^?cwB8#nW~;;tL$x7aOiEJZ8^zO-NuNnR zfoRu4nucj=o`(|Edaqc${ode*F(^2398%k>nN!Fk$+8ANCRpfXY*e495%JQ5(%fc| zrL;D82RKn`Dx1@H2R~t*(Uu~kvEe%u>BrNOQ^9d$h7ySO6w#K>7W+d>lSE#d{a+v? zDBERlIkg=``P4SrLu$@**qS}gX>A#A9Q!ID(8%m^p6%Dk>E_Uv@S%X~?3|I!q?TBL zB=px-aoAAdT#3INxCFgecKIr3!=?&<7$P`}i*#lyQXyJ*EIZyziCYyZvsIu*c!K&c!h?HcaT!?Xy6ag>gehVRMCKk&msY#Ozj?N}w|a@? zX1Q!IyB0XnI@AN)Ejb2%iu!Rk3G$D9K>3#8ifSiuS!p@R3xss7$!x@LCPR;C1q>>u z6{-mBm}8I`11L~>Vr9W-#gi@SEtg45ZgRSUwE^bzckxG{ggxLxdUIH1b^&Rsu-N}7 z2gdZRNXB*yB4<;QPs@auzUv_;rpFMROc3Vs4ILqz(&IaEy;2sV_^!ix$%b0>9JUDj zXx?)f<%KQoE{y#_+${EmEHg!+A@kSu)Ld2u-_x6QtW}k|dF>7S_X8kA21-&N7MWr5 za^`JitLiYBvf#x?wN%=}r7Y&=^zEgGsc*iGY6bT+y=iVu|7|N>**4`Fk->~Ff-gTP zQ?0@SO6*+evpOPLD&Vf6D`Xx>kMD>viwUIQQTUz_NvkgrS)ATl(xG+=-%^2jRzL)= z_w(TuG3w&Ivn#v;lf(P?mW~tqJ(y+W(%B)GUFew`TV0K-i@MKuaDH8K=J<{<)6idqviUksW5t8^K0 z8GR*aVm09ZyWBHM2`EIouCVXL2$50U%=mG-nYV{5mAP`;65;Dib(mwZ6=@|@#TTD| z2G2QlY>9STCUp$?J`8Ka-@$b#!W@#CanBL4X3lUYH@xlCxc<*%=`r=Jt0D>grAp&s zrBoPSBl^S@v}l)<$GHSX_?D@Ep zrPof%@rigSwc!&jaS?QM<~E7j`sMgVaY+}^iUpF>2_^_UOuZO?adVlR^GIHkFqh6X)J3Ood_GDAKk)r9T zw>*Jf8}wdlcsnt+bGu4SrFL}JQ#%9+pJ&ts)(3d1P3h~?tTGBo>ZbQw2knE|Vuv`=BU@fw~7}@&olg@S;MB9!Jg@{$43|vSj*UOG?z? zK&_M3yu2)WylQ`J*M~HMD(v)9Zx9M50y;VmRk3#o=(>mcu@VwR3Rs%d#3HFd0v(qS z!Wh??7;M#FkF6?WsUuJnbGnO0y~6-Yg&$ill}W!fKq*ra0~*tvnvP_$xy6}>zN4Eu z^N^lD4`oGD(7aX*@A-S#ilcjphhhGv$x<~XHRxt4{Z6+Itfs<&nJdlZ=|Qh{U@|>+ zN70p9&7B;tefCN!&T>nRX6s966&lQpV%_=i5^5esT%9e3NaEOdEeE_V zR;g$PXBKdfsy246yw=vrSNjxombXpo&sVM265pccUyK5dkd@Y4vZ>S7T&~spg)_j< zUVfz3^l8%?jD7j7;mk~#UKf)KCiIwU5grOL39LkmK!M7Piq*9!%| zP`^qy4AW|M6WHU~VMnU?*iZ7i;adD{R5zd*VU%wyYha*jiZaS>-Q5f7UV_2>1?gw@p!^MbtWLVEI8duH+BZs^kv7~){9$R5)4G}18ozk! zd|FKlhvlD@8wR>$vZ;siTX(foqHg98>Q+1R8~k;a`(94+NZnZ?6-7?qZ(+3ON(FUV zhS-+-J=xcl_(fb>`LLPe>RcPO|zeszWru`Yq;}>t*6Ox*|JH&0icb)Z zLmyW{qV7($gs)A>+!EWdY%udpcM-)7Ly2K&yF^&)XG*!O$Yat?NZ=A}@l4msP#&~;z#qj%OOs*Fl%=*- zt3r~&H}*Fag6zJsmRLx#qb=Od(-Mi>++lw?E5em_sUkbKmE+AbWs)k7Ue>CvYKcd4 zh{a80$xo^0kr4|-y9ojfH>KLgI{43mPg!by%oCQHpONC4OS;m81*8MYY}+GQjr!+6 z9l2@((GE}Rl=Y0H=4;evwGj5DErpf}Oje`5{*?}*J`bDFHy_(hE~ROYO<=Ov`W_LR z5H%m$eVt$vm@KvxFCU?9SwznWUETH5@Qw%-uB8H_)=%l5cf=_(#HCuzeS}@g&Q`*- zW=xj6L2FF0$hV+bTTesv*aEfswQmBtt9TOF-*3mfq)sK^hMwDJS3B&{hp?nCa1KiU zyx0kFls11TONo_w-P5A_uo98=N636Z79Z$OMBJ@@NUv?i^1eV%ec&~c^QxE=jbw6( zoDn&0q!WDi<%=-Xs@Tf$7Us$acx9_q|3~4_RooG)CCSUCOs6DH3@pbg z-K=Q>EVz&DYbUOvS)(>GECr>qZ`8O%YSi2D{bf`7##_#fl(q&y%pCt5MGA6-%#(6x z>=tglKs?wM!t>6#I}gZL!@{y9%Jm;L>v?~ZE_F<^4HEU=O=yZxI-*U)N`Ga zP#3QEyW}B=3^29<5!A(y^ub5c)J8=_MH;8G3$%pQr?nScT1)3d_zZ_&`+uCAL|xWu z7VtoT4r(UY{pKh(IM~!3v)NyJ{f@MKW7ieJ;CFK?1IQ6Ku>l^F>wIIM6P?fL+Kl9Gxhlqr?tGAjme%f?%$Wraa2p~igZ~q#L zGyi@kh?gEeaIuy+?Tmr~;?jrBJ!lTnGZGm<-LGRd87Hgz1dPYj5T7hzXd^fBw>WyV zpPd=qt2OD`DwC}$GyI}G4r-EE7X7B*I>v8Z?)6*2VoNVoK)SYC*Vee8esgS--<cs@h2{^7Zh@x*r4!^_B)nY6uK{XXMZy48l42`E#d?zQyYd66qICb`22i>`o#%ux%{ zZ*pQ0K`0g-`NmNB#CFx0kpV#^^lus> zv)0b-f!b_Rl~yx?jRu@?#3qgR5W#N;^MR0VVuU6hmDqp6$^HYmfkT@m!ScDMcAji6 z(Diq-8B5&Ul2cUHl4w7_Twx#vnn-reCDG*?Imnj3>BZws3{WeK7sK0QWQXFqt~ld&gfYij1mlZ4IOPA$29A(Xtb z#}XcetAY*hc_SB(uu4w~wyYRo`A>q!wN>02)>k(}eZ3>BX(ttrup%dwYHPK1x*6%q zRe96;mZB+_g?(EmtsI^7ABP`IQz$ta-zXb_-Jr#%N;y{l7Xw!4MK2?U!QeMbxytXV z{PG-Mu}8Pg*R5Z0e`b)?zOKrV3OS`0>EQ zoMPKHW0e{>3P}rX3YxI>R<^u94Q@CCKysGb~!G?oHVRMtvD}Jc^^q=DwM(EiM z0$K4g_dHb>6A_-@X=8OY7t$PY^O6=tP8nq#&kfpZMw-WO9A%Avl@{?lexny&5BoMu z+A$_MzF%RmWsPJaM^V_fW%ATfR_VhueWY3Xo6N0W5z?>cBOO367xp%APD$VOT2Yo4 z<-#J*CY(NmF+&v}hdghk=a-1pN2@sp-hfvJNe76a{&*0B1otC0r_{&VaUM8YCC8WJ zwWM&^uRv7dmyLt*xK?DTvTHgnx1&{Yu~|=FZ&WOH{oc&m_5YUx(-+ye;ss+d7@tsaXT_CFm$88R=qZ=84S9y z^*3)2>1qxcZtPo*&?t!ZBS;?~dte)=k<`LWmGe*l1eD;Y1H9(|dGN4g;3#L1%rW5c za!$g5ifnByM^SAcbxn%UVPA@h%3*{7I8FwoC;G)-D4?it2 z6+0N^2`ftm#7;PAWW|mQEX0m(o!bksqg(!7B6ijycKRV>`Z4^c^)f(V-ps%lrLuMK;w^AS3J z>)K-G@lpbquo*4$w}>6TS>`v#dCl93xg!(>6``|g#u{6Oi9#W(InW_Lf=T^TW5a%i z#6{vuiqJWL&{>U;K@sjw1iXfwMMANCTMW6Gr=hx7f@Jy{rj2vv_F%FKp|eVcROFPA zR{vEat?{d9h}2}H*?%=cXEj2nfjja<=v>tkp|e^tk)udv9u?zsxaGY^YZ`8P@6Al@ z0xu{PJ_o%Bvm@f2d{!RLlMy@WavVY@tGPAZX9F8C&iw0gOUSc4?8NRQYQ1w43^V3k ziZfU-O}1)8S&ye=y))I%&JI^sDvgtyG78n$2)3-VhY?Yra+`Zcl&j!t^H#X}efmM7 z8K9QRNXiiS+R<3u+>W+OdE7d*&iLZTL%*XCz z%(QG&U^qHdIK32Uv4>$`3!fou(t+-dT#c8j_sV91{>oPMvh=poos_>IC$iVSxsC>2 zGK-_Z-OAD61xFaOKNK`o9VE>E3rZ7o-l?QWUP89@V7;sK3|nS)S7fWn>SlBPtI%t>@{Hvpd_(i?F%aFBT#-O{ocA5s`|mBHPhQMntan#hZr)6FKe!QDXBCUbqZ z0DL&QYK39$4|-JD*<3@~dloIgeF(pU4eMCfJNlH{D^3r%v=92W1ho-dLN$LsRN-2a z>TC3sHAMU`n8~%UD|^gjfv(2ZWB`GAN4PWCo*Pw#UdYm+O z)_(mJnYA6xtN7UP9Ad7{VjALP9Wvjkkpi-BBd>EnA>P7D<{=FKoUXQeV>Yd9u~%XC z75#NiKR8Tol9IXe)!?`OS0F>yBLifi9r8Ug zK$i2I%8xHk>*h$)EAwwaemS>7VU zo-5J7TV6yw4+{C-oi@L!PSqq2L{{hc$y>@&l3mVD?YKZ^#=Z^o*>$>pMTd2|N*A5n zwI8qr#T^vNFvEH}i~4xc3BHy4E}}{nrONh$_j-*qDBr^18X;EDi#dzS+$ETM?PF-0 ziVh+x8T)nqFfp@U+)V!y5?l1ErJ`SPzmFRvI;aIcLe(V-bIA9mcIWTd^J-O8w3;g= z!Z4xV%o^cOHHrN|$m@tdmL6(3vMIY9sjIGcO(#g0=@pDbDbl(1guxM(Gi%%*(vN%Z zv_v=6k$bdRa`GHdXPR6U8G^u+!*WWI3s!JJbTTC?vch8V*;mh~@X?aY4Z#W(=sI#u z7T5_*Oi5be->j9~OB7g9J;ob8N)IW;Z!L!P1 z#qt?%M)mn8Cl>Ra(T$nbw`US@#?_cMlA&)Gvb5`Aw6HJ~t!kAPzmzgj)Lv#W_p)eJ z+FI6fYs|Z8b#B${M#ZYoK%9s}=31`pG8zt}PjP|Q7PfTIuZ)Iw zdEY`xkUP$NYem1>!tbK4}+L zsh&ayw7i3#MY+c^$D&Pfoc##!SvCJyP&xp9vxKf2?Dd+p}7An;U{YwzI0^~q*cs@GmxZUL=(8SbQv|c8(B6>5z^PrDN^`$YKnk_1R(6#;A#L&5u>h{s(>+&Ke9sR@FVoiku%@ zt(a3bBUmY#gVvY6S($2CwQmFdSz`YZ;}VD^R+(cl3^KKw+c`~@oF|#m_r0L}Lyj>v z915QNPkg#*Z63nRMy!$wd!)&Jjx;sozsa=b4#*8$>y{ml+MF15Fg(nNoeaqzW`|Cp z8j?kkGj(m*u)6}7J1<6C2lkuIVU|-K<5U&(S;dU#w3u)5m4TF^wa_DSyV?eiT$pw0 zBuUnul9YAo6(0MvbLm4r~&vQyepy+Operj+^H_yW~=e zw$U!5FWc9UQ8iUOK0~IReg-9~1KcC_S-`33QrSro1qB-IQa|B-Vt2k(lUGiE&@631FIe~Wm zi*_FGhNTp%hy5oGjCR&e@g2%zy7cdMc5Jd%^BPpQZvchUY@Bdtc7C?SPjsXJ@ogmA z5V8?9n;4SfvFOZwt}|nh$UoK#qG_>15U%(nA*nwnx zC_~GKLKS89xQ8eFC5d!Q7qgrXCr9;g*5P7pWx5_Q(mMVemhmI4tIly(_kOegIev5e zIbK%$=P*-Wbq+JNEc-E;p2M^_{v2msWZ}QOb>Tmz2jPT0A>RfqE_W4=vb?X4utKkU z#o&qop!D^TrvG)X{T*R7W%>9fPdNCg+MT4nHehfq)2%9Rz#3N^ur9;GlFHgXnzYpc zvv0t>7L%)v{pE6Hjm2AGMx*^!wvk)qfz=&`jHH3};{a8{`r$9c`mrDDhq8;v>^w1u z*ALP`AS>2#jklVe`JEQjmrxhtpN~@0vlu@DmUk_a)>_CTJ1&0Hi_*cX5&;-LLP>v5 zj2}(GFRbCSv{evrR#pp)80>R9dgeja^XPvk ziIy2XD(u-E_UsG!9u|Q&bzZ1E5<7pXtncu5^x`UyTBXA3iy;!K*65O!AmAKj*8H-_0s#E&jnj?#n zwdtbBIfy;)9R7sn;G!iI7V+l_PVXF~CkZaCU(KU+p|Qb+)LL9lsf|G1j?`9(w1re7 zZP`2Sq9iFpL^=JKD>W;pKcl2yc2d&Kd}|d%kvo(S@;TCn?@HugR6^RaKQ+3Tb$#bj z=w2pT`)mEWmO|;13Ci1EifT32NxpYDUzIO<(xc=Oi*}M(t2t9(p8+u}u2D zM`g;sLb)SmrLN)tSM=K7At}dyN4qN!cagIOD~~-80IxY66}j*7X+p`*t!X#&6%Z`W@D%OAV1A*SrFV#%(ZaMC~evC_lx4*kSV*F-H?0v zF#dixDEnpny+!Vx$g6pKB8AM-Y>8;`8>kgoO2=nsX*Nf$voGQ6|3P6NzuQ@1|Kcl3 zS}_7g?R+qE$uqhydYalNz~YhH`q(IB%*}XTp3#QvhY6m-4Wg^*F8%D*&KPYk3w3)M z`PwkroAsSB+Dig^8L+IbG}wYxR;k(P-90qn1|DgvG6b463t&oa3VVnj*5RPzXTDfn z(tkf!_EOce><}FbZCnFx34SZu(i+)ba5i_egrb~tF=9+h%*KHS2({}Omq3YA_`u!q zQW!ifmC3H?owWclqPPxf9N)P|_909nsy>#g4|}O6pc+fHxx+`chf2BNSk<44+TTXGm`6%k&Jmmt5t9#MYKQbh+xVp2-8#!7Ob7_lNBj=OcdSGj9^X?9&pY2nFNlUCG zhZ?p@S-K|sSym|apWhMIaP~(2s-9aFqqzVmnRKZWhDNDH)Idogwx`jK#1}889ko5P zuhkr6p6Dz%jfzJ@g|b|3y+m^DcHyCw$T79VeySj@WgNDRkPN$KL3yJv&(S*gwYX zlYhoV+Ot}&pXkt@Ck1>M;Qy!X87-yMBjS(Lo-MC;)}AuS`rDF@?Kvp%@;kI=ClcTO z3E;|6p{5twM$78>!5-RdS?{r{@Yqe*=2$|HuvYHdifNMK@k4}Wy_4Y|Z* zzLG9r4%A*rIqqQ9bGyrzdD<42nNn9H*fCAs$d9U=!ckZAecsz)aS_(lOjNLXdt@Cp z6sq83HWXrukpqqhahq9+KeG}cHv8gS%_;P$?e1PKh>hhIRrn?Ch?8l`wf{1w68U+g z!q^a`9k{QE4N!!mpPd+YhH;vzN0L5=Hg(3`LnZ4A7^&JzpX24Gj1JuG5%4*H!%904Hp*!L z4-c1^7`4~1UrO8`0~PenfBjSDu+1TJCngcrYOd3lGLB5z!Ho8QDZ<8KrMI7k!HzWK z-`&_5QNAWw>+u6WZjGrynTDV z!^GdQJtqkGV}QFm7dqxEXX`=>Yz_N9*6!TARrCcVrI_n-dj{@Zkp$6gumVbAK?$bt*YcnXs!eM^VDQukV%RG%BJ`%m&UEgW{OV)Z+qxSUb@%zr` z^?_U`dMRD+ECxfx==BF${S34@37Qo4tm@R&;Kwjcxz z*{O`P?C^=q`+q1+LZ>2bIi3F+P^B!6$P+Nif;v9K1Jl_476gVGzL@&Y_{F@7{bZ!% zt$0I_lW|uI1Fzv7k6zXU*J4Lek^*T|3&(@tGK3+969U!jct!4T?_Y3wvIbX%K7j{Z zzuJL5nGFp@Ll`@pO=?hwAmqfRu<+^#f8$LoJ$*Q}dl!ba4mBB^8fwID%Fv3E{#&Ro8!|MnnjSU5Z=)*VA0RKHhEBF| z4k%9T*`|h8)VtqQTTkAXWHE_%-ncR~DiM3M#&e9p2E&L(1Imf-_H; z>lkf7-mZjqa9bzkr>7CA_30Yik;D@8f7yXp(}+;;aUzPd2{NY9o8&!dWw;XNu@2*0 z*ab`)kq(fByP+ddibs+O#5ll-fSkjpK(paAct2WX9|oZh0Oa>F(?AJdge8r_j}qPs zW^JV}#0--EKg8oU@V<*8004-8<5hqCE z+Jvz$-i9o^Jwy!kWsqH@5QNUmu|*VI#cXLAI4t2bOB4YX`n4#QTcgAL{#c(HX@9Hg zG{~?hIJ70gnum$1GcC1*hx7Fi#NSIS-f492_oz(QC5>iv|2O7$cb~>CM`QY8l*pcH zf5x*h6%k*L6WF2+fw?Bxy1bRDau2D3r}?|N}M6E`oSQ>u1yy7_0!%nus*GD!TD`6-A` z*~3N52cz9|m5E!-%qkoGHFB6uq#0BOl?Y2U<^afxS z(mWpR`ui{o8tX?tC30tpU4LGbh(O>6s^1q7G7y7$dQmr=q)7FNzl}p@fv4c@_z(xG zgyM!fslMDb2iK( zeWjb*nEjK_Y3b7yRxMSq=nE*C-_mf)mJUKj*XJO6HtOp!dP9rxrNr?+vr-3U-{Amt zfo1paWYHdI*Ymr7EiQoT3#dz&y$#vXeF~Wn@<=Bv=KD48dZWJC-hRG3cBzlBg?h`|(k z;VvxXaXLK0G#ukp5-wY5o1kMhAYR+ z+BJa~ag%OVXVNj&L{H#JN(U!)!zczjXc=s-(&_p7tb+ZG0zSrGyHSH^G3QPd5p1m< z@*mc)H=qwgg_P1wZ)R-HTWk%Uc|u-CsFw!wyYes`U*cF2wm^eI0;4l!MF)>PyTwF(+@M@p=v|tzAbhKGGUk_1E__u(Y_~19>uWs=xm$!H# z@q6y`Xsw8H3=ePk`6M3MW(bo{bIKqRJ}dNB^mr>;{q~Q&n(?Awne#z>NRCHIc7)LZ z%M;I_47@!idQ)Mi4R6%eIK(mp5)6yn=ps%A$Qt-wc=3H73EWVd@I`}Nh?KNN;HsDL zn*Gs6XBH={;?39jTJ9G6kw=VwkMg%f!fR!4c+24&XTd68_Pj#4JjS)yu?<1g)M9jyh3T zLFqf}oB*ge0=UN|?4(RWc#1%fFmlQi;E7la9b&7J7>Xqjs0)nph9m?XOR!+hHd|&| zKNpQ=Ln!f^)6j2RwaE3~3ouYdHpiiiqRtbiJx0~@N79pPn(JEEb=QEbV5x$yz3eis zx1ZzC99QvaatPwzk)!x3x)I=vG=Rf&B0%Vsv5`2A$fyR_;yY4Miugp) zy-Ju8A?je9%|Ela5rMK;iS(i$ZY^%u$|E`+jV2HqQ*ioFFMQYsL*as8m4e{?+Gix4 z`7g-4q)v7kC&a|Nz7BtPKn^Man{T5P9|&-L65}yvI{5ig`hx>a%vy8Kv2N$ z)QG&RETEbXwSt6J2`QP{g_h06fd2sa=%vVEmZ<7PLkkM|hG!fHw|G`b%|VNM_$n$3 zjH(hLvx@Js3Y=pD;2tM=cw-Y`I`ym+`;J9`1pRo$7wmrKUXBg_VrEk#dl@2D#8VW5 z-kqp4tGo@R5KBZ^{J2nSZc`Tg9QB(cCM3Q=3?U8yGyqJ}wDNxbG*R~lnQ z{LI&kv9d4v803J8@1RS2%cFIhqjvRd;joMG5oAa{1vtA~+!%%t`?1Y3%JPoXS}#dyKJQJpS}}@D(}y#(2!HIpeu! zlL6yzp&cw6=?*4Frh7&@^lNfBni!7$d%)R50YXrofh#@`{F;IzqDf9K^H#jZ(;+W& z$|t5j0$W#fv5+d$6r_YXe1m*G*=Tg)J9sC^=Qo0UI%i*)A)UZkV0_u3`0@|a{T{kd z$dzGu)EKBQ3QWpHO4YW6ha8o<5rL(|=}tp8G8|1Cu`Qt+2^`%=`PxVBNbDcAA3o56 zrNDdG;L(qhMeDn;hG6c*$vIHlcf>YsthvXLLBDgn^%jUlPgbTsgVI>!M3h>9D0htu z<7RuKRXv1^S?k=s#A4iYVSc=gwbcKa6pE!z&W+%3BPKAu84DfE6`6%j0HxK#e%lf! z05*W6T;}?Vb}XqWF4wp*8w^AWUt&2Lxym7qm%)9F4v6)x9Bm645Y9%sIz{QgQMmZU zfCTmksl-Dka}mq|aPqCh%)W00JOFksO5|OFMPY`_omik>h7l)JQN~zrs@IX*2w*C8RXq2Y=st-(tTaequ^@o~?D}T$A*aDS zDuyr^CbTp6FHOTm)j-(tEg+;pO5`5k&#>7KbElYYGV;i7*6vl-WXC1VVuOgzit6ZQZdAvi zSnXa#NuwCM(ra`jd1Sj+oKP`p5H0rIz5YRJU{8i-5j_zy&EANN)jbS>xv@<(`z-Bk z$^$%p1e7I;+XccHQMA_uXbUvvSymFiPWHv>Q>Z{?CHj63|NIr;z;ekN|x@t*IXyyB9GrSeLO_z zFvI$5yNlN=jsF0C5EG;1-n)FY@H^d#{ajI`9U({ClLM8;I()?}a{IJfyItB!9HkAM zvE-GtYu6&ef~)7kZ|=dRWVbjfubAsZFq)0H&vT<&!~X8p?qm_NUf$v; ztc-mt6=|1Ambkg@7p$aQRMMFkhDv}iwuopq zB{MG!z2A-J+P!;}pAEPR*H!G9pv-naf{d4_)h%~_;>GdTc@tV31JA4yaX{{s@g+c-MF)lt(;)CQo!?^D$cE- zm1ZS$D+-_`Tu=+|L> z+ppnfm^R{h5by^{xHzsf#*mCnK=_%XlsS~me6_Fnwe^TZ7r?Sr6dd#-=-HOU3Cj|s ziJIgEh+Ob}qN_ddZLPPev*!~8?MSsN&vv*{Z58|H{igobD{Yt0Ej?aq1=VaxULX$N zqR`mXY8E;T=U-Co>gZ-<-|+FgdYRpEJnr}HB3ZP9ERL__9tV1fx>BksaEN9nC0VTxS24!?6E?SUH8K{7m-*eM!;mR6zlrPas^Xz{fZcXtcYIz= zO~h{d^ayG?9+*XJlXhTsIx*Xxd@mb^x$Ap+zN*^(^W((hah#>vZZ~J_R;GDwX-8SpI{esM|GnrB~a;iF_80dSS+>Jv$MA&JILjBCGah z_!9bKcMiZ*9*a;=n^^OD_uMW-7Q=Mzh3X-DO5Z1^G>%SLPHCL>dNK=f-^rfRvt!wa zL!g~6F{7(dM;fpBGx|TLSf1wI7 zpF238ug;p!S7y!U%W$)H;BK`RlQSOp5yD^K+SeYO#>b>?Q!%U6iv6xsd(FI;PBDC1Pf)wVk+in3bH(8pbes2}*K)x2stbybM`_Z*qpWVTPAshPyDs+d0D- zT_}Hs$3JI=UmMLP6jZ<&-g|Q$h})du&584nDNPCaGyLIej(CQn>q;aDWG8=(M#L0v z%AVpkMAQx)D8l{8%LL0l4r`ebxq)Ao3BEnhMNcG~zc$W;UO!2s za9lEuTayRDbs7w9wI}>xaA2wpnE05QM1&IsgMP%-bCCL>z#S|C8~3>g;NsfwUZ|*OE7ZqgurNKnExkc=nRY)y#ci2 zuiZB9eo0#HV^glw8dL*4RBGmN$_t3BfHg!}a3x0}U(eFLwJ;PlyQ|-tb>h6D`hArM zE{M%Tx-pG|rv=d}RR zQ>#}`Z$}G9b9KQ3T38CYOSIU^_1D2nEC)33$OiQIlp`JxEe|g36`;KCVwd)sTYJYn zdXJ~#1Kj1BY6IFg?Dx!jftbHyZa`q(Q~kkA2Po$iS^?aeu0I9A)<_c>zZQ=`kQG8E z&N(84ynWRX_g}8WChV0_roP;ipa1{)`v0N%dPd}k$RqAQV)C$>uT8iQ>~rSpPxD&% zvh(#?G<5_F=wsgz59t5h`TFb75%vGvBk%v`&R4^}HO7U&xX}ThT{!@8-MKU(SUUE9 zYogGS!)VgA-i1&P+T|KiB!tYg=4Bt@wa= zla!2fTEmbyPyZN+o@V@U1g`2^*QwccP0X(=SiINMRe*Edkjz-^RQ(UK+KKva&1&K5 z+lVx?Oz_0&4kA(K1b_C1S`NBGDfG86s|}i{-fln`w%S(K*WxZKxEg;7VNEErdy*d1 za3HIO1F{A>VVfgn4UeU3n8+Gjtii_`uE8G%0?K2#OMHhH_TB_PPb_#B=Wdq$lR(kf zksojFm3PB(poE^s!iHXPtBmKnKh^()7uYIqH|oe)GzS}X7<;>>yHUq#CA3V`AvR@P zHb2$>#yZ-Q+ZnieW;JXT*}L|Y-u#ZxAQgHm(-AzQl2?q5SXMIIx{_`Am8>=@fy}1! zqab#DJyMzbd4&a+23!z$bif6u8MlhzuI~=0csy8&5mvpqYA;AQaI4Y?t%nVgPUG)L zzWW{b4neeya*#dg*Rv772;}GMOLH~ACY4y_Ae%(zY=eIHn)EveV#hg^$pQR1Poh#@ zy?oP(o+cD=1g`5_=lR)n*5%h}(D6_bsi=OctbU?J^@V{bvrV+7W$IkbzLOGI1*NXMw<%(OtL zKf+qtlkW(kggz>VvUg4F(-}e9>#{mS+TNotH#%ck&7bwX+WUKkP^x)lLdPX7CaDK zq%!HiUxR=RUS#lLiwb#II9=gOGp#C|Dk?NcHoL;Y!0&inU_acKVFAsWNwMEY}X7aNno#LQv>M&?cr;VZSm;=keXOqI4GD{TJ!M z2Yethh~f) zH=5UO1&h*V#pzd7yBBf8w5=Y55Nq|c0V&wDuhTrwX`UsCC`1VnK=o<7RvMoJ-MT{m zzDAkz7iL48!$2kea%=xDv9%wArxHGiefZoeIlW>lO*_o86=d zne2Dt2M1ccsaKW8I7Z^pbdQ#ZdX^yIb`9}y=b%?v^nn~OI@fJPM$FcO-z#D<8e)jO0B<5j!n zI-CfXis$JgycKW2LHXvolYvx$(Znk=44FTB;K)-lvl0hZaB38K{@av~Of4{grJu^%jMidiCqjKd3PR#jd55_^dm{ zGcsR_gt+(*!c%rXJdqET$SM7N1WF?V`uR2<2pA0dS2cf|uR7SKG~$}ql<+fK!n0F( z?U>UfyX`*q=`TA!etfSnKb}OxO5+dH^MjghF+WD<%#Rau=EpEGKaxg>o_?pq-ZX8e zr-V0eN_;bSN*vEA@nE`G-J;|mF$a=`edY${L8q7p%g|#?0!#%l54z+$K%n!(%!5gi z`Y{g}kqk2e^T5W`k<5c`0V2zJu!)~?<^kc^XC4eC-QSs+14`&5(2O|`j!DmhRl!1= zUWiYE_P_Btw6BCVgPwBeUtfhcLJA;(>0DAc83sZl^kM!)xEAeD>1a-b(c&5R2+`0c zCW3w+$_w&8EB)#=ydu$;rQb}&8NohxZLHT)$_`GZ?QYU-87 zx9}JBHn!k5IJFA4nYv5Ge$ECn;=Iy}>i3riPOINv864J1*9fWzXl|^E*Y7`1=2I5R zSArL`%v>YiE@5VoRR|vg1CybP-CL(->ULZ_zC2JlermuqJ`lKM{KUZ6@wWxWj6Wy% zlA3x|t$r==g7T94;(}1u+o9g6fsvu!iGd->Kf?-ak5}*;yk5Y=mDOnpkTVF7qwqQ(B1XjDp!W-wZ*fI95|0&Z{+d}c^$D?IolBuoioqXgAlUNbzs^4H~fTe zg7+O5_R+HkEk#ryTXL`~c3oj;f6eTH_Dt7o;RLU*OsDRUdq zJAFS;iXwycPnbY8wi2{NA11Ssa2O9>#C+ku?#mD$J8;_G2!UK5tR?ms_#9m(h7qaI z;cD2ILVxRAvP{P@wJw&q$SiX*P|qR_+gSp)95w78fzi%B4%f_}M{)%E56~T`zwm;P z(iuim4XuQ#ez&SM`C^Za0SFpaV|Z>?Y*q?zD!IHDR9=bKK5e8EImU|QjZQ@AJmj^j zTYRyYO}uhDOOVrnv`3rr2Ij;Ei2x=I&hRlT09q+G@fwY>KG$;v6oh^ZllPFot@v9U z_#XZa4cy?b{m^g&*oAnKjA@WK>u0!6Cn|48lao%Z?hOn`OxU}RXGPj_&x$y3pO~px z&6Z~j+^Wjb-LRQ<1_ue3reql#hm$+H8C^&Skn{0gauaX3u(k%kp!rF7)lL*z8`^X000scY_iJIZZsQ@3UK0@8yUHnIkknn&oI); zK1Yl+<)bXFRAz)h%vq%5#Z%BMNX8jhNKLv>YOChg8Bp0CT`He;fyQ zOsE%dj)VFzN+t3f+(B?}0y)Y{<$!{LY;YY0V>5U};@qDgT(u+_qXmhL7l35a3-E$e zG)Ba6rh$0nWnfFLoi=Tnwx&mKIxwnYLu};LJ=^TBN4B|Rm*bM5$vELoq;DDq=x^!S z5{l!P!}I8byP}s6lHvLd@Nl@827>lM_P*FtgbD`V<%-QN&}KZ51+w&fAjq^^oF&mI zPXk0t55#xO=7u zFCcjhG=^QVW(JJLB&6g3Pu06UuM4^c&CaY^3UENVeap-N3~#B4ON6BXD={PxGzGxE9JRx|SMA=Wc; zug6&uEX5QGD!l$J`~eOKD&lmAtGd&z_&dckhQtgOJGmpYoZKgMd2H%&g);}EpP(&U zpfJ^3703OYoI#z`ga?PoO9O%4r_e6n6wzw^TRy_q%0VU_x{?gxTt~L$6ve3U$Mq-Z^NBuGf!Xg!`p7Vtw-0|aK&0v@2HB7nByUP zyrM1CRC)Q_p~bjlEw$#ptxGD#NJ+Z3_+!eT1#iLAK2Y(?53NL`E-KN_2xFuO@0$7MFMaGo4^!7qqRJ_47BZqL= zn?Pgyrq*`g+C<0*HLS%h<~ObmbOZ*p6pl^WTMEyK-BkcUF6h8OaXkppBTWBk z0`9lM+k#~vd|rWIUqoQF46KaZRj5CKZ&tK<5F@f$ElRtsX!A8NY0K3DAd|}v)IMs( z0rbFY?^P=fneYWvC44136QA8?0x}k`7i58B)-mjTR0i^@Xlb#Xojlp3-r)pIN#6Gg ztKMJxu~qNO(0fR_xk>{opzOr1+p5~sM^@D~VSTXzimX{OZ38-qSU)vCWm)qNzd+4Z z{nUJ=WzEC-sTrUq7esg*E;wm%hZ2q{>x>%(9v`8AZLo5PHV%W8Lqccl5}Pk3gae;e znj;6{wOk{oI&lXyq@FrxoU){zsQ3(TnLDT%yCt+Aa!zRf(7?B?Ksf;p{19fnR3#)*ur^7S48TV*#z3^1GLWK1w{#Jj* z2HZSBj&)V+mf_e0KE+iED^1-^@Zu5}@G+48PHZRz0;C{_B|&gs1AJ$r>)A+aAoMm;^4P; z;o@AseWTaj4gV#t9X4}`zmY#6{@AEpijb0OjK*;29$)5(jqBcKN8l(d9vr5tr6x5t zIW+6(9E^f_UG~>Kh?2*JgYooHk6bwRrLu7U9M_3BG0cS{o?bXS&id^|&XRb-5#MDW z(rhjoucIO^A7as1iw7(kr}Nre85IrVk1k@{YHVbQw_=MsHnFh9Ua9{PIjy+mix{#w zZ?ZQW>vbz~;eEUdWjl9AI_fYSNwf`^{WK*ii#2?wH$N z09iFPix*;(ybR$0Bl1?nxt5$pDWKe3P!KxZDx2k!Vz(U4D!`0ErH#Cla#vdqSxDSUihP!xvH*_$aBDscdX_vxVC2}rH z{TzQXa%rkrzXNe7{Iv%EmTZi7cT_+giwhB?*H^m+1mm}_Gwv0`Oy%^?73@Cyo){%R z&@I^z4sm9TFCZKmVq#j1NsRlhDZm)=pUd8=_o6daGvqh2b|GJ8&yZ&kCn+DTO62Eg zQ@@=9r9OvSK0Sn>6Pe3<^kPQEI18i)#FUWC4aR+LKkZy$*$yopx()4!pefJ-9m?F+ zuDz~zA_fB_fNr<;v6NQbxZb2T#?{h?OM3BxU2k*|7aX+DZh&R6w~42Z7qSBsXnnO1 z%iiOVr$Gy`N$z|Rx1!Xz`eg=O9`mF#we~SKD0L00{V_J{uHH5C24i&zl+q(xd&>Ys z;;|bGZON&=+U>?JS!}?(6&ua(!+D;=$^yAOHtq0fsKg7XUeN?lNTF{a8OB}Vy?%fk@&2Wq~5DAP|6FZQpscRZm@h; z6Z~KaUV-A@t=eX+iQ5e@YoZ;ALXZa3eqs-jI02nEHq-ix2(fE4rG#$;wT70H!l7@w z3JfNG1sZ$$hMh=0`41_Ym~jy zin-Frwk(QSYEaC!EQ(o*>EZ z-)|`Tq4M`dPg*pZ`u(0;)Tl#DZUz*tS_N$oNeC{8ZDNIs4*xHa?^Q@~LS&2H=&biP z?I<@yykdx7H#*-C%71tCCnX+jrgN=F^EsFB&qn^);yJ(F)#`S>%Wa1rN~D$2h#+kO zypsFgVcw=>xf|C^py}k$=t3ucxEAhIgxgOO7J!;d(l|8M(VsIuF zsSEK*S`3(}c(t;4`T0z&qrG4pQl`CtpP`ep;U{@c&AjE`;J3L4YU+DTdjWIQ)bFId zfVtd5-iEzk5VQ5H;?9eP0^HOZen_b74rLn(t~Ct>DZ@|z^(OQkLJuJg1w@#IpoxW;1$zQ&;mojE-VOXLqWq%!%nbE+6h)sbEZVb zVkqj%7#07`2Ay%NYGi-Vk6{WsK{d7PuVm~5v;v6J@j^%Zi$cY{zvpe2J%xL7Q51fo z%G@W=MZFXGP;ju`&IBqG)`A#XOfJ z|HqC7$mz5c$o#YvFh48>GCwT^B7a{?fw)6Jj6uH?T~WfVih?ET>3!ZuoQ?r3@inoiaqlr?5Z$1xp1MC zanxTt9Eb(yPmFwP zUrJ9RWg;!l0B{_tRl>Y_3AaU{*VO;ti6>X}Ys!LJB+xc4KNAV;SHFdXyJB|+v)=}0 zq5XfQuxFdg{x+^QL>;sOtOC#g#6LkVfx(envaJ9Fm9PSIp+4r6Ho06YK)bL4TtX{A zx3mJ3qc#_IFSG)bBF*bDPl96Ycq#T%?@yh7Yzp`R`HyJ|m{?$#0;=*%0lU(s0FE8n zd}z9fJC}X0filAsAaN^A0b(mq~R7Qn?L6`y(Af{YX zz(l+erhpO9WDuj}8I0n3-Yo>QCP*PM29W}d4X07NGz0K<6ln%eNykF+7+Srl_ubd%sc+8eL}uu@t9K;i;6 zZVj*zan&*IZda@hRsfh#1c4J;27UX$>0t$!Nh`o}fXNkW9fKbh{ z0W2c^qzyoPfek>woytTZg|;{@HHYl3*ajnju&pNt!Ux;cvrSk5uv!e6d7&@^AbHEo zii{n=)o?%<0!j=+fV+B&ump62lQ!N8%?`j=14sm_VF{S^Lqmw1h0E*Z?U@U&v7B=E zLot*1%T`Re8A$DoaB0d>@*jZWM_KS85M-_7C-FhaKXZgo@~<+K{H;{-bENQ@FD9F0dC=KcLmJ{p_7Q1jD0jt;*1^I(AXT8R`atHQ1i3t!sJi- z(BARz4K^jd^zIWExPl=j&fWsrI|zrM}-M)%OBYnSJm0s{j)*tO>Ee=mLz* z)Y!8Zs?^w@g4rNQvCJ5!p|nqDvDC2qVe>wCUjLTp@B{(29$HYpI48UjH-tG`(Jr{Jhe*2-@h;IZCATYed}Za zJm^kL%f1U3*%kI5qO~8Ql(BP@f({0#gdc(VMkv86nGiIX;&MVos4=u z`NwgKdeweqK0N}eg)o^>gIAl|?(@?G$AFLtza;N8gbT)&+kIh-2zSbRk87<#-iO(<0pA9~-q?@0|e(G3l^q1&dG+f;9(d+;@aejA$YjDA}* zKmJOhhE1mR+k9^TT?!x>{q`^r1SOM}E1=#k&ODqWFTj9u+l|$R%I$w(w)D>~-PJ-* zd&K~reP}ovfnY=em09dg}iisT*3g&je4j8VB5gs*qoL@D7lAWT}+PQpa5l?wGHR0|+fu%gYiw*6&Lt z7v;D97zW)3ih=owMa(_N+#+Txiq+A}#by!yM4?Bag4CbJAMC-o4HJ8C@mX%Y>41x^ zH#T(+q>9%mk#Q_>5B{X(npCTPCKOUQ=Ojs|*&5iJq&`?IUD^8Jymis3BC`|`JofkXO=vQkq&Nu@52C_8z)-@o`0dFKkkoXf zs8Lff8h!d+s%A)wAT*nPFr!<}h?SRG*GTWH#MP{k-dBctw*~55vIDM5E^V8>7fNI- zUC{69(Fo-fj|N?NjN{7E?+T6?UBrSE*b-~GRP>{t>sq%D+D=NE`hQDJ94nLiL_;4} zE!N1{s=+z~N1N(fY)jvn2vyo;rtVf~@u9cHhwBMj4XXnbw#1&$*8Y>Zk50pwe7h3) z`oI^Yu4ei*0{xPsHD_0@LY8Q@NrkLP2ELL)mQa;ICkoB&nRbOx$dU``RUp-n5K19T zj0e%A6|(2zL2Bl(+XCZYT}GcR6|#p4gs>0l8G*?Ca;1x1SD^Uz>jUt@z_fv2qB=_< z%etwM%}4gzpq2iRz2}uQvYViLh1ylj2&tksalYkn`2NJ*558{)YWv`O1#{=(y9W8J z@O^!zYp0`YQLzm*@tvnjt;Ep3v@Vr!Gdp1FQaMwIZBv%{y@#C?a*aL^I8E$F?=0dg zOygNrzxIkdI(+U?13)ZsH=+O{E=qJ-DH0I=Ck*R)!sZ|%VF!=-yBb!b8TcAbOYHS@ z#R15M0Ode&U?VaSS4Y@33kNka=Dre@WUsIC~pI z^x$fUXxG|d7ufHvPSp*^V#!0PQXAErs3THUZ|xSm#MZ-GAwz*^{*FW~K6xwNMt7qA z4sUGcNo?brb;Cp}ErTlf3JziK`zsD{?msyJV9xdIVRz3)cXc07(lY35Q6jn4IM|SP zzM-!^o2zcW{_Ce<6LEz8>u|hz< z(8MMnBMy?yhB~qaNq6z;z)?|=G@R4N!tv~Ke93Z7m*44|F7rs&be4Y*|(uY!d z@6RRuUi3=e1sWDE>F+RMx}-nAc_2(=1%X-f77~*6+w0@I1~u#hrY;K(40i^vOrC+i z*U~OP8@5~9+OWNTHl54|h4#;``$ogQ`d^n_861+VGPAfEb}$3(R2&2)6C?J}5B(eH zhT(_KlYvV361)(8=#%jX9?+HcLodguOzrZl)E@ewmqWcKHITv&omwTKUXy<4&@T7y zhd%T{R4>I;v{H^uEhP{`oA`zN(EnIt&7GIF(*Bk2hrS=`O)Gzf9-(3p2+egtzY*P% zrZB3YC*w)DpnI4QF6h-V1tm1kI~|D&`Yhoem}xQNbgn!cmtF&=iuV78_c;+QRnA0c zAMbOCaH(<@5;RrLd#H%bsGOH1#?BW?Rk7R7RXJB<{^zQk9|6sM0q^s_Uz)9UW(yJ# z3xp|)-se1Q5EW;0IH@oVzkv7oe}h2MN@pwYbApG%1@VhBJktA|P=Ve#A-&J3cji{X z&^r@MhTd6tpHuG~$9)^QAQBz^>fYz<-`D4TK9#!sBl12!;S%e4c>YSOd3dDW=c^!< z9?tumBzi>N=R^<`({<3Hr@haA&W9ZDa}~{5d7r$QeZ9|xJp1|H=YoSU@ZA4h@AJBgt!eYuO;)t|wRxZ4dyxr9!~5I>hpEdJ?D0!` zpKpm<_5O&x&+h=5&0R%WUyp5UgJrc}#QR+7r{*&(YyKkM=ZgSQt3JQ-vK1)4lJ_}y ze53|U!(ips-sfbthW9yfE1A6Mlx}*Tm(R(Ob<+CuBk?|8i5ohs2K>fLRs;TW-sd-? zjVz@*6$VG-eLhC?O&B54O7}uA%Fp*c{|HiaTJg^IgyP)>{v{Oev!J;TEf=ia+WVYf z@8f-bI!b*3@ADs_4_1)9f4LQ8|5tgRKYKyGZeG}+r8wP3H&0-F&EDt#Sw;M@(X@7+ zSj2L{#!T;Xt`T3>`&@F$|3%*C)#I$m<(hw4k;~WTeO`4w*ARjl&?QviVz>Pz8$ z-tZ1~|2VjbjkZmBU~xCJtSj(`Y82sCF4ZUxT%B0pk=KjKeD;DlTGgV46qmQe`^ zqx}-#S16>d-OAfgnPEK0bu0hR^F;S4tL3_I5e}n_2_aD`i`d@S1%Fpk|t$a(RH4?fPTeVZkcFsdP zS#IUzKG0j(;8wm5=%x-+xRr}}W9e4T5*Q}|Z@QJc4&zpStLTd1R?aO&mL2PH+9GmQ zgK4*N(ah(&l}|heddkDNmA?SA8Dt`?6xnX&Ls-_*L%3d+>Vv=EzCgHI52o`Vpex5~FMt@IGCC9>9ocjALXK|^&r>{7!b;2jmp7-LvPQkoHLHZ*)HOo48leH zVRTJrKoQ|0zMKiuMLbV?PdFYvbkYw;kM;Ig|4(k?9 zjOMw8SH&~UO1}tz)+RLb6y~DBd-C%Z?aa zXFLiG^&8MVuT8}65xQscOqyTJK_NIyD@Z6;J%1YB2=)Al1FRhCwh+dKNBD>{xL8ZI zxb)tluQTow6&~RSfRPgC|3pr(kZaxY48Xn=|0XK*ouHcvq++)g!o%dah0FLb z8Mkm5AV#=_Uj~&6U|9nw_U9H}cbesF6K>%TJ%iaM-NL!T+`^flTeuw=vfaYPF-@=iK(<@>I#7^>TlhK`g28y^ z4uxAdqQM-2TlfiI*)4oK%zU5g7A_bd+@9$YxySSidyMfTR0(=IPDa`z&0GUUnK6Vy zgn(*sK!k$(B*Q&@_>qFeY{4Ag=TbfD%$*OMTE z7NmTKbqg00C>_Nlc_LR6LhkEu3m0`~>jHh~la*Vz!)hGhwj+`M@NVH}K-$b#r={J( z^V(mQSo2brik0hyzsARWFBph-hVn{m&692NE%CJwm* z*@=Jt5yZlaDbfz#kK{UhpPJG7W@_|X*T`eGiSM(zqfj+=opY)9u4&TgQEyC4WJA8Lz?{Dew{X@bw-{HHNxpN(W zFGIdQ@C6ZHm+9B|FX`}2R`o?xr2>4yNxQGZ_iv9Es#4BzeJV&b?eP5r5KUTDIt>r4 z0+`rLfh8Qd!}oaM@J+lK4&N31IDE5{A_7O+;X4o6Z(&Of5@Ga>KFBV7B8}{wIS${< zndR^;II^XKzwNkw@O>{(+XvsBBl_U`D&({3+7BO3cg;tK?}b^g3lvAb7A+^MG}|_{ zocX@q&tiavXriA7bS91h%=+;+&hqze>vCYj75}pS-Zz{mkp_V=-{0HyHT!#CI{d5o zd(S6Mt^K{HUY=I)W1L5_zvYN`oLXs&5+$Sa~JVC zB{-gsVSTwV(I154DICv7!|{AHz?>fweQH)r^bSn=e2sNKuIA87F}R7i?6={4Be)5Jpudh@V<|*%lb=D%$5Ag14R>t^Z-kUWT`G)sJu|p$jq*wZnGG6IF5_;`lnO^DNkqbu$jObpi z$rYOh&3GI7??%W^2T<;}PjW!>Cl(+aRB>zj!~|1gi@4CLT7W9Qh2xO+VZJeR#6==~ zqqAI%)^(}TdlFu4!m`Ah_hbhQMZjlfgIhX|$J`z|G$c?PI#e9^Zs<^-(CD0R3FR2E zesG1#D7PUmobd>4XZbGam9VQU!5H%S4Csouw;|AO9_9@X_2bY9L{LQ@GoY!`cov?7 zgE~*-p{Gi?OeCOsRgi#t`b#*DZIA~D194J3d%!&^K4PeJP?S)1habfrH>3Pc_v8eu zItC4jxaq;cE#kQ#IY=fTPY_bM>Twx1{To?f(|2GuY=%wWjI;;AB#%SDlw+&fv%{t< zk2fXDezFTLU10(8@}4M9_`jhxwhW8{c8Nt}o_prB+0veW{$d zj4l_fSCer${;h~@v!EgXM+xr~#x#Un58sFs4BYG}Co~8_3GYS?hDLmYt7lhsjFhd= zkWNR8l(!Jn8Q8a@bXp_+FBFr((mSA$C-J1gvd@4DMmf|3OZ2W%Tnka4O<9S6S%i)e zR7L`4D#N7Qi1`BJBp~E=mb;@hzXfPI5-(4epfS3QXs>K5aM_m)nQqoou>tW?1WRPR zly>MijCd*ghs+$alv8BME%<}jwg(AoVWJ;dCH%;s>bjK#$U{>?`nqH3drvCNP!hAxQV8CwpWs zxW5deehOauY9FJh0M1NsAe6cn_j=pA8A{y@uCftS=W04AgR5+G$D9bR@~)?1Bkufy z7QM8}rQzzOHTSL039Qo2z$$Ymnib0>$Ox-4IW}}40%LMvbtCkO5oM*j-zY1{geWUl zm{C?*mBvqK9k7nF!kK@VC@X?RC3X#=0)&Jr)al}-sZOt91&52W@+xOmG(r^R1yh%C zR?J}PpBoc5j*8MTasP=2L<~5=GQx@o#$rXce=oMC+xCa7=(ZD_+=^~RAQpp19X^zL z;<>?sd2#R}7z-g_dax6rMl=@7`045Imcax@Sax|7y4;Vup}|#+8T@CU6pXgdI{Wgk ztRT^bg~kdJ62_8u8*Dq_@2BQlEo=Vi7pQp;fN9m|V#}HtP0Xs#SSiR3mGEU;cS0+( z1fo`9nB+3DS?HlFl zS??K*c$>mO$Wy&e#!_FGiKTvJEHE5SSc}+09znVpVO<1zcvY5+&0^T-`$U@&ID2y- zS&Tev6#IFB0mgh+b^$0Ea1E#KTos>aA{-lTZ$mKk_H;1y*ZT{m{tk|Xi(u-Xh+yj7 zrq|dy2l3a7zNf7U?3IBT)194*gke<><7}BIgUy%^=g4U0F8h|)JtEc&xB1Hbp>8NcB6s31HuOrk776`l ze79JL{m|(wYz9(Y#kd7x@nb7Ras%JCq~8j~h0L&!m#!PhwKAzhI^o!>pNKlsA}oC4 zFNGZ;%Qv2IlD_dGqE2s?fu+@OipTXiZKyJ_pzv@879lNWBF%MT%LPhiL63c>uA|kw zSwp6ls79SufW1buz)^&!#`QBWAl%<5xR!p`r&POBkOvLg^c{Pwo7q@k-OLAbt(y4^ zRtG%};AQ#1R{~CA_1CuQe}xqQ(t&h>r~GCeTb)IqV<3bvHMw3V?vw%NEaPL}Ec#;j zjdP*Qa)Pftj1#_NhX?&tV36aF%`y7>NgAPksbS~|h=yAiEt0L!MG;6)Zg zR{W(b)kjwRk2wUa^Da8U_QdL zxduJVvh4`ZX1+VT8$8h@Bczj15-Ttw{f|JgS-TRx5+s^7=Wv#^3Z)CpIr`No4JBtm z=rybu2+~7uc8C$NYZ0MmxBfRg8T4T7+s?*?Z@UFa+yIFag)K?K|3LpxoI>CBgtXg< zxo5`ik@V1?Z#$8fxZvM;w7?ZCix!?bL|HV87Wmzug?$GtXo24oKa-{U(88QZ|D%{k z-}X~EijX)QV+&r4DN}|{rWLYhMsvtyAgJKXqyvAyAvLOnfpesn``Fx!v>X)+O$TD| zXHiLKuKzo6V{#zVGDHxPOiW2;A>d^QPr4hFVQ6Oc-|a$rlp8ySQDNrK+^2e-j0dz1 z@qiL7miD2^M;H(2jzXaoD!ENne%i)A&9^C~Z7>!oA~sNooH4~!aj!PWt6fnf7UEvl z_ikE&FhyT2KG0DIFi9d9)|ZSA^j(sQwY}(aeEI_RqA&uCe_4A`+O{)IZTMg=W*g3u zZJ88vJVu21Vke!;9|Tg2g`F=Wd8sS4LpgKCC(4<3y`!9Y`+DWfo12s~um8Jp=9E7u zXR5za&a7!bpe45!b|OHj4GJ}_(Rn>mF735+zWZ(H|8pK-=nm3Bb9zYFh0qTWpK=5Fz(#7sP4Cd$pkb7rE_OvKGZ zjhW~$6I0AYmzlWPOmqVVYHL{Z4oO&c!_J%0JD>Kj^LFF+BK%UTYAYxTlr9~MT=EH) zj;Y7+ZpNkO;2mUZW&Zg%y5rGyyR|(o#L~grh8_4*uRZE4MR>JLg@&W9s=+86G8vMGo=bdB3^OH`T zc(YAZUUFXRiTRv8@Bnrwb8bT!kG5%YY}~aT`-k4xPYXQCOScucdfpV7u0TL4uz2Pi zhMeA1GqM!&?IBmLOfI zrdIKy-EcE<`IMKoB4|)(J7W0v02Lho3!WRc zw4(;!x-#FkASu2%@T~;jx`BPv#&QXfZ7)8fZtRv#xQ5;@5M+UBk3|+7ov@)02&ET4 z_)ic`8-Dpug%@}c>McTU6^No$%%@4Pd9_tOO+w5E2;PiOZsnz0p;z%aH-+~3l{p$q z#fHD!h&BeHs+m<@+mre}o>KT6~t{H0VK z`3c{m2>XRID7ZexraJ*D21>^8__Y`sc_o5yWj6ghelh9@y-|$r;-V!$)R|fYdnF3ck~EAb8kHqScv1-rsDo!q&t{a!fWwY%!Cz4)X%b& zL$*RnQhx9w{TaUgMe4RdBSx?Gysp~UyR^+hiECggSgzj(YmNDI4DLYvh5p0Lo4}o} z(AsitZbB>nqCbNA(0UhsY=Nuw^8g?`lKeq7qw$lx1kWT}Td+z$7f^SF4h{|u;fBM( z&nM%#JXn?SkDSsb15G}YYIG7AL`4I(Y34+f5pac z9uuN>9mwIpO)H3`mufOet6{$&>4%#zcz^89VFkYG=bd~NI35@3c~dQ*63#$%!}iHB zN3-9)GWk7H{O!n6F#U8jD!H~x1oi_j-#CMrQ_U)7C-eBVuH-qs!B0BL)00l(3%yW7 z+o3IzMDDZiQY%)g=n^I}Cz8RIA`>CU`@nT?MoFKRV16;r`(cl&AR4eT@G?&)KvN@= zo49t=V?bljZO$>=ZVr+N91n7^1qUUM=EG36VGX|6^*=!#rv-exs^LQB-D;?7s4}Ka z#Yq}fdtJG1*pFa{4ce74O_<*G*wHk!vlyVr2gUum{sUBi#xb#Nfs0MvFi@Fu6?Kx@ z>MC5mx)tB+@!ePZs957cva8ui!G_&$c`Mf7;9#Tp1d4=;453ZQ9!=J<5raUOc`xGo z#Kt$MwP7J2s7+mkgb~4ouWHjfgHnEFXOS*U4 zMDMm`_s%E>^on62cs)w^u-35CKwW|Iz{7YWNi?Qnm5+PZ>q_|7{H(o(+i=ZA$Xqx~ zdD~yxrG4UUde`Af#V2DisTURZs2e`k*87Uzo@}%+8C{<%KE3VT@V@qm`0m}X!&lrh z83fGb%U|7e_ut*dihg-)9Oh))+tlTN5y@w)?`o<=-uwgve(b&DC!7QX;QlQA7vaG6MH-rx? z3yxLX!B4A2S%U`_D)+xgkQlQ<+QCtAAu7flHMs8?x1BVQZ=n(;`~ZPlyC0QydYg7S zb}KiuO^!B>Cob9J^ym{~Z$tjop$@?6jV!CeonuPbJWPgo*3)eAqN9z=bOt4#^JueJ>m+SPFfMDE2S zRUEr*+BLvi-7#w@o^Mnkukr=5EO;4Whu?mbJdHKIZuKS^NyMtJU1y1+yi@-C~YfIB6E#zs`xhN zK0LC*)n4xH@UMHeZ}fg|)5qfi$Er)@s}cxs&EU?($&*yA!&8+)dMIF8SFGCOUZ^z5 zYrVLF#9*`DhSowXeMfMUF8PG2bU~h295p?{W zSH-q_W4~F*YC`+V>IN+>LozuSwJ39=oTS=o zwi*0X4ec!8uB`*#US`+951CKhuv5ieNM_Pr7aCQOcf$@fwMHGiRUQ1OkUdn~9#_N~ zwxATct2_`xHIrgfPcFc`Q0B~LUn*Lvpr=|Pv^qGGrLNZl*XFMc>=%U@uXd38i!M}m zW%1N;MTip5-xA1yC2IA)yK#hDW>jNSFT*9~xtlpPHYuf6w<)1PXxD4UeK%p*&EoJz z2{QSt@8lq9jx#_gBquLM@~{{QKQ-;TOtnKwkh?ZHq`{4{x>g5)Y{TSM9-vE&8oRbo zjCTPaFy2lz)g}O%KVCJq>{Ir{Tob+8Mvj+5_ZJ7omv9}%Zp{6<8Dj@ziC;)s%tAz|p?8WXM6q5}?3f^I9m>LHH8%8Ds=dv% z0e45oIYK48l3B3Iuq>BKZ0IJH|OIb?|jXysXEC#qBwVdCZ3cQJli+gsKhzhWc;8ZrIaI#uWg++zQ^FZl= zQ_|?uI#@vumP3QOM|Y^&(Y*a4-8pYVsvdRDF878~_bUtjj5J=|35GRun8}C2kX#9@Kf7m z>V}W7o^pt)a@B5csH+I#&`4h~u0wG+vDANF;eY7TZW4>~3=(A3O4vH&Rg+321P-M(telGvH+{$T zJ=b?#H@R+H0a}QoTb1~q(oq|};uT3szJg1gs{IFXt!lrI;|C%ie?kW;XO2+uAjm9s zjhL8BC(H0)Ff-w`W6-vJYxG#%^&upu&>n}W@hCw7?m%R#y`X1w(x&f*At-AH)SqIA zJD=1l(yf#cg;J+ml$FfX+>o0p5_3w^gAyHfz~feOr>NYkx(#A2hH!`pXgib~X zWDlaa=M7D%7=C|a)XOm**hYdsPW}s!sz)8kf!K@Rn0$tm80sqb7Ox6EfgY77RafZH z;NU=9WOiwCKGNmExwyJLc%D$?`~vgHC7c{cE63v?n3&?BH8o%rBOtmL41ppjd;ACSi1c&cYj>eq~aFJD(c8@Zr zjM-G+1a4}_&GXpCL*r4;cEnJEA0|g}+Z#BZ-%HIoZ0AfuE^-B_Rgp7(2)``Tm*>3tJNU7f z4r&V5B1rmmrCQD1l>Yt~Qy=Kd(7a3QuIiLBJRDiqCj#f8LqjQ)Vzt8tbtq+G%%-8_ za@b)GweeG^sRZ)q-Eg?{9aG?neJh3AE<>lnR1Ei)NzsSba;r5-dsv7<`VhPijdzwS zVHMUL{c8N7%0~(7dS=A^&VteD><=DE_D_)sI&G5NoMxoG+HU;={LFd++D?8_Q-bJ1|gKt!1Wq2Xl zFkHfjA)cTIoK`{R<;oZ_=2v2eq3K%E)$k50G;A0*I&T*Sj5Xe-cVNI+Ck+@n3>dFd zkgXIAlq0_qcB2Mizi6lZ;w(I|3v=;}ynYIDg7MbihYa{4{KAMZc5-Z5PiQ|Z2(Q3K z<Kj??TlyM$<}5I zC?&-TcO5eMVYVO#ebo5``T#qH%~s>mlG;bu1s1}sx`bf4(Ft)N$-pt%$9P{5+KEUq zH##fj%X0CuB(&4PmlwITUC23x-;jBGjR`QrAfe(m>6>YwKwIEuc)A|60po<*IR(D} zd%#)4RX{ZX@72~CuvaxG-tTnY1>hbPb79qlErL@Bt7g?-g)L%2&Z-%j>AVQ!G9ED0 ze~Nr!{koL}Ohd%=e29FA3)-1L{wc6RT#mGU<(YUPRx5rfb~|g7$XWbw4L_Kg#4^5d z8E-HgsLq%j@&t+&PjyaFPm>0S4khvd#_7|>aa9Zcg(m0yKvkWa2Mr)YJR^v}J+Iso zem8KcYu-7o`nBaXutKP*xa;B%lt>Ij53~V!C^q{wUzEi_A*7vp3^RP*StOZpPU_$5 z(H1)?x`bm3{dDODeu)jZ@CpZdwwv7ny83qKLd|XZg3O!1^&wb!pdbsy z|DxBU99k~71t#d!fg(Ky1attela&yb#_God$f13Map&tyXC*#$@ze0ozVcv+>~iE) zyrGckl$}QSbV5JQPD1emQ$nz~;dy5m zRpMVgEF0R^)1)zBHD1^+VLDR}Zp79%I0Xv8&1`{h5I!ZaD6Bh$lK2Y9h~A!U=wm&; zs!+~^Kz|0_tR!ZAu^GaEa8Xq|kc-XNN*mr*#l;3Zjt%%YY{1{bNf(T} zqy*XPq~V~Xh-t%cz>3U{2&2JBz7XAj!2sP51_O5EQK!fY5e(zqi+=MJdxotj3)CanTnWh(9|-lBw0L}}k@h9GhtukT1D46qzbYo%*m7Q85X! z4Qe?MA9!n%TD#g88(H9OIItXUVM=4`$*8H}zy%n#vS2A5Fb-er7o=5y!LLk)56CiM zy7Ah3f$4Buf+BUCrU*Iu}iT9 zY0CT*y2*~*d$yc55YjnwiZN^88X{(mw+AjAa?*H1%{BVzgNSIb#wwUuhMx*0HF)De z60<)xyTFI(EoKvna7hIM{n6iXa$_hkQn*M%;EfPXv4n%<9~5|a-noQhk6n$8)iPmO zHgp1lJsJqHmLSz=0JWh*cd6ArXHn4MkB;0AJDH~n7jdtWidb|?c4jX%9Zd2cH1_L1 zRKl0C>)M+zLV24$ET>BcIP(gx)(QPhxi_^EBn%o?o?YQno_)=$Jo_g82QO(=n|7AN zFi`HZZ&vMFs^ajUQMDfBAy^A`@+F>yGJbM&*|-PMT#fQjtKYubU%h&=);NxxaM1_A z=29MN!X2M#(?{igZJ)PEFIVko@-lpz2~ zNDw}43xM_+x(u(U1cvt+9(w`HgtzHEJRU@S=)fi@ro0?V)5qmF>US!*#~byi3zlVQ z$W=`~Ex{Wb!0WBvB(<*(HLLbjRUi7R*J9MGeD>YA9o1+5H?7SmLI6_*D}L?awUQkf z&(-pI`W>K$wH!46kvU;DEE6kNDv0Sz_3H|#Ul9T>iJYbN%!Yr+RLXj>ZT)|^d-wRN z>NDRzVMiMccB4h5iZ-XFl^SfZp_RI$uyse*3Tp*y=~NwSZR0q0hPD=hr8B6JgqGFK zR!CCU^oSrE?+W9e4+R~bES3#~S0tzU%O}L3j!ZqjpdA@5UA%N}7`JI0b zuNT>Suj}{vJfH7#`FwNNmrl77*Q5RRmob(&&CvmV%XiDWo1T{ewpquz+k?!~^z<(& z2oyV(jeE=mHtvC&0XDCPDS$%+Ju>L5E1CM11t;{(k}0>?Tw;>>(K=kH>va^jcXyj? z#^VZuOPIZ3Y8@&IUw2ses~%rB-%(ju1?)j$vmAlo8K#GV5+1t(T|3N6t;P5}W9{Qd zkTb)u9N4vCbWA4+W;A@Qm!v+ z_5h12)2%1@?lrCnqplpzkzqkKc!_zRMeWA|I$6V@3#^Jg`Y(|c1JOHfl^0OB^8CcA zN_6{>9O!-+@u6XU_{Aam-ESm@odll)eoNZ`e;o_9ZD>Lc1s5zh@iWTW-NtiHNZt62 zU15IO#a&@^(qFgFF5Km}v>yyEm}^%er|i1Sl1cwSX@^7$b3p!Kz1=vlioF&t0SHQj zy?=jZ3*);p?DvvxnITz3nh_eIaScj~&7Z^6hOluHa&^5%To5fodJc=$po~!8Ylx<( zzhJ>;l^rp>StT!y;URt_!U!J(?y}Yq>KuT^fb^_^m6CN`mL*L)HxybI>z1%^S2;f3 zbO3{dUl@yLW=(q5R9HliIiJ#vqiucf`+&`jDr?h?E;HcIeH zh0zi(TIJ`5pJ43!(KmR*61-EZ{LD*}$o@I&$R1l5xFL)-$m^QI{C;ctv000oskTp; z;DfiOFAEk=rRz>%1Htu#y(`FUob)RrJ3z^Y;=vkI-A zZheSww%@3pG7$|vn0(oqd|91*Y2%C6vS-YcR}E}VpRV7OOQ_7@0Q2QBXsx6veDW_& zz9ymZkcVlZ^r*FuZjC2?$IY_*+bu*c(M~@q|(x&xE z(Q|_jQi0syt@d}d{iVGr?prEkvqp0vHvlx$b)N~A?|c)>#ZiDrP&n_?ZuQrqY9VK|8E#0(!a{p4+si(muA~{pNG8n(+#lF46Kh{Y%iYI^43SZ z>UXeop7-A=B+!}?HS5vo=Lg=YV*bRccG3R-s&)S0HC%a(YK6AYWz=r4YKPD)uTMYU zboYH@^RqU%D)Jz!;;gueYW^ck*lvQJkXbJ1iMkB5>RHf}ntz~G&ElTe#Cn0Pc!WG+ zT;@eb5kykV(Iyo4n=*Q<#hIZ*fuq&mWVoWgH~5(i+4&TaT6KXoKtRPxfyQUJ*pHTT z<;&a;s9{y8Iz}(Etf)kqo2>9sJcj^*%$r_xPq|?e?o~enQNq-snj=BVJ~#H#O4rj$(lZP4&--s3?M?|O&|MAL-Ti%f)Uvtd}()VkeShrFxDlB%)LVKdOap zrnUnEho9Lu>7cID@p$=`NV4R1{nks9aze!Qcv+YIJ?^zE8{lV7PU_Ibx~S*oxEiXe zjz97-I*x6VH+j`Bd)2SX(Q21RLrIDqdWi9+734ui9x4rWL71U5(1UtpJb2I$>q}IQ zcroM^YS#yaIi}YYtn~~7xxaD=^S41Kk|=v5k3G*V3*vV2qm$ApuJD+Gbp@rl0dSK^!VEf!Idml&k8~c z-|i;(SW{_owID7N7C1rY=*Id~)8g{_)V#$rsd{}h&$U?o!j6=eztBVPeV#E-%&8hu zLO=~JJ%}K-D2~rs6bJfD5vM`nE)3=3ZNq>DYPhhZ2{tu^7dNXn)L4qs;N8|SD4r+D zld=b!z)u}fhyO&E(FJym)-U`X&``Ly6xl&gDkVrye~IF%JUZv3Tg?jyv2L?0P0`6% z%%nduhS0#*fo$ZdH00+F9i$gxO=>?dI!x{JDmtn4P`#=?KX2#|K3VnZq?bApR2*oC z+#LjKPMV*Hkz8Tu1=5o3+seSQ^dzM<-J{a0M8L0H^kz`VvT8jz`J+5}vtH{Ite#wd z!K}^p&L}?9a+3_)u09}v()9H2X)H42b>n>gmn0y@n#F;bVZ9(mvq0^ue=O4C5kK1+ z(IFYTuOE`}oEh*mq~MT@uBOvK3F{m3tp*qULhu0=d-Gzw8Y`t}5!2ykTum!e!8(N( zN?k5wU5pVAMHsyn9g&Vuznb1mKl?5xUowjWJ*sgSq%c72;o5g`$02N9tXUgmSa7=t z;D*AS&CQf2{lkS)iJ3)VbXy-0#pP1#n1TG%azq6l;k}bfUvS`|SAaX=+$+cv;q4ylQM>1ORxG@evFAs}Bm|o|BRQavp*d>p zz(`TO!+h-_t;sMj1kqN+_Y%Z6c_=5v+by#Qza-|nF>W~fjE^ZMwVNe!2J^`Q84%1q z@*2PU+D8O(&92}@1F_-|DY>r_>m()y?v^EbS((hV7$sIByRo#Tr#~#&9XFKbsLGqI zCeQ2bl$1J0G!Flr;v7||LE=XPYfz*)rml^d!ad!7S#+A2o$lM z#)i7oqHN1n@XLmvkXzrSm1sP~f&|Y1ZRkxKlUy%UG+P+mdk_e6?;#4d)XTgxX@AX;u<#Wo&L-rjf=K^d zTDOs<;sRTRCyJ)NP`g>*r3ZAbS#82^Q__4sY{zStSX=R1ot(@jU8k`>7Iv2elP9yU z4piKOmgZE+0FX?o{#KKIlT0QGn@Q0-gf!T+4tYtKAB+RM>OB>tE?P&vq6V&t6IQQ> zX-l>=D|BkB8rgtEey+hbC$wf;pN}h4kr3)y)lVIhT2g-mDMAgMM61t_#MN|2(kn#f zr=KO5{n>RY%octem7pWM!tVxr?ZhOwAC-T~Pth4if($tAWmNi7o#HSDey{R^#g_W1 z1AgW}pBXKoN+^EnRm|;P>eYI@0=hPcb}H|Pg;?}St7XOSuGBS1IMO`}G)&I0XHm_v~O}}B%ziRsH1-BKN&W+a^x|znRnDE+> zuyL8@FukH1>r;X7+N>C_&00KP?UFASUMm+~yOnXp$Q;DAeHP5MWC?8vQ(fS+Qe_5x z37qy(5-eoPX{jv*r_~o?B~Lmd@3O~Y@_ce5%|aNoPxmto?6COyrZ41pysRwTnz;0) zsST;3WKrMtYkZTHRE)pctjT-v*Q)wx)=)hc+&*-+wDBaRYOZurr5@>d9#cZ<*OPc6+QHfu!N2xSao?iY|LTyNfYC}`rQpy+@?OhPR zCkgbYNrwb%yY#*PM>k_nv&t3tp~|)S-K(4tn)$S5Pt%0Ba;%&VI}sD>XOgHXwMr3G zOuUF-|2BONarIlMV1IYkD+DEH)=$fcWs3EGxu>-%T36VdOxgu&`Vc&-@@Q5jQT}=z zgQV=QoF+JHl)pqJMmnPWH7HW%vY^QqPHysKpeMLrU24Jos*wJ%Xs~uYcW}SffPW~s z-;xPbg^o|lx1@&?gF+ZBsgrWr^hWmMQSe+?KV|_}CJe|5#(4bd*pi%n>K`c>KUP7r zGOb*ZfhB{Q9*d(mNF41G(f``_$}AnJ+~SX3aK9KAF6QV0?j1uN70^GIGWEUl$MK!R zlsJ9fQ}M6Lz9gNLpk>KkwhRL87UvVauL0X zLy56G+8CtAE%jU8BC`Lj+OT4E;7sRbRmGIO?VwDao#eJIO%tJ_5kAIz;x{M*O<810 z;7b>t(!@Mx5?}FQPU{AZH0h#0E_)9@I=W#Po&a^xRHq;?{MOS*ihcNepS-<2N#0%; z@9C4bH@jBKO9jO}vsQU~>+FIxdtBb$MxBcD_GZ@((Y5{Z_Wsa)-EF#q(M{f7ThNHv zbdfZNN}Qv!&P>{~)%zdQ0+x5j6ndBv|2s1FFo?_&iREJ-XJB161M4_Gmoe1u?pbF1 zCl!T4j?wSc60@geaeRDwPZr0%rb{&TT@puF(oq&hQ_vUNlOzrVJKcJh#O-NG95?C6 z6N?|>qi+&N89{BFD1gg3gTJ%PexoqRFC$@tl1O_D!jIO{Jz^T9NYixYD@au?>A0A0 z(j|=mMy~Qw$8-71i+8UFKw7c}p`U~F{5VsC*iYV4QvAEu6_@S;%Mwu^^@Nrswisf{ zh(u#-G0q2B0PEk{eQv>y7S)cP(ugc~oOvvf&8P#d9TU7lnTO>NIhFh$m7iEOLf+dU zezX|Ekxvo_M@mMWOUamFjdAIu=Ch<^0GVd|!k+qolSE<@uid742U2t||U2)R} zBaI{>W5MYO8NaY3|F?0xLscg&1$|(`CtV+lLA^bHUKl?lN zllq;6jD4OWpe!My>=1Dv^@XNkaY9BC%6AF(6mOLkfLZV{mymH*lcE=uRmJHTS20p& zJwZB#LNoE;jTtiKD**B-e_f2M89J4R@pG)nNgl>mxY({s@-TwbL8L39t8X5LvOn9D zgfUtjTh0yqwRbeZ3fkTDsq7EVudSRiEspto2ZjgY1)GNG+=mj0n_?0)GqBFczewUq zm85%24Vh%L-BJ@pnN9?|l{#ET*jHIRQ2hQ^{$NY4F z@$S6m$pz-jz_C3}#+00l(|>?8Jk7~C5+~z4Gbs4^!K;fuew*EE*A{=jmG@!%kOnNA zxAt)jw)FF~0nvc{xA1__{yh;yl;jH_^iM`*-u* zkKQS^@X0WyX=pro1X12eMswxrCeNH}hBtV71_aszF?>#=E~lF%hJzvlP^) zc0R>HJ-e*=!uZR>$(Q?+FXQ>*wd}^*?lO9^zx^D~);QKv>!KIKXgBjJ{iIete&b<~ zjpbNpI~Q|ZGpU{~NqWkF8t964)$GeYv8$xAq?x@!vQKpDTQ(w+G_OhC_A0yYG z`DXn=n5JhhBml6yr1^>C`a32)dx@51+4fx*w!d{j`;PKl#j#w)$!z-Pok{NYCBHeQ zn$K`6wRGKTvc*}bec(5ixP7rDZlgTntsd%d&tEJ6tVp(I{*#;6R5i%IhRx023$RVs z6uoG-oCmu<5S>Cd4N}(S6WU}~OD-jtG(Vo6@z2zp;O!~b67aC|Ba_jGtS0D%WhKbg z?v7h~e{&(g_l(Q1t#o&w>yz6g99{bjO1E~qAI*G#2bgQ>MSIY9xyIyZrEb+>M1h8Y zeZ}Xg9(wFQD3XQl(vb1lG(_tnyCCYI-=^d`{t9GoM@k;QRx3MQsOd3=D!`@d75=hx zncOxdwq!2;IfKT-e{Ij`x!esd53WUW;O|dAx$sV?LL6+^vitZi#LO38!jtU{g^8aw zAD>?Hd&(Zycuf2*4wR(pUM+SBTt)}cPqZ~1ae31P&TBBNV<=zf%=WiG;mz129smU? z^Oaa>7QyWupCVy)Q2JM!T&HPO{EP;3#iHVBn$2TWS@-?D{W$4yYD|0_6JH+qwj7I9L zK2!G)>YsgLI|Ul!RlDBHw(q?vx{SCo+bn+FTP+Ju6dSOps4>(k#$deXAK(HCuYx@u~$El$At-XuPj{$69h-$EC^K;NUHf zlrgjP@BfB&?P<{Y49#Q;M3>ppoh>C+7rSWAo&h<>$(0ny!3JdVTL7At{s@|3JhEL) z$vB3un1+_T)%c7K)?tdVX_S599UaPA=VjZAWp#zSZ)cNea=v$8E&w)+jGZT5W=2T2 z4(m|Z#3vl)X03kYF)%#?m#KC{X$f5JbrSg~3^Obj?eGeBO`k7$(XwLz;Cm(&n}XmX z%235b8g+cDN8+SseQ%t~_J)jKJ5qkM&+mMLNV_uRX^_ql**_5jhxm)0ZBU2XYnQHMtaIxI5gZ<I-=9` z)DE7Cgp8khTu)u3r~c)QEsNY!-?(k&y%PtJFT_JrL8h3VzBo`xMU+>RtyVJ4s$>>5 zS06;X)dy{)`Y6%eRd*mfNGm6QS%tfl!cG42nFV{t3RbLzK#p>?>?oz@E7=vEqP44N zU%#=X-4$)6XYI7W+UeGr!Of+9VdAH(=7V|oq_UbLL?d=DO)9O_og%#7v z6@y9g@`*_uMyW{Pnc3v~HbG(91*IPOCX{0GMGb|f8%rB1797^x2!I?6&UbA3$TwvY z7o%iYXgYs7O{p23i*6J&sjOq-rH<4UMlNNE#Q<80xp-+V^-fT6D*dB2Hof>Ba`vrK zKiUsp%{bTv2yK6N$|p?E*n+TgBQ7QSv^00q73mp&U#~IoO75n6AmT{>ep0t3?X;Zw zTsECslVVG`DHOOP-Fh3>bzER${M({Yj*38!W(v^siRMSUM@*TZ7?FiuVdN#k;i-3; zZvi%ZvsCX6%r8R4p)=@mbiI8te6G{LUFo6^7{narB{-DkaB(oUQd3}{b!ytytX)B`->U!uy zF7p_J7mxYD4TMUKX+AZABo-VfdwxSV*)8Lx>1MppG$6WI@TWvSYu5MS_x`TW5$4Sk ziv`g8SWE~wn9)`j?Zn}po`c7E=K$}CMYo27!j^3Va0o6EF@(BWRw6mitZ?mJBZSR8 zdY9ptjJS~f6XYa)n8S7K^U$(uFwe`%_f@I!6c5CA)AzI+-2}(*>mm0?@Xh3keG+|V zS3?J3pR=pR^U0b*NxpaSHT&CUsvQd;IYcR*WRFl?j^A1$Xb@{KcHAlTJ3=L*pF20W zdsSi;p4Y44hw+tq^m|l~nCSP&Xb}td379G#y_o!H)k9)6qiA@Tcl~*vqf+E)nMKY9^C~p81`G&x^7 zNYcc?^K994F>9zh74>_kf`0E@ZPC74yqo{Y60826H+R&Uy8zcuRr<*vaexPC;gvjL z_Ta7VQL_iHPQJA9#f3S0H{Z>hAHOU6>oMF)2`+}pK1`2$$$#Q#Ge^=tB3zs>Vf6r= zqK=a8Qjf?8rY@D$%ZcmWu2tt1e*$O=aUeu%I(`ed`i~ETxPHeo`FD_Jlb4EB?3{&K zP-BPOAVbY2@0t$UQsi8QQ?z@cSFw&JG;%HyuGE~6bDg_6pID+u@TAl+Q`En$=*rlB z$|(0c-{5Pj7Jkuwukcshoo{CG%aC#)m4{%J&+Bcp7IyV$&U))klK6DeOlOj$xo91( zWWxhwUaje9y3fN8TbQ?4SB3d+mXFPsjfBL|h32f=6&1sZ1LLBJBg@C-Cype|f^@~* zoYxt@V%gZJY^2ZL1LR%=nN5=x-d4z6N%j%U$(@_H>+15tT?pollSc)OuTemS=&i2L zFNn)_JTC5m`U~c)7c{Al;!}B7e6UIU4N#WB?XuR%JUTSH;99DK^YL1ndPu_{-LOqa zSrP@Hq8(gEz;G%K)Q32fe)1i3 z8A_;sSxB^!a9Kt`^e&>#TA4+wed;3hlyVHC4g#57v_458YtS*j#gVrwL5%dbR9gs&$sCN9H$+XBcUfQ+A%Yb=sOj>9?BGn) z%|SxX($lBdO32k0#)c9)aw{FVVO%tDK$aky%o~&MW3P^}h2j6|HE#4X`$feNT(7W> zWw58a;&yV7yf6(u6}d3@A!g9%Ftdg*7(1$~gNpZpR43wpvsyrXtWVe5cBJJvlwibd z=xobIJYP$`{`nM~%=e7Q&b&7z9FzjHEebQ6)6>7I`JpIK*;07|ir z0WhUt>Z#d|!#bP(+r`j7lv0fG+zLKf0c+j+LgrUw=ClY2SUmvJDTMpA-vwvn4|v3nQYgirNPv z{iIg&HS8;RM|aj_jOI3hBC8l`^jI>ylfg|?aL@QgUOt4}WHg>oYp46h^N!6AAB^;= zV-r?HZ;(P!ygoL6@8B*-CIK4B@yvU5(NYWdNv(uYC-tr*LXdekIht8XW^wvIx9ct; z6;gNzBh`^i*QCEox-M53JesYkk{+xhC@Jp5oEY&mvsKW#!q>V9%*bW7rd#f#TL`+N zvamq#=(_4-5T5(hq(RR%5u-HOwe(e(IuvFO0bEo{pCG}^i!A9WKv1zUoBr`)+DJKe zY5?*Rz3MeV%^`;KXnMBk^4_7+ulF^y)Z4cghQ3;t+Du3Pr=E_clk4z$wSF&04@ed~ z%9liqwS1HxX1audbd1w>LHf4kJ@Dd*ol@pl7%y)cDhVVFCqgzYQ@0M2?prM|a6@tq zWYWI%6UlKf8cFqd{fTaJ3H9!JK~`?n)U=mNF_#@=*==98CSO)3U)uQMETVdkw5^Jp zp7BX6RZh(p#*^N2?7r`OU8<*W-q3HNR1240`fW1>xty2u^Aqm5PgxS>C}63w8Dq1I z)lCdRM$IDAQd!q@hmZ*{;!mh>EmY>d*pYM{&Vl6V6ctZ_Kx$IwI3Nr zn$8!MBNnDM`;ElZ0ZVBlRN-r0;i}sO6$;mn{std3U%B8)`uTgma3A3L6~P5zCs(_* zQ*Nl)rzHaRTZNHNyB-Jo7V0rLuG+XbpDM1_xYDL|JY_`*wIm%E`?rV#Y{&3j3aQJo zNF*@qt}rSGmHH7 z8smfX8v%gsZ_7!-SPP>iDPgiSnKI8x;6#$&vQx3Fhr+^x1exqj&-$7!Wy0vvy6C-Z zv{$#BEz)vsBY*KyQ2iaVTfReC^}IZWzIX2;}DB(DX5+iQUPe)Y+)`i+KY@UC&u;J5K3a^a+d zpo0MGp|--4EMXoGwho6~(^YV zUY{RG_9wl*+$RB(Zl!D6fDntg(H&Weg^wGA%z^JW#OH^zE$RB+6#Vxxr_A{z&rz(2kj#+Z?Rn%xidcLC2-eJ^`m5# z%=)yepzd+{iL$AS?3UC9FSCKj)90zA{x!?Rq`{Q z(M^AZ*1Ax4_0w8MZs<+-ojv$rw1+K-?@zvrPri(iVzG4Jnti{;YK`M&f$6$ESi#eU zUtJ){y-K1AG{}TO(|#RI`#g(Mg~Y}emmI|BUHDFSLt*ZTsXVcv@Y55`d_MMosx#Fj z5s@19iI1C4>ivxUB!j~~$xpP;c~#HZ=Yp#FeD=)2c&(JoH8pTE=ZjCtU-p0Y9pWoe zS;f2|De?|F3EqpZp`l~zj4I?6ZvM0>Yge!al=Wr6=Lw%15wcv%&)KW?kkTH-OkjHp zGDv)OLNx*pa!=Ot4f70Wtm$*3V0=;XtXKFl@srZFlCET)N&?N)qLarA;&B3&+_wbj zjQAv^y>Xqg4h7w}ao08l6pZ0@(#p+rZkX97HQWFhgn1}T9jl22FTx04=2uDWARqFl zRn7LAxm8c|**BSv=z696zRD|)pcvNkxeI`BN*Y61jBt?X0?VQ~6%tOLdX2fusU@gU zWz`_%WHKi5UMxMV%2Er1%tE)m`QbvpeJ|JUB~>p-9fPMNj8ZL&PWjPaBTrq^B|V>> zxsK85V~_|Mm$_`+_^;*acHT%cRln9yn74kaIb#t0C4JFAm|2{jwT7$MnW-*XtVKYf z_9PdPmb;#^YGGAZ{Z@zzJ^=zT3LpS#Zq*2ywPxSgXyTqO{v1G)84TDj6r*zj022;% z*+*wr0tAZm72#GU4`G597n3e`oJi|AvG}4Qc=)Xy}Fc0UAD2?WS2(yP4Pm zmRs%9m03-z^Jpivwz}S94+&oJ3}0yzTm!HXbwvBBw$LP6kl5MbrK8l>E|lo!6j|NZ<|F5Ctt7E#2^0Y6m?Q{!TH|_2Usk77=a_MVp7j2dCW34dA&1 zrUr#S8^FE_+ttNzRqcJ+<|{#XJ2gy@Nfm}{I+$55js$_7mD#7A@fn7;?R>Qy`DHWReK?%;w;*)U^(Dr4j{Us z;TOu@GB!2sLNaeBUP0F=oI5v5ArUUx7RL=+!z^JY9qzT< z(mf@MtdHJd0*e288DZ2SoEVLy4pR&3Tc&-m9Pi;nFrx&~lKPg~4|X?UEGGk&+oj~} zF@({4#IsZ`9^R}4JQ7KTv&JqK^vZ5mjAAoCzz9}e0<)(~CasWBC5Z7pWk8MeDFf^* zDueD(8Pp;j)u{I`{8?Ga?-*=ah~IO*De54f`y75IR~%sz^{GJqc}8AiF?CiZ@kIZv4+A%LM&Nk>Emp6&B(Gh$2U_F-CTUcJcDjpnxN+3xxjz% zYBW%S%`T(J=_dzr1R?ip!);JgUHbf=3%;-m()#2=oqF_=1YxQ45&RAk;xp9ZpoO5`65%X+%U(9z9U6Py;UKQwUPG z+{L*BNlMX;x8Dv?>d~Iv>uj&ASJkNAnxj~hPf4!$Eyv5!EhmHvGwsv1$R8~UIcYct z3Rf+EP}SZieL75+6fQmS0A`!?^SO_lukr{kp*Jr9wXL8DV$`;vY7`ge@K1nGu!8`) zP8hi2C@YS-2nl|BY$)$&a3|GIZkv2$8 z)%c0Az5aaBiMBfk{VWf1g_PK9wU30dNqv3chNCn^tmwlZkHd8kRDW%%M79> z(lk-4io#|LpXr&N$)I^w>Y(r-29U$ZYNT-dmrYbL9= zJ=OlO@F@0{&h)I0b5SnZUl(=atx9#WFkewKI}IQn=z`7a@d^9EiA!LP**A&6NOxHRCj~Ba+auR949HG&zryMjVKu$7J&YcB z2RGRR2YEj%D@TMPndDQnNqB1-0T8f-7sKyoj1EZ{wY%wf`|bJ#U4OWlx`+9%gCMI8 zhxshvah}tJBBA5{pKyIL#FOzaH)DxC?{qX7L`1j|{KGBUb%b8mpcbIysOCY4n>PWJ zj4XiLN(Lm(O@}Mf&u-$70ZDbob9ToTa)kvbgUsq2A*?@a3sbL!nb+uO#wV033&RYw zUAdzG%7YvM;0aLjKmkgy9Dq_;tp+F|*hT*E*dT+!5$b$asQlu#MZ8#K0Wy28bAWQS z0HyehcKfM!^@PlBn7MRqau|}s1W@L#my8KAOE|v-Kq)BzF|D8C#ry_P4nIn?Mv%cx zH}V7*VMim;)K$_?HJxyHa)I?%diuW@p4E^*5g$FKx?ZpY9 zb2Xm!#|49~oO}(7z@YIZW*%fOD@69PVkYH>_GE=L9@w)7fCdIY=NSMM2vOVh0MW7V z!+D*I2Qk4xCKePX14O@iorD|NX441_kWmeGOP&hi)C24VN+W)WH!4V2y(B*?Gf?Mz z3CQXHlamq&g>NQkbYIgq`q}A8Qoud6TL~4|uR@{|gp#eY&Zk_y59^{%p#9nx}*aa#Eq`b<` zI6%s>G1nnLDrk_N{*f4v>X&SBu)e5{dIY1_n#Gx*(=Gp?=0Fk)C!oV!ll29pEsw&+ z$pr!yQ*KvI_bj`ZX&mj9!%AZ!+5B-au(aZISXvRoQul(N+H(LEO&2D(v!lsV5`z9U z8!F{Q3~f-!6uaXKNx_6l<01&hyiXBML!}ilDs|Y0uoLb*2lkm>CaB1Oo~jv+st~qP zl~40k7sg+S7wwAgJPri<>X*w(er?FMaPu$j!sCSh?AFh+glCA%8Kt-lrroIL^eO0p z`BHP$tfbf|X8fm*s~)Vj65m=azBM_Z%4Cs6$c#&+XMArk-+J9`;|Abco5Zn%*$*ov zMrmiIOumdyzKr2Z9Ie9(XZ@ZR676&2v?;jafMh9<0&w(_dtstY|0wgx>DCh;(~#Q*_S}(v@(ToqkX)0$vkVA!rPchr$0qQ@ zMd0LTAC=<{tazti>liT@6c zzX|u>M~=}pJ<{2oDY!Enw~@70vt4=Ai{6&`}D2x7fu z+Ua6htM!2j6{P)L>SA4#o_Vu+rqTU^XvXhe5&xCtW!57fX3V8%E=iG zuj==-LYU7X{e!sukvb_}4GDq0cvJ{k=^FL2ZYLhCy_`Qw;izka<8RXb{*qXQ(UrCm zfR#vw<5R>uFJmRpJ*i0G^W;oY;D*A;eR_LPm}|uis|m?tk7L!iT6WGbYC4HounAhD z?q!OZ-Vb_$vyLsqgb6G-1VJA*?y+GW5BpIU#lxQGXc`RTcQUNi4)^nWY@zIv8sa1D z+S+|q46d!T-`JRK$}FfF!f(cMkpiUM>n)x0+D_hWYHss5;hA>g&=dO@^P=$1}93>5f!7L8j#ui3itvZe8 zaG2U+wgo+jYK_q+uTynM0bHXzb|&^gJ8jVtAyFXdXWv4~t%>k^EaL~{yAViXlx3}e zoj@`#wO(w;T1#)QB-SqLVwS?xi7;~_i`yZNg@BwW68|Idb$H$}lCywL?c#2)Q2U0O zn#f($Yf!yQ3_`LXRv(a#)kc*GHIZhj%BN*W=^Y1sIo54MI4H-0Y8adPH>Rt2(x{40 z_N=z9_I`AoEOy?q(|_klpCP zZH!>mYAYJe?s)0eA@p}$^cM3icHke$u7UZ$oXm{~OhRIqNxch*SQHUvrU&YLiRPxb zWo@Xt=_^OR(*RDg3%4`kbg59I9@z&!hpC~rpsUB_2VNGY5S}m9MKI_M{4Bi(A?>}l z;J*(p>*{kV_^cu)7vTe9;jvHtdpGLw-(Qc-`|RQ}SNIa^jrFnr9=h+>8d7uCD_z(= zDLuyF^-|z|ezg4eqvgN94U3-UgPIM)tNi!N692uQdI@AZx}1rUWvTJWtJF}-F}jWx zu_R7^Yx8b$Pkw4Rg79$?4K?&q+Zp|u90o7sUYq_;9H(C-#H}ZMoc0erm{uI0-*`L= z5M<|QR79;nVhA6wA^){u#ZI16tLN~VTERp42<_zdumWpXd;-#lw zX|it(MtRqY`1%=)7MPO&AU|~+Vz_vH5jju;S=)6_`HX^{y1IX5P~qK@fvI z*3T4y5Q6!Pg_4f1Bv)$~d>&bEkyu=zVE_!&Fes}ccHcL<`$sekywWM8#lRo#3($3)h9w+ZYrH=x?oR7I=oPUwCkf z@L*7w@L>aO59@aP#r)sxKp}fknAvbwn8J6piO`_BXbaJll7t~4VlLuLPTXdk?k;#J zj2s{SRUYJukhFSia%*%UvFWiSMrIHGd^J{wIMnV$(~aF5($xL?K81lyn2ci zlZ+xxR)Ex`;_YG44zSyvcwY{34x|dG+wxq*ZZ5A=!{;1xJ9L!)}6O zs&OKl>)_?XQfSyzI6sjKLfnni3aM~j5n%V9b>zAR}nK=3f zr8X-9cTsv~7e|ECbjz7IO$j1F^&C4pU-vUQH_xO?#We{|+u#@e8o0A7J?km1BuKK3 zL`RxgPs1}`mx57k!QrXg;N0?if`Vg3^sB|Ga9D3=ImfiK^ruaaT#Eg(A)2wO`~f}w%Kntp#-$%^BZU0RSZyv zoOpE{;O9Eg{QMLp8NlaSoJiU0Wfrtk2L(FE~FA$`P5=*wLTe!ssvH2hin@h7H!c> zOo}Z`g_APnV{xaVy8#nngx>UW``PE0v^~=zH1edhD7eFPy^mbx5 zU5SFsOAay-B)}S=C{?HmC#|V5Vzs7qt=805%_Xs;+WQa#$tc4<7AVXNK6ehLr+??H zm??(7=g|KiG>$Su1chlI25`+Xv5FiJG{I+2->_scwc|%un>kiQY;_T0bggM*bN~NP ztda2l`GkZBZgzz&Mv+T#Z-GG@nO{5So~cLlgZ*9CX0gRwHoMr=$X- zYqPYQpTAnr=4!?-RE)$PEU;#v4VjVX3eSI1lRH#48py^S7N=kmj_4J>n?xfXko6Q?lf-WZjU9?dlt2Hc!-YGD zGIjBY+k=YL4bkl3dPhTk_HYMp@UV3NO29sE17Pe9c3V0#9+6_i=w`Xzu5iRH=FX49 z5!r0P;u^i4aKr_6#&5ZW?t2M$K8D&3zzt(qfv%{a`urSgN8Jgyu_>RZc!;Asft&wA zJ0#eF?OpnTn-_b*O-&7=cFtzO8+8D_>^6+1L-FMk!M+h}Gep>CtU()$+OA=z7YJf460{*g6=;Jmcv_|pw4oT8KLXm|9)87iXX5W&l!ZlF zJG0;~CHV|@DU!<22u7O10~Y~jh`(ZbBD?mZ_BZlL?nV+Ee}EmeYPv%$>R5SimR9#u zTP!wiS0y5S^9Ys{;2W+8*keZSQ}mVd#6omFMay;D(`$&r7veW*?OtR3iYbX#Gfy`+ zTln!$t4iE&7p8$|)+|d@NV1UcuQGat0N_oEK@SP@RS4g07EFlw2tY&4NL$&VymTCN z9Koox9*3SJwZflyEV8iCAbQ^>N)m><+9eO`@9Cha~ z4U1~b2O<|@GbK=rEILc@+p)2LVwN+DKrzr)Pk6)Vt0!zOXZ*7z(-s+ujyV*gH)*Eo zEkU6wMlqW;?(_m*9%Gog?>&y8=-${+bnJ8#gQbW$;S0qy3VIm^(U{+g-sahRHSo?g zz{VDGmr8_JJ;%jKPKD6UPwY2X9uXoC@H2Z@>t4-<_X9F|jsr51+^v5Z0~tN;bRdJ_ z7$CC?AR}C|T;~BY_IL&zc^7M=7q|ny?AEFcoDE1<5^&L1ZqR##aoX&Y9XI)u&aral z%kX}&tOcVOppkR>jb1?0#kJ=KGz1R*y8sQVMgYyGKMv5m>t){U18A&7TItFL6ayLo z7*$*oLbX=y)Jy_6R(l4j)t>XJeGF*Oofv@xXtr`NJ^fq%PC(Pl$P5Z2KY`!ku=PqI z_yo&%vQp=oz0i;9=z#YW(?~xbW@7Zu98S0XoTJ*tH(r?~&?Z@*CB`H5XE_2*zul`^ z7dvTrilHQNr?WEauzyGyppB&*yJ>Y}bInDo#znPdlFEK+TABRFBSAVnr#NKiEZ=aG z>^bwQ(oIl>F4Wk!L&`e=`?@Z zK>TSUTL9$@ldJgKpqx71=tnPua)z1xX0Cz3{^=JA&#{n2te4JW;GD$&o#Uuae8f(K zVZQnEgrB?dZQ+~kidQrr9~(6~d_%mV@+}NQ5wBR~@-0q}S9D&%KbUXv&3{X}#iN>9 zFOqWca*y>!T+C$E18~fG69b&ntTze3`LUYd9M&7LWA|8ZM%L^@w3+=z00(cJ0L}z? z<2Gs^&lus<8^VFaSqR6BH?TJLGnVukZ#o|DwcMN?-rx#!Mi*Ib?i9$HyWXK216hm6 z=qnrT3^x>^`gC+t{fE&F_+hn;mA%nEC6PySt4a(WoOGHP!>~Idn>FjOedzeTaX1+G z#ZT=^E&vJ~;6Lj!1@w~#j75+qu~jE7Br}7mFsu)@)GuTe97d z{ztT#{CNigpe~*}vH-p4Q|6!e0$q!NR~oFu)&g*%QhxNK$q219ck^2+EM8W`fJdBr z2RS3@-esSO_aO!gvB;4B-#t^4Rc&G7KsCwNZa&==M|E*TCaySIhO9aE4>`LlPVq?2 zoa0<^X3lZj2Ed9D4d2q^io=}aTycAPU2(+6_PXL!Le(-CZOT@^5xe4)`fC+LdRYav z{8UAI(2x^E{bi6JO}rVIsa;C6v3__ptHcnGtvE=(w*=^p28>$K;%6sWqzu+hgBg(1l+)`f{YOtd&brOyh@+j!%1$(RxC z)Ri>)ETD-3F~DDYYg`kf5c%?SQQ`S%kGbF?{ek2DSEZ$g_fNV?tJUKtV+~K;T|vh z1YJvEUY>Nw%N$C#{F-}~mVJ^!u;I-i3h^@zzzp^lN-RC&$Nx-tI7DQZ_9r4Mws0l~ zr(LBc;wYQCjyi|J-5<~BL6Um_(II>mpZx!*b~o9i^Ms5Yl|$7IAzH zgS9M|pIB9%%k0ahgMGvW-#DGHG{;-Fk8n3OoWMUZ5oS>wqlMAGBx8~16+X)s#>RMF z?zQBq1`z;6Vh=4>7`TKn3$x;pg{A4%4L?`wJDL)WXf1vo);-kYE?QMG*r>&z6d$xS zbwhM9nY1WYT~qwwJQdeHw%Ey&=$sMMu4Kw}d>f{3P3KXXsaNu|(oT$WOiSt3AO0)# z9r`QxcD+Gr_kOO?wC&qe(U4*dkB;k-v}eDIdn%PQFqLb%MitW|YhIYq7A;KAZtvU( z!v!(3+D~*)aY!5+qPO#wmH(u|I2dRan&LAAoF%!}#gmIf*Soz~-mXfM;rfa-ymEF^ z(8H5C`A;K6l<=98H(0pV(0f>xmqLm_zXa)E3t?Kr@2Mj%zkMG(3ERb!Q2Stz+T%Ck zrM!Osr??mO@Gw0zHlN#3Qe5@>Zt_lBEnTG;tZ*-%z1)>i_PP1wHIx)D+s_fij=Hwk z3Qs12w>TKiU}7mO-?_Nxu;x*59=Q!N8p?`Se4)c#`1&qg=n|ug8{e`EzxJk{c=L&o zJ;8IAPWmhpCVvNUW1|TuyF_wKkFgR6fU7vgUv5{!EW>?IXn>1eJ3(`-ud(JB_!u!O zE_e;ObMw_44b#C%TBYi-T=W*ypccE9TI^!iwtwc|61!HsU3Bgk0%o!VFaGQm3WC}l zkL^qUihr|)*@=kJWQYfll2<&2hS84jd21m!Qo3$WPQ%^?p_{%WOZFd+#aEuw(@wv= z|9xlN^b>Ak^ccI%j~5p=NQM^98+ARkEL?QMb#ObEQiZfL$Tq9gXYf0ZVwhqDmlhqt z%p^RGZWzWl2;yFlHEgPmo}J!#828TCV`YKC2uGhaYj!hvpH?d{>u1t9`uqu23nb&L zvZonQ_N6)bqQPlL?&r(d>7Dh|KJ?Ct5Db80?Rzf+T75wK4Z!X^(C=I<)HQ|OrM5?e z@;tG#q_U(r+Wo{S`#cqOK-;{uFR?Sm=rf6((aT#0wC^-t=UwF$hblUA>7Vc9;Sz97 ze;liGTog!CMN+oRNS(R6q}jV>m2X)f;xzMchu3U@#?Oy7GvTXjCj*bcR(ir%=i!HQ z(K^93=m~|&%C>(k-1NIfJ8I{t^gvAQoRwU1ztsvb&-A|xJ48$!>@LG#Rbp)iv-1i2 z-ppS|?5zH?$4u>9qU)N_K`zHihBbzWF7ULMEnQ>0&NAC+tR%e7x*)*O-OKB&BQdYD zE|iLWnDRqh8Wb8&<8_`T`!XTh_7WzKyWEYcUS8*8pYOx#e9Z*M>+EiUPnI$y1~&8KYqqf@TIZnYaiIX}*#8&nchyvr)CqGKr0=89I@3B})$$0{Jt zqA~btB+nS6jpVs5{i`Fc56x=FnD#4{7GI(flLsDrTxmBm{v(G1oC-5OtB&p8S-m{Z zuCp}wI+vF4(R2l$+{;Y==r2=zT>7i4CDvk==VQN3q3v8>(Ejho@*EbvdKQ*vj`m}D z=14!5XO8q^dFDtzmS>LiV|nICKbB|m#?D}QR%gK&^u!KoJVudN+ga6CuFJ`~Rn zp&jA|32D8zYbJ@{`IfU2JX`ao9l^8OGikxAHb0wk{LYVGWo;PqJL?)6_P(JBzw`eM zEt<4tc0PmB&HOQa>76e_^0;w$v3$I0gY2^Njo&%l=K$t7T-^so3s)fBX-dX#y0wM7 zk+>R|J##6GALE)u??>@G(osBrD7i=Mjm*ET73{4sL3xgQ;kOO2d=PLiVKHF%%lFL28*@jkn60?wKSXXkyE_;jK+{iNGl>2%)b6AhYC zF=ZZ493|P!EAOKF(9O;IAR$Bo+vtqZBa+X+QAhhM4$ZCNLGB@au5hH!c-f5e`5|#W zKNJ+c<~W}v-dgVBrM)Yf*28WcD0e^h$694|yGJIB&llwijiP*>aRjdM%}_o+B+6%= z=_sFfhN?qf%IB#nHpI-fsNg&5L^TmeQUzH~s77Ao2%os>9ZA%RM)C1EiTnc*_pvexUe4hxFdb$1&}_s#iY-!*5p#d z`Ap1G`uk5ZcY^Ap7$j`8itZUD-$W4p8l0Q8q?&P{>5IZ(s)IP6wGNMaM?A9mGG09m zlIV)2i_nqF^od(*37pSe+N4gWM38uTBP5j16e6a4uCJJ9bkcg`5L*+DE6lr5b4TtC z$>6%Ehv!-80h;S~6h=ZXf;aQP=(-dM1l>$Xo9vJeE+gZqFYhyQ&yk!cuCV`TC3`7%>Jx#5QTPuFmy@NhjoFzYN2a$sq=Nbyt*dlf5zb}{^w5^ z|MST+_@A3;|33WB0@|nZKj-W9cJV)t;#?p8XA59z(~8qd)saolS=#dU0RM@lB7w#x zyOfD9!6?E#58`L?QaJLoCKI$~Xj`4@ZWB3kGhdOUT0_f6-tu-fmKH5L2MgTX#d$3+ zwHnq^;UPYAd_K%)JY=;J(%WRBm0Z+HT5Ey?{B``PaHW<|80|IeAJSL2o9Efmp1X!| z7quB-H=q76nc5`0JKL2rw!`hbLmLG+TIcW4?p#7)r`(&M`h$&4+*C2r?OKj@hKy_;VKx8=cC!ed*#l5vaxqgTGk<9!t~4f|QUB48>Qa7I(rvW5I+1~* zPLxYRBOy^p%3RWjP$#PMi;rSQ&Dz^|OUM69>e`w|zvf5ne&_2hy)xxD9srzOd_@_% zoBpcyFT_2mEVVFmG$>qj&t(E~L6Lo&{-S3er^5BOeVD_k<*chFywWrJ4rSAK&wgPl z4WxY_x<2*T-A=lZB8NHQqNjMn?c~Avq{w~UUI7gYIdUs+#p>cmMQkoD+djfOck1Di zIJgvDE(9e3W70;Ys}2^$9V-_ zXC=>fZbFj40U+J86G z^|hxnU0>VFbiJ^b=~`N>AJcVNmUItt8NO^x*F#~te#OtcNvLdL;FT6@00o)xayz2y z_3B_Fx~{rQu5WnV&}ep4SF^ZxMAt@dt}a$fxX#u$dbJcK=Dxm>@LW5Z>j9-?cMbrj zDq=c4{Q<(MrVyXy*n;#^Pc5U6yc)eJEr^kiUEyC|Nd->??G7=uQ@ z?`^AubRT;qcy|;@;6{@Aqs3urw|4W(-#e}LqRvv`C| zM{-yhvM;9p^FrOm6H@EE%sO|Z4!6+XCcSotW4I;|*LnKXgLNrlpj{_wMysUCH_G9Q zuhX8-U#?@2G|~rav(d|7;#@Ubz~K_;_Gr@ltQ96-X1pMXOhy9P3U$#dDylpNnKij+ ztrZK7w;wO0o!E-p8i7l_>KB8WA_*g8EA8t`a_wbaaTI`#;+)YTaGooS+)r8Ixc-}- zzNVio+<8WhPLLRw#+N_HaV@7S|6~gTEAnWj%}6YO@w#51#yLS*ELBLS9HdPg)wQlp zR_*S%7VeJfI$5~K$2*~Ka;sajAq$rzRM)f0wqoeABde1yZG7pax)!`}RM%evE|_l^ zN7JX6tVVUs8sNMeK7>*(Ty&lAKz^=mT8o<@xbt+X>v35MO#YG94TP{HYlq(4`zcUe zpT|Cf!2dG2CwS%*QC+_?%8nV(!IA?FBKxfE+43b?`Kgs`q2zcjgT^;)EGu&wrt9V>(5zAPa2!GWkT6gIIdVXp*Nj1`eT6aKvy-0I} zTI(nIKUFdRwXV=h1yEut>{)h=j4u%Gy1xovpY`q0ytSIS%@Z8&0KTlvGP3rPU)~25 z_Dktmx9d{ol`b_Z?3auRyW^Bky%o9juG&}ZTM}=*&q^9j`RMkO`i86E{v(Lze%J@4;6N`ggH&57f`jcP+`xrm>vub zF%|Y)3zwF|c8GPHi>&D@y=h+SrTk#1v6qmo2(iBl>^=zf2tqYx#`f4{KpmZVHxM)S zLI#DHvAZlyCUugH)_}H*gZI#5usWlQmjtPuL1rfuZ)Y-Nlh6glDJ%Drz0BC$vb4Um zX-y9^_CprD`8L7Nq(8WtX}L8>HKFgUMu_s=G-e|4lVyi7WQ)#~y`o4*u$BUh9@dl! zqsyRCR`kZe>nyYO<5G2m??8!dY!yc4vqeL=@l`E|hgs8|-jtSI$HR2KlJoYPkp};$ zQNC*xZUu|Gt51^~K{l&Ks|JfHKGC|SChJqRm(cwU`Pu>U$d<#m0(HUff6i75~s-qT?dKNyj*db-z4y5T}D#$J>oPk zw>ZstCY3x#E$O5iG}+4}#-M5}1lQpkcD{91rb#{uyV}<|HXn9UJ0l~o$4b85zI z;CJr~iy?Y4(+~+i;k?mf{~vybN2Y|z>ZKOiy3NsJpLZMD9czd1rB$$S)rU~@vZ;+? zvJ=!1lmWhTS3|T&XwobrS|rGqIDJ1_OV}k|dshdaxH;GrqSrXMg$=>49wjHUa&0h@ z0OQc2TY?Ne=PhcLr?pb06~xqIA#bD|BBCLMCv&Hf-FDc)hKS|2D#=-rJQ`ziYu4gs zIycO045Pb6pS)O3pRA2aLHTkX7DiWu(LG&t*64_RiVN`W~(E{cDd~_F}BZ+FqzGMbnmf2xu}C&cL5Bghmiwd zyx7Zw6x))(P`xT301@#zUp3AU-NFhRMty$8gP-8uXE*cyoxB?`^AaGMtXkNtVHnZ$ z%n(M+?%>dQy2Bj6I)c%z5{9}8mbQL|eWu9TO1-1_@Gx~4vQR(8?}KE99t%>U@P68l z2Fqr$Bp2;bwcB{VpPJC+XbfGVPeNlTT5KqsttBN1k^!qmw#KJ6*7)&g38Q-WobG|P za8S@giv1|0*jPrtF@Oz}targRj!I6r21>%VI!t@5mm8>gv1U`UJyp;0-EVwNqIT<9 zdKMG89ib=2i4^fim?|5Liu;1KG^%!aHI zX@?G{z1rXo9}HiJHn-|Mb?=v}2@9mq zs?LRBa`OMb1&Vph7_v_izIz3{ zgbI&q=05U*RQH*DmFR!69RY#m-xoo)JM1vb|KPZ?O}>~!@a{Q{AA6nRci$r4WY%Dn zCLk%p;&)&0Dh{wq$zVOdK0kM`5(e9(#`IYqid5=|=d;?HbIS`qV$KB?CP+!M}odiJ+Fdo9z7z)gCk2ZR2QxH6~Sy+^Tt-}3|(O+^VJ$6r7@E%VF#xiIHG2W*P zEU^2O!H5XmJyM`*kq+pwuNrw_Opgu0-QCb*Pe4)Ur(HcFDUM*RwLBV15JwI@A%mR6 zmwpRHw?mKJ1(=2&dnxqT$BiC)p=?iUfuEwsj&GL8*3GDT-E8#OJu?){|BRlIwcvYn_iKCyo4V6Vb1lX$9~9u_tInEZ}&Pt zXciNAvDX}f?ILc}qtIh_5g_Jg7Eap&r-h-m#^JoMaQ*+N5Ng|wFKP$d#M6L=%Rpho0|!6i`JWuP_#=cJ=S7Y9dA5v8^TU2|03Jcgr0;ggntK0GB2O>#a*I2p4$=OS@3sm%%)z$rkWGY$>8^B zK}_4kAvktwNNR%WV*p2t(0wC?b^b0&!9EL)A6pt*!4on3GlP|t9b=bD8}nl?1QEcG z-R}6Y`>OfgJLft^ZKQ+lG_bhJ__2c*0gLUVRj@LBr`6+%MeDG<^VXK|pY-}`mjV4o0 zUO-pLv8f4W9SfkOQ+Fk}QuNr%V91tQk^DK=G?K+r-K*;L9e`nUKREL)a3-OG^ZXu0tCd ztGJTXk(L5KNTxWWjG$|E7rfJgD>~;=p#K{MqC1rXZNgIf&ixtrb$%oMHda8`!SZtq zULpn2IM}*2Ieu&dq`b%gXdXTsz~#U(J|!4@kOKkW}Enal8m$>X*mvDt#a+4eG{G3M=}e zbj#mq453bh6m*La1d8*Vko0v2NukCDl3`V4>pa`BMby|Aishwux0DNGYHU4PrV>3` zzP$_kP-FLiQ$wVp#&)pA!BnHhwxT#{Y!E5fg~teyo}&mDHu@C75UIOIMX&~ur|3-F zGrioXvELsaLW~DB_EDq8zUcM=WhK8yK`=OP{^3bt(=l9SV`}W#{iv~H%cKwqHcPx# z=^20ean+-bFRqq2zAZ9GDtVrVeg|soIj2)&e@E2VGdX4vLl)fhFm`DBa)0t=eDY-s zU*g~;oYEcRV}9yYV4y%jlJz7J=EC$ zPznl!8r$>Qw~-m=0APK->BHp^ZG2d8u3Q6}i8Y8%M~%JKQDZOpn5O94h!Lo^ZN}nW^9pu8#8ub%-B2iNM~}U+|FkF2br;_^mQcqa*K)?+rgq4jLbPPGxi5H z+(nW`ImC}ZnY&D5Ja8lVjYM_fC=yf1N+2;F`(A47S;h{G_LL)%$Se2(d#JHrRs;VG zBxRegzkwe0GcWh2#$N7aAQ+4puzRVo!_*sag=qLM*8>WVcZaDr@lKvbjg4Cp%R`l7 zUsrRLX?Xi|rML8ZM~&?~P3WHM~|c$|wG zd-?lOV+YuMGaDml8;2&;*mcoy%f|=)Y$P9lBSQ;yfoHWhA3tfTe$?2m-BjEXRhyc) zb!Xf>Qj%7k#E$sCxO*2csj4&IyPIlFV`Fw3TSJs+C+Q@Z!UV+&u~53SI;nzPKoXPa z1eK(njF~Vw1gecmP#d~CVcTru%wfK9&f&~BGoJ5pCS;QN4l^+h(QfYExrvAGS))Ywx}Qnq-pmJ>NGx+O;ohulst}f4%En|M$%6(TTxiPINnJ>?ziZ?gHCG zF0wp_R%G)Ghnz!lb?0z3NHa?M$_i|&OPf)1k zP;IjTEd8CnX-L>ca6|I7Ub1O%u}Xah^TUF=4mFu*s6hszp+>Xu3m#eB#oX9as1zv~ zqi&(*RTv3)eLgWLh#MPzqyF63`bZ(wkxZFLNLvM*G;VDF9plE%r;h8G{wBwbtqenw zvq!1-X7^NXY*KoS4+z(SfZ`|zqWAsqI+^}XOF<9sBUCUOYr<3YC0*&=eJk04r>MT>Lg zU)paw!{jiZdd{0&A8{nn3b+^4T0`v~SExq6l^6`A66b;|=|XZ3*aQC|7LPphX18H0 zr@GKY@cW8{99*yARX2zz$(kZ8+`vA}p_nMiI-mxrsIePZZqU@jXlfSpqa34;Y`5gw zTK;%sgi4nxV<5#6xL0CFT-$oDk!%uQZ4axwdU5a2jpVhI9rA4r>{KY~L$P|!yscFY zfaDxDh%F!dTMu%SoejaWtT#SItBD_bko;Q@V!a_YPkY7wz23=p8|%hCe(W$Kmyl-` znc+R?yHCt;v`Qy2du4CngxIm|R|P?vt2tkUN`16SH;PXW*h$q1lW{Iq_EA?suftB< zftX(DZWb5^hN+nk_t7iG+xAk+C}P>3MfBLOVuPc>VCk6;o`0eqXn{OV%pNCGWx3V6 z3*UdsY2i2+7*|A@=)RG9?n`nK(n!e#M zLCzL2>TGoQTz_u;LxHa14XkLS@U;@nb975}6>{Qz#@4f_AO);K!y;M7HiY zB#pfBO#Ila@Z=Cut2@V!eYj9d+J?g7v>AVKlEqo7;a(F0gM4vwp#OZF-cVMW5{IVU zn!bbr!iTj_8751jXQuOw4=Y5FolUG5Z#y5^aGDWhFCTBa9!8KICvODV12V)))@$8n zg96TJf#R^@LW#OrgdZHt)u-sMw%h%cdn8Q{pNzXD5;aDt0Wf8!-`^_l9q|pyGy@ zFdM=0n+dZC)Q>QmyVKFzw};X&NmlHfFR4BCzRT|2 zc+(WNf%}}JpLFvu)fVw*yH4C+M}10fji)-%nZZ7;;e5L$6y|;YUylqiIu?~oKZ_MRqH*&sghp}zivJk2vhba zv=8Il zA`pN`ZnEX*oTS6%oK(U#c4QWlPhkH_7?>uP;26cwstASgN1o((#l_e<=C}|E9#HXX zjI0gl1&L}|zWh(&&URV!Q`@}RV+}^_Kmp&APoj&9ib@r#s4AkWMng|U&IKRR9MH3p zv#NdyyvRFm_RKTFsP`U%*@Uy?VfXq%FxWy9x)ED8+FA7`3?C)#bHRnb4O_Nb#X523 znC7%B85hp`?b)(%>NKPpJ?d#}*}U+pPhrb;DfO~tE3tSDgkgSK&aW}Q$7&&)d>NMP zb(NZ(`Hk4J*BSKax3zzx*oPKbHS{W<{1C&+0c_dd1Lzz&Uw!Z-KV0aiM_WSpCJPFVBY+jvM5t( znp{4kvBG3g#-PG@$7o;$Udjl-h>l!5BccqbMe8>N??~=X2Q~3DVJLwR6R?8HjDHbJ)j3;U@M45?%SUB6YPRMoeN%x+_!DjL!P9AA|>ODz*~Om zt)Ms&@30Y~!NoL;dVI&baVsiLs<-76`?0{ur(WuF-=;DIi_=N13cxb9${)BMeQ!ZZ ziXWx^C83*%$`7X?bWX5R!hBFZ+QgK>KYX;A{glFZa}MfB<9z#q#WpA_`rC4x6AA4e zZy0%HZrXORr zx`h;nV$8AvpEBTiFqij$#0`0FbAadZLV+`{~l4Ne990%od0{XSYi9S4|aaKMNt&q!MF15=utq>+QV*^s zr43SfHNmQ|Dyixv7YtR0GdPn4&ZtGb*{%OUIP(b5IxC-hEZaUw zgK$~0kZq9S@-T(W1aE`-Y=|LCS0ni}J99KxN}p~;aSGz4tJ@Md?kXI_KVeCM+bq2N zqA?VVceEZYPc!k+BkEG@$YA}+e)4l@&l-ZIK%Mice@-*rnG*S^_LF;G`R7Z&!xCGL zmrK&`#AxT{%gb%EuRq%PQ_#*{Gi1y*?#(85`3V?j$%K9-H5gWQ+#uKfK^ZcBP&>$} zeg=%x)8(98kMubjMNc*;VD8TTk>_k$ zgp=G>ac(sRj4{md8~2D0xIezxCIBI~X;sHKJ!1Yq;LA3DAh`fjbo1kp@AC&jX9M5B zG_8{t#N@V%$%1_<({1!!P}ZdO8NgX*+lv|@oTDVSgBKY7BfP!o^LDo1@ns+IW;?#@ z^#B|f)Bzk5c=0?R1DyXsSz`c^!^)^XzR7YRz8BvZU-rEB;>$LGGu;5rdIxae%RXEX zU-sLif^3LzRG%`ZbpLNcH@C-`lP0G>Up8CpDD-4O*^e*#Qv<=xr+zcILGbNo?6Kt1 z`U}d?MRmjJpqvtvLY%{`=v%B6ag8J$HjLRa5@2+i()+ zBZ-1Dhq4rlecdkCMA*zsA;q`$@8G`-?x^fD8SBrIeIFAIdT!3c!;;O={vt9Qu_XK= zX&~9Wg>_n=JQ3?Keg|Za%@%C>9flLd7XCpc>GE z#EQ{AW;Kgs*~9t4D(R^x?iO=;rX4vv(a7l;EZLC`M~DYI^(~Rpvp$yWeooI|w#lY& zdX^1Fyxgn9fh8NnvxRr;%1M#Uyn;c%GyQZpt}Nok>{Z{0pG8HNn6?5^jDZlyiJwy? z4~{i&@EbSEEr@DR|MKCtfj=;rEW=BXms{q|(J{GPBS*Gh6HT%Et7BSo|C~mEB-^Af zGk!#pZBA&9X`?Nd+T+cgN+6uj2D|V<%Ur)qX=FIxY(8k$3m9};H0FG^o-*i>_@?E2 z7J$P_V>D0ouh;*q+7_`N%WyT4!l-nL;mrPLtwRt}%UsR$3Tb<6&i||*`=13QaWY#} z*jHI**?)+#h`$m%j9AuQryl~h40Ek@nCqp;z;5n`MBjnHkJzxk18?s9ipNYA?=rd# z*@iT5!e`VTQ*#lOIj*{w$2ct6@rVUwN+yFa!du^ti#qCQPx}t}#F$HLK0*tZSb>XO zus}YjI9qripO|?G^HJso=A+(MnX@$?t&l&?yqk|){E%yCK614p|B|VV97t*G@RM66 zBo^&(WY~*#%%RW|f<-&56ybbhv%;1;Cd0OSEQlqGFrbRbuvvD^93@$F7n9Lfu^Ql@ zDI#%{kzvm_f)I6Bi&SLT%c+2Df^{x4QS{i31O7A58KV77>Aw?A%)RUFy&8FLKKcdq zC;#NOgTQHSl3sE}5hkcD0P&?mbI*RzPud?i6^sn=P z@L{|2fDyGwzw>|*0ZBwU(vm9Aw!8+Fv+-faTjT==Ve$Dh@L@lPxy`%tVQ*cap5-XZ z2Jm68l5uFrpGVz}Tc8;62R%}qYINMU2z3@`lcQw6)7jhAIJi6sH zvfK}Y0z5i9mX3Jb)$$DlEr%m$Tj?q$W+azbH>-!~F(*SU+oA|?(b zT+;TcW5T|m?QqjbM@t124CLa)#r)9_QG8N*JVa|!QIq(|1eL|}h#<;oRBzGCIBfr% z7cOC~{w{3S+6s=-QN)k`qbN|^?w;vaimw>mwL3^%yn3k!i(f6)8Qt|V%?TLeb?$=e zdLvxdPrd|qX?XQ{FYD*}k=$X1HN;U~7qP;6-aiB7HGBy*P+oWC8gVl`Y-dDqz0i)S z6dy2(>%+z8ptx4P1O^?&^_@m>J%6c2Y4M+-xE{5pc)c-PFFGVFTdaOtd0kUXyw#85 zx@Nbdxc+1p@!^QaLSDGtmFmB}PGyAG58arEt>Dgm@KuHY9M^vPrC5dyRxi;fmIc+d z@>ARk$F)QYln?aD&fU;YiQ{_z1}pznj^lbSgb}hpyN;**IIg!E$2CT1F~@b8Qv9ur z(2Dm$5Y0rjLnf5P-4Vz26x3DvS6mZuT&qh*9YrM7)6|W)zlYy`9M{d<#={W>gw3uz zin>;D*Uufrb^otLaozv3Q@{B)zM&B?k`zBm@m0rg{gpM8F}!->i;1%0XN}=HUT=xt zdQ=A%?QK1Usos+xg#PW1;p+W*&kLFGM*P=zS9m|tblGyOws23&vEhYAp0DEh;Jb%& z^%Pehy8DurV|Nrj#O>eOt=DqwvZhN9cMd9CgeJB0L0wh1JYB9?tEa;fY5MOdj_JQo zlP?JSyV}PMf!1Qbu{iHv!Us*8Tb>@|J}5n}`xm2|j)C)0|NP(O^8a=6e_LPv@1CZ- ze_MI~${!~0e`|Taab-g6WH%1A?C$Q%?nY&IQ=IpBAs1!)G(Pd+^rMXTZyUyi6@3KjM=UtZlbMLbH zS;0%PXMG0+$Rm6_>S>)^dRSL1>i6Ht3DS=b=MIYU4u2F*Xt1$@D4Ue=E-r~Vg-a|z z(L8`a?V>uqke#_biL69H>G2a88riG*_=yZB?a8G0$s_TTDe;qE#80NhPdef!lj4gh zTxiiDvrqjFwckZ`&3vMJ*<$EdJIJD_F0U-qq@Nf;5$&$bYx}>x!nXX`=_fwTvj#z) zf4EJntbIW#J!@w(4`*%XPczjphu>@?oEt2icMkPGc9KH{6&OXFpQ~c-Vi(ZTs3nxw z`V}I{1j|tjuinePB6rHgL%g$v54jBRcEpb?5cl)p=e;NE?n{SL>yEU%Q{nx1(_~fo zQOIBKYd}vM{%Lu}d-5CQX$ayJ=JR3ZLp>I-jes27AjBX&Jn3_W`F{yhD6Iy(h0$oT zjYU*ga>y7Z*N{3cu8E$TyeF@^0Znyy_mP&9r29#wo5b3&dtx~C?DB^2Cj43NQ@yk< z(Pt0bR+er)etFZ`pvp?Bt@(Jesan4OKr-o`m0s)rAXMIaa$`E!B~r-8$VGbAHvZPr zUmsouC-mM7n)6A#$A@y|tT%O@O;1MW!x{BHjIDR&!>>)kC1Bl@G;ILGW?G+2uB+9p zzS>^TN~M~wEA)6ck28FhwO}{bjU-H5$Am4{YNeU<*$pv_8d(`?B=qz6rreA95&U-)p9@SGKoJuByq^U*Dc^L-5z6 z6zAxH>Q=VE|3+z(r{-rYOZC_7^4jio`5}8zme$3&d7yeuP2B@Eb**cf8p#7$KG;QD8{d)s=(561MV%ezdL*4?2$!WRSgtmWC_YM6w;UbZRMmjW zzwH1Yls?#Uw6^I3F5hiiTol90nm&=@NEdfr+ar8Kc8GHQtP9J@Dgsn6<5N+rQ)X?mt~BeIb=`TL&^_fte{i|ZyfyPp0W+gx?AFsQ?t$_# z3q@Ww(OtR~O`VD1K{Gy~5hRI>HgboyjtQ-y>V)))^de;qdh)^e6+?`aE>SNg3t60$ za*(%f8h)O$$yL&BBQT~#BByPtsFjJv$$UVQ+9cTy9OG*aFH6ltm%EF^K>^PJL_3qC5p=?shFz;S9cLvZd(s@b7IMsX1W6$ z2&rzsEt<(&$WiecrABsKb7I>^bNcM)60&JD3=V9Ki_(OrvIS6AM=xO%YS5uj`fB_^ zh(e9ZoXOERuFDJftYyi=Cvjf1#r5E)^njemx0d`wyy|iytYTqX#?&!(E0jKulsV2? zm3u#$#}iYH$u5ySTd^qqwQ7W{9oZNO{aE6kg2%Fr``}zfpTT6?K6iv*kI!c4+P$1W zu0ppue}vK@yCa6$tJiaDw~C~d_b@v8RWA_lh$+endw%~d@_>hL(JX5w^}av=)1wfl?^b_*tz>+CyDRVl6F-}4D< zk~#T<%bu76IYBIzcK1SFUk6jk1ies9!K~{@W$uYq6`v4OJVx z)_|`W=;4s(yR|}X1f0ybkNxB;a8wvD^s!y0_tz6;T${OY%#vJq)#9$qUKPTXRBI9o zl&q*LF8Lf0W6~7&(!|PKQf-UG?#wpgqIqR@*3tjYD$$#JWE??f9c^Gv_kOaA8>lbC z8&_~}3wBsc5i)fnu^>Xe9XtPfm%HA}<`Ml+jL;}uT<6vBiu!J@rK7%BkGfR`RqDS4 zM@St~Z_0;vBYoyt&(hIijs>Z5!gHT7e;|Ktlt-di6`$OzC;;N&8@s=wVMH}#*ke@h8MUAj_OR$l&tlAgH>|5F)4bMIF zs|2*T{s+os(0ppmj|&#os5I&DTj*uGyq1s~P@>i09uO+#2pcI1XC!~lE-*%IoEXMF zj{OK6hjAVYlhbXKWh({85CbNi_IaC{iGyWC?YQu&%4}kNHnpC$f<2X1x=huaTKu@X z?7&~S&SSkrRYK~wANm}K`=D>qC)O_|fC-CL)(IyaqWhG)pYbia#tD^O{~kwVGfZH_ z;J2pow4_%O5k>t~p`$Fb$7c*~mV<57kT z7f1Hob$YI>+s+%4-B<>9KEbikndek9f~UDzDRNVi{t}1xT;Rkg*pY9>lr5glbF&$IbSM#Y8RN+Nz>j7i=Wh zI>l?%)R%2!SKuJBGJwx;a$O~MzIdl_qd%PgTr(e>I{H~Ss)}S-YPF-CGjN6QH^kZK zOxvg8caUT~?L)-V)`a$&OY`B^%kzyp#3uZ*I16%XnZt5xw*_xa7`$kQB4hS!JUStm zw?pC|YLH8zC)k!-yDL~d0X`aq5T#&lElx%sJ)tn1DE^;_D!MxQfVk}_fZ7i?o)@E= zde278V5^czO|Bct*fD{0kjYG*KC!pz@e{9SlPAHIIKXUQbi(>Ea)LROiFD_NkSWu@p7L9UU}f+dz2%BEDof>G>*P0FjvjySmpc?3oT`p6IO;NaGF@ld>y3&-QL zeziBZj<6h;Jn~B7nU<~PN&F2S)jk(u8Clo%>fPCFd!Y_D^={UR+J_Nfy+k%EaCNqi zc*}t4w=nGKWc%rb9L71tXrAw#@Pb#Mx4`HFOlGY&rtYA3-&|{U3=;-@)4LF!4DrvP z92rMUi;+#6r^7d+D%LFVvJ~Yh3OwTr*>-*)nTE}n48*x(E?=i!#I*dJ3Y=}nO-nfB zSyVf9K1O18Vj&l05_{Lzp*)MGV+}BUQU+YZ|MNV%QPDwfHnci9gFTF)#X%-41!tb8 z;UvRBHlEo;I*(0lGweBfLm#bSYfY@ZshL9SNas^CDZZ$;_7bfj_zaTCD&4DBk%_cB z?kwX;vNuH~Nl?z{QX3r)l2grdmSwIZn2I#Jh0q-HfU6gg0MOKCe9YBbqo~j@M_j!% z7S^!lI?mn|hW3`5VOObCdj=I-l#&T!E}D@ymO?f-FG@1V{Q^)?xd7_!XR)hQFi!JfRs`#RV zi)@SPv|sSJ!ned1tKy3eRk;OMRSs8n6am-OTx)vB%{t~-Ca=NlWz?F-rLduN;q_fh zSgwO3nXy?E?(gZj@7rphTaZBM&!`FEAu1}@K6TVcjOAs1DvIZK zfG+SfW0p=8=YuZvQ_yDt48T8IYH?)o7&@a|qDviKb(TwYrEQi6!*p;4{mygF&b8k> zYIH9@(Jkcy)ekGFV81Zr9KIrv6(9^ioy_h*O;82BQ47&NJLtzQ$(H3BJ zv6Mp`l?%Shp+8sM-kjCSVkpz+#@Dm(5<~aq{+hk#oCb=Od^2tP`4hsKJMIy&By0Ze zeE28WL2UBo{xLxsg6?$idKyc^aKzh0h|Y95d=F_<4*BF8P)jx>_d_kodZ3S6()Geo z9pi({QkWq#%V37=V8`Fl38{z5h#_;rxFs_KxFrvYTk_2Weg^#H3)syBg|~^J5OGT$ z#F}#tM$kQ@UX?Z7YqXayyE#{4^>_^fHP$p5OQYu=eqjVU(M-05QfRF5cS7!rW(&tUDr8ADzz%O^O#q6G#FFKcyBErDb79r^YVfXH3> z)GorvsPGkdo1PW*iK^e5y;v&->@sDPnS4I(n6b2y=ECZ`7bdy-&IfnF@G}in;YUz` z45Iv;8qs*v+N*uxQZ*&^8SKYk={MIzOfEp}hiXnl*bPA!)+q)x$zobg+oi(r8{d(1 za2$&R8yJ7?)<4uw)F(I{K3Q~bnd!(rEGSSL1eEcRSkuH1x*{BP3wa)TbB zI>U}~?k1H?qEwLy3_kd6g+Xk~bR~LhMwAOk)v7OxaSiFLE*0*CZ)c$WB$4RkXXjpL zKe>KfFmHrn#&U7QP=0e*oH^dpd!Z1hnC=X`QD}S?4u45|SDV%dJRAaDgza4+**G z;@a)$EKSwgPl=VjA&0uRojHDGn}%#iG>wUq)9s+bI%9C0{&*rPmG{&{&4Cw>W^TRM z7#v*%F{cuR)|8VpZUEW0@XL}?Q?;#MSDajZlJ0X-*1pEyI6OE22xBFeT5~_95z&`S zfBF&$sV|G~N2L`@*=!^pPhYu4I;-9l?0c?vipRhz;3LQHxQCljJ-;#th1vdxJD*61 z-4XZ%sJizuvg7syqZJ+ke?JmhL&@PEoa1p{n&<=ljlWR~!QQW2=zKVDkkFVPe*7_N z^4F^DocGjCFhBaA7_DW3Dp5DYz=nrvGEz?UDXpS1Mv5xcMLhFlm4Rx*XX^kM?u@vyjU}PAb9*&;U!YBhM}XVwspo%_cNdHlkUp)9afFzRe08+UkX}bPD;Ll zwd30TvjJ7mso{-+Z*sWB3D1219gSuTAuJ)K%CpC{XU-nYpu{vEZ97u|t3o$x!ozDU z-OMbhmknRU(8=Kp%>N1bFsb<%i(>mvq%agyF&boWd-uVmtwJSmWJe$ij=4Uh^aThW zK~@e%vBulsppGA0=LbLNhn%trmzcq_1ao_`Pl>?S9e;W~82p*PW~E16q#t&V;#SwZX)keH=I(ruJ`Gn* z7OnzOo$A?R|Mk>Va{IgDs^`49&lALO)e8<+y(ZCPxN6;d;wsm>N9`FOOck!0+8(irXT4(_h2@y~a&M1u6Zh%3%9s{U z#Z}t+pJUx8o_1Yc`*2mKdhf%Q!t#N*3R4V+t8@@8!c{tUAK@yLtHM=AP~xXv`?cy( zioer=l^7Kv>RweHH?-j@kiX$7SU~q>g=$1p65}dN7HvS`6?OowLbY4B`pmd$J!q#7 zSG|*k6UD&609-Z9;VO{_7TJJUYJdF z+1hS=Fk*Ck7`;es zM253vI($&z12}gZM)9+Y1eKbe*Q-oCDv_G`1oloIQ z2;W6CXy;RwjKdyS(a9cI@PG|ahp##Y;HziASHlLg>0~@`XbI6(2dzUaBOr6x19K?c z*#mEKGh0735L0?9%|_i&c4fq-PlPgBD6EWlkWFyXEV@jsnlZCK zymG{Xz3}Sl0hD_~IO_Tec&9?K0I$9kbG${j2CpKs=jo! zcA!U|IgtoseJj!A#c9&k-vVRxPSp@UNhaA`?PgadZYJ&7Uo#lw`rhvee{$iCkQjD5 z62n>lk|=ZDOTz1)UyvvpC#PZ8XrCq5-g=$DWWIggb-&QOOA*~J8iq`I4xn#)@@iA8 zb(mtU165=Vsz@o;Djp^Xs(>$|SUY^7inORgU+IxZ47c&@@n-JPon6e2o3D&&Svr`50rvs0By&yc+Yv zpc_}IEn6=2@silcancJ)d<62sDo89lbeb)y@AjK3QQKGGOqx|mR90b)lE+uE;*HEw zjGk+~)+Z=6ye%vh-_UNm_u#p>!@%Nb!DG-CUaVk2r@rbUZj~7e)y%ltRe}4JT6k8= z|HS6EecsA@c&oL)qyv}VWft`IF$b?H8x-^N9$7kc%4mZXRwQah^wkh7&IRH%><|x&X7*JC091*pVl9dcXnUMa zQWiVf-UI>*1Oo4TNGzDyY_^sCz#Jayn8_q!(4-b|3G1jeL{Yimhn0P5D-KjkFP32U zb1^QfAn{QQ4=Lh+^P6mI4BQ9Pal9kM z1h=2cii;)`+pT(`e#-2*TdGiUEi>4-&~~?C#%oC5G|M4hK2nZUArSVmeZ(;`&Y7__ z#JPE4(F}A!MwRnCPr8gM2W;7oDrXmFrl}WEhYqC5v6`Y1S2(sD+nl9aAF;z$I@ZR7 z_>!O4C0)>pio-NBEyAJM7j!av_B6AJk82FkK>pH6%rVU|S>N8`z!jR-Dpn0haH|ID zT&tLO*=D4#s56ZZION|i9S$cMPEm{$qp{%WB< zck>l|$|5J~LhEiJD(Bctdr&ANH|E1Hp^RMY&0R=P&YTC!;mye;)??mSo=!qH?LL;~ zByD8G>)(@wDL2oHktV0US&Wz21!4s(CH(3r*UtUYxj=z z$KLZi9+LLn(sNQJItu4R*Quj$e%%%ujc%16wM$=(MypYVrdkIU#eDFb$%P4YI#q-^ zWR`OzYJ7H*1uN8a#3@4x^;j-pQAC%4s>9W=*c4TeamE9ry@DkH+jy{LxMUX zI>ChY5nFsaK~kFwUPoviKxn>XC*8aH$B#F+M4^)ZlelW;&{7a9; zooLcj(leq@>=Oj6P)x_a-po5*8W)av-gYz*W4m9z3JRPRPephY_n z>zT9VU*!nhGq^`F-k+@q+C8}>_PPUWGM2T1cIt%L;0m)Hg+B4cEFDpe;?16G2jvG! z=~y~TT-K_Ze>aJeO}Ne|MelyK9rE}wwH?Qxt#gGxps85p@GKifb0O{ah{6Qb8tV^p zsefuEeq?kooZi5UBG|<58nG-c=TcUFis+PXg;ZD?ck*Th*u zm1kLWsU47PjjAw?7ul@Dq-}mW$%Sc~4P)^b>oc~rUnC93dz+<|!9{AP?<-f41dZ)A z{Kl2?1-=!#uK7cRmDJ}=|NN?7wH_0VAxaAennQ$k{eZQ&l+$Z4K7?@5zR0o#^?1CQ zp9zQAoCNelG}^BJyb47jw@73Kt1!aP_$a0@o0Oa|rfIZ$#tnuZpC_`jus2aXW?QgG zt|?s_*Q@TmwznyZR_|8YF5M7ZS#(I>R!($nrNG!#FV|(N+iRJv!1Qf(OZ{^|lGT$E z*Y^Fp!btdvz8I~ZENlcLIg%t3T!$rXX12@HZG8)=fnXJlbsCEwuPytj-?+4Js8yMF z%Zh%eb&>6rV{tkwLax=wh#0x1188ho50$CZ;g~B`1NWHxo_S@DY6C&!H*QAv7*9<= zT;mVH=+lhIO0^9^hdPzO1K4X7;&%zJ&|kT^Ms9&41gjC9PrPJGL`5T~7u{@KN;T>5 zt$=JZWk3nxC)Q&4mJhyEiNhiOF^m@zT(}l7i%qVNm23=vb3y8i@YR9DUI7`y_3)~t z8s;Wu8ELLUVynji^B#i8@%F`tA}W<8F3ra824V-G*Vp=#LXSEfGo8>XqkRn1XM|q2 zfK`_{^on<$ZPejvo~$&IfC#;+=r5xo!y!ZJW%SOrTZo1g|A^SY_Dx#0sc5x^Y0h3% z9GjRpDFnCjHQo|IuNb=0SMbN%^L#(_>PkhgXaLwa;M$k@$V`IF3pxA;r<+_bW|Z8> z(q-OR_A50|4oNaki#7Rf!CV0bf{nPu&&j}7m1t?a+R(-Z1u~ukSf?KgS;Ee;gqO2j9 z)W2*V>fD)-Fqp<;{hJU@Ue}FP*o5%rb@#BMW?%5`%VU{oj&+>!781MTuq^q<0IMsq z9Ddpx3qYl(m`{hIZ2C?ws<4(Y!IaA^^NsHBzC|A@cOYd-pe(DM;r^3}3rYf!eFjWb~ zFts^;N3ChhO>^&FQZ4FUMKM>%G`m{XweV>$)dU1VPaSvK{y4)flfad7p+0IgK~+N{ayGhQ=lg%aUW_%=Sp?z-@(b6V=8 zGpO`BCNfcOd{ot{wrlhsf07H`OT)QU&VBlMj;b3M(W%~ zlA|EeiHF3^ODp}vyrmM1jIyP|CF-13IqlUBjYc>9(Wo9dG^#3pPc&Np5u!XJ8g=pZ zL!&2ag#%>!pbSlnn;scrdeo!CUv-~ zHhd3F>QFV>duvjw736eHs#+-qpwb2W?wZtEMf|RsRK*`dQPY^r(StrrYMNAycByTw zEp1g-%8@GM|BISbS7Y<)l;8go zn$+RM+ows@9R~OVG^uSo%QY@R6XQ3o>W@Yxxs*MJLN6Z1r^yXYd8$4nLEB%6Dg>(F z-cRIc{_N7KuM5ln$ z{%TZJirp)Cc$ym3UPrx8{u~p3Nd2h_@|*RiYMx&GsY(;+PxZCdwyK$4{iy`%Y5G&E zyMg*sJ#vUumH(cI^$XgJKONfU|;tA(^I^*n+mSJC)peK&AVUtK|M=l1rGd2^G5&IcPI7>)aPa6EnF)eQ6% zG>(!NQ&BqkY8I0=KCV}W!eNF?1Vn4OcbS`f2&JegO-J+04<{c2+1b6CRExJytO_d9xuN_NIbWy0D5zDwRhnlH64X0aFL)5NnrdJ+B-m$FqB9A@_J4s<>Ze!oL zT7?MKPQ=Cw%HA3w{1n1*EGGu1aV4Kx_lP>B#KCe=!Lx7J`c-Z@mfMZ>s3Brp(fRyG zEh-E7(sr{l?Z(uyi4n6c*(=pb35{BBwr6c<9Y; zd5_KgcvJs3Xh*f6$PyVIC`a|6^Bl^x%vP1^W)Hhg4Q**>pgibBixlql`jO^`)uwdn5WE>$8Nd*t9N zi9DUfpO4i?5WQ)+p*+{}I{8}mD^X&w2YVsJRqvBFy-QzKv7ej4Ybo}Y+XiL-kw;Kw z{py&4wyk;MpZ)!BI+z)%vl=s&=`h{%CM%AI_yY&hqM?*E z3bbe_WyA0G$g^vUsM>OgXEm0rSXHghWmP<+w(g6&m1n3Xl<$$M>05Z3qe9iMSQP6n z^sj@1h7L_3O~|P3hKmU5M?d3pwsQw5%peupDn|rQS(ucxPv6twh%cxkD&uP+fjFfC zPs?LjEs19dB7BG!^Y^2|^_@dTrNZx?lG?JS_XAzx9F`Rhk0f!c9vG$m3&=mUvKuR%X`1pD-qtE%Wq!-8`SDnF_3u7s2H_| z;v)1+CcE<7cR7>?oZrMLW|x<>iL0#a5dTm7$k*-!%S|gsFwRAWEZ~I#Mj`Z#6+tQPl#PaODRxsMWRt#=8 z-RW10W0&{ztf+wYk$3Q`-9@yBfeO19ZIB*5BDl*1&Jb+O#hWwB!o-+7F z?$EQ0Va2$tH2&8|>{C|?Noa<_&{!0oCV{Sk(8d||W#BOy**>*yG{YyG;m`04M_g;+ z25a!1Y(iE(Tb&L+2j%Kj-jCaqv-%t$`vG`0{iGU9z3D@&QnF#iHGEjlFAmd|jtdJT zSCt^Qe6~JjvaIGCINiiq{(5fKn`J{aKMj~}VyT;(b+W7yqMi|y{>JYlL=jpGg=ziB zc&vJDnhr!=+V-zp6qoSFhk+!do?(8?aFoOke$s(B>-vkYgDR>sb@iF{iaG@C$V{>$ zPA87;`$I|S71cOtjOvIVb1Y8QnF&0Rhy$yva7i@Q25@2SAB*_25n|aaTr4WhtJ4oO zl#QwN+UD|IM5nsDbg9v87KSPW2HH;4Bp9E~w7J)?!4bE*$LA2+Bzvks{9BFNrmHoY zjVziGcjhr0Rc&Dwz^Lu}G)C!xuAh9e8zyC&h#cQ-@&7iL1JTWKjVXH4LlmXh&du_Q zx?J&xV(iCyrdcuTl?J{FDbf(hNg?fgZK+LT-?3S1<+c~>`YrX>>}p%{J}!nSy#}f^t!mP$U~%A z88`Y@+ym>slCqkRk!ovcGancE)Bj_=E-riBeJmR$`*=63_xkt|?p(^3z};UQCIbI{ zDeHCd*jo2-v--XsjCj#~Y=zuzpIqPg{oYe==f3g-9d7@;;DEErXn$Yqyud#B1)uoA z8u3M8{@K}u_XgPAudhce-{}3a;*OxRQ{Eb$xwnej%pHU59)Gx;I&(+PCX)ci)&9%( z&T#UKv-CqN$F)}sm6pQlhFqwN6#wGsxc$1BcZ!GkL;EeY_B*o7wco>wRo03+E9W$P zW^h=m)@yz7ANb%E{-j$@aQj`ZG?{56#2x-r5&P5L&=>s{q3_WvR zezjaYyLi2hDux&Q?RTly@T`ZCgvHw_4C}+w`19|2zb(h5sG0(R!Cf44Q>B>hgPOWK zIgw{GJF~nLC+0l_)cf!d^?TqAAKMW^t&ll>%205=2&u^`Z8y&|=Op@l2%0R86}DDX zV|`&4W%0%S_|+CJ?9kzQH+s{*`m9yh0*kdFSd|Y-a)9#S7wK8@eA&5=#pKTSrH?En zTys-Z_Q(qL_NGCjFywx7)E*{_+Opkk&*-n_-L zwli@w&pNKZguwgHmO-6wp3}K)aOWG9RR^lx_I?U0@(RXzS>XduxaDcb<8FDns`O!& z{e|~EVe8WK+`5!wPnH)!&tB-2i$Gq_{TfSFi^9Z9vZH{bbEE3r?47688VY>eBY;o@ z&empUttcxiM|>@`P+&F2g7^Z@!;*~F@ITh=wI!*REO4PZTlHGgC&7?g#?Ao#wAMXN zJFO_|;a};-zI#B`<<^Ifn6%AlUo`-Rc$vxG*mt6{*lqzO08JS)6k;zjLj5q*)z z3JU6%km0edMx#q~De4*beI(BUi>TGtavV%H>8Y^6YqV_Bhf815Qb=Ey-S=N~u-YPG ztmp&N*(-4PmGW%M$tm806<>z6Mra}%?CW~y;eJ6FZT3kx`ATeT=hgj!DtJ=Sx}wyt z5L-;y6a0^YVSVw3>UzD&xZukh%0@zuP#y&poGN}v;d)z9I7+RU`xx_}YZ=;YWZ@%O zJJ_R|@p0c-1=q$K9?1C$NGiN+RjKqxcnB+uVh5obzq%se%_m@wUc#j~o3VR;yJbl= z%0IC$X4mdPS5UPtxAx7_M|opvT}Kfn;$A3$R=^a(cP%SMN?+Ky=QEg-ReQgDE$%do zSh>s1Rvnj?VmOz@Rq85HCVTEjJL$FALA6oG^HnFkw$D;Iy&WU&KTO2dG2(j-h9k?% z_$ge(uVM_(>Ny0XcX+|PZyBu@oy|IBnoa`6W9zq7WhrQ>kv15e=l zhl64a&d1N)QSbCnnfyDvOw)p+aIqiQq~b&W@=b2Musqyhi_GgNACZOY+U zJUW95ZDgkDLB%c9Qg2_3g%aes1B8@t3dmrr5Cj8~nxqGNtz#LqOakhfni=`mbHB{+ zA6JW|XC2U+bmy*$K5@LEAsqL)bPHBMoh8=h(#_CwC1ML7iN!agx{5aHu; z8ufTmYSJ`t9opAwRBeSnnNg;e$Xp;y}1YQONB%g6I{#A1bl`$T(-6>uRy7j z_cCvb9eAkNi5^@$Nu6-2a^?Id`{B>dBBk7F?V#R}4;Nf+x8~7ofeCXzh3R>IpHx0W zX(8EHWLf3{zm9Tb6EV6;0tz`7NO$@M+|X-bh+MEqg=0(D-lE_wFVs`;yGN1mrdnP> zB8fJS58Qfo@B$ZbE&eUsx8N5GC^d|GfwJl35(${X9GkGc} z7?%-e!cP^w*=yrX6~_e6Dq9qlAy(URR5|NZ&ThT7rPFeTniwq&!dKJy9Dh`KHk^Ek6aHwHd<~)M!dJ9Ysr;i0 zKcp@YH(CxR>h?N9&6M){sw$l?s47%xdlu#Q2`RsMLx0tt{D2AwXAUNt6VZ0BoN?}i zuyAepxT=MRhN?kOLZR`2V%>)DA~&UU7RTnpg=cGQf|=%6Jztw4Xl+B{Fay6KylT15 z25@v}MVcLoOyaFv)e-M6JJR8hAFbWR@gY3a@!jPIs=7TTXs9?Pb;^4%E+?L8f10kAra9AEA$5a9BbB z640g19pB&kA4y?mXyPgo@(5jUTHZ*@#$}5x->i|W?&4C* z&|9o0;JBQ7xgzW4Hx?ljMwnQGPG0g#<0X2Bas~F&Do)>$o+^~D$oFIVX|4MOKhmq{ z<9Jl}@4$*II1cz$Vaf_$L3?!Xd3e@R8MJt72%h7B8IEy1AF59S^OyNacNGKd^pV#x z2^2mG-nJvSsKIM^Lvzdd)}iXhld}kl2N#iDukAA7%-)$m)UG*0xlY?_N!Kx?i8%P9>Kx{+y|>WqsjAGHt*TLf;W>QJuIO13Y_j# ziLMo!05)L+$q&Z>+pO;Z=4%A7moVw-CE6pKG~5=yYF)L;2whCS&}de>j-`xxPA4sG%bd9i)U95^PI=G0K zt7rB66KlDdgR`@GZl#{t{HPHL^;GQ>&HQ0lp67cL7h}9Nt6LA^!l*2Nh@5AQ z(^j}kP5-be;$sH{w*;v;&!)vv)B(!NvQ?~VIW)SRR^0`x+QMRKV~P1>P2petR#XLfK@D_5d=qG*K(=E6%no7Qu+vwk%(;_CPeiidw|Qq4QkBgH0JBP z({NQ=S(tc%gpB3!aOIKTYKe=;gK90$tR78?u^%957hB?sRq;g!7fzd@;;QL$Y}j~h zm($xKRV%qp{&VHTBET7SX{#vPPsnC(Ew) z8Z^wJD3Y%rCyK?OWeWfB)+8b}#FZiRGPL_yb)ka;J><%gOhOlqKC+I*TK$mrnGa zDtuXc;1C7p8Zk0hSXW7Xj&HAc86v2QRGjeg^Hn&ivQqt13|F_)A6~LD(#>4y*d!RW zM-vR{7m?G?yj((!a@0gcyCddab;Y`)ys(y7Hp$02oAi;R7Az8Rsx0n}G`a>(v-u3t*E)%s2=0;Wr_T+3n5!Zwd+kQA!QL+iBRjq2(qIEpL=h2*|v0kTK~RJ7KpQ#1d` z=Q{=5tpeuTzX_rGqTOmnb@hjtKE{O$cB`_r$KFL)pRO~BA=EG5;aOvh+_v5Z0`0W~+|kE!LE;00`g zmgf^&@~JHi!ODrjo$D)^^RVe!YGhd)xJ?{2KRG8kT?sAAPW2Z|U?-GkUV`fUnLPMu z_MfmW?LEKliYfS^A_>M=QIG~!l&GFbX_VF^HfVf2N2G&IKCav~CS*aSDuUNL#|c`D zz^GEDRdEk`_q^$_L7)w+W(Vb=PE8%hQZFBjxsr-ml21$?Bzo*Y95(HJ zHS3Q*rHtnX%~U&Rj##o}^PJW_(hHshrSHa&mb7iAv>Hzg9i`Qm$Nk zLs<#hJZcI%tedD6PSaXNVkqh4<@j(IlqO=%W(7K0hFCK&#HznZgXMMX93b;}NwsgC z5l#>Qi4#se-h;N$PwPp#;TK0Uy1fghRslsgwj!mEumXlxzt84sD9flcCU?K$ zY`l10JyOQG?KoqiJ|L48>2t6K-Vh^EQ5i5bY!LI{%RJodx8Hg7Xp^u^v;Yt%b2meE zlnstZ{!C*zC3#a#bV!8d2xqy=IH?l_ej{!Pj^)++Wlakm*W9`dWCmjCrOl}9AP&g~ zx8l|T$BEM5S%-}6De}QZ`QVSb8-nes&t^+zfjPYIPq#%nyD7kW@+zNhYf1Wbeh(Ry zbVB=SHmx)Jo1cx>#dX4DfptE!s8~-psEZ1MHFhqwo*St9_{h|c39Q2vpk=~`RZ$#B>o|a>>V^7W;t{>CMI+1 zR#K(%Ky z)o&gms8H2CWL|)Bn*F*AYZlde)Iuu5Jr>l6G9KZQhQrwI9TI-60j-$#b9`*{F{dS}%@`9;?m-dxanb z7SwgnPCzRyE|0`Xsw0PWGG>g(R+ZIHv02)wA*cQsb^m8ccoP|TgT&EOy#U5HctYP> zuK}8ZU+_(ZjUMyB&gB$qAw;PH$wA$~>rPODbK7yqP$~Ca*he4p6VLl8@M(=E;AI(^ zUa%A;`CQ`WZrUE}>4nxH-t2{}8|m$dd~$t0NmUN)v8rXOeF|f>A9a^}FpiT5)2nkq zH50Q9SU>!3c>{!+;r9pOBjSXbm&x_Hht!vsfB(;-hmuEG{?I5mkqys8T_)Q=|&BrxmHb zJmLLLDF_!^;jTXZwbkOM-UeQoTcc+4ovC-8zFc)+oE$&$kn_Ja4=ew24G1Z8;&8rd z<%Ga}kxjh_Ua9Hhr#1~@uyBZF43;J4TTWf1UXVTc!gWeShQ;Vci6=XF?m7z>xHpDZ z(4*$O%nPDM*WBvOmdiV}tea_{Q8e}uTyOw5>moWvkvi$M{GBR+pqiusP41nH{zz8; zvMrxQ+c(!H@21abTI6sDVF3=TD_kRF!!hVrVO=~5E#9C?_EjcgCyPQDO1wcm1vYow zH=4Et0;Gz(w9h|?42jjDNzu%ai=oo(X|v$>#yJ^WKS+Q5eL+(dq1EeOKGNstR@;~^B@IG z{3aVVJ6|A|&+k_w6Y&Ld=jEd(v==TnFCuCnDKk_fU`GMRKJQNt&XC)^EURndI4uQ$Pv4b^&;;Q`Ox8%u8d1V8@y^GshfNGj9<1 z3pO_d0$wbI*~zdcmW< z@9M}^uVzS9pEoCKk_g&a)gW>|-}oj+)kLu6{-MW_kGD(41Gau z=u3l%FLoci(YrtMOt(C$0&k{6CFg=E0U=F4^{9Pz_a_A{XcEZ)D?yU8Ys>w>Uyqwr ze--I3&ZX7~L?T(gU=Z?LO_J(o3+p=Q9yZ@wo)^@uRDYzb>d?SO>tXr!Df0PtDDwH{ zX2bUL^!ei!JZipZbi}})4S;!`ptA(8AAYOcPdsWu zuK`O6WUG7pbpg&D%^C>dLc>scSIry(;>-mX8tD9xfzB5r&}ka94SbPnG@nHeSr3aw zcq|~r@MiM@^mBTzdp^mAH8=toxEhIjDM|8>K#)>AO4htcla}s;_p&_5f1&B;n24Yhh`2{ z8VFTA^@7j~V3A@3NqRw%CwQEH(c%oD0o@Nd2HwzH1DT#_>OD*aSRLI46djr9vMzH9*RX2-P@P zSo%_&uRLm11I2RHW3 zvVRw-#UwoZJcx)rvxaM;Gq9r{w}xmP{R{m9bDi=NK!TnUC9&7`^5yE&{r1zwpdZ$z zQ-w6JM0yAQQ@#z8haTxGJ(B;Fuk!5Qo4J>2a@aJ~&~`B;zL*qW)N_$-DdBrq3C?Z) zv~Ihvo!P|p8;B*5Z#)F7J1{O$c9ZwZsZE3O;qB#}doXD4%6k(IVz+)RuRibna%K~N z;CNc@RJLE5gJrRC3%iE%$6JvrZULZGNCXN0jl(k_M(x8c7Mc^#(iB(CZ|N+)qS;zb z;6!CHMb8J@ktJ_<54I><;fKFnkKdL>7h5sUy8R|@45o0R{#9+(;hbjXEo?}lx>2bx z*}amP1Q4!0yJh<)%FiR~Q|fBOLj+)b`W3flH$vfc%bp#POr3H&dmGyorPDK$acden z*cHq?($_E5{^rDxBkSgX(N%sfye;CmR&aXRZMaI|JTL2T)7g6uo}l~~1+8l)L21{? z>wad6e0b+YScSiq$91bzG;pYTKQA=|sQUJzfoHy6P&bKBnKLm^`?8s?k4z%YtpPl^^}TRvFtrY1iD7jarbb03-Hd_>e<=6rIj!HbKI|T#6+6_-y>LY(@n|c@l{os4 z=MU*Q`PM3j?+~nl&VK_x9Wiz z3q^^xCu&g%P-$zZu$Sqd9OMCRJj?%^%>fE5-2He`ocoi_!GVDeP#pI06R-HGR{|WX z4BIU|7R}Va#0eocgzkw~V)AGd!fc!31=pK>H`{G-RRN$Hl9(O7kx+k$>kVXX#f{dR zf)-X>ilOR>!Kr2^64D}3h@9?uaoh^vCT*a9 zzL(pe)s_NzbH1#WX?)b~PRIW@eu}rr1@>0*iOw*8_fT>p<~|ky8}i||Sp>Y{%^ga} z2CdTGNF$TTo1$+>ypu+++mPI+PM{&g1}pLo&u{>E=%fjwH`a2n+p#Ff@<{*m`WCLm z*_V&I1~|L7caVg_su~ndt*+?uEDq?OGdp^D@lLHMWzK!!GGL2>&6Tz&*kH^i?2k?_ z=2N?8q~d~5Y?sNH|020rY$7TV;tf1KAt-cJP7DeqSfkmT-mNtOJIXVp#YRZ5lkK(s z2+^N!+|_?POgh(9fX0`Vn0sOWyZDX!`S`Hn(>A6p?3g`q?F_ejG|nbH7S+{quS~hk z>1Z&%>llhURWyd;3XW@6`1ls$Q;$_1)%oiAl|NY99sioT4Lwwu0D{}*I!bozRMuZ=p-DkU%;f=l=~Xs}aW9EU|_4I#%gKtPiJJKTcY_9$*5CAGg|HwZWkYiDeB_fyRIH7l<*PcrUoa&bR3l)r=Y4F zMG2U0Rgb5i47-7`HL-ojg;0t^%-#?zfj#9K+D`lTH=zIaFJ#8+edS*h?cXnlJEiFM z?=^4SgtgAQZs2F|6V;GfH{%msOMG&FyuX&~xo$wfGn-6JqV( ztMycAXnwSRFP9{?e~;=0q&qhDe7(I+)r9BkF=K829!nh}!!5a1>WbG45Eom4IWY6Q z>7Nur{-|dE6VDMRK7OdJ9dbCo?p<%3NCQMLRc2g{5&VM=0fiGA_7JMX24wKG0Sfls((*kau! zy8wUiJTq=!9NU{*%UCdO1G5e5psusCFo4X~X$Ndv)b*4dESts>k+byxbEGzVEq_iS ziNc&p0?SKAPYaxjcnbM}Evl4kSLgNlAOCHN`Cl7Am^vat)(K>)gyd?lsKVQ)O_`r zyI46nTs;k6Bh z*I1JD!)s{ba98)Pc&&&G5MCRBvyTX`y<>Q7u@7I>ii&;eU3oMFa`v&!;WcGSC62{z zI(dRo0ceBKYam#Yv@%TkuHbCMRlcwpJ|t;X)=gkDaV9%xrs~u`pxG+PQibv69MlsG z@N@@I6q}d(D<`LO|Du++NnDZfHil-KD#>jO&2r%nQE%?^=H8`{!7A(^8)SO7u_3Vz zBep}`^hNpgXh?4JBUqD5_6R|Ald!=WIjR)^y8z%dA(*+Ul0Pqla26u~rtggqll|b$ z4N5q))dEg$IN+q5SwbpDFHRSAsWD*HX@Qo;n ziW1GJ(Ws!oN*xehoq-vhi1mtAtu5BtqpcQZ#I_*B%v4{;v9{G?`&CbE>p8V|PiqmW z;!FY|U{yjyZi?KUVYmsE1Q6!?t-arOG6})kIp6;||MPr251IF}-+fto?X}lhdtGd1 zNKclWHfr*tCrg+*SptqA;h>{~zzkZvqgbQg5_D&3rNzsVXX_r+eHdgq+&NCHKWZR+ z3_aM%dr)J()GGKJOh%TmZ7#YzdDjJW5y6%rps`m(T}C4dm|t1#T{0TxKBMZ;qX{R5 zzA1uXeo=#%4?p4^1(zXWi_|TdZ&(;iE7}!Ez!v_q{NZ*ab~KUU+*`5lL&!_ZnZj06 zTL`kQ8+Xw(XS3dv5u-;OcN7WBo@7zKFE#@ z*G%%fwZh+M!H}@R-jd!z4^c5qHf`9N6guM|!Nke9reX-luNo7-vMMD!9DfkwIo8MB zHeyeFeT+J_eE+;5gI}zfxM85i17?)O<^7lE{&uSHO0=5 zPt9g$RPZ>(>uk8f(qCZZ)OUP1#d&~V$?vQ9aLeU9A6A$y2RTU5c8o#d!>Mw_&678w zriS?e>dKDWZ zt%-5>a9NGE?2GBm{8`F?8)tfm1(Tpo0%SEm!@a}Ta12%8Xf)aByJ%@eEVFjGyN) zojCDIN-{FneFbKs!+7LLN?Q8}yemSo6qh6B4lJ|gOQb7x)V%77~-4(Ekt^3 zsM{=oWyK**m=`pJk!5IwB5$D;A|T{)m={TKdq5|+{ip(Y4g19X!n~}SdXdQU(pJ!B zHUvYYxgcrGus>JgY28AWt2JFx*-l4mgoePk%2xW=ZUk^nU|L9+m&xrcG37NNJO57h zGlgUd>3S<_^kiI~^bb~S!5j+XBvD{`o>TV(wpC0I`-!S7wpA8`gVDY5QWOwU5BrY5 zLO7Z`Spc#}NOj~wu=O`-<*V3+Ivy`=QqOWoD(@37e59&JzlN)!4es@j84GhKv^(V zjUIkOMjx`G?1U{WOIx3_lZVCwcYjWPMh+swSW$|@g_@P*O&(OvM6-3n|~S9 z2mexP^Dl!A`icMJ14fe^HbJLp0656gyU2)Z@HN>0^TKm2fV#jz7hj zM+?Z-z`4|Zj6a3MQ4v214u`>U)sFI__zln5HH*C{zG1`Tf299JgVii96tMa*FeGIE zi2f5aA6!zv6aESYM$fR#z=(^w=)7dsL!_YW;YopFp@@HxIGt}f{7YK%FFoUQQi0-M zIzEYi`S!=~FIPF;5&nhk9c6e5y^2Oa^%rL^(q-TYtAe^g+?xM1?-#(I5|oS^wS zvAh-{AwHR!dwC!BM=33m;iF3^8BBgRPr2Y^Wu&jwHXFjpFT)GR-nx~A&K9O?3tRV8 zFjSClgh)zOwNNM32U+DKdayGbC^A=qs4mK~^C$_&*%V~mSMXfK$tv}$cc5vq9ZhWD2E)S*>nwxt>_xF zEJtO;#V==5?o_8@fJ**}N~U3Q2Rs?GGbW3~2CeF&0;k2W@TJb57;S)?l9S5GK0yobGD?AxYX#`6A*y2GEhN&=>>|zu+^p*nmdG{u~wm- zQM_QVZka5AYH5N%ExHMgSJXWQ(2H@#lzmbYkWYAGc=%n*LBNZz%K z-W&+B@k<~F%w`yd?D=YV2`_F$8_-o?b}KNsQhkcLJ0}VnN%M@-jiaMhXoMKJK_>`7 zijEhi-#(l|hawrC4|77*8N#y7;b_FNjT5Rh>V)bYXG$?*QXCD>KlntI^OAF-gWRBNXT<^ELIWL9V%(`5ag@_%<64 zd{1#PHZDNx6lDQX6=f+b$G(>#yeRl3^b9n3>H-z_ha*FoE7%R2`VJ3Si;bAbw#1^>^HqvdQiQCZgDext$nhG}ibnRqCa z8M}wbXoBm%z)V6_cVK=7y zg6aGUMPQS7t5!CU#Bfol3>OQOx*qJv*_iKuep%R&QNoT~%hnjOw!n(u+R5bM)h{an zdx}Rj|B(Xff@G>%l@C<$A2>u@l~ICttVe2dYa5L2Cii6j!0abi4U#VS?5P)F0QmBEx= z^e2yR)s0BlOX^t~>>t~z%31mi;j-045np8$gIaC;aGOLF?OZJzSe|(`tu+nFf61Gj z=n1w8MyD=dR)Pj-mACjXi^;6{Bkt8TB+>n^8n#iv3wvTsUjtb zZ{xIFb|F>SnZi5XS7GXc)?F9!=B^9zDceEqQb50ADVJR+XLv-k3nSO1RH`lkCJXB_ z>#mb4ls@gPsb36D{!qF&ITfs9b^Sp_=OI?C-QjI0k^ZT{qF-U@sRoe4?V=?%#Qoe^r#-rl4=C9Lt zY$8T%4G(|^YDSxO%2|uXULmwWsR;Cv%4Nq9D9Jx-u_C3nOLda!X4e&*OUX+%O7$y+ zWV$Y(ghc?1PE&1yV3ue}|H9jb$<5;WC?7Q>N^nk3j-Cx|o0u%S?+VL5P>#sOcQ3vD z;;?(CvQWx5xJgQ~(6rvXBHOOC7%nXzHdP8g)ilV!6)z7#LzISLg5b&VWPPG@Ek zTx~%2;oE7oVSON@?#r(WV?7o zJ(bd7&+agaCzief8*?nbdbZ_?X)R%%|%N z5TTBZ#4y5UBQikz@pc(cq;sXBARqz)kzU zJ%_Q$$&SF-DDwZmJaP6gXmG$v6a5Bt+BUZH%M&*Z>uT_{Lyny1K1wVA*)U&!J-;xF zV=QDK?8E#{KlQy%pnBuUw0xxkI}y%FKk;=<`MEP;e)P5^h;p`!0GY__sq-gqlJEh# zp8*umnBMt)T}G27N2u8McCN%ZHc+=)k}TJCFc*v-+MrO3!zc-^6?Sh4`?dri1*)H9 z6JJb{4%I0HiKknzIfA?>2v9Uw*B-9l0yd0gRwKuCThNAlOSKd56V1&0Qa{rwQ$0R8 z@@+ay;I4lyOtc&miZ<)d$omZv)Zst425clbRx|?oyhW_eo<~c zT1F$j=6TjDk>m#VjwF|z&l|r4k8^N95q2PLgI8FtHn7!+PM3Y{KN+;nFT2nClnDBPYZ8*Ds2vtY+i!wD#$9w+A^0sLEb%lY421iue3RD5BM?JJHQUi zeSKPYPY#)~FKh-^KzNy#0u=1ara#~eGfU;=;6BPWSd-~`NJhG7Z+EqEJkS*;Gr1sLzVBN*Qz2VhDs zgZ=qOOvbJg)MT7}e?#(aF+UIaFjYBeG*25?5X_19exhd+^Hy1(yXR}`^HOQec=c0S zpJ!w3dSq&uSAaL_802bXxe*bw0ci-Y2-v4FLFcV z>Zqp0CFH*0Ubh#0Onhbrw|LwxiQL_KyK$^vqD7AM8daB(h@ziy)Wj+s;yXcq={Zpd z^+2K&!?SjNZA)fkYiFL?qknB$4DTYf=bn-KU)wi7vE?s;M^@lhbbnpb`(q==8Gjn; zeRsOIj0j%dGEbS;D)ZJXyrHE&bwi6WY+P}9iK{q`tRSeMke^@r61ACgh`ZtfkbxzB z(sTKZR~8crkOXNJ!M%q~}Q=94k!k9O<{}c@6ISsgP%9(3*Cb{_9v@Ky{+E)3kP`yM}Qb9N*Jj zw*!ZB$3gFw`s-8V7BP)i+B#P@rALG(FA5QvFuiU>sAFw|#E*CbwkRyn3ND<$ft1T7 zz>3KQ8!GF;X)oHpP{4TQ4Mt^m`rL6;8=Ty3?UBeLG8G-0Wdd**m0EkRFJ&)!99&Td z0c)((Af{829E(0ym zHgv;MAQ-M$tf04O%4DYo*DN%{;hJ=?W-&EHP;||Ge=O0%J^Q%o1XKqJ5LE;%^?vGL zId&ZY_ZB@a=xd!eNCQ*2xeuf4r#tW64q(Y6Q2rCP&HB_X;}-rO<@a_KueZ-JzK1{U z_-;GQ_)gLNKd$Ha6v6@@L5IEuIQ5VLPH_hKmt%Vku$!KIj`96B%^&F(K6(D873ObB z_wc6a`J3ttuVZkp;T6%#&oRFLrum!lsphYHfcG9Uz-i6^cd_gDK+vN3>tZKBoGw~_ zBh>o4ucDhUiTEk&FO6oyc;LqhKQGhkZ%_|frq`cCz3yVm4cT;(fM%UbLTJBhQem1y zFGBLJkTG}N*r_K5J$t*?p$_xJ&Pc{65Y@ML+6hyJ27SAx9ZhyNew6^|H!fALr3jDZ zM;79MKF3*1&rJg6kO9XYt+qKJ>WdACH#XCI!HG!T~_C|=Y*|_iGapVa6 zE#?==%X!dAWUyu#)>`2~i0{k!88o?LZT1}AVjHY;kcF*gX4t(1DMyB><4u@ySF@FoJ@;Y>`?e&FDt%*-@qhFBNb5#gHFP~$o^Gl}CcGL+PyKLIw*FePU|sxhA* z>vB!Mzj0yvt8~VgyLs%CYnt-L%!%XxIa!wR5_)RwW$W(95ah;_f_0J2YDn&EiSC@@ z)qDC?$J&r*iH21hjIzK=|0-As2!G3Cr*+q?Vjz3k!k)$Y+ehqg^{;$uZ^T986{eK# z%0I@Va9ct!Bh8p|g&heef)&bqHakLgdm9R#<#Ft5+r;jO;gD~NX(JqGW^Bl_zcF3M zq}_iG3auGKrTUJH4EcRT{#U8cCD~Zn?Q)gH4^U!7YCybW0w766(?NG+09Vlgm<&XT z2ER0SggMvXV~h>ibeq;2l9xWcqioi`3ghtINy zu&7zp%@0v z2QnjqrwQJ`I*bwYm~kqjLcq6I!WPsf(y;!uXGo*Y_%Sf@u9;(@IW}Wm;%Z6_hc^}G zc9(!uutyKzS9U%6SL&fq$98L{qDs?wd+0dEY5vl#Tm~uM1?OsHkdV%DTeCA*v&4uc z73}4pVk85&09=NOh(uw&G?-WB+zZ`t=fNZ0t~HBRkM{DYDwvStKctZDhBI)K z2w_Az;#k9^<9K;q(8GC3KWP-{ZO9?=RU!Y=ZUsM-J6!@9T!mrxH1iHo&*x`GzHGgn z-hN!P3VBOpf#a+53GCXHVIg8|@_lD|+4k5+9RTl~Nj@+- z$*Q{{74(EbfjYb;nQ_%)-iSOeQaZHZG)DG3H4thsn7CjzS7A4=Da80D9ihG;d8)e^ zDx@eUbcgEMNsG6f_D;-5Gb#{8dhN(C2<-ti5i`Rerc~y%s4lBi<3hNay7JSHF3|W= za)Y3cY`(XA+>0eS_qg-(O?yYp7=k$-^sr;Q?1pP0D%!6E8zsBNN+B4M%6VF8J|@RNIp<&o5Hz4&fA?c z6?XRoQg8Yz`l6sM$_hrJZ>VVtCN2ze+C{c5R7qlIGiHoNkL(f;7;ia#FA5MQAR%V=})ivg3$D$b?A}CV@LDAC%88)0=!)JQhaxg`0 zK~Jj@3#fHc{#B|CC(6I()NUF#(1ffJSxiS#NY+J#pf!rr(_|?~mWw^pPtU$A^wsJz zJC~S^YhAOrAzV9If@Lw7u*3163w_9^>BQ|4jP3#y{sp3B?b8FdM>~}fZa&=^p)=oN zuhva7g1)y4o2eaKpDng#XXo3JR=4I2vdY_TveUnkJB5CoM6=(ZSqR2Gh1MrQ zC;&iCpnhZFsokeTVXU5zx2KBEx(blbFLXwjJswQ78JlAMhW(&uY7*DO)3F}mwriRl zZo5ERWkXXL3=CLLO%{(6vKU_^S!NU>u)x^zWgjAn;pRHYq>#=I4tf?#8r(A^lAB-8 z_}!=J@$#d|i=sJt%#CTrP+`6#43@k!8=Gfx0wE|+=?4cYnPN!eT164hF-eszH1ZVl zC1HUIl(DOuGIlwXagm&JSY1tPWdsK(4PiV=pFYz;;}KDg=EeZ=wO%i2JZwTGClbOR z3*t8}cDZKF6k=f3wTqL0nx)+inHtgp??U>V!B0{FtT066X|CKf%hwEVlBWGRx9Q&7 z)K#H@_Be4s3k?3_DYGU8?*>Ar*B@8Y<@ZSQ?tRQ~MNvEIQr6dy7Qe9jC~5Q4J(ncQ zj4=$NYHIno*@_VEY1(_@jH87w?AX$|vg3W2^CwaslGCA<q%Klqr5XDb893$@HaaPe!&l`~un&u4wApb^f zf+iXa4)sWHKc16|)J)hmA#VM-nKe@gf6+*b`4{urkoDnZN&oPQps#D%7y@BTBT(PM z%$0xP;0>k@DXm6~cR36{P!TpRArJ|P7CUiB@t@gGxFsvtW!{X6#rboHJ~$sO!IyYu zSN2U7laF)Gyh#%qJtCTQxFLF;C4e8%%ZD>^4=U7NBR+Wc04eK7ERFmdgiV4@+F zxVbG6UGgd?nJ#O_S~_V(GsNtNf3Q|20vR;8iNIRZN@qAzVmBa@aYFvzymOJ_R8&ii zTi2?W(%35_WLm7hjZ!~Ph_RKG4D#1+#jjL9_)+jIUakJh=EQ-*jxr=6D}JlK>tC+! z?vT5LehBdX%19}54^Nd2E$CL)Ji1R8ROKo7uqqgsWtR%fqT3HqkuG-aLu|m)&db3U z1RmqfPx=20Z*_+Q&pDScNyq2DL!pN#@K~kAQ@tiYT^Jji<%dH;ohloZSL;{uun^^U6N!y&oS-fePpD~B1JA5^UM5X2MuXoS01*Ro zau+$D_lpki{kc7lz%BC&{rOsoJQTFQb&8+C#Ts)0 z-ey0#*Nb_Ld98V!dHvPb1{=2qPZ31_ki)AoomrOvH}&)7kZu%jpuh1-*1vO3-85sU z%ZNVPJf?mI z#`(dpBRP1M+*`+ZIog|{F5xJ`$>3jRFzs4KAE;{eSLHz# zOm7)<@e!C2zYv~f4srKH zmqWIyfgh+V&f2O5?@^c6R~s*u@8|M%Yr=?NNkdic3S#2U7dh)xRepW{2ya z^zNu^FrPKMl@Ej^e}2 zi5^!Hi)(O6r-MrlJmQv8aMPa%49$H1kF;dJ&iv^)0o+2lmpRD%o4TK`K%e=Mx@nb{ z3d)V@9)n2krSNyS$CIkT{UIjEf}Rb@XZ!ua1rWf|uYscq@S!9D$4T4xg9qeI5qPdr zJ;m_WTg4ojR|oY{#>pCZU3)c4`byI1%AClmkO|Sy%DnUk4Xbd;*Q@e@p?xFWI$8sH z4#l{p`8X}_Qxo&J_Xft%Yc;PvD2-y}XgB(lcNE>zh(LfHK9E$U6+xyICgdihR{kJ! z-sY{&82_PqHsVvQtf+aI8SHC7(PR1=Oy(dB_QBsL`t{WRAOZ4V79dgjEi|4z&QmqL zR@C}RHNMvh)H-CnrKt6XLa@j2GKBdrkx%*s7qUu$Mbns-J8MK&a&?J7X-6EjpZ4>Gsq`Kte)$+d6@NJGU8?BjP?f3-;;Uz-&M&+u)2`QaDsT%=IoMIe_6FF zQw4&Nl{IJ)D|db7RElO^;SVcsr^21N$4d`D#}RZ4e3^ehrmp;kb)^W0X+{2Dl1GsL zOiUByDzR0-B%LW$akVqylfdNPJS)pUVRkiDsW(EGq?oxdKr0m5MIplHpeQ(+)fb3S z5uFVh{?Xpd?XrCB3iu{-ow}EvXMWEVv6&APsIj!+a)Xvzrg$7J0ox)%Ia|QhIA7*~ zP2d*uX7i?&%xkLI!;E<8M{301SZj}%t!p8Vf&|vf{8%Vq)BHn5d?Wlv=5N224!0;+ z&|HrZ>zU1z+T)FyO}=9z+iH%>khaO%Zqt;|GdKqtLb?Ve({dy?w+dzl4?X+Ii0q;2ax!rd}suFRFP zJlV1)2@+YYvuJOo5&NUGtr~gx13kDoztZJyJzOJIy&K6yDQc32sj2JO$oa%riVV_K ze$%e<>r!PO@QNIPT&$3!FrE<58oaFTTlz^dFQZ7#o z8*!1{xU3m(#MKcFdR{tlu@M(}fEQje?pciEWcehkJe~n%&WW4bY*U29NqCML_d37 zkQFNXypoE84jb_{p|$LWGtPtOQeo0-Yia8f%FtZbGN#P$Xbs;p_L_(_jU( zsp)A*T$%f&;|22JQozPCd4vFcV0^DyOeefsSWM?Uz@wmbwl@>dl)VZ}{?#6h$@lS9 zW}5;RtOi!CEgF$B{lNthihs|&9|`wX0q%XYMX+)2DBM-T1izdFA%$Gdb5#rWZOPmQ zf^eT1N)P!Z@yR8v{@T1NlK@<7(d4i(VlS~)xQL8Zg!Y21U9zhOVN~wP+(x6aUa*K^ z)U+(bcpjCzGH1%5MR*DM78(z%=Ml4+nM{L1qo*-7;RGF%hu?li;4|ik93(yRJ=TgM z)|s!+2P*ic&~hSkd^MOTpHJH%>p=mbBy>)My(9Ld-I1doE20-7Ms^encFnpXYTq1ttT&d<)1~9Tp@Ho_(>*N6udUM zVp17_O|i0>=6_Q&V8s7Qky-lXOe6m9vLc=Z=;Uam;z`>|T$v{sqF~4f-s!14v(uT% zabfHHU^48zGHgvjQt^9(t(R0)XJSlZQx}nWKN5Q2yUB}X{0H`B&}iDsrA+v68p@1f z3=Yb?u3oGUkuBr!^V6BBabY_9id)ohWnT@$&d_k0mShR4hO0BD zO2fb5YgBDAUTK;mWLb0HVI9kH%{>krgj5aT&7;@zhLid|rqZ_5FA|5CcU^)!tWXQp zIHUt1b!y@5p=vlu2^sy(66983P&;q+J1S?G=e@Tvb;jZgN$J z-Pd@BD2IceFm`6MsDkhRoCz0bWxn(O=&S0?H@H&ushX8H)8>5`5hof%4so}WSIc@k z=O#*T;Nj9hEEVmi&@gwMIjf7@;}enSMJeeC`7W!tw>)IMj_aPaEnvKOS&1?ti7!Ou zVb1!V+hsiXGM9nGWn^P|y&>_niU#*T%*0h?A>YcWTyG*i(9|QzUl;PV;2=T0xrb${ zStQ4Jbz_ghIrBwTL-Iz_Prq0bO8(1G^OX~riulrdCvjqItx(=oL}4JRyb@VP;1y%M zIK(7=MbbZn@Y{EtR4NbPz=m7oleIRJeGfOxjG7@B~;r%#q7>mAWo5UOeV|s6z$cf#JpZwd%Vc=R|&I(ZN}Y2ty4#4Z)WKlFPbGl zv7dBs>M3-Nd6xlYw?gTS+1)S6Jn8JaYJUnPUv*W}%Yr)V>a5rI}s6C zSgK;J(`5SDloq^|6IptHF1^R-T|HJK(vOc*kC_%{7W88mj}u=iAxMGke4=PsIQcIn zq4sT&GgzLW(eQk#fyplgWzPsD?=GE~oPGvJsSBoTVBshIt`hXO5@V-%YK2q8=@T7# z8hY+b+55oVnX-z$rp%e>JNQU*I*Ib~ox;8dcd>s*fsx^En|&v9(HDynznN(LeF6>K z%`eE7$u^ZJ{|{A-RR2_u>L2~2>JRQYO!bNKs|s}nd(?T+C)N48!`FFmy90)Qsw>6M z(d*6j-C@CS9d%}3EduBZg_?fXqo$`msisP)DJoz~j=7t{nG^n1IACGIZsit3y37zx z`m!e#H8w$2D&QSsR}YqRH{8BEY`1@bNlvz+sHOwk902TAR}KI+*>{Jn=~}62p6~{V z@;QY{{?wzAXFjQtDyihVR3dzU%`O@7oAyerG4EsJ7!<3aXtSF4xV_t<-%uNr2s2Q) zQd&}UB$z~;aTNsmf&aNx$u#4a2qeqALQ$^Igsrda%uM~6uIfIi=N?fM0P)tWu)Wj0 z_Z5m&{?u+!Hz(Z7QtDTHN66Z0^BrWueHSido+37UU#0fLu$9gH;U|hIihf=AsjB|b zcfwW%-axpxA;KL<{?tv~{D88?C>rp)eBQmiE8b682aJMt1?zAziJi-pL=(uK#)Yn2 z*Q+bVA5`%f-5kTiPL;uhtMo6hJ?GqgzP4mPblRtOiyB z$n4*DivT+H4w^5D?;(&S|<)RCcJa!#$3PnPWr8h)nqj*5J2d0i)8gmP5|&^Fk#(Xw z!`8Q0-d|r!Q!6+gS1{@?#~R;V-Ah&&jhyT$hMHFR$WPs=wFB8!J9X z|D^a?7@x#ndO+XeZTk5V_53FL`NH_E_LUXCjjK7e6rL+zsDn#o@sO$d5!A(sui!m2 z>-=?RLbIQcyO(ZLRXb<9qkbqe9$zcvu$x+i@&Lwu@|-jKsPpB=RGk@J=bE*uPPyw< z=f+1>osYdu-=teWaYZ=s^|j#y080S4#Eh;*=tJW>`BruOrJw3f>GNjqW9s{d_?|*P z<;N~`x}Gp~D4o|GAE9=$@{(-|j#A;m_e89-siOBOP{?16z&ZLbsnCb=^7ndx z^6ei<_4lZ6EPhmsPYdHqs7(Q)0JS+h0kVQH7*xopea%x&$Vx!Jz7Xy$3`8gzPtB}c7@uX= zCa{oenU6WLWx7=%-FYhiDeqXx(s=OBr9*=5CseCV&8)KIV?0efEuZ79Pm*VARep&T zkI7T@S5uvYqCHJr2cxtra7Tyd%3b3;&PPH{Z&fRn8YxYyyQZ!oM*Lj*#RENFwUL1{ z>aH6s+5W1K7){s(^$!z*Wvsro;wkBCpEV`)JB(ri4|nEssUj3P+_G+P`mL6%rk+L1 zTCeA%UeAm4dTv*^TtMX;Y08REr&GDVvP4wp`l4NrsehtR$G}sp;Qb+AS7a}t!7)ieKk*Vl8q8^oum%K@id^41+Y{P1}Uu2Lmd-RBL7mcono~24OD`&G{;+Tc= zWZFZC%9I|Cu{dZf!UDm#q_st{dI~L!3C+riDSP1~g=0zSPxgA)l_Gv9yZpVL_fPgO z>GA%!M|-}1@P?lEotWMi)ps4nu1`KaL{J8*cM(iOIN`#xFpNJ#e;Bfg>}-1PPgDe~ zHY^A!>%x9ee(cu|^4fk!pjdgwkNxh;yu%_}kRNMn`LSQfNsIqs)HrKrqKTPlKdt2H z9+&9hrQPj_!ui2%9jI5o$rWslg2%Mp@ZoT@Xgt}4xAeHbjzi7c*e%UOh1GVN^leO0 z2NzSZ?q84Y{hG&ScTZy6<_BL)PjYj5^C#H}R^ia6o#?$W6j8~(%XDOq3)&^V={G9V5tdB;q=Y}{6N{*?a8>V%j z`^2c8An9kwaZxR0lydMxwz9CbHiT!B4>RSfWM`WLQpvx3DBfzs&*2e)R6?C^z4}ES z*6$(YTFqvTbTT7J?$QdAOa=IG!wd*A* zlle2GN4?L)rMAgS)D6yV61TOnSw7JPe^4lR69vPQcM^&>cXsdEtu=+3uPuB~r#~?B z3j`#_Bg;jpM5n6-kZ2&$=K?)B^$LiWo%Ggjnj>7@dPSkKHSv$_=6m3|0%dee{hn84 zJCjIinF_1KrS9fk8azj@7hGf&thj>0&*sio4t@;vu)amioG zlP5!+^Q$Qsoh~B2pkA=Z1|a%X)Nz8d=2vXVNT8s`+__2(7Hj^l?(ug6DC4GI**yw) z4$z7l_tJRwIF?Ojaf|^V0c_9Q^9;|TJfpj@M@tB`b%v~ico!Op;%_q#I`Hv1@L9&A z>}pzb)*99$VpaZ%EKL5*4E|kTkzqG1JO5h|^I9Z^M>w;#4``O8jRV}a^H3JxlQfoScjzT?t03vcSo{t^YVCKxIa7MOyK%E} zJm{x`-k;idP~Dc*ug)DiR~895*`noh#q7L(HQ}!wZ=r7oW>UuwWd$3t0sO@h`l&r~ z1Um3(etOu1V-<1&d#$+4brIrf8NQ{s%XBW4FcMfUr#FoVxwnNqAEK;mu-&bSRJE8- zK6(*sqo`%d_;tt?$MhZ&_Pqud5V1NsSBp#RFpD(h>p~sttd-*aB>tkIj;-=16ZWjl zg^kz?45xA5EPyxTd^tG4;YP?IUx?Q%!R|UXN=&bf@@_uPjcESEghc4r8uq-FtK`m< z18NB5MhE7OS462qY!jd}ngt;@%*T>xXQ9v5K0(ZkM7O}P$|PY~di_|OQ^w-48EW4e zY^QVUl;%5Bm>AAK(%amPo77D7CmW-<+U8DcJYY}F(%kXArpC8LNi;yVFgtgu*%9>y z({k{iGCL>b`O${&libS0ANZZc*%k^Af{z88mbg&SJl@>k?(NLPY=vvqORTN*298Wt zGkHWKFDq85vT9Hg@SdK3!=WWHU)I zu!+Hu>FY4qsFn?#PwlR8p-`$wZvl#UPpp@D=^n{GxphXeuP~B*Jx20}6`y4!|Muxh zhpjCjbkMV09F6fNK9SCzNM~7}AMH|8FWuDsC=LoUj|H+p0<;F}?%vRJT&>urlAaS4oi32?#@vG&Z1rm>cy3)>^*4Q{pq8WAkf1-=7}C9vEPVQ7_o$^^?xWYFm`I#-0vCdg z%&=bE+12O`)Hd-;s8;ar{NbOF&RpjzKYkTPY$WwL^z&2*ATH{fer6Q?40h}g`pM?e zmF-W_NP|s2FAx%$#UGhi3kC9tzjwW)lCX$vvqO%=SDC;=n$cBs;A3<^tAr-(US{?T6P-|t!4z*U6@MA+#ua%I8Gzeemy)N{= z96tz9si46#U$pZwGjH<*Wp|WR8fOrfHzy$%q8E}QGR#I(++8ECA_^qR@2ABELigxa z?QVyN%9D$Be-P?~2rmhCwnN^Ai>GlqGaN4|Pg?|cx`963X*{v)&rM%*Ya%cR`lpv4%Zo4v^`BLe`u zD4vc`yg7Oe)A6hA4m1nnq6TB`7N+BnssL2AOsi0?uks<3>ypCvHs$Kwx@V1o^C9!2 z#K2zs8|eJ1!?-z)=i>H$9r2I$g{=c(wU+n}TpUicEsn1`K9BHl-E3QT@C3sC5Z-h| zL(M{B4=5ky4J)$m%6!!NBb3nnT_NqX1O%u@rh-?t8#4PV#P zAw*5{ZGch`QJw(AbuHn#=5XD@+!^xx9UG-wu35=D^OOkJw@Lc6x_xAv57o^NyBA9T zo&<{>{)X*54&NE$k&4%4{+%#)L`X~lrHDI>NJrpd#o!8qL>!e>uhL#_@bk&INe3l@jD&3oINC!X0aKM@K4! zETwo=pUQD$k7-+7PC_iJy?TKJT@njOtD!d-;4>e^P+A4z{k@P%The70^K^*=?hkoL zOodfV2ZeWpo~_dHQzUxDT8VL-!`)Me*NWU2BX$j?8xPK6P%|!)2+732kff7DT%k}# zsN@ETRJU5*?Z*R=DC{0$f8@fRrKCz^6%zO{HweQNrB1?5D*w8=YN&fh<%vV&Tp`IA zeDeve16#)WoFDC{_)Up7+dUBghM5f4rDcxZ6d)_sPYAo3qnCNa#6(Dcm3~!bDTirx zDpC&z`s#U79ClJ|1u|1GmK?mTOirsdCbSz94l+MX&gx4rlo^&QfAu>QAslA-KvRC) zj5=#S(Mnc3^CYvhS0Du(-d3}EgD2f#)=82?P z1TC0fgI^~=1QKbgZihr)oo;W*gU2hw%7GL3K~z@Wrs*6zf$ebGxIuBm{rG13$+_{3 z`xWPPv0{#25_Urv>%d~)N~P~}WDvOA)r!kqYAVp-1>0=aEG@_+8o5FUQl8fjgIp4Z zfUVE-R>;!=qlNXqJ}LiGw#KCdDd^V2TwCw<*hjLJ6a$C#__KzrA<0X)pAGSCn5g{g z>PJ=GV#L~@5YWLJs3`viHICw9NDOI4T4cIa<5m&Z3{*q_g2Ah zM=*MZ&u!#BU$TET+k#Oya&Hvm-YD-7j7UhCQrL}Pv{Va5Hdb#W>8F%j>U736i{d1i zRU~FDVg5jNhz{mn1vGEz6U_;;6{;iRco&$SJ&IvASnD+tl>0f*2lNFF=!+TP(+Yfs zaM2S!A0ojMo+fgs-Je;ggyOA=OYjs5+uM?&`$Vr8-eBDfK@nHH9zq2hI$P6xwKcWA zuePS&@YAC~)MfES!Q{X<{((gJcna|wa(xVejBhG|Twe>hzPWd`_68C6vS6s5-U>PO zyl2E#GApd)Xn*MtdJ+{qCpxOZ`a1Qz-D5;X{Ba6{D;Lls8tTbNG~geWyVqs_0RgVV z!J3W`&iybFp_(;pVZ*Iuo?K)w?AGqhYD~gv*?{q_iW~(2I}0`%7>E_z8Q_HguE?2gmKj_o1 zL*pM@e5PyGsJyL#KMM=3ZcXtYu!GAF9{)0$;&;UULdp;6QT`&1X}imxO||*K#}>-> z)xI2dWSjUy`#tz4jQdyn6Sr3etj&qb2+l$j-uz67ih+KfD>2#?YqsrXdV7^0OWj(` z`^?6T0wXNg_NKE{j5P7>vc$>$#3dE}#ARjv#2}MsH=<99J?DW6?bX*MTodlRuHA@- zSs0kT8L^{ar~K{?LU5Dv?#Io3_v?Q5V!!Y8Dg9-?`bxW@uW_pN4y2wngqeP}X8}PK5oz1de z8nIuZj*#7{T4FX-o82)RqWzSCQm)nx-4HFS-;+C$2)p%r8g~l>(z(HnEiOLy`&uMu z730==v|oziCw8YI_9tDlLD2A=Yxw~UWvf#{kC;#IiJY8ojvkrk{20?#iE`G|j#3Uw z6|{1l9W@y?bb-I-)c2Gw#YN}fLZrj2hEPG z^TZU6$nQDE>-V(!Jz;`fbnM8UNXZy-*K4(RY?n*FXN}ph9-+nA znb~VRq=sqcDdFxqn2Pp*wO4QHsL(KYQzqJC${)&2CV(Sps&uObqsjY0Z+5k zt#)LIZl~&6AsWPvEvR>MgLvQs?dK)w1i;w;2Fx}aUssXbKyY`)ME?S2PZ@`d3woQ1 z>jUu#kn6W{61~mLw}R~~1ixp6*}esQ_j{JIDAF6aSOo5y?c4mG7NtWt%0YY>v1*tw zoA+YoR}xw+SEHFPuzpdFaCvL%7hRx`J~OynaGo5mgyM5B{zQfG>xC;PKF(T2cqj9t z39kwgBM84Ja-IpsV?Upcdc@ia6|#v6xjrQf9LspM9uo{)i&@jsxx`;Xc#+Lj0r!Wj z0l!5*Cb9}9^tB2gG@NxBaSM)&rGz$XCRa*Td9PgT#s1=)6$zTU? zBP!YeDq5}BbcWi|^0|jP=W~4Ox3Ye#83OHD?s?txw0mANJxd9Oh}-nwYQ}?Rq=X+Z z3ssJaQN~D|wFZiGZzO^%AG?_dA{~B1!BN1o)oe(Fka?f{r2 zF>Y`y6kLNM=QOU}{BCbtvxOTQ`uhve-`@k#u5JF@(7)(&eCi-ttzLH91D;JEzw8`T zoAJ(n1FGGT{@jCY_#B_Y{HX0`pODT1MTdH4$BA;&>IhiuC~5X0US`i$3QuNZ!gW>ghB+ADEt9Mr;W5f{1f>trm4I=!(kjf(hJ!wGwp>tj*ql1+e0T zo@XmH8y5(v7ftSW(B!@XJuBX~1LQij)SlYCZCkA!IoY$iH|^~m+nfioWqXEtJ*^&& zpUjSJ**mF`ZqbzN*H>^>X{|YQ$LrV-U#&J4M(Fpfwpuziu+47s;K8M<-o&j`o$*^4 z*`l{)2dRpmWqWAack7Hx$Vyx2XweScvB{IOcdTu?ZZ<7dIki!ZXGO<00J#8|7_k_Y z*?Y5(#Pxk`&1fLnJqtXr139%Vt6iDhjjVDVIeIl+fQy1!iSPBP`fc^Avv;Uxq~4Om zxiUT(6@_TGfmZ_JoV9>~$*_F7uqS74t~^t<^QxLx97ub1dOq~*Hezq7jqifSm7?Je zCoZ^^3z_j=efc~gf)BOy+7u=J*gFo?BvZg3!;kB(=Eve8+?th>v2 zT;+_;h;L<1>C8xR< za|T6gCA&3L1$+<_iFR!3jXSm9)Rl!{bio?h#UPD&h+xULMndE%BztDkj!8SJ!F zkh_l7DtwjRDPM@z5{z%k@aPGqFFU0+T4|C5?G&VwDf4rKWiNRpccknXvvd8dHeZ={ z+8^0Eqt7Ku5quIiR>(~Cvv>cGpRpc5I%GceREmW=(AR*RP+?tP8My#p)(Q-w*D=Q@ zEO#c?fnejrN_pE`K3EhzLt`B%r?6wi+X_2g;-@Ee^!idGOYuA(($~j&%99dNj}XaN z+XzY|zFTSS^C#}B^jrIN{M5z`O2Py>#*16hTdMF9t+0lA8{c=i&@8>UJDscYC%%a! z`Bfyzl_$ zZYeXZZ&#Ss{f8_+-#?}d%zZQ9TQ=p0+}C^`PQAr%t-$1?E)}TzhlwBLlj;0ozk3k^ z5~|pM@11G=;e;!>C{mOK>X!N4NGVGQL>}-haEdI5+IAeJ^{eYXbg$`LotunEi@x2g zYoQHaDtUFD1_JJN7mwo_9O8 zt9yBc+YllrG8<1i*0SSfAD|Hs%N$Sx&u;8MH@^H!QA;4>5N?p`K?7V zrK8YK<;D{~Lw|egjB4Jg=h6rDshmbomFXe-*y`K~S{eyhD{wT53PIbncF}D8p6p-MbPUw( zAfF?b7Dmvc9mMlCTYi>&d8#Q=uQ*M~5bF0ppp<;RG&%b;NCqA0JtJ_|emDTkLG`JXvDwXgLpeN2|3)?z>kO$qKvc$YI1*f8{%rFn!DXMwm6eRcJ)h0fkhop4JW+ z`E|0gvI^vo3li?FQY(um;L$pTM_GMo&G&3KI}m@evg%NOtTH|CWSeQgi0!7k)I4s+ zSS72ytLu|REESo;7_Kv|6>9BK9ji}00M}S!S(~S1DNZwD|EjCHRhDs2Rg>Kf z5HhDLVg<|E+<^LmrRmd4(}<1NHGF5rNm7HNC+l=q?6vI4QM|G~^@^-J$tuX&T_)yd zjWQTf{J}f?`AyjnFL<6GiE3TVu2>?Gt?dZW@Df;5tD~tS;;HGwazQ83^;l)&I8TH( zmUQ3)zweD`UA`r1U>GJ^J*DCh4aXwlw4yO_r!=ohEZ(-x_L`MKM3#B>nbyf4Lqs5C z#Q(5_CS{wj+5lUjNeUp@sbcVvWgUsI+-!ROA*xQ1nNyxNBlb`DRM7*xQ8>jKIG<~4 zmA&mtm{$gu{fA*sOb~1(berfAP)W>1M$%6+ z|0W$J_|!>9a%bDYNPk~O+LBfDW%hi%uFTH&4ntAd3f61F(ILdbLWyZ@0TN!>~>h~h%+>W zQ0Fuy^^(-o!>Zbf=pqz#gAj-UMWtG;@)cs=-F@f;{h_0|9)qA}Ns&q?bJ$BlQMcI? zm4_R_OjsKss=|&ySKUB;wPr`^R(7s1eJdQox}u1%LZUR|@_AU6Zo;az)VdF?59_ko zXTS`>%MJ8b@N%2!SwOEPKi`e8o^WRHNkSbhfwhDQ7E~n-s+2}DVsg|lvl8zVtne%| zJ#U$w4kLCP+Y#c+Q?ChLE(9;Jtr>hTci^R16$xJ6D~ce`E~Nt483~)63th9|)+L(y zU6c$8Pp_Ar!?ODm-{ainO(_--PT~qUiRd1zgLwdvmnT5vC%~(k3IK zS@aq?lNiVuiHSZO1Vs`YRMcy~aPzrikVY>F2tm7@v3wf_o~Je>h&K-k0=HY}G`x># zjqfD{1`_vIX5}Cb2A!{#OThH^1v;n6pL7P8y?qhF@8C&)Ds?3W zUdLYt84@Rj<=Huxsb_*qrgbc{!wlWh*9>V)P%uJ3?*_I2H1Y++#0rIY*VE+gHU~c( z0GW+f^eHE<77TNcSF{Mv^C^?{qe2Z1q8}1*SdG|IiYZvAWc}#@TsQ}L5=4J<#~GT zksRBfkNwk;cB%xt3#cSV-kmMHHF!(DgH1+{w~~1={l0!j0yEMfNV3~2bsq>i?vb!+ zlVmUwo1dUuLVHF8J0nttHxh7YlDrrf>Rc;NZY4&Y++WE(4hKO}vrDXmJ0t_dJyQA( zjLB3@#8?p*o?9hq>Yxx|Pe^>^OHHea9GU$H*}Ohav>{*W-g50vq?)ahhz&$gxH4F` z?7Mg_(yVyNOp;hM`PT&^l?_S%h?20cH8Mcr6cOmJb!vsy-Q`FYvO47MxQ~>U5`l@% z0-@>NV92*qk8{*v$2m&cB8E_N5dDKdyNT?g56%Y#WJv0*0|25>^#uT&p$KLmrK`jk zL=An205iyj!O#UN5}uWyI{U-~CKaiaWPja<(=zT6!MX^HX5CKJo$r281`hRpU=jc^~4Jb-rT0TIVbIA*-%D6uN}V0{pMu+G=g* zg?^IG;!C+2BkE zS;R$0*n&@^NOB!D)R%-?l3AXVD_6HDZ5IURh` ztp(lt!=5)AtkS+)b4G5D)!LEX;bxP;$RCRgNhFjRn>&+?0b=z(Oh$MlH)SIFNEqW> zC3h@$Y{a-bKc#_t|GmKRnHGoC+6RiYx)vk$IFNU0Qr|Z5K-Hw`l|y<#hx;%!+Wj2S zImA0cnTD1PV6Pc~!NGqYx3MSI3BU;gB^fBo%Oc3#V1! z-p=vV)UxMGa;4{|I#-K*rWkAvXJVDTCr-~Quzo)j!oa&#tUw z5^#Y2AHVr5K&Lt*R!WbaFUcN|>gNgpl2gH;?;7tUBYv0k7OnFr4gzoGI!3gDcPN;> zT3*Q4^SR?|iAWUmZ724m??dB(%^aj;kAQ15x2h(0mJO{p4Jv|L$l)~{A{MZ9coNNFz{U%Q?)PW(gG37@tVsvSwS zb|ZZsZ`az#+YOpV>ErEjh2!lnI8)#B@1JSv?Nu86Okc5q5sXu0v<44xhlYBI7y%c= z%5~)?gw&~+OljCR)O)XbBNLiC$9V&1Q+NZtaOI9R|1Ob>RPGtmxa2hsLn>4odvqHF zEusx)_Xs-m*e&o})jz^{Zr9IqRXf4KM|#b_v+i7`ijWjAE?E;!jPxSx!gs%BReJZN z$8*H5)wqEeg;>(;TWStczrMukpvTaPuqr~9Gd9wI%y}d*k z0vC?FY8&9=vQMc(nqRX`^QcPle`4oYlMdCqA^s9rqz|`RJS#;OIB5hGf?=SS&Fa>Y zr?(1=%TOrMuR*1PEX_@5@NJzkDtc@;yT$^Xas~@<%F0~1go7+BGS@8iQM@%$K?SUW z9Mrf}xJ;qP+7NO|A4J(77oc3ahbbZ2y9q9XET zvlB}Sb|YcRua>$JgT4GX)K4!ViD}CQGWajQ5`@mOfvm$=^^-ObsunaPfGR&AcZJ!s zp`vMh2{LbF(w;JJscLi$_JuV1XMXx_^oh^Zs4$!(7|VmY+DY;Q1;5g%yL)c*(AeMN zkI_rzt1w55;9)*V(h+e73GZ&@G$N~U_?yjFswoQZj;q4PFfIub-VGSzw_*yv+jK85 z>sp&q!$>whqndN-wAjDz!qEwT1?=A;cAF(1uyFFZlex7zc}HO^cv-OHs26)s|H1k_ zovZULxpLVbuM{pUh`P&&|59GVjEvCP+2`txrU*M0AqwIA2BZEkNQ7OertfX^^o62 z^Pn5)4lBQTIa~bSEWdeRdH;X;?SHKNHUPq*xW{%DmcwyDMu)tpsPpmsd>Z*}QVx$c zCEcKy6!nKPQ~zHn#*NSdSmgAgffl5>3ii})X>JsE1!?a4Ky~Tg3Y%R@6F^6r`*Ha-#cBo)y772D^MX(#uTd*5e zEZ8Y=j;@ZK`d<|2TK^2u`fn2G9+0{cgRkbtp?wa&tp&Puj|&2SW`S-ivv*j5ZlG>- z&7Tg}=={&rs3XwLras2)Zeb3|&hR&jB&TJ%|I_l^GYXyi zlIOxkVC^B|oEGIosQW)8&RtUw=PuLYobgBCo;>OKAA>N7!KcXGe^H$Kh>C4-E(SET zJSRShu^$!tFkZK@*e9`K7ZUp52b#o(QRF|eHP6i-Ja|7Qou<13gI<6As>D%*$1g+s z;3_F;jGRp_^4LzQ?`(GEg_U|wUvp!`7TMP>jOLbbZCZmuP0eM&&a}Z@(eDSfD-uBt-|MBX!AUP?lsW+O6wPjf}&$Z+C# zN)rO)1U{(P(_9uglJUqO0_suOp61d>6>gF8tn_yMuyjvzNu>PYqs)f}wWtPLZm0KV z>m{Wwb=4v-c+xY!9lc2fn^IM~jk_!CE-&I3Vyp4;BFS{`P7|@YSiY9B@(tzrjWqMW zonbDG8m?q(%|_hAGcqS}R1?ZmB*3j$RgK}-YJ09Ua%HG#Zz(B%AVS8ACC2O} zv%=rHz#1dApG$#Yh{Wl45j&Ho^-BfC#B+p$NYK{o zTt&igNp@kTx0FT3gB*9GE4lk9=57i9(@a$J1ri+Bh)ZU9Zd0OS5~oXgy^~fz+!S#J z7a5Np!9$br%nd)7Zrnx3XUS}x#%yVzH%E`+T=M$DbVb6s3bU@czS+E?Wl!2LViK$} z@Gv&nCFVsy>=CNql;-pXYjG&QIC8Q*)aYw!m>gCVO;2p{Hk-_)!oJKCyh)76NNV_ggN3Jo!4 zr}(U*E?wW8`=Rl2>UO`e92>Z1F^)VkV7$EA?^`joTz%c(TYN8yaNR~(DTdf;q@<8U zEv58PoPno3MQZKHf8KuxWUqODyA|Vk{qST%lSwcBkjgwiB zZ6w$sjZCn!84DqFv=0v;5s3NFfEdd{?Ak*_J<{)@8xtJAHDlC)C3uHF*(gLYP`|>a zg3;k7iZw;qniXYh_}Jo+c4^_~w9uK>MDv&WS`kglzINrKzolAp5>S->3n5fQ5Q-8V zZX9)ucP9^t<|jn(?!}5osp0C;3b_>8^PW*fNrs$HgE5i8cuODk5qR*?c&qFvatF=a zE-eU2&Fx_}mNZOWntdMu4><4wqBlShJ?DB7M5mkHus?9JZp0P?ZkZW`W+o@7W@eG@ zHVZ;cIM!#P41P;W%B1w16Gb7_oCMwN9FB$TIjJ=t9)P6+Goh#DtMYliSv4y0RqS%n z6``gs2n^ADT>_bms8+kogqjpRY02NJjjaA%d(Mow*vYdJKeE)+N(ECc;cwNH{?w|b z@vEOu!z$@Pj~b@V6L4o_^X{UPkrR9M|CfBB`ybuZ%2s0I=G~yOP!C1uO%9S`-h;*TI1%xuwid(QRGsMppkR< z1vw+*}eRZ@P;;RD8oLy_q`rbo;r5tM2uF9T8ZF zNj&lo5=?^x!2{3diWJzx2u&Qc{mhOgdj)0}A!~Qoy{e(Evfa$DqsT{W1P#_M!khrh zaiOO5VlH z5yp^zb)iK5TKn|inMbHc<4brp&UrSzL_aL$;jF^LQvJ})!&Kp+yCFGSnhO5E?0pG% zR7KWyX9EO6M~94zBif@dl5s4um=@^2nl8k36q7z5t0}Jbed?~opBl5 z#%)x_QE@jRKond++|Z~2grtc=6d~;S-?!@APIsr90HdG!C;dEK=bXBA>YRG3Zq>bY z>(&)gyp57hd4P7p#7@Ei9eI$3+>r-$+@T4 zpK&qNMbVgA6F%C26r)LzCY72fSa3|K-&LeZr6%~ew9?b0NRvuU)Y1#+p(1EclS)lk zM%vSa<)AP0+#Bt=*7`PRBd#sljBJB8BaaMirfh>YBio?O$Tny*(i?5_GkaXifNfk^ zulPm1T=!sdDI?C=3zwI@Tuu)mt}Hn?eo=C;T7rrMJbpcnYc}3_#R0r*c)&FtQFdpq zBpgk0vq{b?@GXv%J+4a-wQ^5HmlajBkMH6-%Tq#B#IUB7dyY?Ra{Yz}4lvn`NEYTP zAu3{6-O2;UC)T;X!7QC|PVKYfUbpyK$QLVr};VF3nTfqZvU~lr2Jb}%`0adOpEEcL@ zyiWw9BZjpw&GCsXu8VQl=oHWwMw z59V5LtTG>(dm&%EH{maRyUkNLMGe4qpGz?4+tIb7Z4c=`OywMdl|vUd2H z7p!X8niTS>@uX^Te@xd}ha8_bTFv~2sBl=2Cc&EEiO#)zCS{ceXP7jP8m6Bq4AT!2 zhUupW!;D8VbDwjmCwc4eoCaAUWR@hzlB7+Rj6{|s$dUwElC)-tCp?We#4qZhK7xej zIz3z$;3*rK_(fL)yUyU!3`Cx)X}n|j0oQN9Cn2tfrdV0K$JK%-rhIM_;^H?F6vtp_ zlWU8TZ^RLP|Bw%DLKqCKbFG1_Va6j*Tgm21;M^1Ay#`&Qq#wr&)6Zds=?5?YP_jF) zi~t|QD<8}kQgtRQ*vokS;Cdc`D&14UsM0+Efu*}kQ&qY$@GKple}Jme%>=JYmt}BL zx(P~V=|&lxlx`?wmH~$@bh9dAXp5^qV%mEqQp6MfZkhN0htS)Ea?ucfHww)UK(CYd z$;U{?h~Ds@iC!Xh2X;{UvdsHqe_{1|UMN37#NPu#?+QT6B>q^RAIuc}te=Ta5WD=i zFn=A5)=IfMsjmNyhQns5|4ypwzoX%>P3pgs>iX|!ID9Ad-$`}-cQhRKNd0$GUH=^o zhZd>-PO9s_qv6m+o_};wUH=^ohnHpEyGrQuLZ1@)fY7@F&@zcX*5?N^ML+9jq7%gK zs18bpO1UrWq^bkxXgIiERFkFhNB-nPr&RA7jo6?w|KQ;f4w&u@mCDj(&nb=MB06xTw z?aQz?F5YO^K;4WATgZM}$WF=Iyf_J$FL(EnA}Lo0X(< z3m4XbTJcR%l+}vQpD5zeL;+wfnT_Wdu7_~|Z=A*BZMz|F=k+lr=XXBhnuED|yu2x| zDD=6R4{gkSZjRBUNRvtsIDE8au@);=RvxTJk?L8bdKRgkMXHw~)k~4;rAYOW?>`GT6UaL?qnZ!BFYTp=?*O2+1N!+58 zVAl{)l={IdCrsVn(AP3PwR<2QyFMOp^)wDhdc1^UNBUiOD@VQmre(Wx_?{%B-{ayo zr1C<45h_N#mV(!My1J^>0k@3TRfab48B1KhCf8%?m`ZOA*~^CK*laDSud{~Wb5Gyf z&-}`E=1w$JzLeG4igkVAeU=3lV6yT+)Iv=o7Q~3GX~crbB5N9vP=v&Z2qF@ekV6oW zP)QC!L_!_8I+z;?b9ToDciUIR61?N_KvBuAA&QGJ+Pi_b>vR?07XKdJ=>`8?Sni&M8iHGM)1H4%7d za-j#>E8-59K4CI75qN0w63Tu49GE)mL4N%1#B=;Q!2M&bt^BaIL})6YZ=zm0NO#1F%-Cb=K1 z3qbkODt}9lkyeOa(a%J$mGX8}nkD7$sC1^3zoXJ3DSt<$6;l3=N|#9aJ1Si&Ke!0$u{x}s`tcGZeabH`WO^ry0BMc5sm zV2U0uEPQ!c%T{EIly76|+K$h6lx#dT|8#5f25hTmv7fmCDKXiKW%TbMrF*^$n++l_ zPC1(w^Rw*OBGBbyD@4gkU4b?t;_?k77htz?CK_sSjX;D-uVs~rL8a@@-un8u z3S(3_+0`2<*j~bc4u8hJO(v0>(CYZB6S_74t(5qs$4HlmUd7Kujq)1h4^(cWoW9g3 zw^5FxrAE1nr2PNa)Y$K&?SF9CU8GtU8_$9|kD@4z@kNLl*GsOPn4oXKzxnnx1y58?-I9R0K4Z3pA zEW4w!_4^(+e4Ep;m#g+l_5@iSZxwWnE9)M&=(uWod0$?uBf4ARN%o*Bd(iR}XYcBi z@{>=BZQ1O;|HoHPx&qjO{zyN9>5KO)g>1g%Vcd7NQA46e9JM*{34@JYk>480FRtt) ztb`gBgoR`waf^PJ5$6~g6z8yo*h(6@V*UaDuUyI7Ejc8vo^?u6V7bjf-I<2tfk;mxs7G z5kR}Ni39vZ3%9QiR=XY0-lE@OD}Q{;0vq7FnmG@^pL^GL7h?G1z6ty#Y0{D{v|Q*T zLRSj?Qs@s@Y{}pIL>a&5@U1ic?v{F;Fa7#7nI9h|&xJ0>{V#vth<=UeKPmdRi2jYD zKS}h5i~fb8|F!79Df$nI{zB2u7yVSxA1eCiihix=FBAQLh<>5yXNi7_=wBlGXNdlX zqW`Su-zNIAM1QL2CyM_0qJOIBza#pOiGG>r=ZO9U(Z5{u|0Mb+iv9}G|EK8RB>K}t ze~jo~DEg;~zFG8N6aBkI{|3>YB>HyIKUefm68)~C|GenmBKo`C;{sp3cqUZ;U-VUMniT*6nze@Bk z7yYwD-z@t3gw~7x9ipEj`lCeuLecLh`dvlud!b*6{$kOeCi=rg|6I{OS@c_kZWH}a zM1Q{MPZIs1qJM_y_ZGcop_@eiebK*B^ixIu645_Z^m~fl4xyikevRnoi@r_t&l3IP zMgNe{jiUdK=)Wxb8KOT#^iL7}5YcNAx?c3(5dEh_f4u0QE&36nzf0&Q(O)V0#&hQT zMSr;HpDOynqE|2UL(yL*`VWcyTSWg-(LY}Fe-OGs^jC@g6QX~I=ogFrIiepTdRv9A z5&f4$|6b8wAo_WtZxQ`nLO&J#*G2zH(JvSM*`l8=`qda9IrWu)LR{Giaf|qsF^)?? z7(#+@h<7LXy^ZmOV~ZYRmIvb?mp+*1KfH$n*9m&~QG*teg}N3a8uRsbXW0l06?TV1 z5$8X~E9viwILkPXjAM#8Z{x(c-EpfT&axT$m?F;GX6s{$IENS69kwF7bJQZcW8@;N z)~ z+yJ=&auehx$XJv-a!)l1m7<+f#977(d=x_wXW1kzDdH@frX@w3WjR_>#91~=ONuzl z3bmw&bNE7-TnN**fZhUnH|X7<{{;P~-FekxcE^>E!KG*6(zA$PhWKTOe-rU1o2-X{wu`SBfcK-I}pDE@y&>Djw>7961T|K!XhSXcNB4!jnk4M z&a#PGQp8!7p(RC}WxR9%7>YQ{W@sAQ40;#nU7!zuJ^=bJ z(0_qG1Nsc;i=Z!pz5)6M=qk`vpzndc2a3;R*ggjR67);Zt)N>$w}Wm6-3_`Mjd}PX zTrJrSv5>spfwPJ@%f@O+5og&oT2jPWmaZj5oMqFsq=>VuKud}^%jRlH5$Ety7%heI za?o`&__WZ1$`RyY0wuyUjTg_^mWjcpesS&1$`IvBhZgPzX1ILbPMPf z&~HJ%1>FU@i-kNGS2hZlh7Q}oxJ4sXjoP(iia5*0Xh{)g8LvM9gd)zesajIRS(c?G zMVw{%T2jPWcB7UQaSopk8$laEcY^Lj5%;q?QOx~D zZ4TFNDdNO2<)k9cva7VDh_mckEh*wG`-_$oahBz3NfBq+4O&vfIs7J=z6marftG>Z z26`LlKS2Kh`Viq{!GU&^oRiIU%Z-c%K zx(;+5C>~7PHh^vf-3aOeb%A~d`W*_pmxaZ-dKD`df@37k*DG6i3ykNrCDBj!jWPwB zOE+VH$C%46q?t=+VswvlhTk4@x+&@6x6HS!!Y7>Y(L8lS8k|{w z_N|bEdW1ddGmOvpx>*B1VAnmx+4HlM^4`bCwro=NnvfHJyh&C+c`n9#Xa0=mYfT~> z^Y+GfKk8&YbD+<9{Iw!mc+r60455`mBg8HocftQ8M-^Vc3$;~k47CTnZ4X+V6!jJ( zQk*BRhP%IkyBZ&q;VKqnsKr`7%92zbQ80p945aIBfoGXKgOv17~?m;SAk$4|3Z!YdK&pLM&-vCzxi>8`at=G8TsLRsJgt2 zQTZ{(Z+^c&OnzOA{P4|4ogZUVevI*(-x{=}K>l?#@;lDRk1;Ag#`w+eZ->dRn~@(F z?H^-QevI*(-;0wkRuVAJ_AM&-vCzxg>2lOHNk z=Z9+5`7uW2#~8o)4LMAHXkGdVxUY#Yv#^!)c-OV~om=F@E#A z_b~b4B-Qx^8~HIt<;NI*`86i1{?LDafDT0Ghb~3?#~76#WBlcZj&1EX7@~tdGiDuo zE|-qib3P88Q4D&r81!V7<~}!ZiW9x}&`Jcu*P>^M$uQT)RwA&iMbxM|1Xndd99f6p z%BHz*!p`GR3e5cx)Bb$<2c-+bi*x61cuK(xNV8R5ZZ^JAc+O>1904e_yIUR5OEg~ zNu(Kwc<{EE!liJ-1~-P6_YNLj-ZKcppSu=}`i>FYY1&+U9LDe zA#EFnv|$`l)~TgjplP}}_d&ku%tiX?RWhA!QB0>B64M#2sqo4s;Pi)Wtghv#F%Ogo zisLw3L3G2#L^qrr-CTLi9_6u??87wuo`TSrMHg1vUN#o`aT?$J;>R}gv+DpvthqcC zqa$Y9`@(&DP|X$2p4G|aC;tvJ_sh|+Jm#mr16ce$g5H+DT|zB#J&`PQw$Mj~t{1vm z(k~He?8kMo93L(;U+9BE-xrF{#j4+ZLcbN-M~){5ogwsop=*RLm-P1tbqVb)$A=2d z68d+cHA3Hz^mho|A~ZsdUncZAp~imu)gr48f1?D(_1Q+z=f1`KT_SX<&|8JRDfC52 zzgXxOLXGd){aMmY7FsTpS1bHIC+Qan-5@knj-M}df>4LhWkR2k^z(%p-^Vk_@pFWZ z7g{Rxze1lBy&|FOgdPz3CrLL(XtB^|g<2h{%kX~_{~G+?$Nv-jzrw#B{~h=@FG_7$ zj_Yqn>Pz@n;*T%Er{b|y>ZkbE;g1g^r#9igM<;s`>>K#6!v8(|KgRz{{I}x29sk`K zj?_as=?f5F$A2aM@8bUv{$Jp~1^;jH--V{u}Xk;s2c@b#JTJCDHFj@cw2o?{6}!=IrI@6)r@> z$uMVC+G>_ZfVDaH;&GfgDQY#=shaIUpCm=CMUSywdJJ?ItvEQQ9{ivMAlNY6ahX^35b$c#SVC~~E?rky`C>f71%QvtORh?&5a(U0= z)P5%D#usv?m6Wrpq?|zoP2~8H$e|&Tqe3DFghY-7iEA0uF=(nrxRA4&q?3elwvuw8 zrir&O=|34f%iv80?=$#{!44EtWy6_6L@eYiAt`4BNjdw+gf}yIfWb2i-eB+^gD)9u zmnH>%A*bg^ITc6BX*W_%v4JL*Gq|6@(+pl`@GgTd7<}8>+#oLG^cN|ox=1;#Man5G z(8R?I?ql$82Cp%Ahe0iaZ}d3?cHtGG$O$FNoIE1sL=lrZ8Qja@DF&}HSi|6R2954h z4AMf*;*fI2hLp22q@0NXO)O*Z4+c*%c!j}g2A?t5)_Mj)T*z4xQqG8wa`uB%UwITJ zIv^zeoxu|fUS{w%1KipcCc3;%P{b^>iasapDRY9Jl#}t)Sj6BS29Gm%i2*K#3ll$O zz}}BNANYldqRE+Z%A6G^}`#n7V<(qX(#36FDWN_Nja$tnpn!R~L1D=G5mV^i?g8u;g2jY*rh{Bk{^~n31A9(X}X;+UcX0P$j zw>(yJ^@;e41uzkm`Y_-`RScN{32d`|HGhq}Z7t^j|`E3cXb9EfV^X(EegCN9b!pyNjKxg+4BHk5HS~e@E;`h@DiS z4+`Bb^g^*$B6O`#i`e^%&}Bly#LhUO4-4HXG*0Z-i2WX7XOz(Ugt~;DFZSjMT_g1O zVlQ3jb3#pGXQa>vgl-plx!7MW_PdCkB%yZ;{aWbRVsDPnRYHF&_9hE`TIhbEcCq(& zp)R49i2c{aevsI)3cXF}S3(Dfy?minLXQ_aR||by=x(8jV($*2Uke>9_FoeFdxge` zy)vPn2(^g4ETJz8Jx=V57P>^}cA=Mxy~RSg{~CX1i~Xfy_dB5%iM^YIzAvg}x)Suh?HAb~g$gAog;FzA3bu*cl`AL80FX9U}G?3H?~;8DcMA=nA2cVxJo^ zmh4Nx2=RSLuxXYhX-d!AtwA4KaZ?tgwp29t@EVU|E;=;tYD_wH;VRCO`X*~hO@z(y zmNjaxHE6Xp>OE)pd;Rf7=*6pTj_=G1pE(1ADQ@-5^EnUZ41Wd3V5%lG*pxD*r!%Fz zXAiaIBWA1RdH`9+{k91n*vsQi1jWrc>})h!&wJk*r43B?FmUz&!@%fZ8n{v$_*WYP zM*h~4ZMX)=>18ch1zKpP|MJbPow4RZ)2w8`5tI8T^MF5^2P8+B2aL0r2TUAjjyl5} zl@ei&O0}4yCJjU`F~|Y`ni!21O7)-MV3Tc1@7ry7o^=@>zxCkzfX?t${S+RUx-2r6 zybc&(-Yajo;hlN$wjv}m56Fly56B*29x!vVdB8ke_q?d0qo&1}qjE-=qh?JuM->{E zLwQfY?@F1jz43h7pp&4mH;Msxkq=fi6(+cP%4}TrNSI2 z70!ZEVQaz4eG7)=x2**;a>_|SPOSw~myuGil6{ukQ*e-aDp3SV4@SH|;Vo=uY;t|S zHTe`CI`A_mxyf3xoermf+2P${?5f3_Wgd{wgeFsmCbJezrqUdh*n~Dyhc>eoZKjf5 zBNP00#K2OCuO~MX14C5gcra)2!Sl$xk+uY++ z!-zrG!uEllMrF+`nAtdHHn9>x#!>{?OAySgK%hNsZ5@eCV!tpIDut7vQaBANg*i|u zoCTFaDaft=b3u@SCD#Hc6a-|F>rh-Uz!*Uaq#YL2*ZM;~#nttdRPI0*#10R2-;&!E zGJA5I?UlM`Gxu4*6NdPrWth=2PQ{shF6!xW7~7R$zQp`Z5Naxh+-5woxy1Y#NPHy17&Kwkf$4VK-`88C|2qDA?U%~TR!Sf6F`!4)_-HoU6a=i*`Rk$VOsPL@c=i^-fJP)*sXHVdHGW^5nkbS8e z&rmm>c$$v(30d%jd`x%__Vw6r`wZZ(;Q5WJE597Cd>icP!)4 zoy|vrX8?Z%&uxO|XYd!JZT2f}Je8O0RamRSEnSWZ&*t4e-UYyOZ@YLN2RwfV|DxdE z#cn*iy79#2D)59XctSoVJmY;m_S-%K_$zq21kVld_igz5vKvq3<$4v?s&Gr!qr&sC zU5CT-kM8TGJ#F#yx?1W6H2c820r2i3H=5ntXm(R*LKZY3d!qRppQ|OVztopYxNHjg z*z>9h7bV~S;N!HKAN3kP{rKAh*LQ+vgW&loJbnuvzvRYK`MF+&wJO}w?Wpif^>r;k z`)qEDC;jud{_F}wPlSJGz`qOKh#u!g6ch7kpO6Jn$exHE@%87UJKKQC833$f^1NOS z;IH6WFL-_ee{10HGB=*e%k?U(RpAy~Y97V)XIEeE0^qs3T|B!0&)>p7+|XzL*^Os+ zH=f-Uo{$Ak$j5}|*zb=7&j9`ko?8XakKyks`1_(8Pvzx$71pY7OZTI~bJ=%3-UYyO zSG#zI0nbSI*B|~3cH`N@jVC6G&^{pxo{*0T&oEz){q~;${1rU62%aCo-<9z91vj3` z%k?U(RpFK%M}_A!tj6}5NeY1H5AEU^3OswmzkcwKH~RX1v!@$REb9cGkOfc3$Asq# zJA6F$i)R3T1<$Vq&ky163i$iH8&BosdKK2Ha7)jl!t+F5?*ibtvt2wxfah=E-|6sg zkQ>i%H=f}NPsoBN7F`sT>+{H|R*gMjDp@b3@s?>sl2W;dQ#){OHVvfv5% znDAWL=;N_pJOlVEcy1It*TLT^`1>C>p32MhDy&uE7V}Zzd4{idt?d)f7ZP4Vko=b2 znSeJ#lkryQxCXm(Vw2UGyk{q7{cyA}1@Dn2;@!~{yf>PPcSa{+wO`5}Zi7kvN+ey| zR(+gO$9lmOynX7col0$7e^Ni7Y5!Ke=HCOE4rrCy9_#7+xgEgUB3`d~BQy^0%X(sh zQnkt7K$B?=>{RI`KO)Uz#I&tGkEwX~exo@F%UEAEC^=qtO~$LPQ@(;(ybC)C@4+TEV{w=A&^^CM{NH4Lc!jn#FXV0Hg@c7Dc*nLi zALOg@an~Q-!cFjU#X}u$=_Y!4(Ws5MHv#YVCgZ){ad@Y9 z;&y26mik13!W6s=oQM~IQ}FU{Dqj4Zgq5@@yZzSZ8_W;y3kS>(2?|s2Qt^@HcR1Gq zd*#ty;fmj4!2|!L@jgHOp%Tb<)~_#ueyte&vk%(7*djl7O?Y8$=u0gbby1Pw9CwHd zJJGwj+xH8s54_@>fY+Ln@k;YJyv{uFTWIc*`bC1m6ubwWhn;5wCxz;MMO`y!Jf_3)oY*AhK=${2KGa+v0xn!ok86yiVRWA9w$JI9CFC;ZeVV zO#8Lkwtx1ALZGsVvK?maJa`c`uAT>X)@*U|#`V)q!!G_4!}ok5}3g z@EUtEUSS`H*ViXDqCR(WbO!#3NKu%A7vB@{vU>_%bWg=g?vwDILCQ`U)4j&qSD7DP zjrX4yjuxii<#|8($o1A?T?y=kyFI{k;G+1q?18s`)x(sXEy7)Xf29skR=Ga%M%xdz zKKZxSj8`2c&goIc}e-|9u|y z{~y*DwmwL}b_dDW>R=qUIhg1|{eNfFKT;H?V1tB2Y>JSA4G~hY8NwvI43vWJp{i?o zcl$?H2`@80Y@y&kFB~mQ!6plS@{#&KtSf=NaMyo8)Bde`;S&gj!<5}ezip`ll+~zz zFSPw&>yv+L&3M&8YyGQQ^QapyedoBns{Z%3)<0)oBGgh1tcmATK?IhS@tq@7V;5Fs z1cGrE1QQ1$$cRCZJp#eZ$q3r6_EIbFx!Mcg7e>I$-@4lCUe6Uh z=OaH~i+U=fO`e?5;CzB!ji=Y`Tks0L*EFhbPgu)UKC?**$OT>Hh4>pKOlX49z5ZS+7*jg+ldQFICU=O7&c?RL}KF^<1x1&-F_6vR>(*o~640 zS+%jI=Rn$K2`4Mne2ID^A>lKhl2sVvxB9U5z6z7cly?EvYR)`K1A^yUCw%FngSa<* z5vp*n@3e7YsIk6tZ&Fm1J!-W*=shg!)C)RqhY4r+mi?!xwNEAe`e3dA>*u}-GRZo#)5)WUhc!xK5R_D*48FHdZemjmtRy>E|t4>sKf@x~D?tO;O2 z+PlrM4*QC9vjwelhTCDucJbThl7%P2jIsDI2QzeqScf$(0*jR*FkfcDVkHaapa$Y` z;Xth7!g8tDLMp=w0@1o>Ap_g72FXuVzMtn)F58`Nl zq7O4odP-|t9oJ03%v!GSf|*K~sl;^HQaqnr3c3Vz31|gq1!xgyk=qS6teHi5&w4o! z^@%l#s~NxA;Nt+^PcfDXCb#%5N5itg6f7H@6o-|JIS7&qrIZ=*m^6GVC=L$K$cO`9 zL!Ph9Tw*?im0yJ;$n63*D~8-R;Bp3%+YF9tOflyOZc+rfb>L1E;LIg_SIc2_b9!bH-OLh)E9W8{kP(O2*vPPz6SS_ z;nYOBl1=>QdEp=Ifj@b{A1lQKe{h07IKdyB;15pl2X_ScZ*J3e)OZTF==gRbw;DMq z{PBJ#@Q0-Ee~(fv?GgVsC~-ZT!v7gc+aW3ZAE49>N#lRB#viiAf1VqERo5#T??PZQ$$ z+5yRQ{97Wo8aXNa@m4JGhota-mr^b55r4cp3;ZD|{GX<@9g@QTeoD=dH2&opf5;mD zxo-Sbd5;4BjE~yK{{V{NwLA{^+kyWC;-5wQZ}h@H)B}I=f`6zRe{h07IKdyB;15pl z2X_ScZ}!uKH2!q_8zQ$FIVt?{A~EoXr0{=-QZ4Nff4puC{2?j)|4nH-B!&Ndl$s%F z{1NaIh(8;RU%5ReJF<4@;l%^9Qa>F{QpAyZ}7su ziwFMX1%Iq`6a2vm{@?_EaDqQL!5`ca;J?{V6Vmw8@ohwIHF8q;9g@QTAC#IQY5dDH{*X2PH@NXv> zYk?o|w*vq1#Q!?tKidocZXWoP7yPl3PVfgO_=6Mt!3qB01b=Wxfd6JcO-SQU#~X;; zYUHHw$F>N-ACkiVElRbtNBpsQ0`P~V@PC}rc1Q~Udnh$S()cgZ_(RtCtL+$g?OmnH zdldL@eYbu5n^6p}<$%CH5%{MP|7pa3mKXlVdEif8@W;wK!5^I94^Hq0C-{RC{J|Xo z{!{!kA&oyBuP1V=k(0t7n@IqFNDBWNO0~2{{ITT(@Q0-Ee~i+0NDBYEDK$gV_%GD> zL)Q4KO)M1ts=P;mf5toQq_e@F`de^J^F zN#TDNrDjMP{{y{-@3Ye{CA-kUds)Ee?0IXOZ?M`e}NbNJv{Iy zFZg3+pWqKp@CPUOgA@G03I5=Y0RJg|nvlkyj&C7ytC5q!|07E4Au0Sl0A{ zfPLN=R=`wNK)zQ6^z^6z@=^g<3Mdr-PAUMLQ~)@s0B}+P;94tyoBVj)!y6M2n|#}l zasNxdzb104k&(h58@vF2NDBWIlxk^?_&-mH>lGFLk5JkUN#TD7rDjMP|M?n!$QpmO zv5dlB756Cc-&)fS{s4C;is7}K5%3QK{G$o~6vCh91%J2){Nx3GtQ-{h!3q4}1b%P= zKRAIOTr2#6=YRY(A>IDz_+}!v8aXNau_q4jhotbYrc_IN#2-870Dnjd|A#4Uhotbo zol-L-jem*8AF{?@?Zu<;SLHnl{4-XykN@{5hS%~(;6D`jk0Sop68~H;{Cj!ePhRlH zN<+aPoZt^m@CPUOgA@G09RdEE{WKwsKONshv%V(jM`DjuO{H zD*PX!v>lSd|29g^kTm``Y5XB;{MFt?3V&7JqriXbiuUpU4#n_VE(!c&f&WP2pGN%u z>V?1A1Ap>@KUO9R{@?_EaDqQL!5^I95AF!?pW>$pY5eKvhlP`uBC-2%-E{)IVpe!;71V~G9Y)ib+rqlxq0 zHfF$OKD*D&c%Poz5^y6)81a2P-_CQj#P`=p=B$D_BRcTY{&D<`T|bxV_?b z9(WuO;d@r_d4$^Q1HL3+i&*vag-?BKQG4~%7iW0OM*p?)$Pw0x-VA`-@xVwjAFhq# z!?lTgxR$|(YuS9bHj@w6=2h&BgCj+{UQ(J+6RC9wCaqXPxl*m%H>Hb)r@tqfX!r>O@NmDYe$gk-5kkfq#YcuaN!~(!WCbS4jT~ zm4Dcxkxyrof5l!G8BrfwqgW-;Xcu0OD8Dy1B^2R_cw!MbJZ;1dkK}+4ws|B6xUknF zIiQCPAISks?9M>0j$9qNCUV&SQT^P{<8fpG&ubi1Te&f1F;f;#zy4r7gz^V#Rs8$IaUaTRFFxj3 z!rV*9-A?Xyau1Vxm>kzaCH|LOHMweX>&dMrw;6%3A;-mbiO-W;L2d=P56OKP6Z4dh%1w0#%i+S>PB zkAmb2I1h}(YVTC$QO4ZL$o+%dKgc~v?n!c7PnP%!xz*%WllzR^XXLga(Dt_>&Yykn z^-xH@fMY2Vt9@XZhm*NE$=yrtUUE;7dx{*_GbX-DZVkCLQYasKRk zuLni)1$+*O#Ac_m8$m9HTnxE^_^^cP6>tllwin9tf1Z9*FX^7ozRqwoLH6fjT!(=P%^`LhdSZSCJb|ZaBG1 z$X!D2PvrhY?j&+2k?W2?+3SudPkX`IUa;HV9O}%WPA0iba#xbOlAMj4joiiLE+!X6 zE{fdm$o-DoaR`*X;}GR(FG$1qRuRG)5uLDmr5>`Tq3zdau<@jklY#M&LDRp zxf98CMWF0;MU>l~b6kkCmm@URe3aC>+opf^P*VJh{Q-29xVgu0Od*a*^c1 z5GZ?Li1M%(M0-J=_VTHdPo1gcrji>&ZVb6Na&hD?Aa?<|e&qU*>rJjVxljbkUMQkk z?fsUu*Sfx+Df6h4M{WwaDda|z8%=H)xnbl6ksCzrbaJPY`wh9@kPAVe?1do8Z4cvN zP=>P?UcU*-FxqD>b#ke5ExBvSjUqRS+)#2u$(>K`d~&CeJB{24eB0+=sq)P_H|uZrS`|kZD$5e_NEg?{6`U5O{0SLF?39hT59+ zVcD8Af37q9bi^b3CS>okEolYvYi~c&FV?o^8Xo1nAL-jThMYfcle2ODa|#R(Lw<_= zNH;$3Gq<4kBmJ{>7aQUHI`$(y$+s9@>(~E3-;cEKe|_pu+RKl>AL)Oe^RcAY+d9L$ zyr-JCZZE&!{Ybz6k52*g^SVAa>uJ9K-}WO7@hz^dFR%TTemVP*j$PWOa^_=>)@MJc z0RGB;5kK92q|2W5@ve1z_rf#4{+=HDYk4i`cJIIO9s)HjpvWQAL$EE`*`dZ&j9`koGmV7dCJGT0C)!2-_rw6uLaa@Jb(QCNF#kc_S-%K_$zq+bo-Ic zdh*Ed46wha2cBLFqTP7@`1_Hre8R_Lzjy}lSMdDl_9H#R*Si4iGr<0y9(Z~!aCYPQ zZ+zk=8%#<6Qte1MKhVfv493VK<&X{(hu`eLeQuJ_GnGc>Z+z zk>35#k>MF&e@_oQLp|5~y7Bz+_aoi%ppVCX@eJUv;Q7<-N1EvCU4Zr(V1G{!JiQk1 zy7Bz+_anV?$&uh0z+b`hr`wOT`JX=C1;8`F{+=FqdM(IxmgU+-GmC!Q~K?nmmi z3oG{q^}Bm&5$6lBi;%~Tt)2Ukvi)@KN2+#j#r8*?`;oeLNtOL@*giVD=)m+=&|c67CKH}>{ArhL*V^Zx!GsbcdWtVxKZa#Z|K@< zvnwic`Ni$QdXv+qs6Ok>OnCDZejjaF@M3urs;dq!bFalK+?A-VrKqkYsICfBmwuV_ z@1Avq*F4%<;XbmySs8oCqMlZkwQ*jr$Kw96Sbuwld45qpzC)|Fk~Nn+%Bh#~zRAAT zD+%%jxHmn${$`(?z285DuU*>PTJ|0obB32as@5HvOQQ7FvZE>jY%S}x9@H5=ih8oY z>;p%?zwDU-%=p<~_M1n3-u-1wzWv7k_5QM#`?jKA(f+d4zNhc6X@A*Oi+oQq_x+T6 zf8SsD{<6c`v>n}l{wnsDO<34I{=e}3Wvl%(p*U<+@vGQhc2#Nn`2WK9mmTJ(32FR) z1^de;%x@q6U-H!Tz$V3fss37rwvjFh5O5Z`SKZh?{=e}3 zWrz7`LK^>H!Tz!de`_EAU-;n{SFpcq z!t8eN$8F>1;QWC7Xs}sJGdOv_3lT8>VeaODm-eybHmO(XT84Qi2X}{tUYHZdUObX_?oaEnUW<5i?oW%>)VV(`nu6Nzkb!%@LyYg8`_rPIxtcxB)qtpT zf7;IdX*>6)?cAUCm%Tr&`~G*Q`ILRJV`9g~jy&rw7Vwk62{=yu*_9W!+HJnM2pQDO@3#~LUv4s4%kSuixdcW%4{@N1x}cxcao0;^9WPd@ znCOc}3@|C!Qp}_w8D3bOy5PWIs&$Bl#9Z2-RKpIYpn%0ISP`)kW3P#w zP;GVIp>VPe`Vh%`D+JA@FEhD!y7K6{=`hi_e^-l@B`jhR$0}?2YyI8=`wHcTYYyyc zdE*=&k?4l25AJHQIaVZwtJQ~U(g;5gXY7*XkHb*~Qv|ZoFge}> zL|>vY8K^zENujm|QT|XX=;e)A!*lzXFzkx>)3jl0dE_)?VRc@FjPC?wu0k{w;JNoN zz%X<#QkPcd-`J*!-+&|DO?)#w!YT~OxObyR7zw+qlG}XWt=;nTl zZ%WkK)i}9Vg`Cq+LIr2E9indDL)pA-bkW&&L7Y(t$Lc|qR_Bn04*`S16UD07NMsoM z24Y=bDxK(H;G0#z67i z(xs%xOOzD8SxMm+DQWN*N*erUB}IRwq-Y+4^$n0WGN*__yR=+FH|IY5eUlXP$axekx1&<9eo#r zAeVBG8kHA1D$`30^mikS_X~Kwj6es|4@bsh-+m>lbPdO=C?lbaPoqYT9+w(BB6ehK zD$dI4L6zo*aGBKPn9%PBTq*6r#nXY38~Zhx%=6y}#o$@8A7jZo;8d1K`-$VD;(AjN zE_b#BIo^wPEVowe2yb3)LX@>UD<{Za9^cJoj&ER;DX5^oqZ!FfrkIzyA{_L#`5~r{ z#RnxrcEmc~a(v~&*n}&p@2ur>@!83h1C?H|)f|7Y7@emnG`4u7x(KP-*1H*B;ADSr z)+Ol9Pb>oOXr?I|=w`C5b2+}Z^>86Cn_~yn;F7KQeH=11uYw0Aq}`!14TcZhtvz}gY;zYxxo_o#3{99EJFPw5 zZLR@lVe!oIu3{D~##+@FZtc;C*SH*w{kx$Au?~FQa1E8BDLVEz_FBzxjj<*5q5YW? zJrBhgSwG173NpYi*ktc<(2h~Q_+8{~YOdkMoE;EZUsuObHVmIV>^-nk&wiD+DT1DK zW1{_d6%&W{+IoDVybD6yKGtTD`Js}H792I>=u0q+2wRUG&DF#^&QTfXsHTnnCZsLi zTm(yoxo$Mq-`1nX#s`1+g~Gu-vCWl&a*efW^V!xOpQ6~Y%~eDeaC{Nxc(-^9(^{*x z^v9u>dP7sS2*);S@oEUcyQ?FRavN*I)J4 z&sC7%eA7t9(D5p3kB{gJO2NzkCn^}lgiTcIHlPh-MUsVuNi+;6sN;i$hPK2CfEfS^lgy%j9b%#xm`nc%|CGmjVUD$FiqPfj#tH~BIrgJ5 z&@;A=PbkDh9@W+!4Y9>7NKk~*WM=Zu0dtNE30 zPi04x-`naq`w`m!(>1t6y)t(Eq={Ewc~v#y79kGA(dJN1SSI3#r6uCDDI^HB){ZF1aJ=l5=cRY}KY<>!6Q@Iz#Vr-~AMvVs(6T4Q`C$n~;V3 z9;%=#uBmvS;ku?>Ej97?(ENyz_l z()5`$-3J;qrSIV4k4{_5OF!i`p`(;vN;Isc+MP;PeTHN2OKd{shn_eUB)@O01O4Lo z&{&5REq+ALlA55BmTq&q*h(rR8rM5sXU>!8%b*tf6lEtKWrIgaxVyNS-=l;l4<-&U z4K2GPoVFLO?br9xpn|-jO?8#q!ptvzfOZ@@)Hy%A76%i|%kB&3Rcn7!)8(ev;?0$C zTQ$VSE-jTq&C3?6WU(#P#T#49>{BM3-?OF45qEyKSo5>h3C{b%>!6L}apq??;QwiC zRbzLD{ru24$I0hgTWV}2RS~u!d(4Zc!?Tj;6X6*8g(U!~WNt;UdGTG~2n*`yKA^M~ znXx_q5ZRY_7MdUOf#lMlc}bTB&pZFpka;J%Q^X7eY8L>ti-6jtt_s8gai0#2VKNjV+mq*8>on{(V z7TVmeD<@=1xo_{A&*{U{&4l^$cZ64|(Limany z&I!$-RSh9k+ssw2F0qcdL1-~!2BFE=2lb3~oIJ?ZveH&^Fx0%5kKT+^*w#{IAM(C= z@o2=cuy&^|j8hlJsSD#&g{cXf60dsv_e@q<2agx>_FB>F;xsNrt#z9jk-E%ZdL zCDD--W=4-Tt{m^5%5vVB#jup0(7f7NO5q8VJ2byr?3--%jo}cBO!-}6)or-5Z|$%F zrqa)69v|n7{0OY$OPp?z?}KxOtwT6ul{&PVhgR{>3Uz2z>!CN@hh7F(`nh?2C=69? z?q0REyJN$;y^bcwXH^ZSR&6`A%5_S}ddJ{@WSnLSX>#;cbj`X$x>LDQ?l&TF1B#ciq&e}V(p{zh<`lnnNNG=`F_#{X%$@Nc4k_)e z#9$?UI;1p0i93O3O({=U#N$kU!3tJvkaenKer+_X96f8Irj(~V^1*QO!id(4$U4)TJE%((u;&g76V(eAnR1e{AS^dj7SIG>(=c>1(}zXo`B>btE=j|q%BT2(;-|T8>c)9^Ycj*MU2n9c* zcMpA#6`}_4*Hu#U{L66uU_>h~y%ee*gSaCGpOqY2iQ)S#HGEr7c64JEx`*z{g1#4z zT~W~I;-t3>7!!!~o(!*->0%AJ%@#?lYWH*?zE?s#DU@{K8bEu1D}7VR(E z+_z|dP{F*IqWU^}`QUYzqZTn_FUC=h*f)d57T0mi)`nR=+uo|GcQU>A$ZbZJ#>gE4 zUfsg@4%&Dg0>w8tq^s#s?YE5HZGGo(z4KB%Z0{Eug3`FofB~7f@p!&~fx8>VFvs_f z?@Bg>mTU~pKdrfjqi6m_r61(uE|Ztm`Df|*5_9R3kQ%SUX*a(DoE+_C99_(#lV0Mj z9sPqVaiLuA7Z+Nm!nG>IDbWy9u*v*PXg^#o#PvJ*@fdU5`xvW(P3E{ybY2BD>=5oi35#OfS)xJ!c`RMYo$FyOS27ggS@D$FPx#ls`5# zcAU-e2_E>3v6uHh=Zw=#W3A<9Uj{lFlgu{9ZhI8=-T$VWwd!CO-^>oTWYXUWX7Ov_DA%TLcm+O%w?P%vW##A|a3vQ-{P+&!>))BkKgD?Kl- z)p%CUtTx7Z{bV{WMB@+)JdO*~ylu>tBjRz)pv3ATl^W@TbedL~XQZjk@nP0jTk<4( zd~)I#tEsS6Psa~U85I{l>hSSKzM2|#ZKL8xt2|7X!WaK(SQhVe+Gkx3@BCD`rA$2T zsprZ2`t4tCEpK*idLD7HWKX#+Ei>Dc30ZTdR^EaZF})x^Ek83S8>x{bb1K@AcPw*h z`}?2U$1lHqdelXXX-w?U5%Hsvbkze6U)ifZaQtXx-~7Dfc{mr`?M~N4hrmC<9-D~b z+5*tFeSmR3>hsMwXN`2p@gv9D#y%_aq)O9dMb6?v=+w+ZQJMxWdPd5DV#H3vvX~zcM2CnVt z8R-n#UV0;cgG%}~ZR<$$^DLv0r=jaByW@@i!6>uHx({w06OHr+_3fjL>y1G1?taLy z6Nvh=4@3gxd-(WP|8=^+avT4|4^9@OCiFV) zD+ln~h)yn;el4zOaWS6$*Mdx3e`8Y4qAsv-<(*S7BkvO22>U-`QVEce<@D+4%!LZqE*s%>^=5dc>Hm!HFaP@NFJ9*j>aV@?mL zV~I7LY~tS-6KBJIAl^4!tcS1uSYBlw?vG~%d~Oi%&nsk3D{+b^41Y|mo4Vppo#XKT zpYi$S_aCSmtQC+tiZz|+!RvZ!J$7s|vJd#{pOrP02Z8gXshMfh@+M_+V*Z>dh|A2F zl9QW0X?otYbEc%_n@lLIfDmK}YHzR#YW=7@|OL}f@POfo0lgiUEP^C{bWlqb6jj5Jg3}5Ma%yDXF-i(~Q zOwI++hr=B|%aW0qm2RQUsp-leQ_O(VqiigJB>^*6xtMbrHO6j9f{SU>(k;W%^3$?% zrX4r#yo=8nc=o`7=UI|4d3D}-mh%Umcae!D&&^KDLh-WmGT}`2lsOm=)2Cc-$wBOsp;97=~K_L6l7=SBe7fEWSWwe zO}BGqrsvMe&CE}?q|b)M%m(1U!Dc+rB%-`;zxBI+b1Klz zv1H|BPxF&*XzZ{nMvsUEG^*+ONntXjXHPvlC*y3@hNc$e5`0Wn`mHX^Nhyoja=BHI zk148j3)W#>Yf2drpKJj}aq$VZ;gL2G9_vr{xE%<+Oaj zi5ctG6Eiy}`)qZx@k&{v@5fGNw!0HBQpqXgCoynUWwJ;sQfKrLqzlm6;8a0wUgpen z)gs)zuHOtZv-1iv(8Ff3G&3`E^Lf(aay}<_4*Ftt&)1=EoS8Yre={}dHj_3z-Q8E~ z9zIYV`NJiD&J4e~U!Oi_7Ee?CR6rwyX0A?+!?klS8%%w!Zuv9Pa^WcYX#dU8q&rg7 z^r-mQxRhl3m51p|jkcSXJFS2XiVegVwMG?WpFJiMkk~V?%}oQ49EYT>qfFjN`Kc8z z|EYl6CiD~R4qCfA#QRZ&9glXWDkmp*T3UAI4XRrFX`nyXqpTW5RWFs5Gv#{!!w%a7 z8dvUN+dlg2QJCuqcuvK|+v5*&*fciTo-*u;fa)gnh=&;w)U^mtX|G`lGT_TjPs_FR zKj%+*rYww>XHP|M%3)CVoF1c^f1EP2Gcqv{W2n)6MpjPF41X#0;d6~q?QFJh3r2W2 zHRU=#3SN$)fopv~3EBS^|KGoFK z1`^K7J6yjM=I}Za?&JK< zEttVt9WdIKXiFZWCU4y3;}sLjfbzNHre@CMXngG)%MIzdIj!*+1&ze+v@>#G0#{p8 z(r3serYZJXTq;^{u{gt$hwII>EaaW%e%1*TIlZEWdXvfU^ZLxJEOBuRp2sL3jblJ8 zUpbFyetJJE7uP5jo|ZiY*NHiK z`KSe7C*1fM_#ZBf8~3(}(x(2U0IiExr25J6RCKhs+QzlBIuTeVw=G>)9_I=#!}ax3 z!lbbYNn>zDVZ&`kdNxMBoNU#PyBpywJdc*UhfA1sc6v@ho^&d#6MfM=B|UvApAQ2b zeT662$-s$`?1B9@SdJBw;K8I(@x$!?9pD4;HinfRT|Zhy;9`rDp%jnRJzJ$e2RV+Q zo1cQ)4is7jh+K8q4m|bUL!iBYTdC33Gt(brHoA;b2Qp= zPsGkAkZYy@*A!_MeTm@ixcp%fNVokfZ_j&QcaNBto_@V0?b^(&%zVE?xoMcb$CK-5 zW7x$d(e>=8_27l;G*u~nF0W0V*RJSBr)A^LIu94x7z24Zn~e+Zv@DGExMP@V5w7*j zLVJ;G7Tm4l){Xb-GjOwow9t+pA3tpDnD|M7)AfDzC6+TdD4zlScy(-ae$EWb*_IKxIn!{-WOTlA+pJ`T#L)!>-8zlo*okhBcgD9f}S|-dfcR-`@@<6-q_<7J$-sXmg@6Vzp9g( z3g~MdutaBqyY(5K$K2hNzJG5u0Q=s(@C6ej({age`0E+x?PqIRV~EG#nw~oo^{H+VvekWMS{~v! zut|5CjfokH0vT9I51W^-?scW7(~%tSbhMV$a3>0Fnikjf824%J7RdPtc$AYxkI=_p z`b7CbJlf94Ov}o-7R9DQLGF}vQ(GHQGyH}*whIqarhxbZz<|fpnP$|D$&?tM%({WI zxOj-R44mCRYc`fTWlhDHZ8Y6@<3a(=Sx)4cnK`;GvabB4n~EzWVp$Z8h_1Sds3r}&leq& z4_((q;N35`>g_cwnO0RjX;f2MB05N~@hZh!8&x*$V58;L$JNK14Xe_S5c6Q-YVwtC z8oSL$HPh>@H-A~zz21A%tEt7i9)yOH8K z^mX<*s$WoptY~NZVnWLx>x{j8X{ialNwI2KW60m6Je%;=$Vj)Lhbb}T05KLqXM>hS zRb{u^gR(-5GHI+)S%c=8Ms-y2F|ehpp0C#^d5upQKGG!5Fa#B&u4+>ehJoCL(b!sa z7lkw)7hNPafuXO$2&Qx)S`(^wvL&%n+frX?nun@}+FZB@-9(+Z6&z{8+;XA4)Kp)C z%Mj)m#KB*>w-6K1)TO~ongpVu3QbZ|*K2Uu)RivA@YhaZqB^NDp&GhJqJ?d(C&xVG zk%%{j+4YFL$XYd4#XO_9gOCHvwr3jUyrFZV9Wg;p7L}J^CYknBB7+gFVw~WnHyimO zhds_YB8qyO2CjM0z-@TmE^rIOQ1iY4n^-F8%0-XK1&OMH8JKF6AG%W#(hgIMVKB0& zQR4`w4G9X>te3p{#W=$$pHH2K>Jd%zYO5LS& zbcWf{M~LY!k$zk*Vq}4`SxDLDN}scAgeN?B_iBV%>+B}g&`!)I(EYuqOwO0nOoJ}t z>cocbcCtT>E?N>TZt&UM!*ACuw-h_e$uk|!g4YwS>zj&jO^MW2VOb81vCn!!imoDe z`r}?doPLSw=E`GNeU=j(>OQcv1r`S%uh@O+{^23gv5tk6FD}B73NZy%=+AWrYC@0hma^EmtKPUAeN#U1T}c6Xa<{RPAun%yK&|N5BtM zO7y0fSFfXab(t8$l#9-puPiYf!APTINmXGbR*b1x!&rs-Vd{-3--JHeGu!~9nH2^! zhwv3kkk4)1W#@>Sbvb~fIHl6i0XZusvgxLR z<_U``3ab|2#zqa9FsMRj>s%4SJia9t88yuWdyCm@E=aM=w4|5|l4ciNWX{Q^f|2v3 z@Q%U|I+m=Ni5Zxw(u6{mJ=2_%nvp$A6AD>g7M_G?ElhN+-xXtO65~2vN|#TVP%}d< zIJ#@mx5}|C)lcUQt!paRZ9>|8{*2;|JwrK($(YJ@GxViiQCNiO3kp?SS-9ra;21@l zmYti8Vz$#@6?50-H25edXiMu*tGStX%9ugpaxvczJMN{GJ;qXr84!v#l4dQVkO#-H(+Tix30DE;zr6ri*$FjJ18VcEknj#mXDDRwAiSpe%(v&*VltP7+*0z}}DNEZ* zTqO+5Iky#ujO;W^GL^iznt85bYetc@JKNRtSd)5h;^Ql^2M$hbLx0Fjhe{Gx8)}0A}i!#i<^FC zc8Zy~>_=j9vf1WEHz^}AYlc#0UEH8%>h?CYQ|u}0(M-L!usrTw5w9xT98l}2`fA+J zR~KU?33(t&Zv<4FX~MDwo=tN_l*4lKz+E?k<0;!;u5diGC^6jT9Q0Kx#H%VgJul6y zCMM)8mfbXN%nY8(qs!Rkm+KyuV}-`k*+|IU4wM#icB-i@4Zg2!OGn+uwxwdI^>Egq z+DAJ(qN}UW<$+XRo1woG1b0u&ScYxYd=BPhyPA z{WjmTP(5y4-zlCpJoSMIYzxK)V!MW`x{*gBzbS8IUO=CMpq?J5LZ}K0x^DFkbrCmZ zG!8_j%bFr4_~gW{vzrrBV>NiN7haWCpm^Nc&r%OQr$@CpFqESl=Bq^qCtucKv7Hie z1se-g)(msLGBa{1{;94G7aFRs6A5&cx3~uoJUQdzUaYcVG}6hhLZq^;wz>wlB6^R? zm#N#(%-QB)OAp58bXg$=WmwMPg&Z}A<6A#D=5|$5PPgZtOR9JnMj;Gx)VV`}8%$>lNwX@2t}!46z;ZbUQS}U0?sJgqK2n93iZQIL!sw|g+Buprp-rhY zocGJ34!K$%HRe)Xj*E|SFRjJESJV?zQTcpYAP~=jD^M_(E@QY_{nP;oJ#FE=l@Dwtt0!(1M?l883d znQ(4?_!4lJd0b|kmzloHy4CR6J^k+YeC~;m{)$4iV_p^8h!SmB3&|o|dnt{UX=>FO zU$<0X4gvRcwWcBHrg5>Lv#Tm8#EwU;{S1HJwTw1`#TnZ|k znC>%S{EV@--ISGUq_Lj31Eh6)DqbFC(+xMbW{5uBqE%z8TS)r> zNz66la>TetF6|jPrD8ZhGaq8as_u2k-kME!KsmUdb=Of`*Gng;y>BRW8RE?y9&326t4{6_K>qo%MJ#C;gT0Xzv~A8X z%O^W1wMY?0f>s*Vy8^`P0|XCtybq0^VQ~5*hGDLbNEzTs4rx0Qs}r;cV6rBr7%KnO zj%Pi5@p=tk;p@38^GLqI1hFs1%p?-G2wSJ=`t|7*+Sf`HvR$lxqE*A(Cq`Xrmm*oJ zXyf`)`*HYU5$SYh4qatviA**tZC@4(hBP~ej8t1B3`{fP4t25I=2u%-P8S5OkQ(t$ z6S}KH{`=73yq3z)v$*0cXJZjjeQcm#_sO<&OKL9WnoEZ3wbSs>6&i?{GH6wk<77pq zd1CRr4NteyIsxYg)hko6y{vp*T|sf7m{S(IGPcnk6Z@XJ82O;>M5E&Li@YL60qu0k zwPa$lK~>u_+W8rU#}cQgwo6Dk4(+hJC>u|CbifXirFj^j__w4BjI!Q@2c2l6qkTBn zeKBxLFnN>!Wxm*c=k`_}8m9ZPvF2o_l@r_9;17W$}E9yZ7YpX#c-laNa(i8-@9N`Q?h8{~i-HAG}S-P++k zO0?FZvvb;$E@`2JJd~&oDgP*+oORx3J$5OlnR63!(h^KFMVo}?bcXk9FEu02mhPsO zAtvsck7M~Sy9?)gm|}IPcuZ3YgN^cO=e;~ zE_B_7_lNQ#l)SH_=as7Iu@fxJsN|^L&223t1=ISNx}io6<5ToE*rH>?x)^0+bF5f9jV4-d*R1T`k&6&Q|C3GYE-2Jczr z(UhJn%%8Dp0((uB(s?^O$~9BTezS}Rgfh;pat!@|o8O7zRb?Jtd&rZW_w=$PJT=j` z%Kf|?+17dHCHz)pTwhm>8zxj$=L|s``N2=>C3p!-UAi0_wC-)!+f1=Cr`JKNN5h9% zWNH#hs_SVh7u_b7i>>)|DWX1k)1@lL7cbR0Z#tNbkR6B@d0vKCNOV)t{J`^v^%d0= zEg1{cOCC?!sBz6QV@BMDhgY2nwDM}g;%F^xDKalEE5s8AG>2%-%k_vI_H3nOXBODZ zxcz{&bNq>9U~g#Px;f70^~y(8W6DY0y}06uSn?p28!CiH)eB=i8z%Amm0ex{ZI05R zmcVYutV>C>SRt2HSxoSwZ=5m(qlE>c8^M}LS)tp5O&CEqAH|?y1_rViWgx@Ewk#TQ zMK}a~Z?Tn1i#4-5MEqRsc7kv`=5POEll%_4$rSdyMjHUTtY9 z-N=f*gr1J4?akPKMO$$(XO4XcH5D|uT~=Lzr>*GP5qo5!$!l5pFmuAsfmPyCsJL{~$i(4@2PU%+858u>UK_aqLD0@;)@Uyc<~qb{5ophW82Lg) z{OEljc(ts92!JDU{d77t&Q;h)VT8i23WF8?{)E&&r0_?D!V~<9iHXUjO*BPf_qyEC zO|==b+hz2m8$HIK(8dc$y}p;iggyxm%+VvZ&UF^`0t#=>9dTT|A+HBGdkyN+oI?X# zAf7kn?e!k}Oz;pQR*Z2?IWJ(U^wGQ^gBHGGQQ;B*Z;*}3%FZ<>$ki_74pst@RLDhI z#UzPaLjFbnoo}m90imJw42JWE9;3#%2@CqJhMBq#;>)!MESY-AonrM27LT#jwl^}R zHbxYmT1wT%VO~6QOE;e;a>GQsZ$!&TTixumG>a)fjOA%rQ+4*-hoFS(%D|&?@E3}Y z=lJ9l5~ad<>n76T&pVE`6KQ`nnpzr-i0DVt)OECL{eY^Y%y+EQqT!FGRUlL)k$be3 zO`AsA2o?PV?K2KMXHX66t7y>@eS${@Iiu`x(r*6)&UqP(bNbeGz2K%yy!=CTQz#1T zNfwhZUh;t+4|N~3Q1?RvKYH-N^)#MJgc=G6j(EKLhT~3XnTG-VEHPn${J`V=;<*dYS45af zv5yQFlz4dvs=V576D7ivSAyE!Gu#_Z9}5&egzkIZP?LtUun^UN+EJSkGccee8I~z9tG;$8HBxV7}Q~J zJW8D2g5cgWi7Uxf>zvQU7MfCWX=qRDf?Q#+*R-@4_hD#i>clN*AsQ~sbI`-=&bp*- zWoaBVl5gzg;$)6xCZ;;PT@#78nyR7;OBUi`QR>&l+b|&QI(NL(%AtrI0Q zqdH}R=A{SOk@t%d3*RwMwGp6{GrByJ?B`q=eub3)? z)I?iurWxzQvJTL`HB>;?sJRFevUGjnbru+U;lX#jE=s=Hf_o3%6OYlGot|EzOO-5e z|4@icne20Qt=Eg>-x$6amLU%pV>(B?p@ISo#Q*f9S^V%B_lOJeoB-{_=un!Rh4-(A z?`#sP@Qky!3{2#`>tdivO;shfGRd1`*Cmgk4w`ED$OZKp&b9yo_x*cf#;INHgY#WW z$>KeG>iLQo@u&w^LcCqTK8&hMk(h`O8wsfIr`d7IQumtf8K=%W>OV#SB2<6jXu}<9 z-o-eX3%+n^wJ)m^F-W1Yv3kZ?jIG4LOvF;{Nkt{1;V|}ej>3?&0&Ofdb>cGe z5?{SA6KUo;$2>)BZ{>E~`xqG)sK+i6F+49cU7VGDiSQ%EZ8V5vj-pIMJ5LeCSV>$k z^sd1GBIOpzLQ`G}p3jp{MDwH9d;^3eVjO9kLgj-o{uD1>w`osPm=;W`CFatV=eBMs zZ#rboqq(axMaNMX(eYXckz&85TXb8UmQw@jmIMSz<3i5wp}BHBB;Z;` zks-8s4ajvj^4@a;S6cy4Szs$3l0}wZie%5ST@8OXP_L+&c8DhCe?hx}4H)4C1pT0ZB+kPJzf{ZaLrdTiZU50J@ zukYz;pWhV!_U5m1KMpP=*G?Mp$@{Op{yWPr5YG{08~MYVSk#6Rk84M+V!5r=dXIgZ z{-ewCvhSpwMbJk4$^X`S3jTfmbN;A>?SFgz1m?f5j8}Y&k7j2j)AkIv`F_`X4KRA7 z5j^^MUMEm*a;2*m-GW-=^c{%ozg4d(8(A?eMeC)Qc9yG}QanlVBqdkw<7nXG`|8EB zmvnEA*Tp*T_{G=`&(vUFuxoA)O}qB|7Z#Rj@Fs7TsV5LIX`K%5{?nR&>mcNO8+t6f z{#lJ&{RZRR|A69OsD{oyVlLC--GA@#cf~m%uSEbI^j{6lT)B=~R)ELi>IyI#EvYE2 z6)*5d2)}+dU4-+h!uV!M|M63ac?x3`uKz^xSV&AyZJhviH&GM|z8I4DtZd^>Ga0s2UdMpHrmsh!jR(yGKW@bSKz1=Y>2b)|A ztcmyvrPvpM$6IL8-x+Hg!lAUN`K|(z=H|@y;0aE_ti+rwPhF{r{Z$Ar8A}H zAGIJl(Q0iK0rd`d`IM`i6t_Q=gg+)srGWpGOSZl28MeIupr`HAl~iQ$^ssV z2h!{@cXN~NVe z+UC@ZcH~L2EzOo{Ylne3C#N0S^s-S*h6R3cVhxz?^x9#Ooa6s0nupzZ^X<`7ix-tp zRK~=Nac^#%Z3L^?15=w9Wa#bXn=;;$tjoY11Lg@ zWL!tHMKcUMTQtMKvqduuJX>Jc-fW5QXtrpEfoF?m7gG?%i_vP zHBzA=ju_`S|K)qT$K)Yb0a?nN=!m7vijG*yyy%FfyaDWprMwyJh~+pj3hapG_zqi6 z=&+@n2pL+IxsO{gPaW^~ULHDLZ@P31?{`}sT3&8?THj{*vuNFX`?F}>Zu_%n-C%pO z@YPbc($#KE0!XuF5kQ(XivZHBSp<+~SOlDA?XDw$G;0^HAX6=382q4XxMF44rMZjs+ZUzEKvt|)M znl+06(yUnokY-o}oMvsLA3&NlivZHBSp<+~%_4v_!y@1`Ys2^e(yUnokY>#yfHZ3s z0i+ogfu%X1+X>I^Eui~|)+REYZHzZto5+N=%f#`EU3_=9lSV ziS5mw=DXTw*U@;gov(Zu?D_MXjL3SaQa?ww1HN#9l6SpC>gmXK%xBscj!^zF>UKe6cmmaQ}`ql?2|9jc=sX)zN$BaXyK7 zlAc6#f{RX&d$aH*Y5D-UB`Xo{cEx*r;4)GP=|ABl(31pBo+albfKCuJd8XcNFZQd^ zBRI5QEybLgn3s`jnIThayrrIyQB~1GC zl3rk*6@F#U!fr9cpbrKSs<(BKE;gfC@TfO_=uP}F%vw2*fvLUc`gdh$p__n(?6v@fdbb1oY zpzoCsjdvE&^JOC6vvblCvn&@Oec4$g<9CeFIhA*IR)#1K@wx`Vqi>Yt&bGoQ`IH*s zu6&d4h(KKU4bxl@@JzmH!JI<=Cerrp^qlOh>^vLMlvcbCDGOh!%B6kNpbIDjh{UPjb$?g;;OqXd-Hl5BN`;jQFV+0XQgr=t8Q%+iphe>+YP4=Q z(T6b==Jl#*X{qW z(7oE3o^Yiftnm0VvOIrQ7-+f=D*X?A*zNVfXa8UJBWFFv%}W0Xg=-bwrEv3RnT|CI zZ&Y}t!dgvUrqL%hdD{Q1Xr2FsrpMvEt?_p-&8Wh=S);E~bfv~;fB&aZPp`l5=c;(y z6s9U1s-@>FMTaRo@|?`?Zxw#1aJRz0DST9+uXx<73HePDNuAF9#1-H9#U{X67?|AP;{?(ab#dLR4X z>-PUw=>6?X&mN_}Q{h&HPqovZhn4<4KI|HO@Ht=q;787Sj7yb%wZamGvlZf2P~Fl6 z1?Ac3%R}@#j(cY2pQ3q-ILSXj=kfAf@JG9ykKywSYp&8iW#HVYk8`I!&Yk+W-B@foX?!E#}uEQS)?DYr39J}(yH};j(_MU zvV1w-j9nC;%cHdqZFByo{O_*f$@#+Z@2&V;e>fc`O`r2WO5=0>$7=kxQ|*#+`geUM z^OwWn_)Sp$c2y=EzsZWv;k$hFJY)Y;wD__A8H&&0vj4f7zNfD)iv9mj*N-_WK3u;! z{%8A$f0^P3nm_;P{IBs5|0@;0hssjU|C_XQarvy$_*|dw)%cw5b&Ajaa=Y<}#^?I~ zxW?ytw?XkaJXZ~9`;6=&-R?I3XRX<)@lB8x;ChG zl*@ztyHe9<`EteYt|G|sU8VSZUHXgvI;GF~$?<$#@i`tGPrcpp=f6H4VE;F2{`>OB z7oYQai1J6TKU)=_^M&KD_a~gbol2kcmr=hie8uN}><4jo&}(paeL=XpX6U;+hv9j+ zujjzD)sN(~&J(gfQOI_@Bk}RKCFUw*n)Svjem{jj|6S@&I3RJw7ZPv$T;c+SOtapJ zW+}f}VT3|jC$6cNYs9T0?Z!az|5tw$&sx0EvH4%U|X*a=aKhJbyIX zv%ZdB43X*UIocCX#Y>v;XGMReaJRx|6b|rV&vvYT-gxP6svqpC31|9x*dn>HpFqBrhn6Gx|1-B5zC(VdYT(;G+cO^kT)!k zNlbro>*`4$ok0m*$hcPq>yQrS17)YH)lyZ ztHR$hJ!zJ|toS;|E?0ECLZ(^%Tb|U{(K1`|yDNMy-;-u}gW~J>*Fve!Sf=QK z3Ylj4H*=-Fj)O`h|I1>Dw<=_s<+BxE$A$&cj&X{jk6b4COtbt2#n-V*mDGQuQewSA zrdd8s@pUw5KdL{AXuLbGQVh;5RrBaIe@nO?PJBX!6RGfYg(n}E{BISG-XLklmM10M zq>yQr&sTgMpL$E$eYV#-E>!#r6^>TeOT!nHKa3x}DgE<>^-6wVkJNiqL-xn6_`dK$ zCGV#pr$-Op7r*F$j0fX+ir(~vneX8GR~Uq`MFAD)zU zjCU$JRUy+X@1giQt~)bXczKt?8x&rputwn>W29b3@fl_B52KY{dvW3@89zq0KN2JP zj5?p`j-oGrna{}aV&w4r(QME9I=-sP=hJ>Nos9P=I$j~uEdQym)YozCxsuOVpy(q5 zB%f)PKdtyW-aAO@GtO3Y%RtFzn&lf6U&qIXNqxq0MF%Nln&rEON_`#EMoK_T zzT`8_@z-gRzp&G|LMVU&qJBNqxroigt{Ze5P6cyyEMaYLohmA&R~y zNAj6w`7FiPvEMAI&-ngKNmnamn&sy!zK+*iEbSPlD*C;PB%f)PuTgv*weGPM>Fh7n z{7`s0K9j)jv(2NAn5i4>DHe$~g-PTy{7cGLa)rqX6BUXWK+hue@p4I_ zFJBv(KmhX8?Fl@6@1f7~YOJcSPCq-hil4s^8+sINN-q~)O0bA@VH|JaN6ohz` z0^g)g%d(_elJUuMBRblE^ZZf#!xKyJ@lIqPKGN)-wF%*o(Q$DxadCF_TH%U(a3;n~ zWI8|G$V+zRE6%Z<0Fl5iH)#eQkPx3H#+LXbZ0Gm*M6uZW-j+PE0^ew^!l(F5HoPAZ z5wp17Ep!s+LZ%(j{H|azJNM_e4w{b`~Ia?RLc*LSgY~DNl_fN)d825vl38A zwM}@|q&DKs-o(Yn#KlWr!^5>`a%EDrwapq84G-<8sUpMd91V?&iaeo&8b^BFDpfuL z?O*tRm0A@Q^p5p&DPXBG3S~p9Q6Hwg{-xMtP~ zscn1*#F9~vjUj(QR$eBCcQtio^kJR?duhcy8tpMHJ}_76M&mo&r4=q3pB=+#VN@ud`(j^xqTbaY;QmE^kk`20ml!JV2(tmg|4|1AC4uW+wMKcVRR zeck!3C#+dU(M}>)%rMFoqW9gX;3dPnvkXu4J&& zA3lk+_Ygxann$AdQxs7AVv2=7G1#~z_IKrGT2m}Jh5{o!JJU?|LdFmKd(xJyG|}MM z(&onW@QvxJToj*a9obIj z2THSjPxZQt(>07uRpp}iOzX&YIzLdF?WuhVRQQiW$Mknv%>sm43ad`4ZL`GF$azoEk0tKq!0#jtZ|p!*6eq@nSyHI{K6A`Z~?_ z(YMO*Vl{kWr6-?h9obIj2THU3n%iY~O&Uh4_c$`2X&wE^b$y*?`yO}8ctmLU+&!Lr zrgdaHogXO8_BY)t!@E_(Q4e_Xnbwi*bbg>T+gGUYsx>@Ky_b{uOzY@RuIuYG+gnt4 z85$1wtIQAPGp(aPxvsC%Y=4OguTaBB*2{P>pJ^Ta$#s35X8S2m%J333T%q2x%Y3GF z^e5N#b(-x5JR{>VP(%B3o_wZtWILT7D9!c*HmUG5T(HHH&$NyMm7UHHlxF*rD!icQ zWw?wp)O(C|n)!_WFKL2lJWM(Vtw`*J-wYUxoLPh97<< zv!<`+qINJ5R&szxCuZts~p%{6J~8KmR)!-Y5;<_`#FUw2o}2^8=;X zev#kFkWFlh20gl9FuyCgYv2tR8=pk8bpf? z_(et9O_BCV_)jjrFTVb5S2!-!;mU_K3)a`x>lX}mFOT1g*tqT93;T4KL*;VQ@ z>UM{e{JS1f?@fi972c-sa)lEVF6u7z8Fjl{B|j-L{v_V~6@*_fj!+z3aD)n)&PnPz zNPf~F4f^lm%d?2!lSV`^9WD*xnL?%9p?o?Kbi(;2g;Tx?AADMuD=D=X7nIl0Hw#;7 zP8=%J=?}k%lzRWKAjg;EV;$ldzgq@-(z@REK~nzmK#2_s%M@-fN&ejmuRl-H*PSbI z!M_y`_F%g&&_G z>92Z8T&(c;>E8Wi|Eo0lml2-&zRHj78UO#5{`D$9*D9RxZ^CJsKch9;S2#lg)H^dk zJzwE4|NnaWTQ#tP5#+%R##@zw#lh^L0YT>mofkAPXi!jO(9oc$pb;bwF+xnC^nY+D z6hpv~-(dn z2WQCkV8I0v=OjuzkuEVfMdA#_pQdnQlH?aFn*Cwa{hQ^(U)_IS;ppLUxIayk@zC*r z;xm4#=yx>StLQ!|evH3Pm;N%ou4u-!ie_A*Xx(1dXT6Rh`{xfk>c4Jxp-LB{FS*WV zn(Y{eEB{!o)68cKR{A%o`o>tIXvWEkX6&tK#_v`6>h`)m>va^_KY!R!|8={URk|2` z$#p){Y{z(?@{i>@&3wj1O8+B#>xX`fPb-@721PTLDw=V!4|`po^*V~|pFixV|GHft zl`ckKa-GjK+cEyk^<4R@(`?7MOX)vimgRG`!V46d6#l5%`JD=HQ&^^u2E1Hq{x;^t*?-A8M`NNM@`u5o_Sjq!x4cZ?q?n(=N$Gj36|Zm;XJUPqDr^M@VvU$^7*G5V70e5Tosaf!+& zmg_Y08S|C?m8zX!OjI=Ed5UIiR^`d)P_%BZ>$6@*k^S?B9ra(g(G46{8HC@i(?w4fBrC3>Aiic)L*NxR^b$d@82Tj6BN$8L(=2^ zEb-Xg5;rKUQh1@lF$()AJbstd|3u-N3VSH5x>L$~DhyM2NQLVQ|Dojm@HwUD3s(f_ zj~>otn!mc7!(+ZLTIaKVpg2>-WpQ}t|8&U-9oyD^a$x0bXrhE(CNXwg3k!<9eif+S;2jR z&kpVz+%LF)mvce}gq|CEUMExNz|cXR28Rp@jSLwYGAuMIWO(R^;PXR9hDHa+gpTSI z8ypuJ-wE&j3^T%l!h$=8goTE63JVMC9M&bQYnSlO-MVz|(xXeyu+zdK!cOnptMeJ1 zdv`vw^I4tybUwRt-_HFy_wPC&{M_*K!Uu*A>N+Gmvg^>U!@{Gw4i6vE`TVXU!=pRL zgpcYR7akv05mp&i6;>Tq6Lxu6ZJ0f%BB(N`DyTZBCg}2@+8}#3@zis7@n6paqceWp zyZ7nS9neQfyUQQz_8HlSek1#g#1Bk|gC&9D>4rQ88Uu|)90LVS=bk^3yADqozL#uV zBdo~>d43HzbjTk)7pdE{MW1F2H#%eGp}p9apMl8w8smc^5bg-zK&*8z-Ckt-5k}e> z4MwNH`-$$4PPejRe|2o77#Kqj&mSF_um5{mzT)qU zQGof@ZhzQcXF%;c@f9BP+vnT=1KR!i#nQ9w{qzUi|5H)x%3s=X3!qy!gTJ%m#`W5L zu$;!@c=1|o4ZpCM1#Ms_!x%yi-?9;|JCNL2%3+;&sP5YE&N!`e@L+a5aqjNgvLjia z(?SN17#KRZPekxwI`0z^GWcwqpN;eL!Dpm%a-{3-Cpx16?dp)+jeVSRe(3nG75D_HJat8DZY+V_elFr3ZHqylV7~OifChy#BK_i{#eO(8B%_yLZ*M|Ecu%imTNT2V-#PNmi_GR9|%QD`<7+PTHJkVaX1w1 zaJ;x|*^7LY2_50L!?6rM@)Q5?hai_N6M;5396-K4i3PFvF|rII@oP}%luPwiSut1X zF*K-?0;T_%!numytWXE2iKv6G(&9<$`tI}y?Pt<{v2pRE$BZ2}e!|4Wq~sK{tTb*O zXyzj{bCa8@IQ1vj_5Zi&qTrn1qTuA<`-ArczuW4#AAHv_BAAY|gTwKkxM4vot2OQq zo{KA(X~Hu+C<9b`?Jt>?mDcr+)%@!k$j?iDHn{V$3i-RulA9Hr7@QS6Hu&n`M}yb5 zI<5xabqolmqg(LFpaFt=%3#?7oXs|-J89xacu)qY_S#>ZmtpR5``!HO63EXzt#0QH zd|vMMy^5;BDkIj%N7{di~M1l zFakW+VSs9{{l&R6%w1OfnSX&~4}S)ev!hk|odR`2dkyKw@BJ*1r14FNJc$@4vFUoL zIX&q#!DzViZYlWua3^u{`szsn4|dC?eU`>I3)96^PsBs}zahG*HtTE}@=sqH@z0BZ z4X>`d`eq8`rRra=ry=bPmn=3HBao86Jo8+04|wpW(7~_W0D=3jK@!K7DO62&i=tZ; z-830(Ds?Jp&_m~O+5{Q<#&Oav;QtLCnhg#Wj^d(g@sJyu9HTqdG>q-A-440|*uZ>a z@AGF=9!Q8DSC}_)$ljEqaeupP{1ZX%-8pW)`44Abd*hyQg)?l~aqkC>pLlN6gC{e_ zjejlj*KSjq7mUAm)}moUD;^ksU3A`4qh5P={K3VKt@(XIw+Xl2ctg^fki-eKG10d# zPpO}9+R|g29=hYP36_lCSN?HL^MpC)ZCUi~&fXJ8|K*W)2OqIaY$*Fv>3b6!CN}N( z{?v^0jT6(JdHB?&7kxXi?_BG)BOA_3h?xBAxYc`Y3BBJ~zjOMI6$u|+_0i#dzivzT z%Po)mdB?1OCS3S*uj$W3M@{nv z?&PG$li&XPCAIOB@7kZ5dbsEO$y@*Q!Cg$9qG+=@xVP)P$R2zqnE<7wZ94kuhN-`l9a!<~v4c~ilh677i*fy?op|(@w=;{Z)2`^fKJD|R%crdt zSJU67$#Q8?IApq{XG@%ZtHc#AOT6ruK>F^If#1Gf#R8YVf0w}0H{T>Q6*L7W0a5eC z$NSc<>Q@PR`j_{{t_3!pyL0P%z%fG)FX*0ZG&GN2@^WIb(e%L|W{p{xZ0yRKU-{Bs zlZ`32%{`d^dGhp|o?SfP$um=|KY#Jw!G1GRR=%4V_Et+n%8?5`e=Rur*_4fIK3tN# z_`8(bf}=)`xY1-D8xp_i&=a}l;N_rv;(Fk zZ~fM*EUka}tmMso?n`^>fwM-uv-j<^0T!w}nuU%u?9db^|-BYLS`=Ec{==6%l6t+_>*=e%&%UC^oWK9z z_+{<2jQ##C>lLHx9-n;P6_2A0l0TU~`Mhf|p9qW3~@rMXH z=AA*uu(MX+DDPV?(%9`>I({(G@#bJUswp_ z%X@5iE^N~IBX&m2Id~xS;?+xU_}eY#y!y-ZzCX@?`oZxrw-tO7^x3OlY~3;`uJFdi z{VN{5;i`%2XAXMJ_T$H|eOO;VC%5-^=d5^VrM>*mLxw!IV$r^rUyOcY|FahqeRS94 zAC?z=a(v$lGlo69Wz|IU6X!nl*5MP$Ge$nM_nP<-&DEuPo{E<<^G^?|AO23(oza^CbgT-tyDR+btW{jf;P5 z(dLUk&)m6f)g51b`1po|qgM`SJne%yUB`YrWaAk7S#OdPRj=#9-+!=X3jV#hNB>HYjXTxJ%)2iPP_u zXnk4YkV68wb2n|>Cg`XIKMDLT_zuG9o07K>a@RiM>*cqBY&c~4>RDh@+@l2tfT1t$ z?tcsLm6)w-pMurGgazF`b@l5-kH7N$;wOxTrF}LHeg6Za@$sto#n=DQ*f=YE+F50f z8V~%qXK()}A)SW3`qxc;UrT;$21tahw% zG&vr0{KfH@;|a%8j*X5@j^`cQ94|RuaqM!u;dsmOw&PvLhmMaOpE(XVzH)r)_|ehg z_^0EjQcDT6Kh?)jkAsZ#<|8IBhrX6MjE4xcw?L~(U@#ZH7$!J z{NaVnXRq&KdnBY=*KTL#UUF*Cqwk;DxA(WdM^>l2z3;%%-xiImiVROl|K+0hCarwW zcIc<%z2C(=GqvB>&wZKnKu`N;2UYeNrVx2N5JtzKaCuITQhtN!`3 z{i?&o=k4A9Qs?Y%x?VGO^UDhl?D=*0sO8suHNCvw!42R2!CTnGn;YVOd>%%}+OF~# z+=GsF5%P%aO~>_p=yFeL0b>hf7KdE+i`Qfb(pY!~o72m1$_sjT-eFwgcJD=O( zx9(3aiivk5aC`jnANL>s+o^3`xn17)=%1F9ZHvj^_BkT_$c&)zYfj^Kdeu$;yziyu z%Wd3VZ>io8_Ul8XQQU6tH^-!G`s1|U-caqg<^73gK2(0|(Nn4&@1MEiqMj-CXSb>L zJTCT*V=KbT;<#O(a^;qB=l9rg@`P&NGy9i^E^LgS!tH#-Q!nkXte*Dpv#Pz%9Z);^ zV7apY_p0*FL;<&)eVqy1!SXiXk-aXd&vV^>$TW-7Q4_SAP{b8H& zVUMR?zhigg^Ly`KaQkDn1@%ii|9D#Qwu{2LJ+yV>@^?>vKY8Z#=>v|x7PlAcAPFZ2pd-?IJW&n=VoKk>ni7eme)bKC0Aru=;E?R`&Kn)gS&X$!hxThv6yxNQ-) zZSHkLzk7zwJ05b!^t&E7nEh$d8_)l8eL={!mTy+ptvryrqAAS%xTc5uacyt+qqx8O zkuu2r_%h0M%p2u?3>)h@zM14Yb|<+Xdak?Z-}0?nbLW)qdG)rQ53g_Pdtk5i#$TeQ z^eFAqz5bf(>lg0M*}FP^Z&c=A4qh_ll}jewc;CtkE@+r`X2$N-cbRSo&Y8Qj@~y<9 z2R0sZl&bdW%>DPzZb_Z-!lys|Wz5uTFMKR7zeoDtuJ|VpR^ShC~MwbRDm zQTw+Kiq1Om`0?UHH-55r)knk5J7djdPxkvY;b74hpU0HFz5j)KlNKL*IAu?Ll?`M498NuQPhq@CDVvfL;X>tnrXEk1T>KozmJ7aaV zg~g>Nd={*-oIXNUVk#`Es;;dptf*KLBc^mb^or`|&BGVzsuz~l&a0?iG|4otzP7Fm zoO!i{m8Eu5Rdt=oUWT`LNLzfXY+_6tzDyMzHz6i&0wL4#+fs_AfGm}T^Gku&WPCra zy1owICNnbVAAYv#`r2Zg!G3&9+<525q~u4eT)fzrxL6X}c`^#N;o-TI#3K5rnte%S zQFTRmv8lS&REE#&*~O>UO6n_XO!KNMkRZGKt{#QSKj+6q@Yyt^(KMLeHsWNqeS&Y_ zP^uD~bKZ!VHQ7aiAG=t6a&B?BO0}s9!9WMPGTo+mJ z&?GzxeU&lS$TEV!J6p-sYg(LEBTdfJ)+f&SEmwW@tdDHcdfrRw@&8lH_)Ov{j9lCG zYw*-=e|)5U^E53U%QV`-;RG1JhP%%?<(PZ+DaZ7FryQnpPC1No;Y@IY;D(%XG(v8L zJQnf@$Xf=Sax|X@HxO>{DMtR)9cF3)eM?l`v7c$5 zBjk;cn;>uQ16|0QAa8(tF646|p9^`*nXrMp5%L-g**cC zW~8ARX=p|oY9Nn=JOc6-#Bm?e&;)rConM& z4*z?>=Hy974eYnWJ_5FLL*Xav4cJ<{Ko0vB*iY{cKVjbt``8Hh3HyDppPCNaEa<{D zXTpCt1FkUx;lXW~0b96z7r<}077J|QBH)@}I}Yw)*p7pH6?QY>zJlFCxG=aoVLKG= zIoPJcy$8E_a7SQwJ={pRdto~gZYyjv;68?31>6bP-2`_I+~csF47UfibKrh}-IZ{I z;8wzR5Zu$SO@ezHwncEi!tPqQUT|w+8xOYwwmEQLz^)eVY`7J$Jsa*3*iL}k1>1bM zZ(z3=t_$4Vu#JM-4BK?L4`5dY*Awn)*!G0G54JII+hCgo_bKeE;BbrKxCQQ9xb?7| z3bz+_m%@d@)xkCtZWU~Yz-@$W3fz9!mcSi?-Ez3zaO+?@25u+pa^a4ropM|T+vBji z0j?k1W3WwtdmXkH!F>n2rEuYJt6@6=ZVPNLfNO#MT-dk3t^qCrt_ilWaNA*Pg=>ag z4V(ej2wM}}2G~xAYn}pqGk9=~DX@oYOa{U=CIR6Z6M=Az(}8de(-7WNgbVi`?5~9F z3D{M@{Q$cPxF29w0rvy!D&T&AT?O0^u$=?92ey;p_Q1Xt_P@fm2<{8m7QuZ1+akCx zU|R(D1#FApzJP5G+z!~r!|i~58SKA-Z9d!wu+4}20JiyXAHX&r?gQB7!+ikTbhyp1 zje^?@`%7W}DQvUg_QEy`ZZB-J;P%2c3vMrLv*7l^b}HO@*q#fw9`?Dg-w)dqxSg;~ zf!hh&6u6zRO@Z49+Z4E+upI-p4z|7F*1`S)*uM_j1h_4*O@P}1+XT2RuuXv50^0<* zEwCK{w;HzLaI0ZI9roK{8wgg!0k*Ml8(gC~0NWPWHkx2N5Pl2>4gn4Y4g(GcjsT7XMgvCy zV}bF&(ZI35aqt87v4e09``Abz>|>*Vu#Y_-2>aL=Anaq~fUu7p1B89-c$9q!a311R z2EWSD&MknegsX~c@5-qA&-ST z7V=ogw-Hxv-f5UKV(;Z-#wr4*Z1uKG>UPLJs@wu#bT4+>7BS>2N>6{!-Zg1iP!@dcxfY+ZecQu+4(| z6n0f`r(kyr+_`Y;VLKJ>AnbEte-L(caG`LkU^@hEBWzRP_QSRW?hx#j!}W$+2iq}l zAHn_t*nb4O%ixZ~?gqGiaF4+@0q%9!UIh0Y?3TiX!>xwx2)KQ)pAP$du$>Fn0=ovd z2)HKL#=>oftre~rb~SJYTqA5vaNBQ&{vF`K)vSX3?LfGel|Z1KW>bn*p~6wi$4HV4DHA2euh-dtjRZw+FV9;U0(WIdG4|J_q)1!!`+S z2W*qzcEC0XZU=0W;C8?^32p~$iN+&b6}fm;XL-f+ude+ahA;YPszG1&HlTMgTOaI0b4 z4{kMV`@yY-Z9llxunmV>3j6P1yA;j@`zF{%z%{})0? z*f+zr1}*~jjj%P~8enU{HNe(@Yk;i**8p1st^u|!u$>FH54O}sS}(_WEwBz)4_pLX z3|tDl0(cehYG4EK8sK%n<-qF^F6{Tg-f9QJ-ntM7d+QP)?5$Si0*0`9dC-PSZo?Ng}~@)lZ+C{5L;xrrjpJ) z!I=lYx?0AKA>{;@9i5V`5R`yodpf22%&w^7|7=hLL9%GZjc?c~wn)T>(uxm@p5+=M zF~0su^JgNlg5!}iBNsVMkzWKI`b1x;-CkX5M>%0?C(<5cs1h#I!F#l`it zwWTE^F++tpuo4r0AJig>u%djatfkfS)a;h2tgx!2f~MpO5v`IKS@g){l2VbAS-B}0 z8790(w;qwE9GzEPUxnPrsjEmXtf{N7Ek()6!m6(-7FU2%3ngu;sw=6eh=D`?i7CWc zg%t}-_U{Y7Cnt&1O!UNodKybqGw#vk6SKnhj%ib-k&w-d<;_D6d*zT2x+FhO?sjszv3v zVo;On?YJVGvxW0i`U@+{>z1G%)szs({Mwl&G&j_yIWxO;BDFBQM=HTY*Q-ZbsSXyE zQkkKel!)4c=0mY$gNmzBHY{#om}a4JVP@HsZ#9h@6J1nZXEK+d^+iNys`fEHHg+^k zNmrFF!gY)J^LjLBMWrGfluFw_XZ=d9t}Ttq%^Yq@sjqgWA1zGVRa9OERO>2AsYyp? zVXH%1hV_8?CYvQQ#bjPwS6W34x!p9{6lJs7%%g|9*FR^K^%_xU{M@daF@Z(OY1(Fl zTw3jmn2N2_ygl(lt6D`D0WK@C@n;@hQ7Fb-V$6JXe*1V(eTk# zg73xFqUEBdS2O{_GtbLMHAgZT)aE75%=f61{{jC;no{G&C5y=9q~s)KrFf*wBXq16 z{rl4wKhl(xX&GtCxCpsA(v+TI9%;(Sm5qIBW@1~hX=+^dYxe-wKqR}tJ z1z(Pl6g5QDJIJ0v^h`7$bMMfo*wIg7q)bqY4#F*%JX9_WKFX`ytk9N~qr0rd_r)ug z2oc&3^f4G&JFBx#58eEx(~h>!xD1h1l%BR*>12F;z0@Sfv6QvN)fjFS*CF1urPL9l zsYmX_#+Xz=mR8NjKv{O2WrejRi!g$tsyYgZ&bDz|NL?&ifm)36xIaR3L4B1;2ag(K&>}Kr3Z~#Z=lkXjtCPtHZERx zVOVo#WwhH+ypq)RoMd>N-!RC>XZ%L?hFh zujEOyT=JP1&9U7~il)*j7=r+;7~(nUnORvDGL+#L%#?W`4k7 zoSl_wNizxxELpkcjDieHk|ig(AjO=NM^P|>`iD#!)7>!sfCa;SD-Jmta2|W>A;%-Y zxj-v0rSXtsJFpQLfhQXxRv&VF0BpSXkmKy0*f{y-A;(-`)80dlCZO@*A;$_lW>NFi zA;&Rb$&ZH|)3Nlw5m*LX9(35T0l2E?VaG9GXs^SL38#a9#$m@|U^B1@IHvz$$2Y*x z0g(5?!_C0Cz+B)8;Fy7ju?7ZyB;;ox{PPbx8i5-p9(F|ahCJc0BOkaN*Z?eGnu7-t&B{=~x$E3gIF0Ni;2?D4R0$xO)c5Xf?1EO3ARVaMIT+)EBSx?n*% zv?GJ0O$vi9^n4Rpbs4L_+f|XT*Ui1bcdfbojyUk545Rm; zBaSBEMqmqJ)Dg#o^9|$B$Rmz2!Wig{L^z|5IP!t(#vO4q5KaL<8klm#kq+EB6ZXK| z*+(2!v_Xe1KH_);*n7?q$3EaHV3$$Q2bzF8f$6|imm)sEjlj*o{lI2m@4_RFs940i z_=uwhxDI$Xa3^p(u&xB*0S}hKpE!g!4{~7d`H%xwl_7rd@b@yvfprUxI93o1+yFcX z{DA1?2!A}v<95VvBI@&<& zag6ZMBaYa~;6H}^BYYhB3p@ne2dsMn@tOjE)+3*RV>Tl{312?q_+~27`6leAp}xP5 zbORecMZQnR_4qmb0j@d#e+a)vekI~M{sH*~OgVJKu?sE6m}5sAi_!At0-J!VfV+S@ zfi1wg-w-ZZjpfIYZeZx|h(GY)sUuipLjDII#abcsLytP>vEtsHk2=cGil%fq>bM)Y zzw1%QF5n?x3vfvIQODV6W$J*_fuX~pp8@+^$TPv834Rv%vyVDzfGG>%FIv8R&p@7s ze&aRBXQ3QEIO=Eso&-Ju?ER0Uj%MJPkB>T{@?rnUQO8_h-9gBKDc>D+d;`n{8nY3v zpN={v05_gM{DG@_9COrM1pc|lu$F;xIPaKa7jWm`V~&VRkzU{g;Qq*Cj=4k+J?3Zv zj)^+v_y(Ap{{OM}J@8RgSN`+vn@s)^f<#4uI!IK|gan9yHR^;+2!RL@0tAgFAqgZ9 zLQE$7(WucxM4JF=RBW+gn<}+fX`5Q?(w3H#(l#hUU^(4L<|e?9d43i?5v??FFk=Wn1N^z;e%@m|FL zcjON=+c8k#-H^kH6mWpS^q}R%w&XvCXYGm zKS6ZdS$~-i`mZ|c-vQb;@htXSL9aXOpW6if4QKuJpvf5s2lZw`FQ{|YS$_-;8ui?K z)}H~|c^mYDcITY+?*{G5JL`WJG`Zlc-?IVsE`%P?%tdGYyFiPUob}^~xufzf=-q_) zC9nsy@9wkMBS!gDp7kF9&8$A_KLc91=B$7F{gA7JUeKO;*xd}hKG+ND1w8|r@eiY`pe$?S`?1#Oe8KApB%Rmok3XMz^}3U-2agYE$B1KkUH z>pu?o`#_z)9`GmcM!eq)_>X=OdO(kZc7dJ&?FLPF74_x>_@J4fXF!WUlfDH0pW&}P z@GEF0sP_!~0GfPuz`q}~7PKF<&5!)OhV&fg{c}N+K}$eWKLEAvRpgTZ|K=*)F zf*t@(G0ywn1QtEjsfifO$F@(^?)7+Edo6aS`FGJ&ih+HPeq;gC%ukw zf8=@pmaih6F-W%?@j!Qgo&wzi>bdT`f6_kq;YQGJ!j7Et{!{xw?>O(@_Z|3Y(Ru$- z&>qkepvjA2&jF;j1a^Y9EknHT!j9!g7qqhJyni>*t;i2(=F5l&TK@*(eGm2ZE#w2# z(SP2b0eUnR&kjMiXX1GlXcC^MZv@T!6rM|g_Tc%}3D7<~_bNUJzv4OAM$k+=C)*C{ z1>FZ)2HFqWiRY>tzmN3sJhmS+3G$XwN;$BHQW@W?b2;KM@et0e-w2R6J8VWvl7norXeaBpF2bi3K%+#0pbW&Y#}sblt$*}bGEdb6;C zq#d=;Q&#Pf@!hzmE1-w%5M6_sA@i^Yaaw9TGG1AnB*FN1D4+GqVt!Yahjg`K$Z}5_ zLB3ZESsu!#ilK^7mY8DD_toYCRWg(%S!sf$qoia?D4oATS~5em`0hj*^*4GXt{)+Z z%BPvsDi-0bQ|le~BqfOT8m5zfHaUBJDvZ;nM|$={PvuSzMRz3F{Y1@PthE{bttg!$Y9CG~Z2F>y)HrIPldgc> zVs(eP)wwN7JTHBVdc9dFj+CSLUc^7X$0Kobc)b>Pw>sNR@zKF-*(RLSCJH2w@+tUk zL;T7wtN107YfHbZ-FbKK!b4v0_dxCd%N0f|!GN8sY}rlLW>=QWY3NCQL#5XnVQ+b> zt6k;zDdjY2w~OqSemD@|k_9RFc%zX2Zzz4^h>0s;*J9Prl3Xq1oclZ!Oxp$W3dk*0 za$aydA(zQ=$HL3QUO)atUmq)>=NR-P@At@bP7a|*bm(e_xl*5kRExO>@{cy-JfPBP z4sSmT$ekUiKxU3f$#CB&{VCa5vf~YBcS7$@=xRBn^d=>Ofh*uIyC2S|zT47m>vzop znJ9M(AzkuHZKh`i`@HaOT$WoV>RxA`N7~aYzioDTsd0!>q?kh`O66V&`Q)E_q+~?D zu#u#cTs!0{S?*YPy)@?-)bvPSH{`s(@K7|zfJTn$*D;d&rH8~E$KD%X~_|1p2y^oacKm1+;kIM&$f z`~re6D0Iy*gdl=BBtDs#3w8aghoEC;yd;CzNgZ;qPjb2e4@%44mbU6lvd*7jS)vl)oO5st?#2<@^qcUwJ{B zf9@H!qVvL4i%%EQ>Hd?4praX?qbo9D7|EqY33OZ?$nq=^n&S) z_)EO5#(_4ZcYMG@$;df8(a7}Xf_q5LBfBB*J?|kgiHSzaQv+%@os&VhU67m?pVNrn z#_AphgIT@}ePfnly)joX^yE|gUoFn3pomp%LXeZEn40^l9 zDZTs2r?>+4&9m7Tr5z;28e6_YhELO_brz+QiBAdYR^8FkU6~{pNLsnlPwdzD5Em*arDN#P6BN>0S{Qe~~TUY1(pG zq0RP9+R1?$5(k@v#AxGSuAoinb*+QVd-Os5+B})BX@gLC0xPG`Ql6nrsZbY3I-JU} z1YPp>TU0q@gqLGptBV&F-(y8InLy{SxDuApKgz zPq{*A~~1lbzAaJ3ayY}Z9G@6y(X2effo?e$K%P0ov(FTvj8 zUCJMY%n$hULDe7Bg5L!>M~RZ#3qR5oki))-oN@p3V78od%k3M<$qVP)#f)6q;UN)J zVHqdDz&aSZld&f6zFVc2N+TYwKzitpx0zyPdvu3uYm|7e7qi~C6u7$-N;a5o4i?dyP$8M$1G*pbzH%i`YfHKU zcGlYZx%;*C={{YdRbF(!ow^uHbpd2=B|dG*$oEQ>kAd)f*w=Zj+RjpFQ>R35Q936n zom!Pn^HAwb)u%IesLUV@T8|Z7iu4*(I#fn<1?Xw5I8^`JpZqOn(MX{y|;9 zL%IOHW16&4^cFAC#%a`s+^!8N(uJ)4I|QuMrJ-$l+9j9xPn|9-@zKZhj>WjMQ}sKk zL-af5=vbX1^9nV69i-ulx3!VR=*P>?>LOiWz@~ZM&T&`^epTgXXZX6 zF7MGLpKlAG{&^=p3FEQu{5p@@*gK^wFmBJMb*IR0joTWtE!Mo$e9QZ`_n<=g_O<8( zGQi6nXPjD~$~d1AZ_NwDS!9nR{`giNLUNV5Wf7`jM*%*2VBhKe><=;ySJ1w|dTIq{ zjpm_&_0$~!ri$kU8GyddZz+94&bv(Q$Rg*h-cLZ!L8T`P;~!lCyUcB-T|}%Id(wPtU!pl zh-Q)jSSkVb`zh99JD`~&Eh?x!B)F0OyPEWE+n67bE360ItjUMmdg@g;0pL-ZmTK0?NL}`ql|k+{lVGjKF!Ud z!n#rNq$hJC{Q9A?t2SIuen*I&2k{sX&AY>FvTl?fvb!02DnHWXkL@P8F37d%AT1z#qA-<|-@e%Vf0|8&FNCzKeUT zfYsJbK5nD}8mEe2bdO`U#I)~4S3vKacC(=)DsQVxY{1S*N7PnVm9^eoaOABy);$H} z1IYa2tItsSBI@0Im2MW&=!M*AmTL}AcOLEA+}A!y+}GPaDX*7yt57nuQ6u+YyojH0 z4eFc8>4cZ-vcPlf$7E~e0Y2~?n=*-u>?nes&M2j4zvSBTUr6P!4Sh(IxEo_Wwhgzr z>a0>x^}ZAFi(D!`>7y&)zub0nCHrMRrNeSm{&d;piXqqS#GVJ_dRVTP4~+%n#1h*^ zkz3mlnY_jJck(lT9)MY;g(6kofo z{`ZI>PU-Be&;@9hUFPN58TQ31(`H`l;2~yp-_hko{8k(C&)N{ZwiDVo+DWQdppB#5 zMbvJhU%Z?D9x=2yyfNf9>S+DDt` zqkG#&iyf?idiKE5M=TzUYi+%RidqE|%AGTq0yTRl@qJgYv3Fb7?o zS$hE?lA^xX+8<+n`)HNrjg;hkO5WOz3W-=uA=WNJNQl+ILzsEJw#6ZhH^~@Gwog%h zKOp3=5*$~&avt%DeS&QoA~1mYAYO#{g;Q1hQ{nOFsVsPtbpQ%yTwIg;0lM>arPU2`dUBy3|95KEMWbIeZ| za*{kpMf9rKCq$tP^O#&U3&A`MX%?m7obN1UM}L$wBWQ?x=hvMa_cRSj6Q;DxC;4NL?_+tY4|E0cMeCH+@P%Sa z|0QG~KXaA-2*2aG6`gVy5Au?Y<9R{7hmUd(<8*R#wv zO?^c>8wrd65iQF6g}r%%OjFHvtv>A_svY1iK88>YZjhO^HGo8BMn6f`ZjGq|qw+dE z6@I=)`MEaS&qX#rzo;*-Ea=IahW@Tv>1huCeF*pS<_qdfexT89Qyt=Q#BWA?XM>7g z629MR>nF8OBlKq;%$eHK7S;$H;Z^YsUG+4hwCe8G#R>YmayrI?O)8(;h2jU=;aqwi zY!(UoV_&ZwD0$ibq36{7N>59;93Mk3rt|ppqXL!oT92E)UvGdh>f)hlm=T zHt{W8i0RO((=Nx9Us6DN(E0l|t9(ZETVgA9_wx5MCn1;gn37B4^TmO3u+=y5X`P*V zf6Ui*A)-pBP5gr{WC(wh>*6SX>;dV!5&H<+R6d6~_iz3{>vjF(JbfVw?c+pi+8NQ} z)P6_X4D?4&D|^SOYy`(C-ru5f-UGQzmZScMu0Z(}%VL)MhJBFpu^hDsfSdRQgS3oXLjdx4KcPK?;$N*S`INq5UH#?R65%Uh)IZNTwm7P$>=G71&?I62% zLT}|WN^i5|+U%Q)@q0yZ{HE|;$RB6~&b z&ui+PEq!g5X|B<>BJ%Sd=b$q}Ce(u$mEHnD zxv}|qzP0ZsYj^mrpBziVndS@9i{Wgkm&(B){e~#s;o%BJzyGzNBld0PBvmm%{J^;BsmWya7#j2fM6d0HR@;->kdHSsxlgy9hZ|}`bDzzVsyoEHUeN#FhH?6! z>QDFIpaKH@q-`E*p3x46;t8ATkj1Qi`mH_fWKPts^UOcRXcIcC4LPU{Iid?OUvz1M z^k>e^DpMQlhg#>6$7vj+pImkQhbo6X;p1xXcdPZXs|X*>izs2qBz1C}F386C_eZ6# z9b+P0fpRt1%5xs_w=UqfVZ3aH{P902`7E5pp(`LC@?36$wzm@R=^dc;O~|Q&(AuMa zF84*f4bN+B*rY84{o$UAANtC5>1zkFiytg6ejvN}82aP5+95`pL-V)V@~YIiOFP0{ zd<>!8hr0Nz{1qRHi9Nc!>!%&o${}+0_VFV|^num_+5Uq~ZLPfc!oT=dWZti>`66OO zK8=3gnTPeus2th0W^pQTNkMz1WrI}jGwIkqKoignge#w*XS=8i&#A)f^V&#y{3+Gl7-{LV%dKVNcf@$YGMVk7ksws0NYkozZ=bA`{d z#N1XV4tJ}gUFK^j9=VZ0`+X-7?{t&WKMv(jSHM2|KHcwhE>O=IGv{N!a)Z*-tJDPb z@cBm36|zkz&)3!>-f@msJH&pxIbK_@rJuW@r|2P0Km7UfJhg9WzU{O+X6tONv@{vt zrx8EpQ58Rd?I*t`U{ajPeCs_60soYeUh~(cng=VLh*OD=7xB6uSNiBT=X3?)iDFwr zI;72*_6(U)Cx73t2kCS^$LS=gfM7bMwsfMj2iDEcY1caX{RN?IEMmE?s+e)wrbm{K zGco_a9c#heDnD7_?L}1B^7D>1KRAo28H3Ap0dnPHRSx^8t<9zOtenvP=te)CdP!%O z_<}aX+R}}jg8f(SuQrqF;GawU2i0 z2LkOqNB$0*x((XVw~q13ezp(syx&yuN}OT+gnd5OsU1?~bEI*1V1MA-O3xts=u$C_ zTl7}@9+o>9KCYPW8#DmX_*e_M?gL6+Lb%*gdd?tUF!mc&J?U%=J-<*~8o%~XI^R|C zY5qc2z#r=ONk6c6&r9t$(rL!90)?ari_txH8e z`U&kens{2P?O${u=6HR5)+c1|Peb?k>_1Wq4bl2dUk1#8L>+jqBTGppj|d<>(t*P zKwEFu=yI;zx6}q$hqogpr`kijT2`3J5N+vei%c7E@v5{jGXUqwni^zgpCd)<44{>&bE}9=! zLaslOxIb0eTiY{ONE^C3gwrf@>>MC zlwrsOse;5UjM71|mDGt`f6qQ&f9djG+)$Pie8 zfZ44v?XGRnumoV90`&)b-!8K!v|Iw|9>+Fw!<`=F=?d&p!5JM zv9Jn4`dNn!y=q73r-MOAi|p({dd_Vsy;>(2xB}&JR|nPO7x6k2ibtu*|Lj5W1`yBp z^u@(%L%hr?l+$x6UbB-@v!^HP^Ka2^th%txN$<^*iBlN8GA{tk5g~$THo-8V-r6GT z(>7;FkgAXSVMpaoWyi5_J5>MhReS$%67t@ch9_T%JdIn4dECoNJ|Vmu<@*%O6j~8; zIiecLGqnM@${r@(u_GF8WgkuD(1vs}zr=Q#b8-!E5{fL+R`o+cbA>L`k zJN;D^Zy+K)`JC&`kl){__Y2Dwg=b(nAz{V#P1am3AbV?9A>B8IwD<18^4W!Wec!ye zc$Cj$h}Zq?zc`nHxB~6be88k;NOH}P>pL{G9EEm4?(~n8 zT*N%dJS_h&LLDhJm&p6O={`U3Maj!`*h%O~d0Xk(A71X}H37SlYtX)bIxWMIYMgH5D)zY|9$&hx{28^Teu?>2BzfyW4{8cQ+uRoi%ai|;eoxdKQd?oZB zhkWBB6NKGb_lGo4~U}Gj;!HPj&}vCQBLoxbRyn!wH)2U>w@|U z`NkE>cQfRj|28~%Ea4n`AfNmPB|k3Q-&n_(V-2g1ud;5;n*+RM7B4sA2L3d#)?b5u zgN~%H>_S zP$qBqhB60Df6-vc^V8qZ=z~g%rorMb9E{12^+T2N>9A1dpvkLqx?Px5ct23(l8SN) zDHlBV!tc7DxBp@?-wqzI1B{o5d>ZIRnYgSy^;$kw5rTj=NvmIw}T}T zDEp9vqhu}G-5HfmZ+Lye?}{iT{9`4#!c=;KzgIHYqQoaM;p`~haO)n>j~diSZaIT$^QdxkZ0i9{0Z$w zs{Q$k`kh(rI*b?b%8rtu{M@O{kKT?aZ2m-^Q}8*4^qeDAdgGK^gZ+MvdiD4o)JtbQ z&;H)kgZIe!IIz|KRy`eNx&3 zH2R{oUMLf3x3)IumFYvY2X*vOJ`UOD`akCb{Zpa8YIQT?wM|vrt80(q+qw|^!!lja z|G5$>|DVn&PpKk@S?x1O{YjAj&7~uMx7EEK?{UadSzb%k>S{;wqK+Z8?^#CwwDj=(2Tn^~EB^3dV*hBGiYhe|*KALKkb zIh(!#$kprQ%9Xw@q?@t{^EQ?{=~M;==0^p#`Qtimk2lm2o?qxn%+&w$CHs#yq(McP z*Y?8B&Jr%S@ZS^K&&S;vuS-&Y*7FX1o!h0&w)nL!A^kzD*}5p3bOHKvXuQsj>=v~F z`m-{>*Ck)83lKlnhP*A6OLMc>Y8xSJQQ96S?(c1nE9td79ujVu9m32-obUFE`R#F) zy+!SDUPP}MEX_fgO}!0>{ygG{_vx#TzFzMwP`>u98Gle!c`k#Q=7oEBGZ4vv~%#eVGbS-6As$}_`dr4*6v`+MXJ98MR02N=k&M~$bPAM4M6npy14ePQwP6401!Y$j_9N&Dv@?4< zU!*Mr@x0DG`j>3Ubh7a6d>HNg^D6zF;q?~pXQO!|mX-29P^p~K<8a08LBHfh{L@`3 ze)Hv0ZP5OZ-|;7EtBN^I+lLMD-W&bwUi*70Gg@!MWqKR5$Ci16nQMS;TB+^xt&TFH zDQnv}JxCn%cgEV4@x{luc&miHt%mGuRp{*1F4Km1JLSb2X2xpE(Ha{fe9s&Gk;SM# zd8&`1{T;ISna(rfs5V5eO*?ZIPinRCQHN?qQy?F(I2 zCi=aE&6w})SN&LmC#)Z{uOE`H(IsITBXmJS{I|PL>Ef)=1(>n=4PEV=(#+Miiy__< zR;wL!$U`)Kc^`8)S_YKg3d5f-%xO2v<%_5DaGvt>IBDp8JLI2SY>O_C%v^dO^|t7B z^i+(7mlf8{66=OzvtSX}NV^T69;AQtBbEMvXfSXMI)47#sq?4M_A=TTnR&C_nz2$0cI(9x%7-`v2{b^^d9K%iBtL`=9dC* z=3d`hLC#x8Um{z6|B#%7i=L02MEvdq6@P#DI4^z}h*~aVJ}qNXx+#yNT_mb_3E|}{ zN@yzZ5RTm1()LIVKY<2Hw-WK&l2rWOh;;ukEZt6-?jFS3iFieqsCauKpBLf$pIFfm zReGc&3jYm!c1M)=$Q;~0djvCfsxx%93buhgwazbo?4@!YfW6&UD0`2Em#g*voIkIo zOXN@N`_Ta|%C2npS)W3EAE)9+oU69pbKhY-#8r=6@w|6g1n2YN9CM-(&XWJ_6s9>d5&+m8Vw;kKe=U2PhIiHr@f{lY?Y2hrCHB1VmPwT3zcFfzaR_RBa z$FR-Yhj{O4wXQ=_$ywXCwrQpKcU=^r9jCQ375g*VkRe~&9op@pqVUqE1MU18<%izz zaJS2 z|Gj8e75e{}Iz-6(x&kp5>Q_nf%;TWT5&ky_gVoykx|Fm_7_&#~ACwQ3^Zsop=h>=! z3h+Ot=?aYd_VW41k-F67xh>~*j8V&!o@S*csAmqw?YdyUL+NHhzMthC;q}zE&m+F4 zO;*;gX6QLy%;^qQzaG$6q9KAlu3xlmp|4*rT&RAHdkXcUp4)%2su+XTug?u#zbc`p z=+WWVuTIDxW%<9fex<de zejehDCx6|3?oYagh#z=pgWP(%zoUz!f2ypnhriUOgQ7^qr>hh5?-y11V9Ft{Ks}s; zALiY!&XQAr9RDEi*rnwE()vT`?0E)j;>vS=`9Je!CnmLv*@jLC)oPWMH(%Y%3L2l7kI z;S0kSvM1|V%(0u#`BSF>T*#hX(dLV(LnW~*I>eq4L)sH6jO0u3>4iNfUpwbNwtN`& z92jT56hD+b2gcd$A^oY(;oMyGhyG)C4nzN`aprf2)PE{OKXqsA(0{W0L;rr2S9d}G_s5xESTQ!P_r6ikAvriF?3bYvXyq+Xr5O zjaLNTY4DnDylU{uCWNNZ4Bj#Dj@jh4gSY$YP+k{!zKNl{ec*Xgf;^dj@Di>W@SkLT zL?|!E!9NbZ^(=vSXTYn!E+|X9gioUkCk^2OSfd>7<> zQwIFwXe~qK-l8NbRJ0`$At(c%qmZr681U~=vTpNsDdZNbNXjjByQ$(pmM*f#`5E|U z+JL`=7^t@$LSV{F^0*DVqr7H9K6yIqA$h*spatNM1Ais)0t3RTRwqsh90Dr~pL)ow zfXvs)zJQEa)9R$B^JPj9VT>;Wqt_Vy3$L%Hll{1Z2#Zbc#fh1yt4j#!eoD@QC$ zY{^-kxFu(H;`W@v#2q>JfSC{8hN0SDOOCz$iD!l{yMFkhVk6m?2U|+nzIm`O8_bm# zY2T}ezYzIb!0}fg{_5cy;!WI}Bgzq{arkjchc7DIVeJd(!)^-pPt-nIz}p?h>jbaM z#_NOJZt!-2SK^E;cMR{XH1=;YdlJw0stA{1$FYXb;rBI>F1d@fM)9QlGyE{4DVI(=+o6*8N8ek)62x z5d*Gx#4vvuGh|^sV%RIYdA)HF(xT{Mg!3;#7{4W>9EiCx3rP~l?5KWy|BLhv(O`Wl zhFgw;cLKa|)Q5-pNSq3t0lHNUz}A6%UdUYhk}Akm{c!3ol)-%N_oeRa#4(#qR4=hF zaSW=OoLOSbK+?sKEi4%D7vVnG&sDTK*PtT!uvM$gS73&A?B-2TaX%qdZDjiQE=RaRyF>C-wl2OF>q14JF^RYX&5izCFC!R z=LTH+c{V`&5>*L1e zCk*o@<6!QgTm?kQ!9#1+?dpSvHV(G@=#Nq1)&isgvF9mPE^gJ`l7m!N=<>maJ+SB9 zr33y0v0w~lPjLO?O)NC4hHS)zAr1cJ;meBqhibtgYAc2nho8KdKWwFc zlkArdKl#5!_RTwnU;OpMH}%A@MK8kro?$B;zNZ%Gb)GRW*MAv(`rQNmT{LOFV7n8) z)N9L53~3)?VA!JOA~Af~-wnSwMZvJuij%_@tsAx^<|sq#(S&$w_~p5F*gA*Ey&9|B zyD_#@1lKw=)?|X0SsCPQMBh9Yye#kvFFZH%Cf1v84p~C=A${|QLzaAqtaxsyoQH@G z*^WabD~GL947u_NQ9AtO#k0dt|8J4~mBUZ|Z;^fTTf;B@O~W?T#NNRW?JlIK77tre zc!w>zZrGB=dP%g!0rby3UqV}5H{dTDR@)Q5(<{tQ49U4UYWTi4Kj|F4-g854E{52E zMfq?G$}AXup^72L(NGJ9T(X6T4!=}~oSTK{9AeWJ<==ySq@LF>KfWL9;t>}dpYsxr z8s_(h^#0M1rLY*%&@kEW4pmg4vN&-yd|~m@@MTvFU$koYqT;TLkbQXgvTKGfY97A` zk3BSey<&(8mW}FSAB)A1J8Ge_=8=oASJvb9y?DN|8T$*vtjE27t9pE7_}=^ftsW0K znF%dGv3dAzxR`p}cM)6BF0li}Z*#BFF^OJyYvHxXxdm-2THS}9!AjcQQF9CmNFZh=O zaQt@R{1#xZJ$@VHyvOm}jTTpYk<)g9UwwMO{|d$Di}>B(I}*6Lix#WU@!57^Zv_heDZTD_&X1u_qUUu!}bC4 z5>E;9aU=Xm!zrQm_sVqvwNTXty?sAA?@!=;#;tU&VH@o$w>t6sVsjK8YnbBo#7Wp< zcH?Qr7#wCu!uB*C(6yL2RUEZd;ALJn7()xFJkm3}(@4*EooDC{I2x4ahNq!aE36pWF-A1|W#kdw~`gK}|pIeNcWGvqcxE`!=5 z%RMaA&6r0_bps!$n@Md^>L%k+m#RIpwnVEN&*L%bX709FB~!RL&biO&a2!%_?%OQL z?Qqs%g)_d-x_cCLA5?VA_Y_U~uA3{Q7 zkcNC8SMr;v1AXWHy>MXg*@d`+&ZHL8m#AtT)pYQV)=}c&gZZta%v-Vb-8yPR`{f;% zZM}3`viQouyxzPcd2i*ty|8sufV=(ReC9$ewWnsJ)BNsv|9+}LfoH+meuRuiwMbDEott>eY+x5PW`?vAT)yI*Qr$mm6hpalCe`1C>V@%PUA2Z$l7XX19J z^ZNjaT#$exL!dmTl<-YF>*zo4ucCNp7u%>EZZ&fg-5qqks6A>fJ!71kIIA`K_C!xZ z;w5)HSM~6zECewt+F{TM3rJ2f@=IDeyjA=`Wa5ZC^wi0eC*u!`<;}XWSj-dGUj4x%}#`rSEI~ZTi*zuIoPfJOPf0)CsU|h!G zS28}q;c|%z-k5DFKCL|{ej(%WjH?-cg7E>?cNOEE9PVa(l<@?{1B|a`oU~n~HxZc1 zBb9Lq<4nfaFwSCpEn_d^>ln8jQ}u8X<5SNnOiNnQU%>L$#%URHpucb`mvhX3sRR8E&L>&PxxrPSaG0{WNLG6<+-)vRhRNv|H)YM8!^_wnh zi-qbxUBw(O*V@3=z7QwtI4V5gIvoG?k$)Z0SuPI|2b5g*>HADSVCuS#(`R}u(-}f>B~&t zV0wt@J51ka`T#Hu&oGV$rueB#l|Gs;6812*=7T=Q)_ia`V{1O>*rDQE{_5v& zYd+{$royfHU+TJ!?K#z}T7( z)-$%|gWDOqS^s{<6BwUld^O{Q8JT1>Gv?co^c7|8yL4RPG!88u{9q&#@LzTl2vJ#@2jrBV%hmxSO#xAM9gn z%?Fc8ls;=d=w)op2kRMI^TAHW)UGIh-Hc~3?qh7t2TwEpB*LkFCf}{nv*v@d7+dYS zma#P->|{(2|0um4#<$^~+T1C|9^6y-xO{PZ%u6ZcfUWjj=QcQHP| z_-j={0aO1ui*Y&bDgH*rD;Sq?{0heVIJ}baDaKWd53u}7 z#;Ge*daD>0Gp=Ur{1#~5cZ-om(;@#BnrjGtiK$@o)@_c3kaR-MxR;u*3GEQc^ zjd3dD?ToV+Kgqa|@l%Y;7(dPUaE;R6$=Ju?&oJJ?_*up~7(d6ji}4P|y^Nn{9J5O4 z|1{%Sj6cJ;i1ALw&5U1Qyo2#)86RN$BIA>ccQH=j{`4irsf<6zxR~+h8Mia;V!V&> z7Z@LB{4(PN_SY+nXEEN*xPc}d`DMnL9R51v zeh%Nu*z=N#{}sl&7=P6Y=lEY^T*$baaXaI$15F;gf0M)AT`GJ(;}*u>V!VUX|2E@y8Go0t;|nVO_ZXKkJ`7CuCah86KjiQX z#?%>*eFs?HVC;Tb$qU9Uj7`SP_z=di{z`h6&+f1JZdF!t0lWG+n zZN+Dt%($NMrHs26U&i=d#+L)*&k?g$=^Mj1i}4kVOBi3txS8=-#$Al*_n!E3^e`UJ z_%!2BFfQZ#T*Wx0PNnZ=T+Da^<2J@uGv3R1BIAC>DU6fWDSg*4_AX8O9SBC$CrOUClU!@kGYOj8hm_Grop#GvjL+cQL+>@d3t@7@uN1 znQ_VnmHzdNix}U)xP@^l<8H=jjQbf+VVty4=}Tuki*W|yGR9LGZ(%%*@jk}W8TT{J zWbE9e^xw#M65|<+=Q5tjxSH`S##n8dLpmW_&y2U5pnn?qR%;@d?KCUS^7))U49KgK-AqMT`p=FJ|1rnEt;G z#qVOggmDk!rHuO+FJpXyaWUiM2UPmY8Bbz-C*v%}cQGztT*A1F@!gD@8Q;UWi*YIA zeT>T(A7@<7c!2Q=#z_w<`zjcxFs@`=%(#ki8{?IXcQRhZ_%P#Y#{GNV?3Af{fsvsmGfr+*={?3clkpbDm5d)}+{X9`#=97Qitz!) z?Tk+`?qEEwO{KS$@m$8+7#B0%&bXcNlZ?9PLxRAp?&v-lIF2+5Kzrgq;jInc@ir>dL zgYnN9moa{aaSP*LFy6!XUB>;4f5|v`yVCzF#s!T3k?}6h-!aB59R5#?_b~o7s48J}gmk?}cTTJP;-{2_<;FdhiQ=fm(vVb~vr zY4d{Sua-U|42v*qGCsiN;biRos>+{>aUa_k&A5fbV;J`{j%Domnu;ICIO!RMU!x|KeNetg+HK)$8RqSii>wZCNTD_Q$V);^L| z9u#lox`qZHJqR4+I{gOw{T)TEbf^q*cFzA0J~G-d6`sX3T-B=(b>S1v|G$P0yiQL{ zaejm|wwkHsH^+PQ#1!X|@rl7F7VVj?j97ZI8jNT0Iar1b_T?UoY2z*St*dvZxeFWC zt!gM=>-JSOtgWdl_f=I+u?Y=vyQs?7)KKTHSXWu)9zskTMERxR~#UX(7`C4=B0AOph`h^Pu9pnHDlFW?IH{3)8(!_c68Xkw*LtzKn-k0%vDQz45Ta zNFw@(MO%z9wsfs<8|%MyD;{Yv$_CK@zN2LjzQq!cI0O|G{_CZIJEDR*YVe&zC8i3i zxnwwHH0(mYg*%M*w}7zIXn|tN{{cm1eu+={B7TdcK**oPhp4;+%Bcl+M5R1Yk|Rof zAd38(q!0N76%M!5W6~jP=_kcE>2NW^ofHmg_M|iRNI6&F@G;W+pT4Mk?8SDW@-k3A zs2UKZctqVyJ)nQ@OO_**59(_R5+{lhQk2Tis>eiOxM;(4gTm1sxE=^DXBGcpAPOg{ z%3rku!W5s%U)3MUm-QjEUKkEH3<N%uJ=fEgZz&C8V8ne&}4A%N|z6DTRw|-}I z2{?3FzcWJB9rRNAC&gOv!-bT+8{-1uv(-9+&J7NBDSI-|lPY^&o#>HbQ7pWX<6Agf z$Ms;ae^BT_|Eys@5${TTa`7=*)M>?J+{YO0_)eIOgejPgg$g5vP6rAR-3wKCe@QW+ znCQha%+(^pqN+elXH-p{&*97?R!o!$CBksg(Y`2}^&4Xr;5*iAVcQ*_AUVe(e8(7% z;+wAbkVeq3e+6>Nmu$os^ay_n@^mXcv>lpg)ZgHdaa!PZx{Tl93j_5SU?Da*BEk*R zWl$NtOln<5O-+rwjiOt5XFk~_2r<|t%#mUiBD{tOrZDq3uFGW>;x^VS6m)PCKhrYI z`5YEx8V*;SxlGFKJ>IP3gt-EYZm5ejEv6A|n(G3w53?w7?*sQ+Qnok16=oZ_bUq^1 zZ2z-TYeWn4NpOEAxd}JZ=}x!<8a^A)n`LnwE|>TM*s*5DpOs)V-j)N#uVrkD3F}8X zzb@q}Icjvg^V1wD$_$5a=@OtqC2AVRG;n?l`EV)2sluqlMHAkbBPD-A$mfVM42nZ> zjm0jP@k<8LQLf1O z9T4T%T%Y7}CK)w#m9pkWB^iEjN!FEQxX}O6t+~Gc!Kjf&0z=nGV-#-bOi!%2tA@^I zqstg+jNx$SNNS%H5qGuL%^K@wwRNLpT#3dth)5@NV$HIbYNa+XZvZm}j)^th-OL_G|-G=gA39k&*`qXYt|U371CWU!uu@hZ{Ty&u^k{<(KhshHHXBvFaSSxe+qu zj_3)-r=V4ymMwH%ZTOUus}0tFHGC-(x|$QR`Hc8++{M#sc;7FUzFCu6&G)?N)xSZFACRD07Xv6 z_ptjOWBdr_CA@;Kn_C*4oI8}~`(C+OZo z{4oxvn*2D`Bq{1m%6Im71c|xE?fsyxMcEExDMfU+78g2W|pJcvG_bcc=!+erts_1@}t1!o5RFfKyBWg9ttX>BY9aHZRBWQOr z)||^fgO82*J#gGVLr7fmO?=b2-&nKkYc%6S5vmDY!ek0hs{{v~=N1nIITAXEc}qWT z@o;3d>L=yQ#_6cQG&#n20`tFwTk%EnIY-!p_apMJa+7%#WW>8(2stzH#dFIjl{kbx zqLh-H@1bqD)ehS|_1C3vYM2tyg;KctPij3>! zZ31yq<*lE%Q|Q)p6kqhAMBV{Sh`)j4GQN-d_~mpvm2OAm(`{)zXALc0UdGPEACayc zE6+4Hrpws52kssDD8iA$~MWQXIjKBP<^VOdOkdP2y;XI*d^U?&67)bU9p|;)svG6%fsYZ?SrDUhBvo zjSeW&VJ3bu{^t1n(YIY8uyu&o(741Es&8zf3GENBhuXynNG^JHf>b@lxHfY?kxV0v&M0XMu_#4k-m+6#6NEu)q}efcJ7a@l%FZ~;xcCbhXSvI=#|*V+ zP*+JOy6kDfIJ-SD_Att2Y|w8ZrXj}(%EA$mu1O4-5<|YwJ9wCRkY-yBmQJ+t01#2! z`oe}SdbcjQJfs#5%dO*$C6_NUrjA}7zbw8u9(6F7@nEULda`kd8c0TwLzO$S5~xny zmf(iM5mB;bB~EZ$J%Z}$NF_3LG?|C?8%)n~bVzF*ZN#JP+#GM9wwogYt#cMMJA(xq zby*+;S%6rKYQ!WKeW~NRD_}gDHghSV*pcW4WD~NQd>wMB8hw1QUr4Y*tuT9cLOBR; zWp+cXP9><$Wf=LRDJ#(vP^n@p8)7dtuDgQRamrco_EfWAe1giuh$)WSu23D+byra8 zo-xnOMsVU3V-P+m92pgGj6mm?6jV%bR6IJ4OQK2e5`OqOI_QHPF@JUwVfc_+9+{sT+H_%Lwxe9Eb6q4DO1uLH#JsP z)i&Q&&;jR9RKpRM$||h%LIRMqgvqy%p8vHFb?sR$`Cj50CsY z>O^$T!rO0OxL`{Df}-3-**QfHK{Hdr91HucJEXXff z>~K8tNY_uI&Rs@stG~emGjIiO6XV3KW{mOtOtD*FIkHE*Oskp3|%2sMli z6Gn=ch`;Kj#NsN`G|UGL@i@td7~GbXT_bLTgl~k{OOk1&rLFOoiBaZ8Lu8ou86wlX zpWI{ZaKIUzFvRJ&3Ez>9an#h~`8T=X`2pn0F9yvjWh9_5c$*kELzvhn6L-K65er+z zQ)H89GjJb&S^P91%m)l{xA~AE%CKG}f6Vm25L|{)jj6QLF-P8q7uXbsLzYfyl76W|CfY(C zyJEbUP7Wfi_ls@hoVzYx_nYaGabw1WtET6Pcd0(C6AAFo$eE9i6uS&F*$`vQm4?VO zk=yc>nPt1cIbr1ECG#o63ol-?{{6ci0dPZvL?6kZWqWhr!mZ(MWRk5M@` z889YN^89YEGo+s6V3-0M2407DX1^Ps!pgneHAZomZrz zm>)DoiWU^SQ8iZJ|6e|2l!}8ykOde*!sD+KNp!!FzLq1N%ag-CAS(bX0`jISkndqm1;_cq(_aJJssY z)~x*#w6zCi=Qw%Lw&p-rI4#&0{=63*!C9KJ1r-Eu(VVVD)~>sJ;dP%v#fmkqlikr3 zsGBJ3M`e+iWWTeQ2 zXR6Toxs3QL#UCE8sa8%lp(GmIdn59`Y3Wu43&s&M<)D$v1WoYA`VuKye4n_$O&oFkvc-7$WGIe zLw|IBj5b6(wHA}CqFlm()?N)t;99KtoDN!y4blr!C*0(tKJFjh zfcHCN$@_uG!P~^RLt-4N?RBW`sPiMtdnu`r#=^9*w_i1N;tMyAPlpjsAvC!$k8OCM!kX-pj}-jJ=rL$TWBEj7W(|0L>=_V2`I zStkDrIqK*j1Y*|wxW^CAc^VQESudA%BYRIcyx1zkZaY{8!*T7y}vubY6 zy0vS)<-T&Bcs(z56%VE>y{WMwy|!k>jLdXAu;m$GT4PgVRaz}Q*G-?9&eJA`qpEgg zT5vko=&P)(TB(wyifV0MmLdC4BL&SzfYmft?JF3Y@RUS0{F!I=L_Uq5&%<~izj zX%BK*5P`qRa&@nrDes63{N{Eh8KZfp+ zQL%-}^EB(JVBk&prAhb)K;uTVAnuhTPT>3Mq{JZOjAV=qGVn@7|J7!hNJ1Q9y4Y{=u@@;oKUv&1L@N3aK0a z<-V8n(|=gzAo(gd(i8r)A)trt6J3Lvr_DF*d%X+2*1%Ur+f%p#dhbxa@0aEJt}I4b zWQw86bp(~6V#sn;Wuq9XD#(&o4Eny>T%byrvKm&(N=l}LQvNHXCG(>z_gaL~&o8Wz z!+Jy@^KT}#ibY8-Jchm}DM75?m^4DHuTM%8>#LJ6AucnIxlj{SX?amq4`wG&3>jfC zc`}6R1Em+f1t0MD?Y8xz?;4b zomWNLv?Hp<*VV0ZH`O)Ptg5T3bkkXb#_DwqK6zJ~ zzpxa2SWR6iI=f0oKnio92B{`z>eP!n)Z$KC>uaj3x@A>WT~$L(1z>qYMfELMRj19! zbf>Lyr!Ac3PD7fvtg35*^0bwpvu;A4imtW_u)J{-4$CyGt6SI9nATLc0S`sfeB~=@ zs~QowwyI%ORa$v%ZCb^;I(Vker?`!c<>1#=)vfYX-;x2rhILJK$kr+(@2dueY{ia_ZXb-tAH0YBP9V@2>EIo)7IknbL}lOCe)PI zrd4gMLZ(+1=I64T13o3sM;0%y@Y8FXkaAVJugbTnvRsvQZOw*t>2jT(-ng!*p`t2% zLv{Ju^u~sYwA<4bXBRJySiR@h`KoFsEt>3}g965(Bb)$Y27Hh4u)YRkr5i{3-R1T5 zwKWyxd8Mg0P07IdqN$mg?%7oR=$z54srbY>((9nO#kUn+Blnfqdt+6#c-dgCGIc4UQ zsTt|3>T1$qd_^^?2{NQ&bD|;98Y;@u(F~?c%SfB4Y%axttXZX{t7cVAU%BGO6;sL^ zYIF(KudPYHkz!>IDp6jG-Juy%W=y$phE4gjsZc(xYDPx+%&JVS_6@abODn6W)}>FK zGJVQ)n}VAVf9BMTn=)qUqyKl3USs(rX!VWAB2vYCXX=Wn({x6sRW~-KRaUKszp4B) z26ajk6%EP~8m9z(jzYT;2~^FTRdwTv3|#_LtZCI%<&~&r%JI`|I#5@pLC5qJQ)kYY zwNk5NWBuBywX)2o-W2fa^eN=k%8Hel(`Qs@qc&AGRINhP=~JfJVosfosI#Wdys>h6 zWoXomISUu%re!ZJMhE6CEzMb!y}URla9cVzd-1Z|f`R~}xTqBSGlffva!U*H7c40* zEy`Y$ms=$Jz?^J%TFz{D+B*E`!nOhDPFq%+n$}Q{KI<0QhE#R0Z`@c#X9}C9q7P6r z(h6?O)VfeGXcW}D7F=AzL)?%!m21&0q+>!`-c;*T6XK9?H0BF6%D;n3t3D6i#$iaL zN3b$Ld7}kV=CbSYuR-3I>5o&!A#MY{UBVm-OT8V+H z@|M!&n+wRhF*BMs-SxqlR{`X(-9dT{J0kvV&$f z{lTCo2T5k5oqPRv}()xAwM>pA7pRhZY*J8D+emalRkltR#EL(GOvRcq@*cd~-pTF|$lRLK`C z%*)S#yWl-?7xER@d#Qmzklg62ca+!q7Spt+sHW0^5xuc`$>OStL6+F4+C_-Kb-&c7 zW{)@BG{ni|3r`h!ng}g4qsnotfFV_Nm4&cHHaAMqYHp5n-`e{0HI?N!WStIcN;9TS zn^xM0c_YRm^-zb{>8KdAV?bG;)*3VzRfu;Jc;2JZus3Pt0c_keKnP9Tpa2@nA}UENjPU8K6J zQdOOFB4UezVFYc35k!PyL|_!P9l=3-HON3vt~QD}U$P4j*~<^0=_m~=A+Q@pMA*ae~~-lg^!=C$?z z1F!RpSEkM@u*Wd3^Ct01A;Ts0jC@opav8}IptQexn>`!x6tAJKNM>5Gkjp^ZU$qrA z+gP>LG^4Y-oeWG5`U1__rT3+{uXFC3klup(Hr$Itn(wcB^uFYBy}t$bUAXVTeLwC8 zyhG`1(ZO>rTl}c6s5R#v&s@vaOy!)#pcV4*ffT{=IUVPk%Li1l@mky3a{@&)e&7N%@?V z^nAMC9ZD~w^povA{nhuI=zhk0pOZq*E37mt&GqN@$gDRgWs5XP4tDAsH|`xRskUA< z_0ZPg`n7-hVWHIMyM}!?9j1Q#z;J5+^l-|37pKZMk;o&oro^foqx(YoS6Ag?pHRJM zna}$U(x%F_OMH3B>7(f1ouM?V@=r^B`m3tpKJ>mbd`^n0&Zc|&nLZ~a&8iIE;&W2c z0p0%^O7~OxH)r|uSKq&b?t6TnlR|$T-M_!g=cJ@RM)%GYJ|`vpDY{=1N`H~k%U1gI zSKmKI_ZLIyA5i)et9|;b?|(t}_pS9gDg6FG_wi7=g%tFab9{a+@A+$GZ#%bI<>KpK9ADFn;PkW(mxNS`zbxt(Rlw3O8@MQN=Z@sud|0_zr|80#lf30WlrH%A~WJmwe*+{>R z(zkXs(r={n|ER0{tW0+`Qqp(N0>ORBo8|zx&oL z*G)%xhg1Lk`n$Z{bd>wwO1U}zUOLPxs-cOihy6IG$49qn^pBlhD;e&MbT_AGn;8Vj z`0<^~e14Qp&Ev=Md7qQo$?4t~N*_<@u702X>ig5_{!l1=Hl=Uh;nQDzzk%-ehti#t z{&>l!zxtjx7#;|vhbaA>Q2Kq8{vUOssLCjHr42v(B3)?T-!#X42Oi!Ssjj?o^q=-U za?6y18_YYCQReqcKzRTyN@b9AgsiAa<(iVpCSa_wA z{t%_V9HOsM`qJG#{Z)RWbid*4J|~6$7~Nm{4xj#N`df6r=3PD~<^9ui@4eEeznXrY z?w^0R&q;azGTr}2W)W_q;o6TLedM1bZRB>us1>lWHqzcvYopf@@cJqt~-j)^y;5c4!vmc4)3e-1yicsvc5e6`3g z)WzX%oD34u;_);kdVQ5hr+F{F8bx(5h{F#d!l~Y2UeU3`*8;CPIMK7&EJo}hn>?*~3zP>qKep8$@t9P*(;#$N&cI?(?We2!eDUBLGO=U9!e_W>UP z-lDL_A5>&HZ*b^85BwJ32ZCOI_h6=XhlBqZ^!GUYe+zun;omY<%e~*hd4k09j5+uz z!1p=$*}%sgd<*a&I(RSe8gRCIzTOUe!lC~F@RuBV{{CK;a|Z0e^!#tYTY(#Y{=QYF zPdN1aJ)(@yb8!BCOvaNA&ff#c_!8g;tN7k*;42;a(}Ayd@D;$fI{1aaF9A+TxwZrE z1a9TN6L{X?b3O2i!{;vGLk|6yfDb$Pw}J0<`1~CBwGRECfZyQIA50yD^>!0*lm9s2 zcR2Wb;G@8;9oGOKbMT9Sk2`ol@Z-Ekp+~#DlkhnI_FnMu;ZMvD+zfmScm|9<4Seou z^$%9BG2ltyCjWPV`wsp~;2jQbexuXD&Ce7a{AKVNc5wPoo#=nW!H)-Cb?^niM}b?t zOrQJ(E8%Mm(Z}g?8~FGeRX-;pQy=gQaGo6TH3a-};5IJo1^yo3uTgUEM&KjBZG3r% z-iy5fKM3?S;CBGGNaarOc^LSipubP>Ii7t_#2C*8>H0Qs`>KfHqT;_c9A6AEyh3sQ zf&(6}?b|D?zQ+T%ZTcSXfLx{^Z)*u==f#+{0`tY zzSy{MkAs^(zt_Rd|9{!RheXbq-owC2EplB8{BZ}b0)NuM?*;y}gYN_Wtb;!d{CNkT z0KOl%*~v7jINQl94*e|P)7GlqO#V}W9|D}*om@WfR^Y~eEAUwk-UmG4@V^}RJcoV+ zcoMjkdk63Z4*mVW&vfv|fv*H^{ip`K!=c{~d>e4n!wjk*>#ftl=K$|>_$Pr^9Qu{O zF9%LZxwZj+kAvrdU+duS0)7K<^S2)ceusm93i!Ri%|Cn%_?Ux#7x?4ADJj>lfIsQ* ze+Brn4nC6#V!iEm_`C`DE5J>jGl0)nr*>#~2k;|-n><tQ@fM z>F|+nM|n52mEq}{@1{-b?{e#-{Rm$(!`tfb`NmV+eyIh1x{+0i@%nH z>Bk&CTY!%{cpvZ@aI^n+0DsQGKL~un!9M}~C5Qh5z-OErwTEv5p9S2?eHM7a!TBS8 zT(5Z!ANq{A;7c6*MBr;3K1+aiIQRzO+kjjD?E;>0@Lj-*4xej*4*@s3x*hml2mb=_ zn}Az8$``FreeZDiKLh%E9Q=2{?{)C$BmnE}%MN}l@P{4T=DCjpH+!@B%aabh&0C*# z=xu)VEO6698_M19@L3N06$iKZ=Ct)u`>}c1k-$w(n^(?p=xzRZszYz{z6B0`0pvLo zxY_4rz*jo>6~Na!_=kXRb#R-9UIN_YxA|-aIAxd1=Ft@gw|Vz_96mOGzt*9*`SmRh zy{!-2;n3T9!o3b|>kdh<4DyZ1s5UjjZ1JOg|j z__M%GZ@&P(-@#u7J`M9Gqd)90?Jq|JbBR7~{%G^i8u*y}De&*yr1diS zZN2Vc;3ki)?>*_@w*L04gWG&+zk}O+XIe+JADRA-bZ~30xejjYS_>T9+I^*io1JV0 zPQ#pBwocgT(A&C15xDgWo8JvN^fn*d>)^KDc$0(My2RZMZtD#9JGiY&>~nBi$M~Ux z+j_`z4sPowFFClax6C*%+AijYXF0g7AI@`d^TSJko1V>YuXN~bUcA-8&Cb&_?+jln zo7njV*mGh_w4bJdPur@vb(=xpGaURH;8pOke(^EjhdA_~1K#T3{|@{}2mcZ9Sq}aJ z@Hq}XrB(ev!oiOMKG(rd0zS{d-vazp2R{#Z(!sO97dZHC;7c6*I^btI`0c=b2fq*a zN(X-o_*w`53Gnp}{vz-W2R~q@>TRoo9|L@wgP#Wc5(i%fywkzWuMWd*UBBvWR(mu1 zv31c5aI-^OKkRdG>+gBs76+Pt7;{fN_>cXQ@;CY)0^jH0|4BIS_l5_Y_*coI?A#V^}|&NXTpNaKYzz_d0SO z3;JoO7n!SE^FY7Xkv}Oo6@H`IkI}CH{rwL8?;!s;`xx+H;3nrYz^gAP{k`DBKW-M+?~Ws!{X^oBqEN0yAe90>{8$uU1-$ln z6yFBiACKaf0k3{HieCZT`#}`{5b(~YqWE2e$I1V>CioyJiv8!rAJrcYLk|xLf9j_< zYTQCexqdJ0K5pi6?n@rs<*M9sGKu^A20Y!&wp9~V_Cms4K=!>9FLe9?-&T@`SUoME@UjyC& z+z0)!ZwCDVN(`l-} z^b?>rd=Bva4t}cOv%OB#*XYjz{Ywsg2k=)MJPq7?M*ETRc^CL+9R9Zv9@mbaX@Y-+ zaMtta#uZZGVTvR9`bHD_r$C?VQuKjP580Q@Ege;Ihy!4IVaGpzr+9Xug8`9sHkmJlA-E^C|M7dF9j z!hfcBKhASny9@yzbMUL1@cB>^{MIJ;C!65+HNpSA3I1dg{FhDemzv$%0}iY31W_Iyec`g5D$7dOFsn&5+kv%QU-xk^f`VqkbT@K)fXkmo~$vz)%Ka!vrh zr3wE}g1%#!(p$SfV*D@Ea&6ok2VT1%ivI|B(V_ntaNogyO*qRrc22b1>2y>*&YoMF z;0eN+k9T3TzVirYy-j>n@Hlyfn&4N1Ppwn=tOfrY zn$X`yILkTwiptpmKl~-&<9}6r4C_lzHsSO0Ciowk;4>2O^*WYt)@LoN^4s{81U?4b z?Bv`gd@gN*7n|UhgMVvJwA>F7&ibicxZ0Bo?N|lX zyX7|Hb5@gbH#Wi3P4G$+d~Xx{BTewTo8X^of`5^4@mKi$akHPXze7L6p??f~S{?k` zz-Kx5_nYwl3Fs4`Kg84P7ftA&7y8*=5pjsg|9jv=4*qB0!w$|LCF1$cUI#xA_=tnQ zR&e^ffKxBigZ<9C$#WFw?RVb|H~rY}z#DGuV!sP-_#EOB*N;wWf-fdq{MFD}QRMIe zs?U{8=(mD?;!34YD7n{5INQkxevjVdxm<8s_ug3&$_(hQ1|RQ3;4?*E+y*>xz2f7b z|5xxyfRFk4M+uLs@AsPEKWlU!3{5)OVP$rER9*1ltoKCONCIk>g&xPx2!_BncfzvyAM_d|!?+I_^KxAv_$ z^kxswIk>g&n8U~P+~MfK^t{c%P0yVU{!eJfy$)`A9(8bQm-`+3mL~fDWE1@UCio*w z@b5Ljf8GTDT@(D!x$$-~uL*v36a0cEcrW4f)iAG4MSrkc5jfnb!QK$?I)H~efVQxwa2J0ehYXc^@QtUYDr8UB?~k*S0^t-=Tj(=wDa= z+;pu)89i-$b}1in?s7e6`0gnFJHq4iGwqEk&)#<^{WQpV4Dd0?xepC@D&cW_&L*74 z7yoo!-%cK&j4o|L-%mK}VGQN^D0f(JT2%Xpu9w<3SbUIh;lEV*+dS^0;Nx8pmH%$S zCV$TT1<+6W9Q~V^&*abP zA3^w(n9skTMEK#Pe{am^jNb5cxp@nLyT9$YN^qqK{|!Jtev6KSHm+3&pGp6D+jN{= zflOB$UR3-g*x?P}Gu*9wYM{Sa@NkLx{29=9e$N-6277xHxc7mTf)`<+HQ>c7mMa5v zq~8D^{i@Paqsnz4?MJYFs$W&f6AF7r0WY>Fp9JJT8TjZ+%Ex}c^&beQPc?W6*xQo# zXovjyS*o9>GpdIr;J-}xAQ8G<)CAwz1iwabTCaZFGU1YhAGi(pc&F;Qh%)YM!smX_ zSAVPZweth}fO{W}w);Uf$s{i3WE!Te3Vh-VKSN@>t z?IOrOAM^>w4%Y$qZ`XFIp?$N4pR`UmjMIK6UzZE6&*8t<6VB~;w{t${t|s&kfdBY) ztAtGgao{%yKOxK*&%XeD@hO!v0XbVvVm(a0ju)KP!%xum9fAGRH^IizuWf?Ajc~5l zFn;-V28wz+_;<{LJixC9UcDan0Q@%K#j6#s0{=Al+xKZ0{|7-oal6u+J#;MgyhP0R za{S2n=hq5nv)h{BC@ggQJ<1)yc@?PBn|89+*M7KHxzUdg5-$Bcr-%=Iz8?5!pW+iJ zV=nNKXQJ)3O!(6}-doi^$I$P#2|mZ$>&Vj!KDDo_9>z}50hqeh~RU)qNC?3 z==Z|k(l(G>cY^=O*R>z{(C35Tlf?Is%mDq9pr2T)?Ui_qzIX=o-cQvsXWXa;^b+u= zo&CxqPgTA7f7E)J{m%t%U%+KQdU7h^T;C(H?wW)=?MDBKFGwfw)u8vv=L+&w;BN)} z$Q-oSRDDqt97Lhp)lKk^G{HYj_z9u>_V~Yqp3W_#RnJAV;}4qf`8DWA_WHtN9Q&<* z20q-X@{gmRww@O6_vQ*t`wd&9J&oR!EYp-{Z%LZ5)fbekmpvx zX`gFA+jleYdz?aU)!#F9+R)H)bBOrS95_U;P;IFY{8K^blXPw38Az-=9|!8O}O~Cnd%4n zkl}s6M-ZpY1AZ&;`1A|4n5{r@7I{m;aIsr{S&UjSa)qy6jAlQhHB`6^Gv ziLY7-XFjc8$M}*^`Zs}o$e~{V`sy4l*ZkhOOi%u8hO<6%8Tizk&p})XKCL#dM7^#7 z-tppcK}KLdp8-C4h}zZI6wUB;!I3$1`vKu>Ki+n=AB3^quZ+JFZ@+B#I}tw|qRbAZ z_+9jThvLJClV=mo?OQ|p4u4ANk2m@+ME%AYf`;fG%je0W^t96MAqyoqp@=Vr_o=opM#X9+zLq1#sQ zX?;QYn;!bXr*pT~tBO4D0)59y)$;`K_X8ilTJ>rE_IANT1>*5O=1=y2q+|aZPT~4a zzMcU8(POk9O`u(V)r9}_MXI+>$6uWw_++2OUnuo2`EtT#e1V-;<*nx}Vw~D>n$wOO3Fmo%`@N$V zga7dDYlOon`1AoE{TS>D^6wHHM4{UUKwrhVuL&sPo+k8T#{XwpUmx^80q!r?a!qf) z1wM8p+6(qJl@>5rKgmxiAKQ1B1AO>Z#YdpeGXxI_j>k=)A9L36GQev|AFu(DiL!o@G;qWyOi^c^^NWPBbGdfIoue*Hf1|1RMt;5mGIQTT)r zeLi?8`rYv=&p1d<5PUNI8BOqwgtPn!j7PS9esL4}e!>%z*?X5aq5q)Zbnfvr>aT2m z`U&8pt5p8ZDa!Od!bKj;v-YB_N1O0}hUsZOyB42AG|~Py`1`BW-aOdVOW^;rJ=$JJ zBE!soP<__&DvzD_cs=luuPAQqzJzf0V`EOd)FJdHMdRMhIQfUxH)$Me@k0gthkvU4 z6L8AIz(=pq_@{<(=YzmIKCa_h6?(giaMqiB-!i(L_XW^bx2wN0JNXK5?`Un8QS_s6 z;G<4|`33Naf7Sltp@6>{{td-#zW=&2RG*_`D!=vjQv`45#h%^*`ibjR&TV+H0r=QQ zv>hiPXE*TiHHr^|zSxBSwS>#KgZ480+zvj~^HqL}8^36{qla$^pPAlMu%8(y_j%B_ ze!&-H9PRQap{MnPmdgcyZn3_YdM4{<@^!S}6hAxr7pDNP?NWUfF|YK2CuS->@)qTJ zA>nKfKGp{^C~5%oV<)P;jUS^g-bwfglg05q4EheNPgX(mao{yy^=AI_D};+34r%|o z8uZ@-eXFy-^K0XOgSMmD$;-gU?@&AmJ~OF)ae6yhaOz(tsXZGXANcSb$T?LRoe#X@ zb*hI>;QhdhcdI^q3f1}A2|PKWd|Ia~J`CJLoS9JAy9Rh|x6+SH(-(IFZ~dMxKnLje z364bQ_Mc7ggK58y$H(e2)lU_9UQamdzlOMU6n1zjoprxW;A6j1p9P-)e5!%A z<00Tv0)4`1$M*^z5*&{o1%1+?A7%a&&)n^-JB@?BcBATT7J{JS;EULdsz<#<6zr`2A zR`~59!8LFA@AaT>?NvVJ&u<1^JyrE!an$F5C$J9I3TBTIF8=L|cL>r4d>r&0ud1CF z(T=|aK3vjrMHosT|yjs-yR?+TTfwx|&?OQ}V|I;^e+&jl>z5fa?e03T9a&51Uqx9_{;jEwc zIP=7J1Hab6uLmE0k;-HKZL7txCldi(r^sK=yT?~OB(G6=TOZp8eDoOD5A^)B(Z5mg zap1oNUUSwtd0CtFoVZi@w;tfh^=9DqdvA75pbdDdGk&cUT=RziUTFOBc__21KEm0b z+~J%n7yx~>OWUyqW)>4PXhB?AM_tL`kbx{)!=Xc75K!L>4C1Q{H5>72R{54 zUl98~iXQ{7aYN8GJVkEaZ-IB<{6JD+kCzwX#*q^Rr*Q=58OA_=GVtO8jo-#$pNoJe zp7Mp#{00w~++IoOp%Z*A5gduoZ5QarA0>hLnyR<=1Fv-|KBBPqal+Z2`(U>-fZr!L zDG~d{HQ=@L>6a<#|lpU z{S;qH>_EB45zh4*vv!}U4b#?y&)Oz0bt(*rR+BYChg;D9Lu{ zV_snGaunk<|EkW@{%iI#7xWW888%&`%HCT*IM?^9PMp6P^c{z*-?n*Ex6qUQR52c5 zowgr*Jn-2I{#Sv|#1t*p{MC(ugD7PI$nzcGoxfB6+@WUT{R(*T zAbOxH3H-l|&tux|HvS$;)nt8+?FXOPS^$SnjCX!a@gmxBHSp?fS}!a2QsDkxUl^D@ zzk_j}7h~P5RoQzVA)M`e6rZ1+2mG_b2Z_+_LGW+=tlEjK7d-_$(W7!sAkQy=kAIOK z=t{Qhi{AmSVSU^9ylQ+tp!J$SeGjGOwK)4fUT}(wj#GM4m0XLP(4PbPPG^5G54`wo z^;djOg|91tk76IZia7HIqo1dGu=)6>1=qaczYi16cHZHP@81-Bj(53ZZ%;Mh^P47k z3#nb~1fTmGM&ZW@9+pI(PX~Px=K*|>Yyj^6NRb+FKHkavlmAQt(B%jEg2QsgtN4D5 zarlS5g!8&?!udX&TS1@rw(4yR?fY-Q{kc(nJ^?)G#A&|*Ui=qd1hIa>-G}Y@S=jS5 z71KM2nw8}&qP|Jse2kFktIqkrw}8I&-NcZtg#7iq4MI=j1^SoafzX2}bgMMM_kzDa zsP#2J@Co3x??m?P{tF$*WRFV9zI=P{1W(BRoiO}^uIU$+q6I0e%3+c zu30~04=Vo-wBxaa%XoB|&Qm(U=VZ|PSuM8)JjwJl|Mi^tFMkaz^Y=ahe+Bw1`1|1B z0en#K+1@W61{SoUkfqCB$@D@@p>&=ae4kKLb*0KLL z3qHBrGmU<+FE1w`=z8FtMQ!&9EXeY*L!A6PjB>dN4uI(zfj!&+yaVkx@&<+y?xd2XVgx{;XfY*-uW4&?^JT{XM!UUy8W>UK6AawnRL!4%rbnx+CvrcoCdu3 zC+%N8>g5~#OTLsk3VY}<`rA}**6(_NkMIPFF5_PTK5FME8SN^*IW8ZYP}E zeVWr>9%7vSdj#=}t)Kr`aN1{g?CJ&Zuf0L*H39xD6i9PB4ma7*yU5DT(EOaY^-hV*L?S!890`FL_@ucmy-Uz()%f4{2c9>&lvKO>ySQxD%K2JyX@KtJNFR~))Y z^;}z}<5cY;E%;dAp0i$Y8t~2%$~{8q7XcrANcEgR!5xINJc)bM&-;+`t)TB%p?2j> zQ9c>LQTfnqs0n@p_zyYbOSK98nBX*TdeIl|36$|Y;X~i2gz;_y_TTkK+Ac6p?>OL{*w+{aeLLYiFK%__#T!ANM4U7BTFua9IL?W6f=@s25#R~nJAr%7 zzW)t^gD7n`*c^Vv!^ z)3#{o(k1akK~HWV7o*l3@83;XLaBf#D^b!yDd%9H-Nma_7g?tv#mPcCANS zCfhaGOWnPv5R|jMUapue^}BsKMl~^|#3(C9z8FzbG1X1Qs3k_DF^!>m66X|@clY;a z$vJ zs?8f>-)(H3ZNsvT6>FER+ZdZ~-PTnbI%41aP0zV7M%4>rT5eHHD=ms?%|$WhvM9!& z7sc4nqL?;b6k}M6Vq{(%Bj4f}YhD~v?&27k7str5IHuesF?pB7l)EHGz9liTEQu+1 zNnE)xZL~B-&r4(IQpuQxOC@7+r;;%uE{(%tnrUfVDX|_P6<2gBrkGSJrkqqNu8wh| zX)12$OvR0psknhMm5eJr8B_Y=mi29jkBrwabm}f=Bc>h zJQX+2q~ZdE)chD#q!z@~I~6xpr{V_xRNM%jiW|aHabtKYZV*q!jpC`ep*XcLrhBL2 z2KUs$xN61?`Kh>gAr%+Uq~ao^R9twKO2!ySDj6qyGRAC{#yFUzv6*8CQ^^>EO~nNw zsklfph43UY&Zgqx*;IR+NO6&LDitSZ>?9!-r?^yHL9ua4OwU>z(+L*G(Z%%rMKO67 z#Yng?hTp=NW{5M&g)x40VO$w;N|1tSb`}nbQo?Z($W7pa5=FS6gd3AUu1&i~lh5|} z*{5ocW7xsUq@a)cqRWx1=wez(v^LDxrDK)37^}y{V(KjR>ClNGyI72T(luPVm@>o} zJ9Of;T`Z;y@i8u4Onqf&aOq-nB^}?Plfl%*V#<)=*`tf!mCBW%lIzd5k)shaPkNQU98vVAd$Ym7V1HM( z6na;z(6US+*t&MzmSEk6WouT2-c|aGLDygpnD&=@y}@!;iYg7zx(x%RY$i(!GFh5- z?aY>PmEA!l-IdRZWb~dADw@Z26XBF3z>7S zlG;lmmbLEiFM4Y?gD9P zsN$u&3Z)7$46;MHir3R$;aU<`8D-nsMfhIjmZRmXa(9p~SK4TB6Zf)I-g8zf3oXH` zO?WJp3fN!%Qs$`$nFN!o#oSIB3AjupgIXBG2F$wR@GRckH?%ITf7HdO2m zXxS{FWubhUT9n@qv9>5l7$xp0{x^uznM|oEUs7N|!dF=F&}2|3QoAfr-#VYx=mrN^ z8I$DB91 z>A6BMSjmZ<7fL<(0%?bAw|i$ro;`XXJ)|>1sX$}{SpjyDRc7l5_n7=(SJ2}%CLIlAc(E}fs66!N1}HHgjmJ&PZ>X{wt}gKMg#tP45WtNLqYI%d zLqLjQizjZ^U@`$IF}ySnWkPyhNY?gLdG7mL*3b8C07{0 ztAHqja(8-QAe*6X)m_>gTxc4^CfWN{8D*VloHg>sHH z>B4E3UnZN+^*dDQ?wG7(4&*4Q14Tq9W2y{NFN=Vryh16%t>wHZlzP(xxjpF^_GBfl z7@1s|s^RkJrWJG=Ib66apB`Wb8*Y?zH~X>>$fj5>QoHcteRgM#9J6@+w$xIM^_PgX z7P$gsbltR|ukKxXHyJSZK<=n*spJxN_wxnea*CvxFjg$l$QFfEAz>mNA)-{`2Np&# zVHPZEfLxIx#aKF$ma@E`kRIsXO#t>LO4)K@utfDId8uQTyZg3#+jIFmCG|x!oJ`-i z(Vj;(Jup}d4Pn~9)nI8GfVwvgGnG<-hR;5hyi8jnw1<*Slj~|A0reaj%#FbHl^%tQ z*&!NbcMMYZ%7!Iyyy~Rdc|u@yil#y}WPO#0e~{0WNk_D6BW|%Lm(7!BDYGXI+G(e! zsP&`HTqsd!KpPw6i^=~K$ltL;rLecu)}E9Z=n~G@o8>pmMQkhEJ&@r7BvC08>5(*2 zE$S8FothU(iF5Lw~kEC>HWL zGHU8rG8fXZbQiZHRSwmWq&BNO>Q>y4SLxawP^ak5vhIkM)4bP4T0}I(hz{aHM}cNh zRaFlp6gQ2er77sI+HX(3*W(2H1o0w)n6Y54*&1Dgf(PuPb_o_JV~XXVGJ@|)(_qUe z^C;E3Rh>xUxkxT@1lfE&OFe=>|0CgP?9TP}RnQ};cnXZ_{Lp#B95Y!8g!+VIc3`KB zz&q3VL2|(hbn#9jOCID|b=_zg7I;@F&7FYz7e}ycF6xUa3Y$OJ!FwXiOHx^!T_heh8WVWB0 zn4j6KHPu(h(_A1|>60j5dYJS-&PBTCOcJqD4=hN?M8jN4*20r*i#*aY>z4Le@U(;< z>Igk7iOD}-)+Cc{+RezbK~f?wiD;Z=snZpY{oc+Vj>gCiD74PfP{RdeY5Kv9jJQ^D zNpO^^LNJX~CQlQkU{{YhOz|gqZgU=3s6MiYwLnO@YtsvjiO*lXWz~5r*}YSkA*JOo zb7L=^EBDddl3rHG`bhU;LD;hAqF`#Ak4+Lth9;&ClrMM&B zw2tONydc@_(LhZdnmSG~PoV?>J#@N)256ZfP?Aio+|CxU1AQnH?8%l2-i~&DLpb#d znnz^<8p!*-o}$nOL0-@u?LFM>iZs6+*iAR4ECzjpy?m1lMde1u#S|HRH`L!xzA8^M zdCJU#2M4Hm@jx<+>`Ldi2i;xriU%DTJwS?K)8_a(7{Q|q4s0JN?4n7JECX;Xpd%B- z4TA%_B zZCN@y&w1H@n+FpvH0v%8cCo7IX-AOmDz~loh@z*w!(-P?k-!d*DeM)u1HCh-o~@41 zXYuN+mU-uGOmAE_Ad4~7S$C-DncPk;ks2kP?_vG(tz6Ewv**=%SSl|wOG|b4l_;O3 z2DJW`B*ztbDM@x(v?P@4rif%{VXD1H^d_o`eWj|>SCoUi5QTT7=}?XktkkS?5Cz3z zTfsYj%c@|@mR0TYuwlbCxo@Vkb?0x~ylMUVRV#z_>o%<0DviY%iA^Kp#!Xv;bsK4K zd8L;tbxUkn9xN7h?CYl)53iR|UDM=ZjDi9b@!1@R^2(UbDEKK?PV?ACF)%I9(S(uu z79nyXf&C6mm1tng$clraJrvvzQsn7%7Y73*q$^O?fJj)Kp;x@bN5flJAwvhApa)r* zVQT8-T!n55FKE8dm1my0OnV5Rh_jLl0{UE1otjqUOdMj&>nhygv-zIWxFnHc_2y+8 zRt2jzt_%W^iRkR$RmKZezIEfW4eM4!-|(_Xg`hPX&kt6u4V1&$m7Bd_&H7Etm#q&r zt)^jTYe44&)~^a=P@**xUbs`qs1{|?2Z=ywwo+Q-p-GqTuUWrt`HG;uZGIaab5Qk| z9@sk4!YU~2k$_zSN%+wsJIzIWHX>iy!L3KZMT1>?+d|FB;cRYTko0HKZXixP6!P%E z#<7x$Et3kK3B{3dsD*VMj^9|LT1;qK*Z>=05)NVT;uyOS9>Jrsl2Qi5>Ut)trIgN< zvr%%HC&=uI3brLCQbn#(*g*&9vT@`Z9i&UWbWAU*XzraGB4Y@%5>u@^haw%qo1ANz z)Sf45XcZnNC=`~aA^%r&Gl^sE@K#(vopjZzRl&+l=d;0V-4v`_z9Cq@Y2%uD(IG!U z0@5lRIdxugjnRax6Xy!teaYeJLU0Tj%dfGT7o4wS$8sBqhv_;DQOuD zGisW*_g5$|)mf%mD<-qS5X}KJbA1{mVE|QpLm@Mm&u-);Q!`o}a9q=4BO>Qrsr-Gt z*R@XlRhRpsN~xQOOxYx6%?>q+kB*k)##D5f?v!Y(;wcaJ(sX7rTbay>%{As^aeb>R zJA~yJ(i<)O%4(C?sTRg#BKbaQ;4)b$LSMFtT#U)e&WYyhp~(VubUJa@m!_$LdR%EX z$Hm#ur%lR}LmEWLx9I+6z%gi`vqkY!B%(xNWpTe8_rgg?MOdL-g#s_A*))S}kydch znaRDUr+c81k7|x;JIVc97hjXDY^IaSg@G+RhEYE0=Sgo%wz5iA+;!d*Whk|x-bT$e zSQ-$YFgURFHluE*3sj{A_ckx6Y=B8()>+5axy&|tiM$c%g z1i=smBD5+Jh4VRT1+y!jlc;e~P)P$2I}DoeMsskD%q&S8AG>6-hN$(-= zqGJM0xp>XQ>6}(>c;plM7|oDbutKR1n5znfg4F9Ww0y}+#H3=JAqd2uUa)Liu*Pjf z8boNYi`FZkT2TPNUN%Gfn>jj}AL_y3CeT$Ytysg;NZqWSBqYsZX;h$qjfP1MOla*f z7wUQ(eQ8h-8m#O7&J3xXrFNjjCtLHTc-gX<0rFHt#a8R4fr}RK70C{W9br|ScVu?b zJS?}9X18pkT1bWcWq>&??TYk5**Yc0Y=Z)H-aF-%psA$P&fG=A zD`}UkpKZ*9Y_y!6kNK%)%99o{Gze*mmsn_rh9)=E9XSjU#gOO z3V74J<4O@4ZSe(NSuQ4!p@T;iGmrX^rPJl8s#Q5yn4Dteve$v>T;E;j$%4`Nl z-Ben=(e$*0W=*8K$hyKWHKafMksWSQYE2r1)w_jeq#{zpwX4fvmoDov>tk$ceD(eB8#;{^?mt`9*sE8zzb12-plYCX((y05<07mO(Z0xiffNeS1 z-eap_<7D+wO=#tzn;j9Ia^cTaMa@Mt74G4UzUHyH^gFJG&YiGQz5ea&V~cL*7k0EL zf-^tV9lUZ^$(b<;5!>GY@00NM&?G5B`$S$3k(Ohm4#lu?3_>lR*Jp!9{2m&Ub$OBev(ZKPoy$1I4BCbc~`TD<{CIlQ(*eX7z|U^Pq3CTd1Tkwkq)h5|pCWU|}uiH&a}?SR*^>>{pTC?Ju;^%n3|nqX#MoMWYAXt*`q55BwpgGIts$s5bJ-xdCvdHE zfYrlVDf$v&n(p}ESWvV{Cikwki$vFPlOQbt=eN8SysNr}ri zyJ+)6c$xdqKE|^OSzf-3_LFGJP+tgGU7$UhjIIihl$av~@PCsRWmNYew=UCat|pmy zWjFP;XkB|~;V%?9@%oe+pGZqhP9t432gP!<;)q_zwWmPV?K{#OI^@@VfJ#Q1p)rX& ziWbxGe^gc}8^?@eMxOTZK|8eu^)#~oNPaZpiqxe^Ghh}a<+6{l@ruS$-EpzQ4bL1H+J3jcHoeH7#{<6O?EHyiyvZEkio)M?p>@S}{k9yqb89HX9ET z7Gd!`mwDDh1|FexVaK&l+4aVJAe=okqhHrSGN6+(SEx+4$~EM$NvVy`ZYkuN<5nnH z{0arA|Vk(jo*7*yPG(+OXgg;52okBTZb7a-nxp)e{vhMP9YOkDZDZ`Ya zz98Hl^Lx+9P!<3DijaUmaS}yY85Cr%>=SN;>i)O40&-f2OKA+3_S%Q zl#@0Qvy*cM;ll+SKLx?g=9^VPaG9I~CMrpHslv60hJ%_(AUm$ga5KL_!7hoBC{}yFhZf^F;~+2FN>R-9VIQiO{_r z_@i=~?P%KY!birnf|FfsBTi^+{>TW7nQ9k#FppiH?37ctjNNSevVBC`Ls(^M2!@c5uNkT z?M$+1=wXd0C9R3mnu=pl;bBr(Rd`4smk_gEBX-1nRu{8n?ISZNi+8pw#9Nn8?5l!)hl%#=O?CgYM!;I{H|mTjby7Ky-Fx8ecAT_Y7U zroBDcRCn9GZsUy&c=q#JE3Swh0N@bNos)*6T3Lz;9fFZKRRSbxZ)sT!c75rZla-& zqpsD@TCN+QIb=Rhm_%l=C$<7UtEeUR(t zqjbVa7Ka>1OzWI{mM)5B^7IWtQAlei+W|N@C!-aA)|ZEGHh2vGR*%iu$}-w|)Au~} z*7%s3Jl9K}n_{YH3CxH0@^Wb3#wxX~HL44)Z%J^2#&{%-s#e$gTVn%Za%m!UX!(Nn zx>Q|lz7Md&507D0ooMt4J zbV?Vd#J!iN?-~qY%Zw;Q0%qLk>5Zu(k4Am6wM^S$^uWdHz7DV3)BjOD@Qmwkc?ODB zNcx?QK6#!R<-^5bJDqkgarR59Ojbt=4Yv2m+n^R)%4-hZoDV*uBS_1Tz}zg3ns`sY z-aTY)Lh*KJ^T`E7NW&3EUoEOad$nVrsL`ySPWuT{#HJ?3mUM`W?h;(T>lTH#9DqI*L z!df`+No`&~#ka@N?$`iruv=0>FMHM1Rif`MK#KR??O6o01gX;=$;9k2%9b`dc=}Bn zQTh#<|Ns8-&nEC!x!Tum7N`1@^1LDd`exe5g|B_BV<*xRe?_e2zjmrmDbKqWz+6c+ z{@`mu>%by<3g;i4>dU)P%;T4IaUEHARzAM&*t>u* z7SZzWo9R=^^Y+b@n|Bqy&s9^(!=CwmDgApjB>%?O`3!p-Une*3H+r+5hpd-lBeXy$F}@BfpRQ?X&QO*;=*Am5{%UKl|yCP1MMII*!km->>!W zK*MnV<;%)7JHCmqaQP#&GsM?OLG$-Xs`1D2+x;)}DxBY=y(+nin%_6Uz{2v`eL7_h z=eOUB_RE^Tb{aC`mWU?3Lnt%zvSRG_AQHE0{)wZbzt-U9pNaC54qwZEr-QSseA)e2 zj1aF(??!o2ll&9^tnzQxn~~ScHDFjZk8WQgLhCo?m)O5MDwYi6 g=N~Hf>*@Q|!OV literal 0 HcmV?d00001 diff --git a/source/wham/src-HCD/testseqchains.f b/source/wham/src-HCD/testseqchains.f new file mode 100644 index 0000000..d2001e3 --- /dev/null +++ b/source/wham/src-HCD/testseqchains.f @@ -0,0 +1,33 @@ + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + integer i,ii,iii,ires + integer tperm,iperm + iout=6 + read (*,*) nres,(itype(i),i=1,nres) + call seq2chains(nres,itype,nchain,chain_length,chain_border, + & ireschain) + print *,"nres",nres," nchain",nchain + do i=1,nchain + print *,"chain",i,chain_length(i),chain_border(1,i), + & chain_border(2,i) + enddo + print *,"ireschain" + do i=1,nres + print *,i,ireschain(i) + enddo + call chain_symmetry(nchain,nres,itype,chain_border, + & chain_length,npermchain,tabpermchain) + print *,"ireschain permutations" + do i=1,nres + print '(60i4)',i,(tperm(ireschain(i),ii,tabpermchain), + & ii=1,npermchain) + enddo + print *,"residue permutations" + do i=1,nres + print '(60i4)',i,(iperm(i,ii),ii=1,npermchain) + enddo + stop + end diff --git a/source/wham/src-HCD/timing.F b/source/wham/src-HCD/timing.F new file mode 100644 index 0000000..de9d5ca --- /dev/null +++ b/source/wham/src-HCD/timing.F @@ -0,0 +1,238 @@ +C $Date: 1994/10/05 16:41:52 $ +C $Revision: 2.2 $ +C +C +C + subroutine set_timers +c + implicit none + double precision tcpu + include 'COMMON.TIME1' +#ifdef MP + include 'mpif.h' +#endif +C Diminish the assigned time limit a little so that there is some time to +C end a batch job +c timlim=batime-150.0 +C Calculate the initial time, if it is not zero (e.g. for the SUN). + stime=tcpu() +cd print *,' in SET_TIMERS stime=',stime + return + end +C------------------------------------------------------------------------------ + logical function stopx(nf) +C This function returns .true. if one of the following reasons to exit SUMSL +C occurs. The "reason" code is stored in WHATSUP passed thru a COMMON block: +C +C... WHATSUP = 0 - go on, no reason to stop. Stopx will return .false. +C... 1 - Time up in current node; +C... 2 - STOP signal was received from another node because the +C... node's task was accomplished (parallel only); +C... -1 - STOP signal was received from another node because of error; +C... -2 - STOP signal was received from another node, because +C... the node's time was up. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + integer nf + logical ovrtim +#ifdef MP + include 'mpif.h' + include 'COMMON.INFO' +#endif + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer Kwita + +cd print *,'Processor',MyID,' NF=',nf +#ifndef MPI + if (ovrtim()) then +C Finish if time is up. + stopx = .true. + WhatsUp=1 +#ifdef MPL + else if (mod(nf,100).eq.0) then +C Other processors might have finished. Check this every 100th function +C evaluation. +C Master checks if any other processor has sent accepted conformation(s) to it. + if (MyID.ne.MasterID) call receive_mcm_info + if (MyID.eq.MasterID) call receive_conf +cd print *,'Processor ',MyID,' is checking STOP: nf=',nf + call recv_stop_sig(Kwita) + if (Kwita.eq.-1) then + write (iout,'(a,i4,a,i5)') 'Processor', + & MyID,' has received STOP signal in STOPX; NF=',nf + write (*,'(a,i4,a,i5)') 'Processor', + & MyID,' has received STOP signal in STOPX; NF=',nf + stopx=.true. + WhatsUp=2 + elseif (Kwita.eq.-2) then + write (iout,*) + & 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.' + write (*,*) + & 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.' + WhatsUp=-2 + stopx=.true. + else if (Kwita.eq.-3) then + write (iout,*) + & 'Processor',MyID,' received ERROR-STOP signal in SUMSL.' + write (*,*) + & 'Processor',MyID,' received ERROR-STOP signal in SUMSL.' + WhatsUp=-1 + stopx=.true. + else + stopx=.false. + WhatsUp=0 + endif +#endif + else + stopx = .false. + WhatsUp=0 + endif +#else + stopx=.false. +#endif + +#ifdef OSF +c Check for FOUND_NAN flag + if (FOUND_NAN) then + write(iout,*)" *** stopx : Found a NaN" + stopx=.true. + endif +#endif + + return + end +C-------------------------------------------------------------------------- + logical function ovrtim() + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + real*8 tcpu +#ifdef MPI + include "mpif.h" + curtim = MPI_Wtime()-walltime +#else + curtim= tcpu() +#endif +C curtim is the current time in seconds. +c write (iout,*) "curtim",curtim," timlim",timlim," safety",safety + if (curtim .ge. timlim - safety) then + write (iout,'(a,f10.2,a,f10.2,a,f10.2,a)') + & "***************** Elapsed time (",curtim, + & " s) is within the safety limit (",safety, + & " s) of the allocated time (",timlim," s). Terminating." + ovrtim=.true. + else + ovrtim=.false. + endif + return + end +************************************************************************** + double precision function tcpu() + include 'COMMON.TIME1' +#ifdef ES9000 +**************************** +C Next definition for EAGLE (ibm-es9000) + real*8 micseconds + integer rcode + tcpu=cputime(micseconds,rcode) + tcpu=(micseconds/1.0E6) - stime +**************************** +#endif +#ifdef SUN +**************************** +C Next definitions for sun + REAL*8 ECPU,ETIME,ETCPU + dimension tarray(2) + tcpu=etime(tarray) + tcpu=tarray(1) +**************************** +#endif +#ifdef KSR +**************************** +C Next definitions for ksr +C this function uses the ksr timer ALL_SECONDS from the PMON library to +C return the elapsed time in seconds + tcpu= all_seconds() - stime +**************************** +#endif +#ifdef SGI +**************************** +C Next definitions for sgi + real timar(2), etime + seconds = etime(timar) +Cd print *,'seconds=',seconds,' stime=',stime +C usrsec = timar(1) +C syssec = timar(2) + tcpu=seconds - stime +**************************** +#endif + +#ifdef LINUX +**************************** +C Next definitions for sgi + real timar(2), etime + seconds = etime(timar) +Cd print *,'seconds=',seconds,' stime=',stime +C usrsec = timar(1) +C syssec = timar(2) + tcpu=seconds - stime +**************************** +#endif + + +#ifdef CRAY +**************************** +C Next definitions for Cray +C call date(curdat) +C curdat=curdat(1:9) +C call clock(curtim) +C curtim=curtim(1:8) + cpusec = second() + tcpu=cpusec - stime +**************************** +#endif +#ifdef AIX +**************************** +C Next definitions for RS6000 + integer*4 i1,mclock + i1 = mclock() + tcpu = (i1+0.0D0)/100.0D0 +#endif +#ifdef WINPGI +**************************** +c next definitions for windows NT Digital fortran + real time_real + call cpu_time(time_real) + tcpu = time_real +#endif +#ifdef WINIFL +**************************** +c next definitions for windows NT Digital fortran + real time_real + call cpu_time(time_real) + tcpu = time_real +#endif + + return + end +C--------------------------------------------------------------------------- + subroutine dajczas(rntime,hrtime,mintime,sectime) + include 'COMMON.IOUNITS' + real*8 rntime,hrtime,mintime,sectime + hrtime=rntime/3600.0D0 + hrtime=aint(hrtime) + mintime=aint((rntime-3600.0D0*hrtime)/60.0D0) + sectime=aint((rntime-3600.0D0*hrtime-60.0D0*mintime)+0.5D0) + if (sectime.eq.60.0D0) then + sectime=0.0D0 + mintime=mintime+1.0D0 + endif + ihr=hrtime + imn=mintime + isc=sectime + write (iout,328) ihr,imn,isc + 328 FORMAT(//'***** Computation time: ',I4 ,' hours ',I2 , + 1 ' minutes ', I2 ,' seconds *****') + return + end diff --git a/source/wham/src-HCD/timing.F.org b/source/wham/src-HCD/timing.F.org new file mode 100644 index 0000000..1012457 --- /dev/null +++ b/source/wham/src-HCD/timing.F.org @@ -0,0 +1,163 @@ +C $Date: 1994/10/05 16:41:52 $ +C $Revision: 2.2 $ +C +C +C + subroutine set_timers +c + implicit none + double precision tcpu + include 'COMMON.TIME1' +C Diminish the assigned time limit a little so that there is some time to +C end a batch job +c timlim=batime-150.0 +C Calculate the initial time, if it is not zero (e.g. for the SUN). + stime=tcpu() +cd print *,' in SET_TIMERS stime=',stime + return + end +C------------------------------------------------------------------------------ + logical function stopx(nf) +C This function returns .true. in case of time up on the master node. + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + integer nf + logical ovrtim +#ifdef MPI + include 'mpif.h' + include 'COMMON.MPI' +#endif + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + if (ovrtim()) then +C Finish if time is up. + stopx = .true. + WhatsUp=1 + else if (cutoffviol) then + stopx = .true. + WhatsUp=2 + else + stopx=.false. + endif + return + end +C-------------------------------------------------------------------------- + logical function ovrtim() + implicit none + include 'COMMON.TIME1' + real*8 tcpu,curtim + curtim= tcpu() +c print *,'curtim=',curtim,' timlim=',timlim +C curtim is the current time in seconds. +c ovrtim=(curtim .ge. timlim - safety ) +c ovrtim does not work sometimes and crashes the program ! CHUUUJ ! +c setting always to false + ovrtim=.false. + return + end +************************************************************************** + double precision function tcpu() + implicit none + include 'COMMON.TIME1' +#ifdef ES9000 +**************************** +C Next definition for EAGLE (ibm-es9000) + real*8 micseconds + integer rcode + tcpu=cputime(micseconds,rcode) + tcpu=(micseconds/1.0E6) - stime +**************************** +#endif +#ifdef SUN +**************************** +C Next definitions for sun + REAL*8 ECPU,ETIME,ETCPU + dimension tarray(2) + tcpu=etime(tarray) + tcpu=tarray(1) +**************************** +#endif +#ifdef KSR +**************************** +C Next definitions for ksr +C this function uses the ksr timer ALL_SECONDS from the PMON library to +C return the elapsed time in seconds + tcpu= all_seconds() - stime +**************************** +#endif +#ifdef SGI +**************************** +C Next definitions for sgi + real timar(2), etime, seconds + seconds = etime(timar) +Cd print *,'seconds=',seconds,' stime=',stime +C usrsec = timar(1) +C syssec = timar(2) + tcpu=seconds - stime +**************************** +#endif + +#ifdef LINUX +**************************** +C Next definitions for sgi + real timar(2), etime, seconds + seconds = etime(timar) +Cd print *,'seconds=',seconds,' stime=',stime +C usrsec = timar(1) +C syssec = timar(2) + tcpu=seconds - stime +**************************** +#endif + + +#ifdef CRAY +**************************** +C Next definitions for Cray +C call date(curdat) +C curdat=curdat(1:9) +C call clock(curtim) +C curtim=curtim(1:8) + cpusec = second() + tcpu=cpusec - stime +**************************** +#endif +#ifdef AIX +**************************** +C Next definitions for RS6000 + integer*4 i1,mclock + i1 = mclock() + tcpu = (i1+0.0D0)/100.0D0 +#endif +#ifdef WIN +**************************** +c next definitions for windows NT Digital fortran + real time_real + call cpu_time(time_real) + tcpu = time_real +#endif + + return + end +C--------------------------------------------------------------------------- + subroutine dajczas(rntime,hrtime,mintime,sectime) + implicit none + include 'COMMON.IOUNITS' + integer ihr,imn,isc + real*8 rntime,hrtime,mintime,sectime + hrtime=rntime/3600.0D0 + hrtime=aint(hrtime) + mintime=aint((rntime-3600.0D0*hrtime)/60.0D0) + sectime=aint((rntime-3600.0D0*hrtime-60.0D0*mintime)+0.5D0) + if (sectime.eq.60.0D0) then + sectime=0.0D0 + mintime=mintime+1.0D0 + endif + ihr=hrtime + imn=mintime + isc=sectime + write (iout,328) ihr,imn,isc + 328 FORMAT(//'***** Computation time: ',I4 ,' hours ',I2 , + 1 ' minutes ', I2 ,' seconds *****') + return + end diff --git a/source/wham/src-HCD/wham_calc1.F b/source/wham/src-HCD/wham_calc1.F new file mode 100644 index 0000000..31de33e --- /dev/null +++ b/source/wham/src-HCD/wham_calc1.F @@ -0,0 +1,1554 @@ + subroutine WHAM_CALC(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 + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + integer nGridT + parameter (NGridT=400) + integer MaxBinRms,MaxBinRgy + parameter (MaxBinRms=100,MaxBinRgy=100) +c integer MaxHdim +c parameter (MaxHdim=200) + integer maxinde + parameter (maxinde=200) +#ifdef MPI + include "mpif.h" + include "COMMON.MPI" + integer ierror,errcode,status(MPI_STATUS_SIZE) +#endif + include "COMMON.CONTROL" + include "COMMON.IOUNITS" + include "COMMON.FREE" + include "COMMON.ENERGIES" + include "COMMON.HOMOLOGY" + include "COMMON.FFIELD" + include "COMMON.SBRIDGE" + include "COMMON.PROT" + include "COMMON.ENEPS" + include "COMMON.SHIELD" + integer MaxPoint,MaxPointProc + parameter (MaxPoint=MaxStr, + & MaxPointProc=MaxStr_Proc) + double precision finorm_max,potfac,entmin,entmax,expfac,vf + parameter (finorm_max=1.0d0) + 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,liczba,iparm,nFi,indrgy,indrms + integer htot(0:MaxHdim),histent(0:2000) + double precision v(MaxPointProc,MaxR,MaxT_h,Max_Parm) + double precision energia(0:max_ene) +#ifdef MPI + integer tmax_t,upindE_p + double precision fi_p(MaxR,MaxT_h,Max_Parm), + & fimax_p(MaxR,MaxT_h,Max_Parm) + double precision sumW_p(0:nGridT,Max_Parm), + & sumE_p(0:nGridT,Max_Parm),sumEsq_p(0:nGridT,Max_Parm), + & sumQ_p(MaxQ1,0:nGridT,Max_Parm), + & sumQsq_p(MaxQ1,0:nGridT,Max_Parm), + & sumEQ_p(MaxQ1,0:nGridT,Max_Parm), + & sumEprim_p(MaxQ1,0:nGridT,Max_Parm), + & sumEbis_p(0:nGridT,Max_Parm) + double precision hfin_p(0:MaxHdim,maxT_h), + & hfin_ent_p(0:MaxHdim),histE_p(0:maxindE),sumH, + & hrmsrgy_p(0:MaxBinRgy,0:MaxBinRms,maxT_h) + double precision rgymin_t,rmsmin_t,rgymax_t,rmsmax_t + double precision potEmin_t,entmin_p,entmax_p + double precision ePMF,ePMF_q + double precision weimax_(0:ngridT) + integer histent_p(0:2000) + logical lprint /.true./ +#endif + double precision delta_T /1.0d0/ + double precision rgymin,rmsmin,rgymax,rmsmax + double precision sumW(0:NGridT,Max_Parm),sumE(0:NGridT,Max_Parm), + & sumEsq(0:NGridT,Max_Parm),sumQ(MaxQ1,0:NGridT,Max_Parm), + & sumQsq(MaxQ1,0:NGridT,Max_Parm),sumEQ(MaxQ1,0:NGridT,Max_Parm), + & sumEprim(0:NGridT,Max_Parm),sumEbis(0:NGridT,Max_Parm),betaT, + & weight,econstr + double precision fi(MaxR,maxT_h,Max_Parm), + & fimax(MaxR,maxT_h,Max_Parm), + & dd,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,weimax(0:nGridT,Max_Parm) + double precision 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 + double precision etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors, + & escloc,ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3, + & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor, + & eliptran,esaxs, + & ehomology_constr,edfadis,edfator,edfanei,edfabet + integer ind_point(maxpoint),upindE,indE + character*16 plik + character*1 licz1 + character*2 licz2 + character*3 licz3 + character*128 nazwa + integer ilen + external ilen + + 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 +C#define DEBUG +#ifdef MPI + do i=1,scount(me1) +#else + do i=1,ntot(islice) +#endif +c write (iout,*) "i",i," potE",(potE(i,j),j=1,nParmset) + 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 +c write (iout,*) "i",i," j",j," q",q(j,i)," ind_point", +c & ind_point(i) +c 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 + + write (iout,*) "potEmin before reduce",potEmin + 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 + liczba=t + do j=1,nQ + jj = mod(liczba,nbin1) + liczba=liczba/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) +c potEmin=potEmin_t/2 + potEmin=potEmin_t + 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 +c 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,22) +#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) + if (rescale_mode.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_mode.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 +c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft + else if (rescale_mode.eq.0) then + do l=1,6 + fT(l)=1.0d0 + enddo + else + write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE", + & rescale_mode + call flush(iout) + return1 + endif + evdw=enetb(1,i,iparm) + evdw_t=enetb(21,i,iparm) +#ifdef SCP14 + evdw2_14=enetb(17,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) + eturn6=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) + esccor=enetb(19,i,iparm) + edihcnstr=enetb(20,i,iparm) + eliptran=enetb(22,i,iparm) + esaxs=enetb(26,i,iparm) + ehomology_constr=enetb(27,i,iparm) + edfadis=enetb(28,i,iparm) + edfator=enetb(29,i,iparm) + edfanei=enetb(30,i,iparm) + edfabet=enetb(31,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,esaxs, + & ehomology_constr,edfadis,edfator,edfanei,edfabet +#endif + +#ifdef SPLITELE + if (shield_mode.gt.0) then + etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2 + & +ft(1)*welec*ees + & +ft(1)*wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +! & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs + & +wdfa_dist*edfadis + & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet + else + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees + & +wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs + & +wdfa_dist*edfadis + & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet + endif +#else + if (shield_mode.gt.0) then + etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2 + & +ft(1)*welec*(ees+evdw1) + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs + & +wdfa_dist*edfadis + & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet + else + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 + & +ft(1)*welec*(ees+evdw1) + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs + & +wdfa_dist*edfadis + & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet + endif + +#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) + endif +#endif +#ifdef DEBUG + write (iout,*) "homol_nset",homol_nset,nR(ib,iparm) +#endif + if (homol_nset.gt.1) then + + do kk=1,nR(ib,iparm) + Econstr=waga_homology(kk)*ehomology_constr + v(i,kk,ib,iparm)= + & -beta_h(ib,iparm)*(etot+Econstr) +#ifdef DEBUG + write (iout,'(4i5,4e15.5)') i,kk,ib,iparm, + & etot,Econstr,v(i,kk,ib,iparm) +#endif + enddo ! kk + + else + + etot=etot+ehomology_constr + + do kk=1,nR(ib,iparm) + Econstr=0.0d0 + do j=1,nQ + dd = q(j,i) + Econstr=Econstr+Kh(j,kk,ib,iparm) + & *(dd-q0(j,kk,ib,iparm))**2 + enddo +c Adaptive potential contribution + if (adaptive) then + call PMF_energy(q(1,i),ib,kk,iparm,ePMF,ePMF_q) + Econstr=Econstr+ePMF + endif + 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 + + endif + + 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 + fimax_p(ii,iib,iparm)=v(1,ii,iib,iparm)+entfac(1) + do t=2,scount(me) + if(v(t,ii,iib,iparm)+entfac(t).gt.fimax_p(ii,iib,iparm)) + & fimax_p(ii,iib,iparm)=v(t,ii,iib,iparm)+entfac(t) + enddo +#else + fimax(ii,iib,iparm)=v(1,ii,iib,iparm)+entfac(1) + do t=2,ntot(islice) + if(v(t,ii,iib,iparm)+entfac(t).gt.fimax(ii,iib,iparm)) + & fimax(ii,iib,iparm)=v(t,ii,iib,iparm)+entfac(t) + enddo +#endif + enddo ! ii + enddo ! iib + enddo ! iparm +#ifdef MPI + call MPI_AllReduce(fimax_p(1,1,1),fimax(1,1,1), + & maxR*MaxT_h*nParmSet,MPI_DOUBLE_PRECISION, + & MPI_MAX,WHAM_COMM,IERROR) +#endif + 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)-fimax(ii,iib,iparm)) +#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)-fimax(ii,iib,iparm)) + 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 +c write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet, +c & maxR*MaxT_h*nParmSet +c write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD, +c & " 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))-fimax(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 +c 8/26/05 entropy distribution +#ifdef MPI + entmin_p=1.0d10 + entmax_p=-1.0d10 + do t=1,scount(me1) +c 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 + 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) + ientmax=entmax-entmin + if (ientmax.gt.2000) ientmax=2000 + write (iout,*) "entmin",entmin," entmax",entmax," ientmax",ientmax + call flush(iout) + do t=1,scount(me1) +c 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 + do iparm=1,nParmSet + + call restore_parm(iparm) +c +C Histograms +c +#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 +#ifdef MPI + do t=1,scount(me1) +#else + do t=1,ntot(islice) +#endif + 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 +c +c Thermo and ensemble averages +c + do k=0,nGridT + betaT=startGridT+k*delta_T + call temp_scalfac(betaT,ft,ftprim,ftbis,*10) +c write (iout,*) "ftprim",ftprim +c write (iout,*) "ftbis",ftbis + betaT=1.0d0/(1.987D-3*betaT) +c 7/10/18 AL Determine the max Botzmann weights for each temerature + call sum_ene(1,iparm,ft,etot) + weimax(k,iparm)=-betaT*(etot-potEmin)+entfac(1) +c write (iout,*) "k",k," t",1," weight",weimax(k,iparm) +#ifdef MPI + do t=2,scount(me1) +#else + do t=2,ntot(islice) +#endif + call sum_ene(t,iparm,ft,etot) + weight=-betaT*(etot-potEmin)+entfac(t) +c write (iout,*) "k",k," t",t," weight",weight + if (weight.gt.weimax(k,iparm)) weimax(k,iparm)=weight + enddo +#ifdef MPI + enddo +#ifdef DEBUG + write (iout,*) "weimax before REDUCE" + write (iout,*) (weimax(k,iparm),k=0,ngridt) +#endif + do k=0,nGridT + weimax_(k)=weimax(k,iparm) + enddo + call MPI_Allreduce(weimax_(0),weimax(0,iparm),nGridT+1, + & MPI_DOUBLE_PRECISION,MPI_MAX,WHAM_COMM,IERROR) +#ifdef DEBUG + write (iout,*) "weimax" + write (iout,*) (weimax(k,iparm),k=0,ngridt) +#endif + do k=0,nGridT + temper=startGridT+k*delta_T + betaT=1.0d0/(1.987D-3*temper) + call temp_scalfac(temper,ft,ftprim,ftbis,*10) + 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 +c write (iout,'(2i5,20f8.2)') t,t,(enetb(k,t,iparm),k=1,18) +c call restore_parm(iparm) + call sum_ene_deriv(t,iparm,ft,ftprim,ftbis,etot,eprim,ebis) + weight=dexp(-betaT*(etot-potEmin)+entfac(t)-weimax(k,iparm)) +#ifdef DEBUG + write (iout,*) "iparm",iparm," t",t," betaT",betaT, + & " etot",etot," entfac",entfac(t)," boltz", + & -betaT*(etot-potEmin)+entfac(t)," weimax",weimax(k,iparm), + & " 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 ! t + enddo ! k + 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 + liczba=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(liczba,nbin1) + liczba=liczba/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))-weimax(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 + liczba=t + jj = mod(liczba,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 +C#undef DEBUG + 10 return1 + end +c------------------------------------------------------------------------ + subroutine temp_scalfac(betaT,ft,ftprim,ftbis,*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.FREE" + include "COMMON.CONTROL" + include "COMMON.FREE" + include "COMMON.IOUNITS" + double precision fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl, + & kfac/2.4d0/,T0/300.0d0/,startGridT/200.0d0/, + & logfac,tanhT,betaT,denom,eplus,eminus + integer l + if (rescale_mode.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_mode.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_mode.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_mode + call flush(iout) + return1 + endif + return + end +c-------------------------------------------------------------------- + subroutine sum_ene(t,iparm,ft,etot) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + include 'COMMON.CONTROL' + include 'COMMON.FFIELD' + include "COMMON.SBRIDGE" + include "COMMON.ENERGIES" + include "COMMON.IOUNITS" + integer t,iparm + double precision fT(6) + double precision etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors, + & escloc,ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3, + & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor, + & eliptran,esaxs + evdw=enetb(21,t,iparm) + evdw_t=enetb(1,t,iparm) +#ifdef SCP14 + evdw2_14=enetb(17,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) + eturn6=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) + esccor=enetb(19,t,iparm) + edihcnstr=enetb(20,t,iparm) + eliptran=enetb(22,t,iparm) + esaxs=enetb(26,t,iparm) +#ifdef SPLITELE + if (shield_mode.gt.0) then + etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2 + & +ft(1)*welec*ees + & +ft(1)*wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs + else + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees + & +wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs + endif +#else + if (shield_mode.gt.0) then + etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2 + & +ft(1)*welec*(ees+evdw1) + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs + else + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 + & +ft(1)*welec*(ees+evdw1) + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs + endif +#endif + return + end +c-------------------------------------------------------------------- + subroutine sum_ene_deriv(t,iparm,ft,ftprim,ftbis,etot,eprim,ebis) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + include 'COMMON.CONTROL' + include 'COMMON.FFIELD' + include "COMMON.SBRIDGE" + include 'COMMON.ENERGIES' + include "COMMON.HOMOLOGY" + include "COMMON.IOUNITS" + integer t,iparm + double precision fT(6),fTprim(6),fTbis(6), + & eprim,ebis,temper + double precision etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors, + & escloc,ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3, + & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor, + & eliptran,esaxs,ehomology_constr,edfadis,edfator,edfanei,edfabet + evdw=enetb(21,t,iparm) + evdw_t=enetb(1,t,iparm) +#ifdef SCP14 + evdw2_14=enetb(17,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) + eturn6=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) + esccor=enetb(19,t,iparm) + edihcnstr=enetb(20,t,iparm) + eliptran=enetb(22,t,iparm) + esaxs=enetb(26,t,iparm) + ehomology_constr=enetb(27,t,iparm) + edfadis=enetb(28,t,iparm) + edfator=enetb(29,t,iparm) + edfanei=enetb(30,t,iparm) + edfabet=enetb(31,t,iparm) +#ifdef SPLITELE + if (shield_mode.gt.0) then + etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2 + & +ft(1)*welec*ees + & +ft(1)*wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs + eprim=ftprim(1)*(ft(6)*evdw_t+evdw) +C & +ftprim(6)*evdw_t + & +ftprim(1)*wscp*evdw2 + & +ftprim(1)*welec*ees + & +ftprim(1)*wvdwpp*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*eturn6+ + & ftprim(2)*wel_loc*eel_loc+ftprim(2)*wtor_d*etors_d+ + & ftprim(1)*wsccor*esccor + ebis=ftbis(1)*wsc*(evdw+ft(6)*evdw_t) + & +ftbis(1)*wscp*evdw2+ + & ftbis(1)*welec*ees + & +ftbis(1)*wvdwpp*evdw + & +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*eturn6+ + & 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 + & +wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs + 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*eturn6+ + & 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*eturn6+ + & ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ + & ftbis(1)*wsccor*esccor + endif +#else + if (shield_mode.gt.0) then + etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2 + & +ft(1)*welec*(ees+evdw1) + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc +c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs + eprim=ftprim(1)*(evdw+ft(6)*evdw_t) + & +ftprim(1)*welec*(ees+evdw1) + & +ftprim(1)*wtor*etors+ + & ftprim(1)*wscp*evdw2+ + & 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*eturn6+ + & ftprim(2)*wel_loc*eel_loc+ftprim(2)*wtor_d*etors_d+ + & ftprim(1)*wsccor*esccor + ebis= ftbis(1)*(evdw+ft(6)*evdw_t) + & +ftbis(1)*wscp*evdw2 + & +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*eturn6+ + & ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ + & ftprim(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 +c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs + 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*eturn6+ + & 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*eturn6+ + & ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ + & ftprim(1)*wsccor*esccor + endif +#endif + return + end diff --git a/source/wham/src-HCD/wham_calc1.F.safe b/source/wham/src-HCD/wham_calc1.F.safe new file mode 100644 index 0000000..4400ba3 --- /dev/null +++ b/source/wham/src-HCD/wham_calc1.F.safe @@ -0,0 +1,1298 @@ + subroutine WHAM_CALC(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 + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + integer nGridT + parameter (NGridT=400) + integer MaxBinRms,MaxBinRgy + parameter (MaxBinRms=100,MaxBinRgy=100) +c integer MaxHdim +c parameter (MaxHdim=200) + integer maxinde + parameter (maxinde=200) +#ifdef MPI + include "mpif.h" + include "COMMON.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" + include "COMMON.SHIELD" + integer MaxPoint,MaxPointProc + parameter (MaxPoint=MaxStr, + & MaxPointProc=MaxStr_Proc) + double precision finorm_max,potfac,entmin,entmax,expfac,vf + parameter (finorm_max=1.0d0) + 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,liczba,iparm,nFi,indrgy,indrms + integer htot(0:MaxHdim),histent(0:2000) + double precision v(MaxPointProc,MaxR,MaxT_h,Max_Parm) + double precision energia(0:max_ene) +#ifdef MPI + integer tmax_t,upindE_p + double precision fi_p(MaxR,MaxT_h,Max_Parm) + double precision sumW_p(0:nGridT,Max_Parm), + & sumE_p(0:nGridT,Max_Parm),sumEsq_p(0:nGridT,Max_Parm), + & sumQ_p(MaxQ1,0:nGridT,Max_Parm), + & sumQsq_p(MaxQ1,0:nGridT,Max_Parm), + & sumEQ_p(MaxQ1,0:nGridT,Max_Parm), + & sumEprim_p(MaxQ1,0:nGridT,Max_Parm), + & sumEbis_p(0:nGridT,Max_Parm) + double precision hfin_p(0:MaxHdim,maxT_h), + & hfin_ent_p(0:MaxHdim),histE_p(0:maxindE),sumH, + & hrmsrgy_p(0:MaxBinRgy,0:MaxBinRms,maxT_h) + double precision rgymin_t,rmsmin_t,rgymax_t,rmsmax_t + double precision potEmin_t,entmin_p,entmax_p + double precision ePMF,ePMF_q + integer histent_p(0:2000) + logical lprint /.true./ +#endif + double precision delta_T /1.0d0/ + double precision rgymin,rmsmin,rgymax,rmsmax + double precision sumW(0:NGridT,Max_Parm),sumE(0:NGridT,Max_Parm), + & sumEsq(0:NGridT,Max_Parm),sumQ(MaxQ1,0:NGridT,Max_Parm), + & sumQsq(MaxQ1,0:NGridT,Max_Parm),sumEQ(MaxQ1,0:NGridT,Max_Parm), + & sumEprim(0:NGridT,Max_Parm),sumEbis(0:NGridT,Max_Parm),betaT, + & weight,econstr + double precision fi(MaxR,maxT_h,Max_Parm), + & dd,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 + double precision 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 + double precision etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors, + & escloc,ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3, + & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor, + & eliptran,esaxs + + integer ind_point(maxpoint),upindE,indE + character*16 plik + character*1 licz1 + character*2 licz2 + character*3 licz3 + character*128 nazwa + integer ilen + external ilen + + 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 +C#define DEBUG +#ifdef MPI + do i=1,scount(me1) +#else + do i=1,ntot(islice) +#endif +c write (iout,*) "i",i," potE",(potE(i,j),j=1,nParmset) + 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 +c write (iout,*) "i",i," j",j," q",q(j,i)," ind_point", +c & ind_point(i) +c 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 + + write (iout,*) "potEmin before reduce",potEmin + 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 + liczba=t + do j=1,nQ + jj = mod(liczba,nbin1) + liczba=liczba/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) +c potEmin=potEmin_t/2 + potEmin=potEmin_t + 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 +c 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,22) +#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,wsaxs +#endif + do ib=1,nT_h(iparm) + if (rescale_mode.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_mode.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 +c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft + else if (rescale_mode.eq.0) then + do l=1,6 + fT(l)=1.0d0 + enddo + else + write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE", + & rescale_mode + call flush(iout) + return1 + endif + evdw=enetb(1,i,iparm) + evdw_t=enetb(21,i,iparm) +#ifdef SCP14 + evdw2_14=enetb(17,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) + eturn6=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) + esccor=enetb(19,i,iparm) + edihcnstr=enetb(20,i,iparm) + eliptran=enetb(22,i,iparm) + esaxs=enetb(26,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,esaxs +#endif + +#ifdef SPLITELE + if (shield_mode.gt.0) then + etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2 + & +ft(1)*welec*ees + & +ft(1)*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+wliptran*eliptran+wsaxs*esaxs + else + 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+wliptran*eliptran+wsaxs*esaxs + endif +#else + if (shield_mode.gt.0) then + etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*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+wliptran*eliptran+wsaxs*esaxs + 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+wliptran*eliptran+wsaxs*esaxs + endif + +#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) + endif +#endif + do kk=1,nR(ib,iparm) + Econstr=0.0d0 + do j=1,nQ + dd = q(j,i) + Econstr=Econstr+Kh(j,kk,ib,iparm) + & *(dd-q0(j,kk,ib,iparm))**2 + enddo +c Adaptive potential contribution + if (adaptive) then + call PMF_energy(q(1,i),ib,kk,iparm,ePMF,ePMF_q) + Econstr=Econstr+ePMF + endif + 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 +c write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet, +c & maxR*MaxT_h*nParmSet +c write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD, +c & " 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 +c 8/26/05 entropy distribution +#ifdef MPI + entmin_p=1.0d10 + entmax_p=-1.0d10 + do t=1,scount(me1) +c 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 + 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) + ientmax=entmax-entmin + if (ientmax.gt.2000) ientmax=2000 + write (iout,*) "entmin",entmin," entmax",entmax," ientmax",ientmax + call flush(iout) + do t=1,scount(me1) +c 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 +c write (iout,*) "me1",me1," scount",scount(me1) + + 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 +c write (iout,'(2i5,20f8.2)') t,t,(enetb(k,t,iparm),k=1,18) + call restore_parm(iparm) + evdw=enetb(21,t,iparm) + evdw_t=enetb(1,t,iparm) +#ifdef SCP14 + evdw2_14=enetb(17,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) + eturn6=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) + esccor=enetb(19,t,iparm) + edihcnstr=enetb(20,t,iparm) + esaxs=enetb(26,i,iparm) + do k=0,nGridT + betaT=startGridT+k*delta_T + temper=betaT +c fT=T0/betaT +c ft=2*T0/(T0+betaT) + if (rescale_mode.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_mode.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_mode.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_mode + call flush(iout) + return1 + endif +c write (iout,*) "ftprim",ftprim +c write (iout,*) "ftbis",ftbis + betaT=1.0d0/(1.987D-3*betaT) +#ifdef SPLITELE + if (shield_mode.gt.0) then + etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2 + & +ft(1)*welec*ees + & +ft(1)*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+wliptran*eliptran+wsaxs*esaxs + eprim=ftprim(1)*(ft(6)*evdw_t+evdw) +C & +ftprim(6)*evdw_t + & +ftprim(1)*wscp*evdw2 + & +ftprim(1)*welec*ees + & +ftprim(1)*wvdwpp*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*eturn6+ + & ftprim(2)*wel_loc*eel_loc+ftprim(2)*wtor_d*etors_d+ + & ftprim(1)*wsccor*esccor + ebis=ftbis(1)*wsc*(evdw+ft(6)*evdw_t) + & +ftbis(1)*wscp*evdw2+ + & ftbis(1)*welec*ees + & +ftbis(1)*wvdwpp*evdw + & +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*eturn6+ + & 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 + & +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+wliptran*eliptran+wsaxs*esaxs + 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*eturn6+ + & 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*eturn6+ + & ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ + & ftbis(1)*wsccor*esccor + endif +#else + if (shield_mode.gt.0) then + etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*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+wliptran*eliptran+wsaxs*esaxs + eprim=ftprim(1)*(evdw+ft(6)*evdw_t) + & +ftprim(1)*welec*(ees+evdw1) + & +ftprim(1)*wtor*etors+ + & ftprim(1)*wscp*evdw2+ + & 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*eturn6+ + & ftprim(2)*wel_loc*eel_loc+ftprim(2)*wtor_d*etors_d+ + & ftprim(1)*wsccor*esccor + ebis= ftbis(1)*(evdw+ft(6)*evdw_t) + & +ftbis(1)*wscp*evdw2 + & +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*eturn6+ + & ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ + & ftprim(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*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr + & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr+wliptran*eliptran+wsaxs*esaxs + 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*eturn6+ + & 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*eturn6+ + & ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ + & ftprim(1)*wsccor*esccor + + endif + +#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 + liczba=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(liczba,nbin1) + liczba=liczba/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 + liczba=t + jj = mod(liczba,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 +C#undef DEBUG + end diff --git a/source/wham/src-HCD/wham_multparm.F b/source/wham/src-HCD/wham_multparm.F new file mode 100644 index 0000000..fd62f05 --- /dev/null +++ b/source/wham/src-HCD/wham_multparm.F @@ -0,0 +1,280 @@ + program WHAM_multparm +c Creation/update of the database of conformations + implicit none +#ifndef ISNAN + external proc_proc +#endif +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE + include "COMMON.MPI" +#endif + include "COMMON.IOUNITS" + include "COMMON.FREE" + include "COMMON.CONTROL" + include "COMMON.ALLPARM" + include "COMMON.PROT" + double precision rr,x(max_paropt) + integer idumm + integer i,ipar,islice +#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 +c 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 + call initialize + call openunits + call cinfo + write (iout,*) "calling read_general_data" + call read_general_data(*10) + write (iout,*) "read_general_data" + call flush(iout) + write (iout,*) "calling molread" + call molread(*10) + write (iout,*) "molread" + call flush(iout) + write (iout,*) "MAIN: constr_dist",constr_dist + if (constr_dist.gt.0) call read_dist_constr +#ifdef MPI +c write (iout,*) "Calling proc_groups" + call proc_groups +c write (iout,*) "proc_groups exited" +c call flush(iout) +#endif + 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) + if (adaptive) call PMFread +c write (iout,*) "Finished READ_EFREE" +c call flush(iout) + call read_protein_data(*10) +c write (iout,*) "Finished READ_PROTEIN_DATA" +c call flush(iout) + if (indpdb.gt.0) then + call promienie + call read_compar + call read_ref_structure(*10) + call proc_cont + call fragment_list + endif +C if (constr_dist.gt.0) call read_dist_constr +c write (iout,*) "Begin read_database" +c 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 + call enecalc(islice,*10) + write (iout,*) "enecalc OK" + call flush(iout) + call WHAM_CALC(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" + call MPI_Finalize( IERROR ) + stop + end +c------------------------------------------------------------------------------ +#ifdef MPI + subroutine proc_groups +C Split the processors into the Master and Workers group, if needed. + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + include "mpif.h" + include "COMMON.IOUNITS" + include "COMMON.MPI" + include "COMMON.FREE" + integer n,chunk,i,j,ii,remainder + integer kolor,key,ierror,errcode + logical lprint + lprint=.true. +C +C Split the communicator if independent runs for different parameter +C sets will be performed. +C + 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 + kolor = me/nprocs + key = mod(me,nprocs) + write (iout,*) "My old rank",me," kolor",kolor," key",key + call MPI_Comm_split(MPI_COMM_WORLD,kolor,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=kolor+1 + write (iout,*) "My parameter set is",myparm + call flush(iout) + else + myparm=nparmset + endif + Me1 = Me + Nprocs1 = Nprocs + return + end +c------------------------------------------------------------------------------ + subroutine work_partition(islice,lprint) +c 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 + integer n,chunk,i,j,ii,remainder + integer kolor,key,ierror,errcode + logical lprint +C +C Divide conformations between processors; the first and +C the last conformation to handle by ith processor is stored in +C indstart(i) and indend(i), respectively. +C +C First try to assign equal number of conformations to each processor. +C + n=ntot(islice) + write (iout,*) "n=",n + indstart(0)=1 + chunk = N/nprocs1 + scount(0) = chunk +c print *,"i",0," indstart",indstart(0)," scount", +c & scount(0) + do i=1,nprocs1-1 + indstart(i)=chunk+indstart(i-1) + scount(i)=scount(i-1) +c print *,"i",i," indstart",indstart(i)," scount", +c & scount(i) + enddo +C +C Determine how many conformations remained yet unassigned. +C + remainder=N-(indstart(nprocs1-1) + & +scount(nprocs1-1)-1) +c print *,"remainder",remainder +C +C Assign the remainder conformations to consecutive processors, starting +C from the lowest rank; this continues until the list is exhausted. +C + 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 + +c print *,"N",n," NTOT",ntot(islice) + if (N.ne.ntot(islice)) then + write (iout,*) "!!! Checksum error on processor",me, + & " slice",islice + 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 +#endif +#ifdef AIX + subroutine flush(iu) + call flush_(iu) + return + end +#endif diff --git a/source/wham/src-HCD/xdrf/CMakeLists.txt b/source/wham/src-HCD/xdrf/CMakeLists.txt new file mode 100644 index 0000000..26baa36 --- /dev/null +++ b/source/wham/src-HCD/xdrf/CMakeLists.txt @@ -0,0 +1,19 @@ +# +# CMake project file for UNRESPACK +# + +# m4 macro processor +add_custom_command( + OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/libxdrf.c + COMMAND m4 + ARGS ${CMAKE_CURRENT_SOURCE_DIR}/underscore.m4 ${CMAKE_CURRENT_SOURCE_DIR}/libxdrf.m4 > ${CMAKE_CURRENT_BINARY_DIR}/libxdrf.c + VERBATIM +) + +# add headers from current dir +include_directories(${CMAKE_CURRENT_SOURCE_DIR}) +# compile the libxdrf library +add_library(xdrf STATIC ${CMAKE_CURRENT_BINARY_DIR}/libxdrf.c ftocstr.c) +set(UNRES_XDRFLIB ${CMAKE_CURRENT_BINARY_DIR}/libxdrf.a PARENT_SCOPE) + +#add_dependencies( ${UNRES_BIN} xdrf ) diff --git a/source/wham/src-HCD/xdrf/Makefile b/source/wham/src-HCD/xdrf/Makefile new file mode 100644 index 0000000..02c29f6 --- /dev/null +++ b/source/wham/src-HCD/xdrf/Makefile @@ -0,0 +1,27 @@ +# This make file is part of the xdrf package. +# +# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl +# +# 2006 modified by Cezary Czaplewski + +# Set C compiler and flags for ARCH +CC = gcc +CFLAGS = -O + +M4 = m4 +M4FILE = underscore.m4 + +libxdrf.a: libxdrf.o ftocstr.o + ar cr libxdrf.a $? + +clean: + rm -f libxdrf.o ftocstr.o libxdrf.a + +ftocstr.o: ftocstr.c + $(CC) $(CFLAGS) -c ftocstr.c + +libxdrf.o: libxdrf.m4 $(M4FILE) + $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c + $(CC) $(CFLAGS) -c libxdrf.c + rm -f libxdrf.c + diff --git a/source/wham/src-HCD/xdrf/Makefile_jubl b/source/wham/src-HCD/xdrf/Makefile_jubl new file mode 100644 index 0000000..8dc35cf --- /dev/null +++ b/source/wham/src-HCD/xdrf/Makefile_jubl @@ -0,0 +1,31 @@ +# This make file is part of the xdrf package. +# +# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl +# +# 2006 modified by Cezary Czaplewski + +# Set C compiler and flags for ARCH +BGLSYS = /bgl/BlueLight/ppcfloor/bglsys + +CC = /usr/bin/blrts_xlc +CPPC = /usr/bin/blrts_xlc + +CFLAGS= -O2 -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 + +M4 = m4 +M4FILE = RS6K.m4 + +libxdrf.a: libxdrf.o ftocstr.o xdr_array.o xdr.o xdr_float.o xdr_stdio.o + ar cr libxdrf.a $? + +clean: + rm -f *.o libxdrf.a + +ftocstr.o: ftocstr.c + $(CC) $(CFLAGS) -c ftocstr.c + +libxdrf.o: libxdrf.m4 $(M4FILE) + $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c + $(CC) $(CFLAGS) -c libxdrf.c +# rm -f libxdrf.c + diff --git a/source/wham/src-HCD/xdrf/Makefile_linux b/source/wham/src-HCD/xdrf/Makefile_linux new file mode 100644 index 0000000..f03276e --- /dev/null +++ b/source/wham/src-HCD/xdrf/Makefile_linux @@ -0,0 +1,27 @@ +# This make file is part of the xdrf package. +# +# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl +# +# 2006 modified by Cezary Czaplewski + +# Set C compiler and flags for ARCH +CC = cc +CFLAGS = -O + +M4 = m4 +M4FILE = underscore.m4 + +libxdrf.a: libxdrf.o ftocstr.o + ar cr libxdrf.a $? + +clean: + rm -f libxdrf.o ftocstr.o libxdrf.a + +ftocstr.o: ftocstr.c + $(CC) $(CFLAGS) -c ftocstr.c + +libxdrf.o: libxdrf.m4 $(M4FILE) + $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c + $(CC) $(CFLAGS) -c libxdrf.c + rm -f libxdrf.c + diff --git a/source/wham/src-HCD/xdrf/RS6K.m4 b/source/wham/src-HCD/xdrf/RS6K.m4 new file mode 100644 index 0000000..0331d97 --- /dev/null +++ b/source/wham/src-HCD/xdrf/RS6K.m4 @@ -0,0 +1,20 @@ +divert(-1) +undefine(`len') +# +# do nothing special to FORTRAN function names +# +define(`FUNCTION',`$1') +# +# FORTRAN character strings are passed as follows: +# a pointer to the base of the string is passed in the normal +# argument list, and the length is passed by value as an extra +# argument, after all of the other arguments. +# +define(`ARGS',`($1`'undivert(1))') +define(`SAVE',`divert(1)$1`'divert(0)') +define(`STRING_ARG',`$1_ptr`'SAVE(`, $1_len')') +define(`STRING_ARG_DECL',`char * $1_ptr; int $1_len') +define(`STRING_LEN',`$1_len') +define(`STRING_PTR',`$1_ptr') +divert(0) + diff --git a/source/wham/src-HCD/xdrf/ftocstr.c b/source/wham/src-HCD/xdrf/ftocstr.c new file mode 100644 index 0000000..ed2113f --- /dev/null +++ b/source/wham/src-HCD/xdrf/ftocstr.c @@ -0,0 +1,35 @@ + + +int ftocstr(ds, dl, ss, sl) + char *ds, *ss; /* dst, src ptrs */ + int dl; /* dst max len */ + int sl; /* src len */ +{ + char *p; + + for (p = ss + sl; --p >= ss && *p == ' '; ) ; + sl = p - ss + 1; + dl--; + ds[0] = 0; + if (sl > dl) + return 1; + while (sl--) + (*ds++ = *ss++); + *ds = '\0'; + return 0; +} + + +int ctofstr(ds, dl, ss) + char *ds; /* dest space */ + int dl; /* max dest length */ + char *ss; /* src string (0-term) */ +{ + while (dl && *ss) { + *ds++ = *ss++; + dl--; + } + while (dl--) + *ds++ = ' '; + return 0; +} diff --git a/source/wham/src-HCD/xdrf/libxdrf.m4 b/source/wham/src-HCD/xdrf/libxdrf.m4 new file mode 100644 index 0000000..eebf199 --- /dev/null +++ b/source/wham/src-HCD/xdrf/libxdrf.m4 @@ -0,0 +1,1237 @@ +/*____________________________________________________________________________ + | + | libxdrf - portable fortran interface to xdr. some xdr routines + | are C routines for compressed coordinates + | + | version 1.1 + | + | This collection of routines is intended to write and read + | data in a portable way to a file, so data written on one type + | of machine can be read back on a different type. + | + | all fortran routines use an integer 'xdrid', which is an id to the + | current xdr file, and is set by xdrfopen. + | most routines have in integer 'ret' which is the return value. + | The value of 'ret' is zero on failure, and most of the time one + | on succes. + | + | There are three routines useful for C users: + | xdropen(), xdrclose(), xdr3dfcoord(). + | The first two replace xdrstdio_create and xdr_destroy, and *must* be + | used when you plan to use xdr3dfcoord(). (they are also a bit + | easier to interface). For writing data other than compressed coordinates + | you should use the standard C xdr routines (see xdr man page) + | + | xdrfopen(xdrid, filename, mode, ret) + | character *(*) filename + | character *(*) mode + | + | this will open the file with the given filename (string) + | and the given mode, it returns an id in xdrid, which is + | to be used in all other calls to xdrf routines. + | mode is 'w' to create, or update an file, for all other + | values of mode the file is opened for reading + | + | you need to call xdrfclose to flush the output and close + | the file. + | Note that you should not use xdrstdio_create, which comes with the + | standard xdr library + | + | xdrfclose(xdrid, ret) + | flush the data to the file, and closes the file; + | You should not use xdr_destroy (which comes standard with + | the xdr libraries. + | + | xdrfbool(xdrid, bp, ret) + | integer pb + | + | This filter produces values of either 1 or 0 + | + | xdrfchar(xdrid, cp, ret) + | character cp + | + | filter that translate between characters and their xdr representation + | Note that the characters in not compressed and occupies 4 bytes. + | + | xdrfdouble(xdrid, dp, ret) + | double dp + | + | read/write a double. + | + | xdrffloat(xdrid, fp, ret) + | float fp + | + | read/write a float. + | + | xdrfint(xdrid, ip, ret) + | integer ip + | + | read/write integer. + | + | xdrflong(xdrid, lp, ret) + | integer lp + | + | this routine has a possible portablility problem due to 64 bits longs. + | + | xdrfshort(xdrid, sp, ret) + | integer *2 sp + | + | xdrfstring(xdrid, sp, maxsize, ret) + | character *(*) + | integer maxsize + | + | read/write a string, with maximum length given by maxsize + | + | xdrfwrapstring(xdris, sp, ret) + | character *(*) + | + | read/write a string (it is the same as xdrfstring accept that it finds + | the stringlength itself. + | + | xdrfvector(xdrid, cp, size, xdrfproc, ret) + | character *(*) + | integer size + | external xdrfproc + | + | read/write an array pointed to by cp, with number of elements + | defined by 'size'. the routine 'xdrfproc' is the name + | of one of the above routines to read/write data (like xdrfdouble) + | In contrast with the c-version you don't need to specify the + | byte size of an element. + | xdrfstring is not allowed here (it is in the c version) + | + | xdrf3dfcoord(xdrid, fp, size, precision, ret) + | real (*) fp + | real precision + | integer size + | + | this is *NOT* a standard xdr routine. I named it this way, because + | it invites people to use the other xdr routines. + | It is introduced to store specifically 3d coordinates of molecules + | (as found in molecular dynamics) and it writes it in a compressed way. + | It starts by multiplying all numbers by precision and + | rounding the result to integer. effectively converting + | all floating point numbers to fixed point. + | it uses an algorithm for compression that is optimized for + | molecular data, but could be used for other 3d coordinates + | as well. There is subtantial overhead involved, so call this + | routine only if you have a large number of coordinates to read/write + | + | ________________________________________________________________________ + | + | Below are the routines to be used by C programmers. Use the 'normal' + | xdr routines to write integers, floats, etc (see man xdr) + | + | int xdropen(XDR *xdrs, const char *filename, const char *type) + | This will open the file with the given filename and the + | given mode. You should pass it an allocated XDR struct + | in xdrs, to be used in all other calls to xdr routines. + | Mode is 'w' to create, or update an file, and for all + | other values of mode the file is opened for reading. + | You need to call xdrclose to flush the output and close + | the file. + | + | Note that you should not use xdrstdio_create, which + | comes with the standard xdr library. + | + | int xdrclose(XDR *xdrs) + | Flush the data to the file, and close the file; + | You should not use xdr_destroy (which comes standard + | with the xdr libraries). + | + | int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) + | This is \fInot\fR a standard xdr routine. I named it this + | way, because it invites people to use the other xdr + | routines. + | + | (c) 1995 Frans van Hoesel, hoesel@chem.rug.nl +*/ + + +#include +#include +#include +#include +#include +#include +#include +#include "xdrf.h" + +int ftocstr(char *, int, char *, int); +int ctofstr(char *, int, char *); + +#define MAXID 20 +static FILE *xdrfiles[MAXID]; +static XDR *xdridptr[MAXID]; +static char xdrmodes[MAXID]; +static unsigned int cnt; + +typedef void (* FUNCTION(xdrfproc)) (int *, void *, int *); + +void +FUNCTION(xdrfbool) ARGS(`xdrid, pb, ret') +int *xdrid, *ret; +int *pb; +{ + *ret = xdr_bool(xdridptr[*xdrid], (bool_t *) pb); + cnt += sizeof(int); +} + +void +FUNCTION(xdrfchar) ARGS(`xdrid, cp, ret') +int *xdrid, *ret; +char *cp; +{ + *ret = xdr_char(xdridptr[*xdrid], cp); + cnt += sizeof(char); +} + +void +FUNCTION(xdrfdouble) ARGS(`xdrid, dp, ret') +int *xdrid, *ret; +double *dp; +{ + *ret = xdr_double(xdridptr[*xdrid], dp); + cnt += sizeof(double); +} + +void +FUNCTION(xdrffloat) ARGS(`xdrid, fp, ret') +int *xdrid, *ret; +float *fp; +{ + *ret = xdr_float(xdridptr[*xdrid], fp); + cnt += sizeof(float); +} + +void +FUNCTION(xdrfint) ARGS(`xdrid, ip, ret') +int *xdrid, *ret; +int *ip; +{ + *ret = xdr_int(xdridptr[*xdrid], ip); + cnt += sizeof(int); +} + +void +FUNCTION(xdrflong) ARGS(`xdrid, lp, ret') +int *xdrid, *ret; +long *lp; +{ + *ret = xdr_long(xdridptr[*xdrid], lp); + cnt += sizeof(long); +} + +void +FUNCTION(xdrfshort) ARGS(`xdrid, sp, ret') +int *xdrid, *ret; +short *sp; +{ + *ret = xdr_short(xdridptr[*xdrid], sp); + cnt += sizeof(sp); +} + +void +FUNCTION(xdrfuchar) ARGS(`xdrid, ucp, ret') +int *xdrid, *ret; +char *ucp; +{ + *ret = xdr_u_char(xdridptr[*xdrid], ucp); + cnt += sizeof(char); +} + +void +FUNCTION(xdrfulong) ARGS(`xdrid, ulp, ret') +int *xdrid, *ret; +unsigned long *ulp; +{ + *ret = xdr_u_long(xdridptr[*xdrid], ulp); + cnt += sizeof(unsigned long); +} + +void +FUNCTION(xdrfushort) ARGS(`xdrid, usp, ret') +int *xdrid, *ret; +unsigned short *usp; +{ + *ret = xdr_u_short(xdridptr[*xdrid], usp); + cnt += sizeof(unsigned short); +} + +void +FUNCTION(xdrf3dfcoord) ARGS(`xdrid, fp, size, precision, ret') +int *xdrid, *ret; +float *fp; +int *size; +float *precision; +{ + *ret = xdr3dfcoord(xdridptr[*xdrid], fp, size, precision); +} + +void +FUNCTION(xdrfstring) ARGS(`xdrid, STRING_ARG(sp), maxsize, ret') +int *xdrid, *ret; +STRING_ARG_DECL(sp); +int *maxsize; +{ + char *tsp; + + tsp = (char*) malloc(((STRING_LEN(sp)) + 1) * sizeof(char)); + if (tsp == NULL) { + *ret = -1; + return; + } + if (ftocstr(tsp, *maxsize+1, STRING_PTR(sp), STRING_LEN(sp))) { + *ret = -1; + free(tsp); + return; + } + *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int) *maxsize); + ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp); + cnt += *maxsize; + free(tsp); +} + +void +FUNCTION(xdrfwrapstring) ARGS(`xdrid, STRING_ARG(sp), ret') +int *xdrid, *ret; +STRING_ARG_DECL(sp); +{ + char *tsp; + int maxsize; + maxsize = (STRING_LEN(sp)) + 1; + tsp = (char*) malloc(maxsize * sizeof(char)); + if (tsp == NULL) { + *ret = -1; + return; + } + if (ftocstr(tsp, maxsize, STRING_PTR(sp), STRING_LEN(sp))) { + *ret = -1; + free(tsp); + return; + } + *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int)maxsize); + ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp); + cnt += maxsize; + free(tsp); +} + +void +FUNCTION(xdrfopaque) ARGS(`xdrid, cp, ccnt, ret') +int *xdrid, *ret; +caddr_t *cp; +int *ccnt; +{ + *ret = xdr_opaque(xdridptr[*xdrid], (caddr_t)*cp, (u_int)*ccnt); + cnt += *ccnt; +} + +void +FUNCTION(xdrfsetpos) ARGS(`xdrid, pos, ret') +int *xdrid, *ret; +int *pos; +{ + *ret = xdr_setpos(xdridptr[*xdrid], (u_int) *pos); +} + +void +FUNCTION(xdrf) ARGS(`xdrid, pos') +int *xdrid, *pos; +{ + *pos = xdr_getpos(xdridptr[*xdrid]); +} + +void +FUNCTION(xdrfvector) ARGS(`xdrid, cp, size, elproc, ret') +int *xdrid, *ret; +char *cp; +int *size; +FUNCTION(xdrfproc) elproc; +{ + int lcnt; + cnt = 0; + for (lcnt = 0; lcnt < *size; lcnt++) { + elproc(xdrid, (cp+cnt) , ret); + } +} + + +void +FUNCTION(xdrfclose) ARGS(`xdrid, ret') +int *xdrid; +int *ret; +{ + *ret = xdrclose(xdridptr[*xdrid]); + cnt = 0; +} + +void +FUNCTION(xdrfopen) ARGS(`xdrid, STRING_ARG(fp), STRING_ARG(mode), ret') +int *xdrid; +STRING_ARG_DECL(fp); +STRING_ARG_DECL(mode); +int *ret; +{ + char fname[512]; + char fmode[3]; + + if (ftocstr(fname, sizeof(fname), STRING_PTR(fp), STRING_LEN(fp))) { + *ret = 0; + } + if (ftocstr(fmode, sizeof(fmode), STRING_PTR(mode), + STRING_LEN(mode))) { + *ret = 0; + } + + *xdrid = xdropen(NULL, fname, fmode); + if (*xdrid == 0) + *ret = 0; + else + *ret = 1; +} + +/*___________________________________________________________________________ + | + | what follows are the C routines for opening, closing xdr streams + | and the routine to read/write compressed coordinates together + | with some routines to assist in this task (those are marked + | static and cannot be called from user programs) +*/ +#define MAXABS INT_MAX-2 + +#ifndef MIN +#define MIN(x,y) ((x) < (y) ? (x):(y)) +#endif +#ifndef MAX +#define MAX(x,y) ((x) > (y) ? (x):(y)) +#endif +#ifndef SQR +#define SQR(x) ((x)*(x)) +#endif +static int magicints[] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, + 8, 10, 12, 16, 20, 25, 32, 40, 50, 64, + 80, 101, 128, 161, 203, 256, 322, 406, 512, 645, + 812, 1024, 1290, 1625, 2048, 2580, 3250, 4096, 5060, 6501, + 8192, 10321, 13003, 16384, 20642, 26007, 32768, 41285, 52015, 65536, + 82570, 104031, 131072, 165140, 208063, 262144, 330280, 416127, 524287, 660561, + 832255, 1048576, 1321122, 1664510, 2097152, 2642245, 3329021, 4194304, 5284491, 6658042, + 8388607, 10568983, 13316085, 16777216 }; + +#define FIRSTIDX 9 +/* note that magicints[FIRSTIDX-1] == 0 */ +#define LASTIDX (sizeof(magicints) / sizeof(*magicints)) + + +/*__________________________________________________________________________ + | + | xdropen - open xdr file + | + | This versions differs from xdrstdio_create, because I need to know + | the state of the file (read or write) so I can use xdr3dfcoord + | in eigther read or write mode, and the file descriptor + | so I can close the file (something xdr_destroy doesn't do). + | +*/ + +int xdropen(XDR *xdrs, const char *filename, const char *type) { + static int init_done = 0; + enum xdr_op lmode; + const char *type1; + int xdrid; + + if (init_done == 0) { + for (xdrid = 1; xdrid < MAXID; xdrid++) { + xdridptr[xdrid] = NULL; + } + init_done = 1; + } + xdrid = 1; + while (xdrid < MAXID && xdridptr[xdrid] != NULL) { + xdrid++; + } + if (xdrid == MAXID) { + return 0; + } + if (*type == 'w' || *type == 'W') { + type = "w+"; + type1 = "w+"; + lmode = XDR_ENCODE; + } else if (*type == 'a' || *type == 'A') { + type = "w+"; + type1 = "a+"; + lmode = XDR_ENCODE; + } else { + type = "r"; + type1 = "r"; + lmode = XDR_DECODE; + } + xdrfiles[xdrid] = fopen(filename, type1); + if (xdrfiles[xdrid] == NULL) { + xdrs = NULL; + return 0; + } + xdrmodes[xdrid] = *type; + /* next test isn't usefull in the case of C language + * but is used for the Fortran interface + * (C users are expected to pass the address of an already allocated + * XDR staructure) + */ + if (xdrs == NULL) { + xdridptr[xdrid] = (XDR *) malloc(sizeof(XDR)); + xdrstdio_create(xdridptr[xdrid], xdrfiles[xdrid], lmode); + } else { + xdridptr[xdrid] = xdrs; + xdrstdio_create(xdrs, xdrfiles[xdrid], lmode); + } + return xdrid; +} + +/*_________________________________________________________________________ + | + | xdrclose - close a xdr file + | + | This will flush the xdr buffers, and destroy the xdr stream. + | It also closes the associated file descriptor (this is *not* + | done by xdr_destroy). + | +*/ + +int xdrclose(XDR *xdrs) { + int xdrid; + + if (xdrs == NULL) { + fprintf(stderr, "xdrclose: passed a NULL pointer\n"); + exit(1); + } + for (xdrid = 1; xdrid < MAXID; xdrid++) { + if (xdridptr[xdrid] == xdrs) { + + xdr_destroy(xdrs); + fclose(xdrfiles[xdrid]); + xdridptr[xdrid] = NULL; + return 1; + } + } + fprintf(stderr, "xdrclose: no such open xdr file\n"); + exit(1); + +} + +/*____________________________________________________________________________ + | + | sendbits - encode num into buf using the specified number of bits + | + | This routines appends the value of num to the bits already present in + | the array buf. You need to give it the number of bits to use and you + | better make sure that this number of bits is enough to hold the value + | Also num must be positive. + | +*/ + +static void sendbits(int buf[], int num_of_bits, int num) { + + unsigned int cnt, lastbyte; + int lastbits; + unsigned char * cbuf; + + cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf); + cnt = (unsigned int) buf[0]; + lastbits = buf[1]; + lastbyte =(unsigned int) buf[2]; + while (num_of_bits >= 8) { + lastbyte = (lastbyte << 8) | ((num >> (num_of_bits -8)) /* & 0xff*/); + cbuf[cnt++] = lastbyte >> lastbits; + num_of_bits -= 8; + } + if (num_of_bits > 0) { + lastbyte = (lastbyte << num_of_bits) | num; + lastbits += num_of_bits; + if (lastbits >= 8) { + lastbits -= 8; + cbuf[cnt++] = lastbyte >> lastbits; + } + } + buf[0] = cnt; + buf[1] = lastbits; + buf[2] = lastbyte; + if (lastbits>0) { + cbuf[cnt] = lastbyte << (8 - lastbits); + } +} + +/*_________________________________________________________________________ + | + | sizeofint - calculate bitsize of an integer + | + | return the number of bits needed to store an integer with given max size + | +*/ + +static int sizeofint(const int size) { + unsigned int num = 1; + int num_of_bits = 0; + + while (size >= num && num_of_bits < 32) { + num_of_bits++; + num <<= 1; + } + return num_of_bits; +} + +/*___________________________________________________________________________ + | + | sizeofints - calculate 'bitsize' of compressed ints + | + | given the number of small unsigned integers and the maximum value + | return the number of bits needed to read or write them with the + | routines receiveints and sendints. You need this parameter when + | calling these routines. Note that for many calls I can use + | the variable 'smallidx' which is exactly the number of bits, and + | So I don't need to call 'sizeofints for those calls. +*/ + +static int sizeofints( const int num_of_ints, unsigned int sizes[]) { + int i, num; + unsigned int num_of_bytes, num_of_bits, bytes[32], bytecnt, tmp; + num_of_bytes = 1; + bytes[0] = 1; + num_of_bits = 0; + for (i=0; i < num_of_ints; i++) { + tmp = 0; + for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) { + tmp = bytes[bytecnt] * sizes[i] + tmp; + bytes[bytecnt] = tmp & 0xff; + tmp >>= 8; + } + while (tmp != 0) { + bytes[bytecnt++] = tmp & 0xff; + tmp >>= 8; + } + num_of_bytes = bytecnt; + } + num = 1; + num_of_bytes--; + while (bytes[num_of_bytes] >= num) { + num_of_bits++; + num *= 2; + } + return num_of_bits + num_of_bytes * 8; + +} + +/*____________________________________________________________________________ + | + | sendints - send a small set of small integers in compressed format + | + | this routine is used internally by xdr3dfcoord, to send a set of + | small integers to the buffer. + | Multiplication with fixed (specified maximum ) sizes is used to get + | to one big, multibyte integer. Allthough the routine could be + | modified to handle sizes bigger than 16777216, or more than just + | a few integers, this is not done, because the gain in compression + | isn't worth the effort. Note that overflowing the multiplication + | or the byte buffer (32 bytes) is unchecked and causes bad results. + | + */ + +static void sendints(int buf[], const int num_of_ints, const int num_of_bits, + unsigned int sizes[], unsigned int nums[]) { + + int i; + unsigned int bytes[32], num_of_bytes, bytecnt, tmp; + + tmp = nums[0]; + num_of_bytes = 0; + do { + bytes[num_of_bytes++] = tmp & 0xff; + tmp >>= 8; + } while (tmp != 0); + + for (i = 1; i < num_of_ints; i++) { + if (nums[i] >= sizes[i]) { + fprintf(stderr,"major breakdown in sendints num %d doesn't " + "match size %d\n", nums[i], sizes[i]); + exit(1); + } + /* use one step multiply */ + tmp = nums[i]; + for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) { + tmp = bytes[bytecnt] * sizes[i] + tmp; + bytes[bytecnt] = tmp & 0xff; + tmp >>= 8; + } + while (tmp != 0) { + bytes[bytecnt++] = tmp & 0xff; + tmp >>= 8; + } + num_of_bytes = bytecnt; + } + if (num_of_bits >= num_of_bytes * 8) { + for (i = 0; i < num_of_bytes; i++) { + sendbits(buf, 8, bytes[i]); + } + sendbits(buf, num_of_bits - num_of_bytes * 8, 0); + } else { + for (i = 0; i < num_of_bytes-1; i++) { + sendbits(buf, 8, bytes[i]); + } + sendbits(buf, num_of_bits- (num_of_bytes -1) * 8, bytes[i]); + } +} + + +/*___________________________________________________________________________ + | + | receivebits - decode number from buf using specified number of bits + | + | extract the number of bits from the array buf and construct an integer + | from it. Return that value. + | +*/ + +static int receivebits(int buf[], int num_of_bits) { + + int cnt, num; + unsigned int lastbits, lastbyte; + unsigned char * cbuf; + int mask = (1 << num_of_bits) -1; + + cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf); + cnt = buf[0]; + lastbits = (unsigned int) buf[1]; + lastbyte = (unsigned int) buf[2]; + + num = 0; + while (num_of_bits >= 8) { + lastbyte = ( lastbyte << 8 ) | cbuf[cnt++]; + num |= (lastbyte >> lastbits) << (num_of_bits - 8); + num_of_bits -=8; + } + if (num_of_bits > 0) { + if (lastbits < num_of_bits) { + lastbits += 8; + lastbyte = (lastbyte << 8) | cbuf[cnt++]; + } + lastbits -= num_of_bits; + num |= (lastbyte >> lastbits) & ((1 << num_of_bits) -1); + } + num &= mask; + buf[0] = cnt; + buf[1] = lastbits; + buf[2] = lastbyte; + return num; +} + +/*____________________________________________________________________________ + | + | receiveints - decode 'small' integers from the buf array + | + | this routine is the inverse from sendints() and decodes the small integers + | written to buf by calculating the remainder and doing divisions with + | the given sizes[]. You need to specify the total number of bits to be + | used from buf in num_of_bits. + | +*/ + +static void receiveints(int buf[], const int num_of_ints, int num_of_bits, + unsigned int sizes[], int nums[]) { + int bytes[32]; + int i, j, num_of_bytes, p, num; + + bytes[1] = bytes[2] = bytes[3] = 0; + num_of_bytes = 0; + while (num_of_bits > 8) { + bytes[num_of_bytes++] = receivebits(buf, 8); + num_of_bits -= 8; + } + if (num_of_bits > 0) { + bytes[num_of_bytes++] = receivebits(buf, num_of_bits); + } + for (i = num_of_ints-1; i > 0; i--) { + num = 0; + for (j = num_of_bytes-1; j >=0; j--) { + num = (num << 8) | bytes[j]; + p = num / sizes[i]; + bytes[j] = p; + num = num - p * sizes[i]; + } + nums[i] = num; + } + nums[0] = bytes[0] | (bytes[1] << 8) | (bytes[2] << 16) | (bytes[3] << 24); +} + +/*____________________________________________________________________________ + | + | xdr3dfcoord - read or write compressed 3d coordinates to xdr file. + | + | this routine reads or writes (depending on how you opened the file with + | xdropen() ) a large number of 3d coordinates (stored in *fp). + | The number of coordinates triplets to write is given by *size. On + | read this number may be zero, in which case it reads as many as were written + | or it may specify the number if triplets to read (which should match the + | number written). + | Compression is achieved by first converting all floating numbers to integer + | using multiplication by *precision and rounding to the nearest integer. + | Then the minimum and maximum value are calculated to determine the range. + | The limited range of integers so found, is used to compress the coordinates. + | In addition the differences between succesive coordinates is calculated. + | If the difference happens to be 'small' then only the difference is saved, + | compressing the data even more. The notion of 'small' is changed dynamically + | and is enlarged or reduced whenever needed or possible. + | Extra compression is achieved in the case of GROMOS and coordinates of + | water molecules. GROMOS first writes out the Oxygen position, followed by + | the two hydrogens. In order to make the differences smaller (and thereby + | compression the data better) the order is changed into first one hydrogen + | then the oxygen, followed by the other hydrogen. This is rather special, but + | it shouldn't harm in the general case. + | + */ + +int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) { + + + static int *ip = NULL; + static int oldsize; + static int *buf; + + int minint[3], maxint[3], mindiff, *lip, diff; + int lint1, lint2, lint3, oldlint1, oldlint2, oldlint3, smallidx; + int minidx, maxidx; + unsigned sizeint[3], sizesmall[3], bitsizeint[3], size3, *luip; + int flag, k; + int small, smaller, larger, i, is_small, is_smaller, run, prevrun; + float *lfp, lf; + int tmp, *thiscoord, prevcoord[3]; + unsigned int tmpcoord[30]; + + int bufsize, xdrid, lsize; + unsigned int bitsize; + float inv_precision; + int errval = 1; + + /* find out if xdrs is opened for reading or for writing */ + xdrid = 0; + while (xdridptr[xdrid] != xdrs) { + xdrid++; + if (xdrid >= MAXID) { + fprintf(stderr, "xdr error. no open xdr stream\n"); + exit (1); + } + } + if (xdrmodes[xdrid] == 'w') { + + /* xdrs is open for writing */ + + if (xdr_int(xdrs, size) == 0) + return 0; + size3 = *size * 3; + /* when the number of coordinates is small, don't try to compress; just + * write them as floats using xdr_vector + */ + if (*size <= 9 ) { + return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp), + (xdrproc_t)xdr_float)); + } + + xdr_float(xdrs, precision); + if (ip == NULL) { + ip = (int *)malloc(size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)malloc(bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } else if (*size > oldsize) { + ip = (int *)realloc(ip, size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)realloc(buf, bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } + /* buf[0-2] are special and do not contain actual data */ + buf[0] = buf[1] = buf[2] = 0; + minint[0] = minint[1] = minint[2] = INT_MAX; + maxint[0] = maxint[1] = maxint[2] = INT_MIN; + prevrun = -1; + lfp = fp; + lip = ip; + mindiff = INT_MAX; + oldlint1 = oldlint2 = oldlint3 = 0; + while(lfp < fp + size3 ) { + /* find nearest integer */ + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint1 = lf; + if (lint1 < minint[0]) minint[0] = lint1; + if (lint1 > maxint[0]) maxint[0] = lint1; + *lip++ = lint1; + lfp++; + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint2 = lf; + if (lint2 < minint[1]) minint[1] = lint2; + if (lint2 > maxint[1]) maxint[1] = lint2; + *lip++ = lint2; + lfp++; + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint3 = lf; + if (lint3 < minint[2]) minint[2] = lint3; + if (lint3 > maxint[2]) maxint[2] = lint3; + *lip++ = lint3; + lfp++; + diff = abs(oldlint1-lint1)+abs(oldlint2-lint2)+abs(oldlint3-lint3); + if (diff < mindiff && lfp > fp + 3) + mindiff = diff; + oldlint1 = lint1; + oldlint2 = lint2; + oldlint3 = lint3; + } + xdr_int(xdrs, &(minint[0])); + xdr_int(xdrs, &(minint[1])); + xdr_int(xdrs, &(minint[2])); + + xdr_int(xdrs, &(maxint[0])); + xdr_int(xdrs, &(maxint[1])); + xdr_int(xdrs, &(maxint[2])); + + if ((float)maxint[0] - (float)minint[0] >= MAXABS || + (float)maxint[1] - (float)minint[1] >= MAXABS || + (float)maxint[2] - (float)minint[2] >= MAXABS) { + /* turning value in unsigned by subtracting minint + * would cause overflow + */ + errval = 0; + } + sizeint[0] = maxint[0] - minint[0]+1; + sizeint[1] = maxint[1] - minint[1]+1; + sizeint[2] = maxint[2] - minint[2]+1; + + /* check if one of the sizes is to big to be multiplied */ + if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) { + bitsizeint[0] = sizeofint(sizeint[0]); + bitsizeint[1] = sizeofint(sizeint[1]); + bitsizeint[2] = sizeofint(sizeint[2]); + bitsize = 0; /* flag the use of large sizes */ + } else { + bitsize = sizeofints(3, sizeint); + } + lip = ip; + luip = (unsigned int *) ip; + smallidx = FIRSTIDX; + while (smallidx < LASTIDX && magicints[smallidx] < mindiff) { + smallidx++; + } + xdr_int(xdrs, &smallidx); + maxidx = MIN(LASTIDX, smallidx + 8) ; + minidx = maxidx - 8; /* often this equal smallidx */ + smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2; + small = magicints[smallidx] / 2; + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx]; + larger = magicints[maxidx] / 2; + i = 0; + while (i < *size) { + is_small = 0; + thiscoord = (int *)(luip) + i * 3; + if (smallidx < maxidx && i >= 1 && + abs(thiscoord[0] - prevcoord[0]) < larger && + abs(thiscoord[1] - prevcoord[1]) < larger && + abs(thiscoord[2] - prevcoord[2]) < larger) { + is_smaller = 1; + } else if (smallidx > minidx) { + is_smaller = -1; + } else { + is_smaller = 0; + } + if (i + 1 < *size) { + if (abs(thiscoord[0] - thiscoord[3]) < small && + abs(thiscoord[1] - thiscoord[4]) < small && + abs(thiscoord[2] - thiscoord[5]) < small) { + /* interchange first with second atom for better + * compression of water molecules + */ + tmp = thiscoord[0]; thiscoord[0] = thiscoord[3]; + thiscoord[3] = tmp; + tmp = thiscoord[1]; thiscoord[1] = thiscoord[4]; + thiscoord[4] = tmp; + tmp = thiscoord[2]; thiscoord[2] = thiscoord[5]; + thiscoord[5] = tmp; + is_small = 1; + } + + } + tmpcoord[0] = thiscoord[0] - minint[0]; + tmpcoord[1] = thiscoord[1] - minint[1]; + tmpcoord[2] = thiscoord[2] - minint[2]; + if (bitsize == 0) { + sendbits(buf, bitsizeint[0], tmpcoord[0]); + sendbits(buf, bitsizeint[1], tmpcoord[1]); + sendbits(buf, bitsizeint[2], tmpcoord[2]); + } else { + sendints(buf, 3, bitsize, sizeint, tmpcoord); + } + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + thiscoord = thiscoord + 3; + i++; + + run = 0; + if (is_small == 0 && is_smaller == -1) + is_smaller = 0; + while (is_small && run < 8*3) { + if (is_smaller == -1 && ( + SQR(thiscoord[0] - prevcoord[0]) + + SQR(thiscoord[1] - prevcoord[1]) + + SQR(thiscoord[2] - prevcoord[2]) >= smaller * smaller)) { + is_smaller = 0; + } + + tmpcoord[run++] = thiscoord[0] - prevcoord[0] + small; + tmpcoord[run++] = thiscoord[1] - prevcoord[1] + small; + tmpcoord[run++] = thiscoord[2] - prevcoord[2] + small; + + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + + i++; + thiscoord = thiscoord + 3; + is_small = 0; + if (i < *size && + abs(thiscoord[0] - prevcoord[0]) < small && + abs(thiscoord[1] - prevcoord[1]) < small && + abs(thiscoord[2] - prevcoord[2]) < small) { + is_small = 1; + } + } + if (run != prevrun || is_smaller != 0) { + prevrun = run; + sendbits(buf, 1, 1); /* flag the change in run-length */ + sendbits(buf, 5, run+is_smaller+1); + } else { + sendbits(buf, 1, 0); /* flag the fact that runlength did not change */ + } + for (k=0; k < run; k+=3) { + sendints(buf, 3, smallidx, sizesmall, &tmpcoord[k]); + } + if (is_smaller != 0) { + smallidx += is_smaller; + if (is_smaller < 0) { + small = smaller; + smaller = magicints[smallidx-1] / 2; + } else { + smaller = small; + small = magicints[smallidx] / 2; + } + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx]; + } + } + if (buf[1] != 0) buf[0]++;; + xdr_int(xdrs, &(buf[0])); /* buf[0] holds the length in bytes */ + return errval * (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0])); + } else { + + /* xdrs is open for reading */ + + if (xdr_int(xdrs, &lsize) == 0) + return 0; + if (*size != 0 && lsize != *size) { + fprintf(stderr, "wrong number of coordinates in xdr3dfcoor; " + "%d arg vs %d in file", *size, lsize); + } + *size = lsize; + size3 = *size * 3; + if (*size <= 9) { + return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp), + (xdrproc_t)xdr_float)); + } + xdr_float(xdrs, precision); + if (ip == NULL) { + ip = (int *)malloc(size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)malloc(bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } else if (*size > oldsize) { + ip = (int *)realloc(ip, size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)realloc(buf, bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } + buf[0] = buf[1] = buf[2] = 0; + + xdr_int(xdrs, &(minint[0])); + xdr_int(xdrs, &(minint[1])); + xdr_int(xdrs, &(minint[2])); + + xdr_int(xdrs, &(maxint[0])); + xdr_int(xdrs, &(maxint[1])); + xdr_int(xdrs, &(maxint[2])); + + sizeint[0] = maxint[0] - minint[0]+1; + sizeint[1] = maxint[1] - minint[1]+1; + sizeint[2] = maxint[2] - minint[2]+1; + + /* check if one of the sizes is to big to be multiplied */ + if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) { + bitsizeint[0] = sizeofint(sizeint[0]); + bitsizeint[1] = sizeofint(sizeint[1]); + bitsizeint[2] = sizeofint(sizeint[2]); + bitsize = 0; /* flag the use of large sizes */ + } else { + bitsize = sizeofints(3, sizeint); + } + + xdr_int(xdrs, &smallidx); + maxidx = MIN(LASTIDX, smallidx + 8) ; + minidx = maxidx - 8; /* often this equal smallidx */ + smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2; + small = magicints[smallidx] / 2; + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ; + larger = magicints[maxidx]; + + /* buf[0] holds the length in bytes */ + + if (xdr_int(xdrs, &(buf[0])) == 0) + return 0; + if (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]) == 0) + return 0; + buf[0] = buf[1] = buf[2] = 0; + + lfp = fp; + inv_precision = 1.0 / * precision; + run = 0; + i = 0; + lip = ip; + while ( i < lsize ) { + thiscoord = (int *)(lip) + i * 3; + + if (bitsize == 0) { + thiscoord[0] = receivebits(buf, bitsizeint[0]); + thiscoord[1] = receivebits(buf, bitsizeint[1]); + thiscoord[2] = receivebits(buf, bitsizeint[2]); + } else { + receiveints(buf, 3, bitsize, sizeint, thiscoord); + } + + i++; + thiscoord[0] += minint[0]; + thiscoord[1] += minint[1]; + thiscoord[2] += minint[2]; + + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + + + flag = receivebits(buf, 1); + is_smaller = 0; + if (flag == 1) { + run = receivebits(buf, 5); + is_smaller = run % 3; + run -= is_smaller; + is_smaller--; + } + if (run > 0) { + thiscoord += 3; + for (k = 0; k < run; k+=3) { + receiveints(buf, 3, smallidx, sizesmall, thiscoord); + i++; + thiscoord[0] += prevcoord[0] - small; + thiscoord[1] += prevcoord[1] - small; + thiscoord[2] += prevcoord[2] - small; + if (k == 0) { + /* interchange first with second atom for better + * compression of water molecules + */ + tmp = thiscoord[0]; thiscoord[0] = prevcoord[0]; + prevcoord[0] = tmp; + tmp = thiscoord[1]; thiscoord[1] = prevcoord[1]; + prevcoord[1] = tmp; + tmp = thiscoord[2]; thiscoord[2] = prevcoord[2]; + prevcoord[2] = tmp; + *lfp++ = prevcoord[0] * inv_precision; + *lfp++ = prevcoord[1] * inv_precision; + *lfp++ = prevcoord[2] * inv_precision; + } else { + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + } + *lfp++ = thiscoord[0] * inv_precision; + *lfp++ = thiscoord[1] * inv_precision; + *lfp++ = thiscoord[2] * inv_precision; + } + } else { + *lfp++ = thiscoord[0] * inv_precision; + *lfp++ = thiscoord[1] * inv_precision; + *lfp++ = thiscoord[2] * inv_precision; + } + smallidx += is_smaller; + if (is_smaller < 0) { + small = smaller; + if (smallidx > FIRSTIDX) { + smaller = magicints[smallidx - 1] /2; + } else { + smaller = 0; + } + } else if (is_smaller > 0) { + smaller = small; + small = magicints[smallidx] / 2; + } + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ; + } + } + return 1; +} + + + diff --git a/source/wham/src-HCD/xdrf/underscore.m4 b/source/wham/src-HCD/xdrf/underscore.m4 new file mode 100644 index 0000000..4d620a0 --- /dev/null +++ b/source/wham/src-HCD/xdrf/underscore.m4 @@ -0,0 +1,19 @@ +divert(-1) +undefine(`len') +# +# append an underscore to FORTRAN function names +# +define(`FUNCTION',`$1_') +# +# FORTRAN character strings are passed as follows: +# a pointer to the base of the string is passed in the normal +# argument list, and the length is passed by value as an extra +# argument, after all of the other arguments. +# +define(`ARGS',`($1`'undivert(1))') +define(`SAVE',`divert(1)$1`'divert(0)') +define(`STRING_ARG',`$1_ptr`'SAVE(`, $1_len')') +define(`STRING_ARG_DECL',`char * $1_ptr; int $1_len') +define(`STRING_LEN',`$1_len') +define(`STRING_PTR',`$1_ptr') +divert(0) diff --git a/source/wham/src-HCD/xdrf/xdrf.h b/source/wham/src-HCD/xdrf/xdrf.h new file mode 100644 index 0000000..dedf5a2 --- /dev/null +++ b/source/wham/src-HCD/xdrf/xdrf.h @@ -0,0 +1,10 @@ +/*_________________________________________________________________ + | + | xdrf.h - include file for C routines that want to use the + | functions below. +*/ + +int xdropen(XDR *xdrs, const char *filename, const char *type); +int xdrclose(XDR *xdrs) ; +int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) ; + diff --git a/source/wham/src-HCD/xread.F b/source/wham/src-HCD/xread.F new file mode 100644 index 0000000..ac35de1 --- /dev/null +++ b/source/wham/src-HCD/xread.F @@ -0,0 +1,187 @@ + subroutine xread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + integer MaxTraj + parameter (MaxTraj=2050) +#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*4 csingle(3,maxres2) + character*64 nazwa,bprotfile_temp + integer i,j,k,l,ii,jj(maxslice),kk(maxslice),ll(maxslice), + & mm(maxslice) + integer iscor,islice,islice1,slice + double precision energ + integer ilen,iroof + external ilen,iroof + double precision rmsdev,energia(0:max_ene),efree,eini,temp + double precision prop(maxQ) + integer ntot_all(0:maxprocs-1) + integer iparm,ib,iib,ir,nprop,nthr + double precision etot,time,ts(maxslice),te(maxslice) + integer is(maxslice),ie(maxslice),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) +c write (iout,*) time,eini,etot,nss, +c & (ihpb(j),jhpb(j),j=1,nss),(prop(j),j=1,nprop) +c 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) + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) + 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)) +c write (*,*) "ii",ii," itraj",itraj +c 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 +c write (iout,*) ii,kk,jj,ll,eini,(prop(j),j=1,nprop) +#ifdef DEBUG +c write (iout,*) "Writing conformation, record",ll(islice) +c 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 +c write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ +c write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss",nss +c write (iout,*) "length",nres*4+(nct-nnt+1)*4+4+2*nss*4 +c call flush(iout) + if (islice.ne.islice1) then +c write (iout,*) "islice",islice," islice1",islice1 + close(ientout) +c write (iout,*) "Closing file ", +c & bprotfile_temp(:ilen(bprotfile_temp)) + call opentmp(islice,ientout,bprotfile_temp) +c write (iout,*) "Opening file ", +c & bprotfile_temp(:ilen(bprotfile_temp)) +c 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) +c 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 -- 1.7.9.5