From b074ba8412b77f7a06ccff1b6e9e30f0ae446f47 Mon Sep 17 00:00:00 2001 From: Cezary Czaplewski Date: Fri, 20 Mar 2020 14:49:00 +0100 Subject: [PATCH] ctest dock wham and old source rm --- ctest/dock/wham.inp | 2 +- source/unres/src_MD-M-newcorr/BUGS | 6 - source/unres/src_MD-M-newcorr/CMakeLists.txt | 357 - source/unres/src_MD-M-newcorr/COMMON.BANK | 29 - source/unres/src_MD-M-newcorr/COMMON.BOUNDS | 2 - source/unres/src_MD-M-newcorr/COMMON.CACHE | 6 - source/unres/src_MD-M-newcorr/COMMON.CALC | 15 - source/unres/src_MD-M-newcorr/COMMON.CHAIN | 16 - source/unres/src_MD-M-newcorr/COMMON.CONTACTS | 84 - .../unres/src_MD-M-newcorr/COMMON.CONTACTS.moment | 68 - .../unres/src_MD-M-newcorr/COMMON.CONTACTS_safe1 | 82 - source/unres/src_MD-M-newcorr/COMMON.CONTROL | 13 - source/unres/src_MD-M-newcorr/COMMON.CSA | 11 - source/unres/src_MD-M-newcorr/COMMON.DBASE | 3 - source/unres/src_MD-M-newcorr/COMMON.DERIV | 35 - source/unres/src_MD-M-newcorr/COMMON.DERIV_safe | 35 - source/unres/src_MD-M-newcorr/COMMON.DISTFIT | 14 - source/unres/src_MD-M-newcorr/COMMON.FFIELD | 25 - source/unres/src_MD-M-newcorr/COMMON.GEO | 2 - source/unres/src_MD-M-newcorr/COMMON.HAIRPIN | 5 - source/unres/src_MD-M-newcorr/COMMON.HEADER | 2 - source/unres/src_MD-M-newcorr/COMMON.INFO | 21 - source/unres/src_MD-M-newcorr/COMMON.INTERACT | 31 - source/unres/src_MD-M-newcorr/COMMON.IOUNITS | 69 - source/unres/src_MD-M-newcorr/COMMON.LANGEVIN | 21 - .../unres/src_MD-M-newcorr/COMMON.LANGEVIN.lang0 | 11 - .../unres/src_MD-M-newcorr/COMMON.LANGEVIN.lang0_ | 11 - source/unres/src_MD-M-newcorr/COMMON.LOCAL | 61 - source/unres/src_MD-M-newcorr/COMMON.LOCMOVE | 19 - source/unres/src_MD-M-newcorr/COMMON.MAP | 4 - source/unres/src_MD-M-newcorr/COMMON.MAXGRAD | 12 - source/unres/src_MD-M-newcorr/COMMON.MCE | 13 - source/unres/src_MD-M-newcorr/COMMON.MCM | 70 - source/unres/src_MD-M-newcorr/COMMON.MD | 65 - source/unres/src_MD-M-newcorr/COMMON.MINIM | 5 - source/unres/src_MD-M-newcorr/COMMON.MUCA | 10 - source/unres/src_MD-M-newcorr/COMMON.NAMES | 8 - source/unres/src_MD-M-newcorr/COMMON.REMD | 33 - source/unres/src_MD-M-newcorr/COMMON.SBRIDGE | 17 - source/unres/src_MD-M-newcorr/COMMON.SCCOR | 18 - source/unres/src_MD-M-newcorr/COMMON.SCROT | 3 - source/unres/src_MD-M-newcorr/COMMON.SETUP | 21 - source/unres/src_MD-M-newcorr/COMMON.SPLITELE | 2 - source/unres/src_MD-M-newcorr/COMMON.THREAD | 7 - source/unres/src_MD-M-newcorr/COMMON.TIME1 | 28 - source/unres/src_MD-M-newcorr/COMMON.TORCNSTR | 6 - source/unres/src_MD-M-newcorr/COMMON.TORSION | 41 - source/unres/src_MD-M-newcorr/COMMON.VAR | 22 - source/unres/src_MD-M-newcorr/COMMON.VECTORS | 3 - source/unres/src_MD-M-newcorr/DIMENSIONS | 141 - source/unres/src_MD-M-newcorr/DIMENSIONS.2100 | 80 - source/unres/src_MD-M-newcorr/DIMENSIONS.4100 | 80 - source/unres/src_MD-M-newcorr/DIMENSIONS_safe1 | 135 - source/unres/src_MD-M-newcorr/MD.F | 2565 ------ source/unres/src_MD-M-newcorr/MD_A-MTS.F | 2446 ------ source/unres/src_MD-M-newcorr/MD_A-MTS.F_safe | 2327 ----- source/unres/src_MD-M-newcorr/MD_A-MTS.F_safe1 | 2356 ----- source/unres/src_MD-M-newcorr/MP.F | 518 -- source/unres/src_MD-M-newcorr/MREMD.F | 1876 ---- source/unres/src_MD-M-newcorr/MREMD.F.drabinka | 1199 --- source/unres/src_MD-M-newcorr/MREMD.F.safe | 1756 ---- source/unres/src_MD-M-newcorr/MREMD_nosy1traj.F | 910 -- source/unres/src_MD-M-newcorr/Makefile | 1 - source/unres/src_MD-M-newcorr/Makefile-biosim | 127 - .../src_MD-M-newcorr/Makefile-intrepid-with-tau | 154 - .../unres/src_MD-M-newcorr/Makefile-matrix-intel | 124 - source/unres/src_MD-M-newcorr/Makefile-matrix3 | 141 - .../src_MD-M-newcorr/Makefile-matrix3-oldparm | 127 - source/unres/src_MD-M-newcorr/Makefile-oldparm | 130 - source/unres/src_MD-M-newcorr/Makefile-rstconv | 40 - source/unres/src_MD-M-newcorr/Makefile-tau-temp | 148 - .../src_MD-M-newcorr/Makefile.tau-mpi-f77-pdt | 860 -- .../src_MD-M-newcorr/Makefile.tau-mpi-pdt-pgi.org | 836 -- source/unres/src_MD-M-newcorr/Makefile_MPICH_ifort | 143 - source/unres/src_MD-M-newcorr/Makefile_aix_xlf | 112 - source/unres/src_MD-M-newcorr/Makefile_bigben | 138 - .../unres/src_MD-M-newcorr/Makefile_bigben-oldparm | 136 - source/unres/src_MD-M-newcorr/Makefile_bigben-tau | 137 - source/unres/src_MD-M-newcorr/Makefile_intrepid | 151 - source/unres/src_MD-M-newcorr/Makefile_jubl | 132 - source/unres/src_MD-M-newcorr/Makefile_jubl-debug | 141 - source/unres/src_MD-M-newcorr/Makefile_jubl-opt | 117 - .../src_MD-M-newcorr/Makefile_jubl-opt-oldparm | 116 - source/unres/src_MD-M-newcorr/Makefile_lnx_ifc | 104 - .../unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64 | 128 - .../Makefile_lnx_ifc10_em64_galera | 130 - .../Makefile_lnx_ifc10_em64_galera-oldparm | 131 - .../src_MD-M-newcorr/Makefile_lnx_ifc10_em64_mpi2 | 146 - source/unres/src_MD-M-newcorr/Makefile_lnx_ifc8 | 127 - source/unres/src_MD-M-newcorr/Makefile_lnx_pgf90 | 120 - source/unres/src_MD-M-newcorr/Makefile_osf_f90 | 79 - source/unres/src_MD-M-newcorr/Makefile_win_ifl | 53 - source/unres/src_MD-M-newcorr/Makefile_win_pgf90 | 43 - source/unres/src_MD-M-newcorr/README | 2 - source/unres/src_MD-M-newcorr/TAU | 6 - source/unres/src_MD-M-newcorr/TAU_setup.sh | 15 - source/unres/src_MD-M-newcorr/WVRND | 32 - source/unres/src_MD-M-newcorr/add.f | 28 - source/unres/src_MD-M-newcorr/arcos.f | 9 - source/unres/src_MD-M-newcorr/banach.f | 99 - source/unres/src_MD-M-newcorr/bank.F | 1084 --- source/unres/src_MD-M-newcorr/big-sizes | 9 - source/unres/src_MD-M-newcorr/bigsymbols-lang0.txt | 7 - source/unres/src_MD-M-newcorr/blas.f | 575 -- source/unres/src_MD-M-newcorr/bond_move.f | 124 - source/unres/src_MD-M-newcorr/brown_step.F | 395 - source/unres/src_MD-M-newcorr/cartder.F | 314 - source/unres/src_MD-M-newcorr/cartprint.f | 19 - source/unres/src_MD-M-newcorr/chainbuild.F | 274 - source/unres/src_MD-M-newcorr/change.awk | 11 - source/unres/src_MD-M-newcorr/check_bond.f | 20 - source/unres/src_MD-M-newcorr/check_sc_distr.f | 43 - source/unres/src_MD-M-newcorr/check_sc_map.f | 49 - source/unres/src_MD-M-newcorr/checkder_p.F | 700 -- source/unres/src_MD-M-newcorr/common.size | 130 - source/unres/src_MD-M-newcorr/common.size.orig | 130 - source/unres/src_MD-M-newcorr/compare_s1.F | 188 - source/unres/src_MD-M-newcorr/compinfo.c | 82 - source/unres/src_MD-M-newcorr/contact.f | 195 - source/unres/src_MD-M-newcorr/convert.f | 196 - source/unres/src_MD-M-newcorr/cored.f | 3151 ------- source/unres/src_MD-M-newcorr/csa.f | 364 - source/unres/src_MD-M-newcorr/diff12.f | 27 - source/unres/src_MD-M-newcorr/dihed_cons.F | 185 - source/unres/src_MD-M-newcorr/distfit.f | 207 - source/unres/src_MD-M-newcorr/djacob.f | 107 - source/unres/src_MD-M-newcorr/econstr_local.F | 91 - source/unres/src_MD-M-newcorr/ecorr_num.f | 593 -- source/unres/src_MD-M-newcorr/eelec.F | 278 - source/unres/src_MD-M-newcorr/eigen.f | 2351 ----- source/unres/src_MD-M-newcorr/elecont.f | 511 -- source/unres/src_MD-M-newcorr/energy_p_new-sep.F | 2505 ------ .../src_MD-M-newcorr/energy_p_new-sep_barrier.F | 2268 ----- source/unres/src_MD-M-newcorr/energy_p_new.F | 8381 ------------------ .../unres/src_MD-M-newcorr/energy_p_new_barrier.F | 9268 -------------------- .../src_MD-M-newcorr/energy_p_new_barrier.F.safe | 8916 ------------------- source/unres/src_MD-M-newcorr/energy_split-sep.F | 472 - source/unres/src_MD-M-newcorr/energy_split.F | 417 - source/unres/src_MD-M-newcorr/entmcm.F | 688 -- source/unres/src_MD-M-newcorr/env.log | 97 - source/unres/src_MD-M-newcorr/fitsq.f | 364 - source/unres/src_MD-M-newcorr/gauss.f | 69 - source/unres/src_MD-M-newcorr/gen_rand_conf.F | 911 -- source/unres/src_MD-M-newcorr/geomout.F | 512 -- source/unres/src_MD-M-newcorr/gnmr1.f | 43 - source/unres/src_MD-M-newcorr/gradient_p.F | 418 - source/unres/src_MD-M-newcorr/indexx.f | 81 - source/unres/src_MD-M-newcorr/initialize_p.F | 1424 --- source/unres/src_MD-M-newcorr/int_to_cart.f | 273 - source/unres/src_MD-M-newcorr/intcartderiv.F | 754 -- source/unres/src_MD-M-newcorr/intcor.f | 91 - source/unres/src_MD-M-newcorr/intlocal.f | 517 -- source/unres/src_MD-M-newcorr/kinetic_lesyng.f | 104 - source/unres/src_MD-M-newcorr/lagrangian_lesyng.F | 703 -- source/unres/src_MD-M-newcorr/local_move.f | 972 -- source/unres/src_MD-M-newcorr/make-tau.log | 1960 ----- source/unres/src_MD-M-newcorr/map.f | 89 - source/unres/src_MD-M-newcorr/matmult.f | 18 - source/unres/src_MD-M-newcorr/mc.F | 819 -- source/unres/src_MD-M-newcorr/mcm.F | 1481 ---- source/unres/src_MD-M-newcorr/minim_jlee.F | 435 - source/unres/src_MD-M-newcorr/minim_mcmf.F | 119 - source/unres/src_MD-M-newcorr/minimize_p.F | 641 -- source/unres/src_MD-M-newcorr/misc.f | 203 - source/unres/src_MD-M-newcorr/module.log | 11 - source/unres/src_MD-M-newcorr/moments.f | 328 - source/unres/src_MD-M-newcorr/muca_md.f | 334 - source/unres/src_MD-M-newcorr/newconf.f | 2454 ------ source/unres/src_MD-M-newcorr/objects.sizes | 168 - source/unres/src_MD-M-newcorr/parmread.F | 1375 --- source/unres/src_MD-M-newcorr/pdtf5579.pdb | 1195 --- source/unres/src_MD-M-newcorr/permut.F | 66 - source/unres/src_MD-M-newcorr/pinorm.f | 17 - source/unres/src_MD-M-newcorr/printmat.f | 16 - source/unres/src_MD-M-newcorr/prng.f | 525 -- source/unres/src_MD-M-newcorr/prng_32.F | 1070 --- source/unres/src_MD-M-newcorr/proc_proc.c | 140 - source/unres/src_MD-M-newcorr/q_measure.F | 491 -- source/unres/src_MD-M-newcorr/q_measure1.F | 470 - source/unres/src_MD-M-newcorr/q_measure3.F | 529 -- source/unres/src_MD-M-newcorr/ran.f | 128 - source/unres/src_MD-M-newcorr/randgens.f | 99 - .../src_MD-M-newcorr/random_multi_chain/cont.unr | 2 - .../random_multi_chain/ext_mono.pdb | 42 - .../random_multi_chain/ext_sing.pdb | 42 - .../src_MD-M-newcorr/random_multi_chain/fort.4 | 43 - .../src_MD-M-newcorr/random_multi_chain/output.pdb | 43 - .../src_MD-M-newcorr/random_multi_chain/random.f | 61 - .../src_MD-M-newcorr/random_multi_chain/toggle | Bin 15794 -> 0 bytes source/unres/src_MD-M-newcorr/rattle.F | 724 -- source/unres/src_MD-M-newcorr/readpdb.F | 557 -- source/unres/src_MD-M-newcorr/readpdb.f | Bin 43512 -> 0 bytes source/unres/src_MD-M-newcorr/readrtns_CSA.F | 2490 ------ source/unres/src_MD-M-newcorr/refsys.f | 68 - source/unres/src_MD-M-newcorr/regularize.F | 76 - source/unres/src_MD-M-newcorr/rescode.f | 32 - source/unres/src_MD-M-newcorr/restbin2asc.F | 482 - source/unres/src_MD-M-newcorr/rmdd.f | 159 - source/unres/src_MD-M-newcorr/rmsd.F | 172 - source/unres/src_MD-M-newcorr/sc_move.F | 821 -- source/unres/src_MD-M-newcorr/select.tau | 81 - source/unres/src_MD-M-newcorr/shift.F | 105 - source/unres/src_MD-M-newcorr/sizes.i | 83 - source/unres/src_MD-M-newcorr/sort.f | 589 -- source/unres/src_MD-M-newcorr/ssMD.F | 1951 ---- source/unres/src_MD-M-newcorr/stochfric.F | 627 -- source/unres/src_MD-M-newcorr/sumsld.f | 1446 --- source/unres/src_MD-M-newcorr/surfatom.f | 494 -- source/unres/src_MD-M-newcorr/symbols-lang0.txt | 257 - source/unres/src_MD-M-newcorr/symbolsizes.txt | 257 - source/unres/src_MD-M-newcorr/tau.options | 41 - source/unres/src_MD-M-newcorr/test.F | 2707 ------ source/unres/src_MD-M-newcorr/thread.F | 549 -- source/unres/src_MD-M-newcorr/timing.F | 337 - source/unres/src_MD-M-newcorr/together.F | 1222 --- source/unres/src_MD-M-newcorr/unres.F | 771 -- source/unres/src_MD-M-newcorr/xdrf | 1 - source/unres/src_MD_DFA/CMakeLists.txt | 401 - source/unres/src_MD_DFA/COMMON.BOUNDS | 2 - source/unres/src_MD_DFA/COMMON.CACHE | 6 - source/unres/src_MD_DFA/COMMON.CALC | 15 - source/unres/src_MD_DFA/COMMON.CHAIN | 13 - source/unres/src_MD_DFA/COMMON.CONTACTS | 82 - source/unres/src_MD_DFA/COMMON.CONTACTS.moment | 68 - source/unres/src_MD_DFA/COMMON.CONTROL | 13 - source/unres/src_MD_DFA/COMMON.DBASE | 3 - source/unres/src_MD_DFA/COMMON.DERIV | 37 - source/unres/src_MD_DFA/COMMON.DFA | 101 - source/unres/src_MD_DFA/COMMON.DISTFIT | 14 - source/unres/src_MD_DFA/COMMON.FFIELD | 26 - source/unres/src_MD_DFA/COMMON.GEO | 2 - source/unres/src_MD_DFA/COMMON.HAIRPIN | 5 - source/unres/src_MD_DFA/COMMON.HEADER | 2 - source/unres/src_MD_DFA/COMMON.INFO | 21 - source/unres/src_MD_DFA/COMMON.INTERACT | 34 - source/unres/src_MD_DFA/COMMON.IOUNITS | 69 - source/unres/src_MD_DFA/COMMON.LANGEVIN | 21 - source/unres/src_MD_DFA/COMMON.LANGEVIN.lang0 | 11 - source/unres/src_MD_DFA/COMMON.LOCAL | 55 - source/unres/src_MD_DFA/COMMON.LOCMOVE | 19 - source/unres/src_MD_DFA/COMMON.MAP | 4 - source/unres/src_MD_DFA/COMMON.MAXGRAD | 12 - source/unres/src_MD_DFA/COMMON.MCE | 13 - source/unres/src_MD_DFA/COMMON.MCM | 70 - source/unres/src_MD_DFA/COMMON.MD | 77 - source/unres/src_MD_DFA/COMMON.MINIM | 5 - source/unres/src_MD_DFA/COMMON.MUCA | 10 - source/unres/src_MD_DFA/COMMON.NAMES | 7 - source/unres/src_MD_DFA/COMMON.REFSYS | 3 - source/unres/src_MD_DFA/COMMON.REMD | 36 - source/unres/src_MD_DFA/COMMON.SBRIDGE | 12 - source/unres/src_MD_DFA/COMMON.SCCOR | 17 - source/unres/src_MD_DFA/COMMON.SCROT | 3 - source/unres/src_MD_DFA/COMMON.SETUP | 21 - source/unres/src_MD_DFA/COMMON.SPLITELE | 2 - source/unres/src_MD_DFA/COMMON.THREAD | 7 - source/unres/src_MD_DFA/COMMON.TIME1 | 28 - source/unres/src_MD_DFA/COMMON.TORCNSTR | 6 - source/unres/src_MD_DFA/COMMON.TORSION | 23 - source/unres/src_MD_DFA/COMMON.VAR | 21 - source/unres/src_MD_DFA/COMMON.VECTORS | 3 - source/unres/src_MD_DFA/DIMENSIONS | 139 - source/unres/src_MD_DFA/DIMENSIONS.2100 | 80 - source/unres/src_MD_DFA/DIMENSIONS.4100 | 80 - source/unres/src_MD_DFA/MD_A-MTS.F | 3461 -------- source/unres/src_MD_DFA/MP.F | 516 -- source/unres/src_MD_DFA/MREMD.F | 2102 ----- source/unres/src_MD_DFA/Makefile-intrepid-with-tau | 154 - source/unres/src_MD_DFA/Makefile.tau-mpi-f77-pdt | 860 -- source/unres/src_MD_DFA/Makefile_MPICH_ifort | 124 - source/unres/src_MD_DFA/Makefile_aix_xlf | 113 - source/unres/src_MD_DFA/Makefile_bigben | 138 - source/unres/src_MD_DFA/Makefile_bigben-oldparm | 136 - source/unres/src_MD_DFA/Makefile_bigben-tau | 137 - source/unres/src_MD_DFA/Makefile_galera | 147 - source/unres/src_MD_DFA/Makefile_intrepid | 151 - source/unres/src_MD_DFA/Makefile_lnx_ifc10_opteron | 143 - .../src_MD_DFA/Makefile_lnx_ifc10_opteron_oldparm | 143 - source/unres/src_MD_DFA/Makefile_single_gfortran | 130 - source/unres/src_MD_DFA/Makefile_single_ifort | 127 - source/unres/src_MD_DFA/README | 2 - source/unres/src_MD_DFA/add.f | 28 - source/unres/src_MD_DFA/arcos.f | 9 - source/unres/src_MD_DFA/banach.f | 99 - source/unres/src_MD_DFA/blas.f | 575 -- source/unres/src_MD_DFA/bond_move.f | 125 - source/unres/src_MD_DFA/cartder.F | 314 - source/unres/src_MD_DFA/cartprint.f | 19 - source/unres/src_MD_DFA/chainbuild.F | 274 - source/unres/src_MD_DFA/change.awk | 11 - source/unres/src_MD_DFA/check_bond.f | 20 - source/unres/src_MD_DFA/check_sc_distr.f | 43 - source/unres/src_MD_DFA/checkder_p.F | 713 -- source/unres/src_MD_DFA/compare_s1.F | 188 - source/unres/src_MD_DFA/compinfo.c | 82 - source/unres/src_MD_DFA/contact.f | 195 - source/unres/src_MD_DFA/convert.f | 196 - source/unres/src_MD_DFA/cored.f | 3151 ------- source/unres/src_MD_DFA/dfa.F | 3455 -------- source/unres/src_MD_DFA/dihed_cons.F | 185 - source/unres/src_MD_DFA/djacob.f | 107 - source/unres/src_MD_DFA/econstr_local.F | 91 - source/unres/src_MD_DFA/eigen.f | 2351 ----- source/unres/src_MD_DFA/elecont.f | 509 -- source/unres/src_MD_DFA/energy_p_new-sep_barrier.F | 2322 ----- source/unres/src_MD_DFA/energy_p_new_barrier.F | 9253 ------------------- source/unres/src_MD_DFA/energy_split-sep.F | 476 - source/unres/src_MD_DFA/entmcm.F | 684 -- source/unres/src_MD_DFA/fitsq.f | 364 - source/unres/src_MD_DFA/gauss.f | 69 - source/unres/src_MD_DFA/gen_rand_conf.F | 910 -- source/unres/src_MD_DFA/geomout.F | 491 -- source/unres/src_MD_DFA/gnmr1.f | 43 - source/unres/src_MD_DFA/gradient_p.F | 421 - source/unres/src_MD_DFA/initialize_p.F | 1394 --- source/unres/src_MD_DFA/int_to_cart.f | 278 - source/unres/src_MD_DFA/intcartderiv.F | 725 -- source/unres/src_MD_DFA/intcor.f | 91 - source/unres/src_MD_DFA/intlocal.f | 517 -- source/unres/src_MD_DFA/kinetic_lesyng.f | 104 - source/unres/src_MD_DFA/lagrangian_lesyng.F | 726 -- source/unres/src_MD_DFA/local_move.f | 972 -- source/unres/src_MD_DFA/map.f | 90 - source/unres/src_MD_DFA/matmult.f | 18 - source/unres/src_MD_DFA/mc.F | 819 -- source/unres/src_MD_DFA/mcm.F | 1481 ---- source/unres/src_MD_DFA/minim_mcmf.F | 121 - source/unres/src_MD_DFA/minimize_p.F | 641 -- source/unres/src_MD_DFA/misc.f | 203 - source/unres/src_MD_DFA/moments.f | 328 - source/unres/src_MD_DFA/muca_md.f | 334 - source/unres/src_MD_DFA/parmread.F | 1036 --- source/unres/src_MD_DFA/pinorm.f | 17 - source/unres/src_MD_DFA/printmat.f | 16 - source/unres/src_MD_DFA/prng.f | 525 -- source/unres/src_MD_DFA/prng_32.F | 1077 --- source/unres/src_MD_DFA/proc_proc.c | 139 - source/unres/src_MD_DFA/q_measure.F | 487 - source/unres/src_MD_DFA/q_measure1.F | 470 - source/unres/src_MD_DFA/q_measure3.F | 529 -- source/unres/src_MD_DFA/randgens.f | 99 - source/unres/src_MD_DFA/rattle.F | 706 -- source/unres/src_MD_DFA/readpdb.F | 417 - source/unres/src_MD_DFA/readrtns.F | 2702 ------ source/unres/src_MD_DFA/refsys.f | 67 - source/unres/src_MD_DFA/regularize.F | 76 - source/unres/src_MD_DFA/rescode.f | 32 - source/unres/src_MD_DFA/rmdd.f | 159 - source/unres/src_MD_DFA/rmsd.F | 140 - source/unres/src_MD_DFA/sc_move.F | 823 -- source/unres/src_MD_DFA/sizes.i | 83 - source/unres/src_MD_DFA/sort.f | 589 -- source/unres/src_MD_DFA/stochfric.F | 626 -- source/unres/src_MD_DFA/sumsld.f | 1446 --- source/unres/src_MD_DFA/surfatom.f | 494 -- source/unres/src_MD_DFA/test.F | 863 -- source/unres/src_MD_DFA/thread.F | 549 -- source/unres/src_MD_DFA/timing.F | 344 - source/unres/src_MD_DFA/unres.F | 794 -- source/unres/src_MD_DFA/xdrf | 1 - source/unres/src_MIN/CMakeLists.txt | 225 - source/unres/src_MIN/COMMON.BOUNDS | 2 - source/unres/src_MIN/COMMON.CALC | 15 - source/unres/src_MIN/COMMON.CHAIN | 12 - source/unres/src_MIN/COMMON.CONTACTS | 82 - source/unres/src_MIN/COMMON.CONTROL | 13 - source/unres/src_MIN/COMMON.DERIV | 36 - source/unres/src_MIN/COMMON.DISTFIT | 14 - source/unres/src_MIN/COMMON.FFIELD | 25 - source/unres/src_MIN/COMMON.GEO | 2 - source/unres/src_MIN/COMMON.HEADER | 2 - source/unres/src_MIN/COMMON.INTERACT | 34 - source/unres/src_MIN/COMMON.IOUNITS | 69 - source/unres/src_MIN/COMMON.LOCAL | 53 - source/unres/src_MIN/COMMON.MAXGRAD | 12 - source/unres/src_MIN/COMMON.MCM | 70 - source/unres/src_MIN/COMMON.MD_ | 74 - source/unres/src_MIN/COMMON.MINIM | 5 - source/unres/src_MIN/COMMON.NAMES | 7 - source/unres/src_MIN/COMMON.SBRIDGE | 12 - source/unres/src_MIN/COMMON.SCCOR | 6 - source/unres/src_MIN/COMMON.SCROT | 3 - source/unres/src_MIN/COMMON.SETUP | 21 - source/unres/src_MIN/COMMON.SPLITELE | 2 - source/unres/src_MIN/COMMON.TIME1 | 28 - source/unres/src_MIN/COMMON.TORCNSTR | 6 - source/unres/src_MIN/COMMON.TORSION | 23 - source/unres/src_MIN/COMMON.VAR | 20 - source/unres/src_MIN/COMMON.VECTORS | 3 - source/unres/src_MIN/DIMENSIONS | 139 - source/unres/src_MIN/MP.F | 517 -- source/unres/src_MIN/Makefile | 1 - source/unres/src_MIN/Makefile_gfortran_single | 88 - source/unres/src_MIN/Makefile_ifort_single | 88 - source/unres/src_MIN/arcos.f | 9 - source/unres/src_MIN/cartder.F | 314 - source/unres/src_MIN/cartprint.f | 19 - source/unres/src_MIN/chainbuild.F | 274 - source/unres/src_MIN/checkder_p.F | 688 -- source/unres/src_MIN/compinfo.c | 82 - source/unres/src_MIN/convert.f | 196 - source/unres/src_MIN/cored.f | 3151 ------- source/unres/src_MIN/djacob.f | 107 - source/unres/src_MIN/econstr_local.F | 91 - source/unres/src_MIN/energy_p_new_barrier.F | 9024 ------------------- source/unres/src_MIN/gen_rand_conf.F | 910 -- source/unres/src_MIN/geomout_min.F | 348 - source/unres/src_MIN/gradient_p.F | 408 - source/unres/src_MIN/initialize_p.F | 1385 --- source/unres/src_MIN/int_to_cart.f | 119 - source/unres/src_MIN/intcartderiv.F | 466 - source/unres/src_MIN/intcor.f | 91 - source/unres/src_MIN/intlocal.f | 517 -- source/unres/src_MIN/matmult.f | 18 - source/unres/src_MIN/minimize_p.F | 625 -- source/unres/src_MIN/misc.f | 203 - source/unres/src_MIN/parmread.F | 1006 --- source/unres/src_MIN/pinorm.f | 17 - source/unres/src_MIN/printmat.f | 16 - source/unres/src_MIN/randgens.f | 99 - source/unres/src_MIN/readpdb.F | 428 - source/unres/src_MIN/readrtns_min.F | 1799 ---- source/unres/src_MIN/refsys.f | 60 - source/unres/src_MIN/rescode.f | 32 - source/unres/src_MIN/rmdd.f | 159 - source/unres/src_MIN/sc_move.F | 823 -- source/unres/src_MIN/sumsld.f | 1446 --- source/unres/src_MIN/timing.F | 340 - source/unres/src_MIN/unres_min.F | 272 - source/wham/src-NEWSC-NEWCORR/CMakeLists.txt | 298 - source/wham/src-NEWSC-NEWCORR/COMMON.ALLPARM | 99 - source/wham/src-NEWSC-NEWCORR/COMMON.CHAIN | 8 - source/wham/src-NEWSC-NEWCORR/COMMON.COMPAR | 39 - source/wham/src-NEWSC-NEWCORR/COMMON.CONTACTS1 | 5 - source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL | 10 - source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL.org | 9 - source/wham/src-NEWSC-NEWCORR/COMMON.EMP | 126 - source/wham/src-NEWSC-NEWCORR/COMMON.ENEPS | 3 - source/wham/src-NEWSC-NEWCORR/COMMON.ENERGIES | 4 - source/wham/src-NEWSC-NEWCORR/COMMON.FREE | 15 - source/wham/src-NEWSC-NEWCORR/COMMON.IOUNITS | 51 - source/wham/src-NEWSC-NEWCORR/COMMON.MPI | 8 - source/wham/src-NEWSC-NEWCORR/COMMON.OBCINKA | 3 - source/wham/src-NEWSC-NEWCORR/COMMON.PEPTCONT | 7 - source/wham/src-NEWSC-NEWCORR/COMMON.PROT | 2 - source/wham/src-NEWSC-NEWCORR/COMMON.PROTFILES | 10 - source/wham/src-NEWSC-NEWCORR/COMMON.VAR | 17 - source/wham/src-NEWSC-NEWCORR/DIMENSIONS | 142 - source/wham/src-NEWSC-NEWCORR/DIMENSIONS.COMPAR | 25 - source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE | 14 - source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE.old | 12 - source/wham/src-NEWSC-NEWCORR/DIMENSIONS.ZSCOPT | 40 - source/wham/src-NEWSC-NEWCORR/Makefile | 1 - source/wham/src-NEWSC-NEWCORR/Makefile-pgi | 74 - source/wham/src-NEWSC-NEWCORR/Makefile1_jump | 60 - source/wham/src-NEWSC-NEWCORR/Makefile_MPICH_ifort | 89 - source/wham/src-NEWSC-NEWCORR/Makefile_jubl | 95 - source/wham/src-NEWSC-NEWCORR/Makefile_jump | 69 - source/wham/src-NEWSC-NEWCORR/Makefile_matrix | 67 - source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI | 76 - .../Makefile_matrix_PGI-SCT-oldparm | 76 - .../Makefile_matrix_PGI-SCTF-oldparm | 76 - .../src-NEWSC-NEWCORR/Makefile_matrix_PGI-oldparm | 76 - source/wham/src-NEWSC-NEWCORR/a.sh | 9 - source/wham/src-NEWSC-NEWCORR/angnorm.f | 439 - source/wham/src-NEWSC-NEWCORR/arcos.f | 9 - source/wham/src-NEWSC-NEWCORR/bxread.F | 89 - source/wham/src-NEWSC-NEWCORR/cartder.f | 306 - source/wham/src-NEWSC-NEWCORR/cartprint.f | 20 - source/wham/src-NEWSC-NEWCORR/chainbuild.F | 281 - source/wham/src-NEWSC-NEWCORR/chainbuild.f | 258 - source/wham/src-NEWSC-NEWCORR/compinfo.c | 82 - source/wham/src-NEWSC-NEWCORR/conf_compar.F | 374 - source/wham/src-NEWSC-NEWCORR/cont_frag.f | 99 - source/wham/src-NEWSC-NEWCORR/contact.f | 171 - source/wham/src-NEWSC-NEWCORR/contfunc.f | 96 - source/wham/src-NEWSC-NEWCORR/cxread.F | 336 - source/wham/src-NEWSC-NEWCORR/cxread.F.org | 248 - source/wham/src-NEWSC-NEWCORR/define_pairs.f | 120 - source/wham/src-NEWSC-NEWCORR/elecont.f | 207 - source/wham/src-NEWSC-NEWCORR/enecalc1.F | 780 -- source/wham/src-NEWSC-NEWCORR/energy_p_new.F | 9221 ------------------- source/wham/src-NEWSC-NEWCORR/energy_p_new.F.org | 6452 -------------- source/wham/src-NEWSC-NEWCORR/fitsq.f | 352 - source/wham/src-NEWSC-NEWCORR/geomout.F | 167 - source/wham/src-NEWSC-NEWCORR/gnmr1.f | 43 - source/wham/src-NEWSC-NEWCORR/icant.f | 9 - .../src-NEWSC-NEWCORR/include_unres/COMMON.CALC | 15 - .../include_unres/COMMON.CONTACTS | 68 - .../src-NEWSC-NEWCORR/include_unres/COMMON.CONTPAR | 3 - .../src-NEWSC-NEWCORR/include_unres/COMMON.DERIV | 30 - .../src-NEWSC-NEWCORR/include_unres/COMMON.FFIELD | 29 - .../src-NEWSC-NEWCORR/include_unres/COMMON.FRAG | 5 - .../src-NEWSC-NEWCORR/include_unres/COMMON.GEO | 2 - .../src-NEWSC-NEWCORR/include_unres/COMMON.HEADER | 2 - .../include_unres/COMMON.INTERACT | 38 - .../src-NEWSC-NEWCORR/include_unres/COMMON.LOCAL | 36 - .../src-NEWSC-NEWCORR/include_unres/COMMON.MINIM | 3 - .../src-NEWSC-NEWCORR/include_unres/COMMON.NAMES | 7 - .../src-NEWSC-NEWCORR/include_unres/COMMON.SBRIDGE | 10 - .../src-NEWSC-NEWCORR/include_unres/COMMON.SCCOR | 18 - .../src-NEWSC-NEWCORR/include_unres/COMMON.SCROT | 3 - .../src-NEWSC-NEWCORR/include_unres/COMMON.TIME1 | 13 - .../include_unres/COMMON.TORCNSTR | 5 - .../src-NEWSC-NEWCORR/include_unres/COMMON.TORSION | 29 - .../src-NEWSC-NEWCORR/include_unres/COMMON.VAR | 21 - .../src-NEWSC-NEWCORR/include_unres/COMMON.VECTORS | 3 - .../src-NEWSC-NEWCORR/include_unres/COMMON.WEIGHTS | 22 - source/wham/src-NEWSC-NEWCORR/initialize_p.F | 577 -- source/wham/src-NEWSC-NEWCORR/initialize_p.F.org | 571 -- source/wham/src-NEWSC-NEWCORR/int_from_cart.f | 66 - source/wham/src-NEWSC-NEWCORR/intcor.f | 94 - source/wham/src-NEWSC-NEWCORR/make_ensemble1.F | 375 - source/wham/src-NEWSC-NEWCORR/match_contact.f | 339 - source/wham/src-NEWSC-NEWCORR/matmult.f | 18 - source/wham/src-NEWSC-NEWCORR/misc.f | 203 - source/wham/src-NEWSC-NEWCORR/molread_zs.F | 378 - source/wham/src-NEWSC-NEWCORR/mygetenv.F | 55 - source/wham/src-NEWSC-NEWCORR/mysort.f | 52 - source/wham/src-NEWSC-NEWCORR/odlodc.f | 55 - source/wham/src-NEWSC-NEWCORR/openunits.F | 105 - source/wham/src-NEWSC-NEWCORR/parmread.F | 1164 --- source/wham/src-NEWSC-NEWCORR/pinorm.f | 17 - source/wham/src-NEWSC-NEWCORR/printmat.f | 16 - source/wham/src-NEWSC-NEWCORR/proc_cont.f | 156 - source/wham/src-NEWSC-NEWCORR/proc_proc.c | 124 - source/wham/src-NEWSC-NEWCORR/promienie.f | 46 - source/wham/src-NEWSC-NEWCORR/qwolynes.f | 186 - source/wham/src-NEWSC-NEWCORR/read_ref_str.F | 165 - source/wham/src-NEWSC-NEWCORR/readpdb.f | 219 - source/wham/src-NEWSC-NEWCORR/readrtns.F | 779 -- source/wham/src-NEWSC-NEWCORR/readrtns.F.org | 691 -- source/wham/src-NEWSC-NEWCORR/readrtns_compar.F | 160 - source/wham/src-NEWSC-NEWCORR/rescode.f | 32 - source/wham/src-NEWSC-NEWCORR/rmscalc.f | 156 - source/wham/src-NEWSC-NEWCORR/secondary.f | 713 -- source/wham/src-NEWSC-NEWCORR/setup_var.f | 31 - source/wham/src-NEWSC-NEWCORR/slices.F | 80 - source/wham/src-NEWSC-NEWCORR/store_parm.F | 547 -- source/wham/src-NEWSC-NEWCORR/timing.F | 163 - source/wham/src-NEWSC-NEWCORR/wham_calc1.F | 1454 --- source/wham/src-NEWSC-NEWCORR/wham_calc1.F.safe | 1195 --- source/wham/src-NEWSC-NEWCORR/wham_multparm.F | 277 - source/wham/src-NEWSC-NEWCORR/xdrf | 1 - source/wham/src-NEWSC-NEWCORR/xread.F | 187 - source/wham/src-NEWSC/CMakeLists.txt | 298 - source/wham/src-NEWSC/COMMON.ALLPARM | 99 - source/wham/src-NEWSC/COMMON.CHAIN | 8 - source/wham/src-NEWSC/COMMON.COMPAR | 39 - source/wham/src-NEWSC/COMMON.CONTACTS1 | 5 - source/wham/src-NEWSC/COMMON.CONTROL | 10 - source/wham/src-NEWSC/COMMON.CONTROL.org | 9 - source/wham/src-NEWSC/COMMON.EMP | 126 - source/wham/src-NEWSC/COMMON.ENEPS | 3 - source/wham/src-NEWSC/COMMON.ENERGIES | 4 - source/wham/src-NEWSC/COMMON.FREE | 15 - source/wham/src-NEWSC/COMMON.IOUNITS | 51 - source/wham/src-NEWSC/COMMON.MPI | 8 - source/wham/src-NEWSC/COMMON.OBCINKA | 3 - source/wham/src-NEWSC/COMMON.PEPTCONT | 7 - source/wham/src-NEWSC/COMMON.PROT | 2 - source/wham/src-NEWSC/COMMON.PROTFILES | 10 - source/wham/src-NEWSC/COMMON.VAR | 17 - source/wham/src-NEWSC/DIMENSIONS | 142 - source/wham/src-NEWSC/DIMENSIONS.COMPAR | 25 - source/wham/src-NEWSC/DIMENSIONS.FREE | 14 - source/wham/src-NEWSC/DIMENSIONS.FREE.old | 12 - source/wham/src-NEWSC/DIMENSIONS.ZSCOPT | 40 - source/wham/src-NEWSC/Makefile | 89 - source/wham/src-NEWSC/Makefile-pgi | 74 - source/wham/src-NEWSC/Makefile1_jump | 60 - source/wham/src-NEWSC/Makefile_MPICH_ifort | 89 - source/wham/src-NEWSC/Makefile_jubl | 95 - source/wham/src-NEWSC/Makefile_jump | 69 - source/wham/src-NEWSC/Makefile_matrix | 67 - source/wham/src-NEWSC/Makefile_matrix_PGI | 76 - .../wham/src-NEWSC/Makefile_matrix_PGI-SCT-oldparm | 76 - .../src-NEWSC/Makefile_matrix_PGI-SCTF-oldparm | 76 - source/wham/src-NEWSC/Makefile_matrix_PGI-oldparm | 76 - source/wham/src-NEWSC/a.sh | 9 - source/wham/src-NEWSC/angnorm.f | 439 - source/wham/src-NEWSC/arcos.f | 9 - source/wham/src-NEWSC/bxread.F | 89 - source/wham/src-NEWSC/cartder.f | 306 - source/wham/src-NEWSC/cartprint.f | 20 - source/wham/src-NEWSC/chainbuild.F | 281 - source/wham/src-NEWSC/chainbuild.f | 258 - source/wham/src-NEWSC/compinfo.c | 82 - source/wham/src-NEWSC/conf_compar.F | 374 - source/wham/src-NEWSC/cont_frag.f | 99 - source/wham/src-NEWSC/contact.f | 171 - source/wham/src-NEWSC/contfunc.f | 96 - source/wham/src-NEWSC/cxread.F | 336 - source/wham/src-NEWSC/cxread.F.org | 248 - source/wham/src-NEWSC/define_pairs.f | 120 - source/wham/src-NEWSC/elecont.f | 207 - source/wham/src-NEWSC/enecalc1.F | 780 -- source/wham/src-NEWSC/energy_p_new.F | 9193 ------------------- source/wham/src-NEWSC/energy_p_new.F.org | 6452 -------------- source/wham/src-NEWSC/fitsq.f | 352 - source/wham/src-NEWSC/geomout.F | 167 - source/wham/src-NEWSC/gnmr1.f | 43 - source/wham/src-NEWSC/icant.f | 9 - source/wham/src-NEWSC/include_unres/COMMON.CALC | 15 - .../wham/src-NEWSC/include_unres/COMMON.CONTACTS | 68 - source/wham/src-NEWSC/include_unres/COMMON.CONTPAR | 3 - source/wham/src-NEWSC/include_unres/COMMON.DERIV | 30 - source/wham/src-NEWSC/include_unres/COMMON.FFIELD | 29 - source/wham/src-NEWSC/include_unres/COMMON.FRAG | 5 - source/wham/src-NEWSC/include_unres/COMMON.GEO | 2 - source/wham/src-NEWSC/include_unres/COMMON.HEADER | 2 - .../wham/src-NEWSC/include_unres/COMMON.INTERACT | 38 - source/wham/src-NEWSC/include_unres/COMMON.LOCAL | 36 - source/wham/src-NEWSC/include_unres/COMMON.MINIM | 3 - source/wham/src-NEWSC/include_unres/COMMON.NAMES | 7 - source/wham/src-NEWSC/include_unres/COMMON.SBRIDGE | 10 - source/wham/src-NEWSC/include_unres/COMMON.SCCOR | 18 - source/wham/src-NEWSC/include_unres/COMMON.SCROT | 3 - source/wham/src-NEWSC/include_unres/COMMON.TIME1 | 13 - .../wham/src-NEWSC/include_unres/COMMON.TORCNSTR | 5 - source/wham/src-NEWSC/include_unres/COMMON.TORSION | 25 - source/wham/src-NEWSC/include_unres/COMMON.VAR | 21 - source/wham/src-NEWSC/include_unres/COMMON.VECTORS | 3 - source/wham/src-NEWSC/include_unres/COMMON.WEIGHTS | 22 - source/wham/src-NEWSC/initialize_p.F | 577 -- source/wham/src-NEWSC/initialize_p.F.org | 571 -- source/wham/src-NEWSC/int_from_cart.f | 66 - source/wham/src-NEWSC/intcor.f | 94 - source/wham/src-NEWSC/make_ensemble1.F | 375 - source/wham/src-NEWSC/match_contact.f | 339 - source/wham/src-NEWSC/matmult.f | 18 - source/wham/src-NEWSC/misc.f | 203 - source/wham/src-NEWSC/molread_zs.F | 378 - source/wham/src-NEWSC/mygetenv.F | 55 - source/wham/src-NEWSC/mysort.f | 52 - source/wham/src-NEWSC/odlodc.f | 55 - source/wham/src-NEWSC/openunits.F | 105 - source/wham/src-NEWSC/parmread.F | 1108 --- source/wham/src-NEWSC/pinorm.f | 17 - source/wham/src-NEWSC/printmat.f | 16 - source/wham/src-NEWSC/proc_cont.f | 156 - source/wham/src-NEWSC/proc_proc.c | 124 - source/wham/src-NEWSC/promienie.f | 46 - source/wham/src-NEWSC/qwolynes.f | 186 - source/wham/src-NEWSC/read_ref_str.F | 165 - source/wham/src-NEWSC/readpdb.f | 219 - source/wham/src-NEWSC/readrtns.F | 779 -- source/wham/src-NEWSC/readrtns.F.org | 691 -- source/wham/src-NEWSC/readrtns_compar.F | 160 - source/wham/src-NEWSC/rescode.f | 32 - source/wham/src-NEWSC/rmscalc.f | 156 - source/wham/src-NEWSC/secondary.f | 713 -- source/wham/src-NEWSC/setup_var.f | 31 - source/wham/src-NEWSC/slices.F | 80 - source/wham/src-NEWSC/store_parm.F | 547 -- source/wham/src-NEWSC/timing.F | 163 - source/wham/src-NEWSC/wham_calc1.F | 1454 --- source/wham/src-NEWSC/wham_calc1.F.safe | 1195 --- source/wham/src-NEWSC/wham_multparm.F | 277 - source/wham/src-NEWSC/xdrf/Makefile | 27 - source/wham/src-NEWSC/xdrf/ftocstr.c | 35 - source/wham/src-NEWSC/xdrf/libxdrf.m4 | 1233 --- source/wham/src-NEWSC/xdrf/libxdrf.m4.org | 1230 --- source/wham/src-NEWSC/xdrf/underscore.m4 | 19 - source/wham/src-NEWSC/xdrf/xdrf.h | 10 - source/wham/src-NEWSC/xread.F | 187 - 666 files changed, 1 insertion(+), 267640 deletions(-) delete mode 100644 source/unres/src_MD-M-newcorr/BUGS delete mode 100644 source/unres/src_MD-M-newcorr/CMakeLists.txt delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.BANK delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.BOUNDS delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.CACHE delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.CALC delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.CHAIN delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.CONTACTS delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.CONTACTS.moment delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.CONTACTS_safe1 delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.CONTROL delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.CSA delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.DBASE delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.DERIV delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.DERIV_safe delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.DISTFIT delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.FFIELD delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.GEO delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.HAIRPIN delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.HEADER delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.INFO delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.INTERACT delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.IOUNITS delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.LANGEVIN delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.LANGEVIN.lang0 delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.LANGEVIN.lang0_ delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.LOCAL delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.LOCMOVE delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.MAP delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.MAXGRAD delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.MCE delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.MCM delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.MD delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.MINIM delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.MUCA delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.NAMES delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.REMD delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.SBRIDGE delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.SCCOR delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.SCROT delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.SETUP delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.SPLITELE delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.THREAD delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.TIME1 delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.TORCNSTR delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.TORSION delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.VAR delete mode 100644 source/unres/src_MD-M-newcorr/COMMON.VECTORS delete mode 100644 source/unres/src_MD-M-newcorr/DIMENSIONS delete mode 100644 source/unres/src_MD-M-newcorr/DIMENSIONS.2100 delete mode 100644 source/unres/src_MD-M-newcorr/DIMENSIONS.4100 delete mode 100644 source/unres/src_MD-M-newcorr/DIMENSIONS_safe1 delete mode 100644 source/unres/src_MD-M-newcorr/MD.F delete mode 100644 source/unres/src_MD-M-newcorr/MD_A-MTS.F delete mode 100644 source/unres/src_MD-M-newcorr/MD_A-MTS.F_safe delete mode 100644 source/unres/src_MD-M-newcorr/MD_A-MTS.F_safe1 delete mode 100644 source/unres/src_MD-M-newcorr/MP.F delete mode 100644 source/unres/src_MD-M-newcorr/MREMD.F delete mode 100644 source/unres/src_MD-M-newcorr/MREMD.F.drabinka delete mode 100644 source/unres/src_MD-M-newcorr/MREMD.F.safe delete mode 100644 source/unres/src_MD-M-newcorr/MREMD_nosy1traj.F delete mode 120000 source/unres/src_MD-M-newcorr/Makefile delete mode 100644 source/unres/src_MD-M-newcorr/Makefile-biosim delete mode 100644 source/unres/src_MD-M-newcorr/Makefile-intrepid-with-tau delete mode 100644 source/unres/src_MD-M-newcorr/Makefile-matrix-intel delete mode 100644 source/unres/src_MD-M-newcorr/Makefile-matrix3 delete mode 100644 source/unres/src_MD-M-newcorr/Makefile-matrix3-oldparm delete mode 100644 source/unres/src_MD-M-newcorr/Makefile-oldparm delete mode 100644 source/unres/src_MD-M-newcorr/Makefile-rstconv delete mode 100644 source/unres/src_MD-M-newcorr/Makefile-tau-temp delete mode 100644 source/unres/src_MD-M-newcorr/Makefile.tau-mpi-f77-pdt delete mode 100755 source/unres/src_MD-M-newcorr/Makefile.tau-mpi-pdt-pgi.org delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_MPICH_ifort delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_aix_xlf delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_bigben delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_bigben-oldparm delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_bigben-tau delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_intrepid delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_jubl delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_jubl-debug delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_jubl-opt delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_jubl-opt-oldparm delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_lnx_ifc delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64 delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64_galera delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64_galera-oldparm delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64_mpi2 delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_lnx_ifc8 delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_lnx_pgf90 delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_osf_f90 delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_win_ifl delete mode 100644 source/unres/src_MD-M-newcorr/Makefile_win_pgf90 delete mode 100644 source/unres/src_MD-M-newcorr/README delete mode 100644 source/unres/src_MD-M-newcorr/TAU delete mode 100755 source/unres/src_MD-M-newcorr/TAU_setup.sh delete mode 100644 source/unres/src_MD-M-newcorr/WVRND delete mode 100644 source/unres/src_MD-M-newcorr/add.f delete mode 100644 source/unres/src_MD-M-newcorr/arcos.f delete mode 100644 source/unres/src_MD-M-newcorr/banach.f delete mode 100644 source/unres/src_MD-M-newcorr/bank.F delete mode 100644 source/unres/src_MD-M-newcorr/big-sizes delete mode 100644 source/unres/src_MD-M-newcorr/bigsymbols-lang0.txt delete mode 100644 source/unres/src_MD-M-newcorr/blas.f delete mode 100644 source/unres/src_MD-M-newcorr/bond_move.f delete mode 100644 source/unres/src_MD-M-newcorr/brown_step.F delete mode 100644 source/unres/src_MD-M-newcorr/cartder.F delete mode 100644 source/unres/src_MD-M-newcorr/cartprint.f delete mode 100644 source/unres/src_MD-M-newcorr/chainbuild.F delete mode 100644 source/unres/src_MD-M-newcorr/change.awk delete mode 100644 source/unres/src_MD-M-newcorr/check_bond.f delete mode 100644 source/unres/src_MD-M-newcorr/check_sc_distr.f delete mode 100644 source/unres/src_MD-M-newcorr/check_sc_map.f delete mode 100644 source/unres/src_MD-M-newcorr/checkder_p.F delete mode 100644 source/unres/src_MD-M-newcorr/common.size delete mode 100644 source/unres/src_MD-M-newcorr/common.size.orig delete mode 100644 source/unres/src_MD-M-newcorr/compare_s1.F delete mode 100644 source/unres/src_MD-M-newcorr/compinfo.c delete mode 100644 source/unres/src_MD-M-newcorr/contact.f delete mode 100644 source/unres/src_MD-M-newcorr/convert.f delete mode 100644 source/unres/src_MD-M-newcorr/cored.f delete mode 100644 source/unres/src_MD-M-newcorr/csa.f delete mode 100644 source/unres/src_MD-M-newcorr/diff12.f delete mode 100644 source/unres/src_MD-M-newcorr/dihed_cons.F delete mode 100644 source/unres/src_MD-M-newcorr/distfit.f delete mode 100644 source/unres/src_MD-M-newcorr/djacob.f delete mode 100644 source/unres/src_MD-M-newcorr/econstr_local.F delete mode 100644 source/unres/src_MD-M-newcorr/ecorr_num.f delete mode 100644 source/unres/src_MD-M-newcorr/eelec.F delete mode 100644 source/unres/src_MD-M-newcorr/eigen.f delete mode 100644 source/unres/src_MD-M-newcorr/elecont.f delete mode 100644 source/unres/src_MD-M-newcorr/energy_p_new-sep.F delete mode 100644 source/unres/src_MD-M-newcorr/energy_p_new-sep_barrier.F delete mode 100644 source/unres/src_MD-M-newcorr/energy_p_new.F delete mode 100644 source/unres/src_MD-M-newcorr/energy_p_new_barrier.F delete mode 100644 source/unres/src_MD-M-newcorr/energy_p_new_barrier.F.safe delete mode 100644 source/unres/src_MD-M-newcorr/energy_split-sep.F delete mode 100644 source/unres/src_MD-M-newcorr/energy_split.F delete mode 100644 source/unres/src_MD-M-newcorr/entmcm.F delete mode 100644 source/unres/src_MD-M-newcorr/env.log delete mode 100644 source/unres/src_MD-M-newcorr/fitsq.f delete mode 100644 source/unres/src_MD-M-newcorr/gauss.f delete mode 100644 source/unres/src_MD-M-newcorr/gen_rand_conf.F delete mode 100644 source/unres/src_MD-M-newcorr/geomout.F delete mode 100644 source/unres/src_MD-M-newcorr/gnmr1.f delete mode 100644 source/unres/src_MD-M-newcorr/gradient_p.F delete mode 100644 source/unres/src_MD-M-newcorr/indexx.f delete mode 100644 source/unres/src_MD-M-newcorr/initialize_p.F delete mode 100644 source/unres/src_MD-M-newcorr/int_to_cart.f delete mode 100644 source/unres/src_MD-M-newcorr/intcartderiv.F delete mode 100644 source/unres/src_MD-M-newcorr/intcor.f delete mode 100644 source/unres/src_MD-M-newcorr/intlocal.f delete mode 100644 source/unres/src_MD-M-newcorr/kinetic_lesyng.f delete mode 100644 source/unres/src_MD-M-newcorr/lagrangian_lesyng.F delete mode 100644 source/unres/src_MD-M-newcorr/local_move.f delete mode 100644 source/unres/src_MD-M-newcorr/make-tau.log delete mode 100644 source/unres/src_MD-M-newcorr/map.f delete mode 100644 source/unres/src_MD-M-newcorr/matmult.f delete mode 100644 source/unres/src_MD-M-newcorr/mc.F delete mode 100644 source/unres/src_MD-M-newcorr/mcm.F delete mode 100644 source/unres/src_MD-M-newcorr/minim_jlee.F delete mode 100644 source/unres/src_MD-M-newcorr/minim_mcmf.F delete mode 100644 source/unres/src_MD-M-newcorr/minimize_p.F delete mode 100644 source/unres/src_MD-M-newcorr/misc.f delete mode 100644 source/unres/src_MD-M-newcorr/module.log delete mode 100644 source/unres/src_MD-M-newcorr/moments.f delete mode 100644 source/unres/src_MD-M-newcorr/muca_md.f delete mode 100644 source/unres/src_MD-M-newcorr/newconf.f delete mode 100644 source/unres/src_MD-M-newcorr/objects.sizes delete mode 100644 source/unres/src_MD-M-newcorr/parmread.F delete mode 100644 source/unres/src_MD-M-newcorr/pdtf5579.pdb delete mode 100644 source/unres/src_MD-M-newcorr/permut.F delete mode 100644 source/unres/src_MD-M-newcorr/pinorm.f delete mode 100644 source/unres/src_MD-M-newcorr/printmat.f delete mode 100644 source/unres/src_MD-M-newcorr/prng.f delete mode 100644 source/unres/src_MD-M-newcorr/prng_32.F delete mode 100644 source/unres/src_MD-M-newcorr/proc_proc.c delete mode 100644 source/unres/src_MD-M-newcorr/q_measure.F delete mode 100644 source/unres/src_MD-M-newcorr/q_measure1.F delete mode 100644 source/unres/src_MD-M-newcorr/q_measure3.F delete mode 100644 source/unres/src_MD-M-newcorr/ran.f delete mode 100644 source/unres/src_MD-M-newcorr/randgens.f delete mode 100644 source/unres/src_MD-M-newcorr/random_multi_chain/cont.unr delete mode 100644 source/unres/src_MD-M-newcorr/random_multi_chain/ext_mono.pdb delete mode 100644 source/unres/src_MD-M-newcorr/random_multi_chain/ext_sing.pdb delete mode 100644 source/unres/src_MD-M-newcorr/random_multi_chain/fort.4 delete mode 100644 source/unres/src_MD-M-newcorr/random_multi_chain/output.pdb delete mode 100644 source/unres/src_MD-M-newcorr/random_multi_chain/random.f delete mode 100755 source/unres/src_MD-M-newcorr/random_multi_chain/toggle delete mode 100644 source/unres/src_MD-M-newcorr/rattle.F delete mode 100644 source/unres/src_MD-M-newcorr/readpdb.F delete mode 100644 source/unres/src_MD-M-newcorr/readpdb.f delete mode 100644 source/unres/src_MD-M-newcorr/readrtns_CSA.F delete mode 100644 source/unres/src_MD-M-newcorr/refsys.f delete mode 100644 source/unres/src_MD-M-newcorr/regularize.F delete mode 100644 source/unres/src_MD-M-newcorr/rescode.f delete mode 100644 source/unres/src_MD-M-newcorr/restbin2asc.F delete mode 100644 source/unres/src_MD-M-newcorr/rmdd.f delete mode 100644 source/unres/src_MD-M-newcorr/rmsd.F delete mode 100644 source/unres/src_MD-M-newcorr/sc_move.F delete mode 100644 source/unres/src_MD-M-newcorr/select.tau delete mode 100644 source/unres/src_MD-M-newcorr/shift.F delete mode 100644 source/unres/src_MD-M-newcorr/sizes.i delete mode 100644 source/unres/src_MD-M-newcorr/sort.f delete mode 100644 source/unres/src_MD-M-newcorr/ssMD.F delete mode 100644 source/unres/src_MD-M-newcorr/stochfric.F delete mode 100644 source/unres/src_MD-M-newcorr/sumsld.f delete mode 100644 source/unres/src_MD-M-newcorr/surfatom.f delete mode 100644 source/unres/src_MD-M-newcorr/symbols-lang0.txt delete mode 100644 source/unres/src_MD-M-newcorr/symbolsizes.txt delete mode 100644 source/unres/src_MD-M-newcorr/tau.options delete mode 100644 source/unres/src_MD-M-newcorr/test.F delete mode 100644 source/unres/src_MD-M-newcorr/thread.F delete mode 100644 source/unres/src_MD-M-newcorr/timing.F delete mode 100644 source/unres/src_MD-M-newcorr/together.F delete mode 100644 source/unres/src_MD-M-newcorr/unres.F delete mode 120000 source/unres/src_MD-M-newcorr/xdrf delete mode 100644 source/unres/src_MD_DFA/CMakeLists.txt delete mode 100644 source/unres/src_MD_DFA/COMMON.BOUNDS delete mode 100644 source/unres/src_MD_DFA/COMMON.CACHE delete mode 100644 source/unres/src_MD_DFA/COMMON.CALC delete mode 100644 source/unres/src_MD_DFA/COMMON.CHAIN delete mode 100644 source/unres/src_MD_DFA/COMMON.CONTACTS delete mode 100644 source/unres/src_MD_DFA/COMMON.CONTACTS.moment delete mode 100644 source/unres/src_MD_DFA/COMMON.CONTROL delete mode 100644 source/unres/src_MD_DFA/COMMON.DBASE delete mode 100644 source/unres/src_MD_DFA/COMMON.DERIV delete mode 100644 source/unres/src_MD_DFA/COMMON.DFA delete mode 100644 source/unres/src_MD_DFA/COMMON.DISTFIT delete mode 100644 source/unres/src_MD_DFA/COMMON.FFIELD delete mode 100644 source/unres/src_MD_DFA/COMMON.GEO delete mode 100644 source/unres/src_MD_DFA/COMMON.HAIRPIN delete mode 100644 source/unres/src_MD_DFA/COMMON.HEADER delete mode 100644 source/unres/src_MD_DFA/COMMON.INFO delete mode 100644 source/unres/src_MD_DFA/COMMON.INTERACT delete mode 100644 source/unres/src_MD_DFA/COMMON.IOUNITS delete mode 100644 source/unres/src_MD_DFA/COMMON.LANGEVIN delete mode 100644 source/unres/src_MD_DFA/COMMON.LANGEVIN.lang0 delete mode 100644 source/unres/src_MD_DFA/COMMON.LOCAL delete mode 100644 source/unres/src_MD_DFA/COMMON.LOCMOVE delete mode 100644 source/unres/src_MD_DFA/COMMON.MAP delete mode 100644 source/unres/src_MD_DFA/COMMON.MAXGRAD delete mode 100644 source/unres/src_MD_DFA/COMMON.MCE delete mode 100644 source/unres/src_MD_DFA/COMMON.MCM delete mode 100644 source/unres/src_MD_DFA/COMMON.MD delete mode 100644 source/unres/src_MD_DFA/COMMON.MINIM delete mode 100644 source/unres/src_MD_DFA/COMMON.MUCA delete mode 100644 source/unres/src_MD_DFA/COMMON.NAMES delete mode 100644 source/unres/src_MD_DFA/COMMON.REFSYS delete mode 100644 source/unres/src_MD_DFA/COMMON.REMD delete mode 100644 source/unres/src_MD_DFA/COMMON.SBRIDGE delete mode 100644 source/unres/src_MD_DFA/COMMON.SCCOR delete mode 100644 source/unres/src_MD_DFA/COMMON.SCROT delete mode 100644 source/unres/src_MD_DFA/COMMON.SETUP delete mode 100644 source/unres/src_MD_DFA/COMMON.SPLITELE delete mode 100644 source/unres/src_MD_DFA/COMMON.THREAD delete mode 100644 source/unres/src_MD_DFA/COMMON.TIME1 delete mode 100644 source/unres/src_MD_DFA/COMMON.TORCNSTR delete mode 100644 source/unres/src_MD_DFA/COMMON.TORSION delete mode 100644 source/unres/src_MD_DFA/COMMON.VAR delete mode 100644 source/unres/src_MD_DFA/COMMON.VECTORS delete mode 100644 source/unres/src_MD_DFA/DIMENSIONS delete mode 100644 source/unres/src_MD_DFA/DIMENSIONS.2100 delete mode 100644 source/unres/src_MD_DFA/DIMENSIONS.4100 delete mode 100644 source/unres/src_MD_DFA/MD_A-MTS.F delete mode 100644 source/unres/src_MD_DFA/MP.F delete mode 100644 source/unres/src_MD_DFA/MREMD.F delete mode 100644 source/unres/src_MD_DFA/Makefile-intrepid-with-tau delete mode 100644 source/unres/src_MD_DFA/Makefile.tau-mpi-f77-pdt delete mode 100644 source/unres/src_MD_DFA/Makefile_MPICH_ifort delete mode 100644 source/unres/src_MD_DFA/Makefile_aix_xlf delete mode 100644 source/unres/src_MD_DFA/Makefile_bigben delete mode 100644 source/unres/src_MD_DFA/Makefile_bigben-oldparm delete mode 100644 source/unres/src_MD_DFA/Makefile_bigben-tau delete mode 100644 source/unres/src_MD_DFA/Makefile_galera delete mode 100644 source/unres/src_MD_DFA/Makefile_intrepid delete mode 100644 source/unres/src_MD_DFA/Makefile_lnx_ifc10_opteron delete mode 100644 source/unres/src_MD_DFA/Makefile_lnx_ifc10_opteron_oldparm delete mode 100644 source/unres/src_MD_DFA/Makefile_single_gfortran delete mode 100644 source/unres/src_MD_DFA/Makefile_single_ifort delete mode 100644 source/unres/src_MD_DFA/README delete mode 100644 source/unres/src_MD_DFA/add.f delete mode 100644 source/unres/src_MD_DFA/arcos.f delete mode 100644 source/unres/src_MD_DFA/banach.f delete mode 100644 source/unres/src_MD_DFA/blas.f delete mode 100644 source/unres/src_MD_DFA/bond_move.f delete mode 100644 source/unres/src_MD_DFA/cartder.F delete mode 100644 source/unres/src_MD_DFA/cartprint.f delete mode 100644 source/unres/src_MD_DFA/chainbuild.F delete mode 100644 source/unres/src_MD_DFA/change.awk delete mode 100644 source/unres/src_MD_DFA/check_bond.f delete mode 100644 source/unres/src_MD_DFA/check_sc_distr.f delete mode 100644 source/unres/src_MD_DFA/checkder_p.F delete mode 100644 source/unres/src_MD_DFA/compare_s1.F delete mode 100644 source/unres/src_MD_DFA/compinfo.c delete mode 100644 source/unres/src_MD_DFA/contact.f delete mode 100644 source/unres/src_MD_DFA/convert.f delete mode 100644 source/unres/src_MD_DFA/cored.f delete mode 100644 source/unres/src_MD_DFA/dfa.F delete mode 100644 source/unres/src_MD_DFA/dihed_cons.F delete mode 100644 source/unres/src_MD_DFA/djacob.f delete mode 100644 source/unres/src_MD_DFA/econstr_local.F delete mode 100644 source/unres/src_MD_DFA/eigen.f delete mode 100644 source/unres/src_MD_DFA/elecont.f delete mode 100644 source/unres/src_MD_DFA/energy_p_new-sep_barrier.F delete mode 100644 source/unres/src_MD_DFA/energy_p_new_barrier.F delete mode 100644 source/unres/src_MD_DFA/energy_split-sep.F delete mode 100644 source/unres/src_MD_DFA/entmcm.F delete mode 100644 source/unres/src_MD_DFA/fitsq.f delete mode 100644 source/unres/src_MD_DFA/gauss.f delete mode 100644 source/unres/src_MD_DFA/gen_rand_conf.F delete mode 100644 source/unres/src_MD_DFA/geomout.F delete mode 100644 source/unres/src_MD_DFA/gnmr1.f delete mode 100644 source/unres/src_MD_DFA/gradient_p.F delete mode 100644 source/unres/src_MD_DFA/initialize_p.F delete mode 100644 source/unres/src_MD_DFA/int_to_cart.f delete mode 100644 source/unres/src_MD_DFA/intcartderiv.F delete mode 100644 source/unres/src_MD_DFA/intcor.f delete mode 100644 source/unres/src_MD_DFA/intlocal.f delete mode 100644 source/unres/src_MD_DFA/kinetic_lesyng.f delete mode 100644 source/unres/src_MD_DFA/lagrangian_lesyng.F delete mode 100644 source/unres/src_MD_DFA/local_move.f delete mode 100644 source/unres/src_MD_DFA/map.f delete mode 100644 source/unres/src_MD_DFA/matmult.f delete mode 100644 source/unres/src_MD_DFA/mc.F delete mode 100644 source/unres/src_MD_DFA/mcm.F delete mode 100644 source/unres/src_MD_DFA/minim_mcmf.F delete mode 100644 source/unres/src_MD_DFA/minimize_p.F delete mode 100644 source/unres/src_MD_DFA/misc.f delete mode 100644 source/unres/src_MD_DFA/moments.f delete mode 100644 source/unres/src_MD_DFA/muca_md.f delete mode 100644 source/unres/src_MD_DFA/parmread.F delete mode 100644 source/unres/src_MD_DFA/pinorm.f delete mode 100644 source/unres/src_MD_DFA/printmat.f delete mode 100644 source/unres/src_MD_DFA/prng.f delete mode 100644 source/unres/src_MD_DFA/prng_32.F delete mode 100644 source/unres/src_MD_DFA/proc_proc.c delete mode 100644 source/unres/src_MD_DFA/q_measure.F delete mode 100644 source/unres/src_MD_DFA/q_measure1.F delete mode 100644 source/unres/src_MD_DFA/q_measure3.F delete mode 100644 source/unres/src_MD_DFA/randgens.f delete mode 100644 source/unres/src_MD_DFA/rattle.F delete mode 100644 source/unres/src_MD_DFA/readpdb.F delete mode 100644 source/unres/src_MD_DFA/readrtns.F delete mode 100644 source/unres/src_MD_DFA/refsys.f delete mode 100644 source/unres/src_MD_DFA/regularize.F delete mode 100644 source/unres/src_MD_DFA/rescode.f delete mode 100644 source/unres/src_MD_DFA/rmdd.f delete mode 100644 source/unres/src_MD_DFA/rmsd.F delete mode 100644 source/unres/src_MD_DFA/sc_move.F delete mode 100644 source/unres/src_MD_DFA/sizes.i delete mode 100644 source/unres/src_MD_DFA/sort.f delete mode 100644 source/unres/src_MD_DFA/stochfric.F delete mode 100644 source/unres/src_MD_DFA/sumsld.f delete mode 100644 source/unres/src_MD_DFA/surfatom.f delete mode 100644 source/unres/src_MD_DFA/test.F delete mode 100644 source/unres/src_MD_DFA/thread.F delete mode 100644 source/unres/src_MD_DFA/timing.F delete mode 100644 source/unres/src_MD_DFA/unres.F delete mode 120000 source/unres/src_MD_DFA/xdrf delete mode 100644 source/unres/src_MIN/CMakeLists.txt delete mode 100644 source/unres/src_MIN/COMMON.BOUNDS delete mode 100644 source/unres/src_MIN/COMMON.CALC delete mode 100644 source/unres/src_MIN/COMMON.CHAIN delete mode 100644 source/unres/src_MIN/COMMON.CONTACTS delete mode 100644 source/unres/src_MIN/COMMON.CONTROL delete mode 100644 source/unres/src_MIN/COMMON.DERIV delete mode 100644 source/unres/src_MIN/COMMON.DISTFIT delete mode 100644 source/unres/src_MIN/COMMON.FFIELD delete mode 100644 source/unres/src_MIN/COMMON.GEO delete mode 100644 source/unres/src_MIN/COMMON.HEADER delete mode 100644 source/unres/src_MIN/COMMON.INTERACT delete mode 100644 source/unres/src_MIN/COMMON.IOUNITS delete mode 100644 source/unres/src_MIN/COMMON.LOCAL delete mode 100644 source/unres/src_MIN/COMMON.MAXGRAD delete mode 100644 source/unres/src_MIN/COMMON.MCM delete mode 100644 source/unres/src_MIN/COMMON.MD_ delete mode 100644 source/unres/src_MIN/COMMON.MINIM delete mode 100644 source/unres/src_MIN/COMMON.NAMES delete mode 100644 source/unres/src_MIN/COMMON.SBRIDGE delete mode 100644 source/unres/src_MIN/COMMON.SCCOR delete mode 100644 source/unres/src_MIN/COMMON.SCROT delete mode 100644 source/unres/src_MIN/COMMON.SETUP delete mode 100644 source/unres/src_MIN/COMMON.SPLITELE delete mode 100644 source/unres/src_MIN/COMMON.TIME1 delete mode 100644 source/unres/src_MIN/COMMON.TORCNSTR delete mode 100644 source/unres/src_MIN/COMMON.TORSION delete mode 100644 source/unres/src_MIN/COMMON.VAR delete mode 100644 source/unres/src_MIN/COMMON.VECTORS delete mode 100644 source/unres/src_MIN/DIMENSIONS delete mode 100644 source/unres/src_MIN/MP.F delete mode 120000 source/unres/src_MIN/Makefile delete mode 100644 source/unres/src_MIN/Makefile_gfortran_single delete mode 100644 source/unres/src_MIN/Makefile_ifort_single delete mode 100644 source/unres/src_MIN/arcos.f delete mode 100644 source/unres/src_MIN/cartder.F delete mode 100644 source/unres/src_MIN/cartprint.f delete mode 100644 source/unres/src_MIN/chainbuild.F delete mode 100644 source/unres/src_MIN/checkder_p.F delete mode 100644 source/unres/src_MIN/compinfo.c delete mode 100644 source/unres/src_MIN/convert.f delete mode 100644 source/unres/src_MIN/cored.f delete mode 100644 source/unres/src_MIN/djacob.f delete mode 100644 source/unres/src_MIN/econstr_local.F delete mode 100644 source/unres/src_MIN/energy_p_new_barrier.F delete mode 100644 source/unres/src_MIN/gen_rand_conf.F delete mode 100644 source/unres/src_MIN/geomout_min.F delete mode 100644 source/unres/src_MIN/gradient_p.F delete mode 100644 source/unres/src_MIN/initialize_p.F delete mode 100644 source/unres/src_MIN/int_to_cart.f delete mode 100644 source/unres/src_MIN/intcartderiv.F delete mode 100644 source/unres/src_MIN/intcor.f delete mode 100644 source/unres/src_MIN/intlocal.f delete mode 100644 source/unres/src_MIN/matmult.f delete mode 100644 source/unres/src_MIN/minimize_p.F delete mode 100644 source/unres/src_MIN/misc.f delete mode 100644 source/unres/src_MIN/parmread.F delete mode 100644 source/unres/src_MIN/pinorm.f delete mode 100644 source/unres/src_MIN/printmat.f delete mode 100644 source/unres/src_MIN/randgens.f delete mode 100644 source/unres/src_MIN/readpdb.F delete mode 100644 source/unres/src_MIN/readrtns_min.F delete mode 100644 source/unres/src_MIN/refsys.f delete mode 100644 source/unres/src_MIN/rescode.f delete mode 100644 source/unres/src_MIN/rmdd.f delete mode 100644 source/unres/src_MIN/sc_move.F delete mode 100644 source/unres/src_MIN/sumsld.f delete mode 100644 source/unres/src_MIN/timing.F delete mode 100644 source/unres/src_MIN/unres_min.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/CMakeLists.txt delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.ALLPARM delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.CHAIN delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.COMPAR delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.CONTACTS1 delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL.org delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.EMP delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.ENEPS delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.ENERGIES delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.FREE delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.IOUNITS delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.MPI delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.OBCINKA delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.PEPTCONT delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.PROT delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.PROTFILES delete mode 100644 source/wham/src-NEWSC-NEWCORR/COMMON.VAR delete mode 100644 source/wham/src-NEWSC-NEWCORR/DIMENSIONS delete mode 100644 source/wham/src-NEWSC-NEWCORR/DIMENSIONS.COMPAR delete mode 100644 source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE delete mode 100644 source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE.old delete mode 100644 source/wham/src-NEWSC-NEWCORR/DIMENSIONS.ZSCOPT delete mode 120000 source/wham/src-NEWSC-NEWCORR/Makefile delete mode 100644 source/wham/src-NEWSC-NEWCORR/Makefile-pgi delete mode 100644 source/wham/src-NEWSC-NEWCORR/Makefile1_jump delete mode 100644 source/wham/src-NEWSC-NEWCORR/Makefile_MPICH_ifort delete mode 100644 source/wham/src-NEWSC-NEWCORR/Makefile_jubl delete mode 100644 source/wham/src-NEWSC-NEWCORR/Makefile_jump delete mode 100644 source/wham/src-NEWSC-NEWCORR/Makefile_matrix delete mode 100644 source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI delete mode 100644 source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCT-oldparm delete mode 100644 source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCTF-oldparm delete mode 100644 source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-oldparm delete mode 100644 source/wham/src-NEWSC-NEWCORR/a.sh delete mode 100644 source/wham/src-NEWSC-NEWCORR/angnorm.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/arcos.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/bxread.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/cartder.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/cartprint.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/chainbuild.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/chainbuild.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/compinfo.c delete mode 100644 source/wham/src-NEWSC-NEWCORR/conf_compar.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/cont_frag.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/contact.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/contfunc.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/cxread.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/cxread.F.org delete mode 100644 source/wham/src-NEWSC-NEWCORR/define_pairs.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/elecont.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/enecalc1.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/energy_p_new.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/energy_p_new.F.org delete mode 100644 source/wham/src-NEWSC-NEWCORR/fitsq.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/geomout.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/gnmr1.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/icant.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CALC delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTACTS delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTPAR delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.DERIV delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FFIELD delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FRAG delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.GEO delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.HEADER delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.INTERACT delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.LOCAL delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.MINIM delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.NAMES delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SBRIDGE delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCCOR delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCROT delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TIME1 delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORCNSTR delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORSION delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VAR delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VECTORS delete mode 100644 source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.WEIGHTS delete mode 100644 source/wham/src-NEWSC-NEWCORR/initialize_p.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/initialize_p.F.org delete mode 100644 source/wham/src-NEWSC-NEWCORR/int_from_cart.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/intcor.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/make_ensemble1.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/match_contact.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/matmult.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/misc.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/molread_zs.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/mygetenv.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/mysort.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/odlodc.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/openunits.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/parmread.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/pinorm.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/printmat.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/proc_cont.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/proc_proc.c delete mode 100644 source/wham/src-NEWSC-NEWCORR/promienie.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/qwolynes.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/read_ref_str.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/readpdb.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/readrtns.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/readrtns.F.org delete mode 100644 source/wham/src-NEWSC-NEWCORR/readrtns_compar.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/rescode.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/rmscalc.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/secondary.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/setup_var.f delete mode 100644 source/wham/src-NEWSC-NEWCORR/slices.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/store_parm.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/timing.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/wham_calc1.F delete mode 100644 source/wham/src-NEWSC-NEWCORR/wham_calc1.F.safe delete mode 100644 source/wham/src-NEWSC-NEWCORR/wham_multparm.F delete mode 120000 source/wham/src-NEWSC-NEWCORR/xdrf delete mode 100644 source/wham/src-NEWSC-NEWCORR/xread.F delete mode 100755 source/wham/src-NEWSC/CMakeLists.txt delete mode 100755 source/wham/src-NEWSC/COMMON.ALLPARM delete mode 100755 source/wham/src-NEWSC/COMMON.CHAIN delete mode 100755 source/wham/src-NEWSC/COMMON.COMPAR delete mode 100755 source/wham/src-NEWSC/COMMON.CONTACTS1 delete mode 100755 source/wham/src-NEWSC/COMMON.CONTROL delete mode 100755 source/wham/src-NEWSC/COMMON.CONTROL.org delete mode 100755 source/wham/src-NEWSC/COMMON.EMP delete mode 100755 source/wham/src-NEWSC/COMMON.ENEPS delete mode 100755 source/wham/src-NEWSC/COMMON.ENERGIES delete mode 100755 source/wham/src-NEWSC/COMMON.FREE delete mode 100755 source/wham/src-NEWSC/COMMON.IOUNITS delete mode 100755 source/wham/src-NEWSC/COMMON.MPI delete mode 100755 source/wham/src-NEWSC/COMMON.OBCINKA delete mode 100755 source/wham/src-NEWSC/COMMON.PEPTCONT delete mode 100755 source/wham/src-NEWSC/COMMON.PROT delete mode 100755 source/wham/src-NEWSC/COMMON.PROTFILES delete mode 100755 source/wham/src-NEWSC/COMMON.VAR delete mode 100755 source/wham/src-NEWSC/DIMENSIONS delete mode 100755 source/wham/src-NEWSC/DIMENSIONS.COMPAR delete mode 100755 source/wham/src-NEWSC/DIMENSIONS.FREE delete mode 100755 source/wham/src-NEWSC/DIMENSIONS.FREE.old delete mode 100755 source/wham/src-NEWSC/DIMENSIONS.ZSCOPT delete mode 100755 source/wham/src-NEWSC/Makefile delete mode 100755 source/wham/src-NEWSC/Makefile-pgi delete mode 100755 source/wham/src-NEWSC/Makefile1_jump delete mode 100755 source/wham/src-NEWSC/Makefile_MPICH_ifort delete mode 100755 source/wham/src-NEWSC/Makefile_jubl delete mode 100755 source/wham/src-NEWSC/Makefile_jump delete mode 100755 source/wham/src-NEWSC/Makefile_matrix delete mode 100755 source/wham/src-NEWSC/Makefile_matrix_PGI delete mode 100755 source/wham/src-NEWSC/Makefile_matrix_PGI-SCT-oldparm delete mode 100755 source/wham/src-NEWSC/Makefile_matrix_PGI-SCTF-oldparm delete mode 100755 source/wham/src-NEWSC/Makefile_matrix_PGI-oldparm delete mode 100755 source/wham/src-NEWSC/a.sh delete mode 100755 source/wham/src-NEWSC/angnorm.f delete mode 100755 source/wham/src-NEWSC/arcos.f delete mode 100755 source/wham/src-NEWSC/bxread.F delete mode 100755 source/wham/src-NEWSC/cartder.f delete mode 100755 source/wham/src-NEWSC/cartprint.f delete mode 100755 source/wham/src-NEWSC/chainbuild.F delete mode 100755 source/wham/src-NEWSC/chainbuild.f delete mode 100755 source/wham/src-NEWSC/compinfo.c delete mode 100755 source/wham/src-NEWSC/conf_compar.F delete mode 100755 source/wham/src-NEWSC/cont_frag.f delete mode 100755 source/wham/src-NEWSC/contact.f delete mode 100755 source/wham/src-NEWSC/contfunc.f delete mode 100755 source/wham/src-NEWSC/cxread.F delete mode 100755 source/wham/src-NEWSC/cxread.F.org delete mode 100755 source/wham/src-NEWSC/define_pairs.f delete mode 100755 source/wham/src-NEWSC/elecont.f delete mode 100755 source/wham/src-NEWSC/enecalc1.F delete mode 100755 source/wham/src-NEWSC/energy_p_new.F delete mode 100755 source/wham/src-NEWSC/energy_p_new.F.org delete mode 100755 source/wham/src-NEWSC/fitsq.f delete mode 100755 source/wham/src-NEWSC/geomout.F delete mode 100755 source/wham/src-NEWSC/gnmr1.f delete mode 100755 source/wham/src-NEWSC/icant.f delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.CALC delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.CONTACTS delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.CONTPAR delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.DERIV delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.FFIELD delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.FRAG delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.GEO delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.HEADER delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.INTERACT delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.LOCAL delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.MINIM delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.NAMES delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.SBRIDGE delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.SCCOR delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.SCROT delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.TIME1 delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.TORCNSTR delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.TORSION delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.VAR delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.VECTORS delete mode 100755 source/wham/src-NEWSC/include_unres/COMMON.WEIGHTS delete mode 100755 source/wham/src-NEWSC/initialize_p.F delete mode 100755 source/wham/src-NEWSC/initialize_p.F.org delete mode 100755 source/wham/src-NEWSC/int_from_cart.f delete mode 100755 source/wham/src-NEWSC/intcor.f delete mode 100755 source/wham/src-NEWSC/make_ensemble1.F delete mode 100755 source/wham/src-NEWSC/match_contact.f delete mode 100755 source/wham/src-NEWSC/matmult.f delete mode 100755 source/wham/src-NEWSC/misc.f delete mode 100755 source/wham/src-NEWSC/molread_zs.F delete mode 100755 source/wham/src-NEWSC/mygetenv.F delete mode 100755 source/wham/src-NEWSC/mysort.f delete mode 100755 source/wham/src-NEWSC/odlodc.f delete mode 100755 source/wham/src-NEWSC/openunits.F delete mode 100755 source/wham/src-NEWSC/parmread.F delete mode 100755 source/wham/src-NEWSC/pinorm.f delete mode 100755 source/wham/src-NEWSC/printmat.f delete mode 100755 source/wham/src-NEWSC/proc_cont.f delete mode 100755 source/wham/src-NEWSC/proc_proc.c delete mode 100755 source/wham/src-NEWSC/promienie.f delete mode 100755 source/wham/src-NEWSC/qwolynes.f delete mode 100755 source/wham/src-NEWSC/read_ref_str.F delete mode 100755 source/wham/src-NEWSC/readpdb.f delete mode 100755 source/wham/src-NEWSC/readrtns.F delete mode 100755 source/wham/src-NEWSC/readrtns.F.org delete mode 100755 source/wham/src-NEWSC/readrtns_compar.F delete mode 100755 source/wham/src-NEWSC/rescode.f delete mode 100755 source/wham/src-NEWSC/rmscalc.f delete mode 100755 source/wham/src-NEWSC/secondary.f delete mode 100755 source/wham/src-NEWSC/setup_var.f delete mode 100755 source/wham/src-NEWSC/slices.F delete mode 100755 source/wham/src-NEWSC/store_parm.F delete mode 100755 source/wham/src-NEWSC/timing.F delete mode 100755 source/wham/src-NEWSC/wham_calc1.F delete mode 100755 source/wham/src-NEWSC/wham_calc1.F.safe delete mode 100755 source/wham/src-NEWSC/wham_multparm.F delete mode 100644 source/wham/src-NEWSC/xdrf/Makefile delete mode 100644 source/wham/src-NEWSC/xdrf/ftocstr.c delete mode 100644 source/wham/src-NEWSC/xdrf/libxdrf.m4 delete mode 100644 source/wham/src-NEWSC/xdrf/libxdrf.m4.org delete mode 100644 source/wham/src-NEWSC/xdrf/underscore.m4 delete mode 100644 source/wham/src-NEWSC/xdrf/xdrf.h delete mode 100755 source/wham/src-NEWSC/xread.F diff --git a/ctest/dock/wham.inp b/ctest/dock/wham.inp index 1b83d17..40431b1 100644 --- a/ctest/dock/wham.inp +++ b/ctest/dock/wham.inp @@ -1,6 +1,6 @@ isampl=1 & SEED=-77763650 einicheck=1 rescale=2 delta=0.02 cxfile classify & - n_ene=19 CONSTR_HOMOL=8 & + CONSTR_HOMOL=8 & BOXX=78.90 BOXY=78.90 BOXZ=78.90 nres=49 one_letter GVVDSCCRNSCSFSTLRAYCDSXXNSLRACGPALMDMLRVACPNGFNSX diff --git a/source/unres/src_MD-M-newcorr/BUGS b/source/unres/src_MD-M-newcorr/BUGS deleted file mode 100644 index ad2c176..0000000 --- a/source/unres/src_MD-M-newcorr/BUGS +++ /dev/null @@ -1,6 +0,0 @@ - do i=iturn4_start,iturn4_end - if (itype(i).eq.21 .or. itype(i+1).eq.21 .or. -c-----> Probably bug; should also handle itype(i+2) - & .or. itype(i+3).eq.21 - & .or. itype(i+4).eq.21) cycle - diff --git a/source/unres/src_MD-M-newcorr/CMakeLists.txt b/source/unres/src_MD-M-newcorr/CMakeLists.txt deleted file mode 100644 index 29291da..0000000 --- a/source/unres/src_MD-M-newcorr/CMakeLists.txt +++ /dev/null @@ -1,357 +0,0 @@ -# -# CMake project file for UNRES with MD for single chains -# - -enable_language (Fortran) - -#================================ -# Set source file lists -#================================ -set(UNRES_MDM_SRC0 - add.f - arcos.f - banach.f - bank.F - blas.f - bond_move.f - cartder.F - cartprint.f - chainbuild.F - check_bond.f - checkder_p.F - check_sc_distr.f - compare_s1.F - contact.f - convert.f - cored.f - csa.f - dihed_cons.F - diff12.f - distfit.f - djacob.f - econstr_local.F - eigen.f - elecont.f - energy_split-sep.F - entmcm.F - fitsq.f - gauss.f - gen_rand_conf.F - geomout.F - gnmr1.f - indexx.f - initialize_p.F - intcartderiv.F - intcor.f - intlocal.f - int_to_cart.f - kinetic_lesyng.f - lagrangian_lesyng.F - local_move.f - map.f - matmult.f - mc.F - mcm.F - MD_A-MTS.F - minimize_p.F - minim_jlee.F - minim_mcmf.F - misc.f - moments.f - MP.F - MREMD.F - muca_md.f - newconf.f - parmread.F - permut.F - pinorm.f - printmat.f - prng_32.F - q_measure.F - ran.f - randgens.f - rattle.F - readpdb.F - readrtns_CSA.F - refsys.f - regularize.F - rescode.f - rmdd.f - rmsd.F - sc_move.F - shift.F - sort.f - stochfric.F - sumsld.f - surfatom.f - test.F - thread.F - timing.F - together.F - unres.F - ssMD.F -) - -set(UNRES_MDM_SRC3 energy_p_new_barrier.F energy_p_new-sep_barrier.F gradient_p.F ) - -set(UNRES_MDM_PP_SRC - bank.F - cartder.F - chainbuild.F - checkder_p.F - compare_s1.F - cored.f - csa.f - dihed_cons.F - diff12.f - econstr_local.F - energy_p_new.F - energy_p_new_barrier.F - energy_p_new-sep_barrier.F - energy_split-sep.F - entmcm.F - gen_rand_conf.F - geomout.F - gradient_p.F - intcor.f - initialize_p.F - intcartderiv.F - lagrangian_lesyng.F - matmult.f - mc.F - mcm.F - MD_A-MTS.F - minimize_p.F - minim_jlee.F - minim_mcmf.F - MP.F - MREMD.F - newconf.f - parmread.F - permut.F - prng_32.F - q_measure1.F - q_measure3.F - q_measure.F - ran.f - rattle.F - readpdb.F - readrtns_CSA.F - regularize.F - rmdd.f - rmsd.F - sc_move.F - shift.F - stochfric.F - sumsld.f - test.F - thread.F - timing.F - together.F - unres.F - proc_proc.c -) - - -if(NOT Fortran_COMPILER_NAME STREQUAL "ifort") - set(UNRES_MDM_PP_SRC "${UNRES_MDM_PP_SRC} prng_32.F") -endif(NOT Fortran_COMPILER_NAME STREQUAL "ifort") - - -#================================================ -# Set comipiler flags for different sourcefiles -#================================================ -if (Fortran_COMPILER_NAME STREQUAL "ifort") - set(FFLAGS0 "-ip -w" ) - set(FFLAGS1 "-w -g -d2 -CA -CB" ) - set(FFLAGS2 "-w -g -00 ") - set(FFLAGS3 "-w -ipo " ) -elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") - set(FFLAGS0 "-std=legacy -I. " ) - set(FFLAGS1 "-std=legacy -g -I. " ) - set(FFLAGS2 "-std=legacy -I. ") - set(FFLAGS3 "-std=legacy -I. " ) -endif (Fortran_COMPILER_NAME STREQUAL "ifort") - - -# Add MPI compiler flags -if(UNRES_WITH_MPI) - set(FFLAGS0 "${FFLAGS0} -I${MPI_Fortran_INCLUDE_PATH}") - set(FFLAGS1 "${FFLAGS1} -I${MPI_Fortran_INCLUDE_PATH}") - set(FFLAGS2 "${FFLAGS2} -I${MPI_Fortran_INCLUDE_PATH}") - set(FFLAGS3 "${FFLAGS3} -I${MPI_Fortran_INCLUDE_PATH}") -endif(UNRES_WITH_MPI) - -set_property(SOURCE ${UNRES_MDM_SRC0} APPEND PROPERTY COMPILE_FLAGS ${FFLAGS0} ) -#set_property(SOURCE ${UNRES_MD_SRC1} PROPERTY COMPILE_FLAGS ${FFLAGS1} ) -#set_property(SOURCE ${UNRES_MD_SRC2} PROPERTY COMPILE_FLAGS ${FFLAGS2} ) -set_property(SOURCE ${UNRES_MDM_SRC3} PROPERTY COMPILE_FLAGS ${FFLAGS3} ) - -#========================================= -# Settings for GAB force field -#========================================= -if(UNRES_MD_FF STREQUAL "GAB" ) - # set preprocesor flags - set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCCORPDB -DTIMING -DTIMING_ENE" ) - -#========================================= -# Settings for E0LL2Y force field -#========================================= -elseif(UNRES_MD_FF STREQUAL "E0LL2Y") - # set preprocesor flags - set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0 -DSCCORPDB -DNEWCORR" ) -endif(UNRES_MD_FF STREQUAL "GAB") - - -#========================================= -# System specific flags -#========================================= -if(${CMAKE_SYSTEM_NAME} MATCHES "Linux") - set(CPPFLAGS "${CPPFLAGS} -DLINUX") -endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux") - - -#========================================= -# Compiler specific flags -#========================================= - -if (Fortran_COMPILER_NAME STREQUAL "ifort") - # Add ifort preprocessor flags - set(CPPFLAGS "${CPPFLAGS} -DPGI") -elseif (Fortran_COMPILER_NAME STREQUAL "f95") - # Add new gfortran flags - set(CPPFLAGS "${CPPFLAGS} -DG77") -elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") - # Add old gfortran flags - set(CPPFLAGS "${CPPFLAGS} -DG77") -else (Fortran_COMPILER_NAME STREQUAL "ifort") - # Default preprocessor flags - set(CPPFLAGS "${CPPFLAGS} -DPGI") -endif (Fortran_COMPILER_NAME STREQUAL "ifort") - - -#========================================= -# Add MPI preprocessor flags -#========================================= -if (UNRES_WITH_MPI) - set(CPPFLAGS "${CPPFLAGS} -DMP -DMPI") -endif(UNRES_WITH_MPI) - - -#========================================= -# 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_MDM_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) - -# Apply preprocesor flags to proc_proc.c -set_property(SOURCE proc_proc.c PROPERTY COMPILE_DEFINITIONS "SGI" ) - - -#======================================== -# Setting binary name -#======================================== -if(UNRES_WITH_MPI) - # binary with mpi - set(UNRES_BIN "unresMD-M_${Fortran_COMPILER_NAME}_MPICH_${UNRES_MD_FF}.exe") -else(UNRES_WITH_MPI) - # binary without mpi - set(UNRES_BIN "unresMD-M_${Fortran_COMPILER_NAME}_single_${UNRES_MD_FF}.exe") -endif(UNRES_WITH_MPI) - -#========================================= -# cinfo.f workaround for cmake -#========================================= -# get the current date -TODAY(DATE) -# generate cinfo.f -set(CINFO "${CMAKE_CURRENT_BINARY_DIR}/cinfo.f") -FILE(WRITE ${CINFO} -"C CMake generated file - subroutine cinfo - include 'COMMON.IOUNITS' - write(iout,*)'++++ Compile info ++++' - write(iout,*)'Version ${UNRES_MAJOR}.${UNRES_MINOR} build ${UNRES_PATCH}' -") - -CINFO_FORMAT(${CINFO} "Compiled" "${DATE}" ) -CINFO_FORMAT(${CINFO} "Compiled by" "$ENV{USER}@$ENV{HOST}" ) -CINFO_FORMAT(${CINFO} "OS name:" "${CMAKE_SYSTEM_NAME}" ) -CINFO_FORMAT(${CINFO} "OS release:" "${CMAKE_SYSTEM}" ) -CINFO_FORMAT(${CINFO} "Fortran Compiler:" "${CMAKE_Fortran_COMPILER}" ) -CINFO_FORMAT(${CINFO} "MD Force field:" "${UNRES_MD_FF}" ) -CINFO_FORMAT(${CINFO} "CPPFLAGS =" "${CPPFLAGS}") - -FILE(APPEND ${CINFO} -" write(iout,*)'++++ End of compile info ++++' - return - end ") - - -# add include path -set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f PROPERTY COMPILE_FLAGS "${FFLAGS0} -I${CMAKE_CURRENT_SOURCE_DIR}") - -#========================================= -# Set full unres MD-M sources -#========================================= -set(UNRES_MDM_SRCS ${UNRES_MDM_SRC0} ${UNRES_MDM_SRC3} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f proc_proc.c ) - -#========================================= -# Build the binary -#========================================= -add_executable(UNRES_BIN-MD-M ${UNRES_MDM_SRCS} ) -set_target_properties(UNRES_BIN-MD-M PROPERTIES OUTPUT_NAME ${UNRES_BIN}) -set_property(TARGET UNRES_BIN-MD-M PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin ) -#add_dependencies (${UNRES_BIN} ${UNRES_XDRFLIB}) - -#========================================= -# Link libraries -#========================================= -# link MPI library (libmpich.a) -if(UNRES_WITH_MPI) - target_link_libraries( UNRES_BIN-MD-M ${MPI_Fortran_LIBRARIES} ) -endif(UNRES_WITH_MPI) -# link libxdrf.a -#message("UNRES_XDRFLIB=${UNRES_XDRFLIB}") -target_link_libraries( UNRES_BIN-MD-M xdrf ) - -#========================================= -# Install Path -#========================================= -install(TARGETS UNRES_BIN-MD-M DESTINATION ${CMAKE_INSTALL_PREFIX}) - -#========================================= -# 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 -#========================================= - -#if(NOT UNRES_WITH_MPI) - -# add_test(NAME UNRES_MD_Ala10 COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh ) - -#endif(NOT UNRES_WITH_MPI) - diff --git a/source/unres/src_MD-M-newcorr/COMMON.BANK b/source/unres/src_MD-M-newcorr/COMMON.BANK deleted file mode 100644 index 5b0fb34..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.BANK +++ /dev/null @@ -1,29 +0,0 @@ - real*8 dihang,etot,bvar,bene,rene,rvar,avedif,difmin, - & ebmin,ebmax,ebmaxt,cutdif,dij,dihang_in - integer ibank,is,jbank,ibmin,ibmax,nbank,nconf,iuse,nstep,icycle, - & iseed,ntbank,ntbankm,iref,nconf_in,indb,ilastnstep, - & bvar_nss,bvar_ss,bvar_ns,bvar_s, - & nss_in,iss_in,jss_in,nadd - common/varin/dihang_in(mxang,maxres,mxch,mxio),nss_in(mxio), - & iss_in(maxss,mxio),jss_in(maxss,mxio) - common/minvar/dihang(mxang,maxres,mxch,mxio),etot(mxio),rmsn(mxio) - & ,pncn(mxio),nss_out(mxio), - & iss_out(maxss,mxio),jss_out(maxss,mxio) - common/bank/ - * bvar(mxang,maxres,mxch,mxio),bene(mxio),rene(mxio), - * brmsn(mxio),rrmsn(mxio), - * bpncn(mxio),rpncn(mxio), - * rvar(mxang,maxres,mxch,mxio),ibank(mxio),is(mxio), - * avedif,difmin,ebmin,ebmax,ebmaxt,dele,difcut,cutdif, - * rmscut,pnccut, - * jbank(mxio),dij(mxio,mxio),ibmin,ibmax, - * nbank,ntbank,ntbankm,nconf,iuse,nstep,icycle,iseed,iref, - * nconf_in,ilastnstep,nadd - common/bank_disulfid/ bvar_nss(mxio),bvar_ss(2,maxss,mxio), - * bvar_ns(mxio),bvar_s(maxss,mxio) - common/mvstat/ movenx(mxio),movernx(mxio), - & nstatnx(0:mxmv,3),nstatnx_tot(0:mxmv,3),indb(mxio,9), - & parent(3,mxio) - common/send2/isend2(mxio),iff_in(maxres,mxio2), - & dihang_in2(mxang,maxres,mxch,mxio2), - & idata(5,mxio) diff --git a/source/unres/src_MD-M-newcorr/COMMON.BOUNDS b/source/unres/src_MD-M-newcorr/COMMON.BOUNDS deleted file mode 100644 index f3859ae..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.BOUNDS +++ /dev/null @@ -1,2 +0,0 @@ - double precision phibound(2,maxres) - common /bounds/ phibound diff --git a/source/unres/src_MD-M-newcorr/COMMON.CACHE b/source/unres/src_MD-M-newcorr/COMMON.CACHE deleted file mode 100644 index 8cb0cbc..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.CACHE +++ /dev/null @@ -1,6 +0,0 @@ - integer ncache,CachSrc(max_cache),isent(max_cache), - & iused(max_cache) - logical cache_update - double precision ecache(max_cache),xcache(maxvar,max_cache) - common /cache/ ecache,xcache,ncache,CachSrc,isent,iused, - & cache_update diff --git a/source/unres/src_MD-M-newcorr/COMMON.CALC b/source/unres/src_MD-M-newcorr/COMMON.CALC deleted file mode 100644 index 67b4bb9..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.CALC +++ /dev/null @@ -1,15 +0,0 @@ - integer i,j,k,l - double precision erij,rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, - & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, - & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, - & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, - & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, - & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, - & dsci_inv,dscj_inv,gg - common /calc/ erij(3),rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, - & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, - & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, - & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, - & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, - & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, - & dsci_inv,dscj_inv,gg(3),i,j diff --git a/source/unres/src_MD-M-newcorr/COMMON.CHAIN b/source/unres/src_MD-M-newcorr/COMMON.CHAIN deleted file mode 100644 index f343887..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.CHAIN +++ /dev/null @@ -1,16 +0,0 @@ - integer nres,nsup,nstart_sup,nz_start,nz_end,iz_sc, - & nres0,nstart_seq,chain_length,iprzes,tabperm,nperm - double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm,t,r, - & prod,rt,dc_work,cref,crefjlee,chain_rep,dc_norm2 - common /chain/ c(3,maxres2+2),dc(3,0:maxres2),dc_old(3,0:maxres2), - & xloc(3,maxres),xrot(3,maxres),dc_norm(3,0:maxres2), - & dc_norm2(3,0:maxres2), - & dc_work(MAXRES6),nres,nres0 - common /rotmat/ t(3,3,maxres),r(3,3,maxres),prod(3,3,maxres), - & rt(3,3,maxres) - common /refstruct/ cref(3,maxres2+2,maxperm), - & crefjlee(3,maxres2+2), - & chain_rep(3,maxres2+2,maxsym), - & nsup,nstart_sup,nstart_seq, - & chain_length,iprzes,tabperm(maxperm,maxsym),nperm - common /from_zscore/ nz_start,nz_end,iz_sc diff --git a/source/unres/src_MD-M-newcorr/COMMON.CONTACTS b/source/unres/src_MD-M-newcorr/COMMON.CONTACTS deleted file mode 100644 index 45c578b..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.CONTACTS +++ /dev/null @@ -1,84 +0,0 @@ -C Change 12/1/95 - common block CONTACTS1 included. - integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont - double precision facont,gacont - common /contacts/ ncont,ncont_ref,icont(2,maxcont), - & icont_ref(2,maxcont) - common /contacts1/ facont(maxconts,maxres), - & gacont(3,maxconts,maxres), - & num_cont(maxres),jcont(maxconts,maxres) -C 12/26/95 - H-bonding contacts - common /contacts_hb/ - & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), - & gacontp_hb3(3,maxconts,maxres), - & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), - & gacontm_hb3(3,maxconts,maxres), - & gacont_hbr(3,maxconts,maxres), - & grij_hb_cont(3,maxconts,maxres), - & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), - & ees0m(maxconts,maxres),d_cont(maxconts,maxres), - & num_cont_hb(maxres),jcont_hb(maxconts,maxres) -C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole -C interactions -c 7/25/08 Commented out; not needed when cumulants used -C Interactions of pseudo-dipoles generated by loc-el interactions. -c double precision dip,dipderg,dipderx -c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), -c & dipderx(3,5,4,maxconts,maxres) -C 10/30/99 Added other pre-computed vectors and matrices needed -C to calculate three - six-order el-loc correlation terms - double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, - & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,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 - common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), - & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), - & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), - & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres), - & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres) - double precision costab,sintab,costab2,sintab2 - common /rotat_old/ costab(maxres),sintab(maxres), - & costab2(maxres),sintab2(maxres) -C This common block contains dipole-interaction matrices and their -C Cartesian derivatives. - double precision a_chuj,a_chuj_der - common /dipmat/ a_chuj(2,2,maxconts,maxres), - & a_chuj_der(2,2,3,5,maxconts,maxres) - double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, - & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, - & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont - common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), - & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), - & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), - & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), - & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), - & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), - & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), - & g_contij(3,2),ekont -C 12/13/2008 (again Poland-Jaruzel war anniversary) -C RE: Parallelization of 4th and higher order loc-el correlations - integer ncont_sent,ncont_recv,iint_sent,iisent_local, - & itask_cont_from,itask_cont_to,ntask_cont_from,ntask_cont_to, - & nat_sent,iat_sent,iturn3_sent,iturn4_sent,iturn3_sent_local, - & iturn4_sent_local - common /contdistrib/ ncont_sent(maxres),ncont_recv(maxres), - & iint_sent(4,maxres,maxres),iint_sent_local(4,maxres,maxres), - & iturn3_sent(4,maxres),iturn4_sent(4,maxres), - & iturn3_sent_local(4,maxres),iturn4_sent_local(4,maxres), - & nat_sent,iat_sent(maxres),itask_cont_from(0:max_fg_procs-1), - & itask_cont_to(0:max_fg_procs-1),ntask_cont_from,ntask_cont_to diff --git a/source/unres/src_MD-M-newcorr/COMMON.CONTACTS.moment b/source/unres/src_MD-M-newcorr/COMMON.CONTACTS.moment deleted file mode 100644 index d07a0f0..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.CONTACTS.moment +++ /dev/null @@ -1,68 +0,0 @@ -C Change 12/1/95 - common block CONTACTS1 included. - integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont - double precision facont,gacont - common /contacts/ ncont,ncont_ref,icont(2,maxcont), - & icont_ref(2,maxcont) - common /contacts1/ facont(maxconts,maxres), - & gacont(3,maxconts,maxres), - & num_cont(maxres),jcont(maxconts,maxres) -C 12/26/95 - H-bonding contacts - common /contacts_hb/ - & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), - & gacontp_hb3(3,maxconts,maxres), - & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), - & gacontm_hb3(3,maxconts,maxres), - & gacont_hbr(3,maxconts,maxres), - & grij_hb_cont(3,maxconts,maxres), - & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), - & ees0m(maxconts,maxres),d_cont(maxconts,maxres), - & num_cont_hb(maxres),jcont_hb(maxconts,maxres) -C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole -C interactions -C Interactions of pseudo-dipoles generated by loc-el interactions. - double precision dip,dipderg,dipderx - common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), - & dipderx(3,5,4,maxconts,maxres) -C 10/30/99 Added other pre-computed vectors and matrices needed -C to calculate three - six-order el-loc correlation terms - double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, - & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder, - & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der - common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), - & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), - & obrot_der(2,maxres),obrot2_der(2,maxres) -C This common block contains vectors and matrices dependent on a single -C amino-acid residue. - common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres), - & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), - & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), - & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres), - & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres) -C This common block contains vectors and matrices dependent on two -C consecutive amino-acid residues. - double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, - & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder - common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), - & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), - & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), - & DtUg2EUg(2,2,maxres),DtUg2EUgder(2,2,2,maxres), - & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres) - double precision costab,sintab,costab2,sintab2 - common /rotat_old/ costab(maxres),sintab(maxres), - & costab2(maxres),sintab2(maxres),muder(2,maxres) -C This common block contains dipole-interaction matrices and their -C Cartesian derivatives. - double precision a_chuj,a_chuj_der - common /dipmat/ a_chuj(2,2,maxconts,maxres), - & a_chuj_der(2,2,3,5,maxconts,maxres) - double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, - & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, - & AEAb2,AEAb2derg,AEAb2derx - common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), - & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), - & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), - & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), - & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), - & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), - & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), - & g_contij(3,2),ekont diff --git a/source/unres/src_MD-M-newcorr/COMMON.CONTACTS_safe1 b/source/unres/src_MD-M-newcorr/COMMON.CONTACTS_safe1 deleted file mode 100644 index 64e0761..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.CONTACTS_safe1 +++ /dev/null @@ -1,82 +0,0 @@ -C Change 12/1/95 - common block CONTACTS1 included. - integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont - double precision facont,gacont - common /contacts/ ncont,ncont_ref,icont(2,maxcont), - & icont_ref(2,maxcont) - common /contacts1/ facont(maxconts,maxres), - & gacont(3,maxconts,maxres), - & num_cont(maxres),jcont(maxconts,maxres) -C 12/26/95 - H-bonding contacts - common /contacts_hb/ - & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), - & gacontp_hb3(3,maxconts,maxres), - & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), - & gacontm_hb3(3,maxconts,maxres), - & gacont_hbr(3,maxconts,maxres), - & grij_hb_cont(3,maxconts,maxres), - & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), - & ees0m(maxconts,maxres),d_cont(maxconts,maxres), - & num_cont_hb(maxres),jcont_hb(maxconts,maxres) -C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole -C interactions -c 7/25/08 Commented out; not needed when cumulants used -C Interactions of pseudo-dipoles generated by loc-el interactions. -c double precision dip,dipderg,dipderx -c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), -c & dipderx(3,5,4,maxconts,maxres) -C 10/30/99 Added other pre-computed vectors and matrices needed -C to calculate three - six-order el-loc correlation terms - double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, - & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder, - & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der - common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), - & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), - & obrot_der(2,maxres),obrot2_der(2,maxres) -C This common block contains vectors and matrices dependent on a single -C amino-acid residue. - common /precomp1/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres), - & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres), - & Dtobr2(2,maxres),Dtobr2der(2,maxres), - & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), - & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), - & DtUg2(2,2,maxres),DtUg2der(2,2,maxres) -C This common block contains vectors and matrices dependent on two -C consecutive amino-acid residues. - double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, - & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder - common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), - & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), - & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), - & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres), - & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres) - double precision costab,sintab,costab2,sintab2 - common /rotat_old/ costab(maxres),sintab(maxres), - & costab2(maxres),sintab2(maxres) -C This common block contains dipole-interaction matrices and their -C Cartesian derivatives. - double precision a_chuj,a_chuj_der - common /dipmat/ a_chuj(2,2,maxconts,maxres), - & a_chuj_der(2,2,3,5,maxconts,maxres) - double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, - & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, - & AEAb2,AEAb2derg,AEAb2derx - common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), - & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), - & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), - & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), - & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), - & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), - & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), - & g_contij(3,2),ekont -C 12/13/2008 (again Poland-Jaruzel war anniversary) -C RE: Parallelization of 4th and higher order loc-el correlations - integer ncont_sent,ncont_recv,iint_sent,iisent_local, - & itask_cont_from,itask_cont_to,ntask_cont_from,ntask_cont_to, - & nat_sent,iat_sent,iturn3_sent,iturn4_sent,iturn3_sent_local, - & iturn4_sent_local - common /contdistrib/ ncont_sent(maxres),ncont_recv(maxres), - & iint_sent(4,maxres,maxres),iint_sent_local(4,maxres,maxres), - & iturn3_sent(4,maxres),iturn4_sent(4,maxres), - & iturn3_sent_local(4,maxres),iturn4_sent_local(4,maxres), - & nat_sent,iat_sent(maxres),itask_cont_from(0:MaxProcs-1), - & itask_cont_to(0:MaxProcs-1),ntask_cont_from,ntask_cont_to diff --git a/source/unres/src_MD-M-newcorr/COMMON.CONTROL b/source/unres/src_MD-M-newcorr/COMMON.CONTROL deleted file mode 100644 index 40346c7..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.CONTROL +++ /dev/null @@ -1,13 +0,0 @@ - integer modecalc,iscode,indpdb,indback,indphi,iranconf,icheckgrad, - & inprint,i2ndstr,mucadyn,constr_dist,symetr - logical minim,refstr,pdbref,outpdb,outmol2,overlapsc,energy_dec, - & sideadd,lsecondary,read_cart,unres_pdb, - & vdisulf,searchsc,lmuca,dccart,extconf,out1file, - & gnorm_check,gradout,split_ene - common /cntrl/ modecalc,iscode,indpdb,indback,indphi,iranconf, - & icheckgrad,minim,i2ndstr,refstr,pdbref,outpdb,outmol2,iprint, - & overlapsc,energy_dec,sideadd,lsecondary,read_cart,unres_pdb - & ,vdisulf,searchsc,lmuca,dccart,mucadyn,extconf,out1file, - & constr_dist,gnorm_check,gradout,split_ene,symetr -C... minim = .true. means DO minimization. -C... energy_dec = .true. means print energy decomposition matrix diff --git a/source/unres/src_MD-M-newcorr/COMMON.CSA b/source/unres/src_MD-M-newcorr/COMMON.CSA deleted file mode 100644 index 273a268..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.CSA +++ /dev/null @@ -1,11 +0,0 @@ - integer ngroup,igroup,ntotgr,numch,irestart,ndiff - double precision diffcut - common/alphaa/ ngroup(mxgr),igroup(3,mxang,mxgr),ntotgr,numch - common/csa_input/cut1,cut2,eglob_csa,estop,jstart,jend, - & n1,n2,n3,n4,n5,n6,n7,n8,n9,n14,n15,n16,n17,n18,n0, - & is1,is2,nseed,ntotal,icmax,nstmax,irestart,nran0,nran1,irr, - & nglob_csa,nmin_csa,ndiff - logical ldih_bias - common/dih_control/rdih_bias,ldih_bias - common/diffcuta/ diffcut - diff --git a/source/unres/src_MD-M-newcorr/COMMON.DBASE b/source/unres/src_MD-M-newcorr/COMMON.DBASE deleted file mode 100644 index 4f07780..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.DBASE +++ /dev/null @@ -1,3 +0,0 @@ - common /struct/ cart_base(3,maxres_base,maxseq),str_nam(maxseq), - & nres_base(3,maxseq),nseq - character*8 str_nam diff --git a/source/unres/src_MD-M-newcorr/COMMON.DERIV b/source/unres/src_MD-M-newcorr/COMMON.DERIV deleted file mode 100644 index d7c98bd..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.DERIV +++ /dev/null @@ -1,35 +0,0 @@ - double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gelc_long, - & gvdwpp,gel_loc,gel_loc_long,gvdwc_scpp, - & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gloc_x,dtheta,dphi,dalpha, - & domega,gscloc,gsclocx,gradcorr,gradcorr_long,gradcorr5_long, - & gradcorr6_long,gcorr6_turn_long,gvdwx - integer nfl,icg - common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), - & gradx(3,maxres,2),gradc(3,maxres,2),gvdwx(3,maxres), - & gvdwc(3,maxres),gelc(3,maxres),gelc_long(3,maxres), - & gvdwpp(3,maxres),gvdwc_scpp(3,maxres), - & gradx_scp(3,maxres),gvdwc_scp(3,maxres),ghpbx(3,maxres), - & ghpbc(3,maxres),gloc(maxvar,2),gradcorr(3,maxres), - & gradcorr_long(3,maxres),gradcorr5_long(3,maxres), - & gradcorr6_long(3,maxres),gcorr6_turn_long(3,maxres), - & gradxorr(3,maxres),gradcorr5(3,maxres),gradcorr6(3,maxres), - & gloc_x(maxvar,2),gel_loc(3,maxres),gel_loc_long(3,maxres), - & gcorr3_turn(3,maxres), - & gcorr4_turn(3,maxres),gcorr6_turn(3,maxres),gradb(3,maxres), - & gradbx(3,maxres),gel_loc_loc(maxvar),gel_loc_turn3(maxvar), - & gel_loc_turn4(maxvar),gel_loc_turn6(maxvar),gcorr_loc(maxvar), - & g_corr5_loc(maxvar),g_corr6_loc(maxvar),gsccorc(3,maxres), - & gsccorx(3,maxres),gsccor_loc(maxres),dtheta(3,2,maxres), - & gscloc(3,maxres),gsclocx(3,maxres), - & dphi(3,3,maxres),dalpha(3,3,maxres),domega(3,3,maxres),nfl,icg - double precision derx,derx_turn - common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2) - double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres), - & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres), - & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres), - & dZZ_XYZtab(3,maxres) - common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab, - & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab - integer igrad_start,igrad_end,jgrad_start(maxres), - & jgrad_end(maxres) - common /mpgrad/ igrad_start,igrad_end,jgrad_start,jgrad_end diff --git a/source/unres/src_MD-M-newcorr/COMMON.DERIV_safe b/source/unres/src_MD-M-newcorr/COMMON.DERIV_safe deleted file mode 100644 index 524d72a..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.DERIV_safe +++ /dev/null @@ -1,35 +0,0 @@ - double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gelc_long, - & gvdwpp,gel_loc,gel_loc_long,gvdwc_scpp, - & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gloc_x,dtheta,dphi,dalpha, - & domega,gscloc,gsclocx,gradcorr,gradcorr_long,gradcorr5_long, - & gradcorr6_long,gcorr6_turn_long - integer nfl,icg - common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), - & gradx(3,maxres,2),gradc(3,maxres,2),gvdwx(3,maxres), - & gvdwc(3,maxres),gelc(3,maxres),gelc_long(3,maxres), - & gvdwpp(3,maxres),gvdwc_scpp(3,maxres), - & gradx_scp(3,maxres),gvdwc_scp(3,maxres),ghpbx(3,maxres), - & ghpbc(3,maxres),gloc(maxvar,2),gradcorr(3,maxres), - & gradcorr_long(3,maxres),gradcorr5_long(3,maxres), - & gradcorr6_long(3,maxres),gcorr6_turn_long(3,maxres), - & gradxorr(3,maxres),gradcorr5(3,maxres),gradcorr6(3,maxres), - & gloc_x(maxvar,2),gel_loc(3,maxres),gel_loc_long(3,maxres), - & gcorr3_turn(3,maxres), - & gcorr4_turn(3,maxres),gcorr6_turn(3,maxres),gradb(3,maxres), - & gradbx(3,maxres),gel_loc_loc(maxvar),gel_loc_turn3(maxvar), - & gel_loc_turn4(maxvar),gel_loc_turn6(maxvar),gcorr_loc(maxvar), - & g_corr5_loc(maxvar),g_corr6_loc(maxvar),gsccorc(3,maxres), - & gsccorx(3,maxres),gsccor_loc(maxres),dtheta(3,2,maxres), - & gscloc(3,maxres),gsclocx(3,maxres), - & dphi(3,3,maxres),dalpha(3,3,maxres),domega(3,3,maxres),nfl,icg - double precision derx,derx_turn - common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2) - double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres), - & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres), - & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres), - & dZZ_XYZtab(3,maxres) - common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab, - & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab - integer igrad_start,igrad_end,jgrad_start(maxres), - & jgrad_end(maxres) - common /mpgrad/ igrad_start,igrad_end,jgrad_start,jgrad_end diff --git a/source/unres/src_MD-M-newcorr/COMMON.DISTFIT b/source/unres/src_MD-M-newcorr/COMMON.DISTFIT deleted file mode 100644 index 044225b..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.DISTFIT +++ /dev/null @@ -1,14 +0,0 @@ -c parameter (maxres22=maxres*(maxres+1)/2) - parameter (maxres22=1) - double precision w,d0,DRDG,DD,H,XX - integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0, - 1 lvar_frag,svar_frag,avar_frag - COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3) - COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3), - 1 lvar_frag(mxio,3),svar_frag(mxio,3), - 2 avar_frag(mxio,5) - COMMON /WAGI/ w(MAXRES22),d0(MAXRES22) - COMMON /POCHODNE/ NX,NY,DRDG(MAXRES22,MAXRES),DD(MAXRES22), - 1 H(MAXRES,MAXRES),XX(MAXRES) - COMMON /frozen/ mask(maxres) - COMMON /store0/ nhpb0 diff --git a/source/unres/src_MD-M-newcorr/COMMON.FFIELD b/source/unres/src_MD-M-newcorr/COMMON.FFIELD deleted file mode 100644 index d7d8cde..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.FFIELD +++ /dev/null @@ -1,25 +0,0 @@ -C----------------------------------------------------------------------- -C The following COMMON block selects the type of the force field used in -C calculations and defines weights of various energy terms. -C 12/1/95 wcorr added -C----------------------------------------------------------------------- - integer n_ene_comp,rescale_mode - common /ffield/ wsc,wscp,welec,wbond,wstrain,wtor,wtor_d,wang, - & wscloc,wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4, - & wturn6,wvdwpp,weights(n_ene),temp0, - & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp, - & rescale_mode - common /potentials/ potname(5) - character*3 potname -C----------------------------------------------------------------------- -C wlong,welec,wtor,wang,wscloc are the weight of the energy terms -C corresponding to side-chain, electrostatic, torsional, valence-angle, -C and local side-chain terms. -C -C IPOT determines which SC...SC interaction potential will be used: -C 1 - LJ: 2n-n Lennard-Jones -C 2 - LJK: 2n-n Kihara type (shifted Lennard-Jones) -C 3 - BP; Berne-Pechukas (angular dependence) -C 4 - GB; Gay-Berne (angular dependence) -C 5 - GBV; Gay-Berne-Vorobjev; angularly-dependent Kihara potential -C------------------------------------------------------------------------ diff --git a/source/unres/src_MD-M-newcorr/COMMON.GEO b/source/unres/src_MD-M-newcorr/COMMON.GEO deleted file mode 100644 index 8cfbbde..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.GEO +++ /dev/null @@ -1,2 +0,0 @@ - double precision pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin - common /geo/ pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin diff --git a/source/unres/src_MD-M-newcorr/COMMON.HAIRPIN b/source/unres/src_MD-M-newcorr/COMMON.HAIRPIN deleted file mode 100644 index f103268..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.HAIRPIN +++ /dev/null @@ -1,5 +0,0 @@ - integer nharp_seed(max_seed),nharp_tot, - & iharp_seed(4,maxres/3,max_seed),iharp_use(0:4,maxres/3,max_seed), - & nharp_use(max_seed) - common /spinka/ nharp_seed,nharp_tot,iharp_seed,iharp_use, - & nharp_use diff --git a/source/unres/src_MD-M-newcorr/COMMON.HEADER b/source/unres/src_MD-M-newcorr/COMMON.HEADER deleted file mode 100644 index 7154812..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.HEADER +++ /dev/null @@ -1,2 +0,0 @@ - character*80 titel - common /header/ titel diff --git a/source/unres/src_MD-M-newcorr/COMMON.INFO b/source/unres/src_MD-M-newcorr/COMMON.INFO deleted file mode 100644 index 4f63708..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.INFO +++ /dev/null @@ -1,21 +0,0 @@ -c NPROCS - total number of processors; -c MyID - processor's ID; -c MasterID - master processor's ID. - integer MyId,AllGrp,DontCare,MasterId,WhatsUp,ifinish - logical koniec - integer tag,status(MPI_STATUS_SIZE) - common /info/ myid,masterid,allgrp,dontcare, - & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1) -c... 5/12/96 - added variables for collective communication -c FGPROCS - Number of fine-grain processors per coarse-grain task; -c NCTASKS - Number of coarse-grain tasks; -c MYGROUP - label of the processor's FG group id; -c BOSSID - ID of group's master; -c FGLIST - list of group's FG processors. -c MSGLEN_VAR - length of the vector of variables passed to the fine-grain -c slave processors - integer fgprocs,nctasks,mygroup,bossid,cglabel, - & cglist(max_cg_procs),cgGroupID,fglist(max_fg_procs), - & fgGroupID,MyRank - common /info1/ fgprocs,nctasks,mygroup,bossid,cglabel,cglist, - & cgGroupID,fglist,fgGroupID,MyRank,msglen_var diff --git a/source/unres/src_MD-M-newcorr/COMMON.INTERACT b/source/unres/src_MD-M-newcorr/COMMON.INTERACT deleted file mode 100644 index 83af3fb..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.INTERACT +++ /dev/null @@ -1,31 +0,0 @@ - double precision aa,bb,augm,aad,bad,app,bpp,ale6,ael3,ael6 - integer expon,expon2 - integer nnt,nct,nint_gr,istart,iend,itype,itel,itypro, - & ielstart,ielend,ielstart_vdw,ielend_vdw,nscp_gr,iscpstart, - & iscpend,iatsc_s,iatsc_e, - & iatel_s,iatel_e,iatscp_s,iatscp_e,iatel_s_vdw,iatel_e_vdw, - & ispp,iscp - common /interact/aa(ntyp,ntyp),bb(ntyp,ntyp),augm(ntyp,ntyp), - & aad(ntyp,2),bad(ntyp,2),app(2,2),bpp(2,2),ael6(2,2),ael3(2,2), - & expon,expon2,nnt,nct,nint_gr(maxres),istart(maxres,maxint_gr), - & iend(maxres,maxint_gr),itype(maxres),itel(maxres),itypro, - & ielstart(maxres),ielend(maxres),ielstart_vdw(maxres), - & ielend_vdw(maxres),nscp_gr(maxres), - & iscpstart(maxres,maxint_gr),iscpend(maxres,maxint_gr), - & iatsc_s,iatsc_e,iatel_s,iatel_e,iatel_s_vdw,iatel_e_vdw, - & iatscp_s,iatscp_e,ispp,iscp -C 12/1/95 Array EPS included in the COMMON block. - double precision eps,sigma,sigmaii,rs0,chi,chip,alp,sigma0,sigii, - & rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp - common /body/eps(ntyp,ntyp),sigma(0:ntyp1,0:ntyp1), - & sigmaii(ntyp,ntyp), - & rs0(ntyp,ntyp),chi(ntyp,ntyp),chip(ntyp),alp(ntyp),sigma0(ntyp), - & sigii(ntyp),rr0(ntyp),r0(ntyp,ntyp),r0e(ntyp,ntyp),r0d(ntyp,2), - & rpp(2,2),epp(2,2),elpp6(2,2),elpp3(2,2),eps_scp(ntyp,2), - & rscp(ntyp,2) -c 12/5/03 modified 09/18/03 Bond stretching parameters. - double precision vbldp0,vbldsc0,akp,aksc,abond0,distchainmax - integer nbondterm - common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp, - & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp), - & distchainmax,nbondterm(ntyp) diff --git a/source/unres/src_MD-M-newcorr/COMMON.IOUNITS b/source/unres/src_MD-M-newcorr/COMMON.IOUNITS deleted file mode 100644 index 49b6db3..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.IOUNITS +++ /dev/null @@ -1,69 +0,0 @@ -C----------------------------------------------------------------------- -C I/O units used by the program -C----------------------------------------------------------------------- -C 9/18/99 - unit ifourier and filename fouriername included to identify -C the file from which the coefficients of second-order Fourier expansion -C of the local-interaction energy are read. -C 8/9/01 - file for SCP interaction constants named scpname (unit iscpp) -C included. -C----------------------------------------------------------------------- -C General I/O units & files - integer inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,irotam, - & itorp,itordp,ifourier,ielep,isidep,iscpp,icbase,istat, - & ientin,ientout,izs1,isecpred,ibond,irest2,iifrag,icart, - & irest1,isccor,ithep_pdb,irotam_pdb - common /iounits/ inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep, - & irotam,itorp,itordp,ifourier,ielep,isidep,iscpp,icbase, - & istat,ientin,ientout,izs1,isecpred,ibond,irest2,iifrag, - & icart,irest1,isccor,ithep_pdb,irotam_pdb - character*256 outname,intname,pdbname,mol2name,statname,intinname, - & entname,prefix,secpred,rest2name,qname,cartname,tmpdir, - & mremd_rst_name,curdir,pref_orig - character*4 liczba - common /fnames/ outname,intname,pdbname,mol2name,statname, - & intinname,entname,prefix,pot,secpred,rest2name,qname, - & cartname,tmpdir,mremd_rst_name,curdir,pref_orig,liczba -C CSA I/O units & files - character*256 csa_rbank,csa_seed,csa_history,csa_bank, - & csa_bank1,csa_alpha,csa_alpha1,csa_bankt,csa_int, - & csa_bank_reminimized,csa_native_int,csa_in - common /csafiles/ csa_rbank,csa_seed,csa_history,csa_bank, - & csa_bank1,csa_alpha,csa_alpha1,csa_bankt,csa_int, - & csa_bank_reminimized,csa_native_int,csa_in - integer icsa_rbank,icsa_seed,icsa_history,icsa_bank, - & icsa_bank1,icsa_alpha,icsa_alpha1,icsa_bankt,icsa_int, - & icsa_bank_reminimized,icsa_native_int,icsa_in,icsa_pdb - common /csaunits/ icsa_rbank,icsa_seed,icsa_history,icsa_bank, - & icsa_bank1,icsa_alpha,icsa_alpha1,icsa_bankt,icsa_int, - & icsa_bank_reminimized,icsa_native_int,icsa_in,icsa_pdb -C Parameter files - character*256 bondname,thetname,rotname,torname,tordname, - & fouriername,elename,sidename,scpname,sccorname,patname, - & thetname_pdb,rotname_pdb - common /parfiles/ bondname,thetname,rotname,torname,tordname, - & fouriername,elename,sidename,scpname,sccorname,patname, - & thetname_pdb,rotname_pdb - character*3 pot -C----------------------------------------------------------------------- -C INP - main input file -C IOUT - list file -C IGEOM - geometry output in the form of virtual-chain internal coordinates -C INTIN - geometry input (for multiple conformation processing) in int. coords. -C IPDB - Cartesian-coordinate output in PDB format -C IMOL2 - Cartesian-coordinate output in Tripos mol2 format -C IPDBIN - PDB input file -C ITHEP - virtual-bond torsional angle parametrs -C IROTAM - side-chain geometry and local-interaction parameters -C ITORP - torsional parameters -C ITORDP - double torsional parameters -C IFOURIER - coefficients of the expansion of local-interaction energy -C IELEP - electrostatic-interaction parameters -C ISIDEP - side-chain interaction parameters. -C ISCPP - SCp interaction parameters. -C IBOND - virtual-bond constant parameters and moments of inertia. -C ISCCOR - parameters of the potential of SCCOR term -C ICBASE - data base with Cartesian coords of known structures. -C ISTAT - energies and other conf. characteristics from an MCM run. -C IENTIN - entropy from preceeding simulation(s) to be read in. -C SECPRED - SECONDARY STRUCTURE PREDICTION for dihedral constraint generation. -C----------------------------------------------------------------------- diff --git a/source/unres/src_MD-M-newcorr/COMMON.LANGEVIN b/source/unres/src_MD-M-newcorr/COMMON.LANGEVIN deleted file mode 100644 index 6a703e2..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.LANGEVIN +++ /dev/null @@ -1,21 +0,0 @@ - double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), - & fricmat(MAXRES2,MAXRES2),fric_work(MAXRES6), - & stoch_work(MAXRES6), - & fricgam(MAXRES6),fricvec(MAXRES2,MAXRES2), - & pfric_mat(MAXRES2,MAXRES2),vfric_mat(MAXRES2,MAXRES2), - & afric_mat(MAXRES2,MAXRES2),prand_mat(MAXRES2,MAXRES2), - & vrand_mat1(MAXRES2,MAXRES2),vrand_mat2(MAXRES2,MAXRES2), - & pfric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), - & afric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), - & vfric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), - & prand0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), - & vrand0_mat1(MAXRES2,MAXRES2,0:maxflag_stoch), - & vrand0_mat2(MAXRES2,MAXRES2,0:maxflag_stoch), - & mt1(maxres2,maxres2),mt2(maxres2,maxres2),mt3(maxres2,maxres2) - logical flag_stoch(0:maxflag_stoch) - common /langforc/ friction,stochforc, - & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1, - & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat, - & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1, - & vrand0_mat2,flag_stoch - common /langmat/ mt1,mt2,mt3 diff --git a/source/unres/src_MD-M-newcorr/COMMON.LANGEVIN.lang0 b/source/unres/src_MD-M-newcorr/COMMON.LANGEVIN.lang0 deleted file mode 100644 index 354a0c4..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.LANGEVIN.lang0 +++ /dev/null @@ -1,11 +0,0 @@ - double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), - & fricmat(MAXRES2,MAXRES2),fric_work(MAXRES6), - & stoch_work(MAXRES6), - & fricgam(MAXRES6),fricvec(MAXRES2,MAXRES2) - logical flag_stoch(0:maxflag_stoch) - common /langforc/ friction,stochforc, - & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1, - & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat, - & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1, - & vrand0_mat2,flag_stoch - common /langmat/ mt1,mt2,mt3 diff --git a/source/unres/src_MD-M-newcorr/COMMON.LANGEVIN.lang0_ b/source/unres/src_MD-M-newcorr/COMMON.LANGEVIN.lang0_ deleted file mode 100644 index 26eb500..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.LANGEVIN.lang0_ +++ /dev/null @@ -1,11 +0,0 @@ - double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), - & fricmat(MAXRES6,MAXRES6),fric_work(MAXRES6), - & stoch_work(MAXRES6), - & fricgam(MAXRES6),fricvec(MAXRES6,MAXRES6) - logical flag_stoch(0:maxflag_stoch) - common /langforc/ friction,stochforc, - & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1, - & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat, - & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1, - & vrand0_mat2,flag_stoch - common /langmat/ mt1,mt2,mt3 diff --git a/source/unres/src_MD-M-newcorr/COMMON.LOCAL b/source/unres/src_MD-M-newcorr/COMMON.LOCAL deleted file mode 100644 index 9f0627b..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.LOCAL +++ /dev/null @@ -1,61 +0,0 @@ - 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 - 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 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, - & ibond_displ(0:max_fg_procs-1),ibond_count(0:max_fg_procs-1), - & ithet_displ(0:max_fg_procs-1),ithet_count(0:max_fg_procs-1), - & iphi_displ(0:max_fg_procs-1),iphi_count(0:max_fg_procs-1), - & iphi1_displ(0:max_fg_procs-1),iphi1_count(0:max_fg_procs-1), - & ivec_displ(0:max_fg_procs-1),ivec_count(0:max_fg_procs-1), - & iset_displ(0:max_fg_procs-1),iset_count(0:max_fg_procs-1), - & iint_count(0:max_fg_procs-1),iint_displ(0:max_fg_procs-1) - common /peptbond/ vbl,vblinv,vblinv2,vbl_cis,vbl0 - common /indices/ loc_start,loc_end,ithet_start,ithet_end, - & iphi_start,iphi_end,iphid_start,iphid_end,ibond_start,ibond_end, - & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end, - & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start, - & iint_end,iphi1_start,iphi1_end,iint_count,iint_displ,ivec_displ, - & ivec_count,iset_displ,itau_start,itau_end, - & iset_count,ibond_displ,ibond_count,ithet_displ,ithet_count, - & iphi_displ,iphi_count,iphi1_displ,iphi1_count -C Inverses of the actual virtual bond lengths - common /invlen/ vbld_inv(maxres2) diff --git a/source/unres/src_MD-M-newcorr/COMMON.LOCMOVE b/source/unres/src_MD-M-newcorr/COMMON.LOCMOVE deleted file mode 100644 index 211516d..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.LOCMOVE +++ /dev/null @@ -1,19 +0,0 @@ -c Variables (set in init routine) never modified by local_move - integer init_called - logical locmove_output - double precision min_theta, max_theta - double precision dmin2,dmax2 - double precision flag,small,small2 - - common /loc_const/ init_called,locmove_output,min_theta, - + max_theta,dmin2,dmax2,flag,small,small2 - -c Workspace for local_move - integer a_n,b_n,res_n - double precision a_ang,b_ang,res_ang - logical a_tab,b_tab,res_tab - - common /loc_work/ res_ang(0:11),a_ang(0:7),b_ang(0:3), - + res_n,res_tab(0:2,0:2,0:11), - + a_n,a_tab(0:2,0:7), - + b_n,b_tab(0:2,0:3) diff --git a/source/unres/src_MD-M-newcorr/COMMON.MAP b/source/unres/src_MD-M-newcorr/COMMON.MAP deleted file mode 100644 index 77e97e7..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.MAP +++ /dev/null @@ -1,4 +0,0 @@ - integer nmap,res1,res2,nstep - double precision ang_from,ang_to - common /mapp/ ang_from(maxvar),ang_to(maxvar),nmap,kang(maxvar), - & res1(maxvar),res2(maxvar),nstep(maxvar) diff --git a/source/unres/src_MD-M-newcorr/COMMON.MAXGRAD b/source/unres/src_MD-M-newcorr/COMMON.MAXGRAD deleted file mode 100644 index 285241a..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.MAXGRAD +++ /dev/null @@ -1,12 +0,0 @@ - double precision - & gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max - common /maxgrad/ - & gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max diff --git a/source/unres/src_MD-M-newcorr/COMMON.MCE b/source/unres/src_MD-M-newcorr/COMMON.MCE deleted file mode 100644 index 2d79184..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.MCE +++ /dev/null @@ -1,13 +0,0 @@ - double precision entropy(-max_ene-4:max_ene),nminima(maxsave), - & nhist(-max_ene:max_ene) - logical ent_read,multican - common /mce/ entropy,emin,emax,nhist,nminima,ent_read,multican, - & indminn,indmaxx - integer npool - double precision xpool,epool,pool_fraction - common /pool/ xpool(maxvar,max_pool),epool(max_pool), - & pool_fraction,npool - integer save_frequency,message_frequency,pool_read_freq, - & pool_save_freq,print_freq - common /mce_counters/ save_frequency,message_frequency, - & pool_read_freq,pool_save_freq,print_freq diff --git a/source/unres/src_MD-M-newcorr/COMMON.MCM b/source/unres/src_MD-M-newcorr/COMMON.MCM deleted file mode 100644 index 576f912..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.MCM +++ /dev/null @@ -1,70 +0,0 @@ -C... Following COMMON block contains general variables controlling the MC/MCM -C... procedure -c----------------------------------------------------------------------------- - double precision Tcur,Tmin,Tmax,TstepH,TstepC,RanFract, - & overlap_cut,e_up,delte - integer nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter, - & maxrepm,ngen,ntrial,ntherm,nrepm,neneval,nsave,maxoverlap, - & nsave_part,max_mcm_it,nsweep,print_mc - logical print_stat,print_int - common /mcm/ Tcur,Tmin,Tmax,TstepH,TstepC,Rbol,betbol,RanFract, - & overlap_cut,e_up,delte, - & nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter,maxrepm, - & maxoverlap,ntrial,max_mcm_it, - & ngen,ntherm,nrepm,neneval,nsave,nsave_part(max_cg_procs),nsweep, - & print_mc,print_stat,print_int -c----------------------------------------------------------------------------- -C... The meaning of the above variables is as follows: -C... Tcur,Tmin,Tmax - Current,minimum and maximum temperature, respectively; -C... NstepC,NStepH - Number of cooling and heating steps, respectively; -C... TstepH,TstepC - factors by which T is multiplied in order to be -C... increased or decreased. -C... betbol - Boltzmann's inverse temperature (1/(Rbol*Tcur)); -C... Rbol - the gas constant; -C... RanFract - the chance that a new conformation will be random-generated; -C... maxacc - maximum number of accepted conformations; -C... maxgen,ngen - Maximum and current number of generated conformations; -C... maxtrial,ntrial - maximum number of trials before temperature is increased -C... and current number of trials, respectively; -C... maxrepm,nrepm - maximum number of allowed minima repetition and current -C... number of minima repetitions, respectively; -C... maxoverlap - max. # of overlapping confs generated in a single iteration; -C... neneval - number of energy evaluations; -C... nsave - number of confs. in the backup array; -C... nsweep - the number of macroiterations in generating the distributions. -c------------------------------------------------------------------------------ -C... Following COMMON block contains variables controlling motion. -c------------------------------------------------------------------------------ - double precision sumpro_type,sumpro_bond - integer koniecl, Nbm,MaxSideMove,nmove,moves(-1:MaxMoveType+1), - & moves_acc(-1:MaxMoveType+1),nacc_tot,nacc_part(0:MaxProcs) - common /move/ sumpro_type(0:MaxMoveType),sumpro_bond(0:maxres), - & koniecl,Nbm,MaxSideMove,nmove,nbond_move(maxres), - & nbond_acc(maxres),moves,moves_acc - common /accept_stats/ nacc_tot,nacc_part - integer nwindow,winstart,winend,winlen - common /windows/ nwindow,winstart(maxres),winend(maxres), - & winlen(maxres) - character*16 MovTypID - common /moveID/ MovTypID(-1:MaxMoveType+1) -c------------------------------------------------------------------------------ -C... koniecl - the number of bonds to be considered "end bonds" subjected to -C... end moves; -C... Nbm - The maximum length of N-bond segment to be moved; -C... MaxSideMove - maximum number of side chains subjected to local moves -C... simultaneously; -C... nmove - the current number of attempted moves; -C... nbond_move(*) array that stores the total numbers of 2-bond,3-bond,... -C... moves; -C... nendmove - number of endmoves; -C... nbackmove - number of backbone moves; -C... nsidemove - number of local side chain moves; -C... sumpro_type(*) - array that stores the lower and upper boundary of the -C... random-number range that determines the type of move -C... (N-bond, backbone or side chain); -C... sumpro_bond(*) - array that stores the probabilities to perform bond -C... moves of consecutive segment length. -C... winstart(*) - the starting position of the perturbation window; -C... winend(*) - the end position of the perturbation window; -C... winlen(*) - length of the perturbation window; -C... nwindow - the number of perturbation windows (0 - entire chain). diff --git a/source/unres/src_MD-M-newcorr/COMMON.MD b/source/unres/src_MD-M-newcorr/COMMON.MD deleted file mode 100644 index b17c722..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.MD +++ /dev/null @@ -1,65 +0,0 @@ - double precision gcart, gxcart, gradcag,gradxag - common /mdgrad/ gcart(3,0:MAXRES), gxcart(3,0:MAXRES), - & gradcag(3,MAXRES),gradxag(3,MAXRES) - integer dimen,dimen1, dimen3, ifrag(2,50,maxprocs/20), - & ipair(2,100,maxprocs/20),iset, - & mset(maxprocs/20),nset - double precision IP,ISC(ntyp+1),mp, - & msc(ntyp+1),d_t_work(MAXRES6), - & d_t_work_new(MAXRES6),d_t(3,0:MAXRES2),d_t_new(3,0:MAXRES2), - & d_af_work(MAXRES6),d_as_work(MAXRES6), - & d_t_old(3,0:MAXRES2),d_a_old(3,0:MAXRES2),d_a_short(3,0:MAXRES2), - & Gmat(MAXRES2,MAXRES2),Ginv(MAXRES2,MAXRES2),A(MAXRES2,MAXRES2), - & d_a(3,0:MAXRES2),d_a_work(6*MAXRES),kinetic_force(MAXRES6), - & Gsqrp(MAXRES2,MAXRES2),Gsqrm(MAXRES2,MAXRES2), - & vtot(MAXRES2),Gvec(maxres2,maxres2),Geigen(maxres2) - double precision v_ini,d_time,d_time0,t_bath,tau_bath, - & EK,potE,potEcomp(0:n_ene+4),totE,totT,amax,kinetic_T,dvmax,damax, - & edriftmax, - & eq_time,wfrag(50,maxprocs/20),wpair(100,maxprocs/20), - & qfrag(50),qpair(100), - & qinfrag(50,maxprocs/20),qinpair(100,maxprocs/20), - & Ucdfrag,Ucdpair,dUdconst(3,0:MAXRES),Uconst, - & dUdxconst(3,0:MAXRES),dqwol(3,0:MAXRES),dxqwol(3,0:MAXRES), - & utheta(maxfrag_back),ugamma(maxfrag_back),uscdiff(maxfrag_back), - & dutheta(maxres),dugamma(maxres),duscdiff(3,maxres), - & duscdiffx(3,maxres),wfrag_back(3,maxfrag_back,maxprocs/20), - & uconst_back - integer n_timestep,ntwx,ntwe,lang,count_reset_moment, - & count_reset_vel,reset_fricmat,nfrag,npair,nfrag_back, - & ifrag_back(3,maxfrag_back,maxprocs/20),ntime_split,ntime_split0, - & maxtime_split - logical large,print_compon,tbf,rest,reset_moment,reset_vel, - & surfarea,rattle,usampl,mdpdb,RESPA - integer igmult_start,igmult_end,my_ng_count,ng_start,ng_counts, - & nginv_start,nginv_counts,myginv_ng_count - common /back_constr/ uconst_back,utheta,ugamma,uscdiff, - & dutheta,dugamma,duscdiff,duscdiffx, - & wfrag_back,nfrag_back,ifrag_back - common /qmeas/ qfrag,qpair,qinfrag,qinpair,wfrag,wpair,eq_time, - & Ucdfrag,Ucdpair,dUdconst,dUdxconst,dqwol,dxqwol,Uconst, - & iset,mset,nset,usampl,ifrag,ipair,npair,nfrag - common /mdpar/ v_ini,d_time,d_time0,scal_fric, - & t_bath,tau_bath,dvmax,damax,n_timestep,mdpdb, - & ntime_split,ntime_split0,maxtime_split, - & ntwx,ntwe,large,print_compon,tbf,rest - common /MDcalc/ totT,totE,potE,potEcomp,EK,amax,edriftmax, - & kinetic_T - common /lagrange/ d_t,d_t_old,d_t_new,d_t_work, - & d_t_work_new,d_a,d_a_old,d_a_work,d_af_work,d_as_work,d_a_short, - & kinetic_force, - & A,Ginv,Gmat,Gvec,Geigen,Gsqrp,Gsqrm, - & vtot,dimen,dimen1,dimen3,lang, - & reset_moment,reset_vel,count_reset_moment,count_reset_vel, - & rattle,RESPA - common /inertia/ IP,ISC,MP,MSC - double precision scal_fric,rwat,etawat,gamp, - & gamsc(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,surfarea, - & reset_fricmat - common /mdpmpi/ igmult_start,igmult_end,my_ng_count, - & myginv_ng_count, - & ng_start(0:MaxProcs-1),ng_counts(0:MaxProcs-1), - & nginv_start(0:MaxProcs),nginv_counts(0:MaxProcs-1) diff --git a/source/unres/src_MD-M-newcorr/COMMON.MINIM b/source/unres/src_MD-M-newcorr/COMMON.MINIM deleted file mode 100644 index e44f9cd..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.MINIM +++ /dev/null @@ -1,5 +0,0 @@ - double precision tolf,rtolf - integer maxfun,maxmin,minfun,minmin, - & print_min_ini,print_min_stat,print_min_res - common /minimm/ tolf,rtolf,maxfun,maxmin,minfun,minmin, - & print_min_ini,print_min_stat,print_min_res diff --git a/source/unres/src_MD-M-newcorr/COMMON.MUCA b/source/unres/src_MD-M-newcorr/COMMON.MUCA deleted file mode 100644 index 7529c15..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.MUCA +++ /dev/null @@ -1,10 +0,0 @@ - double precision emuca(4*maxres),nemuca(4*maxres), - & nemuca2(4*maxres),elow,ehigh,factor, - & elowi(maxprocs),ehighi(maxprocs),hbin, - & hist(4*maxres),factor_min - integer nmuca,imtime,muca_smooth - common /double_muca/ emuca,nemuca, - & nemuca2,elow,ehigh,factor,hbin,hist,factor_min - common /integer_muca/ nmuca,imtime,muca_smooth - common /mucarem/ elowi,ehighi - diff --git a/source/unres/src_MD-M-newcorr/COMMON.NAMES b/source/unres/src_MD-M-newcorr/COMMON.NAMES deleted file mode 100644 index 13dde91..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.NAMES +++ /dev/null @@ -1,8 +0,0 @@ - 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(n_ene),wname(n_ene),nprint_ene, - & print_order(n_ene) diff --git a/source/unres/src_MD-M-newcorr/COMMON.REMD b/source/unres/src_MD-M-newcorr/COMMON.REMD deleted file mode 100644 index 7109548..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.REMD +++ /dev/null @@ -1,33 +0,0 @@ - integer nrep,nstex - logical remd_tlist,remd_mlist,mremdsync,restart1file,traj1file - double precision retmin,retmax,remd_t(maxprocs) - integer remd_m(maxprocs),i_sync_step - integer*2 i2rep(0:maxprocs),i2set(0:maxprocs) - integer*2 ifirst(maxprocs) - integer*2 nupa(0:maxprocs/4,0:maxprocs), - & ndowna(0:maxprocs/4,0:maxprocs) - real t_restart1(5,maxprocs) - integer iset_restart1(maxprocs) - common /remdcommon/ nrep,nstex,retmin,retmax,remd_t,remd_tlist, - & remd_mlist,remd_m,mremdsync,restart1file, - & traj1file,i_sync_step - common /remdrestart/ i2rep,i2set,ifirst,nupa,ndowna,t_restart1, - & iset_restart1 - real totT_cache,EK_cache,potE_cache,t_bath_cache,Uconst_cache, - & qfrag_cache,qpair_cache,c_cache,uscdiff_cache, - & ugamma_cache,utheta_cache - integer ntwx_cache,ii_write,max_cache_traj_use - common /traj1cache/ totT_cache(max_cache_traj), - & EK_cache(max_cache_traj), - & potE_cache(max_cache_traj), - & t_bath_cache(max_cache_traj), - & Uconst_cache(max_cache_traj), - & qfrag_cache(50,max_cache_traj), - & qpair_cache(100,max_cache_traj), - & ugamma_cache(maxfrag_back,max_cache_traj), - & utheta_cache(maxfrag_back,max_cache_traj), - & uscdiff_cache(maxfrag_back,max_cache_traj), - & c_cache(3,maxres2+2,max_cache_traj), - & iset_cache(max_cache_traj),ntwx_cache, - & ii_write,max_cache_traj_use - diff --git a/source/unres/src_MD-M-newcorr/COMMON.SBRIDGE b/source/unres/src_MD-M-newcorr/COMMON.SBRIDGE deleted file mode 100644 index 91dd2cd..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.SBRIDGE +++ /dev/null @@ -1,17 +0,0 @@ - double precision ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss - integer ns,nss,nfree,iss - common /sbridge/ ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss, - & ns,nss,nfree,iss(maxss) - double precision dhpb,dhpb1,forcon - integer ihpb,jhpb,nhpb,idssb,jdssb - common /links/ dhpb(maxdim),dhpb1(maxdim),forcon(maxdim), - & ihpb(maxdim),jhpb(maxdim),ibecarb(maxdim),nhpb - double precision weidis - common /restraints/ weidis - integer link_start,link_end - common /links_split/ link_start,link_end - double precision Ht,dyn_ssbond_ij - logical dyn_ss,dyn_ss_mask - common /dyn_ssbond/ dyn_ssbond_ij(maxres,maxres), - & idssb(maxdim),jdssb(maxdim), - & Ht,dyn_ss,dyn_ss_mask(maxres) diff --git a/source/unres/src_MD-M-newcorr/COMMON.SCCOR b/source/unres/src_MD-M-newcorr/COMMON.SCCOR deleted file mode 100644 index 7952bd1..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.SCCOR +++ /dev/null @@ -1,18 +0,0 @@ -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), - & nterm_sccor(-ntyp:ntyp,-ntyp:ntyp),isccortyp(-ntyp:ntyp), - & nsccortyp, - & nlor_sccor(-ntyp:ntyp,-ntyp:ntyp), - & vlor1sccor(maxterm_sccor,20,20), - & vlor2sccor(maxterm_sccor,20,20), - & vlor3sccor(maxterm_sccor,20,20),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) diff --git a/source/unres/src_MD-M-newcorr/COMMON.SCROT b/source/unres/src_MD-M-newcorr/COMMON.SCROT deleted file mode 100644 index a352775..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.SCROT +++ /dev/null @@ -1,3 +0,0 @@ -C Parameters of the SC rotamers (local) term - double precision sc_parmin - common/scrot/sc_parmin(maxsccoef,ntyp) diff --git a/source/unres/src_MD-M-newcorr/COMMON.SETUP b/source/unres/src_MD-M-newcorr/COMMON.SETUP deleted file mode 100644 index 5039116..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.SETUP +++ /dev/null @@ -1,21 +0,0 @@ - integer king,idint,idreal,idchar,is_done - parameter (king=0,idint=1105,idreal=1729,idchar=1597,is_done=1) - integer me,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,nfgtasks,kolor, - & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1),CG_COMM,FG_COMM, - & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp(0:maxprocs-1), - & kolor1,key1,nfgtasks1,MyRank, - & max_gs_size - logical yourjob, finished, cgdone - common/setup/me,MyRank,cg_rank,fg_rank,fg_rank1,nodes,Nprocs, - & nfgtasks,nfgtasks1, - & max_gs_size,kolor,koniec,WhatsUp,ifinish,CG_COMM,FG_COMM, - & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp - integer MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, - & MPI_THET,MPI_GAM, - & MPI_ROTAT1(0:1),MPI_ROTAT2(0:1),MPI_ROTAT_OLD(0:1), - & MPI_PRECOMP11(0:1),MPI_PRECOMP12(0:1),MPI_PRECOMP22(0:1), - & MPI_PRECOMP23(0:1) - common /types/ MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, - & MPI_THET,MPI_GAM, - & MPI_ROTAT1,MPI_ROTAT2,MPI_ROTAT_OLD,MPI_PRECOMP11,MPI_PRECOMP12, - & MPI_PRECOMP22,MPI_PRECOMP23 diff --git a/source/unres/src_MD-M-newcorr/COMMON.SPLITELE b/source/unres/src_MD-M-newcorr/COMMON.SPLITELE deleted file mode 100644 index a2f0447..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.SPLITELE +++ /dev/null @@ -1,2 +0,0 @@ - double precision r_cut,rlamb - common /splitele/ r_cut,rlamb diff --git a/source/unres/src_MD-M-newcorr/COMMON.THREAD b/source/unres/src_MD-M-newcorr/COMMON.THREAD deleted file mode 100644 index 5c814cc..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.THREAD +++ /dev/null @@ -1,7 +0,0 @@ - integer nthread,nexcl,iexam,ipatt - double precision ener0,ener,max_time_for_thread, - & ave_time_for_thread - common /thread/ nthread,nexcl,iexam(2,maxthread), - & ipatt(2,maxthread) - common /thread1/ ener0(n_ene+2,maxthread),ener(n_ene+2,maxthread), - & max_time_for_thread,ave_time_for_thread diff --git a/source/unres/src_MD-M-newcorr/COMMON.TIME1 b/source/unres/src_MD-M-newcorr/COMMON.TIME1 deleted file mode 100644 index d6203a6..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.TIME1 +++ /dev/null @@ -1,28 +0,0 @@ - DOUBLE PRECISION BATIME,TIMLIM,STIME,PREVTIM,SAFETY - DOUBLE PRECISION WALLTIME - INTEGER ISTOP -c FOUND_NAN - set by calcf to stop sumsl via stopx - logical FOUND_NAN - COMMON/TIME1/STIME,TIMLIM,BATIME,PREVTIM,SAFETY,WALLTIME - COMMON/STOPTIM/ISTOP - common /sumsl_flag/ FOUND_NAN - double precision t_init,t_MDsetup,t_langsetup,t_MD, - & t_enegrad,t_sdsetup,time_bcast,time_reduce,time_gather, - & time_sendrecv,time_barrier_e,time_barrier_g,time_scatter, - & t_eelecij,time_bcast7,time_bcastc,time_bcastw,time_allreduce, - & time_enecalc,time_sumene,time_lagrangian,time_cartgrad, - & time_sumgradient,time_intcartderiv,time_inttocart,time_intfcart, - & time_vec,time_mat,time_ginvmult,time_fricmatmult,time_fric, - & time_scatter_fmat,time_scatter_ginv, - & time_fsample,time_scatter_fmatmult,time_scatter_ginvmult, - & time_stoch,t_eshort,t_elong,t_etotal - common /timing/ t_init,t_MDsetup,t_langsetup, - & t_MD,t_enegrad,t_sdsetup,time_bcast,time_reduce,time_gather, - & time_sendrecv,time_scatter,time_barrier_e,time_barrier_g, - & time_bcast7,time_bcastc,time_bcastw,time_allreduce, - & t_eelecij,time_enecalc,time_sumene,time_lagrangian,time_cartgrad, - & time_sumgradient,time_intcartderiv,time_inttocart,time_intfcart, - & time_vec,time_mat,time_ginvmult,time_fricmatmult,time_fric, - & time_fsample,time_scatter_fmatmult,time_scatter_ginvmult, - & time_scatter_fmat,time_scatter_ginv, - & time_stoch,t_eshort,t_elong,t_etotal diff --git a/source/unres/src_MD-M-newcorr/COMMON.TORCNSTR b/source/unres/src_MD-M-newcorr/COMMON.TORCNSTR deleted file mode 100644 index e4af17c..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.TORCNSTR +++ /dev/null @@ -1,6 +0,0 @@ - integer ndih_constr,idih_constr(maxdih_constr) - integer ndih_nconstr,idih_nconstr(maxdih_constr) - integer idihconstr_start,idihconstr_end - double precision phi0(maxdih_constr),drange(maxdih_constr),ftors - common /torcnstr/ phi0,drange,ftors,ndih_constr,idih_constr, - & ndih_nconstr,idih_nconstr,idihconstr_start,idihconstr_end diff --git a/source/unres/src_MD-M-newcorr/COMMON.TORSION b/source/unres/src_MD-M-newcorr/COMMON.TORSION deleted file mode 100644 index 3f1b981..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.TORSION +++ /dev/null @@ -1,41 +0,0 @@ -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(-ntyp1:ntyp1),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, - &bnew1,bnew2,eenew,gtb1,gtb2,eeold,gtee - integer nloctyp - common/fourier/ b1(2,maxres),b2(2,maxres), - & bnew1(3,2,-maxtor:maxtor),bnew2(3,2,-maxtor:maxtor), - & cc(2,2,-maxtor:maxtor), - & dd(2,2,-maxtor:maxtor),eeold(2,2,-maxtor:maxtor), - & eenew(2,-maxtor:maxtor), - & ee(2,2,maxres), - & ctilde(2,2,-maxtor:maxtor), - & dtilde(2,2,-maxtor:maxtor),b1tilde(2,maxres), - & b2tilde(2,maxres), - & gtb1(2,maxres),gtb2(2,maxres),gtEE(2,2,maxres), - & nloctyp - diff --git a/source/unres/src_MD-M-newcorr/COMMON.VAR b/source/unres/src_MD-M-newcorr/COMMON.VAR deleted file mode 100644 index 1ab0a16..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.VAR +++ /dev/null @@ -1,22 +0,0 @@ -C Store the geometric variables in the following COMMON block. - integer ntheta,nphi,nside,nvar,Origin,nstore,ialph,ivar, - & mask_theta,mask_phi,mask_side - double precision theta,phi,alph,omeg,varsave,esave,varall,vbld, - & thetaref,phiref,costtab,sinttab,cost2tab,sint2tab, - & tauangle,omicron, - & xxtab,yytab,zztab,xxref,yyref,zzref - common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), - & vbld(2*maxres),thetaref(maxres),phiref(maxres), - & costtab(maxres), sinttab(maxres), cost2tab(maxres), - & omicron(2,maxres),tauangle(3,maxres), - & sint2tab(maxres),xxtab(maxres),yytab(maxres), - & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres), - & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar -C Store the angles and variables corresponding to old conformations (for use -C in MCM). - common /oldgeo/ varsave(maxvar,maxsave),esave(maxsave), - & Origin(maxsave),nstore -C freeze some variables - logical mask_r - common /restr/ varall(maxvar),mask_r,mask_theta(maxres), - & mask_phi(maxres),mask_side(maxres) diff --git a/source/unres/src_MD-M-newcorr/COMMON.VECTORS b/source/unres/src_MD-M-newcorr/COMMON.VECTORS deleted file mode 100644 index d880c24..0000000 --- a/source/unres/src_MD-M-newcorr/COMMON.VECTORS +++ /dev/null @@ -1,3 +0,0 @@ - common /vectors/ uy(3,maxres),uz(3,maxres), - & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres) - diff --git a/source/unres/src_MD-M-newcorr/DIMENSIONS b/source/unres/src_MD-M-newcorr/DIMENSIONS deleted file mode 100644 index 6815ae9..0000000 --- a/source/unres/src_MD-M-newcorr/DIMENSIONS +++ /dev/null @@ -1,141 +0,0 @@ -******************************************************************************** -* Settings for the program of united-residue peptide simulation in real space * -* * -* ------- As of 6/23/01 ----------- * -* * -******************************************************************************** -C Max. number of processors. - integer maxprocs - parameter (maxprocs=2048) -C Max. number of fine-grain processors - integer max_fg_procs -c parameter (max_fg_procs=maxprocs) - parameter (max_fg_procs=512) -C Max. number of coarse-grain processors - integer max_cg_procs - parameter (max_cg_procs=maxprocs) -C Max. number of AA residues - integer maxres - parameter (maxres=1200) -C Appr. max. number of interaction sites - integer maxres2,maxres6,mmaxres2 - parameter (maxres2=2*maxres,maxres6=6*maxres) - parameter (mmaxres2=(maxres2*(maxres2+1)/2)) -C Max number of symetric chains - integer maxsym - parameter (maxsym=50) - integer maxperm - parameter (maxperm=120) -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 Max. number of SC contacts - integer maxcont - parameter (maxcont=12*maxres) -C Max. number of contacts per residue - integer maxconts - parameter (maxconts=maxres/4) -c parameter (maxconts=50) -C Number of AA types (at present only natural AA's will be handled - integer ntyp,ntyp1 - parameter (ntyp=24,ntyp1=ntyp+1) -C Max. number of types of dihedral angles & multiplicity of torsional barriers -C and the number of terms in double torsionals - integer maxtor,maxterm,maxlor,maxtermd_1,maxtermd_2 - parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) -C Max. number of residue types and parameters in expressions for -C virtual-bond angle bending potentials - integer maxthetyp,maxthetyp1,maxtheterm,maxtheterm2,maxtheterm3, - & maxsingle,maxdouble,mmaxtheterm - parameter (maxthetyp=3,maxthetyp1=maxthetyp+1,maxtheterm=20, - & maxtheterm2=6,maxtheterm3=4,maxsingle=6,maxdouble=4, - & mmaxtheterm=maxtheterm) -c Max number of torsional terms in SCCOR - integer maxterm_sccor - parameter (maxterm_sccor=6) -C Max. number of lobes in SC distribution - integer maxlob - parameter (maxlob=4) -C Max. number of S-S bridges - integer maxss - parameter (maxss=20) -C Max. number of dihedral angle constraints - integer maxdih_constr - parameter (maxdih_constr=maxres) -C Max. number of patterns in the pattern database - integer maxseq - parameter (maxseq=10) -C Max. number of residues in a peptide in the database - integer maxres_base - parameter (maxres_base=10) -C Max. number of threading attempts - integer maxthread - parameter (maxthread=20) -C Max. number of move types in MCM - integer maxmovetype - parameter (maxmovetype=4) -C Max. number of stored confs. in MC/MCM simulation - integer maxsave - parameter (maxsave=20) -C Max. number of energy intervals - integer max_ene - parameter (max_ene=10) -C Max. number of conformations in Master's cache array - integer max_cache - parameter (max_cache=10) -C Max. number of conformations in the pool - integer max_pool - parameter (max_pool=10) -C Number of energy components - integer n_ene,n_ene2 - parameter (n_ene=21,n_ene2=2*n_ene) -C Number of threads in deformation - integer max_thread,max_thread2 - parameter (max_thread=4,max_thread2=2*max_thread) -C Number of structures to compare at t=0 - integer max_threadss,max_threadss2 - parameter (max_threadss=8,max_threadss2=2*max_threadss) -C Maxmimum number of angles per residue - integer mxang - parameter (mxang=4) -C Maximum number of groups of angles - integer mxgr - parameter (mxgr=2*maxres) -C Maximum number of chains - integer mxch - parameter (mxch=1) -C Maximum number of generated conformations - integer mxio - parameter (mxio=2) -C Maximum number of n7 generated conformations - integer mxio2 - parameter (mxio2=2) -C Maximum number of moves (n1-n8) - integer mxmv - parameter (mxmv=18) -C Maximum number of seed - integer max_seed - parameter (max_seed=1) -C Maximum number of timesteps for which stochastic MD matrices can be stored - integer maxflag_stoch - parameter (maxflag_stoch=0) -C Maximum number of backbone fragments in restraining - integer maxfrag_back - parameter (maxfrag_back=4) -C Maximum number of SC local term fitting function coefficiants - integer maxsccoef - parameter (maxsccoef=65) -C Maximum number of terms in SC bond-stretching potential - integer maxbondterm - parameter (maxbondterm=3) -C Maximum number of conformation stored in cache on each CPU before sending -C to master; depends on nstex / ntwx ratio - integer max_cache_traj - parameter (max_cache_traj=10) diff --git a/source/unres/src_MD-M-newcorr/DIMENSIONS.2100 b/source/unres/src_MD-M-newcorr/DIMENSIONS.2100 deleted file mode 100644 index ea1d287..0000000 --- a/source/unres/src_MD-M-newcorr/DIMENSIONS.2100 +++ /dev/null @@ -1,80 +0,0 @@ -******************************************************************************** -* Settings for the program of united-residue peptide simulation in real space * -* * -* ------- As of 6/23/01 ----------- * -* * -******************************************************************************** -C Max. number of processors. - parameter (maxprocs=2100) -C Max. number of fine-grain processors - parameter (max_fg_procs=maxprocs) -C Max. number of coarse-grain processors - parameter (max_cg_procs=maxprocs) -C Max. number of AA residues - parameter (maxres=150) -C Appr. max. number of interaction sites - parameter (maxres2=2*maxres,maxres6=6*maxres) - parameter (mmaxres6=(maxres6*(maxres6+1)/2)) -C Max. number of variables - parameter (maxvar=6*maxres) -C Max. number of groups of interactions that a given SC is involved in - parameter (maxint_gr=2) -C Max. number of derivatives of virtual-bond and side-chain vectors in theta -C or phi. - parameter (maxdim=(maxres-1)*(maxres-2)/2) -C Max. number of SC contacts - parameter (maxcont=12*maxres) -C Max. number of contacts per residue - parameter (maxconts=maxres) -C Number of AA types (at present only natural AA's will be handled - parameter (ntyp=20,ntyp1=ntyp+1) -C Max. number of types of dihedral angles & multiplicity of torsional barriers -C and the number of terms in double torsionals - parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) -C Max. number of lobes in SC distribution - parameter (maxlob=4) -C Max. number of S-S bridges - parameter (maxss=20) -C Max. number of dihedral angle constraints - parameter (maxdih_constr=maxres) -C Max. number of patterns in the pattern database - parameter (maxseq=10) -C Max. number of residues in a peptide in the database - parameter (maxres_base=10) -C Max. number of threading attempts - parameter (maxthread=20) -C Max. number of move types in MCM - parameter (maxmovetype=4) -C Max. number of stored confs. in MC/MCM simulation - parameter (maxsave=20) -C Max. number of energy intervals - parameter (max_ene=10) -C Max. number of conformations in Master's cache array - parameter (max_cache=10) -C Max. number of conformations in the pool - parameter (max_pool=10) -C Number of energy components - parameter (n_ene=21,n_ene2=2*n_ene) -C Number of threads in deformation - integer max_thread,max_thread2 - parameter (max_thread=4,max_thread2=2*max_thread) -C Number of structures to compare at t=0 - integer max_threadss,max_threadss2 - parameter (max_threadss=8,max_threadss2=2*max_threadss) -C Maxmimum number of angles per residue - parameter (mxang=4) -C Maximum number of groups of angles - parameter (mxgr=2*maxres) -C Maximum number of chains - parameter (mxch=1) -C Maximum number of generated conformations - parameter (mxio=2) -C Maximum number of n7 generated conformations - parameter (mxio2=2) -C Maximum number of moves (n1-n8) - parameter (mxmv=18) -C Maximum number of seed - parameter (max_seed=1) -C Maximum number of timesteps for which stochastic MD matrices can be stored - integer maxflag_stoch - parameter (maxflag_stoch=0) diff --git a/source/unres/src_MD-M-newcorr/DIMENSIONS.4100 b/source/unres/src_MD-M-newcorr/DIMENSIONS.4100 deleted file mode 100644 index a4558b9..0000000 --- a/source/unres/src_MD-M-newcorr/DIMENSIONS.4100 +++ /dev/null @@ -1,80 +0,0 @@ -******************************************************************************** -* Settings for the program of united-residue peptide simulation in real space * -* * -* ------- As of 6/23/01 ----------- * -* * -******************************************************************************** -C Max. number of processors. - parameter (maxprocs=4100) -C Max. number of fine-grain processors - parameter (max_fg_procs=maxprocs) -C Max. number of coarse-grain processors - parameter (max_cg_procs=maxprocs) -C Max. number of AA residues - parameter (maxres=150) -C Appr. max. number of interaction sites - parameter (maxres2=2*maxres,maxres6=6*maxres) - parameter (mmaxres6=(maxres6*(maxres6+1)/2)) -C Max. number of variables - parameter (maxvar=6*maxres) -C Max. number of groups of interactions that a given SC is involved in - parameter (maxint_gr=2) -C Max. number of derivatives of virtual-bond and side-chain vectors in theta -C or phi. - parameter (maxdim=(maxres-1)*(maxres-2)/2) -C Max. number of SC contacts - parameter (maxcont=12*maxres) -C Max. number of contacts per residue - parameter (maxconts=maxres) -C Number of AA types (at present only natural AA's will be handled - parameter (ntyp=20,ntyp1=ntyp+1) -C Max. number of types of dihedral angles & multiplicity of torsional barriers -C and the number of terms in double torsionals - parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) -C Max. number of lobes in SC distribution - parameter (maxlob=4) -C Max. number of S-S bridges - parameter (maxss=20) -C Max. number of dihedral angle constraints - parameter (maxdih_constr=maxres) -C Max. number of patterns in the pattern database - parameter (maxseq=10) -C Max. number of residues in a peptide in the database - parameter (maxres_base=10) -C Max. number of threading attempts - parameter (maxthread=20) -C Max. number of move types in MCM - parameter (maxmovetype=4) -C Max. number of stored confs. in MC/MCM simulation - parameter (maxsave=20) -C Max. number of energy intervals - parameter (max_ene=10) -C Max. number of conformations in Master's cache array - parameter (max_cache=10) -C Max. number of conformations in the pool - parameter (max_pool=10) -C Number of energy components - parameter (n_ene=21,n_ene2=2*n_ene) -C Number of threads in deformation - integer max_thread,max_thread2 - parameter (max_thread=4,max_thread2=2*max_thread) -C Number of structures to compare at t=0 - integer max_threadss,max_threadss2 - parameter (max_threadss=8,max_threadss2=2*max_threadss) -C Maxmimum number of angles per residue - parameter (mxang=4) -C Maximum number of groups of angles - parameter (mxgr=2*maxres) -C Maximum number of chains - parameter (mxch=1) -C Maximum number of generated conformations - parameter (mxio=2) -C Maximum number of n7 generated conformations - parameter (mxio2=2) -C Maximum number of moves (n1-n8) - parameter (mxmv=18) -C Maximum number of seed - parameter (max_seed=1) -C Maximum number of timesteps for which stochastic MD matrices can be stored - integer maxflag_stoch - parameter (maxflag_stoch=0) diff --git a/source/unres/src_MD-M-newcorr/DIMENSIONS_safe1 b/source/unres/src_MD-M-newcorr/DIMENSIONS_safe1 deleted file mode 100644 index 7e72823..0000000 --- a/source/unres/src_MD-M-newcorr/DIMENSIONS_safe1 +++ /dev/null @@ -1,135 +0,0 @@ -******************************************************************************** -* Settings for the program of united-residue peptide simulation in real space * -* * -* ------- As of 6/23/01 ----------- * -* * -******************************************************************************** -C Max. number of processors. - integer maxprocs - parameter (maxprocs=2048) -C Max. number of fine-grain processors - integer max_fg_procs - parameter (max_fg_procs=maxprocs) -C Max. number of coarse-grain processors - integer max_cg_procs - parameter (max_cg_procs=maxprocs) -C Max. number of AA residues - integer maxres - parameter (maxres=800) -C Appr. max. number of interaction sites - integer maxres2,maxres6,mmaxres2 - parameter (maxres2=2*maxres,maxres6=6*maxres) - parameter (mmaxres2=(maxres2*(maxres2+1)/2)) -C Max. number of variables - integer maxvar - parameter (maxvar=6*maxres) -C Max. number of groups of interactions that a given SC is involved in - integer maxint_gr - parameter (maxint_gr=2) -C Max. number of derivatives of virtual-bond and side-chain vectors in theta -C or phi. - integer maxdim - parameter (maxdim=(maxres-1)*(maxres-2)/2) -C Max. number of SC contacts - integer maxcont - parameter (maxcont=12*maxres) -C Max. number of contacts per residue - integer maxconts - parameter (maxconts=maxres/4) -c parameter (maxconts=50) -C Number of AA types (at present only natural AA's will be handled - integer ntyp,ntyp1 - parameter (ntyp=20,ntyp1=ntyp+1) -C Max. number of types of dihedral angles & multiplicity of torsional barriers -C and the number of terms in double torsionals - integer maxtor,maxterm,maxlor,maxtermd_1,maxtermd_2 - parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) -C Max. number of residue types and parameters in expressions for -C virtual-bond angle bending potentials - integer maxthetyp,maxthetyp1,maxtheterm,maxtheterm2,maxtheterm3, - & maxsingle,maxdouble,mmaxtheterm - parameter (maxthetyp=3,maxthetyp1=maxthetyp+1,maxtheterm=20, - & maxtheterm2=6,maxtheterm3=4,maxsingle=6,maxdouble=4, - & mmaxtheterm=maxtheterm) -c Max number of torsional terms in SCCOR - integer maxterm_sccor - parameter (maxterm_sccor=3) -C Max. number of lobes in SC distribution - integer maxlob - parameter (maxlob=4) -C Max. number of S-S bridges - integer maxss - parameter (maxss=20) -C Max. number of dihedral angle constraints - integer maxdih_constr - parameter (maxdih_constr=maxres) -C Max. number of patterns in the pattern database - integer maxseq - parameter (maxseq=10) -C Max. number of residues in a peptide in the database - integer maxres_base - parameter (maxres_base=10) -C Max. number of threading attempts - integer maxthread - parameter (maxthread=20) -C Max. number of move types in MCM - integer maxmovetype - parameter (maxmovetype=4) -C Max. number of stored confs. in MC/MCM simulation - integer maxsave - parameter (maxsave=20) -C Max. number of energy intervals - integer max_ene - parameter (max_ene=10) -C Max. number of conformations in Master's cache array - integer max_cache - parameter (max_cache=10) -C Max. number of conformations in the pool - integer max_pool - parameter (max_pool=10) -C Number of energy components - integer n_ene,n_ene2 - parameter (n_ene=21,n_ene2=2*n_ene) -C Number of threads in deformation - integer max_thread,max_thread2 - parameter (max_thread=4,max_thread2=2*max_thread) -C Number of structures to compare at t=0 - integer max_threadss,max_threadss2 - parameter (max_threadss=8,max_threadss2=2*max_threadss) -C Maxmimum number of angles per residue - integer mxang - parameter (mxang=4) -C Maximum number of groups of angles - integer mxgr - parameter (mxgr=2*maxres) -C Maximum number of chains - integer mxch - parameter (mxch=1) -C Maximum number of generated conformations - integer mxio - parameter (mxio=2) -C Maximum number of n7 generated conformations - integer mxio2 - parameter (mxio2=2) -C Maximum number of moves (n1-n8) - integer mxmv - parameter (mxmv=18) -C Maximum number of seed - integer max_seed - parameter (max_seed=1) -C Maximum number of timesteps for which stochastic MD matrices can be stored - integer maxflag_stoch - parameter (maxflag_stoch=0) -C Maximum number of backbone fragments in restraining - integer maxfrag_back - parameter (maxfrag_back=4) -C Maximum number of SC local term fitting function coefficiants - integer maxsccoef - parameter (maxsccoef=65) -C Maximum number of terms in SC bond-stretching potential - integer maxbondterm - parameter (maxbondterm=3) -C Maximum number of conformation stored in cache on each CPU before sending -C to master; depends on nstex / ntwx ratio - integer max_cache_traj - parameter (max_cache_traj=10) diff --git a/source/unres/src_MD-M-newcorr/MD.F b/source/unres/src_MD-M-newcorr/MD.F deleted file mode 100644 index b740de7..0000000 --- a/source/unres/src_MD-M-newcorr/MD.F +++ /dev/null @@ -1,2565 +0,0 @@ - subroutine MD -c------------------------------------------------ -c The driver for molecular dynamics subroutines -c------------------------------------------------ - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - include 'COMMON.HAIRPIN' - double precision cm(3),L(3),vcm(3) -#ifdef VOUT - double precision v_work(maxres6),v_transf(maxres6) -#endif - integer ilen,rstcount - external ilen - character*50 tytul - common /gucio/ cm - integer itime -c -#ifdef MPI - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_" - & //liczba(:ilen(liczba))//'.rst') -#else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_"//'.rst') -#endif - t_MDsetup=0.0d0 - t_langsetup=0.0d0 - t_MD=0.0d0 - t_enegrad=0.0d0 - t_sdsetup=0.0d0 - write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" -#ifdef MPI - tt0=MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Determine the inverse of the inertia matrix. - call setup_MD_matrices -c Initialize MD - call init_MD -#ifdef MPI - t_MDsetup = MPI_Wtime()-tt0 -#else - t_MDsetup = tcpu()-tt0 -#endif - rstcount=0 -c Entering the MD loop -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif - if (lang.eq.2 .or. lang.eq.3) then - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo -#endif - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif -#ifdef MPI - t_langsetup=MPI_Wtime()-tt0 - tt0=MPI_Wtime() -#else - t_langsetup=tcpu()-tt0 - tt0=tcpu() -#endif - do itime=1,n_timestep - if (ovrtim()) goto 100 - rstcount=rstcount+1 - if (lang.gt.0 .and. surfarea .and. - & mod(itime,reset_fricmat).eq.0) then - if (lang.eq.2 .or. lang.eq.3) then - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo -#endif - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - write (iout,'(a,i10)') - & "Friction matrix reset based on surface area, itime",itime - endif - if (reset_vel .and. tbf .and. lang.eq.0 - & .and. mod(itime,count_reset_vel).eq.0) then - call random_vel - write(iout,'(a,f20.2)') - & "Velocities reset to random values, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - endif - if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then - call inertia_tensor - call vcm_vel(vcm) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen*Rb)*EK - scalfac=dsqrt(T_bath/kinetic_T) - write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=scalfac*d_t(j,i) - enddo - enddo - endif - if (lang.ne.4) then - if (RESPA) then -c Time-reversible RESPA algorithm -c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) - call RESPA_step(itime) - else -c Variable time step algorithm. - call velverlet_step(itime) - endif - else - call brown_step(itime) - endif - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) call statout(itime) -#ifdef VOUT - do j=1,3 - v_work(j)=d_t(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - v_work(ind)=d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - ind=ind+1 - v_work(ind)=d_t(j,i+nres) - enddo - endif - enddo - - write (66,'(80f10.5)') - & ((d_t(j,i),j=1,3),i=0,nres-1),((d_t(j,i+nres),j=1,3),i=1,nres) - do i=1,ind - v_transf(i)=0.0d0 - do j=1,ind - v_transf(i)=v_transf(i)+gvec(j,i)*v_work(j) - enddo - v_transf(i)= v_transf(i)*dsqrt(geigen(i)) - enddo - write (67,'(80f10.5)') (v_transf(i),i=1,ind) -#endif - endif - call check_cartgrad - if (mod(itime,ntwx).eq.0) then - write (tytul,'("time",f8.2)') totT - if(mdpdb) then - call check_cartgrad - write(iout,*) "kupa gowna" - call hairpin(.true.,nharp,iharp) - call secondary2(.true.) - call pdbout(potE,tytul,ipdb) - else - call cartout(totT) - endif - endif - if (rstcount.eq.1000.or.itime.eq.n_timestep) then - open(irest2,file=rest2name,status='unknown') - write(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - write (irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - close(irest2) - rstcount=0 - endif - enddo - 100 continue -#ifdef MPI - t_MD=MPI_Wtime()-tt0 -#else - t_MD=tcpu()-tt0 -#endif - write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') - & ' Timing ', - & 'MD calculations setup:',t_MDsetup, - & 'Energy & gradient evaluation:',t_enegrad, - & 'Stochastic MD setup:',t_langsetup, - & 'Stochastic MD step setup:',t_sdsetup, - & 'MD steps:',t_MD - write (iout,'(/28(1h=),a25,27(1h=))') - & ' End of MD calculation ' - return - end -c------------------------------------------------------------------------------- - subroutine brown_step(itime) -c------------------------------------------------ -c Perform a single Euler integration step of Brownian dynamics -c------------------------------------------------ - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision zapas(MAXRES6) - integer ilen,rstcount - external ilen - double precision stochforcvec(MAXRES6) - double precision Bmat(MAXRES6,MAXRES2),Cmat(maxres2,maxres2), - & Cinv(maxres2,maxres2),GBmat(MAXRES6,MAXRES2), - & Tmat(MAXRES6,MAXRES2),Pmat(maxres6,maxres6),Td(maxres6), - & ppvec(maxres2) - common /stochcalc/ stochforcvec - common /gucio/ cm - integer itime - logical lprn /.false./,lprn1 /.false./ - integer maxiter /5/ - double precision difftol /1.0d-5/ - nbond=nct-nnt - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) nbond=nbond+1 - enddo -c - if (lprn1) then - write (iout,*) "Generalized inverse of fricmat" - call matout(dimen,dimen,MAXRES6,MAXRES6,fricmat) - endif - do i=1,dimen - do j=1,nbond - Bmat(i,j)=0.0d0 - enddo - enddo - ind=3 - ind1=0 - do i=nnt,nct-1 - ind1=ind1+1 - do j=1,3 - Bmat(ind+j,ind1)=dC_norm(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - ind1=ind1+1 - do j=1,3 - Bmat(ind+j,ind1)=dC_norm(j,i+nres) - enddo - ind=ind+3 - endif - enddo - if (lprn1) then - write (iout,*) "Matrix Bmat" - call MATOUT(nbond,dimen,MAXRES6,MAXRES2,Bmat) - endif - do i=1,dimen - do j=1,nbond - GBmat(i,j)=0.0d0 - do k=1,dimen - GBmat(i,j)=GBmat(i,j)+fricmat(i,k)*Bmat(k,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix GBmat" - call MATOUT(nbond,dimen,MAXRES6,MAXRES2,Gbmat) - endif - do i=1,nbond - do j=1,nbond - Cmat(i,j)=0.0d0 - do k=1,dimen - Cmat(i,j)=Cmat(i,j)+Bmat(k,i)*GBmat(k,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Cmat" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) - endif - call matinvert(nbond,MAXRES2,Cmat,Cinv) - if (lprn1) then - write (iout,*) "Matrix Cinv" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cinv) - endif - do i=1,dimen - do j=1,nbond - Tmat(i,j)=0.0d0 - do k=1,nbond - Tmat(i,j)=Tmat(i,j)+GBmat(i,k)*Cinv(k,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Tmat" - call MATOUT(nbond,dimen,MAXRES6,MAXRES2,Tmat) - endif - do i=1,dimen - do j=1,dimen - if (i.eq.j) then - Pmat(i,j)=1.0d0 - else - Pmat(i,j)=0.0d0 - endif - do k=1,nbond - Pmat(i,j)=Pmat(i,j)-Tmat(i,k)*Bmat(j,k) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Pmat" - call MATOUT(dimen,dimen,MAXRES6,MAXRES6,Pmat) - endif - do i=1,dimen - Td(i)=0.0d0 - ind=0 - do k=nnt,nct-1 - ind=ind+1 - Td(i)=Td(i)+vbl*Tmat(i,ind) - enddo - do k=nnt,nct - if (itype(k).ne.10 .and. itype(i).ne.ntyp1) then - ind=ind+1 - Td(i)=Td(i)+vbldsc0(1,itype(k))*Tmat(i,ind) - endif - enddo - enddo - if (lprn1) then - write (iout,*) "Vector Td" - do i=1,dimen - write (iout,'(i5,f10.5)') i,Td(i) - enddo - endif - call stochastic_force(stochforcvec) - if (lprn) then - write (iout,*) "stochforcvec" - do i=1,dimen - write (iout,*) i,stochforcvec(i) - enddo - endif - do j=1,3 - zapas(j)=-gcart(j,0)+stochforcvec(j) - d_t_work(j)=d_t(j,0) - dC_work(j)=dC_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - zapas(ind)=-gcart(j,i)+stochforcvec(ind) - dC_work(ind)=dC_old(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - ind=ind+1 - zapas(ind)=-gxcart(j,i)+stochforcvec(ind) - dC_work(ind)=dC_old(j,i+nres) - enddo - endif - enddo - - if (lprn) then - write (iout,*) "Initial d_t_work" - do i=1,dimen - write (iout,*) i,d_t_work(i) - enddo - endif - - do i=1,dimen - d_t_work(i)=0.0d0 - do j=1,dimen - d_t_work(i)=d_t_work(i)+fricmat(i,j)*zapas(j) - enddo - enddo - - do i=1,dimen - zapas(i)=Td(i) - do j=1,dimen - zapas(i)=zapas(i)+Pmat(i,j)*(dC_work(j)+d_t_work(j)*d_time) - enddo - enddo - if (lprn1) then - write (iout,*) "Final d_t_work and zapas" - do i=1,dimen - write (iout,*) i,d_t_work(i),zapas(i) - enddo - endif - - do j=1,3 - d_t(j,0)=d_t_work(j) - dc(j,0)=zapas(j) - dc_work(j)=dc(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(i) - dc(j,i)=zapas(ind+j) - dc_work(ind+j)=dc(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - do j=1,3 - d_t(j,i+nres)=d_t_work(ind+j) - dc(j,i+nres)=zapas(ind+j) - dc_work(ind+j)=dc(j,i+nres) - enddo - ind=ind+3 - enddo - if (lprn) then - call chainbuild_cart - write (iout,*) "Before correction for rotational lengthening" - write (iout,*) "New coordinates", - & " and differences between actual and standard bond lengths" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - xx=vbld(i+1)-vbl - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i),j=1,3),xx - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - ind=ind+1 - xx=vbld(i+nres)-vbldsc0(1,itype(i)) - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i+nres),j=1,3),xx - endif - enddo - endif -c Second correction (rotational lengthening) -c do iter=1,maxiter - diffmax=0.0d0 - ind=0 - do i=nnt,nct-1 - ind=ind+1 - blen2 = scalar(dc(1,i),dc(1,i)) - ppvec(ind)=2*vbl**2-blen2 - diffbond=dabs(vbl-dsqrt(blen2)) - if (diffbond.gt.diffmax) diffmax=diffbond - if (ppvec(ind).gt.0.0d0) then - ppvec(ind)=dsqrt(ppvec(ind)) - else - ppvec(ind)=0.0d0 - endif - if (lprn) then - write (iout,'(i5,3f10.5)') ind,diffbond,ppvec(ind) - endif - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - ind=ind+1 - blen2 = scalar(dc(1,i+nres),dc(1,i+nres)) - ppvec(ind)=2*vbldsc0(1,itype(i))**2-blen2 - diffbond=dabs(vbldsc0(1,itype(i))-dsqrt(blen2)) - if (diffbond.gt.diffmax) diffmax=diffbond - if (ppvec(ind).gt.0.0d0) then - ppvec(ind)=dsqrt(ppvec(ind)) - else - ppvec(ind)=0.0d0 - endif - if (lprn) then - write (iout,'(i5,3f10.5)') ind,diffbond,ppvec(ind) - endif - endif - enddo - if (lprn) write (iout,*) "iter",iter," diffmax",diffmax - if (diffmax.lt.difftol) goto 10 - do i=1,dimen - Td(i)=0.0d0 - do j=1,nbond - Td(i)=Td(i)+ppvec(j)*Tmat(i,j) - enddo - enddo - do i=1,dimen - zapas(i)=Td(i) - do j=1,dimen - zapas(i)=zapas(i)+Pmat(i,j)*dc_work(j) - enddo - enddo - do j=1,3 - dc(j,0)=zapas(j) - dc_work(j)=zapas(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=zapas(ind+j) - dc_work(ind+j)=zapas(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - dc(j,i+nres)=zapas(ind+j) - dc_work(ind+j)=zapas(ind+j) - enddo - ind=ind+3 - endif - enddo -c Building the chain from the newly calculated coordinates - call chainbuild_cart - if(ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "Cartesian and internal coordinates: step 1" - call cartprint - call intout - write (iout,'(a)') "Potential forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(-gcart(j,i),j=1,3), - & (-gxcart(j,i),j=1,3) - enddo - write (iout,'(a)') "Stochastic forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(stochforc(j,i),j=1,3), - & (stochforc(j,i+nres),j=1,3) - enddo - write (iout,'(a)') "Velocities" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif - if (lprn) then - write (iout,*) "After correction for rotational lengthening" - write (iout,*) "New coordinates", - & " and differences between actual and standard bond lengths" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - xx=vbld(i+1)-vbl - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i),j=1,3),xx - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - ind=ind+1 - xx=vbld(i+nres)-vbldsc0(1,itype(i)) - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i+nres),j=1,3),xx - endif - enddo - endif -c ENDDO -c write (iout,*) "Too many attempts at correcting the bonds" -c stop - 10 continue -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Calculate energy and forces - call zerograd - call etotal(potEcomp) - potE=potEcomp(0)-potEcomp(20) - call cartgrad - totT=totT+d_time -c Calculate the kinetic and total energy and the kinetic temperature - call kinetic(EK) -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - totE=EK+potE - kinetic_T=2.0d0/(dimen*Rb)*EK - return - end -c------------------------------------------------------------------------------- - subroutine velverlet_step(itime) -c------------------------------------------------------------------------------- -c Perform a single velocity Verlet step; the time step can be rescaled if -c increments in accelerations exceed the threshold -c------------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer ierror,ierrcode -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - include 'COMMON.MUCA' - double precision vcm(3),incr(3) - double precision cm(3),L(3) - integer ilen,count,rstcount - external ilen - character*50 tytul - integer maxcount_scale /20/ - common /gucio/ cm - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - integer itime - logical scale -c - scale=.true. - icount_scale=0 - if (lang.eq.1) then - call sddir_precalc - else if (lang.eq.2 .or. lang.eq.3) then - call stochastic_force(stochforcvec) - endif - itime_scal=0 - do while (scale) - icount_scale=icount_scale+1 - if (icount_scale.gt.maxcount_scale) then - write (iout,*) - & "ERROR: too many attempts at scaling down the time step. ", - & "amax=",amax,"epdrift=",epdrift, - & "damax=",damax,"edriftmax=",edriftmax, - & "d_time=",d_time - call flush(iout) -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,IERRCODE) -#endif - stop - endif -c First step of the velocity Verlet algorithm - if (lang.eq.2) then - call sd_verlet1 - else if (lang.eq.3) then - call sd_verlet1_ciccotti - else if (lang.eq.1) then - call sddir_verlet1 - else - call verlet1 - endif -c Build the chain from the newly calculated coordinates - call chainbuild_cart - if (rattle) call rattle1 - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "Cartesian and internal coordinates: step 1" - call cartprint - call intout - write (iout,*) "dC" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo - write (iout,*) "Accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 1" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Calculate energy and forces - call zerograd - call etotal(potEcomp) - potE=potEcomp(0)-potEcomp(20) - call cartgrad -c Get the new accelerations - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Determine maximum acceleration and scale down the timestep if needed - call max_accel - call predict_edrift(epdrift) - if (amax.gt.damax .or. epdrift.gt.edriftmax) then -c Maximum acceleration or maximum predicted energy drift exceeded, rescale the time step - scale=.true. - ifac_time=dmax1(dlog(amax/damax),dlog(epdrift/edriftmax)) - & /dlog(2.0d0)+1 - itime_scal=itime_scal+ifac_time -c fac_time=dmin1(damax/amax,0.5d0) - fac_time=0.5d0**ifac_time - d_time=d_time*fac_time - if (lang.eq.2 .or. lang.eq.3) then -c write (iout,*) "Calling sd_verlet_setup: 1" -c Rescale the stochastic forces and recalculate or restore -c the matrices of tinker integrator - if (itime_scal.gt.maxflag_stoch) then - if (large) write (iout,'(a,i5,a)') - & "Calculate matrices for stochastic step;", - & " itime_scal ",itime_scal - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - write (iout,'(2a,i3,a,i3,1h.)') - & "Warning: cannot store matrices for stochastic", - & " integration because the index",itime_scal, - & " is greater than",maxflag_stoch - write (iout,'(2a)')"Increase MAXFLAG_STOCH or use direct", - & " integration Langevin algorithm for better efficiency." - else if (flag_stoch(itime_scal)) then - if (large) write (iout,'(a,i5,a,l1)') - & "Restore matrices for stochastic step; itime_scal ", - & itime_scal," flag ",flag_stoch(itime_scal) -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - pfric_mat(i,j)=pfric0_mat(i,j,itime_scal) - afric_mat(i,j)=afric0_mat(i,j,itime_scal) - vfric_mat(i,j)=vfric0_mat(i,j,itime_scal) - prand_mat(i,j)=prand0_mat(i,j,itime_scal) - vrand_mat1(i,j)=vrand0_mat1(i,j,itime_scal) - vrand_mat2(i,j)=vrand0_mat2(i,j,itime_scal) - enddo - enddo -#endif - else - if (large) write (iout,'(2a,i5,a,l1)') - & "Calculate & store matrices for stochastic step;", - & " itime_scal ",itime_scal," flag ",flag_stoch(itime_scal) - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - flag_stoch(ifac_time)=.true. -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,itime_scal)=pfric_mat(i,j) - afric0_mat(i,j,itime_scal)=afric_mat(i,j) - vfric0_mat(i,j,itime_scal)=vfric_mat(i,j) - prand0_mat(i,j,itime_scal)=prand_mat(i,j) - vrand0_mat1(i,j,itime_scal)=vrand_mat1(i,j) - vrand0_mat2(i,j,itime_scal)=vrand_mat2(i,j) - enddo - enddo -#endif - endif - fac_time=1.0d0/dsqrt(fac_time) - do i=1,dimen - stochforcvec(i)=fac_time*stochforcvec(i) - enddo - else if (lang.eq.1) then -c Rescale the accelerations due to stochastic forces - fac_time=1.0d0/dsqrt(fac_time) - do i=1,dimen - d_as_work(i)=d_as_work(i)*fac_time - enddo - endif - if (large) write (iout,'(a,i10,a,f8.6,a,i3,a,i3)') - & "itime",itime," Timestep scaled down to ", - & d_time," ifac_time",ifac_time," itime_scal",itime_scal - else -c Second step of the velocity Verlet algorithm - if (lang.eq.2) then - call sd_verlet2 - else if (lang.eq.3) then - call sd_verlet2_ciccotti - else if (lang.eq.1) then - call sddir_verlet2 - else - call verlet2 - endif - if (rattle) call rattle2 - totT=totT+d_time - if (d_time.ne.d_time0) then - d_time=d_time0 - if (lang.eq.2 .or. lang.eq.3) then - if (large) write (iout,'(a)') - & "Restore original matrices for stochastic step" -c write (iout,*) "Calling sd_verlet_setup: 2" -c Restore the matrices of tinker integrator if the time step has been restored -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - pfric_mat(i,j)=pfric0_mat(i,j,0) - afric_mat(i,j)=afric0_mat(i,j,0) - vfric_mat(i,j)=vfric0_mat(i,j,0) - prand_mat(i,j)=prand0_mat(i,j,0) - vrand_mat1(i,j)=vrand0_mat1(i,j,0) - vrand_mat2(i,j)=vrand0_mat2(i,j,0) - enddo - enddo -#endif - endif - endif - scale=.false. - endif - enddo -c Calculate the kinetic and the total energy and the kinetic temperature - call kinetic(EK) - totE=EK+potE -c diagnostics -c call kinetic1(EK1) -c write (iout,*) "step",itime," EK",EK," EK1",EK1 -c end diagnostics -c Couple the system to Berendsen bath if needed - if (tbf .and. lang.eq.0) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen*Rb)*EK -c Backup the coordinates, velocities, and accelerations - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, step 2" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif - return - end -c------------------------------------------------------------------------------- - subroutine RESPA_step(itime) -c------------------------------------------------------------------------------- -c Perform a single RESPA step. -c------------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision energia_short(0:n_ene), - & energia_long(0:n_ene) - double precision cm(3),L(3),vcm(3),incr(3) - integer ilen,count,rstcount - external ilen - character*50 tytul - integer maxcount_scale /10/ - common /gucio/ cm - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - integer itime - logical scale - common /cipiszcze/ itt - itt=itime - large=(itime.gt.14600 .and. itime.lt.14700) - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "***************** RESPA itime",itime - write (iout,*) "Cartesian and internal coordinates: step 0" -c call cartprint - call pdbout(0.0d0,"cipiszcze",iout) - call intout - write (iout,*) "Accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 0" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c -c Perform the initial RESPA step (increment velocities) -c write (iout,*) "*********************** RESPA ini" - call RESPA_vel - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, end" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c Compute the short-range forces -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_short(energia_short) - if (large) write (iout,*) "energia_short",energia_short(0) - call cartgrad - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - d_time0=d_time -c Split the time step - d_time=d_time/ntime_split -c Perform the short-range RESPSA steps (velocity Verlet increments of -c positions and velocities using short-range forces) -c write (iout,*) "*********************** RESPA split" - do itsplit=1,ntime_split - if (lang.eq.1) then - call sddir_precalc - else if (lang.eq.2 .or. lang.eq.3) then - call stochastic_force(stochforcvec) - endif -c First step of the velocity Verlet algorithm - if (lang.eq.2) then - call sd_verlet1 - else if (lang.eq.3) then - call sd_verlet1_ciccotti - else if (lang.eq.1) then - call sddir_verlet1 - else - call verlet1 - endif -c Build the chain from the newly calculated coordinates - call chainbuild_cart - if (rattle) call rattle1 - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "Cartesian and internal coordinates: step 1" - call pdbout(0.0d0,"cipiszcze",iout) -c call cartprint - call intout - write (iout,*) "Accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 1" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Calculate energy and forces - call zerograd - call etotal_short(energia_short) - if (large) write (iout,*) "energia_short",energia_short(0) - call cartgrad -c Get the new accelerations - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Second step of the velocity Verlet algorithm - if (lang.eq.2) then - call sd_verlet2 - else if (lang.eq.3) then - call sd_verlet2_ciccotti - else if (lang.eq.1) then - call sddir_verlet2 - else - call verlet2 - endif - if (rattle) call rattle2 -c Backup the coordinates, velocities, and accelerations - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - enddo -c Restore the time step - d_time=d_time0 -c Compute long-range forces -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_long(energia_long) - if (large) write (iout,*) "energia_long",energia_long(0) - call cartgrad - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Compute accelerations from long-range forces - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "Cartesian and internal coordinates: step 2" -c call cartprint - call pdbout(0.0d0,"cipiszcze",iout) - call intout - write (iout,*) "Accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 2" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c Compute the final RESPA step (increment velocities) -c write (iout,*) "*********************** RESPA fin" - call RESPA_vel -c Compute the complete potential energy - do i=0,n_ene - potEcomp(i)=energia_short(i)+energia_long(i) - enddo - potE=potEcomp(0)-potEcomp(20) -c potE=energia_short(0)+energia_long(0) - totT=totT+d_time -c Calculate the kinetic and the total energy and the kinetic temperature - call kinetic(EK) - totE=EK+potE -c Couple the system to Berendsen bath if needed - if (tbf .and. lang.eq.0) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen*Rb)*EK -c Backup the coordinates, velocities, and accelerations - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, end" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif - return - end -c--------------------------------------------------------------------- - subroutine RESPA_vel -c First and last RESPA step (incrementing velocities using long-range -c forces). - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - do j=1,3 - d_t(j,0)=d_t(j,0)+0.5d0*d_a(j,0)*d_time - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t(j,i)+0.5d0*d_a(j,i)*d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t(j,inres)+0.5d0*d_a(j,inres)*d_time - enddo - endif - enddo - return - end -c----------------------------------------------------------------- - subroutine verlet1 -c Applying velocity Verlet algorithm - step 1 to coordinates - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision adt,adt2 - - do j=1,3 - adt=d_a_old(j,0)*d_time - adt2=0.5d0*adt - dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time - d_t_new(j,0)=d_t_old(j,0)+adt2 - d_t(j,0)=d_t_old(j,0)+adt - enddo - do i=nnt,nct-1 - do j=1,3 - adt=d_a_old(j,i)*d_time - adt2=0.5d0*adt - dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time - d_t_new(j,i)=d_t_old(j,i)+adt2 - d_t(j,i)=d_t_old(j,i)+adt - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - adt=d_a_old(j,inres)*d_time - adt2=0.5d0*adt - dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time - d_t_new(j,inres)=d_t_old(j,inres)+adt2 - d_t(j,inres)=d_t_old(j,inres)+adt - enddo - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine verlet2 -c Step 2 of the velocity Verlet algorithm: update velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - do j=1,3 - d_t(j,0)=d_t_new(j,0)+0.5d0*d_a(j,0)*d_time - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+0.5d0*d_a(j,i)*d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+0.5d0*d_a(j,inres)*d_time - enddo - endif - enddo - return - end -c----------------------------------------------------------------- - subroutine sddir_precalc -c Applying velocity Verlet algorithm - step 1 to coordinates - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute friction and stochastic forces -c - call friction_force - call stochastic_force(stochforcvec) -c -c Compute the acceleration due to friction forces (d_af_work) and stochastic -c forces (d_as_work) -c -#ifdef OLD_GINV - do i=1,dimen - d_af_work(i)=0.0d0 - d_as_work(i)=0.0d0 - do j=1,dimen - d_af_work(i)=d_af_work(i)+Ginv(i,j)*fric_work(j) - d_as_work(i)=d_as_work(i)+Ginv(i,j)*stochforcvec(j) - enddo - enddo -#else - call ginv_mult(fric_work, d_af_work) - call ginv_mult(stochforcvec, d_as_work) -#endif - return - end -c--------------------------------------------------------------------- - subroutine sddir_verlet1 -c Applying velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' -c Revised 3/31/05 AL: correlation between random contributions to -c position and velocity increments included. - double precision sqrt13 /0.57735026918962576451d0/ ! 1/sqrt(3) - double precision adt,adt2 -c -c Add the contribution from BOTH friction and stochastic force to the -c coordinates, but ONLY the contribution from the friction forces to velocities -c - do j=1,3 - adt=(d_a_old(j,0)+d_af_work(j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(j)*d_time - dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time - d_t_new(j,0)=d_t_old(j,0)+0.5d0*adt - d_t(j,0)=d_t_old(j,0)+adt - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - adt=(d_a_old(j,i)+d_af_work(ind+j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time - dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time - d_t_new(j,i)=d_t_old(j,i)+0.5d0*adt - d_t(j,i)=d_t_old(j,i)+adt - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - adt=(d_a_old(j,inres)+d_af_work(ind+j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time - dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time - d_t_new(j,inres)=d_t_old(j,inres)+0.5d0*adt - d_t(j,inres)=d_t_old(j,inres)+adt - enddo - ind=ind+3 - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine sddir_verlet2 -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),d_as_work1(MAXRES6) - double precision cos60 /0.5d0/, sin60 /0.86602540378443864676d0/ -c Revised 3/31/05 AL: correlation between random contributions to -c position and velocity increments included. -c The correlation coefficients are calculated at low-friction limit. -c Also, friction forces are now not calculated with new velocities. - -c call friction_force - call stochastic_force(stochforcvec) -c -c Compute the acceleration due to friction forces (d_af_work) and stochastic -c forces (d_as_work) -c -#ifdef OLD_GINV - do i=1,dimen -c d_af_work(i)=0.0d0 - d_as_work1(i)=0.0d0 - do j=1,dimen -c d_af_work(i)=d_af_work(i)+Ginv(i,j)*fric_work(j) - d_as_work1(i)=d_as_work1(i)+Ginv(i,j)*stochforcvec(j) - enddo - enddo -#else - call ginv_mult(stochforcvec, d_as_work1) -#endif - -c -c Update velocities -c - do j=1,3 - d_t(j,0)=d_t_new(j,0)+(0.5d0*(d_a(j,0)+d_af_work(j)) - & +sin60*d_as_work(j)+cos60*d_as_work1(j))*d_time - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+(0.5d0*(d_a(j,i)+d_af_work(ind+j)) - & +sin60*d_as_work(ind+j)+cos60*d_as_work1(ind+j))*d_time - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+(0.5d0*(d_a(j,inres) - & +d_af_work(ind+j))+sin60*d_as_work(ind+j) - & +cos60*d_as_work1(ind+j))*d_time - enddo - ind=ind+3 - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine max_accel -c -c Find the maximum difference in the accelerations of the the sites -c at the beginning and the end of the time step. -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - double precision aux(3),accel(3) - do j=1,3 - aux(j)=d_a(j,0)-d_a_old(j,0) - enddo - amax=0.0d0 - do i=nnt,nct -c Backbone - if (i.lt.nct) then - do j=1,3 - accel(j)=aux(j)+0.5d0*(d_a(j,i)-d_a_old(j,i)) - if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) - enddo - endif -c Side chains - do j=1,3 - accel(j)=aux(j) - enddo - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - accel(j)=accel(j)+d_a(j,i+nres)-d_a_old(j,i+nres) - enddo - endif - do j=1,3 - if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) - enddo - do j=1,3 - aux(j)=aux(j)+d_a(j,i)-d_a_old(j,i) - enddo - enddo - return - end -c--------------------------------------------------------------------- - subroutine predict_edrift(epdrift) -c -c Predict the drift of the potential energy -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.MUCA' - double precision epdrift,epdriftij -c Drift of the potential energy - epdrift=0.0d0 - do i=nnt,nct -c Backbone - if (i.lt.nct) then - do j=1,3 - epdriftij=dabs((d_a(j,i)-d_a_old(j,i))*gcart(j,i)) - if (lmuca) epdriftij=epdriftij*factor -c write (iout,*) "back",i,j,epdriftij - if (epdriftij.gt.epdrift) epdrift=epdriftij - enddo - endif -c Side chains - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - epdriftij= - & dabs((d_a(j,i+nres)-d_a_old(j,i+nres))*gxcart(j,i)) - if (lmuca) epdriftij=epdriftij*factor -c write (iout,*) "side",i,j,epdriftij - if (epdriftij.gt.epdrift) epdrift=epdriftij - enddo - endif - enddo - epdrift=0.5d0*epdrift*d_time*d_time -c write (iout,*) "epdrift",epdrift - return - end -c----------------------------------------------------------------------- - subroutine verlet_bath -c -c Coupling to the thermostat by using the Berendsen algorithm -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision T_half,fact -c - T_half=2.0d0/(dimen*Rb)*EK - fact=dsqrt(1.0d0+(d_time/tau_bath)*(t_bath/T_half-1.0d0)) -c write(iout,*) "T_half", T_half -c write(iout,*) "EK", EK -c write(iout,*) "fact", fact - do j=1,3 - d_t(j,0)=fact*d_t(j,0) - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=fact*d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=fact*d_t(j,inres) - enddo - endif - enddo - return - end -c--------------------------------------------------------- - subroutine init_MD -c Set up the initial conditions of a MD simulation - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MP - include 'mpif.h' - include 'COMMON.SETUP' - character*16 form -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.REMD' - real*8 energia_long(0:n_ene), - & energia_short(0:n_ene),vcm(3),incr(3) - double precision cm(3),L(3),xv,sigv,lowb,highb - double precision varia(maxvar) - character*256 qstr - integer ilen - external ilen - character*50 tytul - logical file_exist - common /gucio/ cm - d_time0=d_time -c write(iout,*) "d_time", d_time -c Compute the standard deviations of stochastic forces for Langevin dynamics -c if the friction coefficients do not depend on surface area - if (lang.gt.0 .and. .not.surfarea) then - do i=nnt,nct-1 - stdforcp(i)=stdfp*dsqrt(gamp) - enddo - do i=nnt,nct - stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamsc(iabs(itype(i)))) - enddo - endif -c Open the pdb file for snapshotshots -#ifdef MPI - if(mdpdb) then - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".pdb") - open(ipdb, - & file=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".pdb") - else -#ifdef NOXDR - if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".x") - cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".x" -#else - if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".cx") - cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".cx" -#endif - endif -#else - if(mdpdb) then - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.pdb") - open(ipdb,file=prefix(:ilen(prefix))//"_MD.pdb") - else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.cx") - cartname=prefix(:ilen(prefix))//"_MD.cx" - endif -#endif - if (usampl) then - write (qstr,'(256(1h ))') - ipos=1 - do i=1,nfrag - iq = qinfrag(i,iset)*10 - iw = wfrag(i,iset)/100 - if (iw.gt.0) then - if(me.eq.king.or..not.out1file) - & write (iout,*) "Frag",qinfrag(i,iset),wfrag(i,iset),iq,iw - write (qstr(ipos:ipos+6),'(2h_f,i1,1h_,i1,1h_,i1)') i,iq,iw - ipos=ipos+7 - endif - enddo - do i=1,npair - iq = qinpair(i,iset)*10 - iw = wpair(i,iset)/100 - if (iw.gt.0) then - if(me.eq.king.or..not.out1file) - & write (iout,*) "Pair",i,qinpair(i,iset),wpair(i,iset),iq,iw - write (qstr(ipos:ipos+6),'(2h_p,i1,1h_,i1,1h_,i1)') i,iq,iw - ipos=ipos+7 - endif - enddo -c pdbname=pdbname(:ilen(pdbname)-4)//qstr(:ipos-1)//'.pdb' -#ifdef NOXDR -c cartname=cartname(:ilen(cartname)-2)//qstr(:ipos-1)//'.x' -#else -c cartname=cartname(:ilen(cartname)-3)//qstr(:ipos-1)//'.cx' -#endif -c statname=statname(:ilen(statname)-5)//qstr(:ipos-1)//'.stat' - endif - icg=1 - if (rest) then - if (restart1file) then - if (me.eq.king) - & inquire(file=mremd_rst_name,exist=file_exist) - write (*,*) me," Before broadcast: file_exist",file_exist - call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM, - & IERR) - write (*,*) me," After broadcast: file_exist",file_exist -c inquire(file=mremd_rst_name,exist=file_exist) - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial state read by master and distributed" - else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_' - & //liczba(:ilen(liczba))//'.rst') - inquire(file=rest2name,exist=file_exist) - endif - if(file_exist) then - if(.not.restart1file) then - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial state will be read from file ", - & rest2name(:ilen(rest2name)) - call readrst - endif - call rescale_weights(t_bath) - else - if(me.eq.king.or..not.out1file)then - if (restart1file) then - write(iout,*) "File ",mremd_rst_name(:ilen(mremd_rst_name)), - & " does not exist" - else - write(iout,*) "File ",rest2name(:ilen(rest2name)), - & " does not exist" - endif - write(iout,*) "Initial velocities randomly generated" - endif - call random_vel - totT=0.0d0 - endif - else -c Generate initial velocities - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial velocities randomly generated" - call random_vel - totT=0.0d0 - endif -c rest2name = prefix(:ilen(prefix))//'.rst' - if(me.eq.king.or..not.out1file)then - write(iout,*) "Initial backbone velocities" - do i=nnt,nct-1 - write(iout,*) (d_t(j,i),j=1,3) - enddo - write(iout,*) "Initial side-chain velocities" - do i=nnt,nct - write(iout,*) (d_t(j,i+nres),j=1,3) - enddo -c Zeroing the total angular momentum of the system - write(iout,*) "Calling the zero-angular - & momentum subroutine" - endif - call inertia_tensor -c Getting the potential energy and forces and velocities and accelerations - call vcm_vel(vcm) -c write (iout,*) "velocity of the center of the mass:" -c write (iout,*) (vcm(j),j=1,3) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo -c Removing the velocity of the center of mass - call vcm_vel(vcm) - if(me.eq.king.or..not.out1file)then - write (iout,*) "vcm right after adjustment:" - write (iout,*) (vcm(j),j=1,3) - endif - if (.not.rest) then - call chainbuild - if(iranconf.ne.0) then - if (overlapsc) then - print *, 'Calling OVERLAP_SC' - call overlap_sc(fail) - endif - - if (searchsc) then - call sc_move(2,nres-1,10,1d10,nft_sc,etot) - print *,'SC_move',nft_sc,etot - if(me.eq.king.or..not.out1file) - & write(iout,*) 'SC_move',nft_sc,etot - endif - - if(dccart)then - print *, 'Calling MINIM_DC' - call minim_dc(etot,iretcode,nfun) - else - call geom_to_var(nvar,varia) - print *,'Calling MINIMIZE.' - call minimize(etot,varia,iretcode,nfun) - call var_to_geom(nvar,varia) - endif - if(me.eq.king.or..not.out1file) - & write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun - endif - endif - call chainbuild_cart - call kinetic(EK) - if (tbf) then - call verlet_bath(EK) - endif - kinetic_T=2.0d0/(dimen*Rb)*EK - if(me.eq.king.or..not.out1file)then - call cartprint - call intout - endif - call zerograd - call etotal(potEcomp) - potE=potEcomp(0) - call cartgrad - call lagrangian - call max_accel - if (amax*d_time .gt. dvmax) d_time=d_time*dvmax/amax - if(me.eq.king.or..not.out1file)then - write(iout,*) "Potential energy and its components" - write(iout,*) (potEcomp(i),i=0,n_ene) - endif - potE=potEcomp(0)-potEcomp(20) - totE=EK+potE - itime=0 - if (ntwe.ne.0) call statout(itime) - if(me.eq.king.or..not.out1file) - & write (iout,*) "Initial:", - & " Kinetic energy",EK," potential energy",potE, - & " total energy",totE," maximum acceleration ", - & amax - if (large) then - write (iout,*) "Initial coordinates" - do i=1,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(c(j,i),j=1,3), - & (c(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial dC" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial velocities" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo -c write (iout,*) "dc_old",i,(dc_old(j,i),j=1,3) - enddo - if (RESPA) then -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_long(energia_long) - if (large) write (iout,*) "energia_long",energia_long(0) - call cartgrad - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c call etotal_short(energia_short) -c write (iout,*) "energia_long",energia_long(0), -c & " energia_short",energia_short(0), -c & " total",energia_long(0)+energia_short(0) - endif - return - end -c----------------------------------------------------------- - subroutine random_vel - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision xv,sigv,lowb,highb -c Generate random velocities from Gaussian distribution of mean 0 and std of KT/m -c First generate velocities in the eigenspace of the G matrix -c write (iout,*) "Calling random_vel" - xv=0.0d0 - do i=1,dimen - sigv=dsqrt((Rb*t_bath)/geigen(i)) - lowb=-5*sigv - highb=5*sigv - d_t_work_new(i)=anorm_distr(xv,sigv,lowb,highb) - enddo -c Ek1=0.0d0 -c do i=1,dimen -c Ek1=Ek1+0.5d0*geigen(i)*d_t_work_new(i)**2 -c enddo -c Transform velocities to UNRES coordinate space - do i=1,dimen - d_t_work(i)=0.0d0 - do j=1,dimen - d_t_work(i)=d_t_work(i)+Gvec(i,j)*d_t_work_new(j) - enddo - enddo -c Transfer to the d_t vector - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - if (itype(i).ne.ntyp1 .and. itype(i+1).ne.ntyp1) then - d_t(j,i)=d_t_work(ind) - else - d_t(j,i)=0.0d0 - endif - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - ind=ind+1 - d_t(j,i+nres)=d_t_work(ind) - enddo - endif - enddo -c call kinetic(EK) -c write (iout,*) "Kinetic energy",Ek,EK1," kinetic temperature", -c & 2.0d0/(dimen*Rb)*EK,2.0d0/(dimen*Rb)*EK1 - return - end -c----------------------------------------------------------- - subroutine sd_verlet_p_setup -c Sets up the parameters of stochastic Verlet algorithm - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision emgdt(MAXRES6), - & pterm,vterm,rho,rhoc,vsig, - & pfric_vec(MAXRES6),vfric_vec(MAXRES6), - & afric_vec(MAXRES6),prand_vec(MAXRES6), - & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6) - logical lprn /.false./ - double precision zero /1.0d-8/, gdt_radius /0.05d0/ - double precision ktm -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c -c AL 8/17/04 Code adapted from tinker -c -c Get the frictional and random terms for stochastic dynamics in the -c eigenspace of mass-scaled UNRES friction matrix -c - do i = 1, dimen - gdt = fricgam(i) * d_time -c -c Stochastic dynamics reduces to simple MD for zero friction -c - if (gdt .le. zero) then - pfric_vec(i) = 1.0d0 - vfric_vec(i) = d_time - afric_vec(i) = 0.5d0 * d_time * d_time - prand_vec(i) = 0.0d0 - vrand_vec1(i) = 0.0d0 - vrand_vec2(i) = 0.0d0 -c -c Analytical expressions when friction coefficient is large -c - else - if (gdt .ge. gdt_radius) then - egdt = dexp(-gdt) - pfric_vec(i) = egdt - vfric_vec(i) = (1.0d0-egdt) / fricgam(i) - afric_vec(i) = (d_time-vfric_vec(i)) / fricgam(i) - pterm = 2.0d0*gdt - 3.0d0 + (4.0d0-egdt)*egdt - vterm = 1.0d0 - egdt**2 - rho = (1.0d0-egdt)**2 / sqrt(pterm*vterm) -c -c Use series expansions when friction coefficient is small -c - else - gdt2 = gdt * gdt - gdt3 = gdt * gdt2 - gdt4 = gdt2 * gdt2 - gdt5 = gdt2 * gdt3 - gdt6 = gdt3 * gdt3 - gdt7 = gdt3 * gdt4 - gdt8 = gdt4 * gdt4 - gdt9 = gdt4 * gdt5 - afric_vec(i) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0 - & - gdt5/120.0d0 + gdt6/720.0d0 - & - gdt7/5040.0d0 + gdt8/40320.0d0 - & - gdt9/362880.0d0) / fricgam(i)**2 - vfric_vec(i) = d_time - fricgam(i)*afric_vec(i) - pfric_vec(i) = 1.0d0 - fricgam(i)*vfric_vec(i) - pterm = 2.0d0*gdt3/3.0d0 - gdt4/2.0d0 - & + 7.0d0*gdt5/30.0d0 - gdt6/12.0d0 - & + 31.0d0*gdt7/1260.0d0 - gdt8/160.0d0 - & + 127.0d0*gdt9/90720.0d0 - vterm = 2.0d0*gdt - 2.0d0*gdt2 + 4.0d0*gdt3/3.0d0 - & - 2.0d0*gdt4/3.0d0 + 4.0d0*gdt5/15.0d0 - & - 4.0d0*gdt6/45.0d0 + 8.0d0*gdt7/315.0d0 - & - 2.0d0*gdt8/315.0d0 + 4.0d0*gdt9/2835.0d0 - rho = sqrt(3.0d0) * (0.5d0 - 3.0d0*gdt/16.0d0 - & - 17.0d0*gdt2/1280.0d0 - & + 17.0d0*gdt3/6144.0d0 - & + 40967.0d0*gdt4/34406400.0d0 - & - 57203.0d0*gdt5/275251200.0d0 - & - 1429487.0d0*gdt6/13212057600.0d0) - end if -c -c Compute the scaling factors of random terms for the nonzero friction case -c - ktm = 0.5d0*d_time/fricgam(i) - psig = dsqrt(ktm*pterm) / fricgam(i) - vsig = dsqrt(ktm*vterm) - rhoc = dsqrt(1.0d0 - rho*rho) - prand_vec(i) = psig - vrand_vec1(i) = vsig * rho - vrand_vec2(i) = vsig * rhoc - end if - end do - if (lprn) then - write (iout,*) - & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,", - & " vrand_vec2" - do i=1,dimen - write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i), - & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) - enddo - endif -c -c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables -c -#ifndef LANG0 - call eigtransf(dimen,maxres6,mt3,mt2,pfric_vec,pfric_mat) - call eigtransf(dimen,maxres6,mt3,mt2,vfric_vec,vfric_mat) - call eigtransf(dimen,maxres6,mt3,mt2,afric_vec,afric_mat) - call eigtransf(dimen,maxres6,mt3,mt1,prand_vec,prand_mat) - call eigtransf(dimen,maxres6,mt3,mt1,vrand_vec1,vrand_mat1) - call eigtransf(dimen,maxres6,mt3,mt1,vrand_vec2,vrand_mat2) -#endif -c call eigtransf1(dimen,maxres6,mt3mt2,pfric_vec,pfric_mat) -c call eigtransf1(dimen,maxres6,mt3mt2,vfric_vec,vfric_mat) -c call eigtransf1(dimen,maxres6,mt3mt2,afric_vec,afric_mat) -c call eigtransf1(dimen,maxres6,mt3mt1,prand_vec,prand_mat) -c call eigtransf1(dimen,maxres6,mt3mt1,vrand_vec1,vrand_mat1) -c call eigtransf1(dimen,maxres6,mt3mt1,vrand_vec2,vrand_mat2) -#ifdef MPI - t_sdsetup=t_sdsetup+MPI_Wtime() -#else - t_sdsetup=t_sdsetup+tcpu()-tt0 -#endif - return - end -c------------------------------------------------------------- - subroutine eigtransf1(n,ndim,ab,d,c) - implicit none - integer n,ndim - double precision ab(ndim,ndim,n),c(ndim,n),d(ndim) - integer i,j,k - do i=1,n - do j=1,n - c(i,j)=0.0d0 - do k=1,n - c(i,j)=c(i,j)+ab(k,j,i)*d(k) - enddo - enddo - enddo - return - end -c------------------------------------------------------------- - subroutine eigtransf(n,ndim,a,b,d,c) - implicit none - integer n,ndim - double precision a(ndim,n),b(ndim,n),c(ndim,n),d(ndim) - integer i,j,k - do i=1,n - do j=1,n - c(i,j)=0.0d0 - do k=1,n - c(i,j)=c(i,j)+a(i,k)*b(k,j)*d(k) - enddo - enddo - enddo - return - end -c------------------------------------------------------------- - subroutine sd_verlet1 -c Applying stochastic velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - logical lprn /.false./ - -c write (iout,*) "dc_old" -c do i=0,nres -c write (iout,'(i5,3f10.5,5x,3f10.5)') -c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) -c enddo - do j=1,3 - dc_work(j)=dc_old(j,0) - d_t_work(j)=d_t_old(j,0) - d_a_work(j)=d_a_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc_work(ind+j)=dc_old(j,i) - d_t_work(ind+j)=d_t_old(j,i) - d_a_work(ind+j)=d_a_old(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - dc_work(ind+j)=dc_old(j,i+nres) - d_t_work(ind+j)=d_t_old(j,i+nres) - d_a_work(ind+j)=d_a_old(j,i+nres) - enddo - ind=ind+3 - endif - enddo -#ifndef LANG0 - if (lprn) then - write (iout,*) - & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,", - & " vrand_mat2" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j), - & vfric_mat(i,j),afric_mat(i,j), - & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) - enddo - enddo - endif - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) - & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) - ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) - ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) - enddo - d_t_work_new(i)=ddt1+0.5d0*ddt2 - d_t_work(i)=ddt1+ddt2 - enddo -#endif - do j=1,3 - dc(j,0)=dc_work(j) - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_work(ind+j) - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_work(ind+j) - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c-------------------------------------------------------------------------- - subroutine sd_verlet2 -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute the stochastic forces which contribute to velocity change -c - call stochastic_force(stochforcvecV) - -#ifndef LANG0 - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) - ddt2=ddt2+vrand_mat1(i,j)*stochforcvec(j)+ - & vrand_mat2(i,j)*stochforcvecV(j) - enddo - d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 - enddo -#endif - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c----------------------------------------------------------- - subroutine sd_verlet_ciccotti_setup -c Sets up the parameters of stochastic velocity Verlet algorithmi; Ciccotti's -c version - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision emgdt(MAXRES6), - & pterm,vterm,rho,rhoc,vsig, - & pfric_vec(MAXRES6),vfric_vec(MAXRES6), - & afric_vec(MAXRES6),prand_vec(MAXRES6), - & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6) - logical lprn /.false./ - double precision zero /1.0d-8/, gdt_radius /0.05d0/ - double precision ktm -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c -c AL 8/17/04 Code adapted from tinker -c -c Get the frictional and random terms for stochastic dynamics in the -c eigenspace of mass-scaled UNRES friction matrix -c - do i = 1, dimen - write (iout,*) "i",i," fricgam",fricgam(i) - gdt = fricgam(i) * d_time -c -c Stochastic dynamics reduces to simple MD for zero friction -c - if (gdt .le. zero) then - pfric_vec(i) = 1.0d0 - vfric_vec(i) = d_time - afric_vec(i) = 0.5d0*d_time*d_time - prand_vec(i) = afric_vec(i) - vrand_vec2(i) = vfric_vec(i) -c -c Analytical expressions when friction coefficient is large -c - else - egdt = dexp(-gdt) - pfric_vec(i) = egdt - vfric_vec(i) = dexp(-0.5d0*gdt)*d_time - afric_vec(i) = 0.5d0*dexp(-0.25d0*gdt)*d_time*d_time - prand_vec(i) = afric_vec(i) - vrand_vec2(i) = vfric_vec(i) -c -c Compute the scaling factors of random terms for the nonzero friction case -c -c ktm = 0.5d0*d_time/fricgam(i) -c psig = dsqrt(ktm*pterm) / fricgam(i) -c vsig = dsqrt(ktm*vterm) -c prand_vec(i) = psig*afric_vec(i) -c vrand_vec2(i) = vsig*vfric_vec(i) - end if - end do - if (lprn) then - write (iout,*) - & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,", - & " vrand_vec2" - do i=1,dimen - write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i), - & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) - enddo - endif -c -c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables -c - call eigtransf(dimen,maxres6,mt3,mt2,pfric_vec,pfric_mat) - call eigtransf(dimen,maxres6,mt3,mt2,vfric_vec,vfric_mat) - call eigtransf(dimen,maxres6,mt3,mt2,afric_vec,afric_mat) - call eigtransf(dimen,maxres6,mt3,mt1,prand_vec,prand_mat) - call eigtransf(dimen,maxres6,mt3,mt1,vrand_vec2,vrand_mat2) -#ifdef MPI - t_sdsetup=t_sdsetup+MPI_Wtime() -#else - t_sdsetup=t_sdsetup+tcpu()-tt0 -#endif - return - end -c------------------------------------------------------------- - subroutine sd_verlet1_ciccotti -c Applying stochastic velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - logical lprn /.false./ - -c write (iout,*) "dc_old" -c do i=0,nres -c write (iout,'(i5,3f10.5,5x,3f10.5)') -c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) -c enddo - do j=1,3 - dc_work(j)=dc_old(j,0) - d_t_work(j)=d_t_old(j,0) - d_a_work(j)=d_a_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc_work(ind+j)=dc_old(j,i) - d_t_work(ind+j)=d_t_old(j,i) - d_a_work(ind+j)=d_a_old(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - dc_work(ind+j)=dc_old(j,i+nres) - d_t_work(ind+j)=d_t_old(j,i+nres) - d_a_work(ind+j)=d_a_old(j,i+nres) - enddo - ind=ind+3 - endif - enddo - -#ifndef LANG0 - if (lprn) then - write (iout,*) - & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,", - & " vrand_mat2" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j), - & vfric_mat(i,j),afric_mat(i,j), - & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) - enddo - enddo - endif - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) - & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) - ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) - ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) - enddo - d_t_work_new(i)=ddt1+0.5d0*ddt2 - d_t_work(i)=ddt1+ddt2 - enddo -#endif - do j=1,3 - dc(j,0)=dc_work(j) - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_work(ind+j) - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_work(ind+j) - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c-------------------------------------------------------------------------- - subroutine sd_verlet2_ciccotti -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute the stochastic forces which contribute to velocity change -c - call stochastic_force(stochforcvecV) -#ifndef LANG0 - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - - ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) -c ddt2=ddt2+vrand_mat2(i,j)*stochforcvecV(j) - ddt2=ddt2+vrand_mat2(i,j)*stochforcvec(j) - enddo - d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 - enddo -#endif - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end diff --git a/source/unres/src_MD-M-newcorr/MD_A-MTS.F b/source/unres/src_MD-M-newcorr/MD_A-MTS.F deleted file mode 100644 index e0c1cfb..0000000 --- a/source/unres/src_MD-M-newcorr/MD_A-MTS.F +++ /dev/null @@ -1,2446 +0,0 @@ - subroutine MD -c------------------------------------------------ -c The driver for molecular dynamics subroutines -c------------------------------------------------ - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" - integer IERROR,ERRCODE -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - include 'COMMON.HAIRPIN' - double precision cm(3),L(3),vcm(3) -#ifdef VOUT - double precision v_work(maxres6),v_transf(maxres6) -#endif - integer ilen,rstcount - external ilen - character*50 tytul - common /gucio/ cm - integer itime - logical ovrtim -c -#ifdef MPI - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_" - & //liczba(:ilen(liczba))//'.rst') -#else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_"//'.rst') -#endif - t_MDsetup=0.0d0 - t_langsetup=0.0d0 - t_MD=0.0d0 - t_enegrad=0.0d0 - t_sdsetup=0.0d0 - write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" -#ifdef MPI - tt0=MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Determine the inverse of the inertia matrix. - call setup_MD_matrices -c Initialize MD - call init_MD -#ifdef MPI - t_MDsetup = MPI_Wtime()-tt0 -#else - t_MDsetup = tcpu()-tt0 -#endif - rstcount=0 -c Entering the MD loop -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif -#ifdef MPI - t_langsetup=MPI_Wtime()-tt0 - tt0=MPI_Wtime() -#else - t_langsetup=tcpu()-tt0 - tt0=tcpu() -#endif - do itime=1,n_timestep - if (ovrtim()) exit - if (large.and. mod(itime,ntwe).eq.0) - & write (iout,*) "itime",itime - rstcount=rstcount+1 - if (lang.gt.0 .and. surfarea .and. - & mod(itime,reset_fricmat).eq.0) then - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - write (iout,'(a,i10)') - & "Friction matrix reset based on surface area, itime",itime - endif - if (reset_vel .and. tbf .and. lang.eq.0 - & .and. mod(itime,count_reset_vel).eq.0) then - call random_vel - write(iout,'(a,f20.2)') - & "Velocities reset to random values, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - endif - if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then - call inertia_tensor - call vcm_vel(vcm) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen3*Rb)*EK - scalfac=dsqrt(T_bath/kinetic_T) - write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=scalfac*d_t(j,i) - enddo - enddo - endif - if (lang.ne.4) then - if (RESPA) then -c Time-reversible RESPA algorithm -c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) - call RESPA_step(itime) - else -c Variable time step algorithm. - call velverlet_step(itime) - endif - else -#ifdef BROWN - call brown_step(itime) -#else - print *,"Brown dynamics not here!" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) call statout(itime) -#ifdef VOUT - do j=1,3 - v_work(j)=d_t(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - v_work(ind)=d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - ind=ind+1 - v_work(ind)=d_t(j,i+nres) - enddo - endif - enddo - - write (66,'(80f10.5)') - & ((d_t(j,i),j=1,3),i=0,nres-1),((d_t(j,i+nres),j=1,3),i=1,nres) - do i=1,ind - v_transf(i)=0.0d0 - do j=1,ind - v_transf(i)=v_transf(i)+gvec(j,i)*v_work(j) - enddo - v_transf(i)= v_transf(i)*dsqrt(geigen(i)) - enddo - write (67,'(80f10.5)') (v_transf(i),i=1,ind) -#endif - endif - if (mod(itime,ntwx).eq.0) then - write (tytul,'("time",f8.2)') totT - if(mdpdb) then - call check_ecartint - call hairpin(.true.,nharp,iharp) - call secondary2(.true.) - call pdbout(potE,tytul,ipdb) - else - call cartout(totT) - endif - endif - if (rstcount.eq.1000.or.itime.eq.n_timestep) then - open(irest2,file=rest2name,status='unknown') - write(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - write (irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - close(irest2) - rstcount=0 - endif - enddo -#ifdef MPI - t_MD=MPI_Wtime()-tt0 -#else - t_MD=tcpu()-tt0 -#endif - write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') - & ' Timing ', - & 'MD calculations setup:',t_MDsetup, - & 'Energy & gradient evaluation:',t_enegrad, - & 'Stochastic MD setup:',t_langsetup, - & 'Stochastic MD step setup:',t_sdsetup, - & 'MD steps:',t_MD - write (iout,'(/28(1h=),a25,27(1h=))') - & ' End of MD calculation ' -#ifdef TIMING_ENE - write (iout,*) "time for etotal",t_etotal," elong",t_elong, - & " eshort",t_eshort - write (iout,*) "time_fric",time_fric," time_stoch",time_stoch, - & " time_fricmatmult",time_fricmatmult," time_fsample ", - & time_fsample -#endif - return - end -c------------------------------------------------------------------------------- - subroutine velverlet_step(itime) -c------------------------------------------------------------------------------- -c Perform a single velocity Verlet step; the time step can be rescaled if -c increments in accelerations exceed the threshold -c------------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer ierror,ierrcode -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - include 'COMMON.MUCA' - double precision vcm(3),incr(3) - double precision cm(3),L(3) - integer ilen,count,rstcount - external ilen - character*50 tytul - integer maxcount_scale /20/ - common /gucio/ cm - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - integer itime - logical scale -c - scale=.true. - icount_scale=0 - if (lang.eq.1) then - call sddir_precalc - else if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call stochastic_force(stochforcvec) -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - itime_scal=0 - do while (scale) - icount_scale=icount_scale+1 - if (icount_scale.gt.maxcount_scale) then - write (iout,*) - & "ERROR: too many attempts at scaling down the time step. ", - & "amax=",amax,"epdrift=",epdrift, - & "damax=",damax,"edriftmax=",edriftmax, - & "d_time=",d_time - call flush(iout) -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,IERRCODE) -#endif - stop - endif -c First step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet1 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet1_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet1 - else - call verlet1 - endif -c Build the chain from the newly calculated coordinates - call chainbuild_cart - if (rattle) call rattle1 - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "Cartesian and internal coordinates: step 1" - call cartprint - call intout - write (iout,*) "dC" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo - write (iout,*) "Accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 1" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Calculate energy and forces - call zerograd - call etotal(potEcomp) - if (large.and. mod(itime,ntwe).eq.0) - & call enerprint(potEcomp) -#ifdef TIMING_ENE -#ifdef MPI - t_etotal=t_etotal+MPI_Wtime()-tt0 -#else - t_etotal=t_etotal+tcpu()-tt0 -#endif -#endif - potE=potEcomp(0)-potEcomp(20) - call cartgrad -c Get the new accelerations - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Determine maximum acceleration and scale down the timestep if needed - call max_accel - amax=amax/(itime_scal+1)**2 - call predict_edrift(epdrift) - if (amax/(itime_scal+1).gt.damax .or. epdrift.gt.edriftmax) then -c Maximum acceleration or maximum predicted energy drift exceeded, rescale the time step - scale=.true. - ifac_time=dmax1(dlog(amax/damax),dlog(epdrift/edriftmax)) - & /dlog(2.0d0)+1 - itime_scal=itime_scal+ifac_time -c fac_time=dmin1(damax/amax,0.5d0) - fac_time=0.5d0**ifac_time - d_time=d_time*fac_time - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 -c write (iout,*) "Calling sd_verlet_setup: 1" -c Rescale the stochastic forces and recalculate or restore -c the matrices of tinker integrator - if (itime_scal.gt.maxflag_stoch) then - if (large) write (iout,'(a,i5,a)') - & "Calculate matrices for stochastic step;", - & " itime_scal ",itime_scal - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - write (iout,'(2a,i3,a,i3,1h.)') - & "Warning: cannot store matrices for stochastic", - & " integration because the index",itime_scal, - & " is greater than",maxflag_stoch - write (iout,'(2a)')"Increase MAXFLAG_STOCH or use direct", - & " integration Langevin algorithm for better efficiency." - else if (flag_stoch(itime_scal)) then - if (large) write (iout,'(a,i5,a,l1)') - & "Restore matrices for stochastic step; itime_scal ", - & itime_scal," flag ",flag_stoch(itime_scal) - do i=1,dimen - do j=1,dimen - pfric_mat(i,j)=pfric0_mat(i,j,itime_scal) - afric_mat(i,j)=afric0_mat(i,j,itime_scal) - vfric_mat(i,j)=vfric0_mat(i,j,itime_scal) - prand_mat(i,j)=prand0_mat(i,j,itime_scal) - vrand_mat1(i,j)=vrand0_mat1(i,j,itime_scal) - vrand_mat2(i,j)=vrand0_mat2(i,j,itime_scal) - enddo - enddo - else - if (large) write (iout,'(2a,i5,a,l1)') - & "Calculate & store matrices for stochastic step;", - & " itime_scal ",itime_scal," flag ",flag_stoch(itime_scal) - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - flag_stoch(ifac_time)=.true. - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,itime_scal)=pfric_mat(i,j) - afric0_mat(i,j,itime_scal)=afric_mat(i,j) - vfric0_mat(i,j,itime_scal)=vfric_mat(i,j) - prand0_mat(i,j,itime_scal)=prand_mat(i,j) - vrand0_mat1(i,j,itime_scal)=vrand_mat1(i,j) - vrand0_mat2(i,j,itime_scal)=vrand_mat2(i,j) - enddo - enddo - endif - fac_time=1.0d0/dsqrt(fac_time) - do i=1,dimen - stochforcvec(i)=fac_time*stochforcvec(i) - enddo -#endif - else if (lang.eq.1) then -c Rescale the accelerations due to stochastic forces - fac_time=1.0d0/dsqrt(fac_time) - do i=1,dimen - d_as_work(i)=d_as_work(i)*fac_time - enddo - endif - if (large) write (iout,'(a,i10,a,f8.6,a,i3,a,i3)') - & "itime",itime," Timestep scaled down to ", - & d_time," ifac_time",ifac_time," itime_scal",itime_scal - else -c Second step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet2 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet2_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet2 - else - call verlet2 - endif - if (rattle) call rattle2 - totT=totT+d_time - if (d_time.ne.d_time0) then - d_time=d_time0 -#ifndef LANG0 - if (lang.eq.2 .or. lang.eq.3) then - if (large) write (iout,'(a)') - & "Restore original matrices for stochastic step" -c write (iout,*) "Calling sd_verlet_setup: 2" -c Restore the matrices of tinker integrator if the time step has been restored - do i=1,dimen - do j=1,dimen - pfric_mat(i,j)=pfric0_mat(i,j,0) - afric_mat(i,j)=afric0_mat(i,j,0) - vfric_mat(i,j)=vfric0_mat(i,j,0) - prand_mat(i,j)=prand0_mat(i,j,0) - vrand_mat1(i,j)=vrand0_mat1(i,j,0) - vrand_mat2(i,j)=vrand0_mat2(i,j,0) - enddo - enddo - endif -#endif - endif - scale=.false. - endif - enddo -c Calculate the kinetic and the total energy and the kinetic temperature - call kinetic(EK) - totE=EK+potE -c diagnostics -c call kinetic1(EK1) -c write (iout,*) "step",itime," EK",EK," EK1",EK1 -c end diagnostics -c Couple the system to Berendsen bath if needed - if (tbf .and. lang.eq.0) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK -c Backup the coordinates, velocities, and accelerations - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, step 2" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif - return - end -c------------------------------------------------------------------------------- - subroutine RESPA_step(itime) -c------------------------------------------------------------------------------- -c Perform a single RESPA step. -c------------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer IERROR,ERRCODE -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision energia_short(0:n_ene), - & energia_long(0:n_ene) - double precision cm(3),L(3),vcm(3),incr(3) - double precision dc_old0(3,0:maxres2),d_t_old0(3,0:maxres2), - & d_a_old0(3,0:maxres2) - logical PRINT_AMTS_MSG /.false./ - integer ilen,count,rstcount - external ilen - character*50 tytul - integer maxcount_scale /10/ - common /gucio/ cm - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - integer itime - logical scale - common /cipiszcze/ itt - itt=itime - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "***************** RESPA itime",itime - write (iout,*) "Cartesian and internal coordinates: step 0" -c call cartprint - call pdbout(0.0d0,"cipiszcze",iout) - call intout - write (iout,*) "Accelerations from long-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 0" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c -c Perform the initial RESPA step (increment velocities) -c write (iout,*) "*********************** RESPA ini" - call RESPA_vel - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, end" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c Compute the short-range forces -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif -C 7/2/2009 commented out -c call zerograd -c call etotal_short(energia_short) -c call cartgrad -c call lagrangian -C 7/2/2009 Copy accelerations due to short-lange forces from previous MD step - do i=0,2*nres - do j=1,3 - d_a(j,i)=d_a_short(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "energia_short",energia_short(0) - write (iout,*) "Accelerations from short-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo -c 6/30/08 A-MTS: attempt at increasing the split number - do i=0,2*nres - do j=1,3 - dc_old0(j,i)=dc_old(j,i) - d_t_old0(j,i)=d_t_old(j,i) - d_a_old0(j,i)=d_a_old(j,i) - enddo - enddo - if (ntime_split.gt.ntime_split0) ntime_split=ntime_split/2 - if (ntime_split.lt.ntime_split0) ntime_split=ntime_split0 -c - scale=.true. - d_time0=d_time - do while (scale) - - scale=.false. -c write (iout,*) "itime",itime," ntime_split",ntime_split -c Split the time step - d_time=d_time0/ntime_split -c Perform the short-range RESPA steps (velocity Verlet increments of -c positions and velocities using short-range forces) -c write (iout,*) "*********************** RESPA split" - do itsplit=1,ntime_split - if (lang.eq.1) then - call sddir_precalc - else if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call stochastic_force(stochforcvec) -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif -c First step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet1 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet1_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet1 - else - call verlet1 - endif -c Build the chain from the newly calculated coordinates - call chainbuild_cart - if (rattle) call rattle1 - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "***** ITSPLIT",itsplit - write (iout,*) "Cartesian and internal coordinates: step 1" - call pdbout(0.0d0,"cipiszcze",iout) -c call cartprint - call intout - write (iout,*) "Velocities, step 1" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Calculate energy and forces - call zerograd - call etotal_short(energia_short) - if (large.and. mod(itime,ntwe).eq.0) - & call enerprint(energia_short) -#ifdef TIMING_ENE -#ifdef MPI - t_eshort=t_eshort+MPI_Wtime()-tt0 -#else - t_eshort=t_eshort+tcpu()-tt0 -#endif -#endif - call cartgrad -c Get the new accelerations - call lagrangian -C 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array - do i=0,2*nres - do j=1,3 - d_a_short(j,i)=d_a(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*)"energia_short",energia_short(0) - write (iout,*) "Accelerations from short-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - endif -c 6/30/08 A-MTS -c Determine maximum acceleration and scale down the timestep if needed - call max_accel - amax=amax/ntime_split**2 - call predict_edrift(epdrift) - if (ntwe.gt.0 .and. large .and. mod(itime,ntwe).eq.0) - & write (iout,*) "amax",amax," damax",damax, - & " epdrift",epdrift," epdriftmax",epdriftmax -c Exit loop and try with increased split number if the change of -c acceleration is too big - if (amax.gt.damax .or. epdrift.gt.edriftmax) then - if (ntime_split.lt.maxtime_split) then - scale=.true. - ntime_split=ntime_split*2 - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc_old0(j,i) - d_t_old(j,i)=d_t_old0(j,i) - d_a_old(j,i)=d_a_old0(j,i) - enddo - enddo - if (PRINT_AMTS_MSG) then - write (iout,*) "acceleration/energy drift too large",amax, - & epdrift," split increased to ",ntime_split," itime",itime, - & " itsplit",itsplit - endif - exit - else - write (iout,*) - & "Uh-hu. Bumpy landscape. Maximum splitting number", - & maxtime_split, - & " already reached!!! Trying to carry on!" - endif - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Second step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet2 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet2_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet2 - else - call verlet2 - endif - if (rattle) call rattle2 -c Backup the coordinates, velocities, and accelerations - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - enddo - - enddo ! while scale - -c Restore the time step - d_time=d_time0 -c Compute long-range forces -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_long(energia_long) - if (large.and. mod(itime,ntwe).eq.0) - & call enerprint(energia_long) -#ifdef TIMING_ENE -#ifdef MPI - t_elong=t_elong+MPI_Wtime()-tt0 -#else - t_elong=t_elong+tcpu()-tt0 -#endif -#endif - call cartgrad - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Compute accelerations from long-range forces - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "energia_long",energia_long(0) - write (iout,*) "Cartesian and internal coordinates: step 2" -c call cartprint - call pdbout(0.0d0,"cipiszcze",iout) - call intout - write (iout,*) "Accelerations from long-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 2" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c Compute the final RESPA step (increment velocities) -c write (iout,*) "*********************** RESPA fin" - call RESPA_vel -c Compute the complete potential energy - do i=0,n_ene - potEcomp(i)=energia_short(i)+energia_long(i) - enddo - potE=potEcomp(0)-potEcomp(20) -c potE=energia_short(0)+energia_long(0) - totT=totT+d_time -c Calculate the kinetic and the total energy and the kinetic temperature - call kinetic(EK) - totE=EK+potE -c Couple the system to Berendsen bath if needed - if (tbf .and. lang.eq.0) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK -c Backup the coordinates, velocities, and accelerations - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, end" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif - return - end -c--------------------------------------------------------------------- - subroutine RESPA_vel -c First and last RESPA step (incrementing velocities using long-range -c forces). - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - do j=1,3 - d_t(j,0)=d_t(j,0)+0.5d0*d_a(j,0)*d_time - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t(j,i)+0.5d0*d_a(j,i)*d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t(j,inres)+0.5d0*d_a(j,inres)*d_time - enddo - endif - enddo - return - end -c----------------------------------------------------------------- - subroutine verlet1 -c Applying velocity Verlet algorithm - step 1 to coordinates - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision adt,adt2 - -#ifdef DEBUG - write (iout,*) "VELVERLET1 START: DC" - do i=0,nres - write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo -#endif - do j=1,3 - adt=d_a_old(j,0)*d_time - adt2=0.5d0*adt - dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time - d_t_new(j,0)=d_t_old(j,0)+adt2 - d_t(j,0)=d_t_old(j,0)+adt - enddo - do i=nnt,nct-1 - do j=1,3 - adt=d_a_old(j,i)*d_time - adt2=0.5d0*adt - dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time - d_t_new(j,i)=d_t_old(j,i)+adt2 - d_t(j,i)=d_t_old(j,i)+adt - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - adt=d_a_old(j,inres)*d_time - adt2=0.5d0*adt - dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time - d_t_new(j,inres)=d_t_old(j,inres)+adt2 - d_t(j,inres)=d_t_old(j,inres)+adt - enddo - endif - enddo -#ifdef DEBUG - write (iout,*) "VELVERLET1 END: DC" - do i=0,nres - write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo -#endif - return - end -c--------------------------------------------------------------------- - subroutine verlet2 -c Step 2 of the velocity Verlet algorithm: update velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - do j=1,3 - d_t(j,0)=d_t_new(j,0)+0.5d0*d_a(j,0)*d_time - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+0.5d0*d_a(j,i)*d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+0.5d0*d_a(j,inres)*d_time - enddo - endif - enddo - return - end -c----------------------------------------------------------------- - subroutine sddir_precalc -c Applying velocity Verlet algorithm - step 1 to coordinates - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute friction and stochastic forces -c - time00=MPI_Wtime() - call friction_force - time_fric=time_fric+MPI_Wtime()-time00 - time00=MPI_Wtime() - call stochastic_force(stochforcvec) - time_stoch=time_stoch+MPI_Wtime()-time00 -c -c Compute the acceleration due to friction forces (d_af_work) and stochastic -c forces (d_as_work) -c - call ginv_mult(fric_work, d_af_work) - call ginv_mult(stochforcvec, d_as_work) - return - end -c--------------------------------------------------------------------- - subroutine sddir_verlet1 -c Applying velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' -c Revised 3/31/05 AL: correlation between random contributions to -c position and velocity increments included. - double precision sqrt13 /0.57735026918962576451d0/ ! 1/sqrt(3) - double precision adt,adt2 -c -c Add the contribution from BOTH friction and stochastic force to the -c coordinates, but ONLY the contribution from the friction forces to velocities -c - do j=1,3 - adt=(d_a_old(j,0)+d_af_work(j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(j)*d_time - dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time - d_t_new(j,0)=d_t_old(j,0)+0.5d0*adt - d_t(j,0)=d_t_old(j,0)+adt - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - adt=(d_a_old(j,i)+d_af_work(ind+j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time - dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time - d_t_new(j,i)=d_t_old(j,i)+0.5d0*adt - d_t(j,i)=d_t_old(j,i)+adt - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - adt=(d_a_old(j,inres)+d_af_work(ind+j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time - dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time - d_t_new(j,inres)=d_t_old(j,inres)+0.5d0*adt - d_t(j,inres)=d_t_old(j,inres)+adt - enddo - ind=ind+3 - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine sddir_verlet2 -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),d_as_work1(MAXRES6) - double precision cos60 /0.5d0/, sin60 /0.86602540378443864676d0/ -c Revised 3/31/05 AL: correlation between random contributions to -c position and velocity increments included. -c The correlation coefficients are calculated at low-friction limit. -c Also, friction forces are now not calculated with new velocities. - -c call friction_force - call stochastic_force(stochforcvec) -c -c Compute the acceleration due to friction forces (d_af_work) and stochastic -c forces (d_as_work) -c - call ginv_mult(stochforcvec, d_as_work1) - -c -c Update velocities -c - do j=1,3 - d_t(j,0)=d_t_new(j,0)+(0.5d0*(d_a(j,0)+d_af_work(j)) - & +sin60*d_as_work(j)+cos60*d_as_work1(j))*d_time - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+(0.5d0*(d_a(j,i)+d_af_work(ind+j)) - & +sin60*d_as_work(ind+j)+cos60*d_as_work1(ind+j))*d_time - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+(0.5d0*(d_a(j,inres) - & +d_af_work(ind+j))+sin60*d_as_work(ind+j) - & +cos60*d_as_work1(ind+j))*d_time - enddo - ind=ind+3 - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine max_accel -c -c Find the maximum difference in the accelerations of the the sites -c at the beginning and the end of the time step. -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - double precision aux(3),accel(3),accel_old(3),dacc - do j=1,3 -c aux(j)=d_a(j,0)-d_a_old(j,0) - accel_old(j)=d_a_old(j,0) - accel(j)=d_a(j,0) - enddo - amax=0.0d0 - do i=nnt,nct -c Backbone - if (i.lt.nct) then -c 7/3/08 changed to asymmetric difference - do j=1,3 -c accel(j)=aux(j)+0.5d0*(d_a(j,i)-d_a_old(j,i)) - accel_old(j)=accel_old(j)+0.5d0*d_a_old(j,i) - accel(j)=accel(j)+0.5d0*d_a(j,i) -c if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) - if (dabs(accel(j)).gt.dabs(accel_old(j))) then - dacc=dabs(accel(j)-accel_old(j)) -c write (iout,*) i,dacc - if (dacc.gt.amax) amax=dacc - endif - enddo - endif - enddo -c Side chains - do j=1,3 -c accel(j)=aux(j) - accel_old(j)=d_a_old(j,0) - accel(j)=d_a(j,0) - enddo - if (nnt.eq.2) then - do j=1,3 - accel_old(j)=accel_old(j)+d_a_old(j,1) - accel(j)=accel(j)+d_a(j,1) - enddo - endif - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 -c accel(j)=accel(j)+d_a(j,i+nres)-d_a_old(j,i+nres) - accel_old(j)=accel_old(j)+d_a_old(j,i+nres) - accel(j)=accel(j)+d_a(j,i+nres) - enddo - endif - do j=1,3 -c if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) - if (dabs(accel(j)).gt.dabs(accel_old(j))) then - dacc=dabs(accel(j)-accel_old(j)) -c write (iout,*) "side-chain",i,dacc - if (dacc.gt.amax) amax=dacc - endif - enddo - do j=1,3 - accel_old(j)=accel_old(j)+d_a_old(j,i) - accel(j)=accel(j)+d_a(j,i) -c aux(j)=aux(j)+d_a(j,i)-d_a_old(j,i) - enddo - enddo - return - end -c--------------------------------------------------------------------- - subroutine predict_edrift(epdrift) -c -c Predict the drift of the potential energy -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.MUCA' - double precision epdrift,epdriftij -c Drift of the potential energy - epdrift=0.0d0 - do i=nnt,nct -c Backbone - if (i.lt.nct) then - do j=1,3 - epdriftij=dabs((d_a(j,i)-d_a_old(j,i))*gcart(j,i)) - if (lmuca) epdriftij=epdriftij*factor -c write (iout,*) "back",i,j,epdriftij - if (epdriftij.gt.epdrift) epdrift=epdriftij - enddo - endif -c Side chains - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - epdriftij= - & dabs((d_a(j,i+nres)-d_a_old(j,i+nres))*gxcart(j,i)) - if (lmuca) epdriftij=epdriftij*factor -c write (iout,*) "side",i,j,epdriftij - if (epdriftij.gt.epdrift) epdrift=epdriftij - enddo - endif - enddo - epdrift=0.5d0*epdrift*d_time*d_time -c write (iout,*) "epdrift",epdrift - return - end -c----------------------------------------------------------------------- - subroutine verlet_bath -c -c Coupling to the thermostat by using the Berendsen algorithm -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision T_half,fact -c - T_half=2.0d0/(dimen3*Rb)*EK - fact=dsqrt(1.0d0+(d_time/tau_bath)*(t_bath/T_half-1.0d0)) -c write(iout,*) "T_half", T_half -c write(iout,*) "EK", EK -c write(iout,*) "fact", fact - do j=1,3 - d_t(j,0)=fact*d_t(j,0) - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=fact*d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=fact*d_t(j,inres) - enddo - endif - enddo - return - end -c--------------------------------------------------------- - subroutine init_MD -c Set up the initial conditions of a MD simulation - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MP - include 'mpif.h' - character*16 form - integer IERROR,ERRCODE -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.REMD' - real*8 energia_long(0:n_ene), - & energia_short(0:n_ene),vcm(3),incr(3) - double precision cm(3),L(3),xv,sigv,lowb,highb - double precision varia(maxvar) - character*256 qstr - integer ilen - external ilen - character*50 tytul - logical file_exist - common /gucio/ cm - d_time0=d_time -c write(iout,*) "d_time", d_time -c Compute the standard deviations of stochastic forces for Langevin dynamics -c if the friction coefficients do not depend on surface area - if (lang.gt.0 .and. .not.surfarea) then - do i=nnt,nct-1 - stdforcp(i)=stdfp*dsqrt(gamp) - enddo - do i=nnt,nct - stdforcsc(i)=stdfsc(iabs(itype(i))) - & *dsqrt(gamsc(iabs(itype(i)))) - enddo - endif -c Open the pdb file for snapshotshots -#ifdef MPI - if(mdpdb) then - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".pdb") - open(ipdb, - & file=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".pdb") - else -#ifdef NOXDR - if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".x") - cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".x" -#else - if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".cx") - cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".cx" -#endif - endif -#else - if(mdpdb) then - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.pdb") - open(ipdb,file=prefix(:ilen(prefix))//"_MD.pdb") - else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.cx") - cartname=prefix(:ilen(prefix))//"_MD.cx" - endif -#endif - if (usampl) then - write (qstr,'(256(1h ))') - ipos=1 - do i=1,nfrag - iq = qinfrag(i,iset)*10 - iw = wfrag(i,iset)/100 - if (iw.gt.0) then - if(me.eq.king.or..not.out1file) - & write (iout,*) "Frag",qinfrag(i,iset),wfrag(i,iset),iq,iw - write (qstr(ipos:ipos+6),'(2h_f,i1,1h_,i1,1h_,i1)') i,iq,iw - ipos=ipos+7 - endif - enddo - do i=1,npair - iq = qinpair(i,iset)*10 - iw = wpair(i,iset)/100 - if (iw.gt.0) then - if(me.eq.king.or..not.out1file) - & write (iout,*) "Pair",i,qinpair(i,iset),wpair(i,iset),iq,iw - write (qstr(ipos:ipos+6),'(2h_p,i1,1h_,i1,1h_,i1)') i,iq,iw - ipos=ipos+7 - endif - enddo -c pdbname=pdbname(:ilen(pdbname)-4)//qstr(:ipos-1)//'.pdb' -#ifdef NOXDR -c cartname=cartname(:ilen(cartname)-2)//qstr(:ipos-1)//'.x' -#else -c cartname=cartname(:ilen(cartname)-3)//qstr(:ipos-1)//'.cx' -#endif -c statname=statname(:ilen(statname)-5)//qstr(:ipos-1)//'.stat' - endif - icg=1 - if (rest) then - if (restart1file) then - if (me.eq.king) - & inquire(file=mremd_rst_name,exist=file_exist) - write (*,*) me," Before broadcast: file_exist",file_exist - call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM, - & IERR) - write (*,*) me," After broadcast: file_exist",file_exist -c inquire(file=mremd_rst_name,exist=file_exist) - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial state read by master and distributed" - else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_' - & //liczba(:ilen(liczba))//'.rst') - inquire(file=rest2name,exist=file_exist) - endif - if(file_exist) then - if(.not.restart1file) then - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial state will be read from file ", - & rest2name(:ilen(rest2name)) - call readrst - endif - call rescale_weights(t_bath) - else - if(me.eq.king.or..not.out1file)then - if (restart1file) then - write(iout,*) "File ",mremd_rst_name(:ilen(mremd_rst_name)), - & " does not exist" - else - write(iout,*) "File ",rest2name(:ilen(rest2name)), - & " does not exist" - endif - write(iout,*) "Initial velocities randomly generated" - endif - call random_vel - totT=0.0d0 - endif - else -c Generate initial velocities - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial velocities randomly generated" - call random_vel - totT=0.0d0 - endif -c rest2name = prefix(:ilen(prefix))//'.rst' - if(me.eq.king.or..not.out1file)then - write (iout,*) "Initial velocities" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo -c Zeroing the total angular momentum of the system - write(iout,*) "Calling the zero-angular - & momentum subroutine" - endif - call inertia_tensor -c Getting the potential energy and forces and velocities and accelerations - call vcm_vel(vcm) -c write (iout,*) "velocity of the center of the mass:" -c write (iout,*) (vcm(j),j=1,3) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo -c Removing the velocity of the center of mass - call vcm_vel(vcm) - if(me.eq.king.or..not.out1file)then - write (iout,*) "vcm right after adjustment:" - write (iout,*) (vcm(j),j=1,3) - endif - if (.not.rest) then - call chainbuild - if(iranconf.ne.0) then - if (overlapsc) then - print *, 'Calling OVERLAP_SC' - call overlap_sc(fail) - endif - - if (searchsc) then - call sc_move(2,nres-1,10,1d10,nft_sc,etot) - print *,'SC_move',nft_sc,etot - if(me.eq.king.or..not.out1file) - & write(iout,*) 'SC_move',nft_sc,etot - endif - - if(dccart)then - print *, 'Calling MINIM_DC' - call minim_dc(etot,iretcode,nfun) - else - call geom_to_var(nvar,varia) - print *,'Calling MINIMIZE.' - call minimize(etot,varia,iretcode,nfun) - call var_to_geom(nvar,varia) - endif - if(me.eq.king.or..not.out1file) - & write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun - endif - endif - call chainbuild_cart - call kinetic(EK) - if (tbf) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK - if(me.eq.king.or..not.out1file)then - call cartprint - call intout - endif -#ifdef MPI - tt0=MPI_Wtime() -#else - tt0=tcpu() -#endif - call zerograd - call etotal(potEcomp) - if (large) call enerprint(potEcomp) -#ifdef TIMING_ENE -#ifdef MPI - t_etotal=t_etotal+MPI_Wtime()-tt0 -#else - t_etotal=t_etotal+tcpu()-tt0 -#endif -#endif - potE=potEcomp(0) - call cartgrad - call lagrangian - call max_accel - if (amax*d_time .gt. dvmax) then - d_time=d_time*dvmax/amax - if(me.eq.king.or..not.out1file) write (iout,*) - & "Time step reduced to",d_time, - & " because of too large initial acceleration." - endif - if(me.eq.king.or..not.out1file)then - write(iout,*) "Potential energy and its components" - call enerprint(potEcomp) -c write(iout,*) (potEcomp(i),i=0,n_ene) - endif - potE=potEcomp(0)-potEcomp(20) - totE=EK+potE - itime=0 - if (ntwe.ne.0) call statout(itime) - if(me.eq.king.or..not.out1file) - & write (iout,'(/a/3(a25,1pe14.5/))') "Initial:", - & " Kinetic energy",EK," Potential energy",potE, - & " Total energy",totE," Maximum acceleration ", - & amax - if (large) then - write (iout,*) "Initial coordinates" - do i=1,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(c(j,i),j=1,3), - & (c(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial dC" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial velocities" - write (iout,"(13x,' backbone ',23x,' side chain')") - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial accelerations" - do i=0,nres -c write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - write (iout,'(i3,3f15.10,3x,3f15.10)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo -c write (iout,*) "dc_old",i,(dc_old(j,i),j=1,3) - enddo - if (RESPA) then -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_short(energia_short) - if (large) call enerprint(potEcomp) -#ifdef TIMING_ENE -#ifdef MPI - t_eshort=t_eshort+MPI_Wtime()-tt0 -#else - t_eshort=t_eshort+tcpu()-tt0 -#endif -#endif - call cartgrad - call lagrangian - if(.not.out1file .and. large) then - write (iout,*) "energia_long",energia_long(0), - & " energia_short",energia_short(0), - & " total",energia_long(0)+energia_short(0) - write (iout,*) "Initial fast-force accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif -C 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array - do i=0,2*nres - do j=1,3 - d_a_short(j,i)=d_a(j,i) - enddo - enddo -#ifdef MPI - tt0=MPI_Wtime() -#else - tt0=tcpu() -#endif - call zerograd - call etotal_long(energia_long) - if (large) call enerprint(potEcomp) -#ifdef TIMING_ENE -#ifdef MPI - t_elong=t_elong+MPI_Wtime()-tt0 -#else - t_elong=t_elong+tcpu()-tt0 -#endif -#endif - call cartgrad - call lagrangian - if(.not.out1file .and. large) then - write (iout,*) "energia_long",energia_long(0) - write (iout,*) "Initial slow-force accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - endif - return - end -c----------------------------------------------------------- - subroutine random_vel - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision xv,sigv,lowb,highb -c Generate random velocities from Gaussian distribution of mean 0 and std of KT/m -c First generate velocities in the eigenspace of the G matrix -c write (iout,*) "Calling random_vel dimen dimen3",dimen,dimen3 -c call flush(iout) - xv=0.0d0 - ii=0 - do i=1,dimen - do k=1,3 - ii=ii+1 - sigv=dsqrt((Rb*t_bath)/geigen(i)) - lowb=-5*sigv - highb=5*sigv - d_t_work_new(ii)=anorm_distr(xv,sigv,lowb,highb) -c write (iout,*) "i",i," ii",ii," geigen",geigen(i), -c & " d_t_work_new",d_t_work_new(ii) - enddo - enddo -c diagnostics -c Ek1=0.0d0 -c ii=0 -c do i=1,dimen -c do k=1,3 -c ii=ii+1 -c Ek1=Ek1+0.5d0*geigen(i)*d_t_work_new(ii)**2 -c enddo -c enddo -c write (iout,*) "Ek from eigenvectors",Ek1 -c end diagnostics -c Transform velocities to UNRES coordinate space - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - d_t_work(ind)=0.0d0 - do j=1,dimen - d_t_work(ind)=d_t_work(ind) - & +Gvec(i,j)*d_t_work_new((j-1)*3+k+1) - enddo -c write (iout,*) "i",i," ind",ind," d_t_work",d_t_work(ind) -c call flush(iout) - enddo - enddo -c Transfer to the d_t vector - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - d_t(j,i)=d_t_work(ind) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - ind=ind+1 - d_t(j,i+nres)=d_t_work(ind) - enddo - endif - enddo -c call kinetic(EK) -c write (iout,*) "Kinetic energy",Ek,EK1," kinetic temperature", -c & 2.0d0/(dimen3*Rb)*EK,2.0d0/(dimen3*Rb)*EK1 -c call flush(iout) - return - end -#ifndef LANG0 -c----------------------------------------------------------- - subroutine sd_verlet_p_setup -c Sets up the parameters of stochastic Verlet algorithm - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision emgdt(MAXRES6), - & pterm,vterm,rho,rhoc,vsig, - & pfric_vec(MAXRES6),vfric_vec(MAXRES6), - & afric_vec(MAXRES6),prand_vec(MAXRES6), - & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6) - logical lprn /.false./ - double precision zero /1.0d-8/, gdt_radius /0.05d0/ - double precision ktm -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c -c AL 8/17/04 Code adapted from tinker -c -c Get the frictional and random terms for stochastic dynamics in the -c eigenspace of mass-scaled UNRES friction matrix -c - do i = 1, dimen - gdt = fricgam(i) * d_time -c -c Stochastic dynamics reduces to simple MD for zero friction -c - if (gdt .le. zero) then - pfric_vec(i) = 1.0d0 - vfric_vec(i) = d_time - afric_vec(i) = 0.5d0 * d_time * d_time - prand_vec(i) = 0.0d0 - vrand_vec1(i) = 0.0d0 - vrand_vec2(i) = 0.0d0 -c -c Analytical expressions when friction coefficient is large -c - else - if (gdt .ge. gdt_radius) then - egdt = dexp(-gdt) - pfric_vec(i) = egdt - vfric_vec(i) = (1.0d0-egdt) / fricgam(i) - afric_vec(i) = (d_time-vfric_vec(i)) / fricgam(i) - pterm = 2.0d0*gdt - 3.0d0 + (4.0d0-egdt)*egdt - vterm = 1.0d0 - egdt**2 - rho = (1.0d0-egdt)**2 / sqrt(pterm*vterm) -c -c Use series expansions when friction coefficient is small -c - else - gdt2 = gdt * gdt - gdt3 = gdt * gdt2 - gdt4 = gdt2 * gdt2 - gdt5 = gdt2 * gdt3 - gdt6 = gdt3 * gdt3 - gdt7 = gdt3 * gdt4 - gdt8 = gdt4 * gdt4 - gdt9 = gdt4 * gdt5 - afric_vec(i) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0 - & - gdt5/120.0d0 + gdt6/720.0d0 - & - gdt7/5040.0d0 + gdt8/40320.0d0 - & - gdt9/362880.0d0) / fricgam(i)**2 - vfric_vec(i) = d_time - fricgam(i)*afric_vec(i) - pfric_vec(i) = 1.0d0 - fricgam(i)*vfric_vec(i) - pterm = 2.0d0*gdt3/3.0d0 - gdt4/2.0d0 - & + 7.0d0*gdt5/30.0d0 - gdt6/12.0d0 - & + 31.0d0*gdt7/1260.0d0 - gdt8/160.0d0 - & + 127.0d0*gdt9/90720.0d0 - vterm = 2.0d0*gdt - 2.0d0*gdt2 + 4.0d0*gdt3/3.0d0 - & - 2.0d0*gdt4/3.0d0 + 4.0d0*gdt5/15.0d0 - & - 4.0d0*gdt6/45.0d0 + 8.0d0*gdt7/315.0d0 - & - 2.0d0*gdt8/315.0d0 + 4.0d0*gdt9/2835.0d0 - rho = sqrt(3.0d0) * (0.5d0 - 3.0d0*gdt/16.0d0 - & - 17.0d0*gdt2/1280.0d0 - & + 17.0d0*gdt3/6144.0d0 - & + 40967.0d0*gdt4/34406400.0d0 - & - 57203.0d0*gdt5/275251200.0d0 - & - 1429487.0d0*gdt6/13212057600.0d0) - end if -c -c Compute the scaling factors of random terms for the nonzero friction case -c - ktm = 0.5d0*d_time/fricgam(i) - psig = dsqrt(ktm*pterm) / fricgam(i) - vsig = dsqrt(ktm*vterm) - rhoc = dsqrt(1.0d0 - rho*rho) - prand_vec(i) = psig - vrand_vec1(i) = vsig * rho - vrand_vec2(i) = vsig * rhoc - end if - end do - if (lprn) then - write (iout,*) - & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,", - & " vrand_vec2" - do i=1,dimen - write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i), - & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) - enddo - endif -c -c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables -c -#ifndef LANG0 - call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) - call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec1,vrand_mat1) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) -#endif -#ifdef MPI - t_sdsetup=t_sdsetup+MPI_Wtime() -#else - t_sdsetup=t_sdsetup+tcpu()-tt0 -#endif - return - end -c------------------------------------------------------------- - subroutine eigtransf1(n,ndim,ab,d,c) - implicit none - integer n,ndim - double precision ab(ndim,ndim,n),c(ndim,n),d(ndim) - integer i,j,k - do i=1,n - do j=1,n - c(i,j)=0.0d0 - do k=1,n - c(i,j)=c(i,j)+ab(k,j,i)*d(k) - enddo - enddo - enddo - return - end -c------------------------------------------------------------- - subroutine eigtransf(n,ndim,a,b,d,c) - implicit none - integer n,ndim - double precision a(ndim,n),b(ndim,n),c(ndim,n),d(ndim) - integer i,j,k - do i=1,n - do j=1,n - c(i,j)=0.0d0 - do k=1,n - c(i,j)=c(i,j)+a(i,k)*b(k,j)*d(k) - enddo - enddo - enddo - return - end -c------------------------------------------------------------- - subroutine sd_verlet1 -c Applying stochastic velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - logical lprn /.false./ - -c write (iout,*) "dc_old" -c do i=0,nres -c write (iout,'(i5,3f10.5,5x,3f10.5)') -c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) -c enddo - do j=1,3 - dc_work(j)=dc_old(j,0) - d_t_work(j)=d_t_old(j,0) - d_a_work(j)=d_a_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc_work(ind+j)=dc_old(j,i) - d_t_work(ind+j)=d_t_old(j,i) - d_a_work(ind+j)=d_a_old(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - dc_work(ind+j)=dc_old(j,i+nres) - d_t_work(ind+j)=d_t_old(j,i+nres) - d_a_work(ind+j)=d_a_old(j,i+nres) - enddo - ind=ind+3 - endif - enddo -#ifndef LANG0 - if (lprn) then - write (iout,*) - & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,", - & " vrand_mat2" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j), - & vfric_mat(i,j),afric_mat(i,j), - & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) - enddo - enddo - endif - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) - & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) - ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) - ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) - enddo - d_t_work_new(i)=ddt1+0.5d0*ddt2 - d_t_work(i)=ddt1+ddt2 - enddo -#endif - do j=1,3 - dc(j,0)=dc_work(j) - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_work(ind+j) - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_work(ind+j) - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c-------------------------------------------------------------------------- - subroutine sd_verlet2 -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute the stochastic forces which contribute to velocity change -c - call stochastic_force(stochforcvecV) - -#ifndef LANG0 - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) - ddt2=ddt2+vrand_mat1(i,j)*stochforcvec(j)+ - & vrand_mat2(i,j)*stochforcvecV(j) - enddo - d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 - enddo -#endif - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c----------------------------------------------------------- - subroutine sd_verlet_ciccotti_setup -c Sets up the parameters of stochastic velocity Verlet algorithmi; Ciccotti's -c version - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision emgdt(MAXRES6), - & pterm,vterm,rho,rhoc,vsig, - & pfric_vec(MAXRES6),vfric_vec(MAXRES6), - & afric_vec(MAXRES6),prand_vec(MAXRES6), - & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6) - logical lprn /.false./ - double precision zero /1.0d-8/, gdt_radius /0.05d0/ - double precision ktm -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c -c AL 8/17/04 Code adapted from tinker -c -c Get the frictional and random terms for stochastic dynamics in the -c eigenspace of mass-scaled UNRES friction matrix -c - do i = 1, dimen - write (iout,*) "i",i," fricgam",fricgam(i) - gdt = fricgam(i) * d_time -c -c Stochastic dynamics reduces to simple MD for zero friction -c - if (gdt .le. zero) then - pfric_vec(i) = 1.0d0 - vfric_vec(i) = d_time - afric_vec(i) = 0.5d0*d_time*d_time - prand_vec(i) = afric_vec(i) - vrand_vec2(i) = vfric_vec(i) -c -c Analytical expressions when friction coefficient is large -c - else - egdt = dexp(-gdt) - pfric_vec(i) = egdt - vfric_vec(i) = dexp(-0.5d0*gdt)*d_time - afric_vec(i) = 0.5d0*dexp(-0.25d0*gdt)*d_time*d_time - prand_vec(i) = afric_vec(i) - vrand_vec2(i) = vfric_vec(i) -c -c Compute the scaling factors of random terms for the nonzero friction case -c -c ktm = 0.5d0*d_time/fricgam(i) -c psig = dsqrt(ktm*pterm) / fricgam(i) -c vsig = dsqrt(ktm*vterm) -c prand_vec(i) = psig*afric_vec(i) -c vrand_vec2(i) = vsig*vfric_vec(i) - end if - end do - if (lprn) then - write (iout,*) - & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,", - & " vrand_vec2" - do i=1,dimen - write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i), - & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) - enddo - endif -c -c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables -c - call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) - call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) -#ifdef MPI - t_sdsetup=t_sdsetup+MPI_Wtime() -#else - t_sdsetup=t_sdsetup+tcpu()-tt0 -#endif - return - end -c------------------------------------------------------------- - subroutine sd_verlet1_ciccotti -c Applying stochastic velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - logical lprn /.false./ - -c write (iout,*) "dc_old" -c do i=0,nres -c write (iout,'(i5,3f10.5,5x,3f10.5)') -c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) -c enddo - do j=1,3 - dc_work(j)=dc_old(j,0) - d_t_work(j)=d_t_old(j,0) - d_a_work(j)=d_a_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc_work(ind+j)=dc_old(j,i) - d_t_work(ind+j)=d_t_old(j,i) - d_a_work(ind+j)=d_a_old(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - dc_work(ind+j)=dc_old(j,i+nres) - d_t_work(ind+j)=d_t_old(j,i+nres) - d_a_work(ind+j)=d_a_old(j,i+nres) - enddo - ind=ind+3 - endif - enddo - -#ifndef LANG0 - if (lprn) then - write (iout,*) - & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,", - & " vrand_mat2" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j), - & vfric_mat(i,j),afric_mat(i,j), - & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) - enddo - enddo - endif - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) - & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) - ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) - ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) - enddo - d_t_work_new(i)=ddt1+0.5d0*ddt2 - d_t_work(i)=ddt1+ddt2 - enddo -#endif - do j=1,3 - dc(j,0)=dc_work(j) - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_work(ind+j) - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_work(ind+j) - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c-------------------------------------------------------------------------- - subroutine sd_verlet2_ciccotti -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute the stochastic forces which contribute to velocity change -c - call stochastic_force(stochforcvecV) -#ifndef LANG0 - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - - ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) -c ddt2=ddt2+vrand_mat2(i,j)*stochforcvecV(j) - ddt2=ddt2+vrand_mat2(i,j)*stochforcvec(j) - enddo - d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 - enddo -#endif - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -#endif diff --git a/source/unres/src_MD-M-newcorr/MD_A-MTS.F_safe b/source/unres/src_MD-M-newcorr/MD_A-MTS.F_safe deleted file mode 100644 index db8058f..0000000 --- a/source/unres/src_MD-M-newcorr/MD_A-MTS.F_safe +++ /dev/null @@ -1,2327 +0,0 @@ - subroutine MD -c------------------------------------------------ -c The driver for molecular dynamics subroutines -c------------------------------------------------ - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" - integer IERROR,ERRCODE -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision cm(3),L(3),vcm(3) -#ifdef VOUT - double precision v_work(maxres6),v_transf(maxres6) -#endif - integer ilen,rstcount - external ilen - character*50 tytul - common /gucio/ cm - integer itime -c -#ifdef MPI - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_" - & //liczba(:ilen(liczba))//'.rst') -#else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_"//'.rst') -#endif - t_MDsetup=0.0d0 - t_langsetup=0.0d0 - t_MD=0.0d0 - t_enegrad=0.0d0 - t_sdsetup=0.0d0 - write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" -#ifdef MPI - tt0=MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Determine the inverse of the inertia matrix. - call setup_MD_matrices -c Initialize MD - call init_MD -#ifdef MPI - t_MDsetup = MPI_Wtime()-tt0 -#else - t_MDsetup = tcpu()-tt0 -#endif - rstcount=0 -c Entering the MD loop -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif -#ifdef MPI - t_langsetup=MPI_Wtime()-tt0 - tt0=MPI_Wtime() -#else - t_langsetup=tcpu()-tt0 - tt0=tcpu() -#endif - do itime=1,n_timestep - rstcount=rstcount+1 - if (lang.gt.0 .and. surfarea .and. - & mod(itime,reset_fricmat).eq.0) then - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - write (iout,'(a,i10)') - & "Friction matrix reset based on surface area, itime",itime - endif - if (reset_vel .and. tbf .and. lang.eq.0 - & .and. mod(itime,count_reset_vel).eq.0) then - call random_vel - write(iout,'(a,f20.2)') - & "Velocities reset to random values, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - endif - if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then - call inertia_tensor - call vcm_vel(vcm) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen3*Rb)*EK - scalfac=dsqrt(T_bath/kinetic_T) - write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=scalfac*d_t(j,i) - enddo - enddo - endif - if (lang.ne.4) then - if (RESPA) then -c Time-reversible RESPA algorithm -c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) - call RESPA_step(itime) - else -c Variable time step algorithm. - call velverlet_step(itime) - endif - else -#ifdef BROWN - call brown_step(itime) -#else - print *,"Brown dynamics not here!" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) call statout(itime) -#ifdef VOUT - do j=1,3 - v_work(j)=d_t(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - v_work(ind)=d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - ind=ind+1 - v_work(ind)=d_t(j,i+nres) - enddo - endif - enddo - - write (66,'(80f10.5)') - & ((d_t(j,i),j=1,3),i=0,nres-1),((d_t(j,i+nres),j=1,3),i=1,nres) - do i=1,ind - v_transf(i)=0.0d0 - do j=1,ind - v_transf(i)=v_transf(i)+gvec(j,i)*v_work(j) - enddo - v_transf(i)= v_transf(i)*dsqrt(geigen(i)) - enddo - write (67,'(80f10.5)') (v_transf(i),i=1,ind) -#endif - endif - if (mod(itime,ntwx).eq.0) then - write (tytul,'("time",f8.2)') totT - if(mdpdb) then - call pdbout(potE,tytul,ipdb) - else - call cartout(totT) - endif - endif - if (rstcount.eq.1000.or.itime.eq.n_timestep) then - open(irest2,file=rest2name,status='unknown') - write(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - write (irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - close(irest2) - rstcount=0 - endif - enddo -#ifdef MPI - t_MD=MPI_Wtime()-tt0 -#else - t_MD=tcpu()-tt0 -#endif - write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') - & ' Timing ', - & 'MD calculations setup:',t_MDsetup, - & 'Energy & gradient evaluation:',t_enegrad, - & 'Stochastic MD setup:',t_langsetup, - & 'Stochastic MD step setup:',t_sdsetup, - & 'MD steps:',t_MD - write (iout,'(/28(1h=),a25,27(1h=))') - & ' End of MD calculation ' - return - end -c------------------------------------------------------------------------------- - subroutine velverlet_step(itime) -c------------------------------------------------------------------------------- -c Perform a single velocity Verlet step; the time step can be rescaled if -c increments in accelerations exceed the threshold -c------------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer ierror,ierrcode -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - include 'COMMON.MUCA' - double precision vcm(3),incr(3) - double precision cm(3),L(3) - integer ilen,count,rstcount - external ilen - character*50 tytul - integer maxcount_scale /20/ - common /gucio/ cm - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - integer itime - logical scale -c - scale=.true. - icount_scale=0 - if (lang.eq.1) then - call sddir_precalc - else if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call stochastic_force(stochforcvec) -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - itime_scal=0 - do while (scale) - icount_scale=icount_scale+1 - if (icount_scale.gt.maxcount_scale) then - write (iout,*) - & "ERROR: too many attempts at scaling down the time step. ", - & "amax=",amax,"epdrift=",epdrift, - & "damax=",damax,"edriftmax=",edriftmax, - & "d_time=",d_time - call flush(iout) -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,IERRCODE) -#endif - stop - endif -c First step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet1 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet1_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet1 - else - call verlet1 - endif -c Build the chain from the newly calculated coordinates - call chainbuild_cart - if (rattle) call rattle1 - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "Cartesian and internal coordinates: step 1" - call cartprint - call intout - write (iout,*) "dC" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo - write (iout,*) "Accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 1" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Calculate energy and forces - call zerograd - call etotal(potEcomp) - potE=potEcomp(0)-potEcomp(20) - call cartgrad -c Get the new accelerations - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Determine maximum acceleration and scale down the timestep if needed - call max_accel - amax=amax/(itime_scal+1)**2 - call predict_edrift(epdrift) - if (amax/(itime_scal+1).gt.damax .or. epdrift.gt.edriftmax) then -c Maximum acceleration or maximum predicted energy drift exceeded, rescale the time step - scale=.true. - ifac_time=dmax1(dlog(amax/damax),dlog(epdrift/edriftmax)) - & /dlog(2.0d0)+1 - itime_scal=itime_scal+ifac_time -c fac_time=dmin1(damax/amax,0.5d0) - fac_time=0.5d0**ifac_time - d_time=d_time*fac_time - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 -c write (iout,*) "Calling sd_verlet_setup: 1" -c Rescale the stochastic forces and recalculate or restore -c the matrices of tinker integrator - if (itime_scal.gt.maxflag_stoch) then - if (large) write (iout,'(a,i5,a)') - & "Calculate matrices for stochastic step;", - & " itime_scal ",itime_scal - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - write (iout,'(2a,i3,a,i3,1h.)') - & "Warning: cannot store matrices for stochastic", - & " integration because the index",itime_scal, - & " is greater than",maxflag_stoch - write (iout,'(2a)')"Increase MAXFLAG_STOCH or use direct", - & " integration Langevin algorithm for better efficiency." - else if (flag_stoch(itime_scal)) then - if (large) write (iout,'(a,i5,a,l1)') - & "Restore matrices for stochastic step; itime_scal ", - & itime_scal," flag ",flag_stoch(itime_scal) - do i=1,dimen - do j=1,dimen - pfric_mat(i,j)=pfric0_mat(i,j,itime_scal) - afric_mat(i,j)=afric0_mat(i,j,itime_scal) - vfric_mat(i,j)=vfric0_mat(i,j,itime_scal) - prand_mat(i,j)=prand0_mat(i,j,itime_scal) - vrand_mat1(i,j)=vrand0_mat1(i,j,itime_scal) - vrand_mat2(i,j)=vrand0_mat2(i,j,itime_scal) - enddo - enddo - else - if (large) write (iout,'(2a,i5,a,l1)') - & "Calculate & store matrices for stochastic step;", - & " itime_scal ",itime_scal," flag ",flag_stoch(itime_scal) - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - flag_stoch(ifac_time)=.true. - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,itime_scal)=pfric_mat(i,j) - afric0_mat(i,j,itime_scal)=afric_mat(i,j) - vfric0_mat(i,j,itime_scal)=vfric_mat(i,j) - prand0_mat(i,j,itime_scal)=prand_mat(i,j) - vrand0_mat1(i,j,itime_scal)=vrand_mat1(i,j) - vrand0_mat2(i,j,itime_scal)=vrand_mat2(i,j) - enddo - enddo - endif - fac_time=1.0d0/dsqrt(fac_time) - do i=1,dimen - stochforcvec(i)=fac_time*stochforcvec(i) - enddo -#endif - else if (lang.eq.1) then -c Rescale the accelerations due to stochastic forces - fac_time=1.0d0/dsqrt(fac_time) - do i=1,dimen - d_as_work(i)=d_as_work(i)*fac_time - enddo - endif - if (large) write (iout,'(a,i10,a,f8.6,a,i3,a,i3)') - & "itime",itime," Timestep scaled down to ", - & d_time," ifac_time",ifac_time," itime_scal",itime_scal - else -c Second step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet2 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet2_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet2 - else - call verlet2 - endif - if (rattle) call rattle2 - totT=totT+d_time - if (d_time.ne.d_time0) then - d_time=d_time0 -#ifndef LANG0 - if (lang.eq.2 .or. lang.eq.3) then - if (large) write (iout,'(a)') - & "Restore original matrices for stochastic step" -c write (iout,*) "Calling sd_verlet_setup: 2" -c Restore the matrices of tinker integrator if the time step has been restored - do i=1,dimen - do j=1,dimen - pfric_mat(i,j)=pfric0_mat(i,j,0) - afric_mat(i,j)=afric0_mat(i,j,0) - vfric_mat(i,j)=vfric0_mat(i,j,0) - prand_mat(i,j)=prand0_mat(i,j,0) - vrand_mat1(i,j)=vrand0_mat1(i,j,0) - vrand_mat2(i,j)=vrand0_mat2(i,j,0) - enddo - enddo - endif -#endif - endif - scale=.false. - endif - enddo -c Calculate the kinetic and the total energy and the kinetic temperature - call kinetic(EK) - totE=EK+potE -c diagnostics -c call kinetic1(EK1) -c write (iout,*) "step",itime," EK",EK," EK1",EK1 -c end diagnostics -c Couple the system to Berendsen bath if needed - if (tbf .and. lang.eq.0) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK -c Backup the coordinates, velocities, and accelerations - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, step 2" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif - return - end -c------------------------------------------------------------------------------- - subroutine RESPA_step(itime) -c------------------------------------------------------------------------------- -c Perform a single RESPA step. -c------------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer IERROR,ERRCODE -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision energia_short(0:n_ene), - & energia_long(0:n_ene) - double precision cm(3),L(3),vcm(3),incr(3) - double precision dc_old0(3,0:maxres2),d_t_old0(3,0:maxres2), - & d_a_old0(3,0:maxres2) - integer ilen,count,rstcount - external ilen - character*50 tytul - integer maxcount_scale /10/ - common /gucio/ cm - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - integer itime - logical scale - common /cipiszcze/ itt - itt=itime - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "***************** RESPA itime",itime - write (iout,*) "Cartesian and internal coordinates: step 0" -c call cartprint - call pdbout(0.0d0,"cipiszcze",iout) - call intout - write (iout,*) "Accelerations from long-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 0" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c -c Perform the initial RESPA step (increment velocities) -c write (iout,*) "*********************** RESPA ini" - call RESPA_vel - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, end" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c Compute the short-range forces -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_short(energia_short) - call cartgrad - call lagrangian - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "energia_short",energia_short(0) - write (iout,*) "Accelerations from short-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo -c 6/30/08 A-MTS: attempt at increasing the split number - do i=0,2*nres - do j=1,3 - dc_old0(j,i)=dc_old(j,i) - d_t_old0(j,i)=d_t_old(j,i) - d_a_old0(j,i)=d_a_old(j,i) - enddo - enddo - if (ntime_split.gt.ntime_split0) ntime_split=ntime_split/2 - if (ntime_split.lt.ntime_split0) ntime_split=ntime_split0 -c - scale=.true. - d_time0=d_time - do while (scale) - - scale=.false. -c write (iout,*) "itime",itime," ntime_split",ntime_split -c Split the time step - d_time=d_time0/ntime_split -c Perform the short-range RESPA steps (velocity Verlet increments of -c positions and velocities using short-range forces) -c write (iout,*) "*********************** RESPA split" - do itsplit=1,ntime_split - if (lang.eq.1) then - call sddir_precalc - else if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call stochastic_force(stochforcvec) -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif -c First step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet1 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet1_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet1 - else - call verlet1 - endif -c Build the chain from the newly calculated coordinates - call chainbuild_cart - if (rattle) call rattle1 - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "***** ITSPLIT",itsplit - write (iout,*) "Cartesian and internal coordinates: step 1" - call pdbout(0.0d0,"cipiszcze",iout) -c call cartprint - call intout - write (iout,*) "Velocities, step 1" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Calculate energy and forces - call zerograd - call etotal_short(energia_short) - call cartgrad -c Get the new accelerations - call lagrangian - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*)"energia_short",energia_short(0) - write (iout,*) "Accelerations from short-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - endif -c 6/30/08 A-MTS -c Determine maximum acceleration and scale down the timestep if needed - call max_accel - amax=amax/ntime_split**2 - call predict_edrift(epdrift) - if (ntwe.gt.0 .and. large .and. mod(itime,ntwe).eq.0) - & write (iout,*) "amax",amax," damax",damax, - & " epdrift",epdrift," epdriftmax",epdriftmax -c Exit loop and try with increased split number if the change of -c acceleration is too big - if (amax.gt.damax .or. epdrift.gt.edriftmax) then - if (ntime_split.lt.maxtime_split) then - scale=.true. - ntime_split=ntime_split*2 - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc_old0(j,i) - d_t_old(j,i)=d_t_old0(j,i) - d_a_old(j,i)=d_a_old0(j,i) - enddo - enddo - write (iout,*) "acceleration/energy drift too large",amax, - & epdrift," split increased to ",ntime_split," itime",itime, - & " itsplit",itsplit - exit - else - write (iout,*) - & "Uh-hu. Bumpy landscape. Maximum splitting number", - & maxtime_split, - & " already reached!!! Trying to carry on!" - endif - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Second step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet2 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet2_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet2 - else - call verlet2 - endif - if (rattle) call rattle2 -c Backup the coordinates, velocities, and accelerations - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - enddo - - enddo ! while scale - -c Restore the time step - d_time=d_time0 -c Compute long-range forces -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_long(energia_long) - call cartgrad - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Compute accelerations from long-range forces - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "energia_long",energia_long(0) - write (iout,*) "Cartesian and internal coordinates: step 2" -c call cartprint - call pdbout(0.0d0,"cipiszcze",iout) - call intout - write (iout,*) "Accelerations from long-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 2" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c Compute the final RESPA step (increment velocities) -c write (iout,*) "*********************** RESPA fin" - call RESPA_vel -c Compute the complete potential energy - do i=0,n_ene - potEcomp(i)=energia_short(i)+energia_long(i) - enddo - potE=potEcomp(0)-potEcomp(20) -c potE=energia_short(0)+energia_long(0) - totT=totT+d_time -c Calculate the kinetic and the total energy and the kinetic temperature - call kinetic(EK) - totE=EK+potE -c Couple the system to Berendsen bath if needed - if (tbf .and. lang.eq.0) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK -c Backup the coordinates, velocities, and accelerations - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, end" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif - return - end -c--------------------------------------------------------------------- - subroutine RESPA_vel -c First and last RESPA step (incrementing velocities using long-range -c forces). - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - do j=1,3 - d_t(j,0)=d_t(j,0)+0.5d0*d_a(j,0)*d_time - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t(j,i)+0.5d0*d_a(j,i)*d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t(j,inres)+0.5d0*d_a(j,inres)*d_time - enddo - endif - enddo - return - end -c----------------------------------------------------------------- - subroutine verlet1 -c Applying velocity Verlet algorithm - step 1 to coordinates - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision adt,adt2 - -#ifdef DEBUG - write (iout,*) "VELVERLET1 START: DC" - do i=0,nres - write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo -#endif - do j=1,3 - adt=d_a_old(j,0)*d_time - adt2=0.5d0*adt - dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time - d_t_new(j,0)=d_t_old(j,0)+adt2 - d_t(j,0)=d_t_old(j,0)+adt - enddo - do i=nnt,nct-1 - do j=1,3 - adt=d_a_old(j,i)*d_time - adt2=0.5d0*adt - dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time - d_t_new(j,i)=d_t_old(j,i)+adt2 - d_t(j,i)=d_t_old(j,i)+adt - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - adt=d_a_old(j,inres)*d_time - adt2=0.5d0*adt - dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time - d_t_new(j,inres)=d_t_old(j,inres)+adt2 - d_t(j,inres)=d_t_old(j,inres)+adt - enddo - endif - enddo -#ifdef DEBUG - write (iout,*) "VELVERLET1 END: DC" - do i=0,nres - write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo -#endif - return - end -c--------------------------------------------------------------------- - subroutine verlet2 -c Step 2 of the velocity Verlet algorithm: update velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - do j=1,3 - d_t(j,0)=d_t_new(j,0)+0.5d0*d_a(j,0)*d_time - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+0.5d0*d_a(j,i)*d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+0.5d0*d_a(j,inres)*d_time - enddo - endif - enddo - return - end -c----------------------------------------------------------------- - subroutine sddir_precalc -c Applying velocity Verlet algorithm - step 1 to coordinates - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute friction and stochastic forces -c - call friction_force - call stochastic_force(stochforcvec) -c -c Compute the acceleration due to friction forces (d_af_work) and stochastic -c forces (d_as_work) -c - call ginv_mult(fric_work, d_af_work) - call ginv_mult(stochforcvec, d_as_work) - return - end -c--------------------------------------------------------------------- - subroutine sddir_verlet1 -c Applying velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' -c Revised 3/31/05 AL: correlation between random contributions to -c position and velocity increments included. - double precision sqrt13 /0.57735026918962576451d0/ ! 1/sqrt(3) - double precision adt,adt2 -c -c Add the contribution from BOTH friction and stochastic force to the -c coordinates, but ONLY the contribution from the friction forces to velocities -c - do j=1,3 - adt=(d_a_old(j,0)+d_af_work(j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(j)*d_time - dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time - d_t_new(j,0)=d_t_old(j,0)+0.5d0*adt - d_t(j,0)=d_t_old(j,0)+adt - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - adt=(d_a_old(j,i)+d_af_work(ind+j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time - dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time - d_t_new(j,i)=d_t_old(j,i)+0.5d0*adt - d_t(j,i)=d_t_old(j,i)+adt - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - adt=(d_a_old(j,inres)+d_af_work(ind+j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time - dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time - d_t_new(j,inres)=d_t_old(j,inres)+0.5d0*adt - d_t(j,inres)=d_t_old(j,inres)+adt - enddo - ind=ind+3 - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine sddir_verlet2 -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),d_as_work1(MAXRES6) - double precision cos60 /0.5d0/, sin60 /0.86602540378443864676d0/ -c Revised 3/31/05 AL: correlation between random contributions to -c position and velocity increments included. -c The correlation coefficients are calculated at low-friction limit. -c Also, friction forces are now not calculated with new velocities. - -c call friction_force - call stochastic_force(stochforcvec) -c -c Compute the acceleration due to friction forces (d_af_work) and stochastic -c forces (d_as_work) -c - call ginv_mult(stochforcvec, d_as_work1) - -c -c Update velocities -c - do j=1,3 - d_t(j,0)=d_t_new(j,0)+(0.5d0*(d_a(j,0)+d_af_work(j)) - & +sin60*d_as_work(j)+cos60*d_as_work1(j))*d_time - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+(0.5d0*(d_a(j,i)+d_af_work(ind+j)) - & +sin60*d_as_work(ind+j)+cos60*d_as_work1(ind+j))*d_time - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+(0.5d0*(d_a(j,inres) - & +d_af_work(ind+j))+sin60*d_as_work(ind+j) - & +cos60*d_as_work1(ind+j))*d_time - enddo - ind=ind+3 - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine max_accel -c -c Find the maximum difference in the accelerations of the the sites -c at the beginning and the end of the time step. -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - double precision aux(3),accel(3),accel_old(3),dacc - do j=1,3 -c aux(j)=d_a(j,0)-d_a_old(j,0) - accel_old(j)=d_a_old(j,0) - accel(j)=d_a(j,0) - enddo - amax=0.0d0 - do i=nnt,nct -c Backbone - if (i.lt.nct) then -c 7/3/08 changed to asymmetric difference - do j=1,3 -c accel(j)=aux(j)+0.5d0*(d_a(j,i)-d_a_old(j,i)) - accel_old(j)=accel_old(j)+0.5d0*d_a_old(j,i) - accel(j)=accel(j)+0.5d0*d_a(j,i) -c if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) - if (dabs(accel(j)).gt.dabs(accel_old(j))) then - dacc=dabs(accel(j)-accel_old(j)) - if (dacc.gt.amax) amax=dacc - endif - enddo - endif - enddo -c Side chains - do j=1,3 -c accel(j)=aux(j) - accel_old(j)=d_a_old(j,0) - accel(j)=d_a(j,0) - enddo - if (nnt.eq.2) then - do j=1,3 - accel_old(j)=accel_old(j)+d_a_old(j,1) - accel(j)=accel(j)+d_a(j,1) - enddo - endif - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 -c accel(j)=accel(j)+d_a(j,i+nres)-d_a_old(j,i+nres) - accel_old(j)=accel_old(j)+d_a_old(j,i+nres) - accel(j)=accel(j)+d_a(j,i+nres) - enddo - endif - do j=1,3 -c if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) - if (dabs(accel(j)).gt.dabs(accel_old(j))) then - dacc=dabs(accel(j)-accel_old(j)) - if (dacc.gt.amax) amax=dacc - endif - enddo - do j=1,3 - accel_old(j)=accel_old(j)+d_a_old(j,i) - accel(j)=accel(j)+d_a(j,i) -c aux(j)=aux(j)+d_a(j,i)-d_a_old(j,i) - enddo - enddo - return - end -c--------------------------------------------------------------------- - subroutine predict_edrift(epdrift) -c -c Predict the drift of the potential energy -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.MUCA' - double precision epdrift,epdriftij -c Drift of the potential energy - epdrift=0.0d0 - do i=nnt,nct -c Backbone - if (i.lt.nct) then - do j=1,3 - epdriftij=dabs((d_a(j,i)-d_a_old(j,i))*gcart(j,i)) - if (lmuca) epdriftij=epdriftij*factor -c write (iout,*) "back",i,j,epdriftij - if (epdriftij.gt.epdrift) epdrift=epdriftij - enddo - endif -c Side chains - if (itype(i).ne.10) then - do j=1,3 - epdriftij= - & dabs((d_a(j,i+nres)-d_a_old(j,i+nres))*gxcart(j,i)) - if (lmuca) epdriftij=epdriftij*factor -c write (iout,*) "side",i,j,epdriftij - if (epdriftij.gt.epdrift) epdrift=epdriftij - enddo - endif - enddo - epdrift=0.5d0*epdrift*d_time*d_time -c write (iout,*) "epdrift",epdrift - return - end -c----------------------------------------------------------------------- - subroutine verlet_bath -c -c Coupling to the thermostat by using the Berendsen algorithm -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision T_half,fact -c - T_half=2.0d0/(dimen3*Rb)*EK - fact=dsqrt(1.0d0+(d_time/tau_bath)*(t_bath/T_half-1.0d0)) -c write(iout,*) "T_half", T_half -c write(iout,*) "EK", EK -c write(iout,*) "fact", fact - do j=1,3 - d_t(j,0)=fact*d_t(j,0) - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=fact*d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=fact*d_t(j,inres) - enddo - endif - enddo - return - end -c--------------------------------------------------------- - subroutine init_MD -c Set up the initial conditions of a MD simulation - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MP - include 'mpif.h' - character*16 form - integer IERROR,ERRCODE -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.REMD' - real*8 energia_long(0:n_ene), - & energia_short(0:n_ene),vcm(3),incr(3) - double precision cm(3),L(3),xv,sigv,lowb,highb - double precision varia(maxvar) - character*256 qstr - integer ilen - external ilen - character*50 tytul - logical file_exist - common /gucio/ cm - d_time0=d_time -c write(iout,*) "d_time", d_time -c Compute the standard deviations of stochastic forces for Langevin dynamics -c if the friction coefficients do not depend on surface area - if (lang.gt.0 .and. .not.surfarea) then - do i=nnt,nct-1 - stdforcp(i)=stdfp*dsqrt(gamp) - enddo - do i=nnt,nct - stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamsc(itype(i))) - enddo - endif -c Open the pdb file for snapshotshots -#ifdef MPI - if(mdpdb) then - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".pdb") - open(ipdb, - & file=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".pdb") - else -#ifdef NOXDR - if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".x") - cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".x" -#else - if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".cx") - cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".cx" -#endif - endif -#else - if(mdpdb) then - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.pdb") - open(ipdb,file=prefix(:ilen(prefix))//"_MD.pdb") - else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.cx") - cartname=prefix(:ilen(prefix))//"_MD.cx" - endif -#endif - if (usampl) then - write (qstr,'(256(1h ))') - ipos=1 - do i=1,nfrag - iq = qinfrag(i,iset)*10 - iw = wfrag(i,iset)/100 - if (iw.gt.0) then - if(me.eq.king.or..not.out1file) - & write (iout,*) "Frag",qinfrag(i,iset),wfrag(i,iset),iq,iw - write (qstr(ipos:ipos+6),'(2h_f,i1,1h_,i1,1h_,i1)') i,iq,iw - ipos=ipos+7 - endif - enddo - do i=1,npair - iq = qinpair(i,iset)*10 - iw = wpair(i,iset)/100 - if (iw.gt.0) then - if(me.eq.king.or..not.out1file) - & write (iout,*) "Pair",i,qinpair(i,iset),wpair(i,iset),iq,iw - write (qstr(ipos:ipos+6),'(2h_p,i1,1h_,i1,1h_,i1)') i,iq,iw - ipos=ipos+7 - endif - enddo -c pdbname=pdbname(:ilen(pdbname)-4)//qstr(:ipos-1)//'.pdb' -#ifdef NOXDR -c cartname=cartname(:ilen(cartname)-2)//qstr(:ipos-1)//'.x' -#else -c cartname=cartname(:ilen(cartname)-3)//qstr(:ipos-1)//'.cx' -#endif -c statname=statname(:ilen(statname)-5)//qstr(:ipos-1)//'.stat' - endif - icg=1 - if (rest) then - if (restart1file) then - if (me.eq.king) - & inquire(file=mremd_rst_name,exist=file_exist) - write (*,*) me," Before broadcast: file_exist",file_exist - call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM, - & IERR) - write (*,*) me," After broadcast: file_exist",file_exist -c inquire(file=mremd_rst_name,exist=file_exist) - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial state read by master and distributed" - else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_' - & //liczba(:ilen(liczba))//'.rst') - inquire(file=rest2name,exist=file_exist) - endif - if(file_exist) then - if(.not.restart1file) then - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial state will be read from file ", - & rest2name(:ilen(rest2name)) - call readrst - endif - call rescale_weights(t_bath) - else - if(me.eq.king.or..not.out1file)then - if (restart1file) then - write(iout,*) "File ",mremd_rst_name(:ilen(mremd_rst_name)), - & " does not exist" - else - write(iout,*) "File ",rest2name(:ilen(rest2name)), - & " does not exist" - endif - write(iout,*) "Initial velocities randomly generated" - endif - call random_vel - totT=0.0d0 - endif - else -c Generate initial velocities - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial velocities randomly generated" - call random_vel - totT=0.0d0 - endif -c rest2name = prefix(:ilen(prefix))//'.rst' - if(me.eq.king.or..not.out1file)then - write(iout,*) "Initial backbone velocities" - do i=nnt,nct-1 - write(iout,*) (d_t(j,i),j=1,3) - enddo - write(iout,*) "Initial side-chain velocities" - do i=nnt,nct - write(iout,*) (d_t(j,i+nres),j=1,3) - enddo -c Zeroing the total angular momentum of the system - write(iout,*) "Calling the zero-angular - & momentum subroutine" - endif - call inertia_tensor -c Getting the potential energy and forces and velocities and accelerations - call vcm_vel(vcm) -c write (iout,*) "velocity of the center of the mass:" -c write (iout,*) (vcm(j),j=1,3) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo -c Removing the velocity of the center of mass - call vcm_vel(vcm) - if(me.eq.king.or..not.out1file)then - write (iout,*) "vcm right after adjustment:" - write (iout,*) (vcm(j),j=1,3) - endif - if (.not.rest) then - call chainbuild - if(iranconf.ne.0) then - if (overlapsc) then - print *, 'Calling OVERLAP_SC' - call overlap_sc(fail) - endif - - if (searchsc) then - call sc_move(2,nres-1,10,1d10,nft_sc,etot) - print *,'SC_move',nft_sc,etot - if(me.eq.king.or..not.out1file) - & write(iout,*) 'SC_move',nft_sc,etot - endif - - if(dccart)then - print *, 'Calling MINIM_DC' - call minim_dc(etot,iretcode,nfun) - else - call geom_to_var(nvar,varia) - print *,'Calling MINIMIZE.' - call minimize(etot,varia,iretcode,nfun) - call var_to_geom(nvar,varia) - endif - if(me.eq.king.or..not.out1file) - & write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun - endif - endif - call chainbuild_cart - call kinetic(EK) - if (tbf) then - call verlet_bath(EK) - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK - if(me.eq.king.or..not.out1file)then - call cartprint - call intout - endif - call zerograd - call etotal(potEcomp) - potE=potEcomp(0) - call cartgrad - call lagrangian - call max_accel - if (amax*d_time .gt. dvmax) then - d_time=d_time*dvmax/amax - if(me.eq.king.or..not.out1file) write (iout,*) - & "Time step reduced to",d_time, - & " because of too large initial acceleration." - endif - if(me.eq.king.or..not.out1file)then - write(iout,*) "Potential energy and its components" - write(iout,*) (potEcomp(i),i=0,n_ene) - endif - potE=potEcomp(0)-potEcomp(20) - totE=EK+potE - itime=0 - if (ntwe.ne.0) call statout(itime) - if(me.eq.king.or..not.out1file) - & write (iout,*) "Initial:", - & " Kinetic energy",EK," potential energy",potE, - & " total energy",totE," maximum acceleration ", - & amax - if (large) then - write (iout,*) "Initial coordinates" - do i=1,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(c(j,i),j=1,3), - & (c(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial dC" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial velocities" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial accelerations" - do i=0,nres -c write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - write (iout,'(i3,3f15.10,3x,3f15.10)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo -c write (iout,*) "dc_old",i,(dc_old(j,i),j=1,3) - enddo - if (RESPA) then -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_long(energia_long) - if(.not.out1file .and. large) then - write (iout,*) "energia_long",energia_long(0) - write (iout,*) "Initial slow-force accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - call cartgrad - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c call etotal_short(energia_short) -c write (iout,*) "energia_long",energia_long(0), -c & " energia_short",energia_short(0), -c & " total",energia_long(0)+energia_short(0) - endif - return - end -c----------------------------------------------------------- - subroutine random_vel - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision xv,sigv,lowb,highb -c Generate random velocities from Gaussian distribution of mean 0 and std of KT/m -c First generate velocities in the eigenspace of the G matrix -c write (iout,*) "Calling random_vel dimen dimen3",dimen,dimen3 -c call flush(iout) - xv=0.0d0 - ii=0 - do i=1,dimen - do k=1,3 - ii=ii+1 - sigv=dsqrt((Rb*t_bath)/geigen(i)) - lowb=-5*sigv - highb=5*sigv - d_t_work_new(ii)=anorm_distr(xv,sigv,lowb,highb) -c write (iout,*) "ii",ii," d_t_work_new",d_t_work_new(ii) - enddo - enddo -c diagnostics -c Ek1=0.0d0 -c ii=0 -c do i=1,dimen -c do k=1,3 -c ii=ii+1 -c Ek1=Ek1+0.5d0*geigen(i)*d_t_work_new(ii)**2 -c enddo -c enddo -c write (iout,*) "Ek from eigenvectors",Ek1 -c end diagnostics -c Transform velocities to UNRES coordinate space - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - d_t_work(ind)=0.0d0 - do j=1,dimen - d_t_work(ind)=d_t_work(ind) - & +Gvec(i,j)*d_t_work_new((j-1)*3+k+1) - enddo -c write (iout,*) "i",i," ind",ind," d_t_work",d_t_work(ind) -c call flush(iout) - enddo - enddo -c Transfer to the d_t vector - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - d_t(j,i)=d_t_work(ind) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - ind=ind+1 - d_t(j,i+nres)=d_t_work(ind) - enddo - endif - enddo -c call kinetic(EK) -c write (iout,*) "Kinetic energy",Ek,EK1," kinetic temperature", -c & 2.0d0/(dimen3*Rb)*EK,2.0d0/(dimen3*Rb)*EK1 -c call flush(iout) - return - end -#ifndef LANG0 -c----------------------------------------------------------- - subroutine sd_verlet_p_setup -c Sets up the parameters of stochastic Verlet algorithm - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision emgdt(MAXRES6), - & pterm,vterm,rho,rhoc,vsig, - & pfric_vec(MAXRES6),vfric_vec(MAXRES6), - & afric_vec(MAXRES6),prand_vec(MAXRES6), - & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6) - logical lprn /.false./ - double precision zero /1.0d-8/, gdt_radius /0.05d0/ - double precision ktm -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c -c AL 8/17/04 Code adapted from tinker -c -c Get the frictional and random terms for stochastic dynamics in the -c eigenspace of mass-scaled UNRES friction matrix -c - do i = 1, dimen - gdt = fricgam(i) * d_time -c -c Stochastic dynamics reduces to simple MD for zero friction -c - if (gdt .le. zero) then - pfric_vec(i) = 1.0d0 - vfric_vec(i) = d_time - afric_vec(i) = 0.5d0 * d_time * d_time - prand_vec(i) = 0.0d0 - vrand_vec1(i) = 0.0d0 - vrand_vec2(i) = 0.0d0 -c -c Analytical expressions when friction coefficient is large -c - else - if (gdt .ge. gdt_radius) then - egdt = dexp(-gdt) - pfric_vec(i) = egdt - vfric_vec(i) = (1.0d0-egdt) / fricgam(i) - afric_vec(i) = (d_time-vfric_vec(i)) / fricgam(i) - pterm = 2.0d0*gdt - 3.0d0 + (4.0d0-egdt)*egdt - vterm = 1.0d0 - egdt**2 - rho = (1.0d0-egdt)**2 / sqrt(pterm*vterm) -c -c Use series expansions when friction coefficient is small -c - else - gdt2 = gdt * gdt - gdt3 = gdt * gdt2 - gdt4 = gdt2 * gdt2 - gdt5 = gdt2 * gdt3 - gdt6 = gdt3 * gdt3 - gdt7 = gdt3 * gdt4 - gdt8 = gdt4 * gdt4 - gdt9 = gdt4 * gdt5 - afric_vec(i) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0 - & - gdt5/120.0d0 + gdt6/720.0d0 - & - gdt7/5040.0d0 + gdt8/40320.0d0 - & - gdt9/362880.0d0) / fricgam(i)**2 - vfric_vec(i) = d_time - fricgam(i)*afric_vec(i) - pfric_vec(i) = 1.0d0 - fricgam(i)*vfric_vec(i) - pterm = 2.0d0*gdt3/3.0d0 - gdt4/2.0d0 - & + 7.0d0*gdt5/30.0d0 - gdt6/12.0d0 - & + 31.0d0*gdt7/1260.0d0 - gdt8/160.0d0 - & + 127.0d0*gdt9/90720.0d0 - vterm = 2.0d0*gdt - 2.0d0*gdt2 + 4.0d0*gdt3/3.0d0 - & - 2.0d0*gdt4/3.0d0 + 4.0d0*gdt5/15.0d0 - & - 4.0d0*gdt6/45.0d0 + 8.0d0*gdt7/315.0d0 - & - 2.0d0*gdt8/315.0d0 + 4.0d0*gdt9/2835.0d0 - rho = sqrt(3.0d0) * (0.5d0 - 3.0d0*gdt/16.0d0 - & - 17.0d0*gdt2/1280.0d0 - & + 17.0d0*gdt3/6144.0d0 - & + 40967.0d0*gdt4/34406400.0d0 - & - 57203.0d0*gdt5/275251200.0d0 - & - 1429487.0d0*gdt6/13212057600.0d0) - end if -c -c Compute the scaling factors of random terms for the nonzero friction case -c - ktm = 0.5d0*d_time/fricgam(i) - psig = dsqrt(ktm*pterm) / fricgam(i) - vsig = dsqrt(ktm*vterm) - rhoc = dsqrt(1.0d0 - rho*rho) - prand_vec(i) = psig - vrand_vec1(i) = vsig * rho - vrand_vec2(i) = vsig * rhoc - end if - end do - if (lprn) then - write (iout,*) - & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,", - & " vrand_vec2" - do i=1,dimen - write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i), - & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) - enddo - endif -c -c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables -c -#ifndef LANG0 - call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) - call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec1,vrand_mat1) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) -#endif -#ifdef MPI - t_sdsetup=t_sdsetup+MPI_Wtime() -#else - t_sdsetup=t_sdsetup+tcpu()-tt0 -#endif - return - end -c------------------------------------------------------------- - subroutine eigtransf1(n,ndim,ab,d,c) - implicit none - integer n,ndim - double precision ab(ndim,ndim,n),c(ndim,n),d(ndim) - integer i,j,k - do i=1,n - do j=1,n - c(i,j)=0.0d0 - do k=1,n - c(i,j)=c(i,j)+ab(k,j,i)*d(k) - enddo - enddo - enddo - return - end -c------------------------------------------------------------- - subroutine eigtransf(n,ndim,a,b,d,c) - implicit none - integer n,ndim - double precision a(ndim,n),b(ndim,n),c(ndim,n),d(ndim) - integer i,j,k - do i=1,n - do j=1,n - c(i,j)=0.0d0 - do k=1,n - c(i,j)=c(i,j)+a(i,k)*b(k,j)*d(k) - enddo - enddo - enddo - return - end -c------------------------------------------------------------- - subroutine sd_verlet1 -c Applying stochastic velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - logical lprn /.false./ - -c write (iout,*) "dc_old" -c do i=0,nres -c write (iout,'(i5,3f10.5,5x,3f10.5)') -c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) -c enddo - do j=1,3 - dc_work(j)=dc_old(j,0) - d_t_work(j)=d_t_old(j,0) - d_a_work(j)=d_a_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc_work(ind+j)=dc_old(j,i) - d_t_work(ind+j)=d_t_old(j,i) - d_a_work(ind+j)=d_a_old(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc_work(ind+j)=dc_old(j,i+nres) - d_t_work(ind+j)=d_t_old(j,i+nres) - d_a_work(ind+j)=d_a_old(j,i+nres) - enddo - ind=ind+3 - endif - enddo -#ifndef LANG0 - if (lprn) then - write (iout,*) - & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,", - & " vrand_mat2" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j), - & vfric_mat(i,j),afric_mat(i,j), - & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) - enddo - enddo - endif - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) - & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) - ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) - ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) - enddo - d_t_work_new(i)=ddt1+0.5d0*ddt2 - d_t_work(i)=ddt1+ddt2 - enddo -#endif - do j=1,3 - dc(j,0)=dc_work(j) - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_work(ind+j) - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_work(ind+j) - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c-------------------------------------------------------------------------- - subroutine sd_verlet2 -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute the stochastic forces which contribute to velocity change -c - call stochastic_force(stochforcvecV) - -#ifndef LANG0 - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) - ddt2=ddt2+vrand_mat1(i,j)*stochforcvec(j)+ - & vrand_mat2(i,j)*stochforcvecV(j) - enddo - d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 - enddo -#endif - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c----------------------------------------------------------- - subroutine sd_verlet_ciccotti_setup -c Sets up the parameters of stochastic velocity Verlet algorithmi; Ciccotti's -c version - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision emgdt(MAXRES6), - & pterm,vterm,rho,rhoc,vsig, - & pfric_vec(MAXRES6),vfric_vec(MAXRES6), - & afric_vec(MAXRES6),prand_vec(MAXRES6), - & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6) - logical lprn /.false./ - double precision zero /1.0d-8/, gdt_radius /0.05d0/ - double precision ktm -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c -c AL 8/17/04 Code adapted from tinker -c -c Get the frictional and random terms for stochastic dynamics in the -c eigenspace of mass-scaled UNRES friction matrix -c - do i = 1, dimen - write (iout,*) "i",i," fricgam",fricgam(i) - gdt = fricgam(i) * d_time -c -c Stochastic dynamics reduces to simple MD for zero friction -c - if (gdt .le. zero) then - pfric_vec(i) = 1.0d0 - vfric_vec(i) = d_time - afric_vec(i) = 0.5d0*d_time*d_time - prand_vec(i) = afric_vec(i) - vrand_vec2(i) = vfric_vec(i) -c -c Analytical expressions when friction coefficient is large -c - else - egdt = dexp(-gdt) - pfric_vec(i) = egdt - vfric_vec(i) = dexp(-0.5d0*gdt)*d_time - afric_vec(i) = 0.5d0*dexp(-0.25d0*gdt)*d_time*d_time - prand_vec(i) = afric_vec(i) - vrand_vec2(i) = vfric_vec(i) -c -c Compute the scaling factors of random terms for the nonzero friction case -c -c ktm = 0.5d0*d_time/fricgam(i) -c psig = dsqrt(ktm*pterm) / fricgam(i) -c vsig = dsqrt(ktm*vterm) -c prand_vec(i) = psig*afric_vec(i) -c vrand_vec2(i) = vsig*vfric_vec(i) - end if - end do - if (lprn) then - write (iout,*) - & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,", - & " vrand_vec2" - do i=1,dimen - write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i), - & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) - enddo - endif -c -c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables -c - call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) - call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) -#ifdef MPI - t_sdsetup=t_sdsetup+MPI_Wtime() -#else - t_sdsetup=t_sdsetup+tcpu()-tt0 -#endif - return - end -c------------------------------------------------------------- - subroutine sd_verlet1_ciccotti -c Applying stochastic velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - logical lprn /.false./ - -c write (iout,*) "dc_old" -c do i=0,nres -c write (iout,'(i5,3f10.5,5x,3f10.5)') -c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) -c enddo - do j=1,3 - dc_work(j)=dc_old(j,0) - d_t_work(j)=d_t_old(j,0) - d_a_work(j)=d_a_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc_work(ind+j)=dc_old(j,i) - d_t_work(ind+j)=d_t_old(j,i) - d_a_work(ind+j)=d_a_old(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc_work(ind+j)=dc_old(j,i+nres) - d_t_work(ind+j)=d_t_old(j,i+nres) - d_a_work(ind+j)=d_a_old(j,i+nres) - enddo - ind=ind+3 - endif - enddo - -#ifndef LANG0 - if (lprn) then - write (iout,*) - & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,", - & " vrand_mat2" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j), - & vfric_mat(i,j),afric_mat(i,j), - & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) - enddo - enddo - endif - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) - & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) - ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) - ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) - enddo - d_t_work_new(i)=ddt1+0.5d0*ddt2 - d_t_work(i)=ddt1+ddt2 - enddo -#endif - do j=1,3 - dc(j,0)=dc_work(j) - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_work(ind+j) - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_work(ind+j) - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c-------------------------------------------------------------------------- - subroutine sd_verlet2_ciccotti -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute the stochastic forces which contribute to velocity change -c - call stochastic_force(stochforcvecV) -#ifndef LANG0 - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - - ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) -c ddt2=ddt2+vrand_mat2(i,j)*stochforcvecV(j) - ddt2=ddt2+vrand_mat2(i,j)*stochforcvec(j) - enddo - d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 - enddo -#endif - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -#endif diff --git a/source/unres/src_MD-M-newcorr/MD_A-MTS.F_safe1 b/source/unres/src_MD-M-newcorr/MD_A-MTS.F_safe1 deleted file mode 100644 index faa149f..0000000 --- a/source/unres/src_MD-M-newcorr/MD_A-MTS.F_safe1 +++ /dev/null @@ -1,2356 +0,0 @@ - subroutine MD -c------------------------------------------------ -c The driver for molecular dynamics subroutines -c------------------------------------------------ - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" - integer IERROR,ERRCODE -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision cm(3),L(3),vcm(3) -#ifdef VOUT - double precision v_work(maxres6),v_transf(maxres6) -#endif - integer ilen,rstcount - external ilen - character*50 tytul - common /gucio/ cm - integer itime -c -#ifdef MPI - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_" - & //liczba(:ilen(liczba))//'.rst') -#else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_"//'.rst') -#endif - t_MDsetup=0.0d0 - t_langsetup=0.0d0 - t_MD=0.0d0 - t_enegrad=0.0d0 - t_sdsetup=0.0d0 - write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" -#ifdef MPI - tt0=MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Determine the inverse of the inertia matrix. - call setup_MD_matrices -c Initialize MD - call init_MD -#ifdef MPI - t_MDsetup = MPI_Wtime()-tt0 -#else - t_MDsetup = tcpu()-tt0 -#endif - rstcount=0 -c Entering the MD loop -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif -#ifdef MPI - t_langsetup=MPI_Wtime()-tt0 - tt0=MPI_Wtime() -#else - t_langsetup=tcpu()-tt0 - tt0=tcpu() -#endif - do itime=1,n_timestep - rstcount=rstcount+1 - if (lang.gt.0 .and. surfarea .and. - & mod(itime,reset_fricmat).eq.0) then - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - write (iout,'(a,i10)') - & "Friction matrix reset based on surface area, itime",itime - endif - if (reset_vel .and. tbf .and. lang.eq.0 - & .and. mod(itime,count_reset_vel).eq.0) then - call random_vel - write(iout,'(a,f20.2)') - & "Velocities reset to random values, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - endif - if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then - call inertia_tensor - call vcm_vel(vcm) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen3*Rb)*EK - scalfac=dsqrt(T_bath/kinetic_T) - write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=scalfac*d_t(j,i) - enddo - enddo - endif - if (lang.ne.4) then - if (RESPA) then -c Time-reversible RESPA algorithm -c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) - call RESPA_step(itime) - else -c Variable time step algorithm. - call velverlet_step(itime) - endif - else -#ifdef BROWN - call brown_step(itime) -#else - print *,"Brown dynamics not here!" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) call statout(itime) -#ifdef VOUT - do j=1,3 - v_work(j)=d_t(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - v_work(ind)=d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - ind=ind+1 - v_work(ind)=d_t(j,i+nres) - enddo - endif - enddo - - write (66,'(80f10.5)') - & ((d_t(j,i),j=1,3),i=0,nres-1),((d_t(j,i+nres),j=1,3),i=1,nres) - do i=1,ind - v_transf(i)=0.0d0 - do j=1,ind - v_transf(i)=v_transf(i)+gvec(j,i)*v_work(j) - enddo - v_transf(i)= v_transf(i)*dsqrt(geigen(i)) - enddo - write (67,'(80f10.5)') (v_transf(i),i=1,ind) -#endif - endif - if (mod(itime,ntwx).eq.0) then - write (tytul,'("time",f8.2)') totT - if(mdpdb) then - call pdbout(potE,tytul,ipdb) - else - call cartout(totT) - endif - endif - if (rstcount.eq.1000.or.itime.eq.n_timestep) then - open(irest2,file=rest2name,status='unknown') - write(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - write (irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - close(irest2) - rstcount=0 - endif - enddo -#ifdef MPI - t_MD=MPI_Wtime()-tt0 -#else - t_MD=tcpu()-tt0 -#endif - write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') - & ' Timing ', - & 'MD calculations setup:',t_MDsetup, - & 'Energy & gradient evaluation:',t_enegrad, - & 'Stochastic MD setup:',t_langsetup, - & 'Stochastic MD step setup:',t_sdsetup, - & 'MD steps:',t_MD - write (iout,'(/28(1h=),a25,27(1h=))') - & ' End of MD calculation ' - return - end -c------------------------------------------------------------------------------- - subroutine velverlet_step(itime) -c------------------------------------------------------------------------------- -c Perform a single velocity Verlet step; the time step can be rescaled if -c increments in accelerations exceed the threshold -c------------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer ierror,ierrcode -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - include 'COMMON.MUCA' - double precision vcm(3),incr(3) - double precision cm(3),L(3) - integer ilen,count,rstcount - external ilen - character*50 tytul - integer maxcount_scale /20/ - common /gucio/ cm - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - integer itime - logical scale -c - scale=.true. - icount_scale=0 - if (lang.eq.1) then - call sddir_precalc - else if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call stochastic_force(stochforcvec) -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - itime_scal=0 - do while (scale) - icount_scale=icount_scale+1 - if (icount_scale.gt.maxcount_scale) then - write (iout,*) - & "ERROR: too many attempts at scaling down the time step. ", - & "amax=",amax,"epdrift=",epdrift, - & "damax=",damax,"edriftmax=",edriftmax, - & "d_time=",d_time - call flush(iout) -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,IERRCODE) -#endif - stop - endif -c First step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet1 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet1_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet1 - else - call verlet1 - endif -c Build the chain from the newly calculated coordinates - call chainbuild_cart - if (rattle) call rattle1 - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "Cartesian and internal coordinates: step 1" - call cartprint - call intout - write (iout,*) "dC" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo - write (iout,*) "Accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 1" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Calculate energy and forces - call zerograd - call etotal(potEcomp) - potE=potEcomp(0)-potEcomp(20) - call cartgrad -c Get the new accelerations - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Determine maximum acceleration and scale down the timestep if needed - call max_accel - amax=amax/(itime_scal+1)**2 - call predict_edrift(epdrift) - if (amax/(itime_scal+1).gt.damax .or. epdrift.gt.edriftmax) then -c Maximum acceleration or maximum predicted energy drift exceeded, rescale the time step - scale=.true. - ifac_time=dmax1(dlog(amax/damax),dlog(epdrift/edriftmax)) - & /dlog(2.0d0)+1 - itime_scal=itime_scal+ifac_time -c fac_time=dmin1(damax/amax,0.5d0) - fac_time=0.5d0**ifac_time - d_time=d_time*fac_time - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 -c write (iout,*) "Calling sd_verlet_setup: 1" -c Rescale the stochastic forces and recalculate or restore -c the matrices of tinker integrator - if (itime_scal.gt.maxflag_stoch) then - if (large) write (iout,'(a,i5,a)') - & "Calculate matrices for stochastic step;", - & " itime_scal ",itime_scal - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - write (iout,'(2a,i3,a,i3,1h.)') - & "Warning: cannot store matrices for stochastic", - & " integration because the index",itime_scal, - & " is greater than",maxflag_stoch - write (iout,'(2a)')"Increase MAXFLAG_STOCH or use direct", - & " integration Langevin algorithm for better efficiency." - else if (flag_stoch(itime_scal)) then - if (large) write (iout,'(a,i5,a,l1)') - & "Restore matrices for stochastic step; itime_scal ", - & itime_scal," flag ",flag_stoch(itime_scal) - do i=1,dimen - do j=1,dimen - pfric_mat(i,j)=pfric0_mat(i,j,itime_scal) - afric_mat(i,j)=afric0_mat(i,j,itime_scal) - vfric_mat(i,j)=vfric0_mat(i,j,itime_scal) - prand_mat(i,j)=prand0_mat(i,j,itime_scal) - vrand_mat1(i,j)=vrand0_mat1(i,j,itime_scal) - vrand_mat2(i,j)=vrand0_mat2(i,j,itime_scal) - enddo - enddo - else - if (large) write (iout,'(2a,i5,a,l1)') - & "Calculate & store matrices for stochastic step;", - & " itime_scal ",itime_scal," flag ",flag_stoch(itime_scal) - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - flag_stoch(ifac_time)=.true. - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,itime_scal)=pfric_mat(i,j) - afric0_mat(i,j,itime_scal)=afric_mat(i,j) - vfric0_mat(i,j,itime_scal)=vfric_mat(i,j) - prand0_mat(i,j,itime_scal)=prand_mat(i,j) - vrand0_mat1(i,j,itime_scal)=vrand_mat1(i,j) - vrand0_mat2(i,j,itime_scal)=vrand_mat2(i,j) - enddo - enddo - endif - fac_time=1.0d0/dsqrt(fac_time) - do i=1,dimen - stochforcvec(i)=fac_time*stochforcvec(i) - enddo -#endif - else if (lang.eq.1) then -c Rescale the accelerations due to stochastic forces - fac_time=1.0d0/dsqrt(fac_time) - do i=1,dimen - d_as_work(i)=d_as_work(i)*fac_time - enddo - endif - if (large) write (iout,'(a,i10,a,f8.6,a,i3,a,i3)') - & "itime",itime," Timestep scaled down to ", - & d_time," ifac_time",ifac_time," itime_scal",itime_scal - else -c Second step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet2 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet2_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet2 - else - call verlet2 - endif - if (rattle) call rattle2 - totT=totT+d_time - if (d_time.ne.d_time0) then - d_time=d_time0 -#ifndef LANG0 - if (lang.eq.2 .or. lang.eq.3) then - if (large) write (iout,'(a)') - & "Restore original matrices for stochastic step" -c write (iout,*) "Calling sd_verlet_setup: 2" -c Restore the matrices of tinker integrator if the time step has been restored - do i=1,dimen - do j=1,dimen - pfric_mat(i,j)=pfric0_mat(i,j,0) - afric_mat(i,j)=afric0_mat(i,j,0) - vfric_mat(i,j)=vfric0_mat(i,j,0) - prand_mat(i,j)=prand0_mat(i,j,0) - vrand_mat1(i,j)=vrand0_mat1(i,j,0) - vrand_mat2(i,j)=vrand0_mat2(i,j,0) - enddo - enddo - endif -#endif - endif - scale=.false. - endif - enddo -c Calculate the kinetic and the total energy and the kinetic temperature - call kinetic(EK) - totE=EK+potE -c diagnostics -c call kinetic1(EK1) -c write (iout,*) "step",itime," EK",EK," EK1",EK1 -c end diagnostics -c Couple the system to Berendsen bath if needed - if (tbf .and. lang.eq.0) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK -c Backup the coordinates, velocities, and accelerations - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, step 2" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif - return - end -c------------------------------------------------------------------------------- - subroutine RESPA_step(itime) -c------------------------------------------------------------------------------- -c Perform a single RESPA step. -c------------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer IERROR,ERRCODE -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision energia_short(0:n_ene), - & energia_long(0:n_ene) - double precision cm(3),L(3),vcm(3),incr(3) - double precision dc_old0(3,0:maxres2),d_t_old0(3,0:maxres2), - & d_a_old0(3,0:maxres2) - integer ilen,count,rstcount - external ilen - character*50 tytul - integer maxcount_scale /10/ - common /gucio/ cm - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - integer itime - logical scale - common /cipiszcze/ itt - itt=itime - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "***************** RESPA itime",itime - write (iout,*) "Cartesian and internal coordinates: step 0" -c call cartprint - call pdbout(0.0d0,"cipiszcze",iout) - call intout - write (iout,*) "Accelerations from long-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 0" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c -c Perform the initial RESPA step (increment velocities) -c write (iout,*) "*********************** RESPA ini" - call RESPA_vel - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, end" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c Compute the short-range forces -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif -C 7/2/2009 commented out -c call zerograd -c call etotal_short(energia_short) -c call cartgrad -c call lagrangian -C 7/2/2009 Copy accelerations due to short-lange forces from previous MD step - do i=0,2*nres - do j=1,3 - d_a(j,i)=d_a_short(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "energia_short",energia_short(0) - write (iout,*) "Accelerations from short-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo -c 6/30/08 A-MTS: attempt at increasing the split number - do i=0,2*nres - do j=1,3 - dc_old0(j,i)=dc_old(j,i) - d_t_old0(j,i)=d_t_old(j,i) - d_a_old0(j,i)=d_a_old(j,i) - enddo - enddo - if (ntime_split.gt.ntime_split0) ntime_split=ntime_split/2 - if (ntime_split.lt.ntime_split0) ntime_split=ntime_split0 -c - scale=.true. - d_time0=d_time - do while (scale) - - scale=.false. -c write (iout,*) "itime",itime," ntime_split",ntime_split -c Split the time step - d_time=d_time0/ntime_split -c Perform the short-range RESPA steps (velocity Verlet increments of -c positions and velocities using short-range forces) -c write (iout,*) "*********************** RESPA split" - do itsplit=1,ntime_split - if (lang.eq.1) then - call sddir_precalc - else if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call stochastic_force(stochforcvec) -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif -c First step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet1 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet1_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet1 - else - call verlet1 - endif -c Build the chain from the newly calculated coordinates - call chainbuild_cart - if (rattle) call rattle1 - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "***** ITSPLIT",itsplit - write (iout,*) "Cartesian and internal coordinates: step 1" - call pdbout(0.0d0,"cipiszcze",iout) -c call cartprint - call intout - write (iout,*) "Velocities, step 1" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Calculate energy and forces - call zerograd - call etotal_short(energia_short) - call cartgrad -c Get the new accelerations - call lagrangian -C 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array - do i=0,2*nres - do j=1,3 - d_a_short(j,i)=d_a(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*)"energia_short",energia_short(0) - write (iout,*) "Accelerations from short-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - endif -c 6/30/08 A-MTS -c Determine maximum acceleration and scale down the timestep if needed - call max_accel - amax=amax/ntime_split**2 - call predict_edrift(epdrift) - if (ntwe.gt.0 .and. large .and. mod(itime,ntwe).eq.0) - & write (iout,*) "amax",amax," damax",damax, - & " epdrift",epdrift," epdriftmax",epdriftmax -c Exit loop and try with increased split number if the change of -c acceleration is too big - if (amax.gt.damax .or. epdrift.gt.edriftmax) then - if (ntime_split.lt.maxtime_split) then - scale=.true. - ntime_split=ntime_split*2 - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc_old0(j,i) - d_t_old(j,i)=d_t_old0(j,i) - d_a_old(j,i)=d_a_old0(j,i) - enddo - enddo - write (iout,*) "acceleration/energy drift too large",amax, - & epdrift," split increased to ",ntime_split," itime",itime, - & " itsplit",itsplit - exit - else - write (iout,*) - & "Uh-hu. Bumpy landscape. Maximum splitting number", - & maxtime_split, - & " already reached!!! Trying to carry on!" - endif - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Second step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet2 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet2_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet2 - else - call verlet2 - endif - if (rattle) call rattle2 -c Backup the coordinates, velocities, and accelerations - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - enddo - - enddo ! while scale - -c Restore the time step - d_time=d_time0 -c Compute long-range forces -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_long(energia_long) - call cartgrad - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Compute accelerations from long-range forces - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "energia_long",energia_long(0) - write (iout,*) "Cartesian and internal coordinates: step 2" -c call cartprint - call pdbout(0.0d0,"cipiszcze",iout) - call intout - write (iout,*) "Accelerations from long-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 2" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c Compute the final RESPA step (increment velocities) -c write (iout,*) "*********************** RESPA fin" - call RESPA_vel -c Compute the complete potential energy - do i=0,n_ene - potEcomp(i)=energia_short(i)+energia_long(i) - enddo - potE=potEcomp(0)-potEcomp(20) -c potE=energia_short(0)+energia_long(0) - totT=totT+d_time -c Calculate the kinetic and the total energy and the kinetic temperature - call kinetic(EK) - totE=EK+potE -c Couple the system to Berendsen bath if needed - if (tbf .and. lang.eq.0) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK -c Backup the coordinates, velocities, and accelerations - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, end" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif - return - end -c--------------------------------------------------------------------- - subroutine RESPA_vel -c First and last RESPA step (incrementing velocities using long-range -c forces). - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - do j=1,3 - d_t(j,0)=d_t(j,0)+0.5d0*d_a(j,0)*d_time - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t(j,i)+0.5d0*d_a(j,i)*d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t(j,inres)+0.5d0*d_a(j,inres)*d_time - enddo - endif - enddo - return - end -c----------------------------------------------------------------- - subroutine verlet1 -c Applying velocity Verlet algorithm - step 1 to coordinates - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision adt,adt2 - -#ifdef DEBUG - write (iout,*) "VELVERLET1 START: DC" - do i=0,nres - write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo -#endif - do j=1,3 - adt=d_a_old(j,0)*d_time - adt2=0.5d0*adt - dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time - d_t_new(j,0)=d_t_old(j,0)+adt2 - d_t(j,0)=d_t_old(j,0)+adt - enddo - do i=nnt,nct-1 - do j=1,3 - adt=d_a_old(j,i)*d_time - adt2=0.5d0*adt - dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time - d_t_new(j,i)=d_t_old(j,i)+adt2 - d_t(j,i)=d_t_old(j,i)+adt - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - adt=d_a_old(j,inres)*d_time - adt2=0.5d0*adt - dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time - d_t_new(j,inres)=d_t_old(j,inres)+adt2 - d_t(j,inres)=d_t_old(j,inres)+adt - enddo - endif - enddo -#ifdef DEBUG - write (iout,*) "VELVERLET1 END: DC" - do i=0,nres - write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo -#endif - return - end -c--------------------------------------------------------------------- - subroutine verlet2 -c Step 2 of the velocity Verlet algorithm: update velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - do j=1,3 - d_t(j,0)=d_t_new(j,0)+0.5d0*d_a(j,0)*d_time - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+0.5d0*d_a(j,i)*d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+0.5d0*d_a(j,inres)*d_time - enddo - endif - enddo - return - end -c----------------------------------------------------------------- - subroutine sddir_precalc -c Applying velocity Verlet algorithm - step 1 to coordinates - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute friction and stochastic forces -c - call friction_force - call stochastic_force(stochforcvec) -c -c Compute the acceleration due to friction forces (d_af_work) and stochastic -c forces (d_as_work) -c - call ginv_mult(fric_work, d_af_work) - call ginv_mult(stochforcvec, d_as_work) - return - end -c--------------------------------------------------------------------- - subroutine sddir_verlet1 -c Applying velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' -c Revised 3/31/05 AL: correlation between random contributions to -c position and velocity increments included. - double precision sqrt13 /0.57735026918962576451d0/ ! 1/sqrt(3) - double precision adt,adt2 -c -c Add the contribution from BOTH friction and stochastic force to the -c coordinates, but ONLY the contribution from the friction forces to velocities -c - do j=1,3 - adt=(d_a_old(j,0)+d_af_work(j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(j)*d_time - dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time - d_t_new(j,0)=d_t_old(j,0)+0.5d0*adt - d_t(j,0)=d_t_old(j,0)+adt - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - adt=(d_a_old(j,i)+d_af_work(ind+j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time - dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time - d_t_new(j,i)=d_t_old(j,i)+0.5d0*adt - d_t(j,i)=d_t_old(j,i)+adt - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - adt=(d_a_old(j,inres)+d_af_work(ind+j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time - dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time - d_t_new(j,inres)=d_t_old(j,inres)+0.5d0*adt - d_t(j,inres)=d_t_old(j,inres)+adt - enddo - ind=ind+3 - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine sddir_verlet2 -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),d_as_work1(MAXRES6) - double precision cos60 /0.5d0/, sin60 /0.86602540378443864676d0/ -c Revised 3/31/05 AL: correlation between random contributions to -c position and velocity increments included. -c The correlation coefficients are calculated at low-friction limit. -c Also, friction forces are now not calculated with new velocities. - -c call friction_force - call stochastic_force(stochforcvec) -c -c Compute the acceleration due to friction forces (d_af_work) and stochastic -c forces (d_as_work) -c - call ginv_mult(stochforcvec, d_as_work1) - -c -c Update velocities -c - do j=1,3 - d_t(j,0)=d_t_new(j,0)+(0.5d0*(d_a(j,0)+d_af_work(j)) - & +sin60*d_as_work(j)+cos60*d_as_work1(j))*d_time - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+(0.5d0*(d_a(j,i)+d_af_work(ind+j)) - & +sin60*d_as_work(ind+j)+cos60*d_as_work1(ind+j))*d_time - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+(0.5d0*(d_a(j,inres) - & +d_af_work(ind+j))+sin60*d_as_work(ind+j) - & +cos60*d_as_work1(ind+j))*d_time - enddo - ind=ind+3 - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine max_accel -c -c Find the maximum difference in the accelerations of the the sites -c at the beginning and the end of the time step. -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - double precision aux(3),accel(3),accel_old(3),dacc - do j=1,3 -c aux(j)=d_a(j,0)-d_a_old(j,0) - accel_old(j)=d_a_old(j,0) - accel(j)=d_a(j,0) - enddo - amax=0.0d0 - do i=nnt,nct -c Backbone - if (i.lt.nct) then -c 7/3/08 changed to asymmetric difference - do j=1,3 -c accel(j)=aux(j)+0.5d0*(d_a(j,i)-d_a_old(j,i)) - accel_old(j)=accel_old(j)+0.5d0*d_a_old(j,i) - accel(j)=accel(j)+0.5d0*d_a(j,i) -c if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) - if (dabs(accel(j)).gt.dabs(accel_old(j))) then - dacc=dabs(accel(j)-accel_old(j)) - if (dacc.gt.amax) amax=dacc - endif - enddo - endif - enddo -c Side chains - do j=1,3 -c accel(j)=aux(j) - accel_old(j)=d_a_old(j,0) - accel(j)=d_a(j,0) - enddo - if (nnt.eq.2) then - do j=1,3 - accel_old(j)=accel_old(j)+d_a_old(j,1) - accel(j)=accel(j)+d_a(j,1) - enddo - endif - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 -c accel(j)=accel(j)+d_a(j,i+nres)-d_a_old(j,i+nres) - accel_old(j)=accel_old(j)+d_a_old(j,i+nres) - accel(j)=accel(j)+d_a(j,i+nres) - enddo - endif - do j=1,3 -c if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) - if (dabs(accel(j)).gt.dabs(accel_old(j))) then - dacc=dabs(accel(j)-accel_old(j)) - if (dacc.gt.amax) amax=dacc - endif - enddo - do j=1,3 - accel_old(j)=accel_old(j)+d_a_old(j,i) - accel(j)=accel(j)+d_a(j,i) -c aux(j)=aux(j)+d_a(j,i)-d_a_old(j,i) - enddo - enddo - return - end -c--------------------------------------------------------------------- - subroutine predict_edrift(epdrift) -c -c Predict the drift of the potential energy -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.MUCA' - double precision epdrift,epdriftij -c Drift of the potential energy - epdrift=0.0d0 - do i=nnt,nct -c Backbone - if (i.lt.nct) then - do j=1,3 - epdriftij=dabs((d_a(j,i)-d_a_old(j,i))*gcart(j,i)) - if (lmuca) epdriftij=epdriftij*factor -c write (iout,*) "back",i,j,epdriftij - if (epdriftij.gt.epdrift) epdrift=epdriftij - enddo - endif -c Side chains - if (itype(i).ne.10) then - do j=1,3 - epdriftij= - & dabs((d_a(j,i+nres)-d_a_old(j,i+nres))*gxcart(j,i)) - if (lmuca) epdriftij=epdriftij*factor -c write (iout,*) "side",i,j,epdriftij - if (epdriftij.gt.epdrift) epdrift=epdriftij - enddo - endif - enddo - epdrift=0.5d0*epdrift*d_time*d_time -c write (iout,*) "epdrift",epdrift - return - end -c----------------------------------------------------------------------- - subroutine verlet_bath -c -c Coupling to the thermostat by using the Berendsen algorithm -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision T_half,fact -c - T_half=2.0d0/(dimen3*Rb)*EK - fact=dsqrt(1.0d0+(d_time/tau_bath)*(t_bath/T_half-1.0d0)) -c write(iout,*) "T_half", T_half -c write(iout,*) "EK", EK -c write(iout,*) "fact", fact - do j=1,3 - d_t(j,0)=fact*d_t(j,0) - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=fact*d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=fact*d_t(j,inres) - enddo - endif - enddo - return - end -c--------------------------------------------------------- - subroutine init_MD -c Set up the initial conditions of a MD simulation - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MP - include 'mpif.h' - character*16 form - integer IERROR,ERRCODE -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.REMD' - real*8 energia_long(0:n_ene), - & energia_short(0:n_ene),vcm(3),incr(3) - double precision cm(3),L(3),xv,sigv,lowb,highb - double precision varia(maxvar) - character*256 qstr - integer ilen - external ilen - character*50 tytul - logical file_exist - common /gucio/ cm - d_time0=d_time -c write(iout,*) "d_time", d_time -c Compute the standard deviations of stochastic forces for Langevin dynamics -c if the friction coefficients do not depend on surface area - if (lang.gt.0 .and. .not.surfarea) then - do i=nnt,nct-1 - stdforcp(i)=stdfp*dsqrt(gamp) - enddo - do i=nnt,nct - stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamsc(itype(i))) - enddo - endif -c Open the pdb file for snapshotshots -#ifdef MPI - if(mdpdb) then - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".pdb") - open(ipdb, - & file=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".pdb") - else -#ifdef NOXDR - if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".x") - cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".x" -#else - if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".cx") - cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".cx" -#endif - endif -#else - if(mdpdb) then - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.pdb") - open(ipdb,file=prefix(:ilen(prefix))//"_MD.pdb") - else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.cx") - cartname=prefix(:ilen(prefix))//"_MD.cx" - endif -#endif - if (usampl) then - write (qstr,'(256(1h ))') - ipos=1 - do i=1,nfrag - iq = qinfrag(i,iset)*10 - iw = wfrag(i,iset)/100 - if (iw.gt.0) then - if(me.eq.king.or..not.out1file) - & write (iout,*) "Frag",qinfrag(i,iset),wfrag(i,iset),iq,iw - write (qstr(ipos:ipos+6),'(2h_f,i1,1h_,i1,1h_,i1)') i,iq,iw - ipos=ipos+7 - endif - enddo - do i=1,npair - iq = qinpair(i,iset)*10 - iw = wpair(i,iset)/100 - if (iw.gt.0) then - if(me.eq.king.or..not.out1file) - & write (iout,*) "Pair",i,qinpair(i,iset),wpair(i,iset),iq,iw - write (qstr(ipos:ipos+6),'(2h_p,i1,1h_,i1,1h_,i1)') i,iq,iw - ipos=ipos+7 - endif - enddo -c pdbname=pdbname(:ilen(pdbname)-4)//qstr(:ipos-1)//'.pdb' -#ifdef NOXDR -c cartname=cartname(:ilen(cartname)-2)//qstr(:ipos-1)//'.x' -#else -c cartname=cartname(:ilen(cartname)-3)//qstr(:ipos-1)//'.cx' -#endif -c statname=statname(:ilen(statname)-5)//qstr(:ipos-1)//'.stat' - endif - icg=1 - if (rest) then - if (restart1file) then - if (me.eq.king) - & inquire(file=mremd_rst_name,exist=file_exist) - write (*,*) me," Before broadcast: file_exist",file_exist - call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM, - & IERR) - write (*,*) me," After broadcast: file_exist",file_exist -c inquire(file=mremd_rst_name,exist=file_exist) - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial state read by master and distributed" - else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_' - & //liczba(:ilen(liczba))//'.rst') - inquire(file=rest2name,exist=file_exist) - endif - if(file_exist) then - if(.not.restart1file) then - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial state will be read from file ", - & rest2name(:ilen(rest2name)) - call readrst - endif - call rescale_weights(t_bath) - else - if(me.eq.king.or..not.out1file)then - if (restart1file) then - write(iout,*) "File ",mremd_rst_name(:ilen(mremd_rst_name)), - & " does not exist" - else - write(iout,*) "File ",rest2name(:ilen(rest2name)), - & " does not exist" - endif - write(iout,*) "Initial velocities randomly generated" - endif - call random_vel - totT=0.0d0 - endif - else -c Generate initial velocities - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial velocities randomly generated" - call random_vel - totT=0.0d0 - endif -c rest2name = prefix(:ilen(prefix))//'.rst' - if(me.eq.king.or..not.out1file)then - write(iout,*) "Initial backbone velocities" - do i=nnt,nct-1 - write(iout,*) (d_t(j,i),j=1,3) - enddo - write(iout,*) "Initial side-chain velocities" - do i=nnt,nct - write(iout,*) (d_t(j,i+nres),j=1,3) - enddo -c Zeroing the total angular momentum of the system - write(iout,*) "Calling the zero-angular - & momentum subroutine" - endif - call inertia_tensor -c Getting the potential energy and forces and velocities and accelerations - call vcm_vel(vcm) -c write (iout,*) "velocity of the center of the mass:" -c write (iout,*) (vcm(j),j=1,3) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo -c Removing the velocity of the center of mass - call vcm_vel(vcm) - if(me.eq.king.or..not.out1file)then - write (iout,*) "vcm right after adjustment:" - write (iout,*) (vcm(j),j=1,3) - endif - if (.not.rest) then - call chainbuild - if(iranconf.ne.0) then - if (overlapsc) then - print *, 'Calling OVERLAP_SC' - call overlap_sc(fail) - endif - - if (searchsc) then - call sc_move(2,nres-1,10,1d10,nft_sc,etot) - print *,'SC_move',nft_sc,etot - if(me.eq.king.or..not.out1file) - & write(iout,*) 'SC_move',nft_sc,etot - endif - - if(dccart)then - print *, 'Calling MINIM_DC' - call minim_dc(etot,iretcode,nfun) - else - call geom_to_var(nvar,varia) - print *,'Calling MINIMIZE.' - call minimize(etot,varia,iretcode,nfun) - call var_to_geom(nvar,varia) - endif - if(me.eq.king.or..not.out1file) - & write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun - endif - endif - call chainbuild_cart - call kinetic(EK) - if (tbf) then - call verlet_bath(EK) - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK - if(me.eq.king.or..not.out1file)then - call cartprint - call intout - endif - call zerograd - call etotal(potEcomp) - potE=potEcomp(0) - call cartgrad - call lagrangian - call max_accel - if (amax*d_time .gt. dvmax) then - d_time=d_time*dvmax/amax - if(me.eq.king.or..not.out1file) write (iout,*) - & "Time step reduced to",d_time, - & " because of too large initial acceleration." - endif - if(me.eq.king.or..not.out1file)then - write(iout,*) "Potential energy and its components" - write(iout,*) (potEcomp(i),i=0,n_ene) - endif - potE=potEcomp(0)-potEcomp(20) - totE=EK+potE - itime=0 - if (ntwe.ne.0) call statout(itime) - if(me.eq.king.or..not.out1file) - & write (iout,*) "Initial:", - & " Kinetic energy",EK," potential energy",potE, - & " total energy",totE," maximum acceleration ", - & amax - if (large) then - write (iout,*) "Initial coordinates" - do i=1,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(c(j,i),j=1,3), - & (c(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial dC" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial velocities" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial accelerations" - do i=0,nres -c write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - write (iout,'(i3,3f15.10,3x,3f15.10)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo -c write (iout,*) "dc_old",i,(dc_old(j,i),j=1,3) - enddo - if (RESPA) then -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_short(energia_short) - call cartgrad - call lagrangian - if(.not.out1file .and. large) then - write (iout,*) "energia_long",energia_long(0), - & " energia_short",energia_short(0), - & " total",energia_long(0)+energia_short(0) - write (iout,*) "Initial fast-force accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif -C 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array - do i=0,2*nres - do j=1,3 - d_a_short(j,i)=d_a(j,i) - enddo - enddo - call zerograd - call etotal_long(energia_long) - call cartgrad - call lagrangian - if(.not.out1file .and. large) then - write (iout,*) "energia_long",energia_long(0) - write (iout,*) "Initial slow-force accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - endif - return - end -c----------------------------------------------------------- - subroutine random_vel - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision xv,sigv,lowb,highb -c Generate random velocities from Gaussian distribution of mean 0 and std of KT/m -c First generate velocities in the eigenspace of the G matrix -c write (iout,*) "Calling random_vel dimen dimen3",dimen,dimen3 -c call flush(iout) - xv=0.0d0 - ii=0 - do i=1,dimen - do k=1,3 - ii=ii+1 - sigv=dsqrt((Rb*t_bath)/geigen(i)) - lowb=-5*sigv - highb=5*sigv - d_t_work_new(ii)=anorm_distr(xv,sigv,lowb,highb) -c write (iout,*) "ii",ii," d_t_work_new",d_t_work_new(ii) - enddo - enddo -c diagnostics -c Ek1=0.0d0 -c ii=0 -c do i=1,dimen -c do k=1,3 -c ii=ii+1 -c Ek1=Ek1+0.5d0*geigen(i)*d_t_work_new(ii)**2 -c enddo -c enddo -c write (iout,*) "Ek from eigenvectors",Ek1 -c end diagnostics -c Transform velocities to UNRES coordinate space - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - d_t_work(ind)=0.0d0 - do j=1,dimen - d_t_work(ind)=d_t_work(ind) - & +Gvec(i,j)*d_t_work_new((j-1)*3+k+1) - enddo -c write (iout,*) "i",i," ind",ind," d_t_work",d_t_work(ind) -c call flush(iout) - enddo - enddo -c Transfer to the d_t vector - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - d_t(j,i)=d_t_work(ind) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - ind=ind+1 - d_t(j,i+nres)=d_t_work(ind) - enddo - endif - enddo -c call kinetic(EK) -c write (iout,*) "Kinetic energy",Ek,EK1," kinetic temperature", -c & 2.0d0/(dimen3*Rb)*EK,2.0d0/(dimen3*Rb)*EK1 -c call flush(iout) - return - end -#ifndef LANG0 -c----------------------------------------------------------- - subroutine sd_verlet_p_setup -c Sets up the parameters of stochastic Verlet algorithm - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision emgdt(MAXRES6), - & pterm,vterm,rho,rhoc,vsig, - & pfric_vec(MAXRES6),vfric_vec(MAXRES6), - & afric_vec(MAXRES6),prand_vec(MAXRES6), - & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6) - logical lprn /.false./ - double precision zero /1.0d-8/, gdt_radius /0.05d0/ - double precision ktm -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c -c AL 8/17/04 Code adapted from tinker -c -c Get the frictional and random terms for stochastic dynamics in the -c eigenspace of mass-scaled UNRES friction matrix -c - do i = 1, dimen - gdt = fricgam(i) * d_time -c -c Stochastic dynamics reduces to simple MD for zero friction -c - if (gdt .le. zero) then - pfric_vec(i) = 1.0d0 - vfric_vec(i) = d_time - afric_vec(i) = 0.5d0 * d_time * d_time - prand_vec(i) = 0.0d0 - vrand_vec1(i) = 0.0d0 - vrand_vec2(i) = 0.0d0 -c -c Analytical expressions when friction coefficient is large -c - else - if (gdt .ge. gdt_radius) then - egdt = dexp(-gdt) - pfric_vec(i) = egdt - vfric_vec(i) = (1.0d0-egdt) / fricgam(i) - afric_vec(i) = (d_time-vfric_vec(i)) / fricgam(i) - pterm = 2.0d0*gdt - 3.0d0 + (4.0d0-egdt)*egdt - vterm = 1.0d0 - egdt**2 - rho = (1.0d0-egdt)**2 / sqrt(pterm*vterm) -c -c Use series expansions when friction coefficient is small -c - else - gdt2 = gdt * gdt - gdt3 = gdt * gdt2 - gdt4 = gdt2 * gdt2 - gdt5 = gdt2 * gdt3 - gdt6 = gdt3 * gdt3 - gdt7 = gdt3 * gdt4 - gdt8 = gdt4 * gdt4 - gdt9 = gdt4 * gdt5 - afric_vec(i) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0 - & - gdt5/120.0d0 + gdt6/720.0d0 - & - gdt7/5040.0d0 + gdt8/40320.0d0 - & - gdt9/362880.0d0) / fricgam(i)**2 - vfric_vec(i) = d_time - fricgam(i)*afric_vec(i) - pfric_vec(i) = 1.0d0 - fricgam(i)*vfric_vec(i) - pterm = 2.0d0*gdt3/3.0d0 - gdt4/2.0d0 - & + 7.0d0*gdt5/30.0d0 - gdt6/12.0d0 - & + 31.0d0*gdt7/1260.0d0 - gdt8/160.0d0 - & + 127.0d0*gdt9/90720.0d0 - vterm = 2.0d0*gdt - 2.0d0*gdt2 + 4.0d0*gdt3/3.0d0 - & - 2.0d0*gdt4/3.0d0 + 4.0d0*gdt5/15.0d0 - & - 4.0d0*gdt6/45.0d0 + 8.0d0*gdt7/315.0d0 - & - 2.0d0*gdt8/315.0d0 + 4.0d0*gdt9/2835.0d0 - rho = sqrt(3.0d0) * (0.5d0 - 3.0d0*gdt/16.0d0 - & - 17.0d0*gdt2/1280.0d0 - & + 17.0d0*gdt3/6144.0d0 - & + 40967.0d0*gdt4/34406400.0d0 - & - 57203.0d0*gdt5/275251200.0d0 - & - 1429487.0d0*gdt6/13212057600.0d0) - end if -c -c Compute the scaling factors of random terms for the nonzero friction case -c - ktm = 0.5d0*d_time/fricgam(i) - psig = dsqrt(ktm*pterm) / fricgam(i) - vsig = dsqrt(ktm*vterm) - rhoc = dsqrt(1.0d0 - rho*rho) - prand_vec(i) = psig - vrand_vec1(i) = vsig * rho - vrand_vec2(i) = vsig * rhoc - end if - end do - if (lprn) then - write (iout,*) - & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,", - & " vrand_vec2" - do i=1,dimen - write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i), - & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) - enddo - endif -c -c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables -c -#ifndef LANG0 - call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) - call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec1,vrand_mat1) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) -#endif -#ifdef MPI - t_sdsetup=t_sdsetup+MPI_Wtime() -#else - t_sdsetup=t_sdsetup+tcpu()-tt0 -#endif - return - end -c------------------------------------------------------------- - subroutine eigtransf1(n,ndim,ab,d,c) - implicit none - integer n,ndim - double precision ab(ndim,ndim,n),c(ndim,n),d(ndim) - integer i,j,k - do i=1,n - do j=1,n - c(i,j)=0.0d0 - do k=1,n - c(i,j)=c(i,j)+ab(k,j,i)*d(k) - enddo - enddo - enddo - return - end -c------------------------------------------------------------- - subroutine eigtransf(n,ndim,a,b,d,c) - implicit none - integer n,ndim - double precision a(ndim,n),b(ndim,n),c(ndim,n),d(ndim) - integer i,j,k - do i=1,n - do j=1,n - c(i,j)=0.0d0 - do k=1,n - c(i,j)=c(i,j)+a(i,k)*b(k,j)*d(k) - enddo - enddo - enddo - return - end -c------------------------------------------------------------- - subroutine sd_verlet1 -c Applying stochastic velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - logical lprn /.false./ - -c write (iout,*) "dc_old" -c do i=0,nres -c write (iout,'(i5,3f10.5,5x,3f10.5)') -c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) -c enddo - do j=1,3 - dc_work(j)=dc_old(j,0) - d_t_work(j)=d_t_old(j,0) - d_a_work(j)=d_a_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc_work(ind+j)=dc_old(j,i) - d_t_work(ind+j)=d_t_old(j,i) - d_a_work(ind+j)=d_a_old(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc_work(ind+j)=dc_old(j,i+nres) - d_t_work(ind+j)=d_t_old(j,i+nres) - d_a_work(ind+j)=d_a_old(j,i+nres) - enddo - ind=ind+3 - endif - enddo -#ifndef LANG0 - if (lprn) then - write (iout,*) - & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,", - & " vrand_mat2" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j), - & vfric_mat(i,j),afric_mat(i,j), - & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) - enddo - enddo - endif - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) - & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) - ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) - ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) - enddo - d_t_work_new(i)=ddt1+0.5d0*ddt2 - d_t_work(i)=ddt1+ddt2 - enddo -#endif - do j=1,3 - dc(j,0)=dc_work(j) - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_work(ind+j) - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_work(ind+j) - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c-------------------------------------------------------------------------- - subroutine sd_verlet2 -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute the stochastic forces which contribute to velocity change -c - call stochastic_force(stochforcvecV) - -#ifndef LANG0 - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) - ddt2=ddt2+vrand_mat1(i,j)*stochforcvec(j)+ - & vrand_mat2(i,j)*stochforcvecV(j) - enddo - d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 - enddo -#endif - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c----------------------------------------------------------- - subroutine sd_verlet_ciccotti_setup -c Sets up the parameters of stochastic velocity Verlet algorithmi; Ciccotti's -c version - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision emgdt(MAXRES6), - & pterm,vterm,rho,rhoc,vsig, - & pfric_vec(MAXRES6),vfric_vec(MAXRES6), - & afric_vec(MAXRES6),prand_vec(MAXRES6), - & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6) - logical lprn /.false./ - double precision zero /1.0d-8/, gdt_radius /0.05d0/ - double precision ktm -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c -c AL 8/17/04 Code adapted from tinker -c -c Get the frictional and random terms for stochastic dynamics in the -c eigenspace of mass-scaled UNRES friction matrix -c - do i = 1, dimen - write (iout,*) "i",i," fricgam",fricgam(i) - gdt = fricgam(i) * d_time -c -c Stochastic dynamics reduces to simple MD for zero friction -c - if (gdt .le. zero) then - pfric_vec(i) = 1.0d0 - vfric_vec(i) = d_time - afric_vec(i) = 0.5d0*d_time*d_time - prand_vec(i) = afric_vec(i) - vrand_vec2(i) = vfric_vec(i) -c -c Analytical expressions when friction coefficient is large -c - else - egdt = dexp(-gdt) - pfric_vec(i) = egdt - vfric_vec(i) = dexp(-0.5d0*gdt)*d_time - afric_vec(i) = 0.5d0*dexp(-0.25d0*gdt)*d_time*d_time - prand_vec(i) = afric_vec(i) - vrand_vec2(i) = vfric_vec(i) -c -c Compute the scaling factors of random terms for the nonzero friction case -c -c ktm = 0.5d0*d_time/fricgam(i) -c psig = dsqrt(ktm*pterm) / fricgam(i) -c vsig = dsqrt(ktm*vterm) -c prand_vec(i) = psig*afric_vec(i) -c vrand_vec2(i) = vsig*vfric_vec(i) - end if - end do - if (lprn) then - write (iout,*) - & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,", - & " vrand_vec2" - do i=1,dimen - write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i), - & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) - enddo - endif -c -c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables -c - call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) - call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) -#ifdef MPI - t_sdsetup=t_sdsetup+MPI_Wtime() -#else - t_sdsetup=t_sdsetup+tcpu()-tt0 -#endif - return - end -c------------------------------------------------------------- - subroutine sd_verlet1_ciccotti -c Applying stochastic velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - logical lprn /.false./ - -c write (iout,*) "dc_old" -c do i=0,nres -c write (iout,'(i5,3f10.5,5x,3f10.5)') -c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) -c enddo - do j=1,3 - dc_work(j)=dc_old(j,0) - d_t_work(j)=d_t_old(j,0) - d_a_work(j)=d_a_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc_work(ind+j)=dc_old(j,i) - d_t_work(ind+j)=d_t_old(j,i) - d_a_work(ind+j)=d_a_old(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc_work(ind+j)=dc_old(j,i+nres) - d_t_work(ind+j)=d_t_old(j,i+nres) - d_a_work(ind+j)=d_a_old(j,i+nres) - enddo - ind=ind+3 - endif - enddo - -#ifndef LANG0 - if (lprn) then - write (iout,*) - & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,", - & " vrand_mat2" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j), - & vfric_mat(i,j),afric_mat(i,j), - & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) - enddo - enddo - endif - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) - & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) - ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) - ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) - enddo - d_t_work_new(i)=ddt1+0.5d0*ddt2 - d_t_work(i)=ddt1+ddt2 - enddo -#endif - do j=1,3 - dc(j,0)=dc_work(j) - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_work(ind+j) - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_work(ind+j) - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c-------------------------------------------------------------------------- - subroutine sd_verlet2_ciccotti -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute the stochastic forces which contribute to velocity change -c - call stochastic_force(stochforcvecV) -#ifndef LANG0 - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - - ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) -c ddt2=ddt2+vrand_mat2(i,j)*stochforcvecV(j) - ddt2=ddt2+vrand_mat2(i,j)*stochforcvec(j) - enddo - d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 - enddo -#endif - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -#endif diff --git a/source/unres/src_MD-M-newcorr/MP.F b/source/unres/src_MD-M-newcorr/MP.F deleted file mode 100644 index 37bf5b9..0000000 --- a/source/unres/src_MD-M-newcorr/MP.F +++ /dev/null @@ -1,518 +0,0 @@ -#ifdef MPI - subroutine init_task - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - logical lprn /.false./ -c real*8 text1 /'group_i '/,text2/'group_f '/, -c & text3/'initialb'/,text4/'initiale'/, -c & text5/'openb'/,text6/'opene'/ - integer cgtasks(0:max_cg_procs) - character*3 cfgprocs - integer cg_size,fg_size,fg_size1 -c start parallel processing -c print *,'Initializing MPI' - call mpi_init(ierr) - if (ierr.ne.0) then - print *, ' cannot initialize MPI' - stop - endif -c determine # of nodes and current node - call MPI_Comm_rank( MPI_COMM_WORLD, me, ierr ) - if (ierr.ne.0) then - print *, ' cannot determine rank of all processes' - call MPI_Finalize( MPI_COMM_WORLD, IERR ) - stop - endif - call MPI_Comm_size( MPI_Comm_world, nodes, ierr ) - if (ierr.ne.0) then - print *, ' cannot determine number of processes' - stop - endif - Nprocs=nodes - MyRank=me -C Determine the number of "fine-grain" tasks - call getenv_loc("FGPROCS",cfgprocs) - read (cfgprocs,'(i3)') nfgtasks - if (nfgtasks.eq.0) nfgtasks=1 - call getenv_loc("MAXGSPROCS",cfgprocs) - read (cfgprocs,'(i3)') max_gs_size - if (max_gs_size.eq.0) max_gs_size=2 - if (lprn) - & print *,"Processor",me," nfgtasks",nfgtasks, - & " max_gs_size",max_gs_size - if (nfgtasks.eq.1) then - CG_COMM = MPI_COMM_WORLD - fg_size=1 - fg_rank=0 - nfgtasks1=1 - fg_rank1=0 - else - nodes=nprocs/nfgtasks - if (nfgtasks*nodes.ne.nprocs) then - write (*,'(a)') 'ERROR: Number of processors assigned', - & ' to coarse-grained tasks must be divisor', - & ' of the total number of processors.' - call MPI_Finalize( MPI_COMM_WORLD, IERR ) - stop - endif -C Put the ranks of coarse-grain processes in one table and create -C the respective communicator. The processes with ranks "in between" -C the ranks of CG processes will perform fine graining for the CG -C process with the next lower rank. - do i=0,nprocs-1,nfgtasks - cgtasks(i/nfgtasks)=i - enddo - if (lprn) then - print*,"Processor",me," cgtasks",(cgtasks(i),i=0,nodes-1) -c print "(a,i5,a)","Processor",myrank," Before MPI_Comm_group" - endif -c call memmon_print_usage() - call MPI_Comm_group(MPI_COMM_WORLD,world_group,IERR) - call MPI_Group_incl(world_group,nodes,cgtasks,cg_group,IERR) - call MPI_Comm_create(MPI_COMM_WORLD,cg_group,CG_COMM,IERR) - call MPI_Group_rank(cg_group,me,ierr) - call MPI_Group_free(world_group,ierr) - call MPI_Group_free(cg_group,ierr) -c print "(a,i5,a)","Processor",myrank," After MPI_Comm_group" -c call memmon_print_usage() - if (me.ne.MPI_UNDEFINED) call MPI_Comm_Rank(CG_COMM,me,ierr) - if (lprn) print *," Processor",myrank," CG rank",me -C Create communicators containig processes doing "fine grain" tasks. -C The processes within each FG_COMM should have fast communication. - kolor=MyRank/nfgtasks - key=mod(MyRank,nfgtasks) - call MPI_Comm_split(MPI_COMM_WORLD,kolor,key,FG_COMM,ierr) - call MPI_Comm_size(FG_COMM,fg_size,ierr) - if (fg_size.ne.nfgtasks) then - write (*,*) "OOOOps... the number of fg tasks is",fg_size, - & " but",nfgtasks," was requested. MyRank=",MyRank - endif - call MPI_Comm_rank(FG_COMM,fg_rank,ierr) - if (fg_size.gt.max_gs_size) then - kolor1=fg_rank/max_gs_size - key1=mod(fg_rank,max_gs_size) - call MPI_Comm_split(FG_COMM,kolor1,key1,FG_COMM1,ierr) - call MPI_Comm_size(FG_COMM1,nfgtasks1,ierr) - call MPI_Comm_rank(FG_COMM1,fg_rank1,ierr) - else - FG_COMM1=FG_COMM - nfgtasks1=nfgtasks - fg_rank1=fg_rank - endif - endif - if (lprn) then - if (fg_rank.eq.0) then - write (*,*) "Processor",MyRank," out of",nprocs, - & " rank in CG_COMM",me," size of CG_COMM",nodes, - & " size of FG_COMM",fg_size, - & " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1 - else - write (*,*) "Processor",MyRank," out of",nprocs, - & " rank in FG_COMM",fg_rank," size of FG_COMM",fg_size, - & " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1 - endif - endif -C Initialize other variables. -c print '(a)','Before initialize' -c call memmon_print_usage() - call initialize -c print '(a,i5,a)','Processor',myrank,' After initialize' -c call memmon_print_usage() -C Open task-dependent files. -c print '(a,i5,a)','Processor',myrank,' Before openunits' -c call memmon_print_usage() - call openunits -c print '(a,i5,a)','Processor',myrank,' After openunits' -c call memmon_print_usage() - if (me.eq.king .or. fg_rank.eq.0 .and. .not. out1file) - & write (iout,'(80(1h*)/a/80(1h*))') - & 'United-residue force field calculation - parallel job.' -c print *,"Processor",myrank," exited OPENUNITS" - return - end -C----------------------------------------------------------------------------- - subroutine finish_task - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.REMD' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TIME1' - include 'COMMON.MD' - integer ilen - external ilen -c - call MPI_Barrier(CG_COMM,ierr) - if (nfgtasks.gt.1) - & call MPI_Bcast(-1,1,MPI_INTEGER,king,FG_COMM,IERROR) - time1=MPI_WTIME() -c if (me.eq.king .or. .not. out1file) then - write (iout,'(a,i4,a)') 'CG processor',me,' is finishing work.' - write (iout,*) 'Total wall clock time',time1-walltime,' sec' - if (nfgtasks.gt.1) then - write (iout,'(80(1h=)/a/(80(1h=)))') - & "Details of FG communication time" - write (iout,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))') - & "BROADCAST:",time_bcast,"REDUCE:",time_reduce, - & "GATHER:",time_gather, - & "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv, - & "BARRIER ene",time_barrier_e, - & "BARRIER grad",time_barrier_g,"TOTAL:", - & time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv - & +time_barrier_e+time_barrier_g - write (*,*) 'Total wall clock time',time1-walltime,' sec' - write (*,*) "Processor",me," BROADCAST time",time_bcast, - & " REDUCE time", - & time_reduce," GATHER time",time_gather," SCATTER time", - & time_scatter," SENDRECV",time_sendrecv, - & " BARRIER ene",time_barrier_e," BARRIER grad",time_barrier_g - endif -c endif - write (*,'(a,i4,a)') 'CG processor',me,' is finishing work.' - if (ilen(tmpdir).gt.0) then - write (*,*) "Processor",me, - & ": moving output files to the parent directory..." - close(inp) - close(istat,status='keep') - if (ntwe.gt.0) call move_from_tmp(statname) - close(irest2,status='keep') - if (modecalc.eq.12.or. - & (modecalc.eq.14 .and. .not.restart1file)) then - call move_from_tmp(rest2name) - else if (modecalc.eq.14.and. me.eq.king) then - call move_from_tmp(mremd_rst_name) - endif - if (mdpdb) then - close(ipdb,status='keep') - call move_from_tmp(pdbname) - else if (me.eq.king .or. .not.traj1file) then - close(icart,status='keep') - call move_from_tmp(cartname) - endif - if (me.eq.king .or. .not. out1file) then - close (iout,status='keep') - call move_from_tmp(outname) - endif - endif - return - end -c------------------------------------------------------------------------- - subroutine pattern_receive - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.THREAD' - include 'COMMON.IOUNITS' - integer tag,status(MPI_STATUS_SIZE) - integer source,ThreadType - logical flag - ThreadType=45 - source=mpi_any_source - call mpi_iprobe(source,ThreadType, - & CG_COMM,flag,status,ierr) - do while (flag) - write (iout,*) 'Processor ',Me,' is receiving threading', - & ' pattern from processor',status(mpi_source) - write (*,*) 'Processor ',Me,' is receiving threading', - & ' pattern from processor',status(mpi_source) - nexcl=nexcl+1 - call mpi_irecv(iexam(1,nexcl),2,mpi_integer,status(mpi_source), - & ThreadType, CG_COMM,ireq,ierr) - write (iout,*) 'Received pattern:',nexcl,iexam(1,nexcl), - & iexam(2,nexcl) - source=mpi_any_source - call mpi_iprobe(source,ThreadType, - & CG_COMM,flag,status,ierr) - enddo - return - end -c---------------------------------------------------------------------------- - subroutine pattern_send - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.INFO' - include 'COMMON.THREAD' - include 'COMMON.IOUNITS' - integer source,ThreadType,ireq - ThreadType=45 - do iproc=0,nprocs-1 - if (iproc.ne.me .and. .not.Koniec(iproc) ) then - call mpi_isend(iexam(1,nexcl),2,mpi_integer,iproc, - & ThreadType, CG_COMM, ireq, ierr) - write (iout,*) 'CG processor ',me,' has sent pattern ', - & 'to processor',iproc - write (*,*) 'CG processor ',me,' has sent pattern ', - & 'to processor',iproc - write (iout,*) 'Pattern:',nexcl,iexam(1,nexcl),iexam(2,nexcl) - endif - enddo - return - end -c----------------------------------------------------------------------------- - subroutine send_stop_sig(Kwita) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.INFO' - include 'COMMON.IOUNITS' - integer StopType,StopId,iproc,Kwita,NBytes - StopType=66 -c Kwita=-1 -C print *,'CG processor',me,' StopType=',StopType - Koniec(me)=.true. - if (me.eq.king) then -C Master sends the STOP signal to everybody. - write (iout,'(a,a)') - & 'Master is sending STOP signal to other processors.' - do iproc=1,nprocs-1 - print *,'Koniec(',iproc,')=',Koniec(iproc) - if (.not. Koniec(iproc)) then - call mpi_send(Kwita,1,mpi_integer,iproc,StopType, - & mpi_comm_world,ierr) - write (iout,*) 'Iproc=',iproc,' StopID=',StopID - write (*,*) 'Iproc=',iproc,' StopID=',StopID - endif - enddo - else -C Else send the STOP signal to Master. - call mpi_send(Kwita,1,mpi_integer,MasterID,StopType, - & mpi_comm_world,ierr) - write (iout,*) 'CG processor=',me,' StopID=',StopID - write (*,*) 'CG processor=',me,' StopID=',StopID - endif - return - end -c----------------------------------------------------------------------------- - subroutine recv_stop_sig(Kwita) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.INFO' - include 'COMMON.IOUNITS' - integer source,StopType,StopId,iproc,Kwita - logical flag - StopType=66 - Kwita=0 - source=mpi_any_source -c print *,'CG processor:',me,' StopType=',StopType - call mpi_iprobe(source,StopType, - & mpi_comm_world,flag,status,ierr) - do while (flag) - Koniec(status(mpi_source))=.true. - write (iout,*) 'CG processor ',me,' is receiving STOP signal', - & ' from processor',status(mpi_source) - write (*,*) 'CG processor ',me,' is receiving STOP signal', - & ' from processor',status(mpi_source) - call mpi_irecv(Kwita,1,mpi_integer,status(mpi_source),StopType, - & mpi_comm_world,ireq,ierr) - call mpi_iprobe(source,StopType, - & mpi_comm_world,flag,status,ierr) - enddo - return - end -c----------------------------------------------------------------------------- - subroutine send_MCM_info(ione) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - integer tag,status(MPI_STATUS_SIZE) - integer MCM_info_Type,MCM_info_ID,iproc,one,NBytes - common /aaaa/ isend,irecv - integer nsend - save nsend - nsend=nsend+1 - MCM_info_Type=77 -cd write (iout,'(a,i4,a)') 'CG Processor',me, -cd & ' is sending MCM info to Master.' - write (*,'(a,i4,a,i8)') 'CG processor',me, - & ' is sending MCM info to Master, MCM_info_ID=',MCM_info_ID - call mpi_isend(ione,1,mpi_integer,MasterID, - & MCM_info_Type,mpi_comm_world, MCM_info_ID, ierr) -cd write (iout,*) 'CG processor',me,' has sent info to the master;', -cd & ' MCM_info_ID=',MCM_info_ID - write (*,*) 'CG processor',me,' has sent info to the master;', - & ' MCM_info_ID=',MCM_info_ID,' ierr ',ierr - isend=0 - irecv=0 - return - end -c---------------------------------------------------------------------------- - subroutine receive_MCM_info - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - integer tag,status(MPI_STATUS_SIZE) - integer source,MCM_info_Type,MCM_info_ID,iproc,ione - logical flag - MCM_info_Type=77 - source=mpi_any_source -c print *,'source=',source,' dontcare=',dontcare - call mpi_iprobe(source,MCM_info_Type, - & mpi_comm_world,flag,status,ierr) - do while (flag) - source=status(mpi_source) - itask=source/fgProcs+1 -cd write (iout,*) 'Master is receiving MCM info from processor ', -cd & source,' itask',itask - write (*,*) 'Master is receiving MCM info from processor ', - & source,' itask',itask - call mpi_irecv(ione,1,mpi_integer,source,MCM_info_type, - & mpi_comm_world,MCM_info_ID,ierr) -cd write (iout,*) 'Received from processor',source,' IONE=',ione - write (*,*) 'Received from processor',source,' IONE=',ione - nacc_tot=nacc_tot+1 - if (ione.eq.2) nsave_part(itask)=nsave_part(itask)+1 -cd print *,'nsave_part(',itask,')=',nsave_part(itask) -cd write (iout,*) 'Nacc_tot=',Nacc_tot -cd write (*,*) 'Nacc_tot=',Nacc_tot - source=mpi_any_source - call mpi_iprobe(source,MCM_info_Type, - & mpi_comm_world,flag,status,ierr) - enddo - return - end -c--------------------------------------------------------------------------- - subroutine send_thread_results - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.THREAD' - include 'COMMON.IOUNITS' - integer tag,status(MPI_STATUS_SIZE) - integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType, - & EnerID,msglen,nbytes - double precision buffer(20*maxthread+2) - ThreadType=444 - EnerType=555 - ipatt(1,nthread+1)=nthread - ipatt(2,nthread+1)=nexcl - do i=1,nthread - do j=1,n_ene - ener(j,i+nthread)=ener0(j,i) - enddo - enddo - ener(1,2*nthread+1)=max_time_for_thread - ener(2,2*nthread+1)=ave_time_for_thread -C Send the IPATT array - write (iout,*) 'CG processor',me, - & ' is sending IPATT array to master: NTHREAD=',nthread - write (*,*) 'CG processor',me, - & ' is sending IPATT array to master: NTHREAD=',nthread - msglen=2*nthread+2 - call mpi_send(ipatt(1,1),msglen,MPI_INTEGER,MasterID, - & ThreadType,mpi_comm_world,ierror) - write (iout,*) 'CG processor',me, - & ' has sent IPATT array to master MSGLEN',msglen - write (*,*) 'CG processor',me, - & ' has sent IPATT array to master MSGLEN',msglen -C Send the energies. - msglen=n_ene2*nthread+2 - write (iout,*) 'CG processor',me,' is sending energies to master.' - write (*,*) 'CG processor',me,' is sending energies to master.' - call mpi_send(ener(1,1),msglen,MPI_DOUBLE_PRECISION,MasterID, - & EnerType,mpi_comm_world,ierror) - write (iout,*) 'CG processor',me,' has sent energies to master.' - write (*,*) 'CG processor',me,' has sent energies to master.' - return - end -c---------------------------------------------------------------------------- - subroutine receive_thread_results(iproc) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.INFO' - include 'COMMON.THREAD' - include 'COMMON.IOUNITS' - integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType, - & EnerID,ReadyType,ReadyID,Ready,msglen,nbytes,nthread_temp - double precision buffer(20*maxthread+2),max_time_for_thread_t, - & ave_time_for_thread_t - logical flag - ThreadType=444 - EnerType=555 -C Receive the IPATT array - call mpi_probe(iproc,ThreadType, - & mpi_comm_world,status,ierr) - call MPI_GET_COUNT(STATUS, MPI_INTEGER, MSGLEN, IERROR) - write (iout,*) 'Master is receiving IPATT array from processor:', - & iproc,' MSGLEN',msglen - write (*,*) 'Master is receiving IPATT array from processor:', - & iproc,' MSGLEN',msglen - call mpi_recv(ipatt(1,nthread+1),msglen,mpi_integer,iproc, - & ThreadType, - & mpi_comm_world,status,ierror) - write (iout,*) 'Master has received IPATT array from processor:', - & iproc,' MSGLEN=',msglen - write (*,*) 'Master has received IPATT array from processor:', - & iproc,' MSGLEN=',msglen - nthread_temp=ipatt(1,nthread+msglen/2) - nexcl_temp=ipatt(2,nthread+msglen/2) -C Receive the energies. - call mpi_probe(iproc,EnerType, - & mpi_comm_world,status,ierr) - call MPI_GET_COUNT(STATUS, MPI_DOUBLE_PRECISION, MSGLEN, IERROR) - write (iout,*) 'Master is receiving energies from processor:', - & iproc,' MSGLEN=',MSGLEN - write (*,*) 'Master is receiving energies from processor:', - & iproc,' MSGLEN=',MSGLEN - call mpi_recv(ener(1,nthread+1),msglen, - & MPI_DOUBLE_PRECISION,iproc, - & EnerType,MPI_COMM_WORLD,status,ierror) - write (iout,*) 'Msglen=',Msglen - write (*,*) 'Msglen=',Msglen - write (iout,*) 'Master has received energies from processor',iproc - write (*,*) 'Master has received energies from processor',iproc - write (iout,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp - write (*,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp - do i=1,nthread_temp - do j=1,n_ene - ener0(j,nthread+i)=ener(j,nthread+nthread_temp+i) - enddo - enddo - max_time_for_thread_t=ener(1,nthread+2*nthread_temp+1) - ave_time_for_thread_t=ener(2,nthread+2*nthread_temp+1) - write (iout,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t - write (iout,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t - write (*,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t - write (*,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t - if (max_time_for_thread_t.gt.max_time_for_thread) - & max_time_for_thread=max_time_for_thread_t - ave_time_for_thread=(nthread*ave_time_for_thread+ - & nthread_temp*ave_time_for_thread_t)/(nthread+nthread_temp) - nthread=nthread+nthread_temp - return - end -#else - subroutine init_task - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SETUP' - me=0 - myrank=0 - fg_rank=0 - fg_size=1 - nodes=1 - nprocs=1 - call initialize - call openunits - write (iout,'(80(1h*)/a/80(1h*))') - & 'United-residue force field calculation - serial job.' - return - end -#endif diff --git a/source/unres/src_MD-M-newcorr/MREMD.F b/source/unres/src_MD-M-newcorr/MREMD.F deleted file mode 100644 index cac85aa..0000000 --- a/source/unres/src_MD-M-newcorr/MREMD.F +++ /dev/null @@ -1,1876 +0,0 @@ - subroutine MREMD - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.MUCA' - include 'COMMON.HAIRPIN' - integer ERRCODE - double precision cm(3),L(3),vcm(3) - double precision energia(0:n_ene) - double precision remd_t_bath(maxprocs) - integer iremd_iset(maxprocs) - integer*2 i_index - & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) - double precision remd_ene(0:n_ene+4,maxprocs) - integer iremd_acc(maxprocs),iremd_tot(maxprocs) - integer iremd_acc_usa(maxprocs),iremd_tot_usa(maxprocs) - integer ilen,rstcount - external ilen - character*50 tytul - common /gucio/ cm - integer itime -cold integer nup(0:maxprocs),ndown(0:maxprocs) - integer rep2i(0:maxprocs),ireqi(maxprocs) - integer icache_all(maxprocs) - integer status(MPI_STATUS_SIZE),statusi(MPI_STATUS_SIZE,maxprocs) - logical synflag,end_of_run,file_exist /.false./,ovrtim - -cdeb imin_itime_old=0 - ntwx_cache=0 - time00=MPI_WTIME() - time01=time00 - if(me.eq.king.or..not.out1file) then - write (iout,*) 'MREMD',nodes,'time before',time00-walltime - write (iout,*) "NREP=",nrep - endif - - synflag=.false. - if (ilen(tmpdir).gt.0 .and. (me.eq.king)) then - call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_mremd.rst") - endif - mremd_rst_name=prefix(:ilen(prefix))//"_mremd.rst" - -cd print *,'MREMD',nodes -cd print *,'mmm',me,remd_mlist,(remd_m(i),i=1,nrep) -cde write (iout,*) "Start MREMD: me",me," t_bath",t_bath - k=0 - rep2i(k)=-1 - do il=1,max0(nset,1) - do il1=1,max0(mset(il),1) - do i=1,nrep - iremd_acc(i)=0 - iremd_acc_usa(i)=0 - iremd_tot(i)=0 - do j=1,remd_m(i) - i2rep(k)=i - i2set(k)=il - rep2i(i)=k - k=k+1 - i_index(i,j,il,il1)=k - enddo - enddo - enddo - enddo - - if(me.eq.king.or..not.out1file) then - write(iout,*) (i2rep(i),i=0,nodes-1) - write(iout,*) (i2set(i),i=0,nodes-1) - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - write(iout,*) i,j,il,il1,i_index(i,j,il,il1) - enddo - enddo - enddo - enddo - endif - -c print *,'i2rep',me,i2rep(me) -c print *,'rep2i',(rep2i(i),i=0,nrep) - -cold if (i2rep(me).eq.nrep) then -cold nup(0)=0 -cold else -cold nup(0)=remd_m(i2rep(me)+1) -cold k=rep2i(int(i2rep(me)))+1 -cold do i=1,nup(0) -cold nup(i)=k -cold k=k+1 -cold enddo -cold endif - -cd print '(i4,a4,100i4)',me,' nup',(nup(i),i=0,nup(0)) - -cold if (i2rep(me).eq.1) then -cold ndown(0)=0 -cold else -cold ndown(0)=remd_m(i2rep(me)-1) -cold k=rep2i(i2rep(me)-2)+1 -cold do i=1,ndown(0) -cold ndown(i)=k -cold k=k+1 -cold enddo -cold endif - -cd print '(i4,a6,100i4)',me,' ndown',(ndown(i),i=0,ndown(0)) - - - write (*,*) "Processor",me," rest",rest," - & restart1fie",restart1file - if(rest.and.restart1file) then - if (me.eq.king) - & inquire(file=mremd_rst_name,exist=file_exist) -cd write (*,*) me," Before broadcast: file_exist",file_exist - call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM, - & IERR) -cd write (*,*) me," After broadcast: file_exist",file_exist - if(file_exist) then - if(me.eq.king.or..not.out1file) - & write (iout,*) 'Master is reading restart1file' - call read1restart(i_index) - else - if(me.eq.king.or..not.out1file) - & write (iout,*) 'WARNING : no restart1file' - endif - - if(me.eq.king.or..not.out1file) then - write(iout,*) "i2set",(i2set(i),i=0,nodes-1) - write(iout,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - write(iout,*) i,j,il,il1,i_index(i,j,il,il1) - enddo - enddo - enddo - enddo - endif - endif - - if(me.eq.king) then - if (rest.and..not.restart1file) - & inquire(file=mremd_rst_name,exist=file_exist) - if(.not.file_exist.and.rest.and..not.restart1file) - & write(iout,*) 'WARNING : no restart file',mremd_rst_name - IF (rest.and.file_exist.and..not.restart1file) THEN - write (iout,*) 'Master is reading restart file', - & mremd_rst_name - open(irest2,file=mremd_rst_name,status='unknown') - read (irest2,*) - read (irest2,*) (i2rep(i),i=0,nodes-1) - read (irest2,*) - read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - read (irest2,*) - read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - read (irest2,*) - read (irest2,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - if(usampl) then - read (irest2,*) - read (irest2,*) nset - read (irest2,*) - read (irest2,*) (mset(i),i=1,nset) - read (irest2,*) - read (irest2,*) (i2set(i),i=0,nodes-1) - read (irest2,*) - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - read(irest2,*) (i_index(i,j,il,il1),j=1,remd_m(i)) - enddo - enddo - enddo - - write(iout,*) "i2set",(i2set(i),i=0,nodes-1) - write(iout,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - write(iout,*) i,j,il,il1,i_index(i,j,il,il1) - enddo - enddo - enddo - enddo - endif - - close(irest2) - - write (iout,'(a6,1000i5)') "i2rep",(i2rep(i),i=0,nodes-1) - write (iout,'(a6,1000i5)') "ifirst", - & (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (iout,'(a6,i4,a1,100i4)') "nupa",il,":", - & (nupa(i,il),i=1,nupa(0,il)) - write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":", - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - ELSE IF (.not.(rest.and.file_exist)) THEN - do il=1,remd_m(1) - ifirst(il)=il - enddo - - do il=1,nodes - if (i2rep(il-1).eq.nrep) then - nupa(0,il)=0 - else - nupa(0,il)=remd_m(i2rep(il-1)+1) - k=rep2i(int(i2rep(il-1)))+1 - do i=1,nupa(0,il) - nupa(i,il)=k+1 - k=k+1 - enddo - endif - if (i2rep(il-1).eq.1) then - ndowna(0,il)=0 - else - ndowna(0,il)=remd_m(i2rep(il-1)-1) - k=rep2i(i2rep(il-1)-2)+1 - do i=1,ndowna(0,il) - ndowna(i,il)=k+1 - k=k+1 - enddo - endif - enddo - - write (iout,'(a6,100i4)') "ifirst", - & (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (iout,'(a6,i4,a1,100i4)') "nupa",il,":", - & (nupa(i,il),i=1,nupa(0,il)) - write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":", - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - - ENDIF - endif -c -c t_bath=retmin+(retmax-retmin)*me/(nodes-1) - if(.not.(rest.and.file_exist.and.restart1file)) then - if (me .eq. king) then - t_bath=retmin - else - t_bath=retmin+(retmax-retmin)*exp(float(i2rep(me)-nrep)) - endif -cd print *,'ttt',me,remd_tlist,(remd_t(i),i=1,nrep) - if (remd_tlist) t_bath=remd_t(int(i2rep(me))) - - endif - if(usampl) then - iset=i2set(me) - if(me.eq.king.or..not.out1file) - & write(iout,*) me,"iset=",iset,"t_bath=",t_bath - endif -c - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - -c print *,'irep',me,t_bath - if (.not.rest) then - if (me.eq.king .or. .not. out1file) - & write (iout,'(a60,f10.5)') "REMD Temperature:",t_bath - call rescale_weights(t_bath) - endif - - -c------copy MD-------------- -c The driver for molecular dynamics subroutines -c------------------------------------------------ - t_MDsetup=0.0d0 - t_langsetup=0.0d0 - t_MD=0.0d0 - t_enegrad=0.0d0 - t_sdsetup=0.0d0 - if(me.eq.king.or..not.out1file) - & write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Determine the inverse of the inertia matrix. - call setup_MD_matrices -c Initialize MD - call init_MD - if (rest) then - if (me.eq.king .or. .not. out1file) - & write (iout,'(a60,f10.5)') "REMD restart Temperature:",t_bath - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - call rescale_weights(t_bath) - endif - -#ifdef MPI - t_MDsetup = MPI_Wtime()-tt0 -#else - t_MDsetup = tcpu()-tt0 -#endif - rstcount=0 -c Entering the MD loop -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - time00=MPI_WTIME() - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'Setup time',time00-walltime - call flush(iout) -#ifdef MPI - t_langsetup=MPI_Wtime()-tt0 - tt0=MPI_Wtime() -#else - t_langsetup=tcpu()-tt0 - tt0=tcpu() -#endif - itime=0 - end_of_run=.false. - do while(.not.end_of_run) - itime=itime+1 - if(itime.eq.n_timestep.and.me.eq.king) end_of_run=.true. - if(mremdsync.and.itime.eq.n_timestep) end_of_run=.true. - rstcount=rstcount+1 - if (lang.gt.0 .and. surfarea .and. - & mod(itime,reset_fricmat).eq.0) then - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - write (iout,'(a,i10)') - & "Friction matrix reset based on surface area, itime",itime - endif - if (reset_vel .and. tbf .and. lang.eq.0 - & .and. mod(itime,count_reset_vel).eq.0) then - call random_vel - if (me.eq.king .or. .not. out1file) - & write(iout,'(a,f20.2)') - & "Velocities reset to random values, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - endif - if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then - call inertia_tensor - call vcm_vel(vcm) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen3*Rb)*EK - scalfac=dsqrt(T_bath/kinetic_T) -cd write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=scalfac*d_t(j,i) - enddo - enddo - endif - if (lang.ne.4) then - if (RESPA) then -c Time-reversible RESPA algorithm -c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) - call RESPA_step(itime) - else -c Variable time step algorithm. - call velverlet_step(itime) - endif - else -#ifdef BROWN - call brown_step(itime) -#else - print *,"Brown dynamics not here!" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - if(ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) call statout(itime) - endif - if (mod(itime,ntwx).eq.0.and..not.traj1file) then - write (tytul,'("time",f8.2," temp",f8.1)') totT,t_bath - if(mdpdb) then - call hairpin(.true.,nharp,iharp) - call secondary2(.true.) - call pdbout(potE,tytul,ipdb) - else - call cartout(totT) - endif - endif - if (mod(itime,ntwx).eq.0.and.traj1file) then - if(ntwx_cache.lt.max_cache_traj_use) then - ntwx_cache=ntwx_cache+1 - else - if (max_cache_traj_use.ne.1) - & print *,itime,"processor ",me," over cache ",ntwx_cache - do i=1,ntwx_cache-1 - - totT_cache(i)=totT_cache(i+1) - EK_cache(i)=EK_cache(i+1) - potE_cache(i)=potE_cache(i+1) - t_bath_cache(i)=t_bath_cache(i+1) - Uconst_cache(i)=Uconst_cache(i+1) - iset_cache(i)=iset_cache(i+1) - - do ii=1,nfrag - qfrag_cache(ii,i)=qfrag_cache(ii,i+1) - enddo - do ii=1,npair - qpair_cache(ii,i)=qpair_cache(ii,i+1) - enddo - do ii=1,nfrag_back - utheta_cache(ii,i)=utheta_cache(ii,i+1) - ugamma_cache(ii,i)=ugamma_cache(ii,i+1) - uscdiff_cache(ii,i)=uscdiff_cache(ii,i+1) - enddo - - - do ii=1,nres*2 - do j=1,3 - c_cache(j,ii,i)=c_cache(j,ii,i+1) - enddo - enddo - enddo - endif - - totT_cache(ntwx_cache)=totT - EK_cache(ntwx_cache)=EK - potE_cache(ntwx_cache)=potE - t_bath_cache(ntwx_cache)=t_bath - Uconst_cache(ntwx_cache)=Uconst - iset_cache(ntwx_cache)=iset - - do i=1,nfrag - qfrag_cache(i,ntwx_cache)=qfrag(i) - enddo - do i=1,npair - qpair_cache(i,ntwx_cache)=qpair(i) - enddo - do i=1,nfrag_back - utheta_cache(i,ntwx_cache)=utheta(i) - ugamma_cache(i,ntwx_cache)=ugamma(i) - uscdiff_cache(i,ntwx_cache)=uscdiff(i) - enddo - - do i=1,nres*2 - do j=1,3 - c_cache(j,i,ntwx_cache)=c(j,i) - enddo - enddo - - endif - if ((rstcount.eq.1000.or.itime.eq.n_timestep) - & .and..not.restart1file) then - - if(me.eq.king) then - open(irest1,file=mremd_rst_name,status='unknown') - write (irest1,*) "i2rep" - write (irest1,*) (i2rep(i),i=0,nodes-1) - write (irest1,*) "ifirst" - write (irest1,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (irest1,*) "nupa",il - write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - write (irest1,*) "ndowna",il - write (irest1,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - if(usampl) then - write (irest1,*) "nset" - write (irest1,*) nset - write (irest1,*) "mset" - write (irest1,*) (mset(i),i=1,nset) - write (irest1,*) "i2set" - write (irest1,*) (i2set(i),i=0,nodes-1) - write (irest1,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - write(irest1,*) (i_index(i,j,il,il1),j=1,remd_m(i)) - enddo - enddo - enddo - - endif - close(irest1) - endif - open(irest2,file=rest2name,status='unknown') - write(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - write (irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - if(usampl) then - write (irest2,*) iset - endif - close(irest2) - rstcount=0 - endif - -c REMD - exchange -c forced synchronization - if (mod(itime,i_sync_step).eq.0 .and. me.ne.king - & .and. .not. mremdsync) then - synflag=.false. - call mpi_iprobe(0,101,CG_COMM,synflag,status,ierr) - if (synflag) then - call mpi_recv(itime_master, 1, MPI_INTEGER, - & 0,101,CG_COMM, status, ierr) - call mpi_barrier(CG_COMM, ierr) -cdeb if (out1file.or.traj1file) then -cdeb call mpi_gather(itime,1,mpi_integer, -cdeb & icache_all,1,mpi_integer,king, -cdeb & CG_COMM,ierr) - if(traj1file) - & call mpi_gather(ntwx_cache,1,mpi_integer, - & icache_all,1,mpi_integer,king, - & CG_COMM,ierr) - if (.not.out1file) - & write(iout,*) 'REMD synchro at',itime_master,itime - if (itime_master.ge.n_timestep .or. ovrtim()) - & end_of_run=.true. -ctime call flush(iout) - endif - endif - -c REMD - exchange - if ((mod(itime,nstex).eq.0.and.me.eq.king - & .or.end_of_run.and.me.eq.king ) - & .and. .not. mremdsync ) then - synflag=.true. - do i=1,nodes-1 - call mpi_isend(itime,1,MPI_INTEGER,i,101, - & CG_COMM, ireqi(i), ierr) -cd write(iout,*) 'REMD synchro with',i -cd call flush(iout) - enddo - call mpi_waitall(nodes-1,ireqi,statusi,ierr) - call mpi_barrier(CG_COMM, ierr) - time01=MPI_WTIME() - write(iout,*) 'REMD synchro at',itime,'time=',time01-time00 - if (out1file.or.traj1file) then -cdeb call mpi_gather(itime,1,mpi_integer, -cdeb & itime_all,1,mpi_integer,king, -cdeb & CG_COMM,ierr) -cdeb write(iout,'(a19,8000i8)') ' REMD synchro itime', -cdeb & (itime_all(i),i=1,nodes) - if(traj1file) then -cdeb imin_itime=itime_all(1) -cdeb do i=2,nodes -cdeb if(itime_all(i).lt.imin_itime) imin_itime=itime_all(i) -cdeb enddo -cdeb ii_write=(imin_itime-imin_itime_old)/ntwx -cdeb imin_itime_old=int(imin_itime/ntwx)*ntwx -cdeb write(iout,*) imin_itime,imin_itime_old,ii_write - call mpi_gather(ntwx_cache,1,mpi_integer, - & icache_all,1,mpi_integer,king, - & CG_COMM,ierr) -c write(iout,'(a19,8000i8)') ' ntwx_cache', -c & (icache_all(i),i=1,nodes) - ii_write=icache_all(1) - do i=2,nodes - if(icache_all(i).lt.ii_write) ii_write=icache_all(i) - enddo -c write(iout,*) "MIN ii_write=",ii_write - endif - endif -ctime call flush(iout) - endif - if(mremdsync .and. mod(itime,nstex).eq.0) then - synflag=.true. - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'REMD synchro at',itime - - if(traj1file) then - call mpi_gather(ntwx_cache,1,mpi_integer, - & icache_all,1,mpi_integer,king, - & CG_COMM,ierr) - if (me.eq.king) then - write(iout,'(a19,8000i8)') ' ntwx_cache', - & (icache_all(i),i=1,nodes) - ii_write=icache_all(1) - do i=2,nodes - if(icache_all(i).lt.ii_write) ii_write=icache_all(i) - enddo - write(iout,*) "MIN ii_write=",ii_write - endif - endif - call flush(iout) - endif - if (synflag) then -c Update the time safety limiy - if (time001-time00.gt.safety) then - safety=time001-time00+600 - write (iout,*) "****** SAFETY increased to",safety," s" - endif - if (ovrtim()) end_of_run=.true. - endif - if(synflag.and..not.end_of_run) then - time02=MPI_WTIME() - synflag=.false. - - write(iout,*) 'REMD before',me,t_bath - -c call mpi_gather(t_bath,1,mpi_double_precision, -c & remd_t_bath,1,mpi_double_precision,king, -c & CG_COMM,ierr) - potEcomp(n_ene+1)=t_bath - if (usampl) then - potEcomp(n_ene+2)=iset - if (iset.lt.nset) then - i_set_temp=iset - iset=iset+1 - call EconstrQ - potEcomp(n_ene+3)=Uconst - iset=i_set_temp - endif - if (iset.gt.1) then - i_set_temp=iset - iset=iset-1 - call EconstrQ - potEcomp(n_ene+4)=Uconst - iset=i_set_temp - endif - endif - call mpi_gather(potEcomp(0),n_ene+5,mpi_double_precision, - & remd_ene(0,1),n_ene+5,mpi_double_precision,king, - & CG_COMM,ierr) - if(lmuca) then - call mpi_gather(elow,1,mpi_double_precision, - & elowi,1,mpi_double_precision,king, - & CG_COMM,ierr) - call mpi_gather(ehigh,1,mpi_double_precision, - & ehighi,1,mpi_double_precision,king, - & CG_COMM,ierr) - endif - - time03=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD gather times=',time03-time01 - & ,time03-time02 - endif - - if (restart1file) call write1rst(i_index) - - time04=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD writing rst time=',time04-time03 - endif - - if (traj1file) call write1traj -cd debugging -cdeb call mpi_gather(ntwx_cache,1,mpi_integer, -cdeb & icache_all,1,mpi_integer,king, -cdeb & CG_COMM,ierr) -cdeb write(iout,'(a19,8000i8)') ' ntwx_cache after traj1file', -cdeb & (icache_all(i),i=1,nodes) -cd end - - - time05=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD writing traj time=',time05-time04 - call flush(iout) - endif - - - if (me.eq.king) then - do i=1,nodes - remd_t_bath(i)=remd_ene(n_ene+1,i) - iremd_iset(i)=remd_ene(n_ene+2,i) - enddo - if(lmuca) then -co write(iout,*) 'REMD exchange temp,ene,elow,ehigh' - do i=1,nodes - write(iout,'(i4,4f12.5)') i,remd_t_bath(i),remd_ene(0,i), - & elowi(i),ehighi(i) - enddo - else - write(iout,*) 'REMD exchange temp,ene' - do i=1,nodes - write(iout,'(i4,2f12.5)') i,remd_t_bath(i),remd_ene(0,i) - write(iout,'(6f12.5)') (remd_ene(j,i),j=1,n_ene) - enddo - endif -c------------------------------------- - IF(.not.usampl) THEN - write (iout,*) "Enter exchnge, remd_m",remd_m(1), - & " nodes",nodes - call flush(iout) - write (iout,*) "remd_m(1)",remd_m(1) - do irr=1,remd_m(1) - i=ifirst(iran_num(1,remd_m(1))) - write (iout,*) "i",i - call flush(iout) - - do ii=1,nodes-1 - - write (iout,*) "i",i," nupa(0,i)",int(nupa(0,i)) - if(i.gt.0.and.nupa(0,i).gt.0) then - iex=i -c if (i.eq.1 .and. int(nupa(0,i)).eq.1) then -c write (iout,*) -c & "CHUJ ABSOLUTNY!!! No way to sample a distinct replica in MREMD" -c call flush(iout) -c call MPI_Abort(MPI_COMM_WORLD,ERRCODE,ierr) -c endif -c do while (iex.eq.i) -c write (iout,*) "upper",nupa(int(nupa(0,i)),i) - iex=nupa(iran_num(1,int(nupa(0,i))),i) -c enddo -c write (iout,*) "nupa(0,i)",nupa(0,i)," iex",iex - if (lmuca) then - call muca_delta(remd_t_bath,remd_ene,i,iex,delta) - else -c Swap temperatures between conformations i and iex with recalculating the free energies -c following temperature changes. - ene_iex_iex=remd_ene(0,iex) - ene_i_i=remd_ene(0,i) -c write (iout,*) "i",i," ene_i_i",ene_i_i, -c & " iex",iex," ene_iex_iex",ene_iex_iex -c write (iout,*) "rescaling weights with temperature", -c & remd_t_bath(i) -c call flush(iout) - call rescale_weights(remd_t_bath(i)) - -c write (iout,*) "0,iex",remd_t_bath(i) -c call enerprint(remd_ene(0,iex)) - - call sum_energy(remd_ene(0,iex),.false.) - ene_iex_i=remd_ene(0,iex) -c write (iout,*) "ene_iex_i",remd_ene(0,iex) - -c write (iout,*) "0,i",remd_t_bath(i) -c call enerprint(remd_ene(0,i)) - - call sum_energy(remd_ene(0,i),.false.) -c write (iout,*) "ene_i_i",remd_ene(0,i) -c call flush(iout) -c write (iout,*) "rescaling weights with temperature", -c & remd_t_bath(iex) - if (real(ene_i_i).ne.real(remd_ene(0,i))) then - write (iout,*) "ERROR: inconsistent energies:",i, - & ene_i_i,remd_ene(0,i) - endif - call rescale_weights(remd_t_bath(iex)) - -c write (iout,*) "0,i",remd_t_bath(iex) -c call enerprint(remd_ene(0,i)) - - call sum_energy(remd_ene(0,i),.false.) -c write (iout,*) "ene_i_iex",remd_ene(0,i) -c call flush(iout) - ene_i_iex=remd_ene(0,i) - -c write (iout,*) "0,iex",remd_t_bath(iex) -c call enerprint(remd_ene(0,iex)) - - call sum_energy(remd_ene(0,iex),.false.) - if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then - write (iout,*) "ERROR: inconsistent energies:",iex, - & ene_iex_iex,remd_ene(0,iex) - endif -c write (iout,*) "ene_iex_iex",remd_ene(0,iex) -c write (iout,*) "i",i," iex",iex -c write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, -c & " ene_i_iex",ene_i_iex, -c & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex -c call flush(iout) - delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- - & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) - delta=-delta -c write(iout,*) 'delta',delta -c delta=(remd_t_bath(i)-remd_t_bath(iex))* -c & (remd_ene(i)-remd_ene(iex))/Rb/ -c & (remd_t_bath(i)*remd_t_bath(iex)) - endif - if (delta .gt. 50.0d0) then - delta=0.0d0 - else -#ifdef OSF - if(isnan(delta))then - delta=0.0d0 - else if (delta.lt.-50.0d0) then - delta=dexp(50.0d0) - else - delta=dexp(-delta) - endif -#else - delta=dexp(-delta) -#endif - endif - iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 - xxx=ran_number(0.0d0,1.0d0) -c write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx -c call flush(iout) - if (delta .gt. xxx) then - tmp=remd_t_bath(i) - remd_t_bath(i)=remd_t_bath(iex) - remd_t_bath(iex)=tmp - remd_ene(0,i)=ene_i_iex - remd_ene(0,iex)=ene_iex_i - if(lmuca) then - tmp=elowi(i) - elowi(i)=elowi(iex) - elowi(iex)=tmp - tmp=ehighi(i) - ehighi(i)=ehighi(iex) - ehighi(iex)=tmp - endif - - - do k=0,nodes - itmp=nupa(k,i) - nupa(k,i)=nupa(k,iex) - nupa(k,iex)=itmp - itmp=ndowna(k,i) - ndowna(k,i)=ndowna(k,iex) - ndowna(k,iex)=itmp - enddo - do il=1,nodes - if (ifirst(il).eq.i) ifirst(il)=iex - do k=1,nupa(0,il) - if (nupa(k,il).eq.i) then - nupa(k,il)=iex - elseif (nupa(k,il).eq.iex) then - nupa(k,il)=i - endif - enddo - do k=1,ndowna(0,il) - if (ndowna(k,il).eq.i) then - ndowna(k,il)=iex - elseif (ndowna(k,il).eq.iex) then - ndowna(k,il)=i - endif - enddo - enddo - - iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 - itmp=i2rep(i-1) - i2rep(i-1)=i2rep(iex-1) - i2rep(iex-1)=itmp - -c write(iout,*) 'exchange',i,iex -c write (iout,'(a8,100i4)') "@ ifirst", -c & (ifirst(k),k=1,remd_m(1)) -c do il=1,nodes -c write (iout,'(a8,i4,a1,100i4)') "@ nupa",il,":", -c & (nupa(k,il),k=1,nupa(0,il)) -c write (iout,'(a8,i4,a1,100i4)') "@ ndowna",il,":", -c & (ndowna(k,il),k=1,ndowna(0,il)) -c enddo -c call flush(iout) - - else - remd_ene(0,iex)=ene_iex_iex - remd_ene(0,i)=ene_i_i - i=iex - endif - endif - enddo - enddo -cd write (iout,*) "exchange completed" -cd call flush(iout) - ELSE - do ii=1,nodes -cd write(iout,*) "########",ii - - i_temp=iran_num(1,nrep) - i_mult=iran_num(1,remd_m(i_temp)) - i_iset=iran_num(1,nset) - i_mset=iran_num(1,mset(i_iset)) - i=i_index(i_temp,i_mult,i_iset,i_mset) - -cd write(iout,*) "i=",i,i_temp,i_mult,i_iset,i_mset - - i_dir=iran_num(1,3) -cd write(iout,*) "i_dir=",i_dir - - if(i_dir.eq.1 .and. remd_m(i_temp+1).gt.0 )then - - i_temp1=i_temp+1 - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset - i_mset1=iran_num(1,mset(i_iset1)) - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - - elseif(i_dir.eq.2 .and. mset(i_iset+1).gt.0)then - - i_temp1=i_temp - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset+1 - i_mset1=iran_num(1,mset(i_iset1)) - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - econstr_temp_i=remd_ene(20,i) - econstr_temp_iex=remd_ene(20,iex) - remd_ene(20,i)=remd_ene(n_ene+3,i) - remd_ene(20,iex)=remd_ene(n_ene+4,iex) - - elseif(remd_m(i_temp+1).gt.0.and.mset(i_iset+1).gt.0)then - - i_temp1=i_temp+1 - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset+1 - i_mset1=iran_num(1,mset(i_iset1)) - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - econstr_temp_i=remd_ene(20,i) - econstr_temp_iex=remd_ene(20,iex) - remd_ene(20,i)=remd_ene(n_ene+3,i) - remd_ene(20,iex)=remd_ene(n_ene+4,iex) - - else - goto 444 - endif - -cd write(iout,*) "iex=",iex,i_temp1,i_mult1,i_iset1,i_mset1 - call flush(iout) - -c Swap temperatures between conformations i and iex with recalculating the free energies -c following temperature changes. - ene_iex_iex=remd_ene(0,iex) - ene_i_i=remd_ene(0,i) -co write (iout,*) "rescaling weights with temperature", -co & remd_t_bath(i) - call rescale_weights(remd_t_bath(i)) - - call sum_energy(remd_ene(0,iex),.false.) - ene_iex_i=remd_ene(0,iex) -cd write (iout,*) "ene_iex_i",remd_ene(0,iex) -c call sum_energy(remd_ene(0,i),.false.) -cd write (iout,*) "ene_i_i",remd_ene(0,i) -c write (iout,*) "rescaling weights with temperature", -c & remd_t_bath(iex) -c if (real(ene_i_i).ne.real(remd_ene(0,i))) then -c write (iout,*) "ERROR: inconsistent energies:",i, -c & ene_i_i,remd_ene(0,i) -c endif - call rescale_weights(remd_t_bath(iex)) - call sum_energy(remd_ene(0,i),.false.) -cd write (iout,*) "ene_i_iex",remd_ene(0,i) - ene_i_iex=remd_ene(0,i) -c call sum_energy(remd_ene(0,iex),.false.) -c if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then -c write (iout,*) "ERROR: inconsistent energies:",iex, -c & ene_iex_iex,remd_ene(0,iex) -c endif -cd write (iout,*) "ene_iex_iex",remd_ene(0,iex) -c write (iout,*) "i",i," iex",iex -cd write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, -cd & " ene_i_iex",ene_i_iex, -cd & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex - delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- - & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) - delta=-delta -cd write(iout,*) 'delta',delta -c delta=(remd_t_bath(i)-remd_t_bath(iex))* -c & (remd_ene(i)-remd_ene(iex))/Rb/ -c & (remd_t_bath(i)*remd_t_bath(iex)) - if (delta .gt. 50.0d0) then - delta=0.0d0 - else - delta=dexp(-delta) - endif - if (i_dir.eq.1.or.i_dir.eq.3) - & iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 - if (i_dir.eq.2.or.i_dir.eq.3) - & iremd_tot_usa(int(i2set(i-1)))= - & iremd_tot_usa(int(i2set(i-1)))+1 - xxx=ran_number(0.0d0,1.0d0) -cd write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx - if (delta .gt. xxx) then - tmp=remd_t_bath(i) - remd_t_bath(i)=remd_t_bath(iex) - remd_t_bath(iex)=tmp - - itmp=iremd_iset(i) - iremd_iset(i)=iremd_iset(iex) - iremd_iset(iex)=itmp - - remd_ene(0,i)=ene_i_iex - remd_ene(0,iex)=ene_iex_i - - if (i_dir.eq.1.or.i_dir.eq.3) - & iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 - - itmp=i2rep(i-1) - i2rep(i-1)=i2rep(iex-1) - i2rep(iex-1)=itmp - - if (i_dir.eq.2.or.i_dir.eq.3) - & iremd_acc_usa(int(i2set(i-1)))= - & iremd_acc_usa(int(i2set(i-1)))+1 - - itmp=i2set(i-1) - i2set(i-1)=i2set(iex-1) - i2set(iex-1)=itmp - - itmp=i_index(i_temp,i_mult,i_iset,i_mset) - i_index(i_temp,i_mult,i_iset,i_mset)= - & i_index(i_temp1,i_mult1,i_iset1,i_mset1) - i_index(i_temp1,i_mult1,i_iset1,i_mset1)=itmp - - else - remd_ene(0,iex)=ene_iex_iex - remd_ene(0,i)=ene_i_i - remd_ene(20,iex)=econstr_temp_iex - remd_ene(20,i)=econstr_temp_i - endif - -cd do il=1,nset -cd do il1=1,mset(il) -cd do i=1,nrep -cd do j=1,remd_m(i) -cd write(iout,*) i,j,il,il1,i_index(i,j,il,il1) -cd enddo -cd enddo -cd enddo -cd enddo - - 444 continue - - enddo - - - ENDIF - -c------------------------------------- - write (iout,*) "NREP",nrep - do i=1,nrep - if(iremd_tot(i).ne.0) - & write(iout,'(a3,i4,2f12.5,i5)') 'ACC',i,remd_t(i) - & ,iremd_acc(i)/(1.0*iremd_tot(i)),iremd_tot(i) - enddo - - if(usampl) then - do i=1,nset - if(iremd_tot_usa(i).ne.0) - & write(iout,'(a10,i4,f12.5,i8)') 'ACC_usampl',i, - & iremd_acc_usa(i)/(1.0*iremd_tot_usa(i)),iremd_tot_usa(i) - enddo - endif - - call flush(iout) - -cd write (iout,'(a6,100i4)') "ifirst", -cd & (ifirst(i),i=1,remd_m(1)) -cd do il=1,nodes -cd write (iout,'(a5,i4,a1,100i4)') "nup",il,":", -cd & (nupa(i,il),i=1,nupa(0,il)) -cd write (iout,'(a5,i4,a1,100i4)') "ndown",il,":", -cd & (ndowna(i,il),i=1,ndowna(0,il)) -cd enddo - endif - - time06=MPI_WTIME() -cd write (iout,*) "Before scatter" -cd call flush(iout) - call mpi_scatter(remd_t_bath,1,mpi_double_precision, - & t_bath,1,mpi_double_precision,king, - & CG_COMM,ierr) -cd write (iout,*) "After scatter" -cd call flush(iout) - if(usampl) - & call mpi_scatter(iremd_iset,1,mpi_integer, - & iset,1,mpi_integer,king, - & CG_COMM,ierr) - - time07=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD scatter time=',time07-time06 - endif - - if(lmuca) then - call mpi_scatter(elowi,1,mpi_double_precision, - & elow,1,mpi_double_precision,king, - & CG_COMM,ierr) - call mpi_scatter(ehighi,1,mpi_double_precision, - & ehigh,1,mpi_double_precision,king, - & CG_COMM,ierr) - endif - call rescale_weights(t_bath) -co write (iout,*) "Processor",me, -co & " rescaling weights with temperature",t_bath - - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - -cde write(iout,*) 'REMD after',me,t_bath - time08=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD exchange time=',time08-time00 - call flush(iout) - endif - endif - enddo - - if (restart1file) then - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'writing restart at the end of run' - call write1rst(i_index) - endif - - if (traj1file) call write1traj -cd debugging -cdeb call mpi_gather(ntwx_cache,1,mpi_integer, -cdeb & icache_all,1,mpi_integer,king, -cdeb & CG_COMM,ierr) -cdeb write(iout,'(a40,8000i8)') -cdeb & ' ntwx_cache after traj1file at the end', -cdeb & (icache_all(i),i=1,nodes) -cd end - - -#ifdef MPI - t_MD=MPI_Wtime()-tt0 -#else - t_MD=tcpu()-tt0 -#endif - if (me.eq.king .or. .not. out1file) then - write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') - & ' Timing ', - & 'MD calculations setup:',t_MDsetup, - & 'Energy & gradient evaluation:',t_enegrad, - & 'Stochastic MD setup:',t_langsetup, - & 'Stochastic MD step setup:',t_sdsetup, - & 'MD steps:',t_MD - write (iout,'(/28(1h=),a25,27(1h=))') - & ' End of MD calculation ' - endif - return - end - -c----------------------------------------------------------------------- - subroutine write1rst(i_index) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & d_restart2(3,2*maxres*maxprocs) - real t5_restart1(5) - integer iret,itmp - integer*2 i_index - & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) - common /przechowalnia/ d_restart1,d_restart2 - - t5_restart1(1)=totT - t5_restart1(2)=EK - t5_restart1(3)=potE - t5_restart1(4)=t_bath - t5_restart1(5)=Uconst - - call mpi_gather(t5_restart1,5,mpi_real, - & t_restart1,5,mpi_real,king,CG_COMM,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=d_t(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart1,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=dc(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart2,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - if(me.eq.king) then -#ifdef AIX - call xdrfopen_(ixdrf,mremd_rst_name, "w", iret) - do i=0,nodes-1 - call xdrfint_(ixdrf, i2rep(i), iret) - enddo - do i=1,remd_m(1) - call xdrfint_(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes - do i=0,nupa(0,il) - call xdrfint_(ixdrf, nupa(i,il), iret) - enddo - - do i=0,ndowna(0,il) - call xdrfint_(ixdrf, ndowna(i,il), iret) - enddo - enddo - - do il=1,nodes - do j=1,4 - call xdrffloat_(ixdrf, t_restart1(j,il), iret) - enddo - enddo - - do il=0,nodes-1 - do i=1,2*nres - do j=1,3 - call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) - enddo - enddo - enddo - do il=0,nodes-1 - do i=1,2*nres - do j=1,3 - call xdrffloat_(ixdrf, d_restart2(j,i+2*nres*il), iret) - enddo - enddo - enddo - - if(usampl) then - call xdrfint_(ixdrf, nset, iret) - do i=1,nset - call xdrfint_(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint_(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - itmp=i_index(i,j,il,il1) - call xdrfint_(ixdrf,itmp, iret) - enddo - enddo - enddo - enddo - - endif - call xdrfclose_(ixdrf, iret) -#else - call xdrfopen(ixdrf,mremd_rst_name, "w", iret) - do i=0,nodes-1 - call xdrfint(ixdrf, i2rep(i), iret) - enddo - do i=1,remd_m(1) - call xdrfint(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes - do i=0,nupa(0,il) - call xdrfint(ixdrf, nupa(i,il), iret) - enddo - - do i=0,ndowna(0,il) - call xdrfint(ixdrf, ndowna(i,il), iret) - enddo - enddo - - do il=1,nodes - do j=1,4 - call xdrffloat(ixdrf, t_restart1(j,il), iret) - enddo - enddo - - do il=0,nodes-1 - do i=1,2*nres - do j=1,3 - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) - enddo - enddo - enddo - do il=0,nodes-1 - do i=1,2*nres - do j=1,3 - call xdrffloat(ixdrf, d_restart2(j,i+2*nres*il), iret) - enddo - enddo - enddo - - - if(usampl) then - call xdrfint(ixdrf, nset, iret) - do i=1,nset - call xdrfint(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - itmp=i_index(i,j,il,il1) - call xdrfint(ixdrf,itmp, iret) - enddo - enddo - enddo - enddo - - endif - call xdrfclose(ixdrf, iret) -#endif - endif - return - end - - - subroutine write1traj - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - - real t5_restart1(5) - integer iret,itmp - real xcoord(3,maxres2+2),prec - real r_qfrag(50),r_qpair(100) - real r_utheta(50),r_ugamma(100),r_uscdiff(100) - real p_qfrag(50*maxprocs),p_qpair(100*maxprocs) - real p_utheta(50*maxprocs),p_ugamma(100*maxprocs), - & p_uscdiff(100*maxprocs) - real p_c(3,(maxres2+2)*maxprocs),r_c(3,maxres2+2) - common /przechowalnia/ p_c - - call mpi_bcast(ii_write,1,mpi_integer, - & king,CG_COMM,ierr) - -c debugging - print *,'traj1file',me,ii_write,ntwx_cache -c end debugging - -#ifdef AIX - if(me.eq.king) call xdrfopen_(ixdrf,cartname, "a", iret) -#else - if(me.eq.king) call xdrfopen(ixdrf,cartname, "a", iret) -#endif - do ii=1,ii_write - t5_restart1(1)=totT_cache(ii) - t5_restart1(2)=EK_cache(ii) - t5_restart1(3)=potE_cache(ii) - t5_restart1(4)=t_bath_cache(ii) - t5_restart1(5)=Uconst_cache(ii) - call mpi_gather(t5_restart1,5,mpi_real, - & t_restart1,5,mpi_real,king,CG_COMM,ierr) - - call mpi_gather(iset_cache(ii),1,mpi_integer, - & iset_restart1,1,mpi_integer,king,CG_COMM,ierr) - - do i=1,nfrag - r_qfrag(i)=qfrag_cache(i,ii) - enddo - do i=1,npair - r_qpair(i)=qpair_cache(i,ii) - enddo - do i=1,nfrag_back - r_utheta(i)=utheta_cache(i,ii) - r_ugamma(i)=ugamma_cache(i,ii) - r_uscdiff(i)=uscdiff_cache(i,ii) - enddo - - call mpi_gather(r_qfrag,nfrag,mpi_real, - & p_qfrag,nfrag,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(r_qpair,npair,mpi_real, - & p_qpair,npair,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(r_utheta,nfrag_back,mpi_real, - & p_utheta,nfrag_back,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(r_ugamma,nfrag_back,mpi_real, - & p_ugamma,nfrag_back,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(r_uscdiff,nfrag_back,mpi_real, - & p_uscdiff,nfrag_back,mpi_real,king, - & CG_COMM,ierr) - -#ifdef DEBUG - write (iout,*) "p_qfrag" - do i=1,nodes - write (iout,*) i,(p_qfrag((i-1)*nfrag+j),j=1,nfrag) - enddo - write (iout,*) "p_qpair" - do i=1,nodes - write (iout,*) i,(p_qpair((i-1)*npair+j),j=1,npair) - enddo - call flush(iout) -#endif - do i=1,nres*2 - do j=1,3 - r_c(j,i)=c_cache(j,i,ii) - enddo - enddo - - call mpi_gather(r_c,3*2*nres,mpi_real, - & p_c,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - if(me.eq.king) then -#ifdef AIX - do il=1,nodes - call xdrffloat_(ixdrf, real(t_restart1(1,il)), iret) - call xdrffloat_(ixdrf, real(t_restart1(3,il)), iret) - call xdrffloat_(ixdrf, real(t_restart1(5,il)), iret) - call xdrffloat_(ixdrf, real(t_restart1(4,il)), iret) - call xdrfint_(ixdrf, nss, iret) - do j=1,nss -C 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 - enddo - call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret) - call xdrfint_(ixdrf, iset_restart1(il), iret) - do i=1,nfrag - call xdrffloat_(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) - enddo - do i=1,npair - call xdrffloat_(ixdrf, p_qpair(i+(il-1)*npair), iret) - enddo - do i=1,nfrag_back - call xdrffloat_(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret) - call xdrffloat_(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret) - call xdrffloat_(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret) - enddo - prec=10000.0 - do i=1,nres - do j=1,3 - xcoord(j,i)=p_c(j,i+(il-1)*nres*2) - enddo - enddo - do i=nnt,nct - do j=1,3 - xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) - enddo - enddo - itmp=nres+nct-nnt+1 - call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret) - enddo -#else - do il=1,nodes - call xdrffloat(ixdrf, real(t_restart1(1,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(3,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(5,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(4,il)), iret) - call xdrfint(ixdrf, nss, iret) - do j=1,nss - if (dyn_ss) then - call xdrfint(ixdrf, idssb(j)+nres, iret) - call xdrfint(ixdrf, jdssb(j)+nres, iret) - else - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - endif - enddo - call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret) - call xdrfint(ixdrf, iset_restart1(il), iret) - do i=1,nfrag - call xdrffloat(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) - enddo - do i=1,npair - call xdrffloat(ixdrf, p_qpair(i+(il-1)*npair), iret) - enddo - do i=1,nfrag_back - call xdrffloat(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret) - call xdrffloat(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret) - call xdrffloat(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret) - enddo - prec=10000.0 - do i=1,nres - do j=1,3 - xcoord(j,i)=p_c(j,i+(il-1)*nres*2) - enddo - enddo - do i=nnt,nct - do j=1,3 - xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) - enddo - enddo - itmp=nres+nct-nnt+1 - call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) - enddo -#endif - endif - enddo -#ifdef AIX - if(me.eq.king) call xdrfclose_(ixdrf, iret) -#else - if(me.eq.king) call xdrfclose(ixdrf, iret) -#endif - do i=1,ntwx_cache-ii_write - - totT_cache(i)=totT_cache(ii_write+i) - EK_cache(i)=EK_cache(ii_write+i) - potE_cache(i)=potE_cache(ii_write+i) - t_bath_cache(i)=t_bath_cache(ii_write+i) - Uconst_cache(i)=Uconst_cache(ii_write+i) - iset_cache(i)=iset_cache(ii_write+i) - - do ii=1,nfrag - qfrag_cache(ii,i)=qfrag_cache(ii,ii_write+i) - enddo - do ii=1,npair - qpair_cache(ii,i)=qpair_cache(ii,ii_write+i) - enddo - do ii=1,nfrag_back - utheta_cache(ii,i)=utheta_cache(ii,ii_write+i) - ugamma_cache(ii,i)=ugamma_cache(ii,ii_write+i) - uscdiff_cache(ii,i)=uscdiff_cache(ii,ii_write+i) - enddo - - do ii=1,nres*2 - do j=1,3 - c_cache(j,ii,i)=c_cache(j,ii,ii_write+i) - enddo - enddo - enddo - ntwx_cache=ntwx_cache-ii_write - return - end - - - subroutine read1restart(i_index) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & t5_restart1(5) - integer*2 i_index - & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) - common /przechowalnia/ d_restart1 - write (*,*) "Processor",me," called read1restart" - - if(me.eq.king)then - open(irest2,file=mremd_rst_name,status='unknown') - read(irest2,*,err=334) i - write(iout,*) "Reading old rst in ASCI format" - close(irest2) - call read1restart_old - return - 334 continue -#ifdef AIX - call xdrfopen_(ixdrf,mremd_rst_name, "r", iret) - - do i=0,nodes-1 - call xdrfint_(ixdrf, i2rep(i), iret) - enddo - do i=1,remd_m(1) - call xdrfint_(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes - call xdrfint_(ixdrf, nupa(0,il), iret) - do i=1,nupa(0,il) - call xdrfint_(ixdrf, nupa(i,il), iret) - enddo - - call xdrfint_(ixdrf, ndowna(0,il), iret) - do i=1,ndowna(0,il) - call xdrfint_(ixdrf, ndowna(i,il), iret) - enddo - enddo - do il=1,nodes - do j=1,4 - call xdrffloat_(ixdrf, t_restart1(j,il), iret) - enddo - enddo -#else - call xdrfopen(ixdrf,mremd_rst_name, "r", iret) - - do i=0,nodes-1 - call xdrfint(ixdrf, i2rep(i), iret) - enddo - do i=1,remd_m(1) - call xdrfint(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes - call xdrfint(ixdrf, nupa(0,il), iret) - do i=1,nupa(0,il) - call xdrfint(ixdrf, nupa(i,il), iret) - enddo - - call xdrfint(ixdrf, ndowna(0,il), iret) - do i=1,ndowna(0,il) - call xdrfint(ixdrf, ndowna(i,il), iret) - enddo - enddo - do il=1,nodes - do j=1,4 - call xdrffloat(ixdrf, t_restart1(j,il), iret) - enddo - enddo -#endif - endif - call mpi_scatter(t_restart1,5,mpi_real, - & t5_restart1,5,mpi_real,king,CG_COMM,ierr) - totT=t5_restart1(1) - EK=t5_restart1(2) - potE=t5_restart1(3) - t_bath=t5_restart1(4) - - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres -c read(irest2,'(3e15.5)') -c & (d_restart1(j,i+2*nres*il),j=1,3) - do j=1,3 -#ifdef AIX - call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) -#else - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) -#endif - enddo - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - - do i=1,2*nres - do j=1,3 - d_t(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres -c read(irest2,'(3e15.5)') -c & (d_restart1(j,i+2*nres*il),j=1,3) - do j=1,3 -#ifdef AIX - call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) -#else - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) -#endif - enddo - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - do i=1,2*nres - do j=1,3 - dc(j,i)=r_d(j,i) - enddo - enddo - - - if(usampl) then -#ifdef AIX - if(me.eq.king)then - call xdrfint_(ixdrf, nset, iret) - do i=1,nset - call xdrfint_(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint_(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - call xdrfint_(ixdrf,itmp, iret) - i_index(i,j,il,il1)=itmp - enddo - enddo - enddo - enddo - endif -#else - if(me.eq.king)then - call xdrfint(ixdrf, nset, iret) - do i=1,nset - call xdrfint(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - call xdrfint(ixdrf,itmp, iret) - i_index(i,j,il,il1)=itmp - enddo - enddo - enddo - enddo - endif -#endif - call mpi_scatter(i2set,1,mpi_integer, - & iset,1,mpi_integer,king, - & CG_COMM,ierr) - - endif - - - if(me.eq.king) close(irest2) - return - end - - subroutine read1restart_old - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & t5_restart1(5) - common /przechowalnia/ d_restart1 - if(me.eq.king)then - open(irest2,file=mremd_rst_name,status='unknown') - read (irest2,*) (i2rep(i),i=0,nodes-1) - read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - read (irest2,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - do il=1,nodes - read(irest2,*) (t_restart1(j,il),j=1,4) - enddo - endif - call mpi_scatter(t_restart1,5,mpi_real, - & t5_restart1,5,mpi_real,king,CG_COMM,ierr) - totT=t5_restart1(1) - EK=t5_restart1(2) - potE=t5_restart1(3) - t_bath=t5_restart1(4) - - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres - read(irest2,'(3e15.5)') - & (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - - do i=1,2*nres - do j=1,3 - d_t(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres - read(irest2,'(3e15.5)') - & (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - do i=1,2*nres - do j=1,3 - dc(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king) close(irest2) - return - end - diff --git a/source/unres/src_MD-M-newcorr/MREMD.F.drabinka b/source/unres/src_MD-M-newcorr/MREMD.F.drabinka deleted file mode 100644 index 5b4c997..0000000 --- a/source/unres/src_MD-M-newcorr/MREMD.F.drabinka +++ /dev/null @@ -1,1199 +0,0 @@ - subroutine MREMD - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.MUCA' - double precision cm(3),L(3),vcm(3) - double precision energia(0:n_ene) - double precision remd_t_bath(maxprocs) - double precision remd_ene(0:n_ene+1,maxprocs) - integer iremd_acc(maxprocs),iremd_tot(maxprocs) - integer ilen,rstcount - external ilen - character*50 tytul - common /gucio/ cm - integer itime -cold integer nup(0:maxprocs),ndown(0:maxprocs) - integer rep2i(0:maxprocs),ireqi(maxprocs) - integer itime_all(maxprocs) - integer status(MPI_STATUS_SIZE),statusi(MPI_STATUS_SIZE,maxprocs) - logical synflag,end_of_run,file_exist - - time00=MPI_WTIME() - if(me.eq.king.or..not.out1file) - & write (iout,*) 'MREMD',nodes,'time before',time00-walltime - - synflag=.false. - mremd_rst_name=prefix(:ilen(prefix))//"_mremd.rst" - -cd print *,'MREMD',nodes - -cd print *,'mmm',me,remd_mlist,(remd_m(i),i=1,nrep) - -cde write (iout,*) "Start MREMD: me",me," t_bath",t_bath - k=0 - rep2i(k)=-1 - do i=1,nrep - iremd_acc(i)=0 - iremd_tot(i)=0 - do j=1,remd_m(i) - i2rep(k)=i - rep2i(i)=k - k=k+1 - enddo - enddo - -c print *,'i2rep',me,i2rep(me) -c print *,'rep2i',(rep2i(i),i=0,nrep) - -cold if (i2rep(me).eq.nrep) then -cold nup(0)=0 -cold else -cold nup(0)=remd_m(i2rep(me)+1) -cold k=rep2i(int(i2rep(me)))+1 -cold do i=1,nup(0) -cold nup(i)=k -cold k=k+1 -cold enddo -cold endif - -cd print '(i4,a4,100i4)',me,' nup',(nup(i),i=0,nup(0)) - -cold if (i2rep(me).eq.1) then -cold ndown(0)=0 -cold else -cold ndown(0)=remd_m(i2rep(me)-1) -cold k=rep2i(i2rep(me)-2)+1 -cold do i=1,ndown(0) -cold ndown(i)=k -cold k=k+1 -cold enddo -cold endif - -cd print '(i4,a6,100i4)',me,' ndown',(ndown(i),i=0,ndown(0)) - - - if(rest.and.restart1file) then - inquire(file=mremd_rst_name,exist=file_exist) - if(file_exist) call read1restart - endif - - if(me.eq.king) then - if (rest.and..not.restart1file) - & inquire(file=mremd_rst_name,exist=file_exist) - IF (rest.and.file_exist.and..not.restart1file) THEN - open(irest2,file=mremd_rst_name,status='unknown') - read (irest2,*) - read (irest2,*) (i2rep(i),i=0,nodes-1) - read (irest2,*) - read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - read (irest2,*) - read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - read (irest2,*) - read (irest2,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - close(irest2) - - write (iout,'(a6,1000i5)') "i2rep",(i2rep(i),i=0,nodes-1) - write (iout,'(a6,1000i5)') "ifirst", - & (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (iout,'(a6,i4,a1,100i4)') "nupa",il,":", - & (nupa(i,il),i=1,nupa(0,il)) - write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":", - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - ELSE IF (.not.(rest.and.file_exist)) THEN - do il=1,remd_m(1) - ifirst(il)=il - enddo - - do il=1,nodes - - if (i2rep(il-1).eq.nrep) then - nupa(0,il)=0 - else - nupa(0,il)=remd_m(i2rep(il-1)+1) - k=rep2i(int(i2rep(il-1)))+1 - do i=1,nupa(0,il) - nupa(i,il)=k+1 - k=k+1 - enddo - endif - - if (i2rep(il-1).eq.1) then - ndowna(0,il)=0 - else - ndowna(0,il)=remd_m(i2rep(il-1)-1) - k=rep2i(i2rep(il-1)-2)+1 - do i=1,ndowna(0,il) - ndowna(i,il)=k+1 - k=k+1 - enddo - endif - - enddo - -c write (iout,'(a6,100i4)') "ifirst", -c & (ifirst(i),i=1,remd_m(1)) -c do il=1,nodes -c write (iout,'(a6,i4,a1,100i4)') "nupa",il,":", -c & (nupa(i,il),i=1,nupa(0,il)) -c write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":", -c & (ndowna(i,il),i=1,ndowna(0,il)) -c enddo - - ENDIF - endif -c -c t_bath=retmin+(retmax-retmin)*me/(nodes-1) - if(.not.(rest.and.file_exist.and.restart1file)) then - if (me .eq. king) then - t_bath=retmin - else - t_bath=retmin+(retmax-retmin)*exp(float(i2rep(me)-nrep)) - endif -cd print *,'ttt',me,remd_tlist,(remd_t(i),i=1,nrep) - if (remd_tlist) t_bath=remd_t(int(i2rep(me))) - endif -c - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - -c print *,'irep',me,t_bath - if (.not.rest) then - if (me.eq.king .or. .not. out1file) - & write (iout,'(a60,f10.5)') "REMD Temperature:",t_bath - call rescale_weights(t_bath) - endif - - -c------copy MD-------------- -c The driver for molecular dynamics subroutines -c------------------------------------------------ - t_MDsetup=0.0d0 - t_langsetup=0.0d0 - t_MD=0.0d0 - t_enegrad=0.0d0 - t_sdsetup=0.0d0 - if(me.eq.king.or..not.out1file) - & write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" - tt0 = tcpu() -c Determine the inverse of the inertia matrix. - call setup_MD_matrices -c Initialize MD - call init_MD - if (rest) then - if (me.eq.king .or. .not. out1file) - & write (iout,'(a60,f10.5)') "REMD restart Temperature:",t_bath - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - call rescale_weights(t_bath) - endif - - t_MDsetup = tcpu()-tt0 - rstcount=0 -c Entering the MD loop - tt0 = tcpu() - if (lang.eq.2 .or. lang.eq.3) then - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo -#endif - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - time00=MPI_WTIME() - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'Setup time',time00-walltime - call flush(iout) - t_langsetup=tcpu()-tt0 - tt0=tcpu() - itime=0 - end_of_run=.false. - do while(.not.end_of_run) - itime=itime+1 - if(itime.eq.n_timestep.and.me.eq.king) end_of_run=.true. - if(mremdsync.and.itime.eq.n_timestep) end_of_run=.true. - rstcount=rstcount+1 - if (lang.gt.0 .and. surfarea .and. - & mod(itime,reset_fricmat).eq.0) then - if (lang.eq.2 .or. lang.eq.3) then - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo -#endif - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - write (iout,'(a,i10)') - & "Friction matrix reset based on surface area, itime",itime - endif - if (reset_vel .and. tbf .and. lang.eq.0 - & .and. mod(itime,count_reset_vel).eq.0) then - call random_vel - if (me.eq.king .or. .not. out1file) - & write(iout,'(a,f20.2)') - & "Velocities reset to random values, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - endif - if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then - call inertia_tensor - call vcm_vel(vcm) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen*Rb)*EK - scalfac=dsqrt(T_bath/kinetic_T) -cd write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=scalfac*d_t(j,i) - enddo - enddo - endif - if (lang.ne.4) then - if (RESPA) then -c Time-reversible RESPA algorithm -c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) - call RESPA_step(itime) - else -c Variable time step algorithm. - call velverlet_step(itime) - endif - else - call brown_step(itime) - endif - if(ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) call statout(itime) - endif - if (mod(itime,ntwx).eq.0.and..not.traj1file) then - write (tytul,'("time",f8.2," temp",f8.1)') totT,t_bath - if(mdpdb) then - call pdbout(potE,tytul,ipdb) - else - call cartout(totT) - endif - endif - if (mod(itime,ntwx).eq.0.and.traj1file) then - if(ntwx_cache.lt.max_cache_traj) then - ntwx_cache=ntwx_cache+1 - - totT_cache(ntwx_cache)=totT - EK_cache(ntwx_cache)=EK - potE_cache(ntwx_cache)=potE - t_bath_cache(ntwx_cache)=t_bath - Uconst_cache(ntwx_cache)=Uconst - - do i=1,nfrag - qfrag_cache(i,ntwx_cache)=qfrag(i) - enddo - do i=1,npair - qpair_cache(i,ntwx_cache)=qpair(i) - enddo - - do i=1,nres*2 - do j=1,3 - c_cache(j,i,ntwx_cache)=c(j,i) - enddo - enddo - else - print *,itime,"processor ",me," over cache ",ntwx_cache - endif - endif - if ((rstcount.eq.1000.or.itime.eq.n_timestep) - & .and..not.restart1file) then - - if(me.eq.king) then - open(irest1,file=mremd_rst_name,status='unknown') - write (irest1,*) "i2rep" - write (irest1,*) (i2rep(i),i=0,nodes-1) - write (irest1,*) "ifirst" - write (irest1,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (irest1,*) "nupa",il - write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - write (irest1,*) "ndowna",il - write (irest1,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - close(irest1) - endif - open(irest2,file=rest2name,status='unknown') - write(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - write (irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - close(irest2) - rstcount=0 - endif - -c REMD - exchange -c forced synchronization - if (mod(itime,i_sync_step).eq.0 .and. me.ne.king - & .and. .not. mremdsync) then - synflag=.false. - call mpi_iprobe(0,101,mpi_comm_world,synflag,status,ierr) - if (synflag) then - call mpi_recv(itime_master, 1, MPI_INTEGER, - & 0,101,mpi_comm_world, status, ierr) - call mpi_barrier(mpi_comm_world, ierr) - if (out1file.or.traj1file) then - call mpi_gather(itime,1,mpi_integer, - & itime_all,1,mpi_integer,king, - & mpi_comm_world,ierr) - endif - if (.not.out1file) - & write(iout,*) 'REMD synchro at',itime_master,itime - if(itime_master.ge.n_timestep) end_of_run=.true. -ctime call flush(iout) - endif - endif - -c REMD - exchange - if ((mod(itime,nstex).eq.0.and.me.eq.king - & .or.end_of_run.and.me.eq.king ) - & .and. .not. mremdsync ) then - synflag=.true. - time00=MPI_WTIME() - do i=1,nodes-1 - call mpi_isend(itime,1,MPI_INTEGER,i,101, - & mpi_comm_world, ireqi(i), ierr) -cd write(iout,*) 'REMD synchro with',i -cd call flush(iout) - enddo - call mpi_waitall(nodes-1,ireqi,statusi,ierr) - call mpi_barrier(mpi_comm_world, ierr) - time01=MPI_WTIME() - write(iout,*) 'REMD synchro at',itime,'time=',time01-time00 - if (out1file.or.traj1file) then - call mpi_gather(itime,1,mpi_integer, - & itime_all,1,mpi_integer,king, - & mpi_comm_world,ierr) -ctime write(iout,'(a19,8000i8)') ' REMD synchro itime', -ctime & (itime_all(i),i=1,nodes) - if(traj1file) then - imin_itime=itime_all(1) - do i=2,nodes - if(itime_all(i).lt.imin_itime) imin_itime=itime_all(i) - enddo - ii_write=(imin_itime-imin_itime_old)/ntwx - imin_itime_old=int(imin_itime/ntwx)*ntwx - write(iout,*) imin_itime,imin_itime_old,ii_write - endif - endif -ctime call flush(iout) - endif - if(mremdsync .and. mod(itime,nstex).eq.0) then - synflag=.true. - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'REMD synchro at',itime - call flush(iout) - endif - if(synflag.and..not.end_of_run) then - time02=MPI_WTIME() - synflag=.false. - -cd write(iout,*) 'REMD before',me,t_bath - -c call mpi_gather(t_bath,1,mpi_double_precision, -c & remd_t_bath,1,mpi_double_precision,king, -c & mpi_comm_world,ierr) - potEcomp(n_ene+1)=t_bath - potEcomp(n_ene+2)=iset - call mpi_gather(potEcomp(0),n_ene+3,mpi_double_precision, - & remd_ene(0,1),n_ene+3,mpi_double_precision,king, - & mpi_comm_world,ierr) - if(lmuca) then - call mpi_gather(elow,1,mpi_double_precision, - & elowi,1,mpi_double_precision,king, - & mpi_comm_world,ierr) - call mpi_gather(ehigh,1,mpi_double_precision, - & ehighi,1,mpi_double_precision,king, - & mpi_comm_world,ierr) - endif - - time03=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD gather times=',time03-time01 - & ,time03-time02 - endif - - if (restart1file) call write1rst - - time04=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD writing rst time=',time04-time03 - endif - - if (traj1file) call write1traj - - time05=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD writing traj time=',time05-time04 - endif - - - if (me.eq.king) then - do i=1,nodes - remd_t_bath(i)=remd_ene(n_ene+1,i) - enddo - if(lmuca) then -co write(iout,*) 'REMD exchange temp,ene,elow,ehigh' - do i=1,nodes - write(iout,'(i4,4f12.5)') i,remd_t_bath(i),remd_ene(0,i), - & elowi(i),ehighi(i) - enddo - else -cd write(iout,*) 'REMD exchange temp,ene' -c do i=1,nodes -co write(iout,'(i4,2f12.5)') i,remd_t_bath(i),remd_ene(0,i) -c write(iout,'(6f12.5)') (remd_ene(j,i),j=1,n_ene) -c enddo - endif -c------------------------------------- - do irr=1,remd_m(1) - i=ifirst(iran_num(1,remd_m(1))) - do ii=1,nodes-1 - - if(i.gt.0.and.nupa(0,i).gt.0) then - iex=nupa(iran_num(1,int(nupa(0,i))),i) - if (lmuca) then - call muca_delta(remd_t_bath,remd_ene,i,iex,delta) - else -c Swap temperatures between conformations i and iex with recalculating the free energies -c following temperature changes. - ene_iex_iex=remd_ene(0,iex) - ene_i_i=remd_ene(0,i) -co write (iout,*) "rescaling weights with temperature", -co & remd_t_bath(i) - call rescale_weights(remd_t_bath(i)) - call sum_energy(remd_ene(0,iex)) - ene_iex_i=remd_ene(0,iex) -cd write (iout,*) "ene_iex_i",remd_ene(0,iex) - call sum_energy(remd_ene(0,i)) -cd write (iout,*) "ene_i_i",remd_ene(0,i) -c write (iout,*) "rescaling weights with temperature", -c & remd_t_bath(iex) - if (real(ene_i_i).ne.real(remd_ene(0,i))) then - write (iout,*) "ERROR: inconsistent energies:",i, - & ene_i_i,remd_ene(0,i) - endif - call rescale_weights(remd_t_bath(iex)) - call sum_energy(remd_ene(0,i)) -c write (iout,*) "ene_i_iex",remd_ene(0,i) - ene_i_iex=remd_ene(0,i) - call sum_energy(remd_ene(0,iex)) - if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then - write (iout,*) "ERROR: inconsistent energies:",iex, - & ene_iex_iex,remd_ene(0,iex) - endif -c write (iout,*) "ene_iex_iex",remd_ene(0,iex) -c write (iout,*) "i",i," iex",iex -co write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, -co & " ene_i_iex",ene_i_iex, -co & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex - delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- - & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) - delta=-delta -c write(iout,*) 'delta',delta -c delta=(remd_t_bath(i)-remd_t_bath(iex))* -c & (remd_ene(i)-remd_ene(iex))/Rb/ -c & (remd_t_bath(i)*remd_t_bath(iex)) - endif - if (delta .gt. 50.0d0) then - delta=0.0d0 - else -#ifdef OSF - if(isnan(delta))then - delta=0.0d0 - else if (delta.lt.-50.0d0) then - delta=dexp(50.0d0) - else - delta=dexp(-delta) - endif -#else - delta=dexp(-delta) -#endif - endif - iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 - xxx=ran_number(0.0d0,1.0d0) -co write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx - if (delta .gt. xxx) then - tmp=remd_t_bath(i) - remd_t_bath(i)=remd_t_bath(iex) - remd_t_bath(iex)=tmp - remd_ene(0,i)=ene_i_iex - remd_ene(0,iex)=ene_iex_i - if(lmuca) then - tmp=elowi(i) - elowi(i)=elowi(iex) - elowi(iex)=tmp - tmp=ehighi(i) - ehighi(i)=ehighi(iex) - ehighi(iex)=tmp - endif - - - do k=0,nodes - itmp=nupa(k,i) - nupa(k,i)=nupa(k,iex) - nupa(k,iex)=itmp - itmp=ndowna(k,i) - ndowna(k,i)=ndowna(k,iex) - ndowna(k,iex)=itmp - enddo - do il=1,nodes - if (ifirst(il).eq.i) ifirst(il)=iex - do k=1,nupa(0,il) - if (nupa(k,il).eq.i) then - nupa(k,il)=iex - elseif (nupa(k,il).eq.iex) then - nupa(k,il)=i - endif - enddo - do k=1,ndowna(0,il) - if (ndowna(k,il).eq.i) then - ndowna(k,il)=iex - elseif (ndowna(k,il).eq.iex) then - ndowna(k,il)=i - endif - enddo - enddo - - iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 - itmp=i2rep(i-1) - i2rep(i-1)=i2rep(iex-1) - i2rep(iex-1)=itmp - -cd write(iout,*) 'exchange',i,iex -cd write (iout,'(a8,100i4)') "@ ifirst", -cd & (ifirst(k),k=1,remd_m(1)) -cd do il=1,nodes -cd write (iout,'(a8,i4,a1,100i4)') "@ nupa",il,":", -cd & (nupa(k,il),k=1,nupa(0,il)) -cd write (iout,'(a8,i4,a1,100i4)') "@ ndowna",il,":", -cd & (ndowna(k,il),k=1,ndowna(0,il)) -cd enddo - - else - remd_ene(0,iex)=ene_iex_iex - remd_ene(0,i)=ene_i_i - i=iex - endif - endif - enddo - enddo -c------------------------------------- - do i=1,nrep - if(iremd_tot(i).ne.0) - & write(iout,'(a3,i4,2f12.5)') 'ACC',i,remd_t(i) - & ,iremd_acc(i)/(1.0*iremd_tot(i)) - enddo - -cd write (iout,'(a6,100i4)') "ifirst", -cd & (ifirst(i),i=1,remd_m(1)) -cd do il=1,nodes -cd write (iout,'(a5,i4,a1,100i4)') "nup",il,":", -cd & (nupa(i,il),i=1,nupa(0,il)) -cd write (iout,'(a5,i4,a1,100i4)') "ndown",il,":", -cd & (ndowna(i,il),i=1,ndowna(0,il)) -cd enddo - endif - - time06=MPI_WTIME() - call mpi_scatter(remd_t_bath,1,mpi_double_precision, - & t_bath,1,mpi_double_precision,king, - & mpi_comm_world,ierr) - time07=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD scatter time=',time07-time06 - endif - - if(lmuca) then - call mpi_scatter(elowi,1,mpi_double_precision, - & elow,1,mpi_double_precision,king, - & mpi_comm_world,ierr) - call mpi_scatter(ehighi,1,mpi_double_precision, - & ehigh,1,mpi_double_precision,king, - & mpi_comm_world,ierr) - endif - call rescale_weights(t_bath) -co write (iout,*) "Processor",me, -co & " rescaling weights with temperature",t_bath - - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - -cde write(iout,*) 'REMD after',me,t_bath - time08=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD exchange time=',time08-time00 - call flush(iout) - endif - endif - enddo - - if (restart1file) then - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'writing restart at the end of run' - call write1rst - endif - - if (traj1file) call write1traj - - - t_MD=tcpu()-tt0 - if (me.eq.king .or. .not. out1file) then - write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') - & ' Timing ', - & 'MD calculations setup:',t_MDsetup, - & 'Energy & gradient evaluation:',t_enegrad, - & 'Stochastic MD setup:',t_langsetup, - & 'Stochastic MD step setup:',t_sdsetup, - & 'MD steps:',t_MD - write (iout,'(/28(1h=),a25,27(1h=))') - & ' End of MD calculation ' - endif - return - end - - subroutine write1rst_ - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & d_restart2(3,2*maxres*maxprocs) - real t5_restart1(5) - integer iret,itmp - - - t5_restart1(1)=totT - t5_restart1(2)=EK - t5_restart1(3)=potE - t5_restart1(4)=t_bath - t5_restart1(5)=Uconst - - call mpi_gather(t5_restart1,5,mpi_real, - & t_restart1,5,mpi_real,king,mpi_comm_world,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=d_t(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart1,3*2*nres,mpi_real,king, - & mpi_comm_world,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=dc(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart2,3*2*nres,mpi_real,king, - & mpi_comm_world,ierr) - - if(me.eq.king) then - open(irest1,file=mremd_rst_name,status='unknown') - write (irest1,*) (i2rep(i),i=0,nodes-1) - write (irest1,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - write (irest1,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - - do il=1,nodes - write(irest1,*) (t_restart1(j,il),j=1,4) - enddo - - do il=0,nodes-1 - do i=1,2*nres - write(irest1,'(3e15.5)') (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - do il=0,nodes-1 - do i=1,2*nres - write(irest1,'(3e15.5)') (d_restart2(j,i+2*nres*il),j=1,3) - enddo - enddo - close(irest1) - endif - - return - end - - subroutine write1rst - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & d_restart2(3,2*maxres*maxprocs) - real t5_restart1(5) - integer iret,itmp - - - t5_restart1(1)=totT - t5_restart1(2)=EK - t5_restart1(3)=potE - t5_restart1(4)=t_bath - t5_restart1(5)=Uconst - - call mpi_gather(t5_restart1,5,mpi_real, - & t_restart1,5,mpi_real,king,mpi_comm_world,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=d_t(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart1,3*2*nres,mpi_real,king, - & mpi_comm_world,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=dc(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart2,3*2*nres,mpi_real,king, - & mpi_comm_world,ierr) - - if(me.eq.king) then -c open(irest1,file=mremd_rst_name,status='unknown') - call xdrfopen(ixdrf,mremd_rst_name, "w", iret) -c write (irest1,*) (i2rep(i),i=0,nodes-1) - do i=0,nodes-1 - call xdrfint(ixdrf, i2rep(i), iret) - enddo -c write (irest1,*) (ifirst(i),i=1,remd_m(1)) - do i=1,remd_m(1) - call xdrfint(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes -c write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - do i=0,nupa(0,il) - call xdrfint(ixdrf, nupa(i,il), iret) - enddo - -c write (irest1,*) ndowna(0,il), -c & (ndowna(i,il),i=1,ndowna(0,il)) - do i=0,ndowna(0,il) - call xdrfint(ixdrf, ndowna(i,il), iret) - enddo - enddo - - do il=1,nodes -c write(irest1,*) (t_restart1(j,il),j=1,4) - do j=1,4 - call xdrffloat(ixdrf, t_restart1(j,il), iret) - enddo - enddo - - do il=0,nodes-1 - do i=1,2*nres -c write(irest1,'(3e15.5)') (d_restart1(j,i+2*nres*il),j=1,3) - do j=1,3 - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) - enddo - enddo - enddo - do il=0,nodes-1 - do i=1,2*nres -c write(irest1,'(3e15.5)') (d_restart2(j,i+2*nres*il),j=1,3) - do j=1,3 - call xdrffloat(ixdrf, d_restart2(j,i+2*nres*il), iret) - enddo - enddo - enddo -c close(irest1) - call xdrfclose(ixdrf, iret) - endif - - return - end - - - subroutine write1traj - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - - real t5_restart1(5) - integer iret,itmp - real xcoord(3,maxres2+2),prec - real r_qfrag(50),r_qpair(100) - real p_qfrag(50*maxprocs),p_qpair(100*maxprocs) - real p_c(3,(maxres2+2)*maxprocs),r_c(3,maxres2+2) - - call mpi_bcast(ii_write,1,mpi_integer, - & king,mpi_comm_world,ierr) - - print *,'traj1file',me,ii_write,ntwx_cache - - if(me.eq.king) call xdrfopen(ixdrf,cartname, "a", iret) - do ii=1,ii_write - t5_restart1(1)=totT_cache(ii) - t5_restart1(2)=EK_cache(ii) - t5_restart1(3)=potE_cache(ii) - t5_restart1(4)=t_bath_cache(ii) - t5_restart1(5)=Uconst_cache(ii) - call mpi_gather(t5_restart1,5,mpi_real, - & t_restart1,5,mpi_real,king,mpi_comm_world,ierr) - - do i=1,nfrag - r_qfrag(i)=qfrag_cache(i,ii) - enddo - do i=1,npair - r_qpair(i)=qpair_cache(i,ii) - enddo - - call mpi_gather(r_qfrag,nfrag,mpi_real, - & p_qfrag,nfrag,mpi_real,king, - & mpi_comm_world,ierr) - call mpi_gather(r_qpair,npair,mpi_real, - & p_qpair,npair,mpi_real,king, - & mpi_comm_world,ierr) - - do i=1,nres*2 - do j=1,3 - r_c(j,i)=c_cache(j,i,ii) - enddo - enddo - - call mpi_gather(r_c,3*2*nres,mpi_real, - & p_c,3*2*nres,mpi_real,king, - & mpi_comm_world,ierr) - - if(me.eq.king) then - - do il=1,nodes - call xdrffloat(ixdrf, real(t_restart1(1,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(3,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(5,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(4,il)), iret) - call xdrfint(ixdrf, nss, iret) - do j=1,nss - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - enddo - call xdrfint(ixdrf, nfrag+npair, iret) - do i=1,nfrag - call xdrffloat(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) - enddo - do i=1,npair - call xdrffloat(ixdrf, p_qpair(i+(il-1)*npair), iret) - enddo - prec=10000.0 - do i=1,nres - do j=1,3 - xcoord(j,i)=p_c(j,i+(il-1)*nres*2) - enddo - enddo - do i=nnt,nct - do j=1,3 - xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) - enddo - enddo - itmp=nres+nct-nnt+1 - call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) - enddo - endif - enddo - if(me.eq.king) call xdrfclose(ixdrf, iret) - do i=1,ntwx_cache-ii_write - - totT_cache(i)=totT_cache(ii_write+i) - EK_cache(i)=EK_cache(ii_write+i) - potE_cache(i)=potE_cache(ii_write+i) - t_bath_cache(i)=t_bath_cache(ii_write+i) - Uconst_cache(i)=Uconst_cache(ii_write+i) - - do ii=1,nfrag - qfrag_cache(ii,i)=qfrag_cache(ii,ii_write+i) - enddo - do ii=1,npair - qpair_cache(ii,i)=qpair_cache(ii,ii_write+i) - enddo - - do ii=1,nres*2 - do j=1,3 - c_cache(j,ii,i)=c_cache(j,ii,ii_write+i) - enddo - enddo - enddo - ntwx_cache=ntwx_cache-ii_write - return - end - - - subroutine read1restart - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & t5_restart1(5) - - if(me.eq.king)then - open(irest2,file=mremd_rst_name,status='unknown') - read(irest2,*,err=334) i - write(iout,*) "Reading old rst in ASCI format" - close(irest2) - call read1restart_old - return - 334 continue - call xdrfopen(ixdrf,mremd_rst_name, "r", iret) - -c read (irest2,*) (i2rep(i),i=0,nodes-1) - do i=0,nodes-1 - call xdrfint(ixdrf, i2rep(i), iret) - enddo -c read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do i=1,remd_m(1) - call xdrfint(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes -c read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - call xdrfint(ixdrf, nupa(0,il), iret) - do i=1,nupa(0,il) - call xdrfint(ixdrf, nupa(i,il), iret) - enddo - -c read (irest2,*) ndowna(0,il), -c & (ndowna(i,il),i=1,ndowna(0,il)) - call xdrfint(ixdrf, ndowna(0,il), iret) - do i=1,ndowna(0,il) - call xdrfint(ixdrf, ndowna(i,il), iret) - enddo - enddo - do il=1,nodes -c read(irest2,*) (t_restart1(j,il),j=1,4) - do j=1,4 - call xdrffloat(ixdrf, t_restart1(j,il), iret) - enddo - enddo - endif - call mpi_scatter(t_restart1,5,mpi_real, - & t5_restart1,5,mpi_real,king,mpi_comm_world,ierr) - totT=t5_restart1(1) - EK=t5_restart1(2) - potE=t5_restart1(3) - t_bath=t5_restart1(4) - - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres -c read(irest2,'(3e15.5)') -c & (d_restart1(j,i+2*nres*il),j=1,3) - do j=1,3 - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) - enddo - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,mpi_comm_world,ierr) - - do i=1,2*nres - do j=1,3 - d_t(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres -c read(irest2,'(3e15.5)') -c & (d_restart1(j,i+2*nres*il),j=1,3) - do j=1,3 - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) - enddo - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,mpi_comm_world,ierr) - do i=1,2*nres - do j=1,3 - dc(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king) close(irest2) - return - end - - subroutine read1restart_old - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & t5_restart1(5) - - if(me.eq.king)then - open(irest2,file=mremd_rst_name,status='unknown') - read (irest2,*) (i2rep(i),i=0,nodes-1) - read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - read (irest2,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - do il=1,nodes - read(irest2,*) (t_restart1(j,il),j=1,4) - enddo - endif - call mpi_scatter(t_restart1,5,mpi_real, - & t5_restart1,5,mpi_real,king,mpi_comm_world,ierr) - totT=t5_restart1(1) - EK=t5_restart1(2) - potE=t5_restart1(3) - t_bath=t5_restart1(4) - - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres - read(irest2,'(3e15.5)') - & (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,mpi_comm_world,ierr) - - do i=1,2*nres - do j=1,3 - d_t(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres - read(irest2,'(3e15.5)') - & (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,mpi_comm_world,ierr) - do i=1,2*nres - do j=1,3 - dc(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king) close(irest2) - return - end - \ No newline at end of file diff --git a/source/unres/src_MD-M-newcorr/MREMD.F.safe b/source/unres/src_MD-M-newcorr/MREMD.F.safe deleted file mode 100644 index 110dea3..0000000 --- a/source/unres/src_MD-M-newcorr/MREMD.F.safe +++ /dev/null @@ -1,1756 +0,0 @@ - subroutine MREMD - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.MUCA' - double precision cm(3),L(3),vcm(3) - double precision energia(0:n_ene) - double precision remd_t_bath(maxprocs) - integer iremd_iset(maxprocs) - integer*2 i_index - & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) - double precision remd_ene(0:n_ene+4,maxprocs) - integer iremd_acc(maxprocs),iremd_tot(maxprocs) - integer iremd_acc_usa(maxprocs),iremd_tot_usa(maxprocs) - integer ilen,rstcount - external ilen - character*50 tytul - common /gucio/ cm - integer itime -cold integer nup(0:maxprocs),ndown(0:maxprocs) - integer rep2i(0:maxprocs),ireqi(maxprocs) - integer icache_all(maxprocs) - integer status(MPI_STATUS_SIZE),statusi(MPI_STATUS_SIZE,maxprocs) - logical synflag,end_of_run,file_exist /.false./ - -cdeb imin_itime_old=0 - ntwx_cache=0 - time00=MPI_WTIME() - time01=time00 - if(me.eq.king.or..not.out1file) then - write (iout,*) 'MREMD',nodes,'time before',time00-walltime - write (iout,*) "NREP=",nrep - endif - - synflag=.false. - if (ilen(tmpdir).gt.0 .and. (me.eq.king)) then - call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_mremd.rst") - endif - mremd_rst_name=prefix(:ilen(prefix))//"_mremd.rst" - -cd print *,'MREMD',nodes -cd print *,'mmm',me,remd_mlist,(remd_m(i),i=1,nrep) -cde write (iout,*) "Start MREMD: me",me," t_bath",t_bath - k=0 - rep2i(k)=-1 - do il=1,max0(nset,1) - do il1=1,max0(mset(il),1) - do i=1,nrep - iremd_acc(i)=0 - iremd_acc_usa(i)=0 - iremd_tot(i)=0 - do j=1,remd_m(i) - i2rep(k)=i - i2set(k)=il - rep2i(i)=k - k=k+1 - i_index(i,j,il,il1)=k - enddo - enddo - enddo - enddo - - if(me.eq.king.or..not.out1file) then - write(iout,*) (i2rep(i),i=0,nodes-1) - write(iout,*) (i2set(i),i=0,nodes-1) - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - write(iout,*) i,j,il,il1,i_index(i,j,il,il1) - enddo - enddo - enddo - enddo - endif - -c print *,'i2rep',me,i2rep(me) -c print *,'rep2i',(rep2i(i),i=0,nrep) - -cold if (i2rep(me).eq.nrep) then -cold nup(0)=0 -cold else -cold nup(0)=remd_m(i2rep(me)+1) -cold k=rep2i(int(i2rep(me)))+1 -cold do i=1,nup(0) -cold nup(i)=k -cold k=k+1 -cold enddo -cold endif - -cd print '(i4,a4,100i4)',me,' nup',(nup(i),i=0,nup(0)) - -cold if (i2rep(me).eq.1) then -cold ndown(0)=0 -cold else -cold ndown(0)=remd_m(i2rep(me)-1) -cold k=rep2i(i2rep(me)-2)+1 -cold do i=1,ndown(0) -cold ndown(i)=k -cold k=k+1 -cold enddo -cold endif - -cd print '(i4,a6,100i4)',me,' ndown',(ndown(i),i=0,ndown(0)) - - - write (*,*) "Processor",me," rest",rest," - & restart1fie",restart1file - if(rest.and.restart1file) then - if (me.eq.king) - & inquire(file=mremd_rst_name,exist=file_exist) -cd write (*,*) me," Before broadcast: file_exist",file_exist - call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM, - & IERR) -cd write (*,*) me," After broadcast: file_exist",file_exist - if(file_exist) then - if(me.eq.king.or..not.out1file) - & write (iout,*) 'Master is reading restart1file' - call read1restart(i_index) - else - if(me.eq.king.or..not.out1file) - & write (iout,*) 'WARNING : no restart1file' - endif - - if(me.eq.king.or..not.out1file) then - write(iout,*) "i2set",(i2set(i),i=0,nodes-1) - write(iout,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - write(iout,*) i,j,il,il1,i_index(i,j,il,il1) - enddo - enddo - enddo - enddo - endif - endif - - if(me.eq.king) then - if (rest.and..not.restart1file) - & inquire(file=mremd_rst_name,exist=file_exist) - if(.not.file_exist.and.rest.and..not.restart1file) - & write(iout,*) 'WARNING : no restart file',mremd_rst_name - IF (rest.and.file_exist.and..not.restart1file) THEN - write (iout,*) 'Master is reading restart file', - & mremd_rst_name - open(irest2,file=mremd_rst_name,status='unknown') - read (irest2,*) - read (irest2,*) (i2rep(i),i=0,nodes-1) - read (irest2,*) - read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - read (irest2,*) - read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - read (irest2,*) - read (irest2,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - if(usampl) then - read (irest2,*) - read (irest2,*) nset - read (irest2,*) - read (irest2,*) (mset(i),i=1,nset) - read (irest2,*) - read (irest2,*) (i2set(i),i=0,nodes-1) - read (irest2,*) - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - read(irest2,*) (i_index(i,j,il,il1),j=1,remd_m(i)) - enddo - enddo - enddo - - write(iout,*) "i2set",(i2set(i),i=0,nodes-1) - write(iout,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - write(iout,*) i,j,il,il1,i_index(i,j,il,il1) - enddo - enddo - enddo - enddo - endif - - close(irest2) - - write (iout,'(a6,1000i5)') "i2rep",(i2rep(i),i=0,nodes-1) - write (iout,'(a6,1000i5)') "ifirst", - & (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (iout,'(a6,i4,a1,100i4)') "nupa",il,":", - & (nupa(i,il),i=1,nupa(0,il)) - write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":", - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - ELSE IF (.not.(rest.and.file_exist)) THEN - do il=1,remd_m(1) - ifirst(il)=il - enddo - - do il=1,nodes - if (i2rep(il-1).eq.nrep) then - nupa(0,il)=0 - else - nupa(0,il)=remd_m(i2rep(il-1)+1) - k=rep2i(int(i2rep(il-1)))+1 - do i=1,nupa(0,il) - nupa(i,il)=k+1 - k=k+1 - enddo - endif - if (i2rep(il-1).eq.1) then - ndowna(0,il)=0 - else - ndowna(0,il)=remd_m(i2rep(il-1)-1) - k=rep2i(i2rep(il-1)-2)+1 - do i=1,ndowna(0,il) - ndowna(i,il)=k+1 - k=k+1 - enddo - endif - enddo - -c write (iout,'(a6,100i4)') "ifirst", -c & (ifirst(i),i=1,remd_m(1)) -c do il=1,nodes -c write (iout,'(a6,i4,a1,100i4)') "nupa",il,":", -c & (nupa(i,il),i=1,nupa(0,il)) -c write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":", -c & (ndowna(i,il),i=1,ndowna(0,il)) -c enddo - - ENDIF - endif -c -c t_bath=retmin+(retmax-retmin)*me/(nodes-1) - if(.not.(rest.and.file_exist.and.restart1file)) then - if (me .eq. king) then - t_bath=retmin - else - t_bath=retmin+(retmax-retmin)*exp(float(i2rep(me)-nrep)) - endif -cd print *,'ttt',me,remd_tlist,(remd_t(i),i=1,nrep) - if (remd_tlist) t_bath=remd_t(int(i2rep(me))) - - endif - if(usampl) then - iset=i2set(me) - if(me.eq.king.or..not.out1file) - & write(iout,*) me,"iset=",iset,"t_bath=",t_bath - endif -c - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - -c print *,'irep',me,t_bath - if (.not.rest) then - if (me.eq.king .or. .not. out1file) - & write (iout,'(a60,f10.5)') "REMD Temperature:",t_bath - call rescale_weights(t_bath) - endif - - -c------copy MD-------------- -c The driver for molecular dynamics subroutines -c------------------------------------------------ - t_MDsetup=0.0d0 - t_langsetup=0.0d0 - t_MD=0.0d0 - t_enegrad=0.0d0 - t_sdsetup=0.0d0 - if(me.eq.king.or..not.out1file) - & write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Determine the inverse of the inertia matrix. - call setup_MD_matrices -c Initialize MD - call init_MD - if (rest) then - if (me.eq.king .or. .not. out1file) - & write (iout,'(a60,f10.5)') "REMD restart Temperature:",t_bath - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - call rescale_weights(t_bath) - endif - -#ifdef MPI - t_MDsetup = MPI_Wtime() -#else - t_MDsetup = tcpu()-tt0 -#endif - rstcount=0 -c Entering the MD loop -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif - if (lang.eq.2 .or. lang.eq.3) then - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo -#endif - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - time00=MPI_WTIME() - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'Setup time',time00-walltime - call flush(iout) -#ifdef MPI - t_langsetup=MPI_Wtime() - tt0=MPI_Wtime() -#else - t_langsetup=tcpu()-tt0 - tt0=tcpu() -#endif - itime=0 - end_of_run=.false. - do while(.not.end_of_run) - itime=itime+1 - if(itime.eq.n_timestep.and.me.eq.king) end_of_run=.true. - if(mremdsync.and.itime.eq.n_timestep) end_of_run=.true. - rstcount=rstcount+1 - if (lang.gt.0 .and. surfarea .and. - & mod(itime,reset_fricmat).eq.0) then - if (lang.eq.2 .or. lang.eq.3) then - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo -#endif - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - write (iout,'(a,i10)') - & "Friction matrix reset based on surface area, itime",itime - endif - if (reset_vel .and. tbf .and. lang.eq.0 - & .and. mod(itime,count_reset_vel).eq.0) then - call random_vel - if (me.eq.king .or. .not. out1file) - & write(iout,'(a,f20.2)') - & "Velocities reset to random values, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - endif - if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then - call inertia_tensor - call vcm_vel(vcm) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen*Rb)*EK - scalfac=dsqrt(T_bath/kinetic_T) -cd write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=scalfac*d_t(j,i) - enddo - enddo - endif - if (lang.ne.4) then - if (RESPA) then -c Time-reversible RESPA algorithm -c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) - call RESPA_step(itime) - else -c Variable time step algorithm. - call velverlet_step(itime) - endif - else - call brown_step(itime) - endif - if(ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) call statout(itime) - endif - if (mod(itime,ntwx).eq.0.and..not.traj1file) then - write (tytul,'("time",f8.2," temp",f8.1)') totT,t_bath - if(mdpdb) then - call pdbout(potE,tytul,ipdb) - else - call cartout(totT) - endif - endif - if (mod(itime,ntwx).eq.0.and.traj1file) then - if(ntwx_cache.lt.max_cache_traj_use) then - ntwx_cache=ntwx_cache+1 - else - if (max_cache_traj_use.ne.1) - & print *,itime,"processor ",me," over cache ",ntwx_cache - do i=1,ntwx_cache-1 - - totT_cache(i)=totT_cache(i+1) - EK_cache(i)=EK_cache(i+1) - potE_cache(i)=potE_cache(i+1) - t_bath_cache(i)=t_bath_cache(i+1) - Uconst_cache(i)=Uconst_cache(i+1) - iset_cache(i)=iset_cache(i+1) - - do ii=1,nfrag - qfrag_cache(ii,i)=qfrag_cache(ii,i+1) - enddo - do ii=1,npair - qpair_cache(ii,i)=qpair_cache(ii,i+1) - enddo - do ii=1,nfrag_back - utheta_cache(ii,i)=utheta_cache(ii,i+1) - ugamma_cache(ii,i)=ugamma_cache(ii,i+1) - uscdiff_cache(ii,i)=uscdiff_cache(ii,i+1) - enddo - - - do ii=1,nres*2 - do j=1,3 - c_cache(j,ii,i)=c_cache(j,ii,i+1) - enddo - enddo - enddo - endif - - totT_cache(ntwx_cache)=totT - EK_cache(ntwx_cache)=EK - potE_cache(ntwx_cache)=potE - t_bath_cache(ntwx_cache)=t_bath - Uconst_cache(ntwx_cache)=Uconst - iset_cache(ntwx_cache)=iset - - do i=1,nfrag - qfrag_cache(i,ntwx_cache)=qfrag(i) - enddo - do i=1,npair - qpair_cache(i,ntwx_cache)=qpair(i) - enddo - do i=1,nfrag_back - utheta_cache(i,ntwx_cache)=utheta(i) - ugamma_cache(i,ntwx_cache)=ugamma(i) - uscdiff_cache(i,ntwx_cache)=uscdiff(i) - enddo - - do i=1,nres*2 - do j=1,3 - c_cache(j,i,ntwx_cache)=c(j,i) - enddo - enddo - - endif - if ((rstcount.eq.1000.or.itime.eq.n_timestep) - & .and..not.restart1file) then - - if(me.eq.king) then - open(irest1,file=mremd_rst_name,status='unknown') - write (irest1,*) "i2rep" - write (irest1,*) (i2rep(i),i=0,nodes-1) - write (irest1,*) "ifirst" - write (irest1,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (irest1,*) "nupa",il - write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - write (irest1,*) "ndowna",il - write (irest1,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - if(usampl) then - write (irest1,*) "nset" - write (irest1,*) nset - write (irest1,*) "mset" - write (irest1,*) (mset(i),i=1,nset) - write (irest1,*) "i2set" - write (irest1,*) (i2set(i),i=0,nodes-1) - write (irest1,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - write(irest1,*) (i_index(i,j,il,il1),j=1,remd_m(i)) - enddo - enddo - enddo - - endif - close(irest1) - endif - open(irest2,file=rest2name,status='unknown') - write(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - write (irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - if(usampl) then - write (irest2,*) iset - endif - close(irest2) - rstcount=0 - endif - -c REMD - exchange -c forced synchronization - if (mod(itime,i_sync_step).eq.0 .and. me.ne.king - & .and. .not. mremdsync) then - synflag=.false. - call mpi_iprobe(0,101,CG_COMM,synflag,status,ierr) - if (synflag) then - call mpi_recv(itime_master, 1, MPI_INTEGER, - & 0,101,CG_COMM, status, ierr) - call mpi_barrier(CG_COMM, ierr) -cdeb if (out1file.or.traj1file) then -cdeb call mpi_gather(itime,1,mpi_integer, -cdeb & icache_all,1,mpi_integer,king, -cdeb & CG_COMM,ierr) - if(traj1file) - & call mpi_gather(ntwx_cache,1,mpi_integer, - & icache_all,1,mpi_integer,king, - & CG_COMM,ierr) - if (.not.out1file) - & write(iout,*) 'REMD synchro at',itime_master,itime - if(itime_master.ge.n_timestep) end_of_run=.true. -ctime call flush(iout) - endif - endif - -c REMD - exchange - if ((mod(itime,nstex).eq.0.and.me.eq.king - & .or.end_of_run.and.me.eq.king ) - & .and. .not. mremdsync ) then - synflag=.true. - time00=MPI_WTIME() - do i=1,nodes-1 - call mpi_isend(itime,1,MPI_INTEGER,i,101, - & CG_COMM, ireqi(i), ierr) -cd write(iout,*) 'REMD synchro with',i -cd call flush(iout) - enddo - call mpi_waitall(nodes-1,ireqi,statusi,ierr) - call mpi_barrier(CG_COMM, ierr) - time01=MPI_WTIME() - write(iout,*) 'REMD synchro at',itime,'time=',time01-time00 - if (out1file.or.traj1file) then -cdeb call mpi_gather(itime,1,mpi_integer, -cdeb & itime_all,1,mpi_integer,king, -cdeb & CG_COMM,ierr) -cdeb write(iout,'(a19,8000i8)') ' REMD synchro itime', -cdeb & (itime_all(i),i=1,nodes) - if(traj1file) then -cdeb imin_itime=itime_all(1) -cdeb do i=2,nodes -cdeb if(itime_all(i).lt.imin_itime) imin_itime=itime_all(i) -cdeb enddo -cdeb ii_write=(imin_itime-imin_itime_old)/ntwx -cdeb imin_itime_old=int(imin_itime/ntwx)*ntwx -cdeb write(iout,*) imin_itime,imin_itime_old,ii_write - call mpi_gather(ntwx_cache,1,mpi_integer, - & icache_all,1,mpi_integer,king, - & CG_COMM,ierr) -c write(iout,'(a19,8000i8)') ' ntwx_cache', -c & (icache_all(i),i=1,nodes) - ii_write=icache_all(1) - do i=2,nodes - if(icache_all(i).lt.ii_write) ii_write=icache_all(i) - enddo -c write(iout,*) "MIN ii_write=",ii_write - endif - endif -ctime call flush(iout) - endif - if(mremdsync .and. mod(itime,nstex).eq.0) then - synflag=.true. - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'REMD synchro at',itime - - if(traj1file) then - call mpi_gather(ntwx_cache,1,mpi_integer, - & icache_all,1,mpi_integer,king, - & CG_COMM,ierr) - if (me.eq.king) then - write(iout,'(a19,8000i8)') ' ntwx_cache', - & (icache_all(i),i=1,nodes) - ii_write=icache_all(1) - do i=2,nodes - if(icache_all(i).lt.ii_write) ii_write=icache_all(i) - enddo - write(iout,*) "MIN ii_write=",ii_write - endif - endif - - call flush(iout) - endif - if(synflag.and..not.end_of_run) then - time02=MPI_WTIME() - synflag=.false. - -cd write(iout,*) 'REMD before',me,t_bath - -c call mpi_gather(t_bath,1,mpi_double_precision, -c & remd_t_bath,1,mpi_double_precision,king, -c & CG_COMM,ierr) - potEcomp(n_ene+1)=t_bath - if (usampl) then - potEcomp(n_ene+2)=iset - if (iset.lt.nset) then - i_set_temp=iset - iset=iset+1 - call EconstrQ - potEcomp(n_ene+3)=Uconst - iset=i_set_temp - endif - if (iset.gt.1) then - i_set_temp=iset - iset=iset-1 - call EconstrQ - potEcomp(n_ene+4)=Uconst - iset=i_set_temp - endif - endif - call mpi_gather(potEcomp(0),n_ene+5,mpi_double_precision, - & remd_ene(0,1),n_ene+5,mpi_double_precision,king, - & CG_COMM,ierr) - if(lmuca) then - call mpi_gather(elow,1,mpi_double_precision, - & elowi,1,mpi_double_precision,king, - & CG_COMM,ierr) - call mpi_gather(ehigh,1,mpi_double_precision, - & ehighi,1,mpi_double_precision,king, - & CG_COMM,ierr) - endif - - time03=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD gather times=',time03-time01 - & ,time03-time02 - endif - - if (restart1file) call write1rst(i_index) - - time04=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD writing rst time=',time04-time03 - endif - - if (traj1file) call write1traj -cd debugging -cdeb call mpi_gather(ntwx_cache,1,mpi_integer, -cdeb & icache_all,1,mpi_integer,king, -cdeb & CG_COMM,ierr) -cdeb write(iout,'(a19,8000i8)') ' ntwx_cache after traj1file', -cdeb & (icache_all(i),i=1,nodes) -cd end - - - time05=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD writing traj time=',time05-time04 - call flush(iout) - endif - - - if (me.eq.king) then - do i=1,nodes - remd_t_bath(i)=remd_ene(n_ene+1,i) - iremd_iset(i)=remd_ene(n_ene+2,i) - enddo - if(lmuca) then -co write(iout,*) 'REMD exchange temp,ene,elow,ehigh' - do i=1,nodes - write(iout,'(i4,4f12.5)') i,remd_t_bath(i),remd_ene(0,i), - & elowi(i),ehighi(i) - enddo - else -cd write(iout,*) 'REMD exchange temp,ene' -c do i=1,nodes -co write(iout,'(i4,2f12.5)') i,remd_t_bath(i),remd_ene(0,i) -c write(iout,'(6f12.5)') (remd_ene(j,i),j=1,n_ene) -c enddo - endif -c------------------------------------- - IF(.not.usampl) THEN - write (iout,*) "Enter exchnge, remd_m",remd_m(1), - & " nodes",nodes - call flush(iout) - do irr=1,remd_m(1) - i=ifirst(iran_num(1,remd_m(1))) - call flush(iout) - - do ii=1,nodes-1 - - if(i.gt.0.and.nupa(0,i).gt.0) then - iex=nupa(iran_num(1,int(nupa(0,i))),i) - if (lmuca) then - call muca_delta(remd_t_bath,remd_ene,i,iex,delta) - else -c Swap temperatures between conformations i and iex with recalculating the free energies -c following temperature changes. - ene_iex_iex=remd_ene(0,iex) - ene_i_i=remd_ene(0,i) -cd write (iout,*) "rescaling weights with temperature", -cd & remd_t_bath(i) -cd call flush(iout) - call rescale_weights(remd_t_bath(i)) - -cd write (iout,*) "0,iex",remd_t_bath(i) -cd call enerprint(remd_ene(0,iex)) - - call sum_energy(remd_ene(0,iex),.false.) - ene_iex_i=remd_ene(0,iex) -cd write (iout,*) "ene_iex_i",remd_ene(0,iex) - -cd write (iout,*) "0,i",remd_t_bath(i) -cd call enerprint(remd_ene(0,i)) - - call sum_energy(remd_ene(0,i),.false.) -cd write (iout,*) "ene_i_i",remd_ene(0,i) -cd call flush(iout) -cd write (iout,*) "rescaling weights with temperature", -cd & remd_t_bath(iex) - if (real(ene_i_i).ne.real(remd_ene(0,i))) then - write (iout,*) "ERROR: inconsistent energies:",i, - & ene_i_i,remd_ene(0,i) - endif - call rescale_weights(remd_t_bath(iex)) - -cd write (iout,*) "0,i",remd_t_bath(iex) -cd call enerprint(remd_ene(0,i)) - - call sum_energy(remd_ene(0,i),.false.) -cd write (iout,*) "ene_i_iex",remd_ene(0,i) -cd call flush(iout) - ene_i_iex=remd_ene(0,i) - -cd write (iout,*) "0,iex",remd_t_bath(iex) -cd call enerprint(remd_ene(0,iex)) - - call sum_energy(remd_ene(0,iex),.false.) - if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then - write (iout,*) "ERROR: inconsistent energies:",iex, - & ene_iex_iex,remd_ene(0,iex) - endif -cd write (iout,*) "ene_iex_iex",remd_ene(0,iex) -cd write (iout,*) "i",i," iex",iex -cd write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, -cd & " ene_i_iex",ene_i_iex, -cd & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex -cd call flush(iout) - delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- - & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) - delta=-delta -cd write(iout,*) 'delta',delta -c delta=(remd_t_bath(i)-remd_t_bath(iex))* -c & (remd_ene(i)-remd_ene(iex))/Rb/ -c & (remd_t_bath(i)*remd_t_bath(iex)) - endif - if (delta .gt. 50.0d0) then - delta=0.0d0 - else -#ifdef OSF - if(isnan(delta))then - delta=0.0d0 - else if (delta.lt.-50.0d0) then - delta=dexp(50.0d0) - else - delta=dexp(-delta) - endif -#else - delta=dexp(-delta) -#endif - endif - iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 - xxx=ran_number(0.0d0,1.0d0) -cd write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx -cd call flush(iout) - if (delta .gt. xxx) then - tmp=remd_t_bath(i) - remd_t_bath(i)=remd_t_bath(iex) - remd_t_bath(iex)=tmp - remd_ene(0,i)=ene_i_iex - remd_ene(0,iex)=ene_iex_i - if(lmuca) then - tmp=elowi(i) - elowi(i)=elowi(iex) - elowi(iex)=tmp - tmp=ehighi(i) - ehighi(i)=ehighi(iex) - ehighi(iex)=tmp - endif - - - do k=0,nodes - itmp=nupa(k,i) - nupa(k,i)=nupa(k,iex) - nupa(k,iex)=itmp - itmp=ndowna(k,i) - ndowna(k,i)=ndowna(k,iex) - ndowna(k,iex)=itmp - enddo - do il=1,nodes - if (ifirst(il).eq.i) ifirst(il)=iex - do k=1,nupa(0,il) - if (nupa(k,il).eq.i) then - nupa(k,il)=iex - elseif (nupa(k,il).eq.iex) then - nupa(k,il)=i - endif - enddo - do k=1,ndowna(0,il) - if (ndowna(k,il).eq.i) then - ndowna(k,il)=iex - elseif (ndowna(k,il).eq.iex) then - ndowna(k,il)=i - endif - enddo - enddo - - iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 - itmp=i2rep(i-1) - i2rep(i-1)=i2rep(iex-1) - i2rep(iex-1)=itmp - -cd write(iout,*) 'exchange',i,iex -cd write (iout,'(a8,100i4)') "@ ifirst", -cd & (ifirst(k),k=1,remd_m(1)) -cd do il=1,nodes -cd write (iout,'(a8,i4,a1,100i4)') "@ nupa",il,":", -cd & (nupa(k,il),k=1,nupa(0,il)) -cd write (iout,'(a8,i4,a1,100i4)') "@ ndowna",il,":", -cd & (ndowna(k,il),k=1,ndowna(0,il)) -cd enddo - call flush(iout) - - else - remd_ene(0,iex)=ene_iex_iex - remd_ene(0,i)=ene_i_i - i=iex - endif - endif - enddo - enddo -cd write (iout,*) "exchange completed" -cd call flush(iout) - ELSE - do ii=1,nodes -cd write(iout,*) "########",ii - - i_temp=iran_num(1,nrep) - i_mult=iran_num(1,remd_m(i_temp)) - i_iset=iran_num(1,nset) - i_mset=iran_num(1,mset(i_iset)) - i=i_index(i_temp,i_mult,i_iset,i_mset) - -cd write(iout,*) "i=",i,i_temp,i_mult,i_iset,i_mset - - i_dir=iran_num(1,3) -cd write(iout,*) "i_dir=",i_dir - - if(i_dir.eq.1 .and. remd_m(i_temp+1).gt.0 )then - - i_temp1=i_temp+1 - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset - i_mset1=iran_num(1,mset(i_iset1)) - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - - elseif(i_dir.eq.2 .and. mset(i_iset+1).gt.0)then - - i_temp1=i_temp - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset+1 - i_mset1=iran_num(1,mset(i_iset1)) - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - econstr_temp_i=remd_ene(20,i) - econstr_temp_iex=remd_ene(20,iex) - remd_ene(20,i)=remd_ene(n_ene+3,i) - remd_ene(20,iex)=remd_ene(n_ene+4,iex) - - elseif(remd_m(i_temp+1).gt.0.and.mset(i_iset+1).gt.0)then - - i_temp1=i_temp+1 - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset+1 - i_mset1=iran_num(1,mset(i_iset1)) - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - econstr_temp_i=remd_ene(20,i) - econstr_temp_iex=remd_ene(20,iex) - remd_ene(20,i)=remd_ene(n_ene+3,i) - remd_ene(20,iex)=remd_ene(n_ene+4,iex) - - else - goto 444 - endif - -cd write(iout,*) "iex=",iex,i_temp1,i_mult1,i_iset1,i_mset1 - call flush(iout) - -c Swap temperatures between conformations i and iex with recalculating the free energies -c following temperature changes. - ene_iex_iex=remd_ene(0,iex) - ene_i_i=remd_ene(0,i) -co write (iout,*) "rescaling weights with temperature", -co & remd_t_bath(i) - call rescale_weights(remd_t_bath(i)) - - call sum_energy(remd_ene(0,iex),.false.) - ene_iex_i=remd_ene(0,iex) -cd write (iout,*) "ene_iex_i",remd_ene(0,iex) -c call sum_energy(remd_ene(0,i),.false.) -cd write (iout,*) "ene_i_i",remd_ene(0,i) -c write (iout,*) "rescaling weights with temperature", -c & remd_t_bath(iex) -c if (real(ene_i_i).ne.real(remd_ene(0,i))) then -c write (iout,*) "ERROR: inconsistent energies:",i, -c & ene_i_i,remd_ene(0,i) -c endif - call rescale_weights(remd_t_bath(iex)) - call sum_energy(remd_ene(0,i),.false.) -cd write (iout,*) "ene_i_iex",remd_ene(0,i) - ene_i_iex=remd_ene(0,i) -c call sum_energy(remd_ene(0,iex),.false.) -c if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then -c write (iout,*) "ERROR: inconsistent energies:",iex, -c & ene_iex_iex,remd_ene(0,iex) -c endif -cd write (iout,*) "ene_iex_iex",remd_ene(0,iex) -c write (iout,*) "i",i," iex",iex -cd write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, -cd & " ene_i_iex",ene_i_iex, -cd & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex - delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- - & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) - delta=-delta -cd write(iout,*) 'delta',delta -c delta=(remd_t_bath(i)-remd_t_bath(iex))* -c & (remd_ene(i)-remd_ene(iex))/Rb/ -c & (remd_t_bath(i)*remd_t_bath(iex)) - if (delta .gt. 50.0d0) then - delta=0.0d0 - else - delta=dexp(-delta) - endif - if (i_dir.eq.1.or.i_dir.eq.3) - & iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 - if (i_dir.eq.2.or.i_dir.eq.3) - & iremd_tot_usa(int(i2set(i-1)))= - & iremd_tot_usa(int(i2set(i-1)))+1 - xxx=ran_number(0.0d0,1.0d0) -cd write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx - if (delta .gt. xxx) then - tmp=remd_t_bath(i) - remd_t_bath(i)=remd_t_bath(iex) - remd_t_bath(iex)=tmp - - itmp=iremd_iset(i) - iremd_iset(i)=iremd_iset(iex) - iremd_iset(iex)=itmp - - remd_ene(0,i)=ene_i_iex - remd_ene(0,iex)=ene_iex_i - - if (i_dir.eq.1.or.i_dir.eq.3) - & iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 - - itmp=i2rep(i-1) - i2rep(i-1)=i2rep(iex-1) - i2rep(iex-1)=itmp - - if (i_dir.eq.2.or.i_dir.eq.3) - & iremd_acc_usa(int(i2set(i-1)))= - & iremd_acc_usa(int(i2set(i-1)))+1 - - itmp=i2set(i-1) - i2set(i-1)=i2set(iex-1) - i2set(iex-1)=itmp - - itmp=i_index(i_temp,i_mult,i_iset,i_mset) - i_index(i_temp,i_mult,i_iset,i_mset)= - & i_index(i_temp1,i_mult1,i_iset1,i_mset1) - i_index(i_temp1,i_mult1,i_iset1,i_mset1)=itmp - - else - remd_ene(0,iex)=ene_iex_iex - remd_ene(0,i)=ene_i_i - remd_ene(20,iex)=econstr_temp_iex - remd_ene(20,i)=econstr_temp_i - endif - -cd do il=1,nset -cd do il1=1,mset(il) -cd do i=1,nrep -cd do j=1,remd_m(i) -cd write(iout,*) i,j,il,il1,i_index(i,j,il,il1) -cd enddo -cd enddo -cd enddo -cd enddo - - 444 continue - - enddo - - - ENDIF - -c------------------------------------- - write (iout,*) "NREP",nrep - do i=1,nrep - if(iremd_tot(i).ne.0) - & write(iout,'(a3,i4,2f12.5,i5)') 'ACC',i,remd_t(i) - & ,iremd_acc(i)/(1.0*iremd_tot(i)),iremd_tot(i) - enddo - - if(usampl) then - do i=1,nset - if(iremd_tot_usa(i).ne.0) - & write(iout,'(a10,i4,f12.5,i8)') 'ACC_usampl',i, - & iremd_acc_usa(i)/(1.0*iremd_tot_usa(i)),iremd_tot_usa(i) - enddo - endif - - call flush(iout) - -cd write (iout,'(a6,100i4)') "ifirst", -cd & (ifirst(i),i=1,remd_m(1)) -cd do il=1,nodes -cd write (iout,'(a5,i4,a1,100i4)') "nup",il,":", -cd & (nupa(i,il),i=1,nupa(0,il)) -cd write (iout,'(a5,i4,a1,100i4)') "ndown",il,":", -cd & (ndowna(i,il),i=1,ndowna(0,il)) -cd enddo - endif - - time06=MPI_WTIME() -cd write (iout,*) "Before scatter" -cd call flush(iout) - call mpi_scatter(remd_t_bath,1,mpi_double_precision, - & t_bath,1,mpi_double_precision,king, - & CG_COMM,ierr) -cd write (iout,*) "After scatter" -cd call flush(iout) - if(usampl) - & call mpi_scatter(iremd_iset,1,mpi_integer, - & iset,1,mpi_integer,king, - & CG_COMM,ierr) - - time07=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD scatter time=',time07-time06 - endif - - if(lmuca) then - call mpi_scatter(elowi,1,mpi_double_precision, - & elow,1,mpi_double_precision,king, - & CG_COMM,ierr) - call mpi_scatter(ehighi,1,mpi_double_precision, - & ehigh,1,mpi_double_precision,king, - & CG_COMM,ierr) - endif - call rescale_weights(t_bath) -co write (iout,*) "Processor",me, -co & " rescaling weights with temperature",t_bath - - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - -cde write(iout,*) 'REMD after',me,t_bath - time08=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD exchange time=',time08-time00 - call flush(iout) - endif - endif - enddo - - if (restart1file) then - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'writing restart at the end of run' - call write1rst(i_index) - endif - - if (traj1file) call write1traj -cd debugging -cdeb call mpi_gather(ntwx_cache,1,mpi_integer, -cdeb & icache_all,1,mpi_integer,king, -cdeb & CG_COMM,ierr) -cdeb write(iout,'(a40,8000i8)') -cdeb & ' ntwx_cache after traj1file at the end', -cdeb & (icache_all(i),i=1,nodes) -cd end - - -#ifdef MPI - t_MD=MPI_Wtime() -#else - t_MD=tcpu()-tt0 -#endif - if (me.eq.king .or. .not. out1file) then - write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') - & ' Timing ', - & 'MD calculations setup:',t_MDsetup, - & 'Energy & gradient evaluation:',t_enegrad, - & 'Stochastic MD setup:',t_langsetup, - & 'Stochastic MD step setup:',t_sdsetup, - & 'MD steps:',t_MD - write (iout,'(/28(1h=),a25,27(1h=))') - & ' End of MD calculation ' - endif - return - end - -c----------------------------------------------------------------------- - - subroutine write1rst_oldtxt - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & d_restart2(3,2*maxres*maxprocs) - real t5_restart1(5) - integer iret,itmp - - - t5_restart1(1)=totT - t5_restart1(2)=EK - t5_restart1(3)=potE - t5_restart1(4)=t_bath - t5_restart1(5)=Uconst - - call mpi_gather(t5_restart1,5,mpi_real, - & t_restart1,5,mpi_real,king,CG_COMM,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=d_t(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart1,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=dc(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart2,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - if(me.eq.king) then - open(irest1,file=mremd_rst_name,status='unknown') - write (irest1,*) (i2rep(i),i=0,nodes-1) - write (irest1,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - write (irest1,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - - do il=1,nodes - write(irest1,*) (t_restart1(j,il),j=1,4) - enddo - - do il=0,nodes-1 - do i=1,2*nres - write(irest1,'(3e15.5)') (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - do il=0,nodes-1 - do i=1,2*nres - write(irest1,'(3e15.5)') (d_restart2(j,i+2*nres*il),j=1,3) - enddo - enddo - close(irest1) - endif - - return - end - - subroutine write1rst(i_index) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & d_restart2(3,2*maxres*maxprocs) - real t5_restart1(5) - integer iret,itmp - integer*2 i_index - & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) - - - t5_restart1(1)=totT - t5_restart1(2)=EK - t5_restart1(3)=potE - t5_restart1(4)=t_bath - t5_restart1(5)=Uconst - - call mpi_gather(t5_restart1,5,mpi_real, - & t_restart1,5,mpi_real,king,CG_COMM,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=d_t(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart1,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=dc(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart2,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - if(me.eq.king) then -c open(irest1,file=mremd_rst_name,status='unknown') - call xdrfopen(ixdrf,mremd_rst_name, "w", iret) -c write (irest1,*) (i2rep(i),i=0,nodes-1) - do i=0,nodes-1 - call xdrfint(ixdrf, i2rep(i), iret) - enddo -c write (irest1,*) (ifirst(i),i=1,remd_m(1)) - do i=1,remd_m(1) - call xdrfint(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes -c write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - do i=0,nupa(0,il) - call xdrfint(ixdrf, nupa(i,il), iret) - enddo - -c write (irest1,*) ndowna(0,il), -c & (ndowna(i,il),i=1,ndowna(0,il)) - do i=0,ndowna(0,il) - call xdrfint(ixdrf, ndowna(i,il), iret) - enddo - enddo - - do il=1,nodes -c write(irest1,*) (t_restart1(j,il),j=1,4) - do j=1,4 - call xdrffloat(ixdrf, t_restart1(j,il), iret) - enddo - enddo - - do il=0,nodes-1 - do i=1,2*nres -c write(irest1,'(3e15.5)') (d_restart1(j,i+2*nres*il),j=1,3) - do j=1,3 - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) - enddo - enddo - enddo - do il=0,nodes-1 - do i=1,2*nres -c write(irest1,'(3e15.5)') (d_restart2(j,i+2*nres*il),j=1,3) - do j=1,3 - call xdrffloat(ixdrf, d_restart2(j,i+2*nres*il), iret) - enddo - enddo - enddo - - - if(usampl) then -c write (irest1,*) nset - call xdrfint(ixdrf, nset, iret) -c write (irest1,*) (mset(i),i=1,nset) - do i=1,nset - call xdrfint(ixdrf,mset(i), iret) - enddo -c write (irest1,*) (i2set(i),i=0,nodes-1) - do i=0,nodes-1 - call xdrfint(ixdrf,i2set(i), iret) - enddo -c write (irest1,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep -c write(irest1,*) (i_index(i,j,il,il1),j=1,remd_m(i)) - do j=1,remd_m(i) - itmp=i_index(i,j,il,il1) - call xdrfint(ixdrf,itmp, iret) - enddo - enddo - enddo - enddo - - endif - -c close(irest1) - call xdrfclose(ixdrf, iret) - endif - - return - end - - - subroutine write1traj - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - - real t5_restart1(5) - integer iret,itmp - real xcoord(3,maxres2+2),prec - real r_qfrag(50),r_qpair(100) - real r_utheta(50),r_ugamma(100),r_uscdiff(100) - real p_qfrag(50*maxprocs),p_qpair(100*maxprocs) - real p_utheta(50*maxprocs),p_ugamma(100*maxprocs), - & p_uscdiff(100*maxprocs) - real p_c(3,(maxres2+2)*maxprocs),r_c(3,maxres2+2) - - call mpi_bcast(ii_write,1,mpi_integer, - & king,CG_COMM,ierr) - -c debugging - print *,'traj1file',me,ii_write,ntwx_cache -c end debugging - - if(me.eq.king) call xdrfopen(ixdrf,cartname, "a", iret) - do ii=1,ii_write - t5_restart1(1)=totT_cache(ii) - t5_restart1(2)=EK_cache(ii) - t5_restart1(3)=potE_cache(ii) - t5_restart1(4)=t_bath_cache(ii) - t5_restart1(5)=Uconst_cache(ii) - call mpi_gather(t5_restart1,5,mpi_real, - & t_restart1,5,mpi_real,king,CG_COMM,ierr) - - call mpi_gather(iset_cache(ii),1,mpi_integer, - & iset_restart1,1,mpi_integer,king,CG_COMM,ierr) - - do i=1,nfrag - r_qfrag(i)=qfrag_cache(i,ii) - enddo - do i=1,npair - r_qpair(i)=qpair_cache(i,ii) - enddo - do i=1,nfrag_back - r_utheta(i)=utheta_cache(i,ii) - r_ugamma(i)=ugamma_cache(i,ii) - r_uscdiff(i)=uscdiff_cache(i,ii) - enddo - - call mpi_gather(r_qfrag,nfrag,mpi_real, - & p_qfrag,nfrag,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(r_qpair,npair,mpi_real, - & p_qpair,npair,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(r_utheta,nfrag_back,mpi_real, - & p_utheta,nfrag_back,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(r_ugamma,nfrag_back,mpi_real, - & p_ugamma,nfrag_back,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(r_uscdiff,nfrag_back,mpi_real, - & p_uscdiff,nfrag_back,mpi_real,king, - & CG_COMM,ierr) - -#ifdef DEBUG - write (iout,*) "p_qfrag" - do i=1,nodes - write (iout,*) i,(p_qfrag((i-1)*nfrag+j),j=1,nfrag) - enddo - write (iout,*) "p_qpair" - do i=1,nodes - write (iout,*) i,(p_qpair((i-1)*npair+j),j=1,npair) - enddo - call flush(iout) -#endif - do i=1,nres*2 - do j=1,3 - r_c(j,i)=c_cache(j,i,ii) - enddo - enddo - - call mpi_gather(r_c,3*2*nres,mpi_real, - & p_c,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - if(me.eq.king) then - - do il=1,nodes - call xdrffloat(ixdrf, real(t_restart1(1,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(3,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(5,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(4,il)), iret) - call xdrfint(ixdrf, nss, iret) - do j=1,nss - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - enddo - call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret) - call xdrfint(ixdrf, iset_restart1(il), iret) - do i=1,nfrag - call xdrffloat(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) - enddo - do i=1,npair - call xdrffloat(ixdrf, p_qpair(i+(il-1)*npair), iret) - enddo - do i=1,nfrag_back - call xdrffloat(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret) - call xdrffloat(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret) - call xdrffloat(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret) - enddo - prec=10000.0 - do i=1,nres - do j=1,3 - xcoord(j,i)=p_c(j,i+(il-1)*nres*2) - enddo - enddo - do i=nnt,nct - do j=1,3 - xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) - enddo - enddo - itmp=nres+nct-nnt+1 - call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) - enddo - endif - enddo - if(me.eq.king) call xdrfclose(ixdrf, iret) - do i=1,ntwx_cache-ii_write - - totT_cache(i)=totT_cache(ii_write+i) - EK_cache(i)=EK_cache(ii_write+i) - potE_cache(i)=potE_cache(ii_write+i) - t_bath_cache(i)=t_bath_cache(ii_write+i) - Uconst_cache(i)=Uconst_cache(ii_write+i) - iset_cache(i)=iset_cache(ii_write+i) - - do ii=1,nfrag - qfrag_cache(ii,i)=qfrag_cache(ii,ii_write+i) - enddo - do ii=1,npair - qpair_cache(ii,i)=qpair_cache(ii,ii_write+i) - enddo - do ii=1,nfrag_back - utheta_cache(ii,i)=utheta_cache(ii,ii_write+i) - ugamma_cache(ii,i)=ugamma_cache(ii,ii_write+i) - uscdiff_cache(ii,i)=uscdiff_cache(ii,ii_write+i) - enddo - - do ii=1,nres*2 - do j=1,3 - c_cache(j,ii,i)=c_cache(j,ii,ii_write+i) - enddo - enddo - enddo - ntwx_cache=ntwx_cache-ii_write - return - end - - - subroutine read1restart(i_index) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & t5_restart1(5) - integer*2 i_index - & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) - write (*,*) "Processor",me," called read1restart" - - if(me.eq.king)then - open(irest2,file=mremd_rst_name,status='unknown') - read(irest2,*,err=334) i - write(iout,*) "Reading old rst in ASCI format" - close(irest2) - call read1restart_old - return - 334 continue - call xdrfopen(ixdrf,mremd_rst_name, "r", iret) - -c read (irest2,*) (i2rep(i),i=0,nodes-1) - do i=0,nodes-1 - call xdrfint(ixdrf, i2rep(i), iret) - enddo -c read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do i=1,remd_m(1) - call xdrfint(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes -c read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - call xdrfint(ixdrf, nupa(0,il), iret) - do i=1,nupa(0,il) - call xdrfint(ixdrf, nupa(i,il), iret) - enddo - -c read (irest2,*) ndowna(0,il), -c & (ndowna(i,il),i=1,ndowna(0,il)) - call xdrfint(ixdrf, ndowna(0,il), iret) - do i=1,ndowna(0,il) - call xdrfint(ixdrf, ndowna(i,il), iret) - enddo - enddo - do il=1,nodes -c read(irest2,*) (t_restart1(j,il),j=1,4) - do j=1,4 - call xdrffloat(ixdrf, t_restart1(j,il), iret) - enddo - enddo - endif - call mpi_scatter(t_restart1,5,mpi_real, - & t5_restart1,5,mpi_real,king,CG_COMM,ierr) - totT=t5_restart1(1) - EK=t5_restart1(2) - potE=t5_restart1(3) - t_bath=t5_restart1(4) - - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres -c read(irest2,'(3e15.5)') -c & (d_restart1(j,i+2*nres*il),j=1,3) - do j=1,3 - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) - enddo - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - - do i=1,2*nres - do j=1,3 - d_t(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres -c read(irest2,'(3e15.5)') -c & (d_restart1(j,i+2*nres*il),j=1,3) - do j=1,3 - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) - enddo - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - do i=1,2*nres - do j=1,3 - dc(j,i)=r_d(j,i) - enddo - enddo - - - if(usampl) then - if(me.eq.king)then - call xdrfint(ixdrf, nset, iret) - do i=1,nset - call xdrfint(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - call xdrfint(ixdrf,itmp, iret) - i_index(i,j,il,il1)=itmp - enddo - enddo - enddo - enddo - endif - - call mpi_scatter(i2set,1,mpi_integer, - & iset,1,mpi_integer,king, - & CG_COMM,ierr) - - endif - - - if(me.eq.king) close(irest2) - return - end - - subroutine read1restart_old - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & t5_restart1(5) - - if(me.eq.king)then - open(irest2,file=mremd_rst_name,status='unknown') - read (irest2,*) (i2rep(i),i=0,nodes-1) - read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - read (irest2,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - do il=1,nodes - read(irest2,*) (t_restart1(j,il),j=1,4) - enddo - endif - call mpi_scatter(t_restart1,5,mpi_real, - & t5_restart1,5,mpi_real,king,CG_COMM,ierr) - totT=t5_restart1(1) - EK=t5_restart1(2) - potE=t5_restart1(3) - t_bath=t5_restart1(4) - - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres - read(irest2,'(3e15.5)') - & (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - - do i=1,2*nres - do j=1,3 - d_t(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres - read(irest2,'(3e15.5)') - & (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - do i=1,2*nres - do j=1,3 - dc(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king) close(irest2) - return - end - diff --git a/source/unres/src_MD-M-newcorr/MREMD_nosy1traj.F b/source/unres/src_MD-M-newcorr/MREMD_nosy1traj.F deleted file mode 100644 index d9d524e..0000000 --- a/source/unres/src_MD-M-newcorr/MREMD_nosy1traj.F +++ /dev/null @@ -1,910 +0,0 @@ - subroutine MREMD - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.MUCA' - include 'COMMON.HAIRPIN' - double precision cm(3),L(3),vcm(3) - double precision energia(0:n_ene) - double precision remd_t_bath(maxprocs) - double precision remd_ene(0:n_ene+1,maxprocs) - integer iremd_acc(maxprocs),iremd_tot(maxprocs) - integer ilen,rstcount - external ilen - character*50 tytul - common /gucio/ cm - integer itime - integer nup(0:maxprocs),ndown(0:maxprocs) - integer rep2i(0:maxprocs) - integer itime_all(maxprocs) - integer status(MPI_STATUS_SIZE) - logical synflag,end_of_run,file_exist - - time00=MPI_WTIME() - if(me.eq.king.or..not.out1file) - & write (iout,*) 'MREMD',nodes,'time before',time00-walltime - - synflag=.false. - mremd_rst_name=prefix(:ilen(prefix))//"_mremd.rst" - -cd print *,'MREMD',nodes - -cd print *,'mmm',me,remd_mlist,(remd_m(i),i=1,nrep) - -cde write (iout,*) "Start MREMD: me",me," t_bath",t_bath - k=0 - rep2i(k)=-1 - do i=1,nrep - iremd_acc(i)=0 - iremd_tot(i)=0 - do j=1,remd_m(i) - i2rep(k)=i - rep2i(i)=k - k=k+1 - enddo - enddo - -c print *,'i2rep',me,i2rep(me) -c print *,'rep2i',(rep2i(i),i=0,nrep) - - if (i2rep(me).eq.nrep) then - nup(0)=0 - else - nup(0)=remd_m(i2rep(me)+1) - k=rep2i(i2rep(me))+1 - do i=1,nup(0) - nup(i)=k - k=k+1 - enddo - endif - -cd print '(i4,a4,100i4)',me,' nup',(nup(i),i=0,nup(0)) - - if (i2rep(me).eq.1) then - ndown(0)=0 - else - ndown(0)=remd_m(i2rep(me)-1) - k=rep2i(i2rep(me)-2)+1 - do i=1,ndown(0) - ndown(i)=k - k=k+1 - enddo - endif - -cd print '(i4,a6,100i4)',me,' ndown',(ndown(i),i=0,ndown(0)) - - - if(rest.and.restart1file) then - inquire(file=mremd_rst_name,exist=file_exist) - if(file_exist) call read1restart - endif - - if(me.eq.king) then - if (rest.and..not.restart1file) - & inquire(file=mremd_rst_name,exist=file_exist) - IF (rest.and.file_exist.and..not.restart1file) THEN - open(irest2,file=mremd_rst_name,status='unknown') - read (irest2,*) - read (irest2,*) (i2rep(i),i=0,nodes-1) - read (irest2,*) - read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - read (irest2,*) - read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - read (irest2,*) - read (irest2,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - close(irest2) - - write (iout,'(a6,1000i5)') "i2rep",(i2rep(i),i=0,nodes-1) - write (iout,'(a6,1000i5)') "ifirst", - & (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (iout,'(a6,i4,a1,100i4)') "nupa",il,":", - & (nupa(i,il),i=1,nupa(0,il)) - write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":", - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - ELSE - do il=1,remd_m(1) - ifirst(il)=il - enddo - - do il=1,nodes - - if (i2rep(il-1).eq.nrep) then - nupa(0,il)=0 - else - nupa(0,il)=remd_m(i2rep(il-1)+1) - k=rep2i(i2rep(il-1))+1 - do i=1,nupa(0,il) - nupa(i,il)=k+1 - k=k+1 - enddo - endif - - if (i2rep(il-1).eq.1) then - ndowna(0,il)=0 - else - ndowna(0,il)=remd_m(i2rep(il-1)-1) - k=rep2i(i2rep(il-1)-2)+1 - do i=1,ndowna(0,il) - ndowna(i,il)=k+1 - k=k+1 - enddo - endif - - enddo - -c write (iout,'(a6,100i4)') "ifirst", -c & (ifirst(i),i=1,remd_m(1)) -c do il=1,nodes -c write (iout,'(a6,i4,a1,100i4)') "nupa",il,":", -c & (nupa(i,il),i=1,nupa(0,il)) -c write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":", -c & (ndowna(i,il),i=1,ndowna(0,il)) -c enddo - - ENDIF - endif -c -c t_bath=retmin+(retmax-retmin)*me/(nodes-1) - if(.not.(rest.and.file_exist.and.restart1file)) then - if (me .eq. king) then - t_bath=retmin - else - t_bath=retmin+(retmax-retmin)*exp(float(i2rep(me)-nrep)) - endif -cd print *,'ttt',me,remd_tlist,(remd_t(i),i=1,nrep) - if (remd_tlist) t_bath=remd_t(i2rep(me)) - endif -c - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - -c print *,'irep',me,t_bath - if (.not.rest) then - if (me.eq.king .or. .not. out1file) - & write (iout,'(a60,f10.5)') "REMD Temperature:",t_bath - call rescale_weights(t_bath) - endif - - -c------copy MD-------------- -c The driver for molecular dynamics subroutines -c------------------------------------------------ - t_MDsetup=0.0d0 - t_langsetup=0.0d0 - t_MD=0.0d0 - t_enegrad=0.0d0 - t_sdsetup=0.0d0 - if(me.eq.king.or..not.out1file) - & write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" - tt0 = tcpu() -c Determine the inverse of the inertia matrix. - call setup_MD_matrices -c Initialize MD - call init_MD - if (rest) then - if (me.eq.king .or. .not. out1file) - & write (iout,'(a60,f10.5)') "REMD restart Temperature:",t_bath - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - call rescale_weights(t_bath) - endif - - t_MDsetup = tcpu()-tt0 - rstcount=0 -c Entering the MD loop - tt0 = tcpu() - if (lang.eq.2 .or. lang.eq.3) then - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo -#endif - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - time00=MPI_WTIME() - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'Setup time',time00-walltime - call flush(iout) - t_langsetup=tcpu()-tt0 - tt0=tcpu() - itime=0 - end_of_run=.false. - do while(.not.end_of_run) - itime=itime+1 - if(itime.eq.n_timestep.and.me.eq.king) end_of_run=.true. - if(mremdsync.and.itime.eq.n_timestep) end_of_run=.true. - rstcount=rstcount+1 - if (lang.gt.0 .and. surfarea .and. - & mod(itime,reset_fricmat).eq.0) then - if (lang.eq.2 .or. lang.eq.3) then - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo -#endif - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - write (iout,'(a,i10)') - & "Friction matrix reset based on surface area, itime",itime - endif - if (reset_vel .and. tbf .and. lang.eq.0 - & .and. mod(itime,count_reset_vel).eq.0) then - call random_vel - if (me.eq.king .or. .not. out1file) - & write(iout,'(a,f20.2)') - & "Velocities reset to random values, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - endif - if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then - call inertia_tensor - call vcm_vel(vcm) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen*Rb)*EK - scalfac=dsqrt(T_bath/kinetic_T) -cd write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=scalfac*d_t(j,i) - enddo - enddo - endif - if (lang.ne.4) then - if (RESPA) then -c Time-reversible RESPA algorithm -c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) - call RESPA_step(itime) - else -c Variable time step algorithm. - call velverlet_step(itime) - endif - else - call brown_step(itime) - endif - if(ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) call statout(itime) - endif - if (mod(itime,ntwx).eq.0.and..not.traj1file) then - write (tytul,'("time",f8.2," temp",f8.1)') totT,t_bath - if(mdpdb) then - call hairpin(.true.,nharp,iharp) - call secondary2(.true.) - call pdbout(potE,tytul,ipdb) - else - call cartout(totT) - endif - endif - if ((rstcount.eq.1000.or.itime.eq.n_timestep) - & .and..not.restart1file) then - - if(me.eq.king) then - open(irest1,file=mremd_rst_name,status='unknown') - write (irest1,*) "i2rep" - write (irest1,*) (i2rep(i),i=0,nodes-1) - write (irest1,*) "ifirst" - write (irest1,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (irest1,*) "nupa",il - write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - write (irest1,*) "ndowna",il - write (irest1,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - close(irest1) - endif - open(irest2,file=rest2name,status='unknown') - write(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - write (irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - close(irest2) - rstcount=0 - endif - -c REMD - exchange -c forced synchronization - if (mod(itime,100).eq.0 .and. me.ne.king - & .and. .not. mremdsync) then - synflag=.false. - call mpi_iprobe(0,101,CG_COMM,synflag,status,ierr) - if (synflag) then - call mpi_recv(itime_master, 1, MPI_INTEGER, - & 0,101,CG_COMM, status, ierr) - if (.not. out1file) then - write(iout,*) 'REMD synchro at',itime_master,itime - else - call mpi_gather(itime,1,mpi_integer, - & itime_all,1,mpi_integer,king, - & CG_COMM,ierr) - endif - if(itime_master.ge.n_timestep) end_of_run=.true. - call flush(iout) - endif - endif - -c REMD - exchange - if ((mod(itime,nstex).eq.0.and.me.eq.king - & .or.end_of_run.and.me.eq.king ) - & .and. .not. mremdsync ) then - synflag=.true. - time00=MPI_WTIME() - do i=1,nodes-1 - call mpi_isend(itime,1,MPI_INTEGER,i,101, - & CG_COMM, ireq, ierr) -cd write(iout,*) 'REMD synchro with',i -cd call flush(iout) - enddo - time02=MPI_WTIME() - write(iout,*) 'REMD synchro at',itime,'time=',time02-time00 - if (out1file) then - call mpi_gather(itime,1,mpi_integer, - & itime_all,1,mpi_integer,king, - & CG_COMM,ierr) - write(iout,'(a18,8000i8)') 'REMD synchro itime', - & (itime_all(i),i=1,nodes) - endif - call flush(iout) - endif - if(mremdsync .and. mod(itime,nstex).eq.0) then - synflag=.true. - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'REMD synchro at',itime - call flush(iout) - endif - if(synflag.and..not.end_of_run) then - time00=MPI_WTIME() - synflag=.false. - -cd write(iout,*) 'REMD before',me,t_bath - -c call mpi_gather(t_bath,1,mpi_double_precision, -c & remd_t_bath,1,mpi_double_precision,king, -c & CG_COMM,ierr) - potEcomp(n_ene+1)=t_bath - call mpi_gather(potEcomp(0),n_ene+2,mpi_double_precision, - & remd_ene(0,1),n_ene+2,mpi_double_precision,king, - & CG_COMM,ierr) - if(lmuca) then - call mpi_gather(elow,1,mpi_double_precision, - & elowi,1,mpi_double_precision,king, - & CG_COMM,ierr) - call mpi_gather(ehigh,1,mpi_double_precision, - & ehighi,1,mpi_double_precision,king, - & CG_COMM,ierr) - endif - - if (restart1file) call write1rst - if (traj1file) call write1traj - - if (me.eq.king) then - do i=1,nodes - remd_t_bath(i)=remd_ene(n_ene+1,i) - enddo - if(lmuca) then -co write(iout,*) 'REMD exchange temp,ene,elow,ehigh' - do i=1,nodes - write(iout,'(i4,4f12.5)') i,remd_t_bath(i),remd_ene(0,i), - & elowi(i),ehighi(i) - enddo - else -cd write(iout,*) 'REMD exchange temp,ene' -c do i=1,nodes -co write(iout,'(i4,2f12.5)') i,remd_t_bath(i),remd_ene(0,i) -c write(iout,'(6f12.5)') (remd_ene(j,i),j=1,n_ene) -c enddo - endif -c------------------------------------- - do irr=1,remd_m(1) - i=ifirst(iran_num(1,remd_m(1))) - do ii=1,nodes-1 - - if(i.gt.0.and.nupa(0,i).gt.0) then - iex=nupa(iran_num(1,int(nupa(0,i))),i) - if (lmuca) then - call muca_delta(remd_t_bath,remd_ene,i,iex,delta) - else -c Swap temperatures between conformations i and iex with recalculating the free energies -c following temperature changes. - ene_iex_iex=remd_ene(0,iex) - ene_i_i=remd_ene(0,i) -co write (iout,*) "rescaling weights with temperature", -co & remd_t_bath(i) - call rescale_weights(remd_t_bath(i)) - call sum_energy(remd_ene(0,iex),.false.) - ene_iex_i=remd_ene(0,iex) -cd write (iout,*) "ene_iex_i",remd_ene(0,iex) - call sum_energy(remd_ene(0,i),.false.) -cd write (iout,*) "ene_i_i",remd_ene(0,i) -c write (iout,*) "rescaling weights with temperature", -c & remd_t_bath(iex) - if (real(ene_i_i).ne.real(remd_ene(0,i))) then - write (iout,*) "ERROR: inconsistent energies:",i, - & ene_i_i,remd_ene(0,i) - endif - call rescale_weights(remd_t_bath(iex)) - call sum_energy(remd_ene(0,i),.false.) -c write (iout,*) "ene_i_iex",remd_ene(0,i) - ene_i_iex=remd_ene(0,i) - call sum_energy(remd_ene(0,iex),.false.) - if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then - write (iout,*) "ERROR: inconsistent energies:",iex, - & ene_iex_iex,remd_ene(0,iex) - endif -c write (iout,*) "ene_iex_iex",remd_ene(0,iex) -c write (iout,*) "i",i," iex",iex -co write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, -co & " ene_i_iex",ene_i_iex, -co & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex - delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- - & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) - delta=-delta -c write(iout,*) 'delta',delta -c delta=(remd_t_bath(i)-remd_t_bath(iex))* -c & (remd_ene(i)-remd_ene(iex))/Rb/ -c & (remd_t_bath(i)*remd_t_bath(iex)) - endif - if (delta .gt. 50.0d0) then - delta=0.0d0 - else -#ifdef OSF - if(isnan(delta))then - delta=0.0d0 - else if (delta.lt.-50.0d0) then - delta=dexp(50.0d0) - else - delta=dexp(-delta) - endif -#else - delta=dexp(-delta) -#endif - endif - iremd_tot(i2rep(i-1))=iremd_tot(i2rep(i-1))+1 - xxx=ran_number(0.0d0,1.0d0) -co write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx - if (delta .gt. xxx) then - tmp=remd_t_bath(i) - remd_t_bath(i)=remd_t_bath(iex) - remd_t_bath(iex)=tmp - remd_ene(0,i)=ene_i_iex - remd_ene(0,iex)=ene_iex_i - if(lmuca) then - tmp=elowi(i) - elowi(i)=elowi(iex) - elowi(iex)=tmp - tmp=ehighi(i) - ehighi(i)=ehighi(iex) - ehighi(iex)=tmp - endif - - - do k=0,nodes - itmp=nupa(k,i) - nupa(k,i)=nupa(k,iex) - nupa(k,iex)=itmp - itmp=ndowna(k,i) - ndowna(k,i)=ndowna(k,iex) - ndowna(k,iex)=itmp - enddo - do il=1,nodes - if (ifirst(il).eq.i) ifirst(il)=iex - do k=1,nupa(0,il) - if (nupa(k,il).eq.i) then - nupa(k,il)=iex - elseif (nupa(k,il).eq.iex) then - nupa(k,il)=i - endif - enddo - do k=1,ndowna(0,il) - if (ndowna(k,il).eq.i) then - ndowna(k,il)=iex - elseif (ndowna(k,il).eq.iex) then - ndowna(k,il)=i - endif - enddo - enddo - - iremd_acc(i2rep(i-1))=iremd_acc(i2rep(i-1))+1 - itmp=i2rep(i-1) - i2rep(i-1)=i2rep(iex-1) - i2rep(iex-1)=itmp - -cd write(iout,*) 'exchange',i,iex -cd write (iout,'(a8,100i4)') "@ ifirst", -cd & (ifirst(k),k=1,remd_m(1)) -cd do il=1,nodes -cd write (iout,'(a8,i4,a1,100i4)') "@ nupa",il,":", -cd & (nupa(k,il),k=1,nupa(0,il)) -cd write (iout,'(a8,i4,a1,100i4)') "@ ndowna",il,":", -cd & (ndowna(k,il),k=1,ndowna(0,il)) -cd enddo - - else - remd_ene(0,iex)=ene_iex_iex - remd_ene(0,i)=ene_i_i - i=iex - endif - endif - enddo - enddo -c------------------------------------- - do i=1,nrep - if(iremd_tot(i).ne.0) - & write(iout,'(a3,i4,2f12.5)') 'ACC',i,remd_t(i) - & ,iremd_acc(i)/(1.0*iremd_tot(i)) - enddo - -cd write (iout,'(a6,100i4)') "ifirst", -cd & (ifirst(i),i=1,remd_m(1)) -cd do il=1,nodes -cd write (iout,'(a5,i4,a1,100i4)') "nup",il,":", -cd & (nupa(i,il),i=1,nupa(0,il)) -cd write (iout,'(a5,i4,a1,100i4)') "ndown",il,":", -cd & (ndowna(i,il),i=1,ndowna(0,il)) -cd enddo - endif - - call mpi_scatter(remd_t_bath,1,mpi_double_precision, - & t_bath,1,mpi_double_precision,king, - & CG_COMM,ierr) - if(lmuca) then - call mpi_scatter(elowi,1,mpi_double_precision, - & elow,1,mpi_double_precision,king, - & CG_COMM,ierr) - call mpi_scatter(ehighi,1,mpi_double_precision, - & ehigh,1,mpi_double_precision,king, - & CG_COMM,ierr) - endif - call rescale_weights(t_bath) -co write (iout,*) "Processor",me, -co & " rescaling weights with temperature",t_bath - - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - -cde write(iout,*) 'REMD after',me,t_bath - time02=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD exchange time=',time02-time00 - call flush(iout) - endif - endif - enddo - - if (restart1file) then - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'writing restart at the end of run' - call write1rst - endif - - if (traj1file) call write1traj - - - t_MD=tcpu()-tt0 - if (me.eq.king .or. .not. out1file) then - write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') - & ' Timing ', - & 'MD calculations setup:',t_MDsetup, - & 'Energy & gradient evaluation:',t_enegrad, - & 'Stochastic MD setup:',t_langsetup, - & 'Stochastic MD step setup:',t_sdsetup, - & 'MD steps:',t_MD - write (iout,'(/28(1h=),a25,27(1h=))') - & ' End of MD calculation ' - endif - return - end - - subroutine write1rst - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & d_restart2(3,2*maxres*maxprocs) - real t5_restart1(5) - integer iret,itmp - - - t5_restart1(1)=totT - t5_restart1(2)=EK - t5_restart1(3)=potE - t5_restart1(4)=t_bath - t5_restart1(5)=Uconst - - call mpi_gather(t5_restart1,5,mpi_real, - & t_restart1,5,mpi_real,king,CG_COMM,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=d_t(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart1,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=dc(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart2,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - if(me.eq.king) then - open(irest1,file=mremd_rst_name,status='unknown') - write (irest1,*) (i2rep(i),i=0,nodes-1) - write (irest1,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - write (irest1,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - - do il=1,nodes - write(irest1,*) (t_restart1(j,il),j=1,4) - enddo - - do il=0,nodes-1 - do i=1,2*nres - write(irest1,'(3e15.5)') (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - do il=0,nodes-1 - do i=1,2*nres - write(irest1,'(3e15.5)') (d_restart2(j,i+2*nres*il),j=1,3) - enddo - enddo - close(irest1) - endif - - - return - end - - subroutine write1traj - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - - real t5_restart1(5) - integer iret,itmp - real xcoord(3,maxres2+2),prec - real r_qfrag(50),r_qpair(100) - real p_qfrag(50*maxprocs),p_qpair(100*maxprocs) - real p_c(3,(maxres2+2)*maxprocs),r_c(3,maxres2+2) - - if(.not.restart1file) then - t5_restart1(1)=totT - t5_restart1(2)=EK - t5_restart1(3)=potE - t5_restart1(4)=t_bath - t5_restart1(5)=Uconst - call mpi_gather(t5_restart1,5,mpi_real, - & t_restart1,5,mpi_real,king,CG_COMM,ierr) - endif - - do i=1,nfrag - r_qfrag(i)=qfrag(i) - enddo - do i=1,npair - r_qpair(i)=qpair(i) - enddo - - call mpi_gather(r_qfrag,nfrag,mpi_real, - & p_qfrag,nfrag,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(qpair,nfrag,mpi_real, - & p_qpair,nfrag,mpi_real,king, - & CG_COMM,ierr) - - do i=1,nres*2 - do j=1,3 - r_c(j,i)=c(j,i) - enddo - enddo - - call mpi_gather(r_c,3*2*nres,mpi_real, - & p_c,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - if(me.eq.king) then - call xdrfopen(ixdrf,cartname, "a", iret) - do il=1,nodes - call xdrffloat(ixdrf, real(t_restart1(1,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(3,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(5,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(4,il)), iret) - call xdrfint(ixdrf, nss, iret) - do j=1,nss - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - enddo - call xdrfint(ixdrf, nfrag+npair, iret) - do i=1,nfrag - call xdrffloat(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) - enddo - do i=1,npair - call xdrffloat(ixdrf, p_qpair(i+(il-1)*npair), iret) - enddo - prec=10000.0 - do i=1,nres - do j=1,3 - xcoord(j,i)=p_c(j,i+(il-1)*nres*2) - enddo - enddo - do i=nnt,nct - do j=1,3 - xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) - enddo - enddo - itmp=nres+nct-nnt+1 - call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) - enddo - call xdrfclose(ixdrf, iret) - endif - - return - end - - - subroutine read1restart - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & t5_restart1(5) - - if(me.eq.king)then - open(irest2,file=mremd_rst_name,status='unknown') - read (irest2,*) (i2rep(i),i=0,nodes-1) - read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - read (irest2,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - do il=1,nodes - read(irest2,*) (t_restart1(j,il),j=1,4) - enddo - endif - call mpi_scatter(t_restart1,5,mpi_real, - & t5_restart1,5,mpi_real,king,CG_COMM,ierr) - totT=t5_restart1(1) - EK=t5_restart1(2) - potE=t5_restart1(3) - t_bath=t5_restart1(4) - - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres - read(irest2,'(3e15.5)') - & (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - - do i=1,2*nres - do j=1,3 - d_t(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres - read(irest2,'(3e15.5)') - & (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - do i=1,2*nres - do j=1,3 - dc(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king) close(irest2) - return - end - diff --git a/source/unres/src_MD-M-newcorr/Makefile b/source/unres/src_MD-M-newcorr/Makefile deleted file mode 120000 index 8453cdd..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile +++ /dev/null @@ -1 +0,0 @@ -Makefile_MPICH_ifort \ No newline at end of file diff --git a/source/unres/src_MD-M-newcorr/Makefile-biosim b/source/unres/src_MD-M-newcorr/Makefile-biosim deleted file mode 100644 index e8de82a..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile-biosim +++ /dev/null @@ -1,127 +0,0 @@ -#CPPFLAGS = -WF,-DOLD_GINV \ - -WF,-DUNRES -WF,-DMP -WF,-DMPI \ - -WF,-DSPLITELE -WF,-DISNAN \ - -WF,-DAIX -WF,-DLANG0 -WF,-DPROCOR -# -INSTALL_DIR = /opt/mpich-pgi -CC = cc -FC=mpif90 -PGI=/opt/pgi -#OPT = -fast -pc 64 -tp p6 \ -#-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 -OPT = -fast - -OPT1 = -fast -#OPT = -C -g -#OPT1 = -C -g - -# -Mvect <---slows down -# -Minline=name:matmat2 <---false convergence - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGSE = ${FFLAGS} -FFLAGS2 = ${FFLAGS} - -BIN = /home/aliwo/UNRES/MD/bin/unres_MD_Tc-new-fg.exe -LIBS = ../src_Tc_cache/xdrf_new/libxdrf.a -#LIBS=-lmpichfsup -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DOLD_GINV -DLANG0 -CFLAGS = -DLINUX -DPGI -c - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split.o \ - q_measure.o gnmr1.o - -unres: ${object} proc_proc.o - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-M-newcorr/Makefile-intrepid-with-tau b/source/unres/src_MD-M-newcorr/Makefile-intrepid-with-tau deleted file mode 100644 index eae1cc5..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile-intrepid-with-tau +++ /dev/null @@ -1,154 +0,0 @@ -# -FC1=/bgsys/drivers/ppcfloor/comm/bin/mpixlf77 -FC=tau_f90.sh -OPT = -O3 -qarch=450 -qtune=450 -qfixed -#OPT = -O3 -qarch=450 -qtune=450 -qdebug=function_trace -qfixed -#OPT = -O -qarch=450 -qtune=450 -qfixed -#-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ -#-Mprefetch=distance:8,nta - -#OPT = -O0 -C -g -qarch=450 -qtune=450 -qfixed -OPT1 = -O0 -g -qarch=450 -qtune=450 -qfixed -OPT2 = -O2 -qarch=450 -qtune=450 -qfixed -#OPT2 = -O2 -qarch=450 -qtune=450 -qdebug=function_trace -qfixed -#OPT2 = ${OPT} -OPTE = -O4 -qarch=450 -qtune=450 -qfixed -#OPTE = -O4 -qarch=450 -qtune=450 -qdebug=function_trace -qfixed -#OPTE=${OPT} - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include -FFLAGSE = -c ${OPTE} -I$(INSTALL_DIR)/include - -BIN = ../bin/unres_MD_Tc_procor-newparm-gnivpar-O4-test.exe -#LIBS = xdrf/libxdrf.a /home/liwo/UNRES/LIB/libmemmon.a -LIBS = xdrf/libxdrf.a - -CPPFLAGS = -WF,-DAIX -WF,-DISNAN -WF,-DUNRES -WF,-DMP -WF,-DMPI -WF,-DPGI \ - -WF,-DSPLITELE -WF,-DPROCOR -WF,-DAMD64 -WF,-DLANG0 - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new.o \ - energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - ${CC} -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} --print-map ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o; /bin/rm *.pp.* - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS1} ${CPPFLAGS} rmdd.f - -eigen.o : eigen.f - ${FC} ${FFLAGS1} ${CPPFLAGS} eigen.f - -blas.o : blas.f - ${FC} ${FFLAGS1} ${CPPFLAGS} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} ${CPPFLAGS} add.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -energy_p_new-sep.o : energy_p_new-sep.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -compinfo: compinfo.o - ${CC} ${CFLAGS} compfinfo.c - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c - -prng_32.o: prng_32.F - ${FC} -qfixed -O0 prng_32.F - -prng.o: prng.f - ${FC1} ${FFLAGS} prng.f - -readrtns_CSA.o: readrtns_CSA.F - ${FC1} ${FFLAGS} ${CPPFLAGS} readrtns_CSA.F - -gen_rand_conf.o: gen_rand_conf.F - ${FC1} ${FFLAGS} ${CPPFLAGS} gen_rand_conf.F diff --git a/source/unres/src_MD-M-newcorr/Makefile-matrix-intel b/source/unres/src_MD-M-newcorr/Makefile-matrix-intel deleted file mode 100644 index c81649f..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile-matrix-intel +++ /dev/null @@ -1,124 +0,0 @@ -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI \ - -DPGI -DSPLITELE -DISNAN -DAMD64 \ - -DPROCOR -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -## -DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -#INSTALL_DIR = /usr/local/mpich-1.2.0 -INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/ -# -#FC= /usr/local/opt/intel/compiler60/ia32/bin/ifc -FC= ifort - -OPT = -O3 -ip -w - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - -BIN = unres_Tc_procor_new_em64-fg.exe -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich xdrf/libxdrf.a -#LIBS = -L$(INSTALL_DIR)/lib_ifort -lmpich xdrf/libxdrf.a -LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf_em64/libxdrf.a -g -d2 -CA -CB - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split.o \ - q_measure.o gnmr1.o - -unres: ${object} proc_proc.o - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-M-newcorr/Makefile-matrix3 b/source/unres/src_MD-M-newcorr/Makefile-matrix3 deleted file mode 100644 index 3a50a21..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile-matrix3 +++ /dev/null @@ -1,141 +0,0 @@ -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI \ - -DPGI -DSPLITELE -DISNAN -DAMD64 \ - -DPROCOR \ -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -## -DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -CFLAGS = -DSGI -c - -#INSTALL_DIR = /usr/local/mpich-1.2.0 -INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh -# -#FC= /usr/local/opt/intel/compiler60/ia32/bin/ifc -FC= ifort - -OPT = -O3 -ip -w - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - -#FFLAGS = -c -C -g -I$(INSTALL_DIR)/include -#FFLAGS1 = -c -g -I$(INSTALL_DIR)/include -#FFLAGS2 = -c -C -g -I$(INSTALL_DIR)/include -#FFLAGSE = -c -C -g -I$(INSTALL_DIR)/include - -BIN = ../bin/unres_Tc_procor_em64-D-finegrain.exe -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich xdrf/libxdrf.a -#LIBS = -L$(INSTALL_DIR)/lib_ifort -lmpich xdrf/libxdrf.a -LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf_em64/libxdrf.a -g -d2 -CA -CB - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} proc_proc.o - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -eigen.o : eigen.f - ${FC} ${FFLAGS} eigen.f - -blas.o : blas.f - ${FC} ${FFLAGS} blas.f - -add.o : add.f - ${FC} ${FFLAGS} add.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-M-newcorr/Makefile-matrix3-oldparm b/source/unres/src_MD-M-newcorr/Makefile-matrix3-oldparm deleted file mode 100644 index 9096f63..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile-matrix3-oldparm +++ /dev/null @@ -1,127 +0,0 @@ -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI \ - -DPGI -DSPLITELE -DISNAN -DAMD64 \ - -DPROCOR -DLANG0 \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -## -DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -#INSTALL_DIR = /usr/local/mpich-1.2.0 -INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh -# -#FC= /usr/local/opt/intel/compiler60/ia32/bin/ifc -FC= ifort - -OPT = -O3 -ip -w - -CFLAGS = -DSGI -c - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - -BIN = ../bin/unres_Tc_procor_oldparm_em64-D-finegrain.exe -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich xdrf/libxdrf.a -#LIBS = -L$(INSTALL_DIR)/lib_ifort -lmpich xdrf/libxdrf.a -LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf_em64/libxdrf.a -g -d2 -CA -CB - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} proc_proc.o - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} -Wl,-M ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-M-newcorr/Makefile-oldparm b/source/unres/src_MD-M-newcorr/Makefile-oldparm deleted file mode 100644 index bf12898..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile-oldparm +++ /dev/null @@ -1,130 +0,0 @@ -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI \ - -DPGI -DSPLITELE -DISNAN -DAMD64 \ - -DPROCOR \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -## -DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -#INSTALL_DIR = /usr/local/mpich-1.2.0 -#INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/ -INSTALL_DIR = /opt/mpi/mvapich -# -#FC= /usr/local/opt/intel/compiler60/ia32/bin/ifc -FC= ifort -FCL = ${INSTALL_DIR}/bin/mpif77 - -OPT = -O3 -ip -w - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - -BIN = unres_Tc_procor_new_em64-oldparm.exe -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich xdrf/libxdrf.a -#LIBS = -L$(INSTALL_DIR)/lib_ifort -lmpich xdrf/libxdrf.a -LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpthread xdrf_em64/libxdrf.a -g -d2 -CA -CB - -ARCH = LINUX -PP = /lib/cpp -P - -all: unresCSA - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -objectCSA = unres_CSA.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o energy_p_new.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split.o \ - q_measure3.o econstr_local.o gnmr1.o check_sc_map.o check_bond.o - -unresCSA: ${objectCSA} - cc -o compinfo compinfo.c - ./compinfo - ${FC} ${FFLAGS} cinfo.f - ${FCL} -static-libcxa ${OPT} ${objectCSA} cinfo.o ${LIBS} -o ${BIN} - mv ${BIN} ../bin - -clean: - /bin/rm *.o - /bin/rm *.il - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -readrtns_CSA.o : readrtns_CSA.F - ${FC} ${FFLAGS1} ${CPPFLAGS} readrtns_CSA.F - -MREMD.o : MREMD.F - ${FC} ${FFLAGS1} ${CPPFLAGS} MREMD.F - diff --git a/source/unres/src_MD-M-newcorr/Makefile-rstconv b/source/unres/src_MD-M-newcorr/Makefile-rstconv deleted file mode 100644 index 58d5e5f..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile-rstconv +++ /dev/null @@ -1,40 +0,0 @@ -# -FC= ifort -FCL = ${INSTALL_DIR}/bin/mpif77 -CC = cc - -CFLAGS = -c -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include -FFLAGSE = -c ${OPTE} -I$(INSTALL_DIR)/include - -BIN = ../bin/restbin2asc -LIBS = xdrf/libxdrf.a - -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI \ - -DPGI -DSPLITELE -DISNAN -DAMD64 \ - -DPROCOR -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC - -ARCH = LINUX -PP = /lib/cpp -P - - -all: restbin2asc - -obj: ${object} - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = restbin2asc.o - -restbin2asc: ${object} - ${FC} ${OPT} ${object} ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o diff --git a/source/unres/src_MD-M-newcorr/Makefile-tau-temp b/source/unres/src_MD-M-newcorr/Makefile-tau-temp deleted file mode 100644 index 6fd84a8..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile-tau-temp +++ /dev/null @@ -1,148 +0,0 @@ -# -#include TAU_MAKEFILE ${TAU_ROOT_DIR}/xt3/lib/Makefile.tau-mpi-pdt-pgi -TAU_MAKEFILE=/usr/local/packages/TAU-2.17/tau-2.17/xt3/lib/Makefile.tau-mpi-pdt-pgi -FC=tau_f90.sh -OPT = -fast -pc 64 -tp p6 -#-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ -#-Mprefetch=distance:8,nta - -OPT1 = -fast -pc 64 -tp p6 -OPT2 = -fast -pc 64 -tp p6 -OPTE = -fast -pc 64 -tp p6 - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include -FFLAGSE = -c ${OPTE} -I$(INSTALL_DIR)/include - -BIN = ../bin/unres_MD_Tc_procor-newparm-gnivpar-tau.exe -#LIBS = xdrf/libxdrf.a /home/liwo/UNRES/LIB/libmemmon.a -LIBS = xdrf/libxdrf.a - -CPPFLAGS = -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI \ - -DSPLITELE -DPROCOR -DAMD64 -DLANG0 - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new.o \ - energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - ${CC} -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o; /bin/rm *.pp.* - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS1} ${CPPFLAGS} rmdd.f - -eigen.o : eigen.f - ${FC} ${FFLAGS1} ${CPPFLAGS} eigen.f - -blas.o : blas.f - ${FC} ${FFLAGS1} ${CPPFLAGS} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} ${CPPFLAGS} add.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -energy_p_new-sep.o : energy_p_new-sep.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -compinfo: compinfo.o - ${CC} ${CFLAGS} compfinfo.c - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c - -prng_32.o: prng_32.F - ${FC} -qfixed -O0 prng_32.F - -prng.o: prng.f - ${FC} ${FFLAGS} prng.f - -readrtns_CSA.o: readrtns_CSA.F - ${FC} ${FFLAGS} ${CPPFLAGS} readrtns_CSA.F - -gen_rand_conf.o: gen_rand_conf.F - ${FC} ${FFLAGS} ${CPPFLAGS} gen_rand_conf.F diff --git a/source/unres/src_MD-M-newcorr/Makefile.tau-mpi-f77-pdt b/source/unres/src_MD-M-newcorr/Makefile.tau-mpi-f77-pdt deleted file mode 100644 index c8dc5fe..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile.tau-mpi-f77-pdt +++ /dev/null @@ -1,860 +0,0 @@ -#**************************************************************************** -#* TAU Portable Profiling Package ** -#* http://www.cs.uoregon.edu/research/tau ** -#**************************************************************************** -#* Copyright 1997-2002 ** -#* Department of Computer and Information Science, University of Oregon ** -#* Advanced Computing Laboratory, Los Alamos National Laboratory ** -#**************************************************************************** -####################################################################### -## pC++/Sage++ Copyright (C) 1993,1995 ## -## Indiana University University of Oregon University of Rennes ## -####################################################################### - -####################################################################### -# This is a sample Makefile that contains the Profiling and Tracing -# options. Makefiles of other applications and libraries (not included -# in this distribution) should include this Makefile. -# It defines the following variables that should be added to CFLAGS -# TAU_INCLUDE - Include path for tau headers -# TAU_DEFS - Defines that are needed for tracing and profiling only. -# And for linking add to LIBS -# TAU_LIBS - TAU Tracing and Profiling library libprof.a -# -# When the user needs to turn off tracing and profiling and run the -# application without any runtime overhead of instrumentation, simply -# remove TAUDEFS and TAULIBS from CFLAGS and LIBS respectively but keep -# TAUINC. -####################################################################### - -########### Automatically modified by the configure script ############ -CONFIG_ARCH=bgp -TAU_ARCH=bgp -CONFIG_CC=bgxlc_r -CONFIG_CXX=bgxlC_r -TAU_CC_FE=$(CONFIG_CC) -TAU_CXX_FE=$(CONFIG_CXX) - -# Front end C/C++ Compilers -#BGL#TAU_CC_FE=xlc #ENDIF# -#BGL#TAU_CXX_FE=xlC #ENDIF# -TAU_CC_FE=xlc #ENDIF##BGP# -TAU_CXX_FE=xlC #ENDIF##BGP# -#CATAMOUNT#TAU_CC_FE=gcc #ENDIF# -#CATAMOUNT#TAU_CXX_FE=g++ #ENDIF# -#SC_GFORTRAN#TAU_CC_FE=gcc #ENDIF# -#SC_GFORTRAN#TAU_CXX_FE=g++ #ENDIF# -#SC_PATHSCALE#TAU_CC_FE=gcc #ENDIF# -#SC_PATHSCALE#TAU_CXX_FE=g++ #ENDIF# - -PCXX_OPT=-g -USER_OPT= -EXTRADIR=/opt/ibmcmp/xlf/bg/11.1/bin/.. -EXTRADIRCXX=/opt/ibmcmp/vacpp/bg/9.0/bin/.. -TAUROOT=/soft/apps/tau/tau_latest -TULIPDIR= -TAUEXTRASHLIBOPTS= -TAUGCCLIBOPTS= -TAUGCCLIBDIR= -TAUGFORTRANLIBDIR= -PCLDIR= -PAPIDIR= -PAPISUBDIR= -CHARMDIR= -PDTDIR=/soft/apps/tau/pdtoolkit-3.12 -PDTCOMPDIR= -DYNINSTDIR= -JDKDIR= -SLOG2DIR= -OPARIDIR= -TAU_OPARI_TOOL= -EPILOGDIR= -EPILOGBINDIR= -EPILOGINCDIR= -EPILOGLIBDIR= -EPILOGEXTRALINKCMD= -VAMPIRTRACEDIR= -KTAU_INCDIR= -KTAU_INCUSERDIR= -KTAU_LIB= -KTAU_KALLSYMS_PATH= -PYTHON_INCDIR= -PYTHON_LIBDIR= -PERFINCDIR= -PERFLIBDIR= -PERFLIBRARY= -TAU_SHMEM_INC= -TAU_SHMEM_LIB= -TAU_CONFIG=-mpi-pdt -TAU_MPI_INC=-I/bgsys/drivers/ppcfloor/comm/include -TAU_MPI_LIB=-L/soft/apps/tau/tau_latest/bgp/lib -lTauMpi$(TAU_CONFIG) -L/bgsys/drivers/ppcfloor/comm/lib -TAU_MPI_FLIB=-lfmpich.cnk -L/soft/apps/tau/tau_latest/bgp/lib -lTauMpi$(TAU_CONFIG) -L/bgsys/drivers/ppcfloor/comm/lib -TAU_MPILIB_DIR=/bgsys/drivers/ppcfloor/comm/lib -TAU_MPI_NOWRAP_LIB= -L/bgsys/drivers/ppcfloor/comm/lib -TAU_MPI_NOWRAP_FLIB=-lfmpich.cnk -L/bgsys/drivers/ppcfloor/comm/lib -FULL_CXX=mpixlcxx_r -FULL_CC=mpixlc_r -TAU_PREFIX_INSTALL_DIR=/soft/apps/tau/tau_latest - -TAU_BIN_DIR=$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/bin -TAU_INC_DIR=$(TAU_PREFIX_INSTALL_DIR)/include -TAU_LIB_DIR=$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/lib - -####################################################################### - -#OPARI#TAU_OPARI_TOOL=$(TAU_BIN_DIR)/opari #ENDIF# -#ENABLE64BIT#ABI = -64 #ENDIF# -#ENABLEN32BIT#ABI = -n32 #ENDIF# -#ENABLE32BIT#ABI = -32 #ENDIF# - -####################################################################### -#SP1#IBM_XLC_ABI = -q32 #ENDIF# -#SP1#IBM_GNU_ABI = -maix32 #ENDIF# -#IBM64#IBM_XLC_ABI = -q64 #ENDIF# -#IBM64#IBM_GNU_ABI = -maix64 #ENDIF# -#IBM64LINUX#IBM_XLC_ABI = -q64 #ENDIF# -#IBM64LINUX#IBM_GNU_ABI = -m64 #ENDIF# -#SUNX86_64#SUN_GNU_ABI = -m64 #ENDIF# -#SUNX86_64#SUN_CC_ABI = -xarch=amd64 #ENDIF# -#MIPS32LINUX#SC_GNU_ABI = -mabi=n32 #ENDIF# -#MIPS32LINUX#SC_PATH_ABI = -n32 #ENDIF# -#MIPS64LINUX#SC_GNU_ABI = -mabi=64 #ENDIF# -#MIPS64LINUX#SC_PATH_ABI = -64 #ENDIF# -#GNU#SC_ABI = $(SC_GNU_ABI) #ENDIF# -#USE_PATHCC#SC_ABI = $(SC_PATH_ABI) #ENDIF# -#MIPS32#ABI = $(SC_ABI) #ENDIF# -#MIPS64#ABI = $(SC_ABI) #ENDIF# - -IBM_ABI = $(IBM_XLC_ABI) #ENDIF##USE_IBMXLC# -#GNU#IBM_ABI = $(IBM_GNU_ABI) #ENDIF# -#SP1# ABI = $(IBM_ABI) #ENDIF# -#PPC64# ABI = $(IBM_ABI) #ENDIF# -#SOLARIS64#SUN_GNU_ABI = -mcpu=v9 -m64 #ENDIF# -#SOLARIS64#SUN_CC_ABI = -xarch=v9 -xcode=pic32 #ENDIF# -#SOL2CC#SUN_ABI = $(SUN_CC_ABI) #ENDIF# -#GNU#SUN_ABI = $(SUN_GNU_ABI) #ENDIF# -#SOL2#ABI = $(SUN_ABI) #ENDIF# -#SUNX86_64#ABI = $(SUN_ABI) #ENDIF# -#FORCEIA32#ABI = -m32#ENDIF# -####################################################################### -F90_ABI = $(ABI) -#IBM64_FORTRAN#F90_ABI = -q64 #ENDIF# -####################################################################### - -############# Standard Defines ############## -TAU_CC = $(CONFIG_CC) $(ABI) $(ISA) -TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -TAU_RUN_CC = $(FULL_CC) $(ABI) $(ISA) -TAU_RUN_CXX = $(FULL_CXX) $(ABI) $(ISA) -TAU_INSTALL = /bin/cp -TAU_SHELL = /bin/sh -LSX = .a -############################################# -# JAVA DEFAULT ARCH -############################################# -JDKARCH = linux -#COMPAQ_ALPHA#JDKARCH = alpha #ENDIF# -#SOL2#JDKARCH = solaris #ENDIF# -#SGIMP#JDKARCH = irix #ENDIF# -#SP1#JDKARCH = aix #ENDIF# -#T3E#JDKARCH = cray #ENDIF# -############################################# -# JAVA OBJECTS -############################################# -#JAVA#TAU_JAVA_O = TauJava.o TauJAPI.o #ENDIF# -#JAVA#TAUJAPI = Profile.class #ENDIF# - - -############################################# -# OpenMP OBJECTS -############################################# -#OPENMP#OPENMP_O = OpenMPLayer.o #ENDIF# - -############################################# -# Opari OBJECTS -############################################# -#OPARI#OPARI_O = TauOpari.o #ENDIF# -#KOJAKOPARI#OPARI_O = TauKojakOpari.o #ENDIF# -#EPILOG#OPARI_O = #ENDIF# -#VAMPIRTRACE#OPARI_O = #ENDIF# -#GNU#OPARI_O = #ENDIF# - -############################################# -# CallPath OBJECTS -############################################# -#PROFILECALLPATH#CALLPATH_O = TauCallPath.o #ENDIF# -#PROFILEPARAM#PARAM_O = ProfileParam.o #ENDIF# - -############################################# -# Python Binding OBJECTS -############################################# -#PYTHON#PYTHON_O = PyGroups.o PyExceptions.o PyDatabase.o PyBindings.o PyTimer.o PyTau.o #ENDIF# - -############################################# -# DYNINST DEFAULT ARCH -############################################# -DYNINST_PLATFORM = $(PLATFORM) - - -#PCL##include $(TAU_INC_DIR)/makefiles/PCLMakefile.stub #ENDIF# - -############# OpenMP Fortran Option ######## -#OPENMP#TAU_F90_OPT = -mp #ENDIF# -#SOL2CC_OPENMP#TAU_F90_OPT = -xopenmp #ENDIF# -#SUNCC_OPENMP#TAU_F90_OPT = -xopenmp=parallel #ENDIF# -#COMPAQCXX_OPENMP#TAU_F90_OPT = -omp #ENDIF# -#IBMXLC_OPENMP#TAU_F90_OPT = -qsmp=omp #ENDIF# -#GUIDE#TAU_F90_OPT = #ENDIF# -#PGIOPENMP#TAU_F90_OPT = -mp #ENDIF# -#INTELOPENMP#TAU_F90_OPT = -openmp #ENDIF# -#HITACHI_OPENMP#TAU_F90_OPT = #ENDIF# - -TAU_R =_r #ENDIF##THREADSAFE_COMPILERS# - -############# Fortran Compiler ############# -#GNU_FORTRAN#TAU_F90 = g77 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#GNU_GFORTRAN#TAU_F90 = gfortran $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#G95_FORTRAN#TAU_F90 = g95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#SC_GFORTRAN#TAU_F90 = scgfortran $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#SGI_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -TAU_F90 = xlf77$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF##IBM_FORTRAN# -TAU_F90 = mpixlf77$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF##BGP# -#BGL#TAU_F90 = blrts_xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#IBM64_FORTRAN#TAU_F90 = xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#IBMXLFAPPLE#TAU_F90 = xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#CRAY_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#CRAY_X1_FORTRAN#TAU_F90 = ftn $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#PGI_FORTRAN#TAU_F90 = pgf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#CRAYCNL#TAU_F90 = ftn $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#PGI_CATAMOUNT#TAU_F90 = qk-pgf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#ABSOFT_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#LAHEY_FORTRAN#TAU_F90 = lf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#LAHEY64_FORTRAN#TAU_F90 = lf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#NAGWARE_FORTRAN#TAU_F90 = f95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#FUJITSU_FORTRAN#TAU_F90 = F90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#FUJITSU_SOLARIS#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#SUN_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#COMPAQ_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#KAI_FORTRAN#TAU_F90 = guidef90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#HP_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#HITACHI_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#INTEL_FORTRAN#TAU_F90 = efc $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#INTEL32_FORTRAN#TAU_F90 = ifc $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#INTELIFORT#TAU_F90 = ifort $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#PATHSCALE_FORTRAN#TAU_F90 = pathf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#SC_PATHSCALE#TAU_F90 = scpathf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#OPEN64ORC_FORTRAN#TAU_F90 = orf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#NEC_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# - - -############# Portable F90 Options ############# -#IBM64_FORTRAN#TAU_F90_FIXED = -qfixed #ENDIF# -TAU_F90_FIXED = -qfixed #ENDIF##IBM_FORTRAN# -TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF##IBM_FORTRAN# -#IBMXLFAPPLE#TAU_F90_FIXED = -qfixed #ENDIF# -#IBMXLFAPPLE#TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF# -#IBM64_FORTRAN#TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF# - -############# Profiling Options ############# -PROFILEOPT1 = -DPROFILING_ON #ENDIF##PROFILE# -#PCL#PROFILEOPT3 = -DTAU_PCL -I$(PCLDIR)/include #ENDIF# -#PAPI#PROFILEOPT3 = -DTAU_PAPI -I$(PAPIDIR)/src -I$(PAPIDIR)/include #ENDIF# -#PCL#PCL_O = PclLayer.o #ENDIF# -#PAPI#PAPI_O = PapiLayer.o #ENDIF# -#MULTIPLECOUNTERS#MULT_O = MultipleCounters.o #ENDIF# -#PROFILECALLS#PROFILEOPT4 = -DPROFILE_CALLS #ENDIF# -#PROFILESTATS#PROFILEOPT5 = -DPROFILE_STATS #ENDIF# -#DEBUGPROF#PROFILEOPT6 = -DDEBUG_PROF #ENDIF# -PROFILEOPT7 = -DTAU_STDCXXLIB #ENDIF##STDCXXLIB# -#CRAYX1CC#PROFILEOPT7 = #ENDIF# -#CRAYCC#PROFILEOPT7 = #ENDIF# -#INTELTFLOP#PROFILEOPT8 = -DPOOMA_TFLOP #ENDIF# -#NORTTI#PROFILEOPT9 = -DNO_RTTI #ENDIF# -#RTTI#PROFILEOPT9 = -DRTTI #ENDIF# -#GNU#PROFILEOPT10 = -DTAU_GNU -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# -#APPLECXX#PROFILEOPT10 = -DTAU_GNU -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# -#SOL2CC#PROFILEOPT10 = -DTAU_SOL2CC -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#SUNCC#PROFILEOPT10 = -DTAU_SOL2CC -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#USE_PATHCC#PROFILEOPT10 = -DTAU_DOT_H_LESS_HEADERS -fPIC -DTAU_PATHSCALE #ENDIF# -#OPEN64ORC#PROFILEOPT10 = -DTAU_DOT_H_LESS_HEADERS -DTAU_OPEN64ORC -fpic #ENDIF# -#CALLSTACK#PROFILEOPT11 = -DPROFILE_CALLSTACK #ENDIF# -#PGI1.7#PROFILEOPT12 = -DPGI #ENDIF# -#CRAYKAI#PROFILEOPT12 = -DCRAYKAI #ENDIF# -#HP_FORTRAN#PROFILEOPT12 = -DHP_FORTRAN #ENDIF# -#CRAYCC#PROFILEOPT13 = -h instantiate=used -DCRAYCC -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#CRAYX1CC#PROFILEOPT13 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#SGICC#TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -LANG:std #ENDIF# -#INTELCXXLIBICC#TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -cxxlib-icc #ENDIF# -#PTHREAD_AVAILABLE#PROFILEOPT15 = -DPTHREADS #ENDIF# -#COMPAQCXX_PTHREAD#PROFILEOPT15 = -DPTHREADS -pthread #ENDIF# -#TAU_SPROC#PROFILEOPT15 = -DTAU_SPROC #ENDIF# -#TAU_PAPI_THREADS#PROFILEOPT15 = -DTAU_PAPI_THREADS #ENDIF# -#TULIPTHREADS#PROFILEOPT16 = -DTULIPTHREADS #ENDIF# -#TRACE#TRACEOPT = -DTRACING_ON #ENDIF# -#TRACE#EVENTS_O = Tracer.o #ENDIF# -#KTAU#KTAU_O = TauKtau.o KtauProfiler.o KtauSymbols.o #ENDIF# -#KTAU_MERGE#KTAU_MERGE_O = KtauFuncInfo.o KtauMergeInfo.o ktau_syscall.o #ENDIF# -#KTAU_SHCTR#KTAU_SHCTR_O = KtauCounters.o #ENDIF# -#MPITRACE#TRACEOPT = -DTAU_MPITRACE -DTRACING_ON #ENDIF# -#MPITRACE#EVENTS_O = Tracer.o #ENDIF# -#MUSE#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF# -#MUSE_EVENT#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF# -#MUSE_MULTIPLE#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF# -#COMPENSATE#COMPENSATE_O = TauCompensate.o #ENDIF# -#PTHREAD_AVAILABLE#THR_O = PthreadLayer.o #ENDIF# -#TAU_PAPI_THREADS#THR_O = PapiThreadLayer.o #ENDIF# -#TAU_SPROC#THR_O = SprocLayer.o #ENDIF# -#JAVA#THR_O = JavaThreadLayer.o #ENDIF# -#TULIPTHREADS#THR_O = TulipThreadLayer.o #ENDIF# -#LINUXTIMERS#PLATFORM_O = TauLinuxTimers.o #ENDIF# -#TULIPTHREADS#PROFILEOPT17 = -I$(TULIPDIR)/include -I$(TULIPDIR)/Tuliplib #ENDIF# -#SMARTS#PROFILEOPT17 = -I$(TULIPDIR)/include -I$(TULIPDIR)/lib -I$(TULIPDIR)/machine-specific/$(HOSTTYPE) #ENDIF# -#SMARTS#PROFILEOPT18 = -DSMARTS #ENDIF# -#KAI#PROFILEOPT19 = -DKAI -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#USE_DECCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#SGICC#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#USE_INTELCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# -#USE_NECCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#PGI#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# -#ACC#PROFILEOPT19 = -AA +z -DTAU_DOT_H_LESS_HEADERS -DTAU_HPUX #ENDIF# -#FUJITSU#PROFILEOPT19 = -DFUJITSU -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#KAINOEX#PROFILEOPT20 = --no_exceptions #ENDIF# -#SGICCNOEX#PROFILEOPT20 = -LANG:exceptions=off #ENDIF# -#HPGNU#PROFILEOPT21 = -fPIC #ENDIF# -#HITACHI#PROFILEOPT21 = -DTAU_HITACHI #ENDIF# -#SP1#PROFILEOPT21 = -D_POSIX_SOURCE -DTAU_AIX #ENDIF# -#PPC64#TAU_PIC_PROFILEOPT21 = -qpic=large #ENDIF# -#BGL#TAU_PIC_PROFILEOPT21 = #ENDIF# -PROFILEOPT21 = -DTAU_DOT_H_LESS_HEADERS -DTAU_XLC $(TAU_PIC_PROFILEOPT21) #ENDIF##USE_IBMXLC# -#IBMXLCAPPLE#PROFILEOPT21 = -DTAU_DOT_H_LESS_HEADERS -DTAU_XLC -DTAU_APPLE_XLC #ENDIF# -#PCLPTHREAD#PROFILEOPT22 = -DPCL_MUTEX_LOCK #ENDIF# -#JAVA#PROFILEOPT23 = -DJAVA #ENDIF# -#MONITOR#PROFILEOPT24 = -DMONITORING_ON #ENDIF# -#JAVA#PROFILEOPT25 = -I$(JDKDIR)/include -I$(JDKDIR)/include/$(JDKARCH) #ENDIF# -PROFILEOPT26 = -DTAU_MPI #ENDIF##MPI# -PROFILEOPT26 = -DTAU_MPI -DTAU_MPI_THREADED #ENDIF##MPI_THREADED# -#OPENMP#PROFILEOPT27 = -mp -DTAU_OPENMP#ENDIF# -#GNU#PROFILEOPT27 = #ENDIF# -#SOL2CC_OPENMP#PROFILEOPT27 = -xopenmp -DTAU_OPENMP#ENDIF# -#SUNCC_OPENMP#PROFILEOPT27 = -xopenmp=parallel -DTAU_OPENMP#ENDIF# -#SUNCC_OPENMP#PROFILEOPT27 = -xopenmp=parallel -DTAU_OPENMP#ENDIF# -#HITACHI_OPENMP#PROFILEOPT27 = -DTAU_OPENMP#ENDIF# -#COMPAQCXX_OPENMP#PROFILEOPT27 = -omp -DTAU_OPENMP#ENDIF# -#IBMXLC_OPENMP#PROFILEOPT27 = -qsmp=omp -DTAU_OPENMP #ENDIF# -#OPEN64_OPENMP#PROFILEOPT27 = -mp -DTAU_OPENMP #ENDIF# -#GUIDE#PROFILEOPT27 = -DTAU_OPENMP #ENDIF# -#PGIOPENMP#PROFILEOPT27 = -mp -D_OPENMP -DTAU_OPENMP -U_RWSTD_MULTI_THREAD -U_REENTRANT #ENDIF# -#INTELOPENMP#PROFILEOPT27 = -openmp -DTAU_OPENMP #ENDIF# -#GNUOPENMP#PROFILEOPT27 = -fopenmp -DTAU_OPENMP #ENDIF# -#OPARI#PROFILEOPT28 = -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF# -#OPARI_REGION#PROFILEOPT28 = -DTAU_OPARI_REGION -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF# -#OPARI_CONSTRUCT#PROFILEOPT28 = -DTAU_OPARI_CONSTRUCT -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF# -#MULTIPLECOUNTERS#PROFILEOPT29 = -DTAU_MULTIPLE_COUNTERS #ENDIF# -#SGITIMERS#PROFILEOPT30 = -DSGI_TIMERS #ENDIF# -#BGLTIMERS#PROFILEOPT30 = -DBGL_TIMERS -I/bgl/BlueLight/ppcfloor/bglsys/include #ENDIF# -#BGPTIMERS#PROFILEOPT30 = -DBGP_TIMERS -I/bgsys/drivers/ppcfloor/arch/include/common -I/bgsys/drivers/ppcfloor/arch/include -I/bgsys/drivers/ppcfloor/arch/include/spi #ENDIF# -#CRAYTIMERS#PROFILEOPT30 = -DCRAY_TIMERS #ENDIF# -#LINUXTIMERS#PROFILEOPT31 = -DTAU_LINUX_TIMERS #ENDIF# -#ALPHATIMERS#PROFILEOPT31 = -DTAU_ALPHA_TIMERS #ENDIF# -#CPUTIME#PROFILEOPT32 = -DCPU_TIME #ENDIF# -#PAPIWALLCLOCK#PROFILEOPT33 = -DTAU_PAPI_WALLCLOCKTIME #ENDIF# -#PAPIVIRTUAL#PROFILEOPT34 = -DTAU_PAPI_VIRTUAL #ENDIF# -#SGICOUNTERS#PROFILEOPT35 = -DSGI_HW_COUNTERS #ENDIF# -#EPILOG#PROFILEOPT36 = -DTAU_EPILOG -I$(EPILOGINCDIR) #ENDIF# -#SCALASCA#PROFILEOPT36 = -DTAU_SCALASCA -DTAU_EPILOG -I$(EPILOGINCDIR) #ENDIF# -#VAMPIRTRACEINTS#TAU_VAMPIRTRACEOPTS = -DTAU_64BITTYPES_NEEDED -DHAVE_INTTYPES_H #ENDIF# -#VAMPIRTRACE#PROFILEOPT36 = -DTAU_VAMPIRTRACE -I$(VAMPIRTRACEDIR)/vtlib -I$(VAMPIRTRACEDIR)/include $(TAU_VAMPIRTRACEOPTS)#ENDIF# -#PROFILECALLPATH#PROFILEOPT36 = -DTAU_CALLPATH #ENDIF# -#PROFILEPHASE#PROFILEOPT36 = -DTAU_CALLPATH -DTAU_PROFILEPHASE#ENDIF# -#PYTHON#PROFILEOPT37 = -I$(PYTHON_INCDIR) #ENDIF# -#NOCOMM#PROFILEOPT38 = -DTAU_NOCOMM #ENDIF# -#MUSE#PROFILEOPT39 = -DTAU_MUSE #ENDIF# -#SETNODE0#PROFILEOPT40 = -DTAU_SETNODE0 #ENDIF# -#COMPENSATE#PROFILEOPT41 = -DTAU_COMPENSATE #ENDIF# -#MUSE_EVENT#PROFILEOPT42 = -DTAU_MUSE_EVENT #ENDIF# -#MUSE_MULTIPLE#PROFILEOPT43 = -DTAU_MUSE_MULTIPLE #ENDIF# -#DYNINST41##PROFILEOPT44 = -DTAU_DYNINST41BUGFIX #ENDIF# -# DyninstAPI v4.2.1 fixes the bug, so we don't need OPT44 anymore -#PROFILEMEMORY#PROFILEOPT45 = -DTAU_PROFILEMEMORY #ENDIF# -PROFILEOPT46 = -DTAU_MPIGREQUEST #ENDIF##MPIGREQUEST# -#MPIOREQUEST#PROFILEOPT47 = -DTAU_MPIOREQUEST #ENDIF# -PROFILEOPT48 = -DTAU_MPIDATAREP #ENDIF##MPIDATAREP# -PROFILEOPT49 = -DTAU_MPIERRHANDLER #ENDIF##MPIERRHANDLER# -#CATAMOUNT#PROFILEOPT50 = -DTAU_CATAMOUNT #ENDIF# -#MPICONSTCHAR#PROFILEOPT51 = -DTAU_MPICONSTCHAR #ENDIF# -PROFILEOPT52 = -DTAU_MPIATTRFUNCTION #ENDIF##MPIATTR# -PROFILEOPT53 = -DTAU_MPITYPEEX #ENDIF##MPITYPEEX# -PROFILEOPT54 = -DTAU_MPIADDERROR #ENDIF##MPIADDERROR# -#MPINEEDSTATUSCONV#PROFILEOPT55 = -DTAU_MPI_NEEDS_STATUS #ENDIF# - -#DEPTHLIMIT#PROFILEOPT56 = -DTAU_DEPTH_LIMIT #ENDIF# -#TAU_CHARM#PROFILEOPT57 = -DTAU_CHARM -I$(CHARMDIR)/include #ENDIF# -#PROFILEHEADROOM#PROFILEOPT58 = -DTAU_PROFILEHEADROOM #ENDIF# -#JAVACPUTIME#PROFILEOPT59 = -DJAVA_CPU_TIME #ENDIF# -PROFILEOPT60 = -DTAU_LARGEFILE -D_LARGEFILE64_SOURCE #ENDIF##TAU_LARGEFILE# -PROFILEOPT60 = -DTAU_LARGEFILE -D_LARGEFILE64_SOURCE -D__xlc__ #ENDIF##BGP# -# Omit the -D_LARGETFILE64_SOURCE till we can check the IBM crash -#SHMEM#PROFILEOPT61 = -DTAU_SHMEM #ENDIF# -#KTAU#PROFILEOPT62 = -DTAUKTAU -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -I$(KTAU_INCUSERDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF# -#KTAU_MERGE#PROFILEOPT63 = -DTAUKTAU_MERGE -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF# -#FREEBSD#PROFILEOPT64 = -DTAU_FREEBSD #ENDIF# -#PROFILEPARAM#PROFILEOPT65 = -DTAU_PROFILEPARAM #ENDIF# -#IBMMPI#PROFILEOPT66 = -DTAU_IBM_MPI #ENDIF# -#WEAKMPIINIT#PROFILEOPT67 = -DTAU_WEAK_MPI_INIT #ENDIF# -#LAMPI#PROFILEOPT68 = -DTAU_LAMPI #ENDIF# -#MPICH_IGNORE_CXX_SEEK#PROFILEOPT68 = -DMPICH_IGNORE_CXX_SEEK #ENDIF# -PROFILEOPT68 = -DMPICH_IGNORE_CXX_SEEK #ENDIF##BGP# -#MPICH2_MPI_INPLACE#PROFILEOPT73 = -DTAU_MPICH2_MPI_IN_PLACE #ENDIF# - - -############# RENCI Scalable Trace Lib Options ############# -STFF_DIR= -SDDF_DIR= -#RENCI_STFF#PROFILEOPT69 = -DRENCI_STFF -I$(STFF_DIR)/include #ENDIF# -#RENCI_STFF#TAU_LINKER_OPT11 = -L$(STFF_DIR)/lib -lstff -L$(SDDF_DIR)/lib -lPablo $(TAU_MPI_LIB) #ENDIF# -#RENCI_STFF#RENCI_STFF_O = RenciSTFF.o #ENDIF# - -############# KTAU (again) ############# -#KTAU_SHCTR#PROFILEOPT70 = -DTAUKTAU_SHCTR -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF# -#KTAU#TAU_LINKER_OPT12 = -L$(KTAU_LIB) -lktau #ENDIF# - -#MIPS32LINUX#PROFILEOPT71 = -D_ABIN32=2 -D_MIPS_SIM=_ABIN32 #ENDIF# - -#BGL#PROFILEOPT72 = -DTAU_BGL -I/bgl/BlueLight/ppcfloor/bglsys/include #ENDIF# -PROFILEOPT72 = -DTAU_BGP -I/bgsys/drivers/ppcfloor/arch/include/common -I/bgsys/drivers/ppcfloor/arch/include -I/bgsys/drivers/ppcfloor/arch/include/spi #ENDIF##BGP# - -#For F90 support for all platforms -FWRAPPER = TauFMpi.o -MPI2EXTENSIONS = TauMpiExtensions.o #ENDIF##MPI2# -MPI2EXTENSIONS = #ENDIF##BGP# -#CRAYX1CC#MPI2EXTENSIONS = #ENDIF# - -#SGICOUNTERS#LEXTRA = -lperfex #ENDIF# -#ALPHATIMERS#LEXTRA = -lrt #ENDIF# -#SOL2#PCL_EXTRA_LIBS = -lcpc #ENDIF# -#PCL#LEXTRA = -L$(PCLDIR)/lib -lpcl $(PCL_EXTRA_LIBS) #ENDIF# -#PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# -#IA64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi #ENDIF# -#Due to some problems with older versions of libpfm, we are using the static lib -#IA64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# -#PAPIPFM##LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpfm -lpapi -lpfm #ENDIF# -#X86_64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR)/ -L$(PAPIDIR)/lib64/ -lpapi -lperfctr #ENDIF# -#SOL2PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -lcpc #ENDIF# -#IBMPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/usr/lpp/pmtoolkit/lib -L/usr/pmapi/lib -lpmapi#ENDIF# -#PPC64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# -#BGLPAPI_RTS#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.rts.a -L/bgl/BlueLight/ppcfloor/bglsys/lib -lbgl_perfctr.rts -lrts.rts -ldevices.rts #ENDIF# -#BGLPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/bgl/BlueLight/ppcfloor/bglsys/lib -lbgl_perfctr.rts -lrts.rts -ldevices.rts #ENDIF# -#BGPPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/bgsys/drivers/ppcfloor/runtime/SPI -lSPI.cna #ENDIF# -#IBM64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi64.a -L/usr/lpp/pmtoolkit/lib -L/usr/pmapi/lib -lpmapi #ENDIF# -#IBM64PAPILINUX#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# -#SGI64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi64 #ENDIF# -#ALPHAPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a /usr/lib/dcpi/dadd.a -lclu -lrt #ENDIF# - -TAU_PAPI_EXTRA_FLAGS = $(LEXTRA) -#IA64PAPI#TAU_PAPI_EXTRA_FLAGS = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi #ENDIF# - - -# By default make TAU_PAPI_RPATH null. Support it on a compiler by compiler basis. -#PAPI###TAU_PAPI_RPATH = -rpath $(PAPIDIR)/$(PAPISUBDIR) #ENDIF# -#PAPI##TAU_PAPI_RPATH = #ENDIF# -#PPC64PAPI#TAU_PAPI_RPATH = #ENDIF# -#BGLPAPI#TAU_PAPI_RPATH = #ENDIF# -#BGPPAPI#TAU_PAPI_RPATH = #ENDIF# -#USE_INTELCXX#TAU_PAPI_RPATH = #ENDIF# -#CRAYX1CC#TAU_PAPI_RPATH = #ENDIF# -#PGI#TAU_PAPI_RPATH = -R$(PAPIDIR)/$(PAPISUBDIR) #ENDIF# -#GNU#TAU_PAPI_RPATH = -Wl,-rpath $(PAPIDIR)/$(PAPISUBDIR) #ENDIF# -#USE_PATHCC#TAU_PAPI_RPATH = #ENDIF# - -# if the user has specified -cc=gcc -c++=g++ -fortran=intel, we shouldn't use -rpath -# because they are likely going to link with ifort -#INTEL32_FORTRAN#TAU_PAPI_RPATH = #ENDIF# -#SOL2PAPI#TAU_PAPI_RPATH = #ENDIF# -#IBMPAPI#TAU_PAPI_RPATH = #ENDIF# -#IBM64PAPI#TAU_PAPI_RPATH = #ENDIF# -#PAPI#TAU_LINKER_OPT1 = $(TAU_PAPI_RPATH) #ENDIF# - -#PTHREAD_AVAILABLE#LEXTRA1 = -lpthread #ENDIF# -#TULIPTHREADS#LEXTRA1 = -L$(TULIPDIR)/Tuliplib -ltulip #ENDIF# -#SMARTS##include $(TAU_INC_DIR)/makefiles/GNUmakefile-$(HOSTTYPE) #ENDIF# -#SMARTS#LEXTRA1 = $(LSMARTS) #ENDIF# - -TAU_GCCLIB = -lgcc_s -TAU_GCCLIB = #ENDIF##BGP# -#INTEL32_ON_64#TAU_GCCLIB = -lgcc #ENDIF# -#FREEBSD#TAU_GCCLIB = -lgcc #ENDIF# -#BGL#TAU_GCCLIB = -lgcc #ENDIF# -#GNU#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF# -#OPEN64ORC_FORTRAN#TAU_FORTRANLIBS = -lfortran -lffio #ENDIF# -#PATHSCALE_FORTRAN#TAU_FORTRANLIBS = -lpathfstart -lpathfortran #ENDIF# -#SC_PATHSCALE#TAU_FORTRANLIBS = -lpathfstart -lpathfortran #ENDIF# -#NAGWARE_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/quickfit.o -L$(EXTRADIR)/lib -lf96 #ENDIF# -#G95_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR) -lf95 #ENDIF# -#GNU_FORTRAN#TAU_FORTRANLIBS = -lg2c #ENDIF# -#GNU_GFORTRAN#TAU_FORTRANLIBS = -L$(TAUGFORTRANLIBDIR) -lgfortran -lgfortranbegin #ENDIF# -#SC_GFORTRAN#TAU_FORTRANLIBS = -lgfortran -lgfortranbegin #ENDIF# -#SGI_FORTRAN#TAU_FORTRANLIBS = -lfortran -lftn #ENDIF# -TAU_IBM_FORTRANLIBS = -bh:4 -bpT:0x10000000 -bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF##USE_IBMXLC# -#GNU#TAU_IBM_FORTRANLIBS = -Wl,-bh:4 -Wl,-bpT:0x10000000 -Wl,-bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF# -#KAI#TAU_IBM_FORTRANLIBS = --backend -bh:4 --backend -bpT:0x10000000 --backend -bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF# -TAU_FORTRANLIBS = $(TAU_IBM_FORTRANLIBS) #ENDIF##IBM_FORTRAN# - -TAU_IBM64_FORTRANLIBS = -bh:4 -bpT:0x10000000 -bpD:0x20000000 -b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF##USE_IBMXLC# -#GNU#TAU_IBM64_FORTRANLIBS = -Wl,-bh:4 -Wl,-bpT:0x10000000 -Wl,-bpD:0x20000000 -Wl,-b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF# -#KAI#TAU_IBM64_FORTRANLIBS = --backend -bh:4 --backend -bpT:0x10000000 --backend -bpD:0x20000000 --backend -b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF# -#IBM64_FORTRAN#TAU_FORTRANLIBS = $(TAU_IBM64_FORTRANLIBS) #ENDIF# -#IBM64_FORTRAN#TAU_FORLIBDIR=lib64 #ENDIF# -TAU_FORLIBDIR=lib #ENDIF##IBM_FORTRAN# -#BGL#TAU_FORLIBDIR=blrts_dev_lib #ENDIF# -TAU_FORLIBDIR=bglib #ENDIF##BGP# -#PPC64#TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -lxlf90 -lxlfmath -lxl #ENDIF# -#BGL#TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -L$(EXTRADIR)/blrts_lib -lxlf90 -lxlfmath -lxl #ENDIF# - -TAU_BGL_OMP_SERIAL= -lxlomp_ser #ENDIF##BGP# -#OPENMP#TAU_BGL_OMP_SERIAL= #ENDIF# -TAU_OMP_SERIAL=$(TAU_BGL_OMP_SERIAL) #ENDIF##BGP# -TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -lxlf90 -lxlfmath $(TAU_OMP_SERIAL) #ENDIF##BGP# - -#IBMXLFAPPLE#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib -lxlf90 -lxlfmath -lxl #ENDIF# - -#CRAY_FORTRAN#TAU_FORTRANLIBS = #ENDIF# -#CRAY_X1_FORTRAN#TAU_FORTRANLIBS = #ENDIF# -#PGI_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/f90main.o -lpgf90 -lpgf90rtl -lpgf90_rpm1 -lpgf902 -lpgftnrtl -lrt #ENDIF# -#HP_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib/pa2.0 -lF90 -lcl #ENDIF# -#INTEL_FORTRAN#TAU_FORTRANLIBS = -lcprts -lPEPCF90 #ENDIF# -#INTEL32_FORTRAN#TAU_FORTRANLIBS = -lcprts -lCEPCF90 -lF90 #ENDIF# -#INTELIFORT#TAU_FORTRANLIBS = -lcprts #ENDIF# -#INTEL81FIX#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -lcxa -lunwind -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF# -#INTEL10FIX#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF# -#INTELCXXLIBICC#TAU_FORTRANLIBS = -lcprts -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF# -#PGI1.7#LEXTRA = -lstd -lstrm#ENDIF# -#PGI1.7#TAUHELPER = $(TAUROOT)/src/Profile/TauPGIHelper.cpp #ENDIF# -# LINKER OPTIONS -TAU_LINKER_OPT2 = $(LEXTRA) - - -#ACC#TAUHELPER = -AA #ENDIF# -#FUJITSU_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj9i6 -lfj9f6 -lfj9e6 #ENDIF# -#FUJITSU_SOLARIS#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj90l -lfj90f #ENDIF# -#SUN_FORTRAN#TAU_FORTRANLIBS = -lfui -lfsumai -lfprodai -lfminlai -lfmaxlai -lfminvai -lfmaxvai -lfsu -lsunmath #ENDIF# -#SUN_FORTRAN#TAU_FORTRANLIBS_SUN_OPTERON = -lfsu -lsunmath #ENDIF# -#SUN_FORTRAN#TAU_FORTRANLIBS_SUNCC = -lfsu #ENDIF# -#SUN386I#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUN_OPTERON) #ENDIF# -#SUNX86_64#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUN_OPTERON) #ENDIF# -#SUNCC#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUNCC) #ENDIF# -#SOL2#EXTRALIBS = -lsocket -lnsl #ENDIF# -#SUN386I#EXTRALIBS = -lsocket -lnsl -lrt #ENDIF# -#SUNX86_64#EXTRALIBS = -lsocket -lnsl -lrt #ENDIF# -#COMPAQ_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/cmplrs/fort90/for_main.o -L$(EXTRADIR)/lib -L$(EXTRADIR)/lib/cmplrs/fort90 -L$(EXTRADIR)/lib/cmplrs/fort90 -lUfor -lfor -lFutil -lm -lmld -lexc -lc #ENDIF# -#ABSOFT_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib -lfio -lf90math -lU77 -lf77math -lfio #ENDIF# -#LAHEY_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj9i6 -lfj9f6 -lfj9e6 -lfccx86_6a #ENDIF# -#LAHEY64_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib64/fj90rt0.o -L$(EXTRADIR)/lib64 -lfj90f -lfj90i -lelf #ENDIF# -#HITACHI_FORTRAN#TAU_FORTRANLIBS = -lf90 -lhf90math #ENDIF# -#NEC_FORTRAN#TAU_FORTRANLIBS = -f90lib #ENDIF# -#COMPAQ_GUIDEF90#TAU_FORTRANLIBS = $(EXTRADIR)/lib/cmplrs/fort90/for_main.o -lfor #ENDIF# - - -#HITACHI#TAU_HITACHI_EXTRA = -L/usr/local/lib -llrz32 #ENDIF# - -## To use the standard F90 linker instead of TAU_LINKER + TAU_FORTRANLIBS, add -#GNU#TAU_CXXLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF# -#GNU#TAU_GNUCXXLIBS = -L$(TAUGCCLIBDIR) -lstdc++ $(TAU_GCCLIB) #ENDIF# -#OPEN64ORC#TAU_CXXLIBS = -lstdc++ #ENDIF# -#PATHSCALE_FORTRAN#TAU_CXXLIBS = -lstdc++ #ENDIF# -#LAHEY_FORTRAN#TAU_CXXLIBS = $(TAU_GNUCXXLIBS) /usr/lib/libc.a #ENDIF# -#NAGWARE_FORTRAN#TAU_CXXLIBS = $(TAU_GNUCXXLIBS) /usr/lib/libc.a #ENDIF# -#PGI#TAU_CXXLIBS = -lstd -lC #ENDIF# -#CRAYCNL#TAU_CXXLIBS = -L$(EXTRADIR)/lib -lstd -lC -lpgc #ENDIF# -#CRAYX1CC#TAU_CXXLIBS = -L/opt/ctl/CC/CC/lib -lC #ENDIF# - -TAU_SGI_INIT = /usr/lib32/c++init.o -#ENABLE64BIT#TAU_SGI_INIT = /usr/lib64/c++init.o #ENDIF# -#ENABLEN32BIT#TAU_SGI_INIT = /usr/lib32/c++init.o #ENDIF# -#ENABLE32BIT#TAU_SGI_INIT = /usr/lib/c++init.o #ENDIF# - -#SGICC#TAU_CXXLIBS = $(TAU_SGI_INIT) -lC #ENDIF# -#APPLECXX#TAU_CXXLIBS = -lstd -lC #ENDIF# -#SOL2#TAU_CXXLIBS = -lCstd -lCrun #ENDIF# -#SOL2CC#TAU_CXXLIBS_SUN_OPTERON = -lCstd -lCrun -lm #ENDIF# -#SUNCC#TAU_CXXLIBS_SUNCC = -lCstd -lCrun #ENDIF# -#SUN386I#TAU_CXXLIBS = $(TAU_CXXLIBS_SUN_OPTERON) #ENDIF# -#SUNCC#TAU_CXXLIBS = $(TAU_CXXLIBS_SUNCC) #ENDIF# -#SUNX86_64#TAU_CXXLIBS = $(TAU_CXXLIBS_SUN_OPTERON) #ENDIF# -#FUJITSU_SOLARIS#TAU_CXXLIBS = -lstd -lstdm #ENDIF# -#PPC64#TAU_XLCLIBS = -L$(EXTRADIRCXX)/$(TAU_FORLIBDIR) -libmc++ -lstdc++ #ENDIF# -#IBMXLCAPPLE#TAU_FORLIBDIR =lib #ENDIF# -#IBMXLCAPPLE#TAU_XLCLIBS = -L$(EXTRADIRCXX)/$(TAU_FORLIBDIR) -libmc++ -lstdc++ #ENDIF# -#BGL#TAU_XLCLIBS = -L$(EXTRADIRCXX)/blrts_dev_lib -L$(EXTRADIRCXX)/blrts_lib -libmc++ -L/bgl/BlueLight/ppcfloor/blrts-gnu/powerpc-bgl-blrts-gnu/lib -lstdc++ #ENDIF# -TAU_XLCLIBS = -L$(EXTRADIRCXX)/bglib -libmc++ -lstdc++ #ENDIF##BGP# -#SP1#TAU_XLCLIBS = -lC #ENDIF# -TAU_CXXLIBS = $(TAU_XLCLIBS) #ENDIF##USE_IBMXLC# -#USE_DECCXX#TAU_CXXLIBS = -lcxxstd -lcxx #ENDIF# -#USE_INTELCXX#TAU_CXXLIBS_INTEL = -lcprts -lPEPCF90 #ENDIF# -#USE_INTELCXX#TAU_CXXLIBS_INTEL = -lcprts #ENDIF# -#INTELIFORT#TAU_CXXLIBS_INTEL = -lcprts #ENDIF# -#INTEL81FIX#TAU_CXXLIBS_INTEL = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -lcxa -lunwind#ENDIF# -#INTEL10FIX#TAU_CXXLIBS_INTEL = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF# -#INTELCXXLIBICC#TAU_CXXLIBS_INTEL = -lcprts #ENDIF# -#USE_INTELCXX#TAU_CXXLIBS = $(TAU_CXXLIBS_INTEL) #ENDIF# -#APPLECXX#TAU_CXXLIBS = -lstdc++ -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lgcc_s.1 -lSystemStubs #ENDIF# - -# EXTERNAL PACKAGES: VAMPIRTRACE -#VAMPIRTRACE#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# -#VAMPIRTRACEMPI#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.mpi -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# -#VAMPIRTRACEOMPI#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.ompi -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# -#VAMPIRTRACEOMP#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.omp -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# - -# EXTERNAL PACKAGES: EPILOG -#SCALASCA#TAU_ELG_SERIAL_SUFFIX =.ser #ENDIF# -#EPILOG#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg$(TAU_ELG_SERIAL_SUFFIX) $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# -#EPILOGMPI#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.mpi $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# -#EPILOGOMPI#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.ompi $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# -#EPILOGOMP#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.omp $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# - -# When using shared, we don't want -lelg.mpi or -lvt.mpi showing up -#FORCESHARED#TAU_LINKER_OPT3=#ENDIF# - -TAU_LINKER_OPT4 = $(LEXTRA1) -#HITACHI_OPENMP#TAU_LINKER_OPT4 = -lcompas -lpthreads -lc_r #ENDIF# -#OPENMP#TAU_LINKER_OPT5 = -mp #ENDIF# -#SOL2CC_OPENMP#TAU_LINKER_OPT5 = -xopenmp #ENDIF# -#SUNCC_OPENMP#TAU_LINKER_OPT5 = -xopenmp=parallel #ENDIF# -#GNU#TAU_LINKER_OPT5 = #ENDIF# -#COMPAQCXX_OPENMP#TAU_LINKER_OPT5 = -omp #ENDIF# -#IBMXLC_OPENMP#TAU_LINKER_OPT5 = -qsmp=omp #ENDIF# -#OPEN64_OPENMP#TAU_LINKER_OPT5 = -mp #ENDIF# -#GUIDE#TAU_LINKER_OPT5 = #ENDIF# -#PGIOPENMP#TAU_LINKER_OPT5 = -mp #ENDIF# -#INTELOPENMP#TAU_LINKER_OPT5 = -openmp #ENDIF# - -# MALLINFO needs -lmalloc on sgi, sun -#SGIMP#TAU_LINKER_OPT6 = -lmalloc #ENDIF# -#SOL2#TAU_LINKER_OPT6 = #ENDIF# -#SUN386I#TAU_LINKER_OPT6 = -lmalloc #ENDIF# -#SUNX86_64#TAU_LINKER_OPT6 = -lmalloc #ENDIF# - -# We need -lCio with SGI CC 7.4+ -#SGICC#TAU_LINKER_OPT7 = -lCio #ENDIF# - -# charm -#TAU_CHARM#TAU_LINKER_OPT8 = -lconv-core #ENDIF# - -# extra libs -#SUN386I#TAU_LINKER_OPT9 = $(EXTRALIBS) #ENDIF# -#SUNX86_64#TAU_LINKER_OPT9 = $(EXTRALIBS) #ENDIF# -#SOL2#TAU_LINKER_OPT9 = $(ExTRALIBS) #ENDIF# - -#BGL#TAU_LINKER_OPT10 = -L/bgl/BlueLight/ppcfloor/bglsys/lib -lrts.rts #ENDIF# - -TAU_IBM_PYTHON_SHFLAG = -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp -Wl,-einitpytau#ENDIF##USE_IBMXLC# -#GNU#TAU_IBM_PYTHON_SHFLAG = -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp -Wl,-einitpytau#ENDIF# -#KAI#TAU_IBM_PYTHON_SHFLAG = --backend -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp --backend -Wl,-einitpytau#ENDIF# -#ACC#TAU_HPUX_PYTHON_SHFLAG = -lstd_v2 -lCsup_v2 -lm -lcl -lc #ENDIF# - -TAU_IBM_LD_FLAGS = -binitfini:poe_remote_main #ENDIF##USE_IBMXLC# -#GNU#TAU_IBM_LD_FLAGS = -Wl,-binitfini:poe_remote_main #ENDIF# -#KAI#TAU_IBM_LD_FLAGS = --backend -binitfini:poe_remote_main #ENDIF# - - -#PYTHON#TAU_IBM_SHFLAGS = $(TAU_IBM_PYTHON_SHFLAG) #ENDIF# -#PYTHON#TAU_HPUX_SHFLAGS = $(TAU_HPUX_PYTHON_SHFLAG) #ENDIF# -#SP1#TAU_EXTRA_LIBRARY_FLAGS = $(TAU_IBM_SHFLAGS) #ENDIF# -#SOL2#TAU_EXTRA_LIBRARY_FLAGS = #ENDIF# -#SGIMP#TAU_EXTRA_LIBRARY_FLAGS = -lmalloc #ENDIF# -#HP#TAU_EXTRA_LIBRARY_FLAGS = $(TAU_HPUX_SHFLAGS) #ENDIF# - -TAU_MPI_WRAPPER_LIB= -L$(TAU_LIB_DIR) -lTauMpi$(TAU_CONFIG) #ENDIF##MPI# -#EPILOGMPI#TAU_MPI_WRAPPER_LIB= #ENDIF# -#EPILOGOMPI#TAU_MPI_WRAPPER_LIB= #ENDIF# - -############################################## -# Build TAU_LINKER_SHOPTS -#GNU#TAU_IBM_LINKER_SHOPTS=-Wl,-brtl -Wl,-bexpall #ENDIF# -TAU_IBM_LINKER_SHOPTS= -brtl -bexpall #ENDIF##USE_IBMXLC# -#KAI#TAU_IBM_LINKER_SHOPTS= --backend -brtl #ENDIF# -#SP1#TAU_LINKER_SHOPTS= $(TAU_IBM_LINKER_SHOPTS) #ENDIF# - -############################################## -# MPI _r suffix check (as in libmpi_r) -#MPI_R_SUFFIX#TAU_MPI_R_SUFFIX=_r #ENDIF# - -############################################## -# Flags to build a shared object: TAU_SHFLAGS -#GNU#AR_SHFLAGS = -shared #ENDIF# -#PGI#AR_SHFLAGS = -shared #ENDIF# -#SGICC#AR_SHFLAGS = -shared #ENDIF# -#APPLECXX#AR_SHFLAGS = -dynamiclib -flat_namespace -undefined suppress #ENDIF# -#SOL2#AR_SHFLAGS = -G #ENDIF# -#SUN386I#AR_SHFLAGS = -G #ENDIF# -#SUNX86_64#AR_SHFLAGS = -G #ENDIF# -AR_SHFLAGS = -G #ENDIF##USE_IBMXLC# -#USE_DECCXX#AR_SHFLAGS = -shared #ENDIF# -#USE_INTELCXX#AR_SHFLAGS = -shared #ENDIF# -#ACC#AR_SHFLAGS = -b #ENDIF# -TAU_SHFLAGS = $(AR_SHFLAGS) -o - -############# RANLIB Options ############# -TAU_RANLIB = echo "Built" -#APPLECXX#TAU_RANLIB = ranlib #ENDIF# -#IBMXLCAPPLE#TAU_RANLIB = ranlib #ENDIF# - -############################################## -TAU_AR = ar #ENDIF# -#SP1#TAU_AR = ar -X32 #ENDIF# -#IBM64#TAU_AR = ar -X64 #ENDIF# -#PPC64#TAU_AR = ar #ENDIF# -#IBM64LINUX#TAU_AR = ar #ENDIF# - - -############################################## -# PDT OPTIONS -# You can specify -pdtcompdir=intel -pdtarchdir=x86_64 -# If nothing is specified, PDTARCHDIR uses TAU_ARCH -PDTARCHDIRORIG=$(TAU_ARCH) -PDTARCHITECTURE=x86_64 -PDTARCHDIRFINAL=$(PDTARCHDIRORIG) -#PDTARCHITECTURE#PDTARCHDIRFINAL=$(PDTARCHITECTURE)#ENDIF# -PDTARCHDIR=$(PDTARCHDIRFINAL) -#PDTARCH#PDTARCHDIR=$(PDTARCHDIRFINAL)/$(PDTCOMPDIR)#ENDIF# - - -############################################## - -PROFILEOPTS = $(PROFILEOPT1) $(PROFILEOPT2) $(PROFILEOPT3) $(PROFILEOPT4) \ - $(PROFILEOPT5) $(PROFILEOPT6) $(PROFILEOPT7) $(PROFILEOPT8) \ - $(PROFILEOPT9) $(PROFILEOPT10) $(PROFILEOPT11) $(PROFILEOPT12) \ - $(PROFILEOPT13) $(PROFILEOPT14) $(PROFILEOPT15) $(PROFILEOPT16) \ - $(PROFILEOPT17) $(PROFILEOPT18) $(PROFILEOPT19) $(PROFILEOPT20) \ - $(PROFILEOPT21) $(PROFILEOPT22) $(PROFILEOPT23) $(PROFILEOPT24) \ - $(PROFILEOPT25) $(PROFILEOPT26) $(PROFILEOPT27) $(PROFILEOPT28) \ - $(PROFILEOPT29) $(PROFILEOPT30) $(PROFILEOPT31) $(PROFILEOPT32) \ - $(PROFILEOPT33) $(PROFILEOPT34) $(PROFILEOPT35) $(PROFILEOPT36) \ - $(PROFILEOPT37) $(PROFILEOPT38) $(PROFILEOPT39) $(PROFILEOPT40) \ - $(PROFILEOPT41) $(PROFILEOPT42) $(PROFILEOPT43) $(PROFILEOPT44) \ - $(PROFILEOPT45) $(PROFILEOPT46) $(PROFILEOPT47) $(PROFILEOPT48) \ - $(PROFILEOPT49) $(PROFILEOPT50) $(PROFILEOPT51) $(PROFILEOPT52) \ - $(PROFILEOPT53) $(PROFILEOPT54) $(PROFILEOPT55) $(PROFILEOPT56) \ - $(PROFILEOPT57) $(PROFILEOPT58) $(PROFILEOPT59) $(PROFILEOPT60) \ - $(PROFILEOPT61) $(PROFILEOPT62) $(PROFILEOPT63) $(PROFILEOPT64) \ - $(PROFILEOPT65) $(PROFILEOPT66) $(PROFILEOPT67) $(PROFILEOPT68) \ - $(PROFILEOPT69) $(PROFILEOPT70) $(PROFILEOPT71) $(PROFILEOPT72) \ - $(PROFILEOPT73) $(PROFILEOPT74) $(PROFILEOPT75) $(PROFILEOPT76) \ - $(TRACEOPT) - -############################################## - -TAU_LINKER_OPTS = $(TAU_LINKER_OPT1) $(TAU_LINKER_OPT2) $(TAU_LINKER_OPT3) \ - $(TAU_LINKER_OPT4) $(TAU_LINKER_OPT5) $(TAU_LINKER_OPT6) \ - $(TAU_LINKER_OPT7) $(TAU_LINKER_OPT8) $(TAU_LINKER_OPT9) \ - $(TAU_LINKER_OPT10) $(TAU_LINKER_OPT11) $(TAU_LINKER_OPT12) - -############################################## - -############# TAU Fortran #################### -TAU_LINKER=$(TAU_CXX) -#INTEL_FORTRAN##TAU_LINKER=$(TAU_F90) #ENDIF# -#INTEL32_FORTRAN##TAU_LINKER=$(TAU_F90) #ENDIF# -# Intel efc compiler acts as a linker - NO. Let C++ be the linker. - -############################################## -############# TAU Options #################### -TAUDEFS = $(PROFILEOPTS) - -TAUINC = -I$(TAU_INC_DIR) - -TAULIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -ltau$(TAU_CONFIG) $(TAU_LINKER_OPTS) - -TAUMPILIBS = $(TAU_MPI_LIB) - -TAUMPIFLIBS = $(TAU_MPI_FLIB) - -### ACL S/W requirement -TAU_DEFS = $(TAUDEFS) - -TAU_INCLUDE = -I$(TAU_INC_DIR) -#PERFLIB#TAU_INCLUDE = -I$(PERFINCDIR) #ENDIF# -#PERFLIB#TAU_DEFS = #ENDIF# -#PERFLIB#TAU_COMPILER_EXTRA_OPTIONS=-optTau=-p #ENDIF# - -TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/Memory -#IBMXLCAPPLE#TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/MemoryWrapper #ENDIF# -#APPLECXX#TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/MemoryWrapper #ENDIF# - -TAU_LIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -ltau$(TAU_CONFIG) $(TAU_LINKER_OPTS) -#PERFLIB#TAU_LIBS = #ENDIF# - -TAU_SHLIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAUsh$(TAU_CONFIG) $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) $(TAU_MPI_LIB) -#PERFLIB#TAU_SHLIBS = #ENDIF# -TAU_EXLIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAU $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) $(TAU_MPI_LIB) - -TAU_SHLIBS_NOSHOPTS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAUsh$(TAU_CONFIG) $(TAU_LINKER_OPTS) - -TAU_DISABLE = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTauDisable - -TAU_MPI_INCLUDE = $(TAU_MPI_INC) - -TAU_MPI_LIBS = $(TAU_MPI_LIB) - -TAU_MPI_FLIBS = $(TAU_MPI_FLIB) - -## TAU TRACE INPUT LIBRARY (can build a trace converter using TAU TIL) -TAU_TRACE_INPUT_LIB = -L$(TAU_LIB_DIR) -lTAU_traceinput$(TAU_CONFIG) - -## Don't include -lpthread or -lsmarts. Let app. do that. -############################################# -## IBM SPECIFIC CHANGES TO TAU_MPI_LIBS -#SP1#TAU_MPI_LDFLAGS = $(TAU_IBM_LD_FLAGS) #ENDIF# -TAU_LDFLAGS = $(TAU_MPI_LDFLAGS) #ENDIF##MPI# -#SP1#TAU_IBM_MPI_LIBS = $(TAU_MPI_LIB) -L$(TAU_MPILIB_DIR)/ip -lvtd$(TAU_MPI_R_SUFFIX) #ENDIF# -#SP1#TAU_IBM_FMPI_LIBS = $(TAU_MPI_FLIB) -L$(TAU_MPILIB_DIR)/ip -lvtd$(TAU_MPI_R_SUFFIX) #ENDIF# -#SP1#TAU_MPI_LIBS_FLAGS= $(TAU_IBM_MPI_LIBS) #ENDIF# -#SP1#TAU_MPI_FLIBS_FLAGS = $(TAU_IBM_MPI_FLIBS) #ENDIF# -TAU_MPI_LIBS_FLAGS = $(TAU_MPI_LIB) #ENDIF##MPI# -TAU_MPI_FLIBS_FLAGS = $(TAU_MPI_FLIB) #ENDIF##MPI# -TAU_MPI_LIBS = $(TAU_MPI_LIBS_FLAGS) #ENDIF##MPI# -TAU_MPI_FLIBS = $(TAU_MPI_FLIBS_FLAGS) #ENDIF##MPI# - -#SP1#TAUMPILIBS = $(TAU_MPI_LIBS) #ENDIF# -#SP1#TAUMPIFLIBS = $(TAU_MPI_FLIBS) #ENDIF# -############################################# -#SHMEM#TAU_SHMEM_OBJS = TauShmemCray.o #ENDIF# -#SP1#TAU_SHMEM_OBJS = TauShmemTurbo.o #ENDIF# -#GPSHMEM#TAU_SHMEM_OBJS = TauShmemGpshmem.o #ENDIF# - -TAU_SHMEM_INCLUDE = $(TAU_SHMEM_INC) - -TAU_SHMEM_LIBS = -L$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/ -lTauShmem$(TAU_CONFIG) $(TAU_SHMEM_LIB) -############################################# -# TAU COMPILER SHELL SCRIPT OPTIONS -TAUCOMPILEROPTS= -optPdtDir="$(PDTDIR)/${PDTARCHDIR}"\ - -optPdtCOpts="$(TAU_INCLUDE) $(TAU_DEFS) $(TAU_MPI_INCLUDE)"\ - -optPdtCxxOpts="$(TAU_INCLUDE) $(TAU_DEFS) $(TAU_MPI_INCLUDE)"\ - -optTauInstr="$(TAU_BIN_DIR)/tau_instrumentor" \ - -optNoMpi \ - -optOpariDir="$(OPARIDIR)" -optOpariTool="$(TAU_OPARI_TOOL)" \ - -optTauCC="$(TAU_CC)" \ - -optTauIncludes="$(TAU_INCLUDE) $(TAU_MPI_INCLUDE)" \ - -optTauDefs="$(TAU_DEFS)" \ - -optTauCompile="$(TAU_INCLUDE) $(TAU_MPI_INCLUDE) $(TAU_DEFS) "\ - -optLinking="$(TAU_MPI_FLIBS) $(TAU_LIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS)"\ - -optSharedLinking="$(TAU_MPI_FLIBS) $(TAU_EXLIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS)"\ - $(TAU_COMPILER_EXTRA_OPTIONS) \ - -optIncludeMemory="$(TAU_INCLUDE_MEMORY)" -############################################# - -TAU_SHAREDLIBS=$(TAUHELPER) -L$(TAU_LIB_DIR) -lTAU $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) -SHAREDEXTRAS= -#FORCESHARED#SHAREDEXTRAS=-optSharedLinkReset="$(TAU_SHAREDLIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS) $(TAU_MPI_NOWRAP_FLIB)" -optShared #ENDIF# -TAU_COMPILER=$(TAU_BIN_DIR)/tau_compiler.sh $(TAUCOMPILEROPTS) $(SHAREDEXTRAS) -############################################# -# These options could be included in the application Makefile as -#CFLAGS = $(TAUDEFS) $(TAUINC) -# -#LIBS = $(TAULIBS) -# -# To run the application without Profiling/Tracing use -#CFLAGS = $(TAUINC) -# Don't use TAUDEFS but do include TAUINC -# Also ignore TAULIBS when Profiling/Tracing is not used. -############################################# - diff --git a/source/unres/src_MD-M-newcorr/Makefile.tau-mpi-pdt-pgi.org b/source/unres/src_MD-M-newcorr/Makefile.tau-mpi-pdt-pgi.org deleted file mode 100755 index 5f0dd3a..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile.tau-mpi-pdt-pgi.org +++ /dev/null @@ -1,836 +0,0 @@ -#**************************************************************************** -#* TAU Portable Profiling Package ** -#* http://www.cs.uoregon.edu/research/tau ** -#**************************************************************************** -#* Copyright 1997-2002 ** -#* Department of Computer and Information Science, University of Oregon ** -#* Advanced Computing Laboratory, Los Alamos National Laboratory ** -#**************************************************************************** -####################################################################### -## pC++/Sage++ Copyright (C) 1993,1995 ## -## Indiana University University of Oregon University of Rennes ## -####################################################################### - -####################################################################### -# This is a sample Makefile that contains the Profiling and Tracing -# options. Makefiles of other applications and libraries (not included -# in this distribution) should include this Makefile. -# It defines the following variables that should be added to CFLAGS -# TAU_INCLUDE - Include path for tau headers -# TAU_DEFS - Defines that are needed for tracing and profiling only. -# And for linking add to LIBS -# TAU_LIBS - TAU Tracing and Profiling library libprof.a -# -# When the user needs to turn off tracing and profiling and run the -# application without any runtime overhead of instrumentation, simply -# remove TAUDEFS and TAULIBS from CFLAGS and LIBS respectively but keep -# TAUINC. -####################################################################### - -########### Automatically modified by the configure script ############ -CONFIG_ARCH=xt3 -TAU_ARCH=xt3 -CONFIG_CC=qk-pgcc -CONFIG_CXX=qk-pgCC -TAU_CC_FE=$(CONFIG_CC) -#BGL#TAU_CC_FE=xlc #ENDIF# -#BGP#TAU_CC_FE=xlc #ENDIF# -TAU_CC_FE=gcc #ENDIF##CATAMOUNT# -#SC_GFORTRAN#TAU_CC_FE=gcc #ENDIF# -#SC_PATHSCALE#TAU_CC_FE=gcc #ENDIF# -PCXX_OPT=-g -USER_OPT= -EXTRADIR=/opt/pgi/6.1.4/linux86-64/6.1/bin/.. -EXTRADIRCXX= -TAUROOT=/usr/local/packages/TAU-2.17/tau-2.17 -TULIPDIR= -TAUEXTRASHLIBOPTS= -TAUGCCLIBOPTS= -TAUGCCLIBDIR= -PCLDIR= -PAPIDIR= -PAPISUBDIR= -CHARMDIR= -PDTDIR=/usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12 -PDTCOMPDIR= -DYNINSTDIR= -JDKDIR= -SLOG2DIR= -OPARIDIR= -TAU_OPARI_TOOL= -EPILOGDIR= -EPILOGBINDIR= -EPILOGINCDIR= -EPILOGLIBDIR= -EPILOGEXTRALINKCMD= -VAMPIRTRACEDIR= -KTAU_INCDIR= -KTAU_INCUSERDIR= -KTAU_LIB= -KTAU_KALLSYMS_PATH= -PYTHON_INCDIR= -PYTHON_LIBDIR= -PERFINCDIR= -PERFLIBDIR= -PERFLIBRARY= -TAU_SHMEM_INC= -TAU_SHMEM_LIB= -TAU_CONFIG=-mpi-pdt-pgi -TAU_MPI_INC=-I/opt/xt-mpt/default/mpich2-64/P2/include -TAU_MPI_LIB=/usr/local/packages/TAU-2.17/tau-2.17/xt3/lib/libTauMpi$(TAU_CONFIG).a -L/opt/xt-mpt/default/mpich2-64/P2/lib -lrt -lmpichcxx -lmpich -lrt -TAU_MPI_FLIB=-L/opt/xt-mpt/default/mpich2-64/P2/lib -L/usr/local/packages/TAU-2.17/tau-2.17/xt3/lib/libTauMpi$(TAU_CONFIG).a -lrt -lmpichcxx -lmpich -lrt -TAU_MPILIB_DIR=/opt/xt-mpt/default/mpich2-64/P2/lib -TAU_MPI_NOWRAP_LIB= -L/opt/xt-mpt/default/mpich2-64/P2/lib -lrt -lmpichcxx -lmpich -lrt -TAU_MPI_NOWRAP_FLIB=-L/opt/xt-mpt/default/mpich2-64/P2/lib -lrt -lmpichcxx -lmpich -lrt -FULL_CXX=/opt/xt-pe/1.5.47/bin/snos64/qk-pgCC -FULL_CC=/opt/xt-pe/1.5.47/bin/snos64/qk-pgcc -TAU_PREFIX_INSTALL_DIR=/usr/local/packages/TAU-2.17/tau-2.17 - -TAU_BIN_DIR=$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/bin -TAU_INC_DIR=$(TAU_PREFIX_INSTALL_DIR)/include -TAU_LIB_DIR=$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/lib - -####################################################################### - -#ENABLE64BIT#ABI = -64 #ENDIF# -#ENABLEN32BIT#ABI = -n32 #ENDIF# -#ENABLE32BIT#ABI = -32 #ENDIF# - -####################################################################### -#SP1#IBM_XLC_ABI = -q32 #ENDIF# -#SP1#IBM_GNU_ABI = -maix32 #ENDIF# -#IBM64#IBM_XLC_ABI = -q64 #ENDIF# -#IBM64#IBM_GNU_ABI = -maix64 #ENDIF# -#IBM64LINUX#IBM_XLC_ABI = -q64 #ENDIF# -#IBM64LINUX#IBM_GNU_ABI = -m64 #ENDIF# -#SUNX86_64#SUN_GNU_ABI = -m64 #ENDIF# -#SUNX86_64#SUN_CC_ABI = -xarch=amd64 #ENDIF# -#MIPS32LINUX#SC_GNU_ABI = -mabi=n32 #ENDIF# -#MIPS32LINUX#SC_PATH_ABI = -n32 #ENDIF# -#MIPS64LINUX#SC_GNU_ABI = -mabi=64 #ENDIF# -#MIPS64LINUX#SC_PATH_ABI = -64 #ENDIF# -#GNU#SC_ABI = $(SC_GNU_ABI) #ENDIF# -#USE_PATHCC#SC_ABI = $(SC_PATH_ABI) #ENDIF# -#MIPS32#ABI = $(SC_ABI) #ENDIF# -#MIPS64#ABI = $(SC_ABI) #ENDIF# - -#USE_IBMXLC#IBM_ABI = $(IBM_XLC_ABI) #ENDIF# -#GNU#IBM_ABI = $(IBM_GNU_ABI) #ENDIF# -#SP1# ABI = $(IBM_ABI) #ENDIF# -#PPC64# ABI = $(IBM_ABI) #ENDIF# -#SOLARIS64#SUN_GNU_ABI = -mcpu=v9 -m64 #ENDIF# -#SOLARIS64#SUN_CC_ABI = -xarch=v9 -xcode=pic32 #ENDIF# -#SOL2CC#SUN_ABI = $(SUN_CC_ABI) #ENDIF# -#GNU#SUN_ABI = $(SUN_GNU_ABI) #ENDIF# -#SOL2#ABI = $(SUN_ABI) #ENDIF# -#SUNX86_64#ABI = $(SUN_ABI) #ENDIF# -#FORCEIA32#ABI = -m32#ENDIF# -####################################################################### -F90_ABI = $(ABI) -#IBM64_FORTRAN#F90_ABI = -q64 #ENDIF# -####################################################################### - -############# Standard Defines ############## -TAU_CC = $(CONFIG_CC) $(ABI) $(ISA) -TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -TAU_RUN_CC = $(FULL_CC) $(ABI) $(ISA) -TAU_RUN_CXX = $(FULL_CXX) $(ABI) $(ISA) -TAU_INSTALL = /bin/cp -TAU_SHELL = /bin/sh -LSX = .a -############################################# -# JAVA DEFAULT ARCH -############################################# -JDKARCH = linux -#COMPAQ_ALPHA#JDKARCH = alpha #ENDIF# -#SOL2#JDKARCH = solaris #ENDIF# -#SGIMP#JDKARCH = irix #ENDIF# -#SP1#JDKARCH = aix #ENDIF# -#T3E#JDKARCH = cray #ENDIF# -############################################# -# JAVA OBJECTS -############################################# -#JAVA#TAU_JAVA_O = TauJava.o TauJAPI.o #ENDIF# -#JAVA#TAUJAPI = Profile.class #ENDIF# - - -############################################# -# OpenMP OBJECTS -############################################# -#OPENMP#OPENMP_O = OpenMPLayer.o #ENDIF# - -############################################# -# Opari OBJECTS -############################################# -#OPARI#OPARI_O = TauOpari.o #ENDIF# -#KOJAKOPARI#OPARI_O = TauKojakOpari.o #ENDIF# -#EPILOG#OPARI_O = #ENDIF# -#VAMPIRTRACE#OPARI_O = #ENDIF# -#GNU#OPARI_O = #ENDIF# - -############################################# -# CallPath OBJECTS -############################################# -#PROFILECALLPATH#CALLPATH_O = TauCallPath.o #ENDIF# -#PROFILEPARAM#PARAM_O = ProfileParam.o #ENDIF# - -############################################# -# Python Binding OBJECTS -############################################# -#PYTHON#PYTHON_O = PyGroups.o PyExceptions.o PyDatabase.o PyBindings.o PyTimer.o PyTau.o #ENDIF# - -############################################# -# DYNINST DEFAULT ARCH -############################################# -DYNINST_PLATFORM = $(PLATFORM) - - -#PCL##include $(TAU_INC_DIR)/makefiles/PCLMakefile.stub #ENDIF# - -############# OpenMP Fortran Option ######## -#OPENMP#TAU_F90_OPT = -mp #ENDIF# -#SOL2CC_OPENMP#TAU_F90_OPT = -xopenmp #ENDIF# -#SUNCC_OPENMP#TAU_F90_OPT = -xopenmp=parallel #ENDIF# -#COMPAQCXX_OPENMP#TAU_F90_OPT = -omp #ENDIF# -#IBMXLC_OPENMP#TAU_F90_OPT = -qsmp=omp #ENDIF# -#GUIDE#TAU_F90_OPT = #ENDIF# -#PGIOPENMP#TAU_F90_OPT = -mp #ENDIF# -#INTELOPENMP#TAU_F90_OPT = -openmp #ENDIF# -#HITACHI_OPENMP#TAU_F90_OPT = #ENDIF# - -#THREADSAFE_COMPILERS#TAU_R =_r #ENDIF# - -############# Fortran Compiler ############# -#GNU_FORTRAN#TAU_F90 = g77 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#GNU_GFORTRAN#TAU_F90 = gfortran $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#G95_FORTRAN#TAU_F90 = g95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#SC_GFORTRAN#TAU_F90 = scgfortran $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#SGI_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#IBM_FORTRAN#TAU_F90 = xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#BGP#TAU_F90 = bgxlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#BGL#TAU_F90 = blrts_xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#IBM64_FORTRAN#TAU_F90 = xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#IBMXLFAPPLE#TAU_F90 = xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#CRAY_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#CRAY_X1_FORTRAN#TAU_F90 = ftn $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -TAU_F90 = pgf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF##PGI_FORTRAN# -#CRAYCNL#TAU_F90 = ftn $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -TAU_F90 = qk-pgf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF##PGI_CATAMOUNT# -#ABSOFT_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#LAHEY_FORTRAN#TAU_F90 = lf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#LAHEY64_FORTRAN#TAU_F90 = lf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#NAGWARE_FORTRAN#TAU_F90 = f95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#FUJITSU_FORTRAN#TAU_F90 = F90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#FUJITSU_SOLARIS#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#SUN_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#COMPAQ_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#KAI_FORTRAN#TAU_F90 = guidef90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#HP_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#HITACHI_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#INTEL_FORTRAN#TAU_F90 = efc $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#INTEL32_FORTRAN#TAU_F90 = ifc $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#INTELIFORT#TAU_F90 = ifort $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#PATHSCALE_FORTRAN#TAU_F90 = pathf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#SC_PATHSCALE#TAU_F90 = scpathf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#OPEN64ORC_FORTRAN#TAU_F90 = orf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#NEC_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# - - -############# Portable F90 Options ############# -#IBM64_FORTRAN#TAU_F90_FIXED = -qfixed #ENDIF# -#IBM_FORTRAN#TAU_F90_FIXED = -qfixed #ENDIF# -#IBM_FORTRAN#TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF# -#IBMXLFAPPLE#TAU_F90_FIXED = -qfixed #ENDIF# -#IBMXLFAPPLE#TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF# -#IBM64_FORTRAN#TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF# - -############# Profiling Options ############# -PROFILEOPT1 = -DPROFILING_ON #ENDIF##PROFILE# -#PCL#PROFILEOPT3 = -DTAU_PCL -I$(PCLDIR)/include #ENDIF# -#PAPI#PROFILEOPT3 = -DTAU_PAPI -I$(PAPIDIR)/src -I$(PAPIDIR)/include #ENDIF# -#PCL#PCL_O = PclLayer.o #ENDIF# -#PAPI#PAPI_O = PapiLayer.o #ENDIF# -#MULTIPLECOUNTERS#MULT_O = MultipleCounters.o #ENDIF# -#PROFILECALLS#PROFILEOPT4 = -DPROFILE_CALLS #ENDIF# -#PROFILESTATS#PROFILEOPT5 = -DPROFILE_STATS #ENDIF# -#DEBUGPROF#PROFILEOPT6 = -DDEBUG_PROF #ENDIF# -PROFILEOPT7 = -DTAU_STDCXXLIB #ENDIF##STDCXXLIB# -#CRAYX1CC#PROFILEOPT7 = #ENDIF# -#CRAYCC#PROFILEOPT7 = #ENDIF# -#INTELTFLOP#PROFILEOPT8 = -DPOOMA_TFLOP #ENDIF# -#NORTTI#PROFILEOPT9 = -DNO_RTTI #ENDIF# -#RTTI#PROFILEOPT9 = -DRTTI #ENDIF# -#GNU#PROFILEOPT10 = -DTAU_GNU -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# -#APPLECXX#PROFILEOPT10 = -DTAU_GNU -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# -#SOL2CC#PROFILEOPT10 = -DTAU_SOL2CC -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#SUNCC#PROFILEOPT10 = -DTAU_SOL2CC -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#USE_PATHCC#PROFILEOPT10 = -DTAU_DOT_H_LESS_HEADERS -fPIC -DTAU_PATHSCALE #ENDIF# -#OPEN64ORC#PROFILEOPT10 = -DTAU_DOT_H_LESS_HEADERS -DTAU_OPEN64ORC -fpic #ENDIF# -#CALLSTACK#PROFILEOPT11 = -DPROFILE_CALLSTACK #ENDIF# -#PGI1.7#PROFILEOPT12 = -DPGI #ENDIF# -#CRAYKAI#PROFILEOPT12 = -DCRAYKAI #ENDIF# -#HP_FORTRAN#PROFILEOPT12 = -DHP_FORTRAN #ENDIF# -#CRAYCC#PROFILEOPT13 = -h instantiate=used -DCRAYCC -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#CRAYX1CC#PROFILEOPT13 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#SGICC#TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -LANG:std #ENDIF# -#INTELCXXLIBICC#TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -cxxlib-icc #ENDIF# -#PTHREAD_AVAILABLE#PROFILEOPT15 = -DPTHREADS #ENDIF# -#COMPAQCXX_PTHREAD#PROFILEOPT15 = -DPTHREADS -pthread #ENDIF# -#TAU_SPROC#PROFILEOPT15 = -DTAU_SPROC #ENDIF# -#TAU_PAPI_THREADS#PROFILEOPT15 = -DTAU_PAPI_THREADS #ENDIF# -#TULIPTHREADS#PROFILEOPT16 = -DTULIPTHREADS #ENDIF# -#TRACE#TRACEOPT = -DTRACING_ON #ENDIF# -#TRACE#EVENTS_O = Tracer.o #ENDIF# -#KTAU#KTAU_O = TauKtau.o KtauProfiler.o KtauSymbols.o #ENDIF# -#KTAU_MERGE#KTAU_MERGE_O = KtauFuncInfo.o KtauMergeInfo.o ktau_syscall.o #ENDIF# -#KTAU_SHCTR#KTAU_SHCTR_O = KtauCounters.o #ENDIF# -#MPITRACE#TRACEOPT = -DTAU_MPITRACE -DTRACING_ON #ENDIF# -#MPITRACE#EVENTS_O = Tracer.o #ENDIF# -#MUSE#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF# -#MUSE_EVENT#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF# -#MUSE_MULTIPLE#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF# -#COMPENSATE#COMPENSATE_O = TauCompensate.o #ENDIF# -#PTHREAD_AVAILABLE#THR_O = PthreadLayer.o #ENDIF# -#TAU_PAPI_THREADS#THR_O = PapiThreadLayer.o #ENDIF# -#TAU_SPROC#THR_O = SprocLayer.o #ENDIF# -#JAVA#THR_O = JavaThreadLayer.o #ENDIF# -#TULIPTHREADS#THR_O = TulipThreadLayer.o #ENDIF# -#LINUXTIMERS#PLATFORM_O = TauLinuxTimers.o #ENDIF# -#TULIPTHREADS#PROFILEOPT17 = -I$(TULIPDIR)/include -I$(TULIPDIR)/Tuliplib #ENDIF# -#SMARTS#PROFILEOPT17 = -I$(TULIPDIR)/include -I$(TULIPDIR)/lib -I$(TULIPDIR)/machine-specific/$(HOSTTYPE) #ENDIF# -#SMARTS#PROFILEOPT18 = -DSMARTS #ENDIF# -#KAI#PROFILEOPT19 = -DKAI -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#USE_DECCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#SGICC#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#USE_INTELCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# -#USE_NECCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# -PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF##PGI# -#ACC#PROFILEOPT19 = -AA +z -DTAU_DOT_H_LESS_HEADERS -DTAU_HPUX #ENDIF# -#FUJITSU#PROFILEOPT19 = -DFUJITSU -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#KAINOEX#PROFILEOPT20 = --no_exceptions #ENDIF# -#SGICCNOEX#PROFILEOPT20 = -LANG:exceptions=off #ENDIF# -#HPGNU#PROFILEOPT21 = -fPIC #ENDIF# -#HITACHI#PROFILEOPT21 = -DTAU_HITACHI #ENDIF# -#SP1#PROFILEOPT21 = -D_POSIX_SOURCE -DTAU_AIX #ENDIF# -#PPC64#TAU_PIC_PROFILEOPT21 = -qpic=large #ENDIF# -#BGL#TAU_PIC_PROFILEOPT21 = #ENDIF# -#USE_IBMXLC#PROFILEOPT21 = -DTAU_DOT_H_LESS_HEADERS -DTAU_XLC $(TAU_PIC_PROFILEOPT21) #ENDIF# -#IBMXLCAPPLE#PROFILEOPT21 = -DTAU_DOT_H_LESS_HEADERS -DTAU_XLC -DTAU_APPLE_XLC #ENDIF# -#PCLPTHREAD#PROFILEOPT22 = -DPCL_MUTEX_LOCK #ENDIF# -#JAVA#PROFILEOPT23 = -DJAVA #ENDIF# -#MONITOR#PROFILEOPT24 = -DMONITORING_ON #ENDIF# -#JAVA#PROFILEOPT25 = -I$(JDKDIR)/include -I$(JDKDIR)/include/$(JDKARCH) #ENDIF# -PROFILEOPT26 = -DTAU_MPI #ENDIF##MPI# -PROFILEOPT26 = -DTAU_MPI -DTAU_MPI_THREADED #ENDIF##MPI_THREADED# -#OPENMP#PROFILEOPT27 = -mp -DTAU_OPENMP#ENDIF# -#GNU#PROFILEOPT27 = #ENDIF# -#SOL2CC_OPENMP#PROFILEOPT27 = -xopenmp -DTAU_OPENMP#ENDIF# -#SUNCC_OPENMP#PROFILEOPT27 = -xopenmp=parallel -DTAU_OPENMP#ENDIF# -#SUNCC_OPENMP#PROFILEOPT27 = -xopenmp=parallel -DTAU_OPENMP#ENDIF# -#HITACHI_OPENMP#PROFILEOPT27 = -DTAU_OPENMP#ENDIF# -#COMPAQCXX_OPENMP#PROFILEOPT27 = -omp -DTAU_OPENMP#ENDIF# -#IBMXLC_OPENMP#PROFILEOPT27 = -qsmp=omp -DTAU_OPENMP #ENDIF# -#OPEN64_OPENMP#PROFILEOPT27 = -mp -DTAU_OPENMP #ENDIF# -#GUIDE#PROFILEOPT27 = -DTAU_OPENMP #ENDIF# -#PGIOPENMP#PROFILEOPT27 = -mp -D_OPENMP -DTAU_OPENMP -U_RWSTD_MULTI_THREAD -U_REENTRANT #ENDIF# -#INTELOPENMP#PROFILEOPT27 = -openmp -DTAU_OPENMP #ENDIF# -#GNUOPENMP#PROFILEOPT27 = -fopenmp -DTAU_OPENMP #ENDIF# -#OPARI#PROFILEOPT28 = -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF# -#OPARI_REGION#PROFILEOPT28 = -DTAU_OPARI_REGION -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF# -#OPARI_CONSTRUCT#PROFILEOPT28 = -DTAU_OPARI_CONSTRUCT -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF# -#MULTIPLECOUNTERS#PROFILEOPT29 = -DTAU_MULTIPLE_COUNTERS #ENDIF# -#SGITIMERS#PROFILEOPT30 = -DSGI_TIMERS #ENDIF# -#BGLTIMERS#PROFILEOPT30 = -DBGL_TIMERS -I/bgl/BlueLight/ppcfloor/bglsys/include #ENDIF# -#CRAYTIMERS#PROFILEOPT30 = -DCRAY_TIMERS #ENDIF# -#LINUXTIMERS#PROFILEOPT31 = -DTAU_LINUX_TIMERS #ENDIF# -#ALPHATIMERS#PROFILEOPT31 = -DTAU_ALPHA_TIMERS #ENDIF# -#CPUTIME#PROFILEOPT32 = -DCPU_TIME #ENDIF# -#PAPIWALLCLOCK#PROFILEOPT33 = -DTAU_PAPI_WALLCLOCKTIME #ENDIF# -#PAPIVIRTUAL#PROFILEOPT34 = -DTAU_PAPI_VIRTUAL #ENDIF# -#SGICOUNTERS#PROFILEOPT35 = -DSGI_HW_COUNTERS #ENDIF# -#EPILOG#PROFILEOPT36 = -DTAU_EPILOG -I$(EPILOGINCDIR) #ENDIF# -#VAMPIRTRACEINTS#TAU_VAMPIRTRACEOPTS = -DTAU_64BITTYPES_NEEDED -DHAVE_INTTYPES_H #ENDIF# -#VAMPIRTRACE#PROFILEOPT36 = -DTAU_VAMPIRTRACE -I$(VAMPIRTRACEDIR)/vtlib -I$(VAMPIRTRACEDIR)/include $(TAU_VAMPIRTRACEOPTS)#ENDIF# -#PROFILECALLPATH#PROFILEOPT36 = -DTAU_CALLPATH #ENDIF# -#PROFILEPHASE#PROFILEOPT36 = -DTAU_CALLPATH -DTAU_PROFILEPHASE#ENDIF# -#PYTHON#PROFILEOPT37 = -I$(PYTHON_INCDIR) #ENDIF# -#NOCOMM#PROFILEOPT38 = -DTAU_NOCOMM #ENDIF# -#MUSE#PROFILEOPT39 = -DTAU_MUSE #ENDIF# -#SETNODE0#PROFILEOPT40 = -DTAU_SETNODE0 #ENDIF# -#COMPENSATE#PROFILEOPT41 = -DTAU_COMPENSATE #ENDIF# -#MUSE_EVENT#PROFILEOPT42 = -DTAU_MUSE_EVENT #ENDIF# -#MUSE_MULTIPLE#PROFILEOPT43 = -DTAU_MUSE_MULTIPLE #ENDIF# -#DYNINST41##PROFILEOPT44 = -DTAU_DYNINST41BUGFIX #ENDIF# -# DyninstAPI v4.2.1 fixes the bug, so we don't need OPT44 anymore -#PROFILEMEMORY#PROFILEOPT45 = -DTAU_PROFILEMEMORY #ENDIF# -PROFILEOPT46 = -DTAU_MPIGREQUEST #ENDIF##MPIGREQUEST# -#MPIOREQUEST#PROFILEOPT47 = -DTAU_MPIOREQUEST #ENDIF# -PROFILEOPT48 = -DTAU_MPIDATAREP #ENDIF##MPIDATAREP# -PROFILEOPT49 = -DTAU_MPIERRHANDLER #ENDIF##MPIERRHANDLER# -PROFILEOPT50 = -DTAU_CATAMOUNT #ENDIF##CATAMOUNT# -#MPICONSTCHAR#PROFILEOPT51 = -DTAU_MPICONSTCHAR #ENDIF# -PROFILEOPT52 = -DTAU_MPIATTRFUNCTION #ENDIF##MPIATTR# -PROFILEOPT53 = -DTAU_MPITYPEEX #ENDIF##MPITYPEEX# -PROFILEOPT54 = -DTAU_MPIADDERROR #ENDIF##MPIADDERROR# -#MPINEEDSTATUSCONV#PROFILEOPT55 = -DTAU_MPI_NEEDS_STATUS #ENDIF# - -#DEPTHLIMIT#PROFILEOPT56 = -DTAU_DEPTH_LIMIT #ENDIF# -#TAU_CHARM#PROFILEOPT57 = -DTAU_CHARM -I$(CHARMDIR)/include #ENDIF# -#PROFILEHEADROOM#PROFILEOPT58 = -DTAU_PROFILEHEADROOM #ENDIF# -#JAVACPUTIME#PROFILEOPT59 = -DJAVA_CPU_TIME #ENDIF# -PROFILEOPT60 = -DTAU_LARGEFILE -D_LARGEFILE64_SOURCE #ENDIF##TAU_LARGEFILE# -#SHMEM#PROFILEOPT61 = -DTAU_SHMEM #ENDIF# -#KTAU#PROFILEOPT62 = -DTAUKTAU -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -I$(KTAU_INCUSERDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF# -#KTAU_MERGE#PROFILEOPT63 = -DTAUKTAU_MERGE -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF# -#FREEBSD#PROFILEOPT64 = -DTAU_FREEBSD #ENDIF# -#PROFILEPARAM#PROFILEOPT65 = -DTAU_PROFILEPARAM #ENDIF# -#IBMMPI#PROFILEOPT66 = -DTAU_IBM_MPI #ENDIF# -PROFILEOPT67 = -DTAU_WEAK_MPI_INIT #ENDIF##WEAKMPIINIT# -#LAMPI#PROFILEOPT68 = -DTAU_LAMPI #ENDIF# -PROFILEOPT68 = -DMPICH_IGNORE_CXX_SEEK #ENDIF##MPICH_IGNORE_CXX_SEEK# -PROFILEOPT73 = -DTAU_MPICH2_MPI_IN_PLACE #ENDIF##MPICH2_MPI_INPLACE# - - -############# RENCI Scalable Trace Lib Options ############# -STFF_DIR= -SDDF_DIR= -#RENCI_STFF#PROFILEOPT69 = -DRENCI_STFF -I$(STFF_DIR)/include #ENDIF# -#RENCI_STFF#TAU_LINKER_OPT11 = -L$(STFF_DIR)/lib -lstff -L$(SDDF_DIR)/lib -lPablo $(TAU_MPI_LIB) #ENDIF# -#RENCI_STFF#RENCI_STFF_O = RenciSTFF.o #ENDIF# - -############# KTAU (again) ############# -#KTAU_SHCTR#PROFILEOPT70 = -DTAUKTAU_SHCTR -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF# -#KTAU#TAU_LINKER_OPT12 = -L$(KTAU_LIB) -lktau #ENDIF# - -#MIPS32LINUX#PROFILEOPT71 = -D_ABIN32=2 -D_MIPS_SIM=_ABIN32 #ENDIF# - -#BGL#PROFILEOPT72 = -DTAU_BGL -I/bgl/BlueLight/ppcfloor/bglsys/include #ENDIF# - -#For F90 support for all platforms -FWRAPPER = TauFMpi.o -MPI2EXTENSIONS = TauMpiExtensions.o #ENDIF##MPI2# -#CRAYX1CC#MPI2EXTENSIONS = #ENDIF# - -#SGICOUNTERS#LEXTRA = -lperfex #ENDIF# -#ALPHATIMERS#LEXTRA = -lrt #ENDIF# -#SOL2#PCL_EXTRA_LIBS = -lcpc #ENDIF# -#PCL#LEXTRA = -L$(PCLDIR)/lib -lpcl $(PCL_EXTRA_LIBS) #ENDIF# -#PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# -#IA64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi #ENDIF# -#X86_64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR)/ -L$(PAPIDIR)/lib64/ -lpapi -lperfctr #ENDIF# -#PAPIPFM#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpfm -lpapi -lpfm #ENDIF# -#SOL2PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -lcpc #ENDIF# -#IBMPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/usr/lpp/pmtoolkit/lib -L/usr/pmapi/lib -lpmapi#ENDIF# -#PPC64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# -#BGLPAPI_RTS#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.rts.a -L/bgl/BlueLight/ppcfloor/bglsys/lib -lbgl_perfctr.rts -lrts.rts -ldevices.rts #ENDIF# -#BGLPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/bgl/BlueLight/ppcfloor/bglsys/lib -lbgl_perfctr.rts -lrts.rts -ldevices.rts #ENDIF# -#BGPPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/bgsys/drivers/ppcfloor/runtime/SPI -lSPI.cna #ENDIF# -#IBM64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi64.a -L/usr/lpp/pmtoolkit/lib -L/usr/pmapi/lib -lpmapi #ENDIF# -#IBM64PAPILINUX#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# -#SGI64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi64 #ENDIF# -#ALPHAPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a /usr/lib/dcpi/dadd.a -lclu -lrt #ENDIF# - - - -# By default make TAU_PAPI_RPATH null. Support it on a compiler by compiler basis. -#PAPI###TAU_PAPI_RPATH = -rpath $(PAPIDIR)/$(PAPISUBDIR) #ENDIF# -#PAPI##TAU_PAPI_RPATH = #ENDIF# -#PPC64PAPI#TAU_PAPI_RPATH = #ENDIF# -#BGLPAPI#TAU_PAPI_RPATH = #ENDIF# -#BGPPAPI#TAU_PAPI_RPATH = #ENDIF# -#USE_INTELCXX#TAU_PAPI_RPATH = #ENDIF# -#CRAYX1CC#TAU_PAPI_RPATH = #ENDIF# -TAU_PAPI_RPATH = -R$(PAPIDIR)/$(PAPISUBDIR) #ENDIF##PGI# -#GNU#TAU_PAPI_RPATH = -Wl,-rpath $(PAPIDIR)/$(PAPISUBDIR) #ENDIF# -#USE_PATHCC#TAU_PAPI_RPATH = #ENDIF# - -# if the user has specified -cc=gcc -c++=g++ -fortran=intel, we shouldn't use -rpath -# because they are likely going to link with ifort -#INTEL32_FORTRAN#TAU_PAPI_RPATH = #ENDIF# -#SOL2PAPI#TAU_PAPI_RPATH = #ENDIF# -#IBMPAPI#TAU_PAPI_RPATH = #ENDIF# -#IBM64PAPI#TAU_PAPI_RPATH = #ENDIF# -#PAPI#TAU_LINKER_OPT1 = $(TAU_PAPI_RPATH) #ENDIF# - -#PTHREAD_AVAILABLE#LEXTRA1 = -lpthread #ENDIF# -#TULIPTHREADS#LEXTRA1 = -L$(TULIPDIR)/Tuliplib -ltulip #ENDIF# -#SMARTS##include $(TAU_INC_DIR)/makefiles/GNUmakefile-$(HOSTTYPE) #ENDIF# -#SMARTS#LEXTRA1 = $(LSMARTS) #ENDIF# - -TAU_GCCLIB = -lgcc_s -#INTEL32_ON_64#TAU_GCCLIB = -lgcc #ENDIF# -#FREEBSD#TAU_GCCLIB = -lgcc #ENDIF# -#BGL#TAU_GCCLIB = -lgcc #ENDIF# -#GNU#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF# -#OPEN64ORC_FORTRAN#TAU_FORTRANLIBS = -lfortran -lffio #ENDIF# -#PATHSCALE_FORTRAN#TAU_FORTRANLIBS = -lpathfstart -lpathfortran #ENDIF# -#SC_PATHSCALE#TAU_FORTRANLIBS = -lpathfstart -lpathfortran #ENDIF# -#NAGWARE_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/quickfit.o -L$(EXTRADIR)/lib -lf96 #ENDIF# -#G95_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR) -lf95 #ENDIF# -#GNU_FORTRAN#TAU_FORTRANLIBS = -lg2c #ENDIF# -#GNU_GFORTRAN#TAU_FORTRANLIBS = -lgfortran -lgfortranbegin #ENDIF# -#SC_GFORTRAN#TAU_FORTRANLIBS = -lgfortran -lgfortranbegin #ENDIF# -#SGI_FORTRAN#TAU_FORTRANLIBS = -lfortran -lftn #ENDIF# -#USE_IBMXLC#TAU_IBM_FORTRANLIBS = -bh:4 -bpT:0x10000000 -bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF# -#GNU#TAU_IBM_FORTRANLIBS = -Wl,-bh:4 -Wl,-bpT:0x10000000 -Wl,-bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF# -#KAI#TAU_IBM_FORTRANLIBS = --backend -bh:4 --backend -bpT:0x10000000 --backend -bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF# -#IBM_FORTRAN#TAU_FORTRANLIBS = $(TAU_IBM_FORTRANLIBS) #ENDIF# - -#USE_IBMXLC#TAU_IBM64_FORTRANLIBS = -bh:4 -bpT:0x10000000 -bpD:0x20000000 -b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF# -#GNU#TAU_IBM64_FORTRANLIBS = -Wl,-bh:4 -Wl,-bpT:0x10000000 -Wl,-bpD:0x20000000 -Wl,-b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF# -#KAI#TAU_IBM64_FORTRANLIBS = --backend -bh:4 --backend -bpT:0x10000000 --backend -bpD:0x20000000 --backend -b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF# -#IBM64_FORTRAN#TAU_FORTRANLIBS = $(TAU_IBM64_FORTRANLIBS) #ENDIF# -#IBM64_FORTRAN#TAU_FORLIBDIR=lib64 #ENDIF# -#IBM_FORTRAN#TAU_FORLIBDIR=lib #ENDIF# -#BGL#TAU_FORLIBDIR=blrts_dev_lib #ENDIF# -#BGP#TAU_FORLIBDIR=bglib #ENDIF# -#PPC64#TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -lxlf90 -lxlfmath -lxl #ENDIF# -#BGL#TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -L$(EXTRADIR)/blrts_lib -lxlf90 -lxlfmath -lxl #ENDIF# - -#BGP#TAU_BGL_OMP_SERIAL= -lxlomp_ser #ENDIF# -#OPENMP#TAU_BGL_OMP_SERIAL= #ENDIF# -#BGP#TAU_OMP_SERIAL=$(TAU_BGL_OMP_SERIAL) #ENDIF# -#BGP#TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -lxlf90 -lxlfmath $(TAU_OMP_SERIAL) #ENDIF# - -#IBMXLFAPPLE#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib -lxlf90 -lxlfmath -lxl #ENDIF# - -#CRAY_FORTRAN#TAU_FORTRANLIBS = #ENDIF# -#CRAY_X1_FORTRAN#TAU_FORTRANLIBS = #ENDIF# -TAU_FORTRANLIBS = $(EXTRADIR)/lib/f90main.o -lpgf90 -lpgf90rtl -lpgf90_rpm1 -lpgf902 -lpgftnrtl -lrt #ENDIF##PGI_FORTRAN# -#HP_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib/pa2.0 -lF90 -lcl #ENDIF# -#INTEL_FORTRAN#TAU_FORTRANLIBS = -lcprts -lPEPCF90 #ENDIF# -#INTEL32_FORTRAN#TAU_FORTRANLIBS = -lcprts -lCEPCF90 -lF90 #ENDIF# -#INTELIFORT#TAU_FORTRANLIBS = -lcprts #ENDIF# -#INTEL81FIX#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -lcxa -lunwind -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF# -#INTEL10FIX#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF# -#INTELCXXLIBICC#TAU_FORTRANLIBS = -lcprts -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF# -#PGI1.7#LEXTRA = -lstd -lstrm#ENDIF# -#PGI1.7#TAUHELPER = $(TAUROOT)/src/Profile/TauPGIHelper.cpp #ENDIF# -# LINKER OPTIONS -TAU_LINKER_OPT2 = $(LEXTRA) - - -#ACC#TAUHELPER = -AA #ENDIF# -#FUJITSU_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj9i6 -lfj9f6 -lfj9e6 #ENDIF# -#FUJITSU_SOLARIS#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj90l -lfj90f #ENDIF# -#SUN_FORTRAN#TAU_FORTRANLIBS = -lfui -lfsumai -lfprodai -lfminlai -lfmaxlai -lfminvai -lfmaxvai -lfsu -lsunmath #ENDIF# -#SUN_FORTRAN#TAU_FORTRANLIBS_SUN_OPTERON = -lfsu -lsunmath #ENDIF# -#SUN_FORTRAN#TAU_FORTRANLIBS_SUNCC = -lfsu #ENDIF# -#SUN386I#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUN_OPTERON) #ENDIF# -#SUNX86_64#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUN_OPTERON) #ENDIF# -#SUNCC#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUNCC) #ENDIF# -#SOL2#EXTRALIBS = -lsocket -lnsl #ENDIF# -#SUN386I#EXTRALIBS = -lsocket -lnsl -lrt #ENDIF# -#SUNX86_64#EXTRALIBS = -lsocket -lnsl -lrt #ENDIF# -#COMPAQ_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/cmplrs/fort90/for_main.o -L$(EXTRADIR)/lib -L$(EXTRADIR)/lib/cmplrs/fort90 -L$(EXTRADIR)/lib/cmplrs/fort90 -lUfor -lfor -lFutil -lm -lmld -lexc -lc #ENDIF# -#ABSOFT_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib -lfio -lf90math -lU77 -lf77math -lfio #ENDIF# -#LAHEY_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj9i6 -lfj9f6 -lfj9e6 -lfccx86_6a #ENDIF# -#LAHEY64_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib64/fj90rt0.o -L$(EXTRADIR)/lib64 -lfj90f -lfj90i -lelf #ENDIF# -#HITACHI_FORTRAN#TAU_FORTRANLIBS = -lf90 -lhf90math #ENDIF# -#NEC_FORTRAN#TAU_FORTRANLIBS = -f90lib #ENDIF# -#COMPAQ_GUIDEF90#TAU_FORTRANLIBS = $(EXTRADIR)/lib/cmplrs/fort90/for_main.o -lfor #ENDIF# - - -#HITACHI#TAU_HITACHI_EXTRA = -L/usr/local/lib -llrz32 #ENDIF# - -## To use the standard F90 linker instead of TAU_LINKER + TAU_FORTRANLIBS, add -#GNU#TAU_CXXLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF# -#GNU#TAU_GNUCXXLIBS = -L$(TAUGCCLIBDIR) -lstdc++ $(TAU_GCCLIB) #ENDIF# -#OPEN64ORC#TAU_CXXLIBS = -lstdc++ #ENDIF# -#PATHSCALE_FORTRAN#TAU_CXXLIBS = -lstdc++ #ENDIF# -#LAHEY_FORTRAN#TAU_CXXLIBS = $(TAU_GNUCXXLIBS) /usr/lib/libc.a #ENDIF# -#NAGWARE_FORTRAN#TAU_CXXLIBS = $(TAU_GNUCXXLIBS) /usr/lib/libc.a #ENDIF# -TAU_CXXLIBS = -lstd -lC #ENDIF##PGI# -#CRAYCNL#TAU_CXXLIBS = -L$(EXTRADIR)/lib -lstd -lC -lpgc #ENDIF# -#CRAYX1CC#TAU_CXXLIBS = -L/opt/ctl/CC/CC/lib -lC #ENDIF# - -TAU_SGI_INIT = /usr/lib32/c++init.o -#ENABLE64BIT#TAU_SGI_INIT = /usr/lib64/c++init.o #ENDIF# -#ENABLEN32BIT#TAU_SGI_INIT = /usr/lib32/c++init.o #ENDIF# -#ENABLE32BIT#TAU_SGI_INIT = /usr/lib/c++init.o #ENDIF# - -#SGICC#TAU_CXXLIBS = $(TAU_SGI_INIT) -lC #ENDIF# -#APPLECXX#TAU_CXXLIBS = -lstd -lC #ENDIF# -#SOL2#TAU_CXXLIBS = -lCstd -lCrun #ENDIF# -#SOL2CC#TAU_CXXLIBS_SUN_OPTERON = -lCstd -lCrun -lm #ENDIF# -#SUNCC#TAU_CXXLIBS_SUNCC = -lCstd -lCrun #ENDIF# -#SUN386I#TAU_CXXLIBS = $(TAU_CXXLIBS_SUN_OPTERON) #ENDIF# -#SUNCC#TAU_CXXLIBS = $(TAU_CXXLIBS_SUNCC) #ENDIF# -#SUNX86_64#TAU_CXXLIBS = $(TAU_CXXLIBS_SUN_OPTERON) #ENDIF# -#FUJITSU_SOLARIS#TAU_CXXLIBS = -lstd -lstdm #ENDIF# -#PPC64#TAU_XLCLIBS = -L$(EXTRADIRCXX)/$(TAU_FORLIBDIR) -libmc++ -lstdc++ #ENDIF# -#IBMXLCAPPLE#TAU_FORLIBDIR =lib #ENDIF# -#IBMXLCAPPLE#TAU_XLCLIBS = -L$(EXTRADIRCXX)/$(TAU_FORLIBDIR) -libmc++ -lstdc++ #ENDIF# -#BGL#TAU_XLCLIBS = -L$(EXTRADIRCXX)/blrts_dev_lib -L$(EXTRADIRCXX)/blrts_lib -libmc++ -L/bgl/BlueLight/ppcfloor/blrts-gnu/powerpc-bgl-blrts-gnu/lib -lstdc++ #ENDIF# -#BGP#TAU_XLCLIBS = -L$(EXTRADIRCXX)/bglib -libmc++ -lstdc++ #ENDIF# -#SP1#TAU_XLCLIBS = -lC #ENDIF# -#USE_IBMXLC#TAU_CXXLIBS = $(TAU_XLCLIBS) #ENDIF# -#USE_DECCXX#TAU_CXXLIBS = -lcxxstd -lcxx #ENDIF# -#USE_INTELCXX#TAU_CXXLIBS_INTEL = -lcprts -lPEPCF90 #ENDIF# -#USE_INTELCXX#TAU_CXXLIBS_INTEL = -lcprts #ENDIF# -#INTELIFORT#TAU_CXXLIBS_INTEL = -lcprts #ENDIF# -#INTEL81FIX#TAU_CXXLIBS_INTEL = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -lcxa -lunwind#ENDIF# -#INTEL10FIX#TAU_CXXLIBS_INTEL = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF# -#INTELCXXLIBICC#TAU_CXXLIBS_INTEL = -lcprts #ENDIF# -#USE_INTELCXX#TAU_CXXLIBS = $(TAU_CXXLIBS_INTEL) #ENDIF# -#APPLECXX#TAU_CXXLIBS = -lstdc++ -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lgcc_s.1 -lSystemStubs #ENDIF# - -# EXTERNAL PACKAGES: VAMPIRTRACE -#VAMPIRTRACE#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# -#VAMPIRTRACEMPI#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.mpi -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# -#VAMPIRTRACEOMPI#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.ompi -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# -#VAMPIRTRACEOMP#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.omp -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# - -# EXTERNAL PACKAGES: EPILOG -#EPILOG#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# -#EPILOGMPI#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.mpi $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# -#EPILOGOMPI#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.ompi $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# -#EPILOGOMP#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.omp $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# - -# When using shared, we don't want -lelg.mpi or -lvt.mpi showing up -#FORCESHARED#TAU_LINKER_OPT3=#ENDIF# - -TAU_LINKER_OPT4 = $(LEXTRA1) -#HITACHI_OPENMP#TAU_LINKER_OPT4 = -lcompas -lpthreads -lc_r #ENDIF# -#OPENMP#TAU_LINKER_OPT5 = -mp #ENDIF# -#SOL2CC_OPENMP#TAU_LINKER_OPT5 = -xopenmp #ENDIF# -#SUNCC_OPENMP#TAU_LINKER_OPT5 = -xopenmp=parallel #ENDIF# -#GNU#TAU_LINKER_OPT5 = #ENDIF# -#COMPAQCXX_OPENMP#TAU_LINKER_OPT5 = -omp #ENDIF# -#IBMXLC_OPENMP#TAU_LINKER_OPT5 = -qsmp=omp #ENDIF# -#OPEN64_OPENMP#TAU_LINKER_OPT5 = -mp #ENDIF# -#GUIDE#TAU_LINKER_OPT5 = #ENDIF# -#PGIOPENMP#TAU_LINKER_OPT5 = -mp #ENDIF# -#INTELOPENMP#TAU_LINKER_OPT5 = -openmp #ENDIF# - -# MALLINFO needs -lmalloc on sgi, sun -#SGIMP#TAU_LINKER_OPT6 = -lmalloc #ENDIF# -#SOL2#TAU_LINKER_OPT6 = #ENDIF# -#SUN386I#TAU_LINKER_OPT6 = -lmalloc #ENDIF# -#SUNX86_64#TAU_LINKER_OPT6 = -lmalloc #ENDIF# - -# We need -lCio with SGI CC 7.4+ -#SGICC#TAU_LINKER_OPT7 = -lCio #ENDIF# - -# charm -#TAU_CHARM#TAU_LINKER_OPT8 = -lconv-core #ENDIF# - -# extra libs -#SUN386I#TAU_LINKER_OPT9 = $(EXTRALIBS) #ENDIF# -#SUNX86_64#TAU_LINKER_OPT9 = $(EXTRALIBS) #ENDIF# -#SOL2#TAU_LINKER_OPT9 = $(ExTRALIBS) #ENDIF# - -#BGL#TAU_LINKER_OPT10 = -L/bgl/BlueLight/ppcfloor/bglsys/lib -lrts.rts #ENDIF# - -#USE_IBMXLC#TAU_IBM_PYTHON_SHFLAG = -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp -Wl,-einitpytau#ENDIF# -#GNU#TAU_IBM_PYTHON_SHFLAG = -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp -Wl,-einitpytau#ENDIF# -#KAI#TAU_IBM_PYTHON_SHFLAG = --backend -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp --backend -Wl,-einitpytau#ENDIF# -#ACC#TAU_HPUX_PYTHON_SHFLAG = -lstd_v2 -lCsup_v2 -lm -lcl -lc #ENDIF# - -#USE_IBMXLC#TAU_IBM_LD_FLAGS = -binitfini:poe_remote_main #ENDIF# -#GNU#TAU_IBM_LD_FLAGS = -Wl,-binitfini:poe_remote_main #ENDIF# -#KAI#TAU_IBM_LD_FLAGS = --backend -binitfini:poe_remote_main #ENDIF# - - -#PYTHON#TAU_IBM_SHFLAGS = $(TAU_IBM_PYTHON_SHFLAG) #ENDIF# -#PYTHON#TAU_HPUX_SHFLAGS = $(TAU_HPUX_PYTHON_SHFLAG) #ENDIF# -#SP1#TAU_EXTRA_LIBRARY_FLAGS = $(TAU_IBM_SHFLAGS) #ENDIF# -#SOL2#TAU_EXTRA_LIBRARY_FLAGS = #ENDIF# -#SGIMP#TAU_EXTRA_LIBRARY_FLAGS = -lmalloc #ENDIF# -#HP#TAU_EXTRA_LIBRARY_FLAGS = $(TAU_HPUX_SHFLAGS) #ENDIF# - -TAU_MPI_WRAPPER_LIB= -L$(TAU_LIB_DIR) -lTauMpi$(TAU_CONFIG) #ENDIF##MPI# -#EPILOGMPI#TAU_MPI_WRAPPER_LIB= #ENDIF# -#EPILOGOMPI#TAU_MPI_WRAPPER_LIB= #ENDIF# - -############################################## -# Build TAU_LINKER_SHOPTS -#GNU#TAU_IBM_LINKER_SHOPTS=-Wl,-brtl -Wl,-bexpall #ENDIF# -#USE_IBMXLC#TAU_IBM_LINKER_SHOPTS= -brtl -bexpall #ENDIF# -#KAI#TAU_IBM_LINKER_SHOPTS= --backend -brtl #ENDIF# -#SP1#TAU_LINKER_SHOPTS= $(TAU_IBM_LINKER_SHOPTS) #ENDIF# - -############################################## -# MPI _r suffix check (as in libmpi_r) -#MPI_R_SUFFIX#TAU_MPI_R_SUFFIX=_r #ENDIF# - -############################################## -# Flags to build a shared object: TAU_SHFLAGS -#GNU#AR_SHFLAGS = -shared #ENDIF# -AR_SHFLAGS = -shared #ENDIF##PGI# -#SGICC#AR_SHFLAGS = -shared #ENDIF# -#APPLECXX#AR_SHFLAGS = -dynamiclib -flat_namespace -undefined suppress #ENDIF# -#SOL2#AR_SHFLAGS = -G #ENDIF# -#SUN386I#AR_SHFLAGS = -G #ENDIF# -#SUNX86_64#AR_SHFLAGS = -G #ENDIF# -#USE_IBMXLC#AR_SHFLAGS = -G #ENDIF# -#USE_DECCXX#AR_SHFLAGS = -shared #ENDIF# -#USE_INTELCXX#AR_SHFLAGS = -shared #ENDIF# -#ACC#AR_SHFLAGS = -b #ENDIF# -TAU_SHFLAGS = $(AR_SHFLAGS) -o - -############# RANLIB Options ############# -TAU_RANLIB = echo "Built" -#APPLECXX#TAU_RANLIB = ranlib #ENDIF# -#IBMXLCAPPLE#TAU_RANLIB = ranlib #ENDIF# - -############################################## -TAU_AR = ar #ENDIF# -#SP1#TAU_AR = ar -X32 #ENDIF# -#IBM64#TAU_AR = ar -X64 #ENDIF# -#PPC64#TAU_AR = ar #ENDIF# -#IBM64LINUX#TAU_AR = ar #ENDIF# - - -############################################## -# PDT OPTIONS -# You can specify -pdtcompdir=intel -pdtarchdir=x86_64 -# If nothing is specified, PDTARCHDIR uses TAU_ARCH -PDTARCHDIRORIG=$(TAU_ARCH) -PDTARCHITECTURE=x86_64 -PDTARCHDIRFINAL=$(PDTARCHDIRORIG) -#PDTARCHITECTURE#PDTARCHDIRFINAL=$(PDTARCHITECTURE)#ENDIF# -PDTARCHDIR=$(PDTARCHDIRFINAL) -#PDTARCH#PDTARCHDIR=$(PDTARCHDIRFINAL)/$(PDTCOMPDIR)#ENDIF# - - -############################################## - -PROFILEOPTS = $(PROFILEOPT1) $(PROFILEOPT2) $(PROFILEOPT3) $(PROFILEOPT4) \ - $(PROFILEOPT5) $(PROFILEOPT6) $(PROFILEOPT7) $(PROFILEOPT8) \ - $(PROFILEOPT9) $(PROFILEOPT10) $(PROFILEOPT11) $(PROFILEOPT12) \ - $(PROFILEOPT13) $(PROFILEOPT14) $(PROFILEOPT15) $(PROFILEOPT16) \ - $(PROFILEOPT17) $(PROFILEOPT18) $(PROFILEOPT19) $(PROFILEOPT20) \ - $(PROFILEOPT21) $(PROFILEOPT22) $(PROFILEOPT23) $(PROFILEOPT24) \ - $(PROFILEOPT25) $(PROFILEOPT26) $(PROFILEOPT27) $(PROFILEOPT28) \ - $(PROFILEOPT29) $(PROFILEOPT30) $(PROFILEOPT31) $(PROFILEOPT32) \ - $(PROFILEOPT33) $(PROFILEOPT34) $(PROFILEOPT35) $(PROFILEOPT36) \ - $(PROFILEOPT37) $(PROFILEOPT38) $(PROFILEOPT39) $(PROFILEOPT40) \ - $(PROFILEOPT41) $(PROFILEOPT42) $(PROFILEOPT43) $(PROFILEOPT44) \ - $(PROFILEOPT45) $(PROFILEOPT46) $(PROFILEOPT47) $(PROFILEOPT48) \ - $(PROFILEOPT49) $(PROFILEOPT50) $(PROFILEOPT51) $(PROFILEOPT52) \ - $(PROFILEOPT53) $(PROFILEOPT54) $(PROFILEOPT55) $(PROFILEOPT56) \ - $(PROFILEOPT57) $(PROFILEOPT58) $(PROFILEOPT59) $(PROFILEOPT60) \ - $(PROFILEOPT61) $(PROFILEOPT62) $(PROFILEOPT63) $(PROFILEOPT64) \ - $(PROFILEOPT65) $(PROFILEOPT66) $(PROFILEOPT67) $(PROFILEOPT68) \ - $(PROFILEOPT69) $(PROFILEOPT70) $(PROFILEOPT71) $(PROFILEOPT72) \ - $(PROFILEOPT73) $(PROFILEOPT74) $(PROFILEOPT75) $(PROFILEOPT76) \ - $(TRACEOPT) - -############################################## - -TAU_LINKER_OPTS = $(TAU_LINKER_OPT1) $(TAU_LINKER_OPT2) $(TAU_LINKER_OPT3) \ - $(TAU_LINKER_OPT4) $(TAU_LINKER_OPT5) $(TAU_LINKER_OPT6) \ - $(TAU_LINKER_OPT7) $(TAU_LINKER_OPT8) $(TAU_LINKER_OPT9) \ - $(TAU_LINKER_OPT10) $(TAU_LINKER_OPT11) $(TAU_LINKER_OPT12) - -############################################## - -############# TAU Fortran #################### -TAU_LINKER=$(TAU_CXX) -#INTEL_FORTRAN##TAU_LINKER=$(TAU_F90) #ENDIF# -#INTEL32_FORTRAN##TAU_LINKER=$(TAU_F90) #ENDIF# -# Intel efc compiler acts as a linker - NO. Let C++ be the linker. - -############################################## -############# TAU Options #################### -TAUDEFS = $(PROFILEOPTS) - -TAUINC = -I$(TAU_INC_DIR) - -TAULIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -ltau$(TAU_CONFIG) $(TAU_LINKER_OPTS) - -TAUMPILIBS = $(TAU_MPI_LIB) - -TAUMPIFLIBS = $(TAU_MPI_FLIB) - -### ACL S/W requirement -TAU_DEFS = $(TAUDEFS) - -TAU_INCLUDE = -I$(TAU_INC_DIR) -#PERFLIB#TAU_INCLUDE = -I$(PERFINCDIR) #ENDIF# -#PERFLIB#TAU_DEFS = #ENDIF# -#PERFLIB#TAU_COMPILER_EXTRA_OPTIONS=-optTau=-p #ENDIF# - -TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/Memory -#IBMXLCAPPLE#TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/MemoryWrapper #ENDIF# -#APPLECXX#TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/MemoryWrapper #ENDIF# - -TAU_LIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -ltau$(TAU_CONFIG) $(TAU_LINKER_OPTS) -#PERFLIB#TAU_LIBS = #ENDIF# - -TAU_SHLIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAUsh$(TAU_CONFIG) $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) $(TAU_MPI_LIB) -#PERFLIB#TAU_SHLIBS = #ENDIF# -TAU_EXLIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAU $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) $(TAU_MPI_LIB) - -TAU_SHLIBS_NOSHOPTS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAUsh$(TAU_CONFIG) $(TAU_LINKER_OPTS) - -TAU_DISABLE = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTauDisable - -TAU_MPI_INCLUDE = $(TAU_MPI_INC) - -TAU_MPI_LIBS = $(TAU_MPI_LIB) - -TAU_MPI_FLIBS = $(TAU_MPI_FLIB) - -## TAU TRACE INPUT LIBRARY (can build a trace converter using TAU TIL) -TAU_TRACE_INPUT_LIB = -L$(TAU_LIB_DIR) -lTAU_traceinput$(TAU_CONFIG) - -## Don't include -lpthread or -lsmarts. Let app. do that. -############################################# -## IBM SPECIFIC CHANGES TO TAU_MPI_LIBS -#SP1#TAU_MPI_LDFLAGS = $(TAU_IBM_LD_FLAGS) #ENDIF# -TAU_LDFLAGS = $(TAU_MPI_LDFLAGS) #ENDIF##MPI# -#SP1#TAU_IBM_MPI_LIBS = $(TAU_MPI_LIB) -L$(TAU_MPILIB_DIR)/ip -lvtd$(TAU_MPI_R_SUFFIX) #ENDIF# -#SP1#TAU_IBM_FMPI_LIBS = $(TAU_MPI_FLIB) -L$(TAU_MPILIB_DIR)/ip -lvtd$(TAU_MPI_R_SUFFIX) #ENDIF# -#SP1#TAU_MPI_LIBS_FLAGS= $(TAU_IBM_MPI_LIBS) #ENDIF# -#SP1#TAU_MPI_FLIBS_FLAGS = $(TAU_IBM_MPI_FLIBS) #ENDIF# -TAU_MPI_LIBS_FLAGS = $(TAU_MPI_LIB) #ENDIF##MPI# -TAU_MPI_FLIBS_FLAGS = $(TAU_MPI_FLIB) #ENDIF##MPI# -TAU_MPI_LIBS = $(TAU_MPI_LIBS_FLAGS) #ENDIF##MPI# -TAU_MPI_FLIBS = $(TAU_MPI_FLIBS_FLAGS) #ENDIF##MPI# - -#SP1#TAUMPILIBS = $(TAU_MPI_LIBS) #ENDIF# -#SP1#TAUMPIFLIBS = $(TAU_MPI_FLIBS) #ENDIF# -############################################# -#SHMEM#TAU_SHMEM_OBJS = TauShmemCray.o #ENDIF# -#SP1#TAU_SHMEM_OBJS = TauShmemTurbo.o #ENDIF# -#GPSHMEM#TAU_SHMEM_OBJS = TauShmemGpshmem.o #ENDIF# - -TAU_SHMEM_INCLUDE = $(TAU_SHMEM_INC) - -TAU_SHMEM_LIBS = -L$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/ -lTauShmem$(TAU_CONFIG) $(TAU_SHMEM_LIB) -############################################# -# TAU COMPILER SHELL SCRIPT OPTIONS -TAUCOMPILEROPTS= -optPdtDir="$(PDTDIR)/${PDTARCHDIR}"\ - -optPdtCOpts="$(TAU_INCLUDE) $(TAU_DEFS) $(TAU_MPI_INCLUDE)"\ - -optPdtCxxOpts="$(TAU_INCLUDE) $(TAU_DEFS) $(TAU_MPI_INCLUDE)"\ - -optTauInstr="$(TAU_BIN_DIR)/tau_instrumentor" \ - -optNoMpi \ - -optOpariDir="$(OPARIDIR)" -optOpariTool="$(TAU_OPARI_TOOL)" \ - -optTauCC="$(TAU_CC)" \ - -optTauIncludes="$(TAU_INCLUDE) $(TAU_MPI_INCLUDE)" \ - -optTauDefs="$(TAU_DEFS)" \ - -optTauCompile="$(TAU_INCLUDE) $(TAU_MPI_INCLUDE) $(TAU_DEFS) "\ - -optLinking="$(TAU_MPI_FLIBS) $(TAU_LIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS)"\ - -optSharedLinking="$(TAU_MPI_FLIBS) $(TAU_EXLIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS)"\ - $(TAU_COMPILER_EXTRA_OPTIONS) \ - -optIncludeMemory="$(TAU_INCLUDE_MEMORY)" -############################################# - -TAU_SHAREDLIBS=$(TAUHELPER) -L$(TAU_LIB_DIR) -lTAU $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) -SHAREDEXTRAS= -#FORCESHARED#SHAREDEXTRAS=-optSharedLinkReset="$(TAU_SHAREDLIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS) $(TAU_MPI_NOWRAP_FLIB)" -optShared #ENDIF# -TAU_COMPILER=$(TAU_BIN_DIR)/tau_compiler.sh $(TAUCOMPILEROPTS) $(SHAREDEXTRAS) -############################################# -# These options could be included in the application Makefile as -#CFLAGS = $(TAUDEFS) $(TAUINC) -# -#LIBS = $(TAULIBS) -# -# To run the application without Profiling/Tracing use -#CFLAGS = $(TAUINC) -# Don't use TAUDEFS but do include TAUINC -# Also ignore TAULIBS when Profiling/Tracing is not used. -############################################# - diff --git a/source/unres/src_MD-M-newcorr/Makefile_MPICH_ifort b/source/unres/src_MD-M-newcorr/Makefile_MPICH_ifort deleted file mode 100644 index 708cf8f..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_MPICH_ifort +++ /dev/null @@ -1,143 +0,0 @@ -################################################################### -INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh - - -FC= ifort - -OPT = -g -ip -w -CB - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - - -LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf/libxdrf.a - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o permut.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -GAB: BIN = ../../../bin/unres/MD/unres_mchain-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} - -GABT: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -DNEWCORR -DCRYST_BOND -DCRYST_THETA -DCRYST_SC # -DMUOUT -GABT: BIN = ../../../bin/unres/MD/unres_mchain-ifort_MPICH_GAB-NEWC.exe -GABT: ${object} xdrf/libxdrf.a - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - -E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -E0LL2Y: BIN = ../../../bin/unres/MD/unres_mchain_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} - -E0LL2YT: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -DNEWCORR -E0LL2YT: BIN = ../../../bin/unres/MD/unres_mchain_ifort_MPICH_E0LL2Y-NEWC.exe -E0LL2YT: ${object} xdrf/libxdrf.a - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - -xdrf/libxdrf.a: - cd xdrf && make - - -clean: - /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new_barrier.o : energy_p_new_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F - -gradient_p.o : gradient_p.F - ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F - -energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -MD_A-MTS.o : MD_A-MTS.F - ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS2} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-M-newcorr/Makefile_aix_xlf b/source/unres/src_MD-M-newcorr/Makefile_aix_xlf deleted file mode 100644 index 8fe4624..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_aix_xlf +++ /dev/null @@ -1,112 +0,0 @@ -CPPFLAGS = -WF,-DUNRES -WF,-DMP -WF,-DMPI -WF,-DSPLITELE -WF,-DISNAN -WF,-DAIX -#-DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -INSTALL_DIR = -# -FC= mpxlf90 -qfixed -w - -OPT = -q64 - -FFLAGS = -c ${OPT} -O3 -FFLAGS1 = -c ${OPT} -O2 -FFLAGS2 = -c ${OPT} -O -FFLAGSE = -c ${OPT} -O4 - - -BIN = ${HOME}/UNRES/bin/unres_MD.exe -LIBS = -qipa - -ARCH = LINUX -PP = /lib/cpp -P - -all: unresCSA - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -objectCSA = unres_CSA.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o energy_p_new.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD.o REMD.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split.o \ - q_measure.o gnmr1.o - -unresCSA: ${objectCSA} - cc -o compinfo compinfo.c - ./compinfo - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${objectCSA} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - /bin/rm *.il - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F diff --git a/source/unres/src_MD-M-newcorr/Makefile_bigben b/source/unres/src_MD-M-newcorr/Makefile_bigben deleted file mode 100644 index 8d961fa..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_bigben +++ /dev/null @@ -1,138 +0,0 @@ -# -FC= ftn -OPT = -fast \ --Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ --Mprefetch=distance:8,nta - -#OPT = -C -g -#OPT1 = -g -fast -OPT1 = ${OPT} -#OPT2 = -fast -OPT2 = ${OPT} -OPTE = ${OPT} - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include -FFLAGSE = ${FFLAGS} - -CFLAGS = -DSGI -c - -BIN = ../bin/unres_MD_Tc_procor-newmat-novec-noparint_barrier_corr-split.exe -LIBS = xdrf/libxdrf.a - -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \ - -DSPLITELE -DPROCOR -DAMD64 -DLANG0 \ -#-DTIMING \ -#-DCRYST_BOND -DCRYST_THETA -DCRYST_SC -#-DPARVEC #-DPARINT -DPARINTDER - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} proc_proc.o - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -energy_p_new-sep.o : energy_p_new-sep.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS1} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-M-newcorr/Makefile_bigben-oldparm b/source/unres/src_MD-M-newcorr/Makefile_bigben-oldparm deleted file mode 100644 index 14a4ab4..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_bigben-oldparm +++ /dev/null @@ -1,136 +0,0 @@ -# -FC= ftn -OPT = -fast \ --Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ --Mprefetch=distance:8,nta - -#OPT = -C -g -#OPT1 = -g -fast -OPT1 = -fast -OPT2 = -fast -OPT2 = ${OPT} -OPTE = ${OPT} - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include -FFLAGSE = ${FFLAGS} - -CFLAGS = -DSGI -c - -BIN = ../bin/unres_MD_Tc_procor-newmat-novec-noparint_barrier_corr-split-oldparm.exe -LIBS = xdrf/libxdrf.a - -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \ - -DSPLITELE -DPROCOR -DAMD64 -DLANG0 \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} proc_proc.o - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -energy_p_new-sep.o : energy_p_new-sep.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS1} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-M-newcorr/Makefile_bigben-tau b/source/unres/src_MD-M-newcorr/Makefile_bigben-tau deleted file mode 100644 index ee02905..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_bigben-tau +++ /dev/null @@ -1,137 +0,0 @@ -# -#FC= ftn -TAU_MAKEFILE=/usr/local/packages/TAU-2.17/tau-2.17/xt3/lib/Makefile.tau-mpi-pdt-pgi -FC=tau_f90.sh -OPT = -fast \ --Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ --Mprefetch=distance:8,nta - -#OPT = -C -g -#OPT1 = -g -fast -OPT1 = -fast -OPT2 = -fast -OPT2 = ${OPT} -OPTE = ${OPT} - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include -FFLAGSE = ${FFLAGS} - -CFLAGS = -DSGI -c - -BIN = ../bin/unres_MD_Tc_procor-newmat-noparint-barrier-tau.exe -LIBS = xdrf/libxdrf.a - -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \ - -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -DPARVEC - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} proc_proc.o - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o *.pp.[fF] *.pp.inst.[fF] - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -energy_p_new-sep.o : energy_p_new-sep.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS1} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-M-newcorr/Makefile_intrepid b/source/unres/src_MD-M-newcorr/Makefile_intrepid deleted file mode 100644 index 2b57f9e..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_intrepid +++ /dev/null @@ -1,151 +0,0 @@ -# -FC=/bgsys/drivers/ppcfloor/comm/bin/mpixlf77 -OPT = -O4 -qarch=450 -qtune=450 -#OPT = -O3 -qarch=450 -qtune=450 -qdebug=function_trace -#OPT = -O -qarch=450 -qtune=450 -#OPT = -O0 -C -g -qarch=450 -qtune=450 #-qdebug=function_trace -#-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ -#-Mprefetch=distance:8,nta - -#OPT1 = -O -g -qarch=450 -qtune=450 -#OPT1 = -O -g -qarch=450 -qtune=450 -qdebug=function_trace -OPT1 = ${OPT} -#OPT2 = -O2 -qarch=450 -qtune=450 -#OPT2 = -O2 -qarch=450 -qtune=450 -qdebug=function_trace -OPT2 = ${OPT} -#OPTE = -O4 -qarch=450 -qtune=450 -#OPTE = -O4 -qarch=450 -qtune=450 -OPTE=${OPT} - -CFLAGS = -c -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include -FFLAGSE = -c ${OPTE} -I$(INSTALL_DIR)/include - -BIN = ../bin/unres_MD_Tc_procor-newparm-O4-parcorr.exe -#BIN = ../bin/unres_MD_Tc_procor-newparm-O4-PARINT-parcorr.exe -#BIN = ../bin/unres_MD_Tc_procor-newparm-parvecmatint-O4-notau1.exe -#BIN = ../bin/unres_MD_Tc_procor-newparm-O4-notau1.exe -#LIBS = xdrf/libxdrf.a /home/liwo/UNRES/LIB/libmemmon.a -LIBS = xdrf/libxdrf.a - -CPPFLAGS = -WF,-DAIX -WF,-DISNAN -WF,-DUNRES -WF,-DMP -WF,-DMPI -WF,-DPGI \ - -WF,-DSPLITELE -WF,-DPROCOR -WF,-DAMD64 -WF,-DLANG0 -#-WF,-DPARINT -WF,-DPARINTDER -#-WF,-DPARVEC -WF,-DPARMAT -WF,-DMATGATHER - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -obj: ${object} - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - ${CC} -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -eigen.o : eigen.f - ${FC} ${FFLAGS1} ${CPPFLAGS} eigen.f - -blas.o : blas.f - ${FC} ${FFLAGS1} ${CPPFLAGS} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} ${CPPFLAGS} add.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -energy_p_new-sep.o : energy_p_new-sep.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c - -compinfo: compinfo.c - ${CC} ${CFLAGS} compinfo.c diff --git a/source/unres/src_MD-M-newcorr/Makefile_jubl b/source/unres/src_MD-M-newcorr/Makefile_jubl deleted file mode 100644 index 9524cd6..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_jubl +++ /dev/null @@ -1,132 +0,0 @@ -CPPFLAGS = -WF,-DOLD_GINV \ - -WF,-DUNRES -WF,-DMP -WF,-DMPI \ - -WF,-DSPLITELE -WF,-DISNAN \ - -WF,-DAIX -WF,-DLANG0 -WF,-DPROCOR -#-WF,-DNOXDR -#-WF,-DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -BGLSYS = /bgl/BlueLight/ppcfloor/bglsys - -CC = /usr/bin/blrts_xlc -CPPC = /usr/bin/blrts_xlc -FC = /usr/bin/blrts_xlf90 -#-pg -g - -# try -qarch=440 first, then use -qarch=440d for 2nd FPU later on -# (SIMDization requires at least -O3) -# use -qlist -qsource with 440d and look for Parallel ASM instructions. -# -OPT= -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 -qfixed -w -qnosave -CFLAGS= -O3 -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 -FFLAGS= -c -O3 ${OPT} -# -LIBS_MPI = -lmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts -LIBSF_MPI = -lmpich.rts -lfmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts - -FFLAGS1 = -c ${OPT} -O2 -FFLAGS2 = -c ${OPT} -O -FFLAGSE = -c ${OPT} -O4 - - -BIN = ${HOME}/UNRES/bin/unres_Tc_procor_150aa.rts -#BIN = ${HOME}/UNRES/bin/unres_Tc_oldginv_noprocor.rts -LIBS = ${LIBSF_MPI} xdrf/libxdrf.a -#LIBS = ${LIBSF_MPI} - -ARCH = LINUX -PP = /lib/cpp -P - -all: unresCSA - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -objectCSA = unres_CSA.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o energy_p_new.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split.o \ - q_measure.o gnmr1.o - -unresCSA: ${objectCSA} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${objectCSA} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - diff --git a/source/unres/src_MD-M-newcorr/Makefile_jubl-debug b/source/unres/src_MD-M-newcorr/Makefile_jubl-debug deleted file mode 100644 index d2d6c47..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_jubl-debug +++ /dev/null @@ -1,141 +0,0 @@ -CPPFLAGS = -WF,-DOLD_GINV \ - -WF,-DUNRES -WF,-DMP -WF,-DMPI \ - -WF,-DSPLITELE -WF,-DISNAN \ - -WF,-DAIX -WF,-DLANG0 -WF,-DPROCOR -#-WF,-DNOXDR -#-WF,-DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -BGLSYS = /bgl/BlueLight/ppcfloor/bglsys - -CC = /usr/bin/blrts_xlc -CPPC = /usr/bin/blrts_xlc -FC = /usr/bin/blrts_xlf90 -#-pg -g - -# try -qarch=440 first, then use -qarch=440d for 2nd FPU later on -# (SIMDization requires at least -O3) -# use -qlist -qsource with 440d and look for Parallel ASM instructions. -# -OPT= -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 -qfixed -w -qnosave -CFLAGS= -O3 -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 -FFLAGS= -c -O3 ${OPT} -FFLAGS= -c -C -g ${OPT} -# -LIBS_MPI = -lmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts -LIBSF_MPI = -lmpich.rts -lfmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts - -FFLAGS1 = -c ${OPT} -O2 -FFLAGS2 = -c ${OPT} -O -FFLAGSE = -c ${OPT} -O4 - - -BIN = ${HOME}/UNRES/bin/unres_Tc_procor_150aa_newparm.rts -LIBS = ${LIBSF_MPI} xdrf/libxdrf.a -#LIBS = ${LIBSF_MPI} - -ARCH = LINUX -PP = /lib/cpp -P - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${objectCSA} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -eigen.o : eigen.f - ${FC} ${FFLAGS2} ${CPPFLAGS} eigen.f - -blas.o : blas.f - ${FC} ${FFLAGS2} ${CPPFLAGS} blas.f - -add.o : add.f - ${FC} ${FFLAGS2} ${CPPFLAGS} add.f diff --git a/source/unres/src_MD-M-newcorr/Makefile_jubl-opt b/source/unres/src_MD-M-newcorr/Makefile_jubl-opt deleted file mode 100644 index b89fe31..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_jubl-opt +++ /dev/null @@ -1,117 +0,0 @@ -CPPFLAGS = -WF,-DAIX -WF,-DISNAN -WF,-DUNRES -WF,-DMP -WF,-DMPI \ - -WF,-DSPLITELE -WF,-DPROCOR -WF,-DAMD64 -WF,-DLANG0 -#-WF,-DTIMING_ENE -WF,-DTIMING -# -WF,-DCRYST_BOND -WF,-DCRYST_THETA -WF,-DCRYST_SC - - -#FC= mpixlf77 -pg -FC= mpixlf77 -CC= bgcc - -OPT = -O3 -qarch=450d -qtune=450 - -FFLAGS = -c ${OPT} -FFLAGS1 = -c -g -O3 -qarch=450d -qtune=450 -FFLAGS2 = -c -g -O0 -qarch=450d -qtune=450 -FFLAGSE = -c -O4 -qipa -Q+scalar -qhot=simd -qarch=450d -qtune=450 - -BIN = ../bin/unres_Tc_procor_new800_jugene.exe -LIBS = xdrf/libxdrf.a -qipa - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -fitsq.o : fitsq.f - ${FC} ${FFLAGS2} fitsq.f diff --git a/source/unres/src_MD-M-newcorr/Makefile_jubl-opt-oldparm b/source/unres/src_MD-M-newcorr/Makefile_jubl-opt-oldparm deleted file mode 100644 index 4c883a9..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_jubl-opt-oldparm +++ /dev/null @@ -1,116 +0,0 @@ -CPPFLAGS = -WF,-DAIX -WF,-DISNAN -WF,-DUNRES -WF,-DMP -WF,-DMPI \ - -WF,-DSPLITELE -WF,-DPROCOR -WF,-DAMD64 -WF,-DLANG0 \ - -WF,-DCRYST_BOND -WF,-DCRYST_THETA -WF,-DCRYST_SC -WF,-DTIMING_ENE - - -#FC= mpixlf77 -pg -FC= mpixlf77 -CC= bgcc - -OPT = -O3 -qarch=450d -qtune=450 - -FFLAGS = -c ${OPT} -FFLAGS1 = -c -g -O3 -qarch=450d -qtune=450 -FFLAGS2 = -c -g -O0 -qarch=450d -qtune=450 -FFLAGSE = -c -O4 -qipa -Q+scalar -qhot=simd -qarch=450d -qtune=450 - -BIN = ../bin/unres_Tc_procor_new700_jugene-oldparm.exe -LIBS = xdrf/libxdrf.a -qipa - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -fitsq.o : fitsq.f - ${FC} ${FFLAGS2} fitsq.f diff --git a/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc b/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc deleted file mode 100644 index fa4db65..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc +++ /dev/null @@ -1,104 +0,0 @@ -# mpich def -INSTALL_DIR = /usr/local/mpich-1.2.0 -# -#FC= /usr/local/opt/intel/compiler60/ia32/bin/ifc -FC= ifc -OPT = -O3 -ip -w -pc64 -tpp6 - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -tpp6 -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -tpp6 -w -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -tpp6 -w -O3 -ipo -ipo_obj -pc64 -opt_report -I$(INSTALL_DIR)/include - -BIN = ${HOME}/UNRES/NEW/bin/unres_ifc8.exe -LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib -openmp -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -ARCH = LINUX -PP = /lib/cpp -P - -all: unresCSA - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -objectCSA = unres_CSA.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o energy_p_new.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o contact.o djacob.o entmcm.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o proc_proc.o mcmf.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o -#fputrap.o zscore.o - -unresCSA: ${objectCSA} - cc -o compinfo compinfo.c - ./compinfo - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${objectCSA} cinfo.o ${LIBS} -Wl,-Bstatic -o ${BIN} - -clean: - /bin/rm *.o - /bin/rm *.il - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.f - ${FC} ${FFLAGS} ${CPPFLAGS} test.f - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F diff --git a/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64 b/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64 deleted file mode 100644 index f2b013d..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64 +++ /dev/null @@ -1,128 +0,0 @@ -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI \ - -DPGI -DSPLITELE -DISNAN -DAMD64 \ - -DPROCOR -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -## -DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -#INSTALL_DIR = /usr/local/mpich-1.2.0 -INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/ -# -#FC= /usr/local/opt/intel/compiler60/ia32/bin/ifc -FC= ifort - -OPT = -O3 -ip -w - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - -BIN = unres_Tc_procor_new_em64.exe -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich xdrf/libxdrf.a -#LIBS = -L$(INSTALL_DIR)/lib_ifort -lmpich xdrf/libxdrf.a -LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf_em64/libxdrf.a -g -d2 -CA -CB - -ARCH = LINUX -PP = /lib/cpp -P - -all: unresCSA - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -objectCSA = unres_CSA.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o energy_p_new.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split.o \ - q_measure3.o econstr_local.o gnmr1.o check_sc_map.o check_bond.o - -unresCSA: ${objectCSA} - cc -o compinfo compinfo.c - ./compinfo - ${FC} ${FFLAGS} cinfo.f - ${FC} -static-libcxa ${OPT} ${objectCSA} cinfo.o ${LIBS} -o ${BIN} - mv ${BIN} ../bin - -clean: - /bin/rm *.o - /bin/rm *.il - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -readrtns_CSA.o : readrtns_CSA.F - ${FC} ${FFLAGS1} ${CPPFLAGS} readrtns_CSA.F - -MREMD.o : MREMD.F - ${FC} ${FFLAGS1} ${CPPFLAGS} MREMD.F - diff --git a/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64_galera b/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64_galera deleted file mode 100644 index cf0d3a5..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64_galera +++ /dev/null @@ -1,130 +0,0 @@ -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI \ - -DPGI -DSPLITELE -DISNAN -DAMD64 \ - -DPROCOR -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -#INSTALL_DIR = /usr/local/mpich-1.2.0 -#INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/ -INSTALL_DIR = /opt/mpi/mvapich -# -#FC= /usr/local/opt/intel/compiler60/ia32/bin/ifc -FC= ifort -FCL = ${INSTALL_DIR}/bin/mpif77 -CC = cc - -OPT = -O3 -ip -w - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - -BIN = ../bin/unres_Tc_procor_new_em64-lang-D-1000.exe -LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpthread xdrf_em64/libxdrf.a -g -d2 -CA -CB - -ARCH = LINUX -PP = /lib/cpp -P - -all: unresCSA - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unresCSA: ${object} - cc -o compinfo compinfo.c - ./compinfo - ${FC} ${FFLAGS} cinfo.f - ${FCL} -static-libcxa ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - -clean: - /bin/rm *.o - /bin/rm *.il - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -readrtns_CSA.o : readrtns_CSA.F - ${FC} ${FFLAGS1} ${CPPFLAGS} readrtns_CSA.F - -MREMD.o : MREMD.F - ${FC} ${FFLAGS1} ${CPPFLAGS} MREMD.F - -fitsq.o : fitsq.f - ${FC} ${FFLAGS2} fitsq.f diff --git a/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64_galera-oldparm b/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64_galera-oldparm deleted file mode 100644 index 4efcbee..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64_galera-oldparm +++ /dev/null @@ -1,131 +0,0 @@ -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI \ - -DPGI -DSPLITELE -DISNAN -DAMD64 \ - -DPROCOR \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -## -DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -#INSTALL_DIR = /usr/local/mpich-1.2.0 -#INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/ -INSTALL_DIR = /opt/mpi/mvapich -# -#FC= /usr/local/opt/intel/compiler60/ia32/bin/ifc -FC= ifort -FCL = ${INSTALL_DIR}/bin/mpif77 -CC = cc - -OPT = -O3 -ip -w - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - -BIN = ../bin/unres_Tc_procor_new_em64-lang-oldparm-D-1000.exe -LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpthread xdrf_em64/libxdrf.a -g -d2 -CA -CB - -ARCH = LINUX -PP = /lib/cpp -P - -all: unresCSA - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unresCSA: ${object} - cc -o compinfo compinfo.c - ./compinfo - ${FC} ${FFLAGS} cinfo.f - ${FCL} -static-libcxa ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - -clean: - /bin/rm *.o - /bin/rm *.il - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -readrtns_CSA.o : readrtns_CSA.F - ${FC} ${FFLAGS1} ${CPPFLAGS} readrtns_CSA.F - -MREMD.o : MREMD.F - ${FC} ${FFLAGS1} ${CPPFLAGS} MREMD.F - -fitsq.o : fitsq.f - ${FC} ${FFLAGS2} fitsq.f diff --git a/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64_mpi2 b/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64_mpi2 deleted file mode 100644 index c9228ca..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc10_em64_mpi2 +++ /dev/null @@ -1,146 +0,0 @@ -CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DMP -DMPI -DPGI -DISNAN \ - -DSPLITELE -DAMD64 -DLANG0 -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -#-DCRYST_TOR -# -DPROCOR -# -DTSCSC -#-DTIMING \ -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -# -DMOMENT -#-DPARVEC -#-DPARINT -DPARINTDER - -#INSTALL_DIR = /users/local/mpi64/mpich-1.2.7p1/ -#INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh -#INSTALL_DIR = /users/software/mpich2.x86_64/ -INSTALL_DIR = /opt/mpi/mvapich2 - -FC= ifort -FCL= ${INSTALL_DIR}/bin/mpif77 - -OPT = -O3 -ip -w -xO - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -xO -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - - -BIN = ../bin/unres_Tc_procor_new_em64_mpich2-lang.exe -LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf_em64/libxdrf.a -lpthread - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FCL} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new_barrier.o : energy_p_new_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F - -gradient_p.o : gradient_p.F - ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F - -energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -MD_A-MTS.o : MD_A-MTS.F - ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS2} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc8 b/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc8 deleted file mode 100644 index 5b5eeee..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_lnx_ifc8 +++ /dev/null @@ -1,127 +0,0 @@ -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI \ - -DPGI -DSPLITELE -DISNAN \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -## -DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -#INSTALL_DIR = /usr/local/mpich-1.2.0 -INSTALL_DIR = /usr/local/mpich-1.2.7p1_intel-8.0_ssh -# -#FC= /usr/local/opt/intel/compiler60/ia32/bin/ifc -FC= ifort - -OPT = -O3 -ip -w -pc64 -tpp6 - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -tpp6 -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -tpp6 -w -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -tpp6 -w -O3 -ipo -ipo_obj -pc64 -opt_report -I$(INSTALL_DIR)/include - -BIN = unres_Tc_noprocor.exe -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich xdrf/libxdrf.a -#LIBS = -L$(INSTALL_DIR)/lib_ifort -lmpich xdrf/libxdrf.a -LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf/libxdrf.a -g -d2 -CA -CB - -ARCH = LINUX -PP = /lib/cpp -P - -all: unresCSA - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -objectCSA = unres_CSA.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o energy_p_new.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split.o \ - q_measure3.o econstr_local.o gnmr1.o check_sc_map.o check_bond.o - -unresCSA: ${objectCSA} - cc -o compinfo compinfo.c - ./compinfo - ${FC} ${FFLAGS} cinfo.f - ${FC} -static-libcxa ${OPT} ${objectCSA} cinfo.o ${LIBS} -o ${BIN} - mv ${BIN} ../bin - -clean: - /bin/rm *.o - /bin/rm *.il - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -readrtns_CSA.o : readrtns_CSA.F - ${FC} ${FFLAGS1} ${CPPFLAGS} readrtns_CSA.F - -MREMD.o : MREMD.F - ${FC} ${FFLAGS1} ${CPPFLAGS} MREMD.F - diff --git a/source/unres/src_MD-M-newcorr/Makefile_lnx_pgf90 b/source/unres/src_MD-M-newcorr/Makefile_lnx_pgf90 deleted file mode 100644 index 844c8c6..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_lnx_pgf90 +++ /dev/null @@ -1,120 +0,0 @@ -FC= mpif90 -OPT = -fast -pc 64 -tp p6 \ --Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 -#OPT = -C -g -fast -pc 64 -tp p6 - -OPT1 = -C -g -fast -pc 64 -tp p6 -#OPT = -C -g - -# -Mvect <---slows down -# -Minline=name:matmat2 <---false convergence - -CFLAGS = -DSGI -FFLAGS = -c ${OPT} -FFLAGS1 = -c ${OPT1} - -BIN = /users/adam/MEY_MD/bin/unres_MD_Tc-fine-newmat.exe -LIBS = -Lxdrf -lxdrf -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \ - -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -DPARVEC #-DPARINT -DPARINTDER -#-DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -ARCH = LINUX -PP = /lib/cpp -P - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new.o \ - energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - cc -o compinfo compinfo.c - ./compinfo - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -Wl,-Bstatic -o ${BIN} - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS1} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS1} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS1} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -fitsq.o: fitsq.f - ${FC} ${FFLAGS1} ${CPPFLAGS} fitsq.f - -rmsd.o: rmsd.F - ${FC} ${FFLAGS1} ${CPPFLAGS} rmsd.F - -contact.o: contact.f - ${FC} ${FFLAGS1} ${CPPFLAGS} contact.f - -minim_jlee.o: minim_jlee.F - ${FC} ${FFLAGS1} ${CPPFLAGS} minim_jlee.F - -minimize_p.o: minimize_p.F - ${FC} ${FFLAGS1} ${CPPFLAGS} minimize_p.F - -gen_rand_conf.o: gen_rand_conf.F - ${FC} ${FFLAGS} ${CPPFLAGS} gen_rand_conf.F - - -test.o: test.F - ${FC} ${FFLAGS1} ${CPPFLAGS} test.F - -elecont.o: elecont.f - ${FC} ${FFLAGS} ${CPPFLAGS} elecont.f - -eigen.o : eigen.f - ${FC} ${FFLAGS} ${CPPFLAGS} eigen.f - -blas.o : blas.f - ${FC} ${FFLAGS} ${CPPFLAGS} blas.f - -add.o : add.f - ${FC} ${FFLAGS} ${CPPFLAGS} add.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c - -compinfo: compinfo.c - ${CC} ${CFLAGS} compinfo.c diff --git a/source/unres/src_MD-M-newcorr/Makefile_osf_f90 b/source/unres/src_MD-M-newcorr/Makefile_osf_f90 deleted file mode 100644 index f9fa711..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_osf_f90 +++ /dev/null @@ -1,79 +0,0 @@ -# -FC= f90 -OPT = -arch ev67 -tune ev67 -fast -fpe1 -f77 -OPT1 = -arch ev67 -tune ev67 -fast -fpe1 -f77 -#OPT1 = -fast -g3 -arch ev67 -fpe4 -f77 -C -#OPT = -g3 -arch ev67 -tune ev67 -C -fpe1 -f77 - -FFLAGS = -c ${OPT} -FFLAGS1 = -c ${OPT1} - -BIN = ${HOME}/UNRES/MD/bin/unres_MD_procor-Tc.exe -LIBS = -lmpi -lelan xdrf/libxdrf.a -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI -DOSF -DSPLITELE -DPROCOR -DISNAN -#CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI -DOSF -DISNAN -DSPLITELE -#-DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -ARCH = LINUX -PP = /lib/cpp -P - -all: unresCSA - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F -.c.o: - ${CC} -c ${CPPFLAGS} $*.c - - -objectCSA = unres_CSA.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o energy_p_new.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split.o \ - q_measure.o gnmr1.o - -unresCSA: ${objectCSA} - cc -o compinfo compinfo.c - ./compinfo - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${objectCSA} cinfo.o ${LIBS} -o ${BIN} - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -together.o: together.F - ${FC} ${FFLAGS1} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS1} ${CPPFLAGS} test.F - -elecont.o: elecont.f - ${FC} ${FFLAGS} ${CPPFLAGS} elecont.f - -gen_rand_conf.o:gen_rand_conf.F - ${FC} ${FFLAGS1} ${CPPFLAGS} gen_rand_conf.F - -djacob.o: djacob.f - ${FC} ${FFLAGS1} ${CPPFLAGS} djacob.f - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS1} ${CPPFLAGS} chainbuild.F -cartder.o: cartder.F - ${FC} ${FFLAGS1} ${CPPFLAGS} cartder.F - diff --git a/source/unres/src_MD-M-newcorr/Makefile_win_ifl b/source/unres/src_MD-M-newcorr/Makefile_win_ifl deleted file mode 100644 index 309718c..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_win_ifl +++ /dev/null @@ -1,53 +0,0 @@ -CC= icl.exe -FC= ifl.exe - -FFLAGS = /Qlowercase /c /Qip /Qfpp2 /Ox /G6 /w90 /w /cm /DUNRES /DMOMENT /DMP /DMPI /DPGI /DWINIFL -CCFLAGS = /c /Qlowercase /DUNRES /DMOMENT /DMP /DMPI /DPGI /DWIN /DWINIFL -LDFLAGS = /ounres_ifl.exe C:\\Progra~1\\MPIPro\\lib\\MPIPro.lib \ - C:\\Progra~1\\MPIPro\\lib\\MPIPro_abs.lib - -all: unresCSA - -.SUFFIXES: .f .c - -.f.o: - $(FC) $(FFLAGS) $*.f - touch $*.o -.F.o: - $(FC) $(FFLAGS) $*.F - touch $*.o -.c.o: - $(CC) $(CCFLAGS) $*.c - touch $*.o - -objectCSA = unres_CSA.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o energy_p_new.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o contact.o djacob.o entmcm.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o proc_proc.o mcmf.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o -#fputrap.o zscore.o - -objectCSAobj = unres_CSA.obj arcos.obj cartprint.obj chainbuild.obj convert.obj initialize_p.obj \ - matmult.obj readrtns_CSA.obj parmread.obj gen_rand_conf.obj printmat.obj map.obj \ - pinorm.obj randgens.obj rescode.obj intcor.obj timing.obj misc.obj intlocal.obj \ - cartder.obj checkder_p.obj energy_p_new.obj gradient_p.obj minimize_p.obj sumsld.obj \ - cored.obj rmdd.obj geomout.obj readpdb.obj regularize.obj thread.obj fitsq.obj mcm.obj \ - mc.obj bond_move.obj refsys.obj check_sc_distr.obj contact.obj djacob.obj entmcm.obj \ - together.obj csa.obj minim_jlee.obj shift.obj diff12.obj bank.obj newconf.obj ran.obj \ - indexx.obj MP.obj compare_s1.obj prng_32.obj proc_proc.obj mcmf.obj \ - test.obj banach.obj distfit.obj rmsd.obj elecont.obj dihed_cons.obj - -unresCSA: $(objectCSA) - $(FC) $(FFLAGS) cinfo.f - $(FC) $(LDFLAGS) $(objectCSAobj) cinfo.obj -link: - $(FC) $(LDFLAGS) $(objectCSAobj) cinfo.obj - -clean: - del *.obj - del *.o - diff --git a/source/unres/src_MD-M-newcorr/Makefile_win_pgf90 b/source/unres/src_MD-M-newcorr/Makefile_win_pgf90 deleted file mode 100644 index e5530ba..0000000 --- a/source/unres/src_MD-M-newcorr/Makefile_win_pgf90 +++ /dev/null @@ -1,43 +0,0 @@ -CC= pgcc -FC= pgf90 -OPT = -fast -pc 64 -tp p6 \ --Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 - -#FFLAGS = -c $(OPT) -Ic:/progra~1/mpipro/include -FFLAGS = -c $(OPT) -Ih:/users/czarek/mpipro/include - -LIBS = c:/progra~1/mpipro/lib/MPIPro_pgf.lib \ - c:/progra~1/mpipro/lib/MPIPro.lib - -CPPFLAGS = -DUNRES -DMP -DMPI -DPGI -DWINPGI -#-DMOMENT -#-DCRYST_TOR -#-DDEBUG - -all: unresCSA - -.SUFFIXES: .F -.F.o: - $(FC) $(FFLAGS) $(CPPFLAGS) $*.F -.c.o: - $(CC) -c $(CPPFLAGS) $*.c - - -objectCSA = unres_CSA.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o energy_p_new.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o contact.o djacob.o entmcm.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o proc_proc.o mcmf.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o -#fputrap.o - -unresCSA: $(objectCSA) - $(FC) $(FFLAGS) cinfo.f - $(FC) $(OPT) $(objectCSA) cinfo.o $(LIBS) -o unres_pg - -clean: - /bin/rm *.o - diff --git a/source/unres/src_MD-M-newcorr/README b/source/unres/src_MD-M-newcorr/README deleted file mode 100644 index 2b1d2be..0000000 --- a/source/unres/src_MD-M-newcorr/README +++ /dev/null @@ -1,2 +0,0 @@ -The program will fail if there is no "Makefile" file. -You must copy (cp MakeXXXX Makefile) or use a symbolic link (ln -s MakeXXXX Makefile) before compiling. diff --git a/source/unres/src_MD-M-newcorr/TAU b/source/unres/src_MD-M-newcorr/TAU deleted file mode 100644 index 231a93e..0000000 --- a/source/unres/src_MD-M-newcorr/TAU +++ /dev/null @@ -1,6 +0,0 @@ -module load tau/tau-2.17 -#with preprocessor -setenv TAU_OPTIONS '-optPreProcess -optVerbose' -setenv TAU_THROTTLE 1 -setenv TAU_THROTTLE_NUMCALLS 400000 -setenv TAU_THROTTLE_PERCALL 3000 diff --git a/source/unres/src_MD-M-newcorr/TAU_setup.sh b/source/unres/src_MD-M-newcorr/TAU_setup.sh deleted file mode 100755 index 1423b72..0000000 --- a/source/unres/src_MD-M-newcorr/TAU_setup.sh +++ /dev/null @@ -1,15 +0,0 @@ -#!/bin/bash -# -# Adding tau -# Must be executed from command line, don't know why! -#soft add +tau -# -# With preprocessor -# -export TAU_OPTIONS='-optPreProcess -optVerbose' -# -# sets tau makefile -# -export TAU_MAKEFILE=/soft/apps/tau/tau-2.17.1/bgp/lib/Makefile.tau-mpi-pdt - -export TAU_OPTIONS='-optTauSelectFile=select.tau -optPreProcess -optVerbose -optKeepFiles' diff --git a/source/unres/src_MD-M-newcorr/WVRND b/source/unres/src_MD-M-newcorr/WVRND deleted file mode 100644 index 0ebf6db..0000000 --- a/source/unres/src_MD-M-newcorr/WVRND +++ /dev/null @@ -1,32 +0,0 @@ -# This viminfo file was generated by Vim 6.4. -# You may edit it if you're careful! - -# Value of 'encoding' when this file was written -*encoding=utf-8 - - -# hlsearch on (H) or off (h): -~h -# Command Line History (newest to oldest): -:q - -# Search String History (newest to oldest): - -# Expression History (newest to oldest): - -# Input Line History (newest to oldest): - -# Input Line History (newest to oldest): - -# Registers: - -# File marks: -'0 1 0 ~/UNRES/src_TC_newmat.tau-timing/grep - -# Jumplist (newest first): --' 1 0 ~/UNRES/src_TC_newmat.tau-timing/grep - -# History of marks within files (newest to oldest): - -> ~/UNRES/src_TC_newmat.tau-timing/grep - " 1 0 diff --git a/source/unres/src_MD-M-newcorr/add.f b/source/unres/src_MD-M-newcorr/add.f deleted file mode 100644 index fd91a70..0000000 --- a/source/unres/src_MD-M-newcorr/add.f +++ /dev/null @@ -1,28 +0,0 @@ - SUBROUTINE ABRT - STOP 'IN ABRT' - END -C*MODULE MTHLIB *DECK VCLR - SUBROUTINE VCLR(A,INCA,N) -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) -C - DIMENSION A(*) -C - PARAMETER (ZERO=0.0D+00) -C -C ----- ZERO OUT VECTOR -A-, USING INCREMENT -INCA- ----- -C - IF (INCA .NE. 1) GO TO 200 - DO 110 L=1,N - A(L) = ZERO - 110 CONTINUE - RETURN -C - 200 CONTINUE - LA=1-INCA - DO 210 L=1,N - LA=LA+INCA - A(LA) = ZERO - 210 CONTINUE - RETURN - END diff --git a/source/unres/src_MD-M-newcorr/arcos.f b/source/unres/src_MD-M-newcorr/arcos.f deleted file mode 100644 index f054118..0000000 --- a/source/unres/src_MD-M-newcorr/arcos.f +++ /dev/null @@ -1,9 +0,0 @@ - FUNCTION ARCOS(X) - implicit real*8 (a-h,o-z) - include 'COMMON.GEO' - IF (DABS(X).LT.1.0D0) GOTO 1 - ARCOS=PIPOL*(1.0d0-DSIGN(1.0D0,X)) - RETURN - 1 ARCOS=DACOS(X) - RETURN - END diff --git a/source/unres/src_MD-M-newcorr/banach.f b/source/unres/src_MD-M-newcorr/banach.f deleted file mode 100644 index 7c43d77..0000000 --- a/source/unres/src_MD-M-newcorr/banach.f +++ /dev/null @@ -1,99 +0,0 @@ -C -C********************** - SUBROUTINE BANACH(N,NMAX,A,X,osob) -C********************** -C Banachiewicz - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A(NMAX,NMAX),X(NMAX),D(MAXRES6) - COMMON /BANII/ D - logical osob - osob=.false. - if (dabs(a(1,1)).lt.1.0d-15) then - osob=.true. - return - endif - D(1)=1./A(1,1) - DO 80 I=2,N - A(I,1)=A(1,I) - DO 81 J=2,I-1 - XX=A(J,I) - DO 82 K=1,J-1 - XX=XX-A(I,K)*A(J,K) - 82 CONTINUE - A(I,J)=XX - 81 CONTINUE - XX=A(I,I) - JJJJ=I-1 - DO 83 J=1,JJJJ - AIJ=A(I,J) - AIJD=AIJ*D(J) - A(I,J)=AIJD - XX=XX-AIJ*AIJD - 83 CONTINUE - if (dabs(xx).lt.1.0d-15) then - osob=.true. - return - endif - D(I)=1./XX - 80 CONTINUE -C - CALL BANAII(N,NMAX,A,X) - RETURN - END -C************************ - SUBROUTINE BANAII(N,NMAX,A,X) -C************************ - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A(NMAX,NMAX),X(NMAX),D(MAXRES6) - COMMON /BANII/ D - DO 90 I=1,N - Z=X(I) - JJJJ=I-1 - DO 91 J=JJJJ,1,-1 - Z=Z-A(I,J)*X(J) - 91 CONTINUE - X(I)=Z - 90 CONTINUE - DO 92 I=N,1,-1 - Z=X(I)*D(I) - JJJJ=I+1 - DO 93 J=JJJJ,N - Z=Z-A(J,I)*X(J) - 93 CONTINUE - X(I)=Z - 92 CONTINUE - RETURN - END -C - SUBROUTINE MATINVERT(N,NMAX,A,A1,osob) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A(NMAX,NMAX),A1(NMAX,NMAX),D(MAXRES6) - COMMON /BANII/ D - DIMENSION X(NMAX) - logical osob - DO I=1,N - X(I)=0.0 - ENDDO - X(1)=1.0 - CALL BANACH(N,NMAX,A,X,osob) - if (osob) return - DO I=1,N - A1(I,1)=X(I) - ENDDO - DO I=2,N - DO J=1,N - X(J)=0.0 - ENDDO - X(I)=1.0 - CALL BANAII(N,NMAX,A,X) - DO J=1,N - A1(J,I)=X(J) - ENDDO - ENDDO - RETURN - END - - diff --git a/source/unres/src_MD-M-newcorr/bank.F b/source/unres/src_MD-M-newcorr/bank.F deleted file mode 100644 index 5636ba0..0000000 --- a/source/unres/src_MD-M-newcorr/bank.F +++ /dev/null @@ -1,1084 +0,0 @@ -cc--------------------------------- - subroutine refresh_bank(ntrial) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - character chacc - integer iaccn - double precision l_diff(mxio),denep - - do i=0,mxmv - do j=1,3 - nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) - nstatnx(i,j)=0 - enddo - enddo - -c loop over all newly obtained conformations - do n=1,ntrial - chacc=' ' - iaccn=0 - nstatnx(movernx(n),1)=nstatnx(movernx(n),1)+1 -cccccccccccccccccccccccccccccccccccccccccccc -cjlee - if(iref.ne.0) then - if(rmsn(n).gt.rmscut.or.pncn(n).lt.pnccut) goto 100 - endif -cjlee - if(etot(n).gt.ebmax) goto 100 -c Find the conformation closest to the conformation n in the bank - difmin=9.d9 - do m=1,nbank - call get_diff12(dihang(1,1,1,n),bvar(1,1,1,m),l_diff(m)) - if(l_diff(m).lt.difmin) then - difmin=l_diff(m) - idmin=m - endif - enddo - - if(difmin.lt.cutdif) then -c n is redundant to idmin - if(etot(n).lt.bene(idmin)) then - if(etot(n).lt.bene(idmin)-0.01d0) then - ibank(idmin)=0 - jbank(idmin)=0 - endif - denep=bene(idmin)-etot(n) - call replace_bvar(idmin,n) -crc Update dij - do i1=1,nbank - if (i1.ne.idmin) then - dij(i1,idmin)=l_diff(i1) - dij(idmin,i1)=l_diff(i1) - endif - enddo - chacc='c' - iaccn=idmin - nstatnx(movernx(n),2)=nstatnx(movernx(n),2)+1 - if(idmin.eq.ibmax) call find_max - endif - else -c got new conformation - del_ene=0.0d0 - if(ebmax-ebmin.gt.del_ene) then - denep=ebmax-etot(n) - call replace_bvar(ibmax,n) -crc Update dij - do i1=1,nbank - if (i1.ne.ibmax) then - dij(i1,ibmax)=l_diff(i1) - dij(ibmax,i1)=l_diff(i1) - endif - enddo - chacc='f' - iaccn=ibmax - nstatnx(movernx(n),3)=nstatnx(movernx(n),3)+1 - ibank(ibmax)=0 - jbank(ibmax)=0 - call find_max - else - if(del_ene.lt.0.0001) then - write (iout,*) 'ERROR in refresh_bank: ' - write (iout,*) 'ebmax: ',ebmax - write (iout,*) 'ebmin: ',ebmin - write (iout,*) 'del_ene: ',del_ene -crc call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif -cjp nbmax is never defined so condition below is always false -c if(nbank.lt.nbmax) then -c nbank=nbank+1 -c call replace_bvar(nbank,n) -c ibank(nbank)=0 -c jbank(nbank)=0 -c else - call replace_bvar(ibmax,n) - ibank(ibmax)=0 - jbank(ibmax)=0 - call find_max -c endif - endif - endif -cccccccccccccccccccccccccccccccccccccccccccc - 100 continue - if (iaccn.eq.0) then - if (iref.eq.0) then - write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5)') - & indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ', - & indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9) - else - write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5 - & ,a5,0pf4.1,a5,f3.0)') - & indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ', - & indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9), - & ' rms ',rmsn(n),' %NC ',pncn(n)*100 - endif - else - if (iref.eq.0) then - write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5, - & 1x,a1,i4,0pf8.1,0pf8.1)') - & indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ', - & indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9), - & chacc,iaccn,difmin,denep - else - write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5,a5, - & 0pf4.1,a5,f3.0,1x,a1,i4,0pf8.1,0pf8.1)') - & indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ', - & indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9), - & ' rms ',rmsn(n),' %NC ',pncn(n)*100, - & chacc,iaccn,difmin,denep - endif - endif - enddo -c end of loop over all newly obtained conformations - do i=0,mxmv - if(nstatnx(i,1).ne.0) then - if (i.le.9) then - write(iout,'(a4,i1,a7,i4,a7,i4,a5,i4,a5,f5.1)') - & '## N',i,' total=',nstatnx(i,1), - & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), - & ' %acc',(nstatnx(i,2)+nstatnx(i,3))*100.0/nstatnx(i,1) - else - write(iout,'(a3,i2,a7,i4,a7,i4,a5,i4,a5,f5.1)') - & '##N',i,' total=',nstatnx(i,1), - & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), - & ' %acc',(nstatnx(i,2)+nstatnx(i,3))*100.0/nstatnx(i,1) - endif - else - if (i.le.9) then - write(iout,'(a4,i1,a7,i4,a7,i4,a5,i4,a5,f5.1)') - & '## N',i,' total=',nstatnx(i,1), - & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), - & ' %acc',0.0 - else - write(iout,'(a3,i2,a7,i4,a7,i4,a5,i4,a5,f5.1)') - & '##N',i,' total=',nstatnx(i,1), - & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), - & ' %acc',0.0 - endif - endif - enddo - call flush(iout) -crc Update dij -crc moved up, saves some get_diff12 calls -crc -crc do i1=1,nbank-1 -crc do i2=i1+1,nbank -crc if(jbank(i1).eq.0.or.jbank(i2).eq.0) then -crc call get_diff12(bvar(1,1,1,i1),bvar(1,1,1,i2),diff) -crc dij(i1,i2)=diff -crc dij(i2,i1)=diff -crc endif -crc enddo -crc enddo - - do i=1,nbank - jbank(i)=1 - enddo - - return - end -c--------------------------------- - subroutine replace_bvar(iold,inew) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - - if (iold.gt.mxio .or. iold.lt.1 .or. inew.gt.mxio .or. inew.lt.1) - & then - write (iout,*) 'Dimension ERROR in REPLACE_BVAR: IOLD',iold, - & ' INEW',inew - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - bvar(i,j,k,iold)=dihang(i,j,k,inew) - enddo - enddo - enddo - bene(iold)=etot(inew) - brmsn(iold)=rmsn(inew) - bpncn(iold)=pncn(inew) - - if(bene(iold).lt.ebmin) then - ebmin=bene(iold) - ibmin=iold - endif - - if(vdisulf) then - bvar_nss(iold)=nss_out(inew) -cd write(iout,*) 'SS BANK',iold,bvar_nss(iold) - do i=1,bvar_nss(iold) - bvar_ss(1,i,iold)=iss_out(i,inew) - bvar_ss(2,i,iold)=jss_out(i,inew) -cd write(iout,*) 'SS',bvar_ss(1,i,iold)-nres, -cd & bvar_ss(2,i,iold)-nres - enddo - - bvar_ns(iold)=ns-2*bvar_nss(iold) -cd write(iout,*) 'CYS #free ', bvar_ns(iold) - k=0 - do i=1,ns - j=1 - do while( iss(i).ne.iss_out(j,inew)-nres .and. - & iss(i).ne.jss_out(j,inew)-nres .and. - & j.le.nss_out(inew)) - j=j+1 - enddo - if (j.gt.nss_out(inew)) then - k=k+1 - bvar_s(k,iold)=iss(i) - endif - enddo -cd write(iout,*) 'CYS free',(bvar_s(k,iold),k=1,bvar_ns(iold)) - endif - - return - end -c--------------------------------------- - subroutine write_rbank(jlee,adif,nft) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - - open(icsa_rbank,file=csa_rbank,status="unknown") - write (icsa_rbank,900) jlee,nbank,nstep,nft,icycle,adif - do k=1,nbank - write (icsa_rbank,952) k,rene(k),rrmsn(k),rpncn(k) - do j=1,numch - do l=2,nres-1 - write (icsa_rbank,850) (rad2deg*rvar(i,l,j,k),i=1,4) - enddo - enddo - enddo - close(icsa_rbank) - - 850 format (10f8.3) - 900 format (1x,"jlee =",i3,3x,"nbank =",i4,3x,"nstep =", - & i8,i10,i2,f15.5) - 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3 - & ,' %NC ',0pf5.2) - - return - end -c--------------------------------------- - subroutine read_rbank(jlee,adif) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.SETUP' - character*80 karta - - open(icsa_rbank,file=csa_rbank,status="old") - read (icsa_rbank,901) jleer,nbankr,nstepr,nftr,icycler,adif - print *,jleer,nbankr,nstepr,nftr,icycler,adif -c print *, 'adif from read_rbank ',adif - if(nbankr.ne.nbank) then - write (iout,*) 'ERROR in READ_BANK: NBANKR',nbankr, - & ' NBANK',nbank - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - if(jleer.ne.jlee) then - write (iout,*) 'ERROR in READ_BANK: JLEER',jleer, - & ' JLEE',jlee - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - - kk=0 - do k=1,nbankr - read (icsa_rbank,'(a80)') karta - write(iout,*) "READ_RBANK: kk=",kk - write(iout,*) karta -c if (index(karta,"*").gt.0) then -c write (iout,*) "***** Stars in bankr ***** k=",k, -c & " skipped" -c do j=1,numch -c do l=2,nres-1 -c read (30,850) (rdummy,i=1,4) -c enddo -c enddo -c else - kk=kk+1 - call reada(karta,"total E",rene(kk),1.0d20) - call reada(karta,"rmsd from N",rrmsn(kk),0.0d0) - call reada(karta,"%NC",rpncn(kk),0.0d0) - write(iout,*)"total E",bene(kk),"rmsd from N",brmsn(kk), - & "%NC",bpncn(kk),ibank(kk) -c read (icsa_rbank,953) kdummy,rene(kk),rrmsn(kk),rpncn(kk) - do j=1,numch - do l=2,nres-1 - read (icsa_rbank,850) (rvar(i,l,j,kk),i=1,4) -c write (iout,850) (rvar(i,l,j,kk),i=1,4) - do i=1,4 - rvar(i,l,j,kk)=deg2rad*rvar(i,l,j,kk) - enddo - enddo - enddo -c endif - enddo -cd write (*,*) "read_rbank ******************* kk",kk, -cd & "nbankr",nbankr - if (kk.lt.nbankr) nbankr=kk -cd do kk=1,nbankr -cd print *,"kk=",kk -cd do j=1,numch -cd do l=2,nres-1 -cd write (*,850) (rvar(i,l,j,kk),i=1,4) -cd enddo -cd enddo -cd enddo - close(icsa_rbank) - - 850 format (10f8.3) - 901 format (1x,6x,i3,3x,7x,i4,3x,7x,i8,i10,i2,f15.5) - 953 format (1x,1x,i4,9x,f12.3,13x,f8.3,5x,f5.2) - - return - end -c--------------------------------------- - subroutine write_bank(jlee,nft) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - character*7 chtmp - character*40 chfrm - external ilen - - open(icsa_bank,file=csa_bank,status="unknown") - write (icsa_bank,900) jlee,nbank,nstep,nft,icycle,cutdif - write (icsa_bank,902) nglob_csa, eglob_csa - open (igeom,file=intname,status='UNKNOWN') - do k=1,nbank - write (icsa_bank,952) k,bene(k),brmsn(k),bpncn(k),ibank(k) - if (vdisulf) write (icsa_bank,'(101i4)') - & bvar_nss(k),((bvar_ss(j,i,k),j=1,2),i=1,bvar_nss(k)) - do j=1,numch - do l=2,nres-1 - write (icsa_bank,850) (rad2deg*bvar(i,l,j,k),i=1,4) - enddo - enddo - if (bvar_nss(k).le.9) then - write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k), - & bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,bvar_nss(k)) - else - write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k), - & bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,9) - write (igeom,'(3X,11(1X,2I3))') (bvar_ss(1,i,k), - & bvar_ss(2,i,k),i=10,bvar_nss(k)) - endif - write (igeom,200) (rad2deg*bvar(1,i,1,k),i=2,nres-1) - write (igeom,200) (rad2deg*bvar(2,i,1,k),i=2,nres-2) - write (igeom,200) (rad2deg*bvar(3,i,1,k),i=2,nres-1) - write (igeom,200) (rad2deg*bvar(4,i,1,k),i=2,nres-1) - enddo - close(icsa_bank) - close(igeom) - - if (nstep/200.gt.ilastnstep) then - - ilastnstep=(ilastnstep+1)*1.5 - write(chfrm,'(a2,i1,a1)') '(i',int(dlog10(dble(nstep))+1),')' - write(chtmp,chfrm) nstep - open(icsa_int,file=prefix(:ilen(prefix)) - & //'_'//chtmp(:ilen(chtmp))//'.int',status='UNKNOWN') - do k=1,nbank - if (bvar_nss(k).le.9) then - write (icsa_int,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k), - & bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,bvar_nss(k)) - else - write (icsa_int,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k), - & bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,9) - write (icsa_int,'(3X,11(1X,2I3))') (bvar_ss(1,i,k), - & bvar_ss(2,i,k),i=10,bvar_nss(k)) - endif - write (icsa_int,200) (rad2deg*bvar(1,i,1,k),i=2,nres-1) - write (icsa_int,200) (rad2deg*bvar(2,i,1,k),i=2,nres-2) - write (icsa_int,200) (rad2deg*bvar(3,i,1,k),i=2,nres-1) - write (icsa_int,200) (rad2deg*bvar(4,i,1,k),i=2,nres-1) - enddo - close(icsa_int) - endif - - - 200 format (8f10.4) - 850 format (10f8.3) - 900 format (1x,"jlee =",i3,3x,"nbank =",i4,3x,"nstep =", - & i8,i10,i2,f15.5) - 902 format (1x,'nglob_csa =',i4,' eglob_csa =',1pe14.5) - 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3, - & ' %NC ',0pf5.2,i5) - - return - end -c--------------------------------------- - subroutine write_bank_reminimized(jlee,nft) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.SBRIDGE' - - open(icsa_bank_reminimized,file=csa_bank_reminimized, - & status="unknown") - write (icsa_bank_reminimized,900) - & jlee,nbank,nstep,nft,icycle,cutdif - open (igeom,file=intname,status='UNKNOWN') - do k=1,nbank - write (icsa_bank_reminimized,952) k,bene(k),brmsn(k), - & bpncn(k),ibank(k) - do j=1,numch - do l=2,nres-1 - write (icsa_bank_reminimized,850) (rad2deg*bvar(i,l,j,k),i=1,4) - enddo - enddo - if (nss.le.9) then - write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k), - & nss,(ihpb(i),jhpb(i),i=1,nss) - else - write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k), - & nss,(ihpb(i),jhpb(i),i=1,9) - write (igeom,'(3X,11(1X,2I3))') (ihpb(i),jhpb(i),i=10,nss) - endif - write (igeom,200) (rad2deg*bvar(1,i,1,k),i=2,nres-1) - write (igeom,200) (rad2deg*bvar(2,i,1,k),i=2,nres-2) - write (igeom,200) (rad2deg*bvar(3,i,1,k),i=2,nres-1) - write (igeom,200) (rad2deg*bvar(4,i,1,k),i=2,nres-1) - enddo - close(icsa_bank_reminimized) - close(igeom) - - 200 format (8f10.4) - 850 format (10f8.3) - 900 format (1x,"jlee =",i3,3x,"nbank =",i4,3x,"nstep =", - & i8,i10,i2,f15.5) - 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3 - & ,' %NC ',0pf5.2,i5) - - return - end -c--------------------------------- - subroutine read_bank(jlee,nft,cutdifr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - character*80 karta - integer ilen - external ilen - - open(icsa_bank,file=csa_bank,status="old") - read (icsa_bank,901) jlee,nbank,nstep,nft,icycle,cutdifr - read (icsa_bank,902) nglob_csa, eglob_csa -c if(jleer.ne.jlee) then -c write (iout,*) 'ERROR in READ_BANK: JLEER',jleer, -c & ' JLEE',jlee -c call mpi_abort(mpi_comm_world,ierror,ierrcode) -c endif - - kk=0 - do k=1,nbank - read (icsa_bank,'(a80)') karta - write(iout,*) "READ_BANK: kk=",kk - write(iout,*) karta -c if (index(karta,"*").gt.0) then -c write (iout,*) "***** Stars in bank ***** k=",k, -c & " skipped" -c do j=1,numch -c do l=2,nres-1 -c read (33,850) (rdummy,i=1,4) -c enddo -c enddo -c else - kk=kk+1 - call reada(karta,"total E",bene(kk),1.0d20) - call reada(karta,"rmsd from N",brmsn(kk),0.0d0) - call reada(karta,"%NC",bpncn(kk),0.0d0) - read (karta(ilen(karta)-1:),*,end=111,err=111) ibank(kk) - goto 112 - 111 ibank(kk)=0 - 112 continue - write(iout,*)"total E",bene(kk),"rmsd from N",brmsn(kk), - & "%NC",bpncn(kk),ibank(kk) -c read (icsa_bank,953) kdummy,bene(k),brmsn(k),bpncn(k),ibank(k) - if (vdisulf) then - read (icsa_bank,'(101i4)') - & bvar_nss(kk),((bvar_ss(j,i,kk),j=1,2),i=1,bvar_nss(kk)) - bvar_ns(kk)=ns-2*bvar_nss(kk) - write(iout,*) 'read SSBOND',bvar_nss(kk), - & ((bvar_ss(j,i,kk),j=1,2),i=1,bvar_nss(kk)) -cd write(iout,*) 'read CYS #free ', bvar_ns(kk) - l=0 - do i=1,ns - j=1 - do while( iss(i).ne.bvar_ss(1,j,kk)-nres .and. - & iss(i).ne.bvar_ss(2,j,kk)-nres .and. - & j.le.bvar_nss(kk)) - j=j+1 - enddo - if (j.gt.bvar_nss(kk)) then - l=l+1 - bvar_s(l,kk)=iss(i) - endif - enddo -cd write(iout,*)'read CYS free',(bvar_s(l,kk),l=1,bvar_ns(kk)) - endif - do j=1,numch - do l=2,nres-1 - read (icsa_bank,850) (bvar(i,l,j,kk),i=1,4) -c write (iout,850) (bvar(i,l,j,kk),i=1,4) - do i=1,4 - bvar(i,l,j,kk)=deg2rad*bvar(i,l,j,kk) - enddo ! l - enddo ! l - enddo ! j -c endif - enddo ! k - - if (kk.lt.nbank) nbank=kk -cd write (*,*) "read_bank ******************* kk",kk, -cd & "nbank",nbank -cd do kk=1,nbank -cd print *,"kk=",kk -cd do j=1,numch -cd do l=2,nres-1 -cd write (*,850) (bvar(i,l,j,kk),i=1,4) -cd enddo -cd enddo -cd enddo - -c do k=1,nbank -c read (33,953) kdummy,bene(k),brmsn(k),bpncn(k),ibank(k) -c do j=1,numch -c do l=2,nres-1 -c read (33,850) (bvar(i,l,j,k),i=1,4) -c do i=1,4 -c bvar(i,l,j,k)=deg2rad*bvar(i,l,j,k) -c enddo -c enddo -c enddo -c enddo - close(icsa_bank) - - 850 format (10f8.3) - 952 format (1x,'#',i4,' total E ',f12.3,' rmsd from N ',f8.3,i5) - 901 format (1x,6x,i3,3x,7x,i4,3x,7x,i8,i10,i2,f15.5) - 902 format (1x,11x,i4,12x,1pe14.5) - 953 format (1x,1x,i4,9x,f12.3,13x,f8.3,5x,f5.2,i5) - - return - end -c--------------------------------------- - subroutine write_bank1(jlee) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - -#if defined(AIX) || defined(PGI) - open(icsa_bank1,file=csa_bank1,position="append") -#else - open(icsa_bank1,file=csa_bank1,access="append") -#endif - write (icsa_bank1,900) jlee,nbank,nstep,cutdif - do k=1,nbank - write (icsa_bank1,952) k,bene(k),brmsn(k),bpncn(k),ibank(k) - do j=1,numch - do l=2,nres-1 - write (icsa_bank1,850) (rad2deg*bvar(i,l,j,k),i=1,4) - enddo - enddo - enddo - close(icsa_bank1) - 850 format (10f8.3) - 900 format (4x,"jlee =",i5,3x,"nbank =",i5,3x,"nstep =",i10,f15.5) - 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3 - & ,' %NC ',0pf5.2,i5) - - return - end -c--------------------------------- - subroutine save_is(ind) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - - index=nbank+ind -c print *, "nbank,ind,index,is(ind) ",nbank,ind,index,is(ind) - if (index.gt.mxio .or. index.lt.1 .or. - & is(ind).gt.mxio .or. is(ind).lt.1) then - write (iout,*) 'Dimension ERROR in SAVE_IS: INDEX',index, - & ' IND',ind,' IS',is(ind) - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - bvar(i,j,k,index)=bvar(i,j,k,is(ind)) - enddo - enddo - enddo - bene(index)=bene(is(ind)) - ibank(is(ind))=1 - - return - end -c--------------------------------- - subroutine select_is(n,ifar,idum) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - dimension itag(mxio),adiff(mxio) - - iuse=0 - do i=1,nbank - if(ibank(i).eq.0) then - iuse=iuse+1 - itag(iuse)=i - endif - enddo - iusesv=iuse - - if(iuse.eq.0) then - icycle=icycle+1 - do i=1,nbank - if(ibank(i).eq.2) then - ibank(i)=1 - else - ibank(i)=0 - endif - enddo - imade=0 - call get_is(idum,ifar,n,imade,0) -ctest3 call get_is_max(idum,ifar,n,imade,0) - else if(iuse.eq.n) then - do i=1,iuse - is(i)=itag(i) - call save_is(i) - enddo - else if(iuse.lt.n) then -c if(icycle.eq.0) then -c do i=1,n -c ind=mod(i-1,iuse)+1 -c is(i)=itag(ind) -c call save_is(i) -c enddo -c else -c endif - do i=1,iuse - is(i)=itag(i) - call save_is(i) - enddo - imade=iuse -c call get_is_ran(idum,n,imade,1) - call get_is(idum,ifar,n,imade,1) -ctest3 call get_is_max(idum,ifar,n,imade,1) -c if(iusesv.le.n/10) then - if(iusesv.le.0) then - icycle=icycle+1 - do i=1,nbank -c if(ibank(i).eq.2) then -c ibank(i)=1 - if(ibank(i).ge.2) then - ibank(i)=ibank(i)-1 - else - ibank(i)=0 - endif - enddo - endif - else - imade=0 - call get_is(idum,ifar,n,imade,0) -ctest3 call get_is_max(idum,ifar,n,imade,0) - endif - iuse=iusesv - - return - end -c--------------------------------- - subroutine get_is_ran(idum,n,imade,k) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - real ran1,ran2 - dimension itag(mxio),adiff(mxio) - - do j=imade+1,n - iuse=0 - do i=1,nbank - if(ibank(i).eq.k) then - iuse=iuse+1 - itag(iuse)=i - endif - enddo - iran=iuse* ran1(idum)+1 - is(j)=itag(iran) - call save_is(j) - enddo - - return - end -c--------------------------------- - subroutine get_is(idum,ifar,n,imade,k) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - real ran1,ran2 - dimension itag(mxio),adiff(mxio) - - iuse=0 - do i=1,nbank - if(ibank(i).eq.k) then - iuse=iuse+1 - itag(iuse)=i - endif - enddo - iran=iuse* ran1(idum)+1 - imade=imade+1 - is(imade)=itag(iran) - call save_is(imade) - - do i=imade+1,ifar-1 - if(icycle.eq.-1) then - call select_iseed_max(i,k) - else - call select_iseed_min(i,k) -ctest4 call select_iseed_max(i,k) - endif - call save_is(i) - enddo - - do i=ifar,n - call select_iseed_far(i,k) - call save_is(i) - enddo - - return - end -c--------------------------------- - subroutine select_iseed_max(imade1,ik) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - dimension itag(mxio),adiff(mxio) - - iuse=0 - avedif=0.d0 - difmax=0.d0 - do n=1,nbank - if(ibank(n).eq.ik) then - iuse=iuse+1 - diffmn=9.d190 - do imade=1,imade1-1 -c m=nbank+imade -c call get_diff12(bvar(1,1,1,n),bvar(1,1,1,m),diff,idiff) - m=is(imade) - diff=dij(n,m) - if(diff.lt.diffmn) diffmn=diff - enddo - if(diffmn.gt.difmax) difmax=diffmn - adiff(iuse)=diffmn - itag(iuse)=n - avedif=avedif+diffmn - endif - enddo - - avedif=avedif/iuse -c avedif=(avedif+difmax)/2 - emax=-9.d190 - do i=1,iuse - if(adiff(i).ge.avedif) then - itagi=itag(i) - benei=bene(itagi) - if(benei.gt.emax) then - emax=benei - is(imade1)=itagi - endif - endif - enddo - - if(ik.eq.0) iuse=iuse-1 - - return - end -c--------------------------------- - subroutine select_iseed_min(imade1,ik) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - dimension itag(mxio),adiff(mxio) - - iuse=0 - avedif=0.d0 - difmax=0.d0 - do n=1,nbank - if(ibank(n).eq.ik) then - iuse=iuse+1 - diffmn=9.d190 - do imade=1,imade1-1 -c m=nbank+imade -c call get_diff12(bvar(1,1,1,n),bvar(1,1,1,m),diff,idiff) - m=is(imade) - diff=dij(n,m) - if(diff.lt.diffmn) diffmn=diff - enddo - if(diffmn.gt.difmax) difmax=diffmn - adiff(iuse)=diffmn - itag(iuse)=n - avedif=avedif+diffmn - endif - enddo - - avedif=avedif/iuse -c avedif=(avedif+difmax)/2 - emin=9.d190 - do i=1,iuse -c print *,"i, adiff(i),avedif : ",i,adiff(i),avedif - if(adiff(i).ge.avedif) then - itagi=itag(i) - benei=bene(itagi) -c print *,"i, benei,emin : ",i,benei,emin - if(benei.lt.emin) then - emin=benei - is(imade1)=itagi - endif - endif - enddo - - if(ik.eq.0) iuse=iuse-1 - -c print *, "exiting select_iseed_min",is(imade1) - - return - end -c--------------------------------- - subroutine select_iseed_far(imade1,ik) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - - dmax=-9.d190 - do n=1,nbank - if(ibank(n).eq.ik) then - diffmn=9.d190 - do imade=1,imade1-1 -c m=nbank+imade -c call get_diff12(bvar(1,1,1,n),bvar(1,1,1,m),diff,idiff) - m=is(imade) - diff=dij(n,m) - if(diff.lt.diffmn) diffmn=diff - enddo - endif - if(diffmn.gt.dmax) then - dmax=diffmn - is(imade1)=n - endif - enddo - - return - end -c--------------------------------- - subroutine find_min - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - - ebmin=9.d190 - - do i=1,nbank - benei=bene(i) - if(benei.lt.ebmin) then - ebmin=benei - ibmin=i - endif - enddo - - return - end -c--------------------------------- - subroutine write_csa_pdb(var,ene,nft,ik,iw_pdb) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.MINIM' - include 'COMMON.SETUP' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.SBRIDGE' - integer lenpre,lenpot,ilen - external ilen - dimension var(maxvar) - character*50 titelloc - character*3 zahl - - nmin_csa=nmin_csa+1 - if(ene.lt.eglob_csa) then - eglob_csa=ene - nglob_csa=nglob_csa+1 - call numstr(nglob_csa,zahl) - - call var_to_geom(nvar,var) - call chainbuild - call secondary2(.false.) - - lenpre=ilen(prefix) - open(icsa_pdb,file=prefix(:lenpre)//'@'//zahl//'.pdb') - - if (iw_pdb.eq.1) then - write(titelloc,'(a2,i3,a3,i9,a3,i6)') - & 'GM',nglob_csa,' e ',nft,' m ',nmin_csa - else - write(titelloc,'(a2,i3,a3,i9,a3,i6,a5,f5.2,a5,f5.1)') - & 'GM',nglob_csa,' e ',nft,' m ',nmin_csa,' rms ' - & ,rmsn(ik),' %NC ',pncn(ik)*100 - endif - call pdbout(eglob_csa,titelloc,icsa_pdb) - close(icsa_pdb) - endif - - return - end -c--------------------------------- - subroutine find_max - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - - ebmax=-9.d190 - - do i=1,nbank - benei=bene(i) - if(benei.gt.ebmax) then - ebmax=benei - ibmax=i - endif - enddo - - return - end -c--------------------------------- - subroutine get_diff - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - - tdiff=0.d0 - difmin=9.d190 - do i1=1,nbank-1 - do i2=i1+1,nbank - if(jbank(i1).eq.0.or.jbank(i2).eq.0) then - call get_diff12(bvar(1,1,1,i1),bvar(1,1,1,i2),diff) - dij(i1,i2)=diff - dij(i2,i1)=diff - else - diff=dij(i1,i2) - endif - tdiff=tdiff+diff - if(diff.lt.difmin) difmin=diff - enddo - dij(i1,i1)=0.0 - enddo - - do i=1,nbank - jbank(i)=1 - enddo - - avedif=tdiff/nbank/(nbank-1)*2 - - return - end -c--------------------------------- - subroutine estimate_cutdif(adif,xct,cutdifr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - - ctdif1=adif/cut2 - - exponent = cutdifr*cut1/adif - exponent = dlog(exponent)/dlog(xct) - - nexp=exponent+0.25 - cutdif= adif/cut1*xct**nexp - if(cutdif.lt.ctdif1) cutdif=ctdif1 - - return - end -c--------------------------------- - subroutine get_is_max(idum,ifar,n,imade,k) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - double precision emax - - do i=imade+1,n - emax=-9.d190 - do j=1,nbank - if(ibank(j).eq.k .and. bene(j).gt.emax) then - emax=bene(j) - is(i)=j - endif - enddo - call save_is(i) - enddo - - return - end diff --git a/source/unres/src_MD-M-newcorr/big-sizes b/source/unres/src_MD-M-newcorr/big-sizes deleted file mode 100644 index 0a40187..0000000 --- a/source/unres/src_MD-M-newcorr/big-sizes +++ /dev/null @@ -1,9 +0,0 @@ -contacts_hb_ 0x4e483c0 unres.o -contdistrib_ 0x2c0944c unres.o -derivat_ 0x436dbe8 initialize_p.o -dipmat_ 0xafc8000 unres.o -lagrange_ 0x1085e2b8 unres.o -langforc_ 0x26782534 readrtns_CSA.o -langmat_ 0x83d6000 readrtns_CSA.o -links_ 0x107035c unres.o -przechowalnia_ 0x7080000 MREMD.o diff --git a/source/unres/src_MD-M-newcorr/bigsymbols-lang0.txt b/source/unres/src_MD-M-newcorr/bigsymbols-lang0.txt deleted file mode 100644 index 54c4d37..0000000 --- a/source/unres/src_MD-M-newcorr/bigsymbols-lang0.txt +++ /dev/null @@ -1,7 +0,0 @@ -contacts_hb_ 0x4e483c0 unres.o -contdistrib_ 0x2c0944c unres.o -dipmat_ 0xafc8000 unres.o -lagrange_ 0x1085e2b8 unres.o -langforc_ 0x582a594 readrtns_CSA.o -links_ 0x107035c unres.o -przechowalnia_ 0x7080000 MREMD.o diff --git a/source/unres/src_MD-M-newcorr/blas.f b/source/unres/src_MD-M-newcorr/blas.f deleted file mode 100644 index 142d821..0000000 --- a/source/unres/src_MD-M-newcorr/blas.f +++ /dev/null @@ -1,575 +0,0 @@ -C 10 NOV 94 - MWS - DNRM2: REMOVE FTNCHECK WARNINGS -C 11 JUN 94 - MWS - INCLUDE A COPY OF DGEMV (LEVEL TWO ROUTINE) -C 11 AUG 87 - MWS - SANITIZE FLOATING POINT CONSTANTS IN DNRM2 -C 26 MAR 87 - MWS - USE GENERIC SIGN IN DROTG -C 28 NOV 86 - STE - SUPPLY ALL LEVEL ONE BLAS -C 7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS -C -C BASIC LINEAR ALGEBRA SUBPROGRAMS (BLAS) FROM LINPACK (LEVEL 1) -C -C THIS MODULE SHOULD BE COMPILED ONLY IF SPECIALLY CODED -C VERSIONS OF THESE ROUTINES ARE NOT AVAILABLE ON THE TARGET MACHINE -C -C*MODULE BLAS1 *DECK DASUM - DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -C -C TAKES THE SUM OF THE ABSOLUTE VALUES. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DX(1),DTEMP - INTEGER I,INCX,M,MP1,N,NINCX -C - DASUM = 0.0D+00 - DTEMP = 0.0D+00 - IF(N.LE.0)RETURN - IF(INCX.EQ.1)GO TO 20 -C -C CODE FOR INCREMENT NOT EQUAL TO 1 -C - NINCX = N*INCX - DO 10 I = 1,NINCX,INCX - DTEMP = DTEMP + ABS(DX(I)) - 10 CONTINUE - DASUM = DTEMP - RETURN -C -C CODE FOR INCREMENT EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,6) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP = DTEMP + ABS(DX(I)) - 30 CONTINUE - IF( N .LT. 6 ) GO TO 60 - 40 MP1 = M + 1 - DO 50 I = MP1,N,6 - DTEMP = DTEMP + ABS(DX(I)) + ABS(DX(I + 1)) + ABS(DX(I + 2)) - * + ABS(DX(I + 3)) + ABS(DX(I + 4)) + ABS(DX(I + 5)) - 50 CONTINUE - 60 DASUM = DTEMP - RETURN - END -C*MODULE BLAS1 *DECK DAXPY - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(1),DY(1) -C -C CONSTANT TIMES A VECTOR PLUS A VECTOR. -C DY(I) = DY(I) + DA * DX(I) -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - IF(N.LE.0)RETURN - IF (DA .EQ. 0.0D+00) RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,4) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DY(I) = DY(I) + DA*DX(I) - 30 CONTINUE - IF( N .LT. 4 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I + 1) = DY(I + 1) + DA*DX(I + 1) - DY(I + 2) = DY(I + 2) + DA*DX(I + 2) - DY(I + 3) = DY(I + 3) + DA*DX(I + 3) - 50 CONTINUE - RETURN - END -C*MODULE BLAS1 *DECK DCOPY - SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(*),DY(*) -C -C COPIES A VECTOR. -C DY(I) <== DX(I) -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DY(IY) = DX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,7) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DY(I) = DX(I) - 30 CONTINUE - IF( N .LT. 7 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,7 - DY(I) = DX(I) - DY(I + 1) = DX(I + 1) - DY(I + 2) = DX(I + 2) - DY(I + 3) = DX(I + 3) - DY(I + 4) = DX(I + 4) - DY(I + 5) = DX(I + 5) - DY(I + 6) = DX(I + 6) - 50 CONTINUE - RETURN - END -C*MODULE BLAS1 *DECK DDOT - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(1),DY(1) -C -C FORMS THE DOT PRODUCT OF TWO VECTORS. -C DOT = DX(I) * DY(I) -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DDOT = 0.0D+00 - DTEMP = 0.0D+00 - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP = DTEMP + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - DDOT = DTEMP - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP = DTEMP + DX(I)*DY(I) - 30 CONTINUE - IF( N .LT. 5 ) GO TO 60 - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + - * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) - 50 CONTINUE - 60 DDOT = DTEMP - RETURN - END -C*MODULE BLAS1 *DECK DNRM2 - DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) - INTEGER NEXT - DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE - DATA ZERO, ONE /0.0D+00, 1.0D+00/ -C -C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE -C INCREMENT INCX . -C IF N .LE. 0 RETURN WITH RESULT = 0. -C IF N .GE. 1 THEN INCX MUST BE .GE. 1 -C -C C.L.LAWSON, 1978 JAN 08 -C -C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE -C HOPEFULLY APPLICABLE TO ALL MACHINES. -C CUTLO = MAXIMUM OF SQRT(U/EPS) OVER ALL KNOWN MACHINES. -C CUTHI = MINIMUM OF SQRT(V) OVER ALL KNOWN MACHINES. -C WHERE -C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. -C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) -C V = LARGEST NO. (OVERFLOW LIMIT) -C -C BRIEF OUTLINE OF ALGORITHM.. -C -C PHASE 1 SCANS ZERO COMPONENTS. -C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO -C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO -C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M -C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. -C -C VALUES FOR CUTLO AND CUTHI.. -C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER -C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. -C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE -C UNIVAC AND DEC AT 2**(-103) -C THUS CUTLO = 2**(-51) = 4.44089E-16 -C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. -C THUS CUTHI = 2**(63.5) = 1.30438E19 -C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. -C THUS CUTLO = 2**(-33.5) = 8.23181D-11 -C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D+19 -C DATA CUTLO, CUTHI / 8.232D-11, 1.304D+19 / -C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / - DATA CUTLO, CUTHI / 8.232D-11, 1.304D+19 / -C - J=0 - IF(N .GT. 0) GO TO 10 - DNRM2 = ZERO - GO TO 300 -C - 10 ASSIGN 30 TO NEXT - SUM = ZERO - NN = N * INCX -C BEGIN MAIN LOOP - I = 1 - 20 GO TO NEXT,(30, 50, 70, 110) - 30 IF( ABS(DX(I)) .GT. CUTLO) GO TO 85 - ASSIGN 50 TO NEXT - XMAX = ZERO -C -C PHASE 1. SUM IS ZERO -C - 50 IF( DX(I) .EQ. ZERO) GO TO 200 - IF( ABS(DX(I)) .GT. CUTLO) GO TO 85 -C -C PREPARE FOR PHASE 2. - ASSIGN 70 TO NEXT - GO TO 105 -C -C PREPARE FOR PHASE 4. -C - 100 I = J - ASSIGN 110 TO NEXT - SUM = (SUM / DX(I)) / DX(I) - 105 XMAX = ABS(DX(I)) - GO TO 115 -C -C PHASE 2. SUM IS SMALL. -C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. -C - 70 IF( ABS(DX(I)) .GT. CUTLO ) GO TO 75 -C -C COMMON CODE FOR PHASES 2 AND 4. -C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. -C - 110 IF( ABS(DX(I)) .LE. XMAX ) GO TO 115 - SUM = ONE + SUM * (XMAX / DX(I))**2 - XMAX = ABS(DX(I)) - GO TO 200 -C - 115 SUM = SUM + (DX(I)/XMAX)**2 - GO TO 200 -C -C -C PREPARE FOR PHASE 3. -C - 75 SUM = (SUM * XMAX) * XMAX -C -C -C FOR REAL OR D.P. SET HITEST = CUTHI/N -C FOR COMPLEX SET HITEST = CUTHI/(2*N) -C - 85 HITEST = CUTHI/N -C -C PHASE 3. SUM IS MID-RANGE. NO SCALING. -C - DO 95 J =I,NN,INCX - IF(ABS(DX(J)) .GE. HITEST) GO TO 100 - 95 SUM = SUM + DX(J)**2 - DNRM2 = SQRT( SUM ) - GO TO 300 -C - 200 CONTINUE - I = I + INCX - IF ( I .LE. NN ) GO TO 20 -C -C END OF MAIN LOOP. -C -C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. -C - DNRM2 = XMAX * SQRT(SUM) - 300 CONTINUE - RETURN - END -C*MODULE BLAS1 *DECK DROT - SUBROUTINE DROT (N,DX,INCX,DY,INCY,C,S) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(1),DY(1) -C -C APPLIES A PLANE ROTATION. -C DX(I) = C*DX(I) + S*DY(I) -C DY(I) = -S*DX(I) + C*DY(I) -C JACK DONGARRA, LINPACK, 3/11/78. -C - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL -C TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP = C*DX(IX) + S*DY(IY) - DY(IY) = C*DY(IY) - S*DX(IX) - DX(IX) = DTEMP - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C - 20 DO 30 I = 1,N - DTEMP = C*DX(I) + S*DY(I) - DY(I) = C*DY(I) - S*DX(I) - DX(I) = DTEMP - 30 CONTINUE - RETURN - END -C*MODULE BLAS1 *DECK DROTG - SUBROUTINE DROTG(DA,DB,C,S) -C -C CONSTRUCT GIVENS PLANE ROTATION. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DA,DB,C,S,ROE,SCALE,R,Z - DOUBLE PRECISION ZERO, ONE -C - PARAMETER (ZERO=0.0D+00, ONE=1.0D+00) -C -C----------------------------------------------------------------------- -C -C - ROE = DB - IF( ABS(DA) .GT. ABS(DB) ) ROE = DA - SCALE = ABS(DA) + ABS(DB) - IF( SCALE .NE. ZERO ) GO TO 10 - C = ONE - S = ZERO - R = ZERO - GO TO 20 -C - 10 R = SCALE*SQRT((DA/SCALE)**2 + (DB/SCALE)**2) - R = SIGN(ONE,ROE)*R - C = DA/R - S = DB/R - 20 Z = ONE - IF( ABS(DA) .GT. ABS(DB) ) Z = S - IF( ABS(DB) .GE. ABS(DA) .AND. C .NE. ZERO ) Z = ONE/C - DA = R - DB = Z - RETURN - END -C*MODULE BLAS1 *DECK DSCAL - SUBROUTINE DSCAL(N,DA,DX,INCX) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(1) -C -C SCALES A VECTOR BY A CONSTANT. -C DX(I) = DA * DX(I) -C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - IF(N.LE.0)RETURN - IF(INCX.EQ.1)GO TO 20 -C -C CODE FOR INCREMENT NOT EQUAL TO 1 -C - NINCX = N*INCX - DO 10 I = 1,NINCX,INCX - DX(I) = DA*DX(I) - 10 CONTINUE - RETURN -C -C CODE FOR INCREMENT EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DX(I) = DA*DX(I) - 30 CONTINUE - IF( N .LT. 5 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I + 1) = DA*DX(I + 1) - DX(I + 2) = DA*DX(I + 2) - DX(I + 3) = DA*DX(I + 3) - DX(I + 4) = DA*DX(I + 4) - 50 CONTINUE - RETURN - END -C*MODULE BLAS1 *DECK DSWAP - SUBROUTINE DSWAP (N,DX,INCX,DY,INCY) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(1),DY(1) -C -C INTERCHANGES TWO VECTORS. -C DX(I) <==> DY(I) -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL -C TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP = DX(IX) - DX(IX) = DY(IY) - DY(IY) = DTEMP - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,3) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - 30 CONTINUE - IF( N .LT. 3 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,3 - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - DTEMP = DX(I + 1) - DX(I + 1) = DY(I + 1) - DY(I + 1) = DTEMP - DTEMP = DX(I + 2) - DX(I + 2) = DY(I + 2) - DY(I + 2) = DTEMP - 50 CONTINUE - RETURN - END -C*MODULE BLAS1 *DECK IDAMAX - INTEGER FUNCTION IDAMAX(N,DX,INCX) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(1) -C -C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - IDAMAX = 0 - IF( N .LT. 1 ) RETURN - IDAMAX = 1 - IF(N.EQ.1)RETURN - IF(INCX.EQ.1)GO TO 20 -C -C CODE FOR INCREMENT NOT EQUAL TO 1 -C - IX = 1 - RMAX = ABS(DX(1)) - IX = IX + INCX - DO 10 I = 2,N - IF(ABS(DX(IX)).LE.RMAX) GO TO 5 - IDAMAX = I - RMAX = ABS(DX(IX)) - 5 IX = IX + INCX - 10 CONTINUE - RETURN -C -C CODE FOR INCREMENT EQUAL TO 1 -C - 20 RMAX = ABS(DX(1)) - DO 30 I = 2,N - IF(ABS(DX(I)).LE.RMAX) GO TO 30 - IDAMAX = I - RMAX = ABS(DX(I)) - 30 CONTINUE - RETURN - END -C*MODULE BLAS *DECK DGEMV - SUBROUTINE DGEMV(FORMA,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - CHARACTER*1 FORMA - DIMENSION A(LDA,*),X(*),Y(*) - PARAMETER (ZERO=0.0D+00, ONE=1.0D+00) -C -C CLONE OF -DGEMV- WRITTEN BY MIKE SCHMIDT -C - LOCY = 1 - IF(FORMA.EQ.'T') GO TO 200 -C -C Y = ALPHA * A * X + BETA * Y -C - IF(ALPHA.EQ.ONE .AND. BETA.EQ.ZERO) THEN - DO 110 I=1,M - Y(LOCY) = DDOT(N,A(I,1),LDA,X,INCX) - LOCY = LOCY+INCY - 110 CONTINUE - ELSE - DO 120 I=1,M - Y(LOCY) = ALPHA*DDOT(N,A(I,1),LDA,X,INCX) + BETA*Y(LOCY) - LOCY = LOCY+INCY - 120 CONTINUE - END IF - RETURN -C -C Y = ALPHA * A-TRANSPOSE * X + BETA * Y -C - 200 CONTINUE - IF(ALPHA.EQ.ONE .AND. BETA.EQ.ZERO) THEN - DO 210 I=1,N - Y(LOCY) = DDOT(M,A(1,I),1,X,INCX) - LOCY = LOCY+INCY - 210 CONTINUE - ELSE - DO 220 I=1,N - Y(LOCY) = ALPHA*DDOT(M,A(1,I),1,X,INCX) + BETA*Y(LOCY) - LOCY = LOCY+INCY - 220 CONTINUE - END IF - RETURN - END diff --git a/source/unres/src_MD-M-newcorr/bond_move.f b/source/unres/src_MD-M-newcorr/bond_move.f deleted file mode 100644 index 4843f60..0000000 --- a/source/unres/src_MD-M-newcorr/bond_move.f +++ /dev/null @@ -1,124 +0,0 @@ - subroutine bond_move(nbond,nstart,psi,lprint,error) -C Move NBOND fragment starting from the CA(nstart) by angle PSI. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - integer nbond,nstart - double precision psi - logical fail,error,lprint - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.MCM' - dimension x(3),e(3,3),e1(3),e2(3),e3(3),rot(3,3),trans(3,3) - error=.false. - nend=nstart+nbond - if (print_mc.gt.2) then - write (iout,*) 'nstart=',nstart,' nend=',nend,' nbond=',nbond - write (iout,*) 'psi=',psi - write (iout,'(a)') 'Original coordinates of the fragment' - do i=nstart,nend - write (iout,'(i5,3f10.5)') i,(c(j,i),j=1,3) - enddo - endif - if (nstart.lt.1 .or. nend .gt.nres .or. nbond.lt.2 .or. - & nbond.ge.nres-1) then - write (iout,'(a)') 'Bad data in BOND_MOVE.' - error=.true. - return - endif -C Generate the reference system. - i2=nend - i3=nstart - i4=nstart+1 - call refsys(i2,i3,i4,e1,e2,e3,error) -C Return, if couldn't define the reference system. - if (error) return -C Compute the transformation matrix. - cospsi=dcos(psi) - sinpsi=dsin(psi) - rot(1,1)=1.0D0 - rot(1,2)=0.0D0 - rot(1,3)=0.0D0 - rot(2,1)=0.0D0 - rot(2,2)=cospsi - rot(2,3)=-sinpsi - rot(3,1)=0.0D0 - rot(3,2)=sinpsi - rot(3,3)=cospsi - do i=1,3 - e(1,i)=e1(i) - e(2,i)=e2(i) - e(3,i)=e3(i) - enddo - - if (print_mc.gt.2) then - write (iout,'(a)') 'Reference system and matrix r:' - do i=1,3 - write(iout,'(i5,2(3f10.5,5x))')i,(e(i,j),j=1,3),(rot(i,j),j=1,3) - enddo - endif - - call matmult(rot,e,trans) - do i=1,3 - do j=1,3 - e(i,1)=e1(i) - e(i,2)=e2(i) - e(i,3)=e3(i) - enddo - enddo - call matmult(e,trans,trans) - - if (lprint) then - write (iout,'(a)') 'The trans matrix:' - do i=1,3 - write (iout,'(i5,3f10.5)') i,(trans(i,j),j=1,3) - enddo - endif - - do i=nstart,nend - do j=1,3 - rij=c(j,nstart) - do k=1,3 - rij=rij+trans(j,k)*(c(k,i)-c(k,nstart)) - enddo - x(j)=rij - enddo - do j=1,3 - c(j,i)=x(j) - enddo - enddo - - if (lprint) then - write (iout,'(a)') 'Rotated coordinates of the fragment' - do i=nstart,nend - write (iout,'(i5,3f10.5)') i,(c(j,i),j=1,3) - enddo - endif - -c call int_from_cart(.false.,lprint) - if (nstart.gt.1) then - theta(nstart+1)=alpha(nstart-1,nstart,nstart+1) - phi(nstart+2)=beta(nstart-1,nstart,nstart+1,nstart+2) - if (nstart.gt.2) phi(nstart+1)= - & beta(nstart-2,nstart-1,nstart,nstart+1) - endif - if (nend.lt.nres) then - theta(nend+1)=alpha(nend-1,nend,nend+1) - phi(nend+1)=beta(nend-2,nend-1,nend,nend+1) - if (nend.lt.nres-1) phi(nend+2)= - & beta(nend-1,nend,nend+1,nend+2) - endif - if (print_mc.gt.2) then - write (iout,'(/a,i3,a,i3,a/)') - & 'Moved internal coordinates of the ',nstart,'-',nend, - & ' fragment:' - do i=nstart+1,nstart+2 - write (iout,'(i5,2f10.5)') i,rad2deg*theta(i),rad2deg*phi(i) - enddo - do i=nend+1,nend+2 - write (iout,'(i5,2f10.5)') i,rad2deg*theta(i),rad2deg*phi(i) - enddo - endif - return - end diff --git a/source/unres/src_MD-M-newcorr/brown_step.F b/source/unres/src_MD-M-newcorr/brown_step.F deleted file mode 100644 index 0be97f5..0000000 --- a/source/unres/src_MD-M-newcorr/brown_step.F +++ /dev/null @@ -1,395 +0,0 @@ -c------------------------------------------------------------------------------- - subroutine brown_step(itime) -c------------------------------------------------ -c Perform a single Euler integration step of Brownian dynamics -c------------------------------------------------ - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision zapas(MAXRES6) - integer ilen,rstcount - external ilen - double precision stochforcvec(MAXRES6) - double precision Bmat(MAXRES6,MAXRES2),Cmat(maxres2,maxres2), - & Cinv(maxres2,maxres2),GBmat(MAXRES6,MAXRES2), - & Tmat(MAXRES6,MAXRES2),Pmat(maxres6,maxres6),Td(maxres6), - & ppvec(maxres2) - common /stochcalc/ stochforcvec - common /gucio/ cm - integer itime - logical lprn /.false./,lprn1 /.false./ - integer maxiter /5/ - double precision difftol /1.0d-5/ - nbond=nct-nnt - do i=nnt,nct - if (itype(i).ne.10) nbond=nbond+1 - enddo -c - if (lprn1) then - write (iout,*) "Generalized inverse of fricmat" - call matout(dimen,dimen,MAXRES6,MAXRES6,fricmat) - endif - do i=1,dimen - do j=1,nbond - Bmat(i,j)=0.0d0 - enddo - enddo - ind=3 - ind1=0 - do i=nnt,nct-1 - ind1=ind1+1 - do j=1,3 - Bmat(ind+j,ind1)=dC_norm(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind1=ind1+1 - do j=1,3 - Bmat(ind+j,ind1)=dC_norm(j,i+nres) - enddo - ind=ind+3 - endif - enddo - if (lprn1) then - write (iout,*) "Matrix Bmat" - call MATOUT(nbond,dimen,MAXRES6,MAXRES2,Bmat) - endif - do i=1,dimen - do j=1,nbond - GBmat(i,j)=0.0d0 - do k=1,dimen - GBmat(i,j)=GBmat(i,j)+fricmat(i,k)*Bmat(k,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix GBmat" - call MATOUT(nbond,dimen,MAXRES6,MAXRES2,Gbmat) - endif - do i=1,nbond - do j=1,nbond - Cmat(i,j)=0.0d0 - do k=1,dimen - Cmat(i,j)=Cmat(i,j)+Bmat(k,i)*GBmat(k,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Cmat" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) - endif - call matinvert(nbond,MAXRES2,Cmat,Cinv) - if (lprn1) then - write (iout,*) "Matrix Cinv" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cinv) - endif - do i=1,dimen - do j=1,nbond - Tmat(i,j)=0.0d0 - do k=1,nbond - Tmat(i,j)=Tmat(i,j)+GBmat(i,k)*Cinv(k,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Tmat" - call MATOUT(nbond,dimen,MAXRES6,MAXRES2,Tmat) - endif - do i=1,dimen - do j=1,dimen - if (i.eq.j) then - Pmat(i,j)=1.0d0 - else - Pmat(i,j)=0.0d0 - endif - do k=1,nbond - Pmat(i,j)=Pmat(i,j)-Tmat(i,k)*Bmat(j,k) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Pmat" - call MATOUT(dimen,dimen,MAXRES6,MAXRES6,Pmat) - endif - do i=1,dimen - Td(i)=0.0d0 - ind=0 - do k=nnt,nct-1 - ind=ind+1 - Td(i)=Td(i)+vbl*Tmat(i,ind) - enddo - do k=nnt,nct - if (itype(k).ne.10) then - ind=ind+1 - Td(i)=Td(i)+vbldsc0(1,itype(k))*Tmat(i,ind) - endif - enddo - enddo - if (lprn1) then - write (iout,*) "Vector Td" - do i=1,dimen - write (iout,'(i5,f10.5)') i,Td(i) - enddo - endif - call stochastic_force(stochforcvec) - if (lprn) then - write (iout,*) "stochforcvec" - do i=1,dimen - write (iout,*) i,stochforcvec(i) - enddo - endif - do j=1,3 - zapas(j)=-gcart(j,0)+stochforcvec(j) - d_t_work(j)=d_t(j,0) - dC_work(j)=dC_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - zapas(ind)=-gcart(j,i)+stochforcvec(ind) - dC_work(ind)=dC_old(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - ind=ind+1 - zapas(ind)=-gxcart(j,i)+stochforcvec(ind) - dC_work(ind)=dC_old(j,i+nres) - enddo - endif - enddo - - if (lprn) then - write (iout,*) "Initial d_t_work" - do i=1,dimen - write (iout,*) i,d_t_work(i) - enddo - endif - - do i=1,dimen - d_t_work(i)=0.0d0 - do j=1,dimen - d_t_work(i)=d_t_work(i)+fricmat(i,j)*zapas(j) - enddo - enddo - - do i=1,dimen - zapas(i)=Td(i) - do j=1,dimen - zapas(i)=zapas(i)+Pmat(i,j)*(dC_work(j)+d_t_work(j)*d_time) - enddo - enddo - if (lprn1) then - write (iout,*) "Final d_t_work and zapas" - do i=1,dimen - write (iout,*) i,d_t_work(i),zapas(i) - enddo - endif - - do j=1,3 - d_t(j,0)=d_t_work(j) - dc(j,0)=zapas(j) - dc_work(j)=dc(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(i) - dc(j,i)=zapas(ind+j) - dc_work(ind+j)=dc(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - do j=1,3 - d_t(j,i+nres)=d_t_work(ind+j) - dc(j,i+nres)=zapas(ind+j) - dc_work(ind+j)=dc(j,i+nres) - enddo - ind=ind+3 - enddo - if (lprn) then - call chainbuild_cart - write (iout,*) "Before correction for rotational lengthening" - write (iout,*) "New coordinates", - & " and differences between actual and standard bond lengths" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - xx=vbld(i+1)-vbl - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i),j=1,3),xx - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - xx=vbld(i+nres)-vbldsc0(1,itype(i)) - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i+nres),j=1,3),xx - endif - enddo - endif -c Second correction (rotational lengthening) -c do iter=1,maxiter - diffmax=0.0d0 - ind=0 - do i=nnt,nct-1 - ind=ind+1 - blen2 = scalar(dc(1,i),dc(1,i)) - ppvec(ind)=2*vbl**2-blen2 - diffbond=dabs(vbl-dsqrt(blen2)) - if (diffbond.gt.diffmax) diffmax=diffbond - if (ppvec(ind).gt.0.0d0) then - ppvec(ind)=dsqrt(ppvec(ind)) - else - ppvec(ind)=0.0d0 - endif - if (lprn) then - write (iout,'(i5,3f10.5)') ind,diffbond,ppvec(ind) - endif - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - blen2 = scalar(dc(1,i+nres),dc(1,i+nres)) - ppvec(ind)=2*vbldsc0(1,itype(i))**2-blen2 - diffbond=dabs(vbldsc0(1,itype(i))-dsqrt(blen2)) - if (diffbond.gt.diffmax) diffmax=diffbond - if (ppvec(ind).gt.0.0d0) then - ppvec(ind)=dsqrt(ppvec(ind)) - else - ppvec(ind)=0.0d0 - endif - if (lprn) then - write (iout,'(i5,3f10.5)') ind,diffbond,ppvec(ind) - endif - endif - enddo - if (lprn) write (iout,*) "iter",iter," diffmax",diffmax - if (diffmax.lt.difftol) goto 10 - do i=1,dimen - Td(i)=0.0d0 - do j=1,nbond - Td(i)=Td(i)+ppvec(j)*Tmat(i,j) - enddo - enddo - do i=1,dimen - zapas(i)=Td(i) - do j=1,dimen - zapas(i)=zapas(i)+Pmat(i,j)*dc_work(j) - enddo - enddo - do j=1,3 - dc(j,0)=zapas(j) - dc_work(j)=zapas(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=zapas(ind+j) - dc_work(ind+j)=zapas(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc(j,i+nres)=zapas(ind+j) - dc_work(ind+j)=zapas(ind+j) - enddo - ind=ind+3 - endif - enddo -c Building the chain from the newly calculated coordinates - call chainbuild_cart - if(ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "Cartesian and internal coordinates: step 1" - call cartprint - call intout - write (iout,'(a)') "Potential forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(-gcart(j,i),j=1,3), - & (-gxcart(j,i),j=1,3) - enddo - write (iout,'(a)') "Stochastic forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(stochforc(j,i),j=1,3), - & (stochforc(j,i+nres),j=1,3) - enddo - write (iout,'(a)') "Velocities" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif - if (lprn) then - write (iout,*) "After correction for rotational lengthening" - write (iout,*) "New coordinates", - & " and differences between actual and standard bond lengths" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - xx=vbld(i+1)-vbl - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i),j=1,3),xx - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - xx=vbld(i+nres)-vbldsc0(1,itype(i)) - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i+nres),j=1,3),xx - endif - enddo - endif -c ENDDO -c write (iout,*) "Too many attempts at correcting the bonds" -c stop - 10 continue -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Calculate energy and forces - call zerograd - call etotal(potEcomp) - potE=potEcomp(0)-potEcomp(20) - call cartgrad - totT=totT+d_time -c Calculate the kinetic and total energy and the kinetic temperature - call kinetic(EK) -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - totE=EK+potE - kinetic_T=2.0d0/(dimen*Rb)*EK - return - end - diff --git a/source/unres/src_MD-M-newcorr/cartder.F b/source/unres/src_MD-M-newcorr/cartder.F deleted file mode 100644 index dd2b3f1..0000000 --- a/source/unres/src_MD-M-newcorr/cartder.F +++ /dev/null @@ -1,314 +0,0 @@ - subroutine cartder -*********************************************************************** -* This subroutine calculates the derivatives of the consecutive virtual -* bond vectors and the SC vectors in the virtual-bond angles theta and -* virtual-torsional angles phi, as well as the derivatives of SC vectors -* in the angles alpha and omega, describing the location of a side chain -* in its local coordinate system. -* -* The derivatives are stored in the following arrays: -* -* DDCDV - the derivatives of virtual-bond vectors DC in theta and phi. -* The structure is as follows: -* -* dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0, 0, 0 -* dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4) -* . . . . . . . . . . . . . . . . . . -* dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4) -* . -* . -* . -* dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N) -* -* DXDV - the derivatives of the side-chain vectors in theta and phi. -* The structure is same as above. -* -* DCDS - the derivatives of the side chain vectors in the local spherical -* andgles alph and omega: -* -* dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2) -* dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3) -* . -* . -* . -* dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1) -* -* Version of March '95, based on an early version of November '91. -* -*********************************************************************** - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - dimension drt(3,3,maxres),rdt(3,3,maxres),dp(3,3),temp(3,3), - & fromto(3,3,maxdim),prordt(3,3,maxres),prodrt(3,3,maxres) - dimension xx(3),xx1(3) - common /przechowalnia/ fromto -* get the position of the jth ijth fragment of the chain coordinate system -* in the fromto array. - indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 -* -* calculate the derivatives of transformation matrix elements in theta -* - do i=1,nres-2 - rdt(1,1,i)=-rt(1,2,i) - rdt(1,2,i)= rt(1,1,i) - rdt(1,3,i)= 0.0d0 - rdt(2,1,i)=-rt(2,2,i) - rdt(2,2,i)= rt(2,1,i) - rdt(2,3,i)= 0.0d0 - rdt(3,1,i)=-rt(3,2,i) - rdt(3,2,i)= rt(3,1,i) - rdt(3,3,i)= 0.0d0 - enddo -* -* derivatives in phi -* - do i=2,nres-2 - drt(1,1,i)= 0.0d0 - drt(1,2,i)= 0.0d0 - drt(1,3,i)= 0.0d0 - drt(2,1,i)= rt(3,1,i) - drt(2,2,i)= rt(3,2,i) - drt(2,3,i)= rt(3,3,i) - drt(3,1,i)=-rt(2,1,i) - drt(3,2,i)=-rt(2,2,i) - drt(3,3,i)=-rt(2,3,i) - enddo -* -* generate the matrix products of type r(i)t(i)...r(j)t(j) -* - do i=2,nres-2 - ind=indmat(i,i+1) - do k=1,3 - do l=1,3 - temp(k,l)=rt(k,l,i) - enddo - enddo - do k=1,3 - do l=1,3 - fromto(k,l,ind)=temp(k,l) - enddo - enddo - do j=i+1,nres-2 - ind=indmat(i,j+1) - do k=1,3 - do l=1,3 - dpkl=0.0d0 - do m=1,3 - dpkl=dpkl+temp(k,m)*rt(m,l,j) - enddo - dp(k,l)=dpkl - fromto(k,l,ind)=dpkl - enddo - enddo - do k=1,3 - do l=1,3 - temp(k,l)=dp(k,l) - enddo - enddo - enddo - enddo -* -* Calculate derivatives. -* - ind1=0 - do i=1,nres-2 - ind1=ind1+1 -* -* Derivatives of DC(i+1) in theta(i+2) -* - do j=1,3 - do k=1,2 - dpjk=0.0D0 - do l=1,3 - dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) - enddo - dp(j,k)=dpjk - prordt(j,k,i)=dp(j,k) - enddo - dp(j,3)=0.0D0 - dcdv(j,ind1)=vbld(i+1)*dp(j,1) - enddo -* -* Derivatives of SC(i+1) in theta(i+2) -* - xx1(1)=-0.5D0*xloc(2,i+1) - xx1(2)= 0.5D0*xloc(1,i+1) - do j=1,3 - xj=0.0D0 - do k=1,2 - xj=xj+r(j,k,i)*xx1(k) - enddo - xx(j)=xj - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i)*xx(k) - enddo - dxdv(j,ind1)=rj - enddo -* -* Derivatives of SC(i+1) in theta(i+3). The have to be handled differently -* than the other off-diagonal derivatives. -* - do j=1,3 - dxoiij=0.0D0 - do k=1,3 - dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) - enddo - dxdv(j,ind1+1)=dxoiij - enddo -cd print *,ind1+1,(dxdv(j,ind1+1),j=1,3) -* -* Derivatives of DC(i+1) in phi(i+2) -* - do j=1,3 - do k=1,3 - dpjk=0.0 - do l=2,3 - dpjk=dpjk+prod(j,l,i)*drt(l,k,i) - enddo - dp(j,k)=dpjk - prodrt(j,k,i)=dp(j,k) - enddo - dcdv(j+3,ind1)=vbld(i+1)*dp(j,1) - enddo -* -* Derivatives of SC(i+1) in phi(i+2) -* - xx(1)= 0.0D0 - xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i) - xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i) - do j=1,3 - rj=0.0D0 - do k=2,3 - rj=rj+prod(j,k,i)*xx(k) - enddo - dxdv(j+3,ind1)=-rj - enddo -* -* Derivatives of SC(i+1) in phi(i+3). -* - do j=1,3 - dxoiij=0.0D0 - do k=1,3 - dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) - enddo - dxdv(j+3,ind1+1)=dxoiij - enddo -* -* Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru -* theta(nres) and phi(i+3) thru phi(nres). -* - do j=i+1,nres-2 - ind1=ind1+1 - ind=indmat(i+1,j+1) -cd print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 - do k=1,3 - do l=1,3 - tempkl=0.0D0 - do m=1,2 - tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind) - enddo - temp(k,l)=tempkl - enddo - enddo -cd print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3) -cd print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3) -cd print '(9f8.3)',((temp(k,l),l=1,3),k=1,3) -* Derivatives of virtual-bond vectors in theta - do k=1,3 - dcdv(k,ind1)=vbld(i+1)*temp(k,1) - enddo -cd print '(3f8.3)',(dcdv(k,ind1),k=1,3) -* Derivatives of SC vectors in theta - do k=1,3 - dxoijk=0.0D0 - do l=1,3 - dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) - enddo - dxdv(k,ind1+1)=dxoijk - enddo -* -*--- Calculate the derivatives in phi -* - do k=1,3 - do l=1,3 - tempkl=0.0D0 - do m=1,3 - tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind) - enddo - temp(k,l)=tempkl - enddo - enddo - do k=1,3 - dcdv(k+3,ind1)=vbld(i+1)*temp(k,1) - enddo - do k=1,3 - dxoijk=0.0D0 - do l=1,3 - dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) - enddo - dxdv(k+3,ind1+1)=dxoijk - enddo - enddo - enddo -* -* Derivatives in alpha and omega: -* - do i=2,nres-1 -c dsci=dsc(itype(i)) - dsci=vbld(i+nres) -#ifdef OSF - alphi=alph(i) - omegi=omeg(i) - if(alphi.ne.alphi) alphi=100.0 - if(omegi.ne.omegi) omegi=-100.0 -#else - alphi=alph(i) - omegi=omeg(i) -#endif -cd print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - temp(1,1)=-dsci*sinalphi - temp(2,1)= dsci*cosalphi*cosomegi - temp(3,1)=-dsci*cosalphi*sinomegi - temp(1,2)=0.0D0 - temp(2,2)=-dsci*sinalphi*sinomegi - temp(3,2)=-dsci*sinalphi*cosomegi - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - jjj=0 -cd print *,((temp(l,k),l=1,3),k=1,2) - do j=1,2 - xp=temp(1,j) - yp=temp(2,j) - xxp= xp*cost2+yp*sint2 - yyp=-xp*sint2+yp*cost2 - zzp=temp(3,j) - xx(1)=xxp - xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) - xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) - do k=1,3 - dj=0.0D0 - do l=1,3 - dj=dj+prod(k,l,i-1)*xx(l) - enddo - dxds(jjj+k,i)=dj - enddo - jjj=jjj+3 - enddo - enddo - return - end - diff --git a/source/unres/src_MD-M-newcorr/cartprint.f b/source/unres/src_MD-M-newcorr/cartprint.f deleted file mode 100644 index d79409e..0000000 --- a/source/unres/src_MD-M-newcorr/cartprint.f +++ /dev/null @@ -1,19 +0,0 @@ - subroutine cartprint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - write (iout,100) - do i=1,nres - write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i), - & c(3,i),c(1,nres+i),c(2,nres+i),c(3,nres+i) - enddo - 100 format (//' alpha-carbon coordinates ', - & ' centroid coordinates'/ - 1 ' ', 6X,'X',11X,'Y',11X,'Z', - & 10X,'X',11X,'Y',11X,'Z') - 110 format (a,'(',i3,')',6f12.5) - return - end diff --git a/source/unres/src_MD-M-newcorr/chainbuild.F b/source/unres/src_MD-M-newcorr/chainbuild.F deleted file mode 100644 index 45a1a53..0000000 --- a/source/unres/src_MD-M-newcorr/chainbuild.F +++ /dev/null @@ -1,274 +0,0 @@ - subroutine chainbuild -C -C Build the virtual polypeptide chain. Side-chain centroids are moveable. -C As of 2/17/95. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - logical lprn -C Set lprn=.true. for debugging - lprn = .false. -C -C Define the origin and orientation of the coordinate system and locate the -C first three CA's and SC(2). -C - call orig_frame -* -* Build the alpha-carbon chain. -* - do i=4,nres - call locate_next_res(i) - enddo -C -C First and last SC must coincide with the corresponding CA. -C - do j=1,3 - dc(j,nres+1)=0.0D0 - dc_norm(j,nres+1)=0.0D0 - dc(j,nres+nres)=0.0D0 - dc_norm(j,nres+nres)=0.0D0 - c(j,nres+1)=c(j,1) - c(j,nres+nres)=c(j,nres) - enddo -* -* Temporary diagnosis -* - if (lprn) then - - call cartprint - write (iout,'(/a)') 'Recalculated internal coordinates' - do i=2,nres-1 - do j=1,3 - c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) - enddo - be=0.0D0 - if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i) - be1=rad2deg*beta(nres+i,i,maxres2,i+1) - alfai=0.0D0 - if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i) - write (iout,1212) restyp(itype(i)),i,dist(i-1,i), - & alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,maxres2),be1 - enddo - 1212 format (a3,'(',i3,')',2(f10.5,2f10.2)) - - endif - - return - end -c------------------------------------------------------------------------- - subroutine orig_frame -C -C Define the origin and orientation of the coordinate system and locate -C the first three atoms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - cost=dcos(theta(3)) - sint=dsin(theta(3)) - t(1,1,1)=-cost - t(1,2,1)=-sint - t(1,3,1)= 0.0D0 - t(2,1,1)=-sint - t(2,2,1)= cost - t(2,3,1)= 0.0D0 - t(3,1,1)= 0.0D0 - t(3,2,1)= 0.0D0 - t(3,3,1)= 1.0D0 - r(1,1,1)= 1.0D0 - r(1,2,1)= 0.0D0 - r(1,3,1)= 0.0D0 - r(2,1,1)= 0.0D0 - r(2,2,1)= 1.0D0 - r(2,3,1)= 0.0D0 - r(3,1,1)= 0.0D0 - r(3,2,1)= 0.0D0 - r(3,3,1)= 1.0D0 - do i=1,3 - do j=1,3 - rt(i,j,1)=t(i,j,1) - enddo - enddo - do i=1,3 - do j=1,3 - prod(i,j,1)=0.0D0 - prod(i,j,2)=t(i,j,1) - enddo - prod(i,i,1)=1.0D0 - enddo - c(1,1)=0.0D0 - c(2,1)=0.0D0 - c(3,1)=0.0D0 - c(1,2)=vbld(2) - c(2,2)=0.0D0 - c(3,2)=0.0D0 - dc(1,0)=0.0d0 - dc(2,0)=0.0D0 - dc(3,0)=0.0D0 - dc(1,1)=vbld(2) - dc(2,1)=0.0D0 - dc(3,1)=0.0D0 - dc_norm(1,0)=0.0D0 - dc_norm(2,0)=0.0D0 - dc_norm(3,0)=0.0D0 - dc_norm(1,1)=1.0D0 - dc_norm(2,1)=0.0D0 - dc_norm(3,1)=0.0D0 - do j=1,3 - dc_norm(j,2)=prod(j,1,2) - dc(j,2)=vbld(3)*prod(j,1,2) - c(j,3)=c(j,2)+dc(j,2) - enddo - call locate_side_chain(2) - return - end -c----------------------------------------------------------------------------- - subroutine locate_next_res(i) -C -C Locate CA(i) and SC(i-1) -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' -C -C Define the rotation matrices corresponding to CA(i) -C -#ifdef OSF - theti=theta(i) - if (theti.ne.theti) theti=100.0 - phii=phi(i) - if (phii.ne.phii) phii=180.0 -#else - theti=theta(i) - phii=phi(i) -#endif - cost=dcos(theti) - sint=dsin(theti) - cosphi=dcos(phii) - sinphi=dsin(phii) -* Define the matrices of the rotation about the virtual-bond valence angles -* theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this -* program), R(i,j,k), and, the cumulative matrices of rotation RT - t(1,1,i-2)=-cost - t(1,2,i-2)=-sint - t(1,3,i-2)= 0.0D0 - t(2,1,i-2)=-sint - t(2,2,i-2)= cost - t(2,3,i-2)= 0.0D0 - t(3,1,i-2)= 0.0D0 - t(3,2,i-2)= 0.0D0 - t(3,3,i-2)= 1.0D0 - r(1,1,i-2)= 1.0D0 - r(1,2,i-2)= 0.0D0 - r(1,3,i-2)= 0.0D0 - r(2,1,i-2)= 0.0D0 - r(2,2,i-2)=-cosphi - r(2,3,i-2)= sinphi - r(3,1,i-2)= 0.0D0 - r(3,2,i-2)= sinphi - r(3,3,i-2)= cosphi - rt(1,1,i-2)=-cost - rt(1,2,i-2)=-sint - rt(1,3,i-2)=0.0D0 - rt(2,1,i-2)=sint*cosphi - rt(2,2,i-2)=-cost*cosphi - rt(2,3,i-2)=sinphi - rt(3,1,i-2)=-sint*sinphi - rt(3,2,i-2)=cost*sinphi - rt(3,3,i-2)=cosphi - call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1)) - do j=1,3 - dc_norm(j,i-1)=prod(j,1,i-1) - dc(j,i-1)=vbld(i)*prod(j,1,i-1) - c(j,i)=c(j,i-1)+dc(j,i-1) - enddo -cd print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3) -C -C Now calculate the coordinates of SC(i-1) -C - call locate_side_chain(i-1) - return - end -c----------------------------------------------------------------------------- - subroutine locate_side_chain(i) -C -C Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - dimension xx(3) - -c dsci=dsc(itype(i)) -c dsci_inv=dsc_inv(itype(i)) - dsci=vbld(i+nres) - dsci_inv=vbld_inv(i+nres) -#ifdef OSF - alphi=alph(i) - omegi=omeg(i) - if (alphi.ne.alphi) alphi=100.0 - if (omegi.ne.omegi) omegi=-100.0 -#else - alphi=alph(i) - omegi=omeg(i) -#endif - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - xp= dsci*cosalphi - yp= dsci*sinalphi*cosomegi - zp=-dsci*sinalphi*sinomegi -* Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its -* X-axis aligned with the vector DC(*,i) - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - xx(1)= xp*cost2+yp*sint2 - xx(2)=-xp*sint2+yp*cost2 - xx(3)= zp -cd print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i, -cd & xp,yp,zp,(xx(k),k=1,3) - do j=1,3 - xloc(j,i)=xx(j) - enddo -* Bring the SC vectors to the common coordinate system. - xx(1)=xloc(1,i) - xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1) - xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1) - do j=1,3 - xrot(j,i)=xx(j) - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i-1)*xx(k) - enddo - dc(j,nres+i)=rj - dc_norm(j,nres+i)=rj*dsci_inv - c(j,nres+i)=c(j,i)+rj - enddo - return - end diff --git a/source/unres/src_MD-M-newcorr/change.awk b/source/unres/src_MD-M-newcorr/change.awk deleted file mode 100644 index d192a6e..0000000 --- a/source/unres/src_MD-M-newcorr/change.awk +++ /dev/null @@ -1,11 +0,0 @@ -{ - if($0==" include 'COMMON.LANGEVIN'") { - print "#ifndef LANG0" - print " include 'COMMON.LANGEVIN'" - print "#else" - print " include 'COMMON.LANGEVIN.lang0'" - print "#endif" - }else{ - print $0 - } -} diff --git a/source/unres/src_MD-M-newcorr/check_bond.f b/source/unres/src_MD-M-newcorr/check_bond.f deleted file mode 100644 index c8a4ad1..0000000 --- a/source/unres/src_MD-M-newcorr/check_bond.f +++ /dev/null @@ -1,20 +0,0 @@ - subroutine check_bond -C Subroutine is checking if the fitted function which describs sc_rot_pot -C is correct, printing, alpha,beta, energy, data - for some known theta. -C theta angle is read from the input file. Sc_rot_pot are printed -C for the second residue in sequance. - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.CHAIN' - double precision energia(0:n_ene) - it=itype(2) - do i=1,101 - vbld(nres+2)=0.5d0+0.05d0*(i-1) - call chainbuild - call etotal(energia) - write (2,*) vbld(nres+2),energia(17) - enddo - return - end diff --git a/source/unres/src_MD-M-newcorr/check_sc_distr.f b/source/unres/src_MD-M-newcorr/check_sc_distr.f deleted file mode 100644 index db2ed1b..0000000 --- a/source/unres/src_MD-M-newcorr/check_sc_distr.f +++ /dev/null @@ -1,43 +0,0 @@ - subroutine check_sc_distr - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - logical fail - double precision varia(maxvar) - double precision hrtime,mintime,sectime - parameter (MaxSample=10000000,delt=1.0D0/MaxSample) - dimension prob(0:72,0:90) - dV=2.0D0*5.0D0*deg2rad*deg2rad - print *,'dv=',dv - do 10 it=1,1 - if (it.eq.10) goto 10 - open (20,file=restyp(it)//'_distr.sdc',status='unknown') - call gen_side(it,90.0D0*deg2rad,al,om,fail) - close (20) - goto 10 - open (20,file=restyp(it)//'_distr1.sdc',status='unknown') - do i=0,90 - do j=0,72 - prob(j,i)=0.0D0 - enddo - enddo - do isample=1,MaxSample - call gen_side(it,90.0D0*deg2rad,al,om) - indal=rad2deg*al/2 - indom=(rad2deg*om+180.0D0)/5 - prob(indom,indal)=prob(indom,indal)+delt - enddo - do i=45,90 - do j=0,72 - write (20,'(2f10.3,1pd15.5)') 2*i+0.0D0,5*j-180.0D0, - & prob(j,i)/dV - enddo - enddo - 10 continue - return - end diff --git a/source/unres/src_MD-M-newcorr/check_sc_map.f b/source/unres/src_MD-M-newcorr/check_sc_map.f deleted file mode 100644 index 4314e16..0000000 --- a/source/unres/src_MD-M-newcorr/check_sc_map.f +++ /dev/null @@ -1,49 +0,0 @@ - subroutine check_sc_map -C Subroutine is checking if the fitted function which describs sc_rot_pot -C is correct, printing, alpha,beta, energy, data - for some known theta. -C theta angle is read from the input file. Sc_rot_pot are printed -C for the second residue in sequance. - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - real*8 xx,yy,zz,al,om - real*8 escloc, escloc_ene(50000), escloc_min, alph_plot(50000), - & beta_plot(50000) - integer al_plot(5000),be_plot(5000) - integer iialph, iibet,it - write (2,*) "Side-chain-rotamer potential energy map!!!!" - escloc_min = 1000000.00 -C it=itype(2) - i = 0 - do iialph=0,18 - do iibet=-18,18 - i = i + 1 - al = iialph*10.0d0*deg2rad - om = iibet*10.0d0*deg2rad - zz = dcos(al) - xx = -dsin(al)*dcos(om) - yy = -dsin(al)*dsin(om) - alph(2)=dacos(xx) - omeg(2)=-datan2(zz,yy) - al_plot(i)=alph(2)*rad2deg - be_plot(i)=omeg(2)*rad2deg -C write(2,*) alph(2)*rad2deg, omeg(2)*rad2deg - alph_plot(i) = al*rad2deg - beta_plot(i) = om*rad2deg - call chainbuild - call vec_and_deriv - call esc(escloc) - escloc_ene(i) = escloc - if (escloc_min.gt.escloc_ene(i)) escloc_min=escloc_ene(i) - enddo - enddo -C write (2,*) "escloc_min = ", escloc_min - print *,"i",i - do j = 1,i - write (2,'(3f10.3,2i9,f12.5)') alph_plot(j), - & beta_plot(j),theta(3)*rad2deg, al_plot(j),be_plot(j), - & escloc_ene(j) !- escloc_min - enddo - return - end diff --git a/source/unres/src_MD-M-newcorr/checkder_p.F b/source/unres/src_MD-M-newcorr/checkder_p.F deleted file mode 100644 index 0539e48..0000000 --- a/source/unres/src_MD-M-newcorr/checkder_p.F +++ /dev/null @@ -1,700 +0,0 @@ - subroutine check_cartgrad -C Check the gradient of Cartesian coordinates in internal coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.DERIV' - dimension temp(6,maxres),xx(3),gg(3) - indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 -* -* Check the gradient of the virtual-bond and SC vectors in the internal -* coordinates. -* - aincr=1.0d-7 - aincr2=5.0d-8 - call cartder - write (iout,'(a)') '**************** dx/dalpha' - write (iout,'(a)') - do i=2,nres-1 - alphi=alph(i) - alph(i)=alph(i)+aincr - do k=1,3 - temp(k,i)=dc(k,nres+i) - enddo - call chainbuild - do k=1,3 - gg(k)=(dc(k,nres+i)-temp(k,i))/aincr - xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr)) - enddo - write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') - & i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - alph(i)=alphi - call chainbuild - enddo - write (iout,'(a)') - write (iout,'(a)') '**************** dx/domega' - write (iout,'(a)') - do i=2,nres-1 - omegi=omeg(i) - omeg(i)=omeg(i)+aincr - do k=1,3 - temp(k,i)=dc(k,nres+i) - enddo - call chainbuild - do k=1,3 - gg(k)=(dc(k,nres+i)-temp(k,i))/aincr - xx(k)=dabs((gg(k)-dxds(k+3,i))/ - & (aincr*dabs(dxds(k+3,i))+aincr)) - enddo - write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') - & i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - omeg(i)=omegi - call chainbuild - enddo - write (iout,'(a)') - write (iout,'(a)') '**************** dx/dtheta' - write (iout,'(a)') - do i=3,nres - theti=theta(i) - theta(i)=theta(i)+aincr - do j=i-1,nres-1 - do k=1,3 - temp(k,j)=dc(k,nres+j) - enddo - enddo - call chainbuild - do j=i-1,nres-1 - ii = indmat(i-2,j) -c print *,'i=',i-2,' j=',j-1,' ii=',ii - do k=1,3 - gg(k)=(dc(k,nres+j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dxdv(k,ii))/ - & (aincr*dabs(dxdv(k,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3) - write(iout,'(a)') - enddo - write (iout,'(a)') - theta(i)=theti - call chainbuild - enddo - write (iout,'(a)') '***************** dx/dphi' - write (iout,'(a)') - do i=4,nres - phi(i)=phi(i)+aincr - do j=i-1,nres-1 - do k=1,3 - temp(k,j)=dc(k,nres+j) - enddo - enddo - call chainbuild - do j=i-1,nres-1 - ii = indmat(i-2,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,nres+j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ - & (aincr*dabs(dxdv(k+3,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3) - write(iout,'(a)') - enddo - phi(i)=phi(i)-aincr - call chainbuild - enddo - write (iout,'(a)') '****************** ddc/dtheta' - do i=1,nres-2 - thet=theta(i+2) - theta(i+2)=thet+aincr - do j=i,nres - do k=1,3 - temp(k,j)=dc(k,j) - enddo - enddo - call chainbuild - do j=i+1,nres-1 - ii = indmat(i,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dcdv(k,ii))/ - & (aincr*dabs(dcdv(k,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - enddo - do j=1,nres - do k=1,3 - dc(k,j)=temp(k,j) - enddo - enddo - theta(i+2)=thet - enddo - write (iout,'(a)') '******************* ddc/dphi' - do i=1,nres-3 - phii=phi(i+3) - phi(i+3)=phii+aincr - do j=1,nres - do k=1,3 - temp(k,j)=dc(k,j) - enddo - enddo - call chainbuild - do j=i+2,nres-1 - ii = indmat(i+1,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ - & (aincr*dabs(dcdv(k+3,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - enddo - do j=1,nres - do k=1,3 - dc(k,j)=temp(k,j) - enddo - enddo - phi(i+3)=phii - enddo - return - end -C---------------------------------------------------------------------------- - subroutine check_ecart -C Check the gradient of the energy in Cartesian coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTACTS' - common /srutu/ icall - dimension ggg(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar),g(maxvar) - dimension grad_s(6,maxres) - double precision energia(0:n_ene),energia1(0:n_ene) - integer uiparm(1) - double precision urparm(1) - external fdum - icg=1 - nf=0 - nfl=0 - call zerograd - aincr=1.0D-7 - print '(a)','CG processor',me,' calling CHECK_CART.' - nf=0 - icall=0 - call geom_to_var(nvar,x) - call etotal(energia(0)) - etot=energia(0) - call enerprint(energia(0)) - call gradient(nvar,x,nf,g,uiparm,urparm,fdum) - icall =1 - do i=1,nres - write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) - enddo - do i=1,nres - do j=1,3 - grad_s(j,i)=gradc(j,i,icg) - grad_s(j+3,i)=gradx(j,i,icg) - enddo - enddo - call flush(iout) - write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' - do i=1,nres - do j=1,3 - xx(j)=c(j,i+nres) - ddc(j)=dc(j,i) - ddx(j)=dc(j,i+nres) - enddo - do j=1,3 - dc(j,i)=dc(j,i)+aincr - do k=i+1,nres - c(j,k)=c(j,k)+aincr - c(j,k+nres)=c(j,k+nres)+aincr - enddo - call etotal(energia1(0)) - etot1=energia1(0) - ggg(j)=(etot1-etot)/aincr - dc(j,i)=ddc(j) - do k=i+1,nres - c(j,k)=c(j,k)-aincr - c(j,k+nres)=c(j,k+nres)-aincr - enddo - enddo - do j=1,3 - c(j,i+nres)=c(j,i+nres)+aincr - dc(j,i+nres)=dc(j,i+nres)+aincr - call etotal(energia1(0)) - etot1=energia1(0) - ggg(j+3)=(etot1-etot)/aincr - c(j,i+nres)=xx(j) - dc(j,i+nres)=ddx(j) - enddo - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') - & i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6) - enddo - return - end -c---------------------------------------------------------------------------- - subroutine check_ecartint -C Check the gradient of the energy in Cartesian coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTACTS' - include 'COMMON.MD' - include 'COMMON.LOCAL' - include 'COMMON.SPLITELE' - common /srutu/ icall - dimension ggg(6),ggg1(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar), - & g(maxvar) - dimension dcnorm_safe(3),dxnorm_safe(3) - dimension grad_s(6,0:maxres),grad_s1(6,0:maxres) - double precision phi_temp(maxres),theta_temp(maxres), - & alph_temp(maxres),omeg_temp(maxres) - double precision energia(0:n_ene),energia1(0:n_ene) - integer uiparm(1) - double precision urparm(1) - external fdum - r_cut=2.0d0 - rlambd=0.3d0 - icg=1 - nf=0 - nfl=0 - call intout -c call intcartderiv -c call checkintcartgrad - call zerograd - aincr=1.0D-5 - write(iout,*) 'Calling CHECK_ECARTINT.' - nf=0 - icall=0 - call geom_to_var(nvar,x) - if (.not.split_ene) then - call etotal(energia(0)) - etot=energia(0) - call enerprint(energia(0)) - call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) - call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) - icall =1 - do i=1,nres - write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) - enddo - do j=1,3 - grad_s(j,0)=gcart(j,0) - enddo - do i=1,nres - do j=1,3 - grad_s(j,i)=gcart(j,i) - grad_s(j+3,i)=gxcart(j,i) - enddo - enddo - else -!- split gradient check - call zerograd - call etotal_long(energia(0)) - call enerprint(energia(0)) - call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) - call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) - icall =1 - write (iout,*) "longrange grad" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), - & (gxcart(j,i),j=1,3) - enddo - do j=1,3 - grad_s(j,0)=gcart(j,0) - enddo - do i=1,nres - do j=1,3 - grad_s(j,i)=gcart(j,i) - grad_s(j+3,i)=gxcart(j,i) - enddo - enddo - call zerograd - call etotal_short(energia(0)) - call enerprint(energia(0)) - call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) - call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) - icall =1 - write (iout,*) "shortrange grad" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), - & (gxcart(j,i),j=1,3) - enddo - do j=1,3 - grad_s1(j,0)=gcart(j,0) - enddo - do i=1,nres - do j=1,3 - grad_s1(j,i)=gcart(j,i) - grad_s1(j+3,i)=gxcart(j,i) - enddo - enddo - endif - write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' - do i=0,nres - do j=1,3 - xx(j)=c(j,i+nres) - ddc(j)=dc(j,i) - ddx(j)=dc(j,i+nres) - do k=1,3 - dcnorm_safe(k)=dc_norm(k,i) - dxnorm_safe(k)=dc_norm(k,i+nres) - enddo - enddo - do j=1,3 - dc(j,i)=ddc(j)+aincr - call chainbuild_cart -#ifdef MPI -c Broadcast the order to compute internal coordinates to the slaves. -c if (nfgtasks.gt.1) -c & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif -c call int_from_cart1(.false.) - if (.not.split_ene) then - call etotal(energia1(0)) - etot1=energia1(0) - else -!- split gradient - call etotal_long(energia1(0)) - etot11=energia1(0) - call etotal_short(energia1(0)) - etot12=energia1(0) -c write (iout,*) "etot11",etot11," etot12",etot12 - endif -!- end split gradient -c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 - dc(j,i)=ddc(j)-aincr - call chainbuild_cart -c call int_from_cart1(.false.) - if (.not.split_ene) then - call etotal(energia1(0)) - etot2=energia1(0) - ggg(j)=(etot1-etot2)/(2*aincr) - else -!- split gradient - call etotal_long(energia1(0)) - etot21=energia1(0) - ggg(j)=(etot11-etot21)/(2*aincr) - call etotal_short(energia1(0)) - etot22=energia1(0) - ggg1(j)=(etot12-etot22)/(2*aincr) -!- end split gradient -c write (iout,*) "etot21",etot21," etot22",etot22 - endif -c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 - dc(j,i)=ddc(j) - call chainbuild_cart - enddo - do j=1,3 - dc(j,i+nres)=ddx(j)+aincr - call chainbuild_cart -c write (iout,*) "i",i," j",j," dxnorm+ and dxnorm" -c write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) -c write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) -c write (iout,*) "dxnormnorm",dsqrt( -c & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) -c write (iout,*) "dxnormnormsafe",dsqrt( -c & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) -c write (iout,*) - if (.not.split_ene) then - call etotal(energia1(0)) - etot1=energia1(0) - else -!- split gradient - call etotal_long(energia1(0)) - etot11=energia1(0) - call etotal_short(energia1(0)) - etot12=energia1(0) - endif -!- end split gradient -c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 - dc(j,i+nres)=ddx(j)-aincr - call chainbuild_cart -c write (iout,*) "i",i," j",j," dxnorm- and dxnorm" -c write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) -c write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) -c write (iout,*) -c write (iout,*) "dxnormnorm",dsqrt( -c & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) -c write (iout,*) "dxnormnormsafe",dsqrt( -c & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) - if (.not.split_ene) then - call etotal(energia1(0)) - etot2=energia1(0) - ggg(j+3)=(etot1-etot2)/(2*aincr) - else -!- split gradient - call etotal_long(energia1(0)) - etot21=energia1(0) - ggg(j+3)=(etot11-etot21)/(2*aincr) - call etotal_short(energia1(0)) - etot22=energia1(0) - ggg1(j+3)=(etot12-etot22)/(2*aincr) -!- end split gradient - endif -c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 - dc(j,i+nres)=ddx(j) - call chainbuild_cart - enddo - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') - & i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6) - if (split_ene) then - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') - & i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i), - & k=1,6) - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') - & i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6), - & ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6) - endif - enddo - return - end -c------------------------------------------------------------------------- - subroutine int_from_cart1(lprn) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer ierror -#endif - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.SETUP' - include 'COMMON.TIME1' - logical lprn - if (lprn) write (iout,'(/a)') 'Recalculated internal coordinates' -#ifdef TIMING - time01=MPI_Wtime() -#endif -#if defined(PARINT) && defined(MPI) - do i=iint_start,iint_end -#else - do i=2,nres -#endif - dnorm1=dist(i-1,i) - dnorm2=dist(i,i+1) - do j=1,3 - c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))/dnorm1 - & +(c(j,i+1)-c(j,i))/dnorm2) - enddo - be=0.0D0 - if (i.gt.2) then - if (i.le.nres) phi(i+1)=beta(i-2,i-1,i,i+1) - if ((itype(i).ne.10).and.(itype(i-1).ne.10)) then - tauangle(3,i+1)=beta(i+nres-1,i-1,i,i+nres) - endif - if (itype(i-1).ne.10) then - tauangle(1,i+1)=beta(i-1+nres,i-1,i,i+1) - omicron(1,i)=alpha(i-2,i-1,i-1+nres) - omicron(2,i)=alpha(i-1+nres,i-1,i) - endif - if (itype(i).ne.10) then - tauangle(2,i+1)=beta(i-2,i-1,i,i+nres) - endif - endif - omeg(i)=beta(nres+i,i,maxres2,i+1) - alph(i)=alpha(nres+i,i,maxres2) - theta(i+1)=alpha(i-1,i,i+1) - vbld(i)=dist(i-1,i) - vbld_inv(i)=1.0d0/vbld(i) - vbld(nres+i)=dist(nres+i,i) - if (itype(i).ne.10) then - vbld_inv(nres+i)=1.0d0/vbld(nres+i) - else - vbld_inv(nres+i)=0.0d0 - endif - enddo -#if defined(PARINT) && defined(MPI) - if (nfgtasks1.gt.1) then -cd write(iout,*) "iint_start",iint_start," iint_count", -cd & (iint_count(i),i=0,nfgtasks-1)," iint_displ", -cd & (iint_displ(i),i=0,nfgtasks-1) -cd write (iout,*) "Gather vbld backbone" -cd call flush(iout) - time00=MPI_Wtime() - call MPI_Allgatherv(vbld(iint_start),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,vbld(1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather vbld_inv" -cd call flush(iout) - call MPI_Allgatherv(vbld_inv(iint_start),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,vbld_inv(1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather vbld side chain" -cd call flush(iout) - call MPI_Allgatherv(vbld(iint_start+nres),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,vbld(nres+1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather vbld_inv side chain" -cd call flush(iout) - call MPI_Allgatherv(vbld_inv(iint_start+nres), - & iint_count(fg_rank1),MPI_DOUBLE_PRECISION,vbld_inv(nres+1), - & iint_count(0),iint_displ(0),MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather theta" -cd call flush(iout) - call MPI_Allgatherv(theta(iint_start+1),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,theta(2),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather phi" -cd call flush(iout) - call MPI_Allgatherv(phi(iint_start+1),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,phi(2),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -#ifdef CRYST_SC -cd write (iout,*) "Gather alph" -cd call flush(iout) - call MPI_Allgatherv(alph(iint_start),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,alph(1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather omeg" -cd call flush(iout) - call MPI_Allgatherv(omeg(iint_start),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,omeg(1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -#endif - time_gather=time_gather+MPI_Wtime()-time00 - endif -#endif - do i=1,nres-1 - do j=1,3 - dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) - enddo - enddo - do i=2,nres-1 - do j=1,3 - dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) - enddo - enddo - if (lprn) then - do i=2,nres - write (iout,1212) restyp(itype(i)),i,vbld(i), - &rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i), - &rad2deg*alph(i),rad2deg*omeg(i) - enddo - endif - 1212 format (a3,'(',i3,')',2(f15.10,2f10.2)) -#ifdef TIMING - time_intfcart=time_intfcart+MPI_Wtime()-time01 -#endif - return - end -c---------------------------------------------------------------------------- - subroutine check_eint -C Check the gradient of energy in internal coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' - common /srutu/ icall - dimension x(maxvar),gana(maxvar),gg(maxvar) - integer uiparm(1) - double precision urparm(1) - double precision energia(0:n_ene),energia1(0:n_ene), - & energia2(0:n_ene) - character*6 key - external fdum - call zerograd - aincr=1.0D-7 - print '(a)','Calling CHECK_INT.' - nf=0 - nfl=0 - icg=1 - call geom_to_var(nvar,x) - call var_to_geom(nvar,x) - call chainbuild - icall=1 - print *,'ICG=',ICG - call etotal(energia(0)) - etot = energia(0) - call enerprint(energia(0)) - print *,'ICG=',ICG -#ifdef MPL - if (MyID.ne.BossID) then - call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID) - nf=x(nvar+1) - nfl=x(nvar+2) - icg=x(nvar+3) - endif -#endif - nf=1 - nfl=3 -cd write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar) - call gradient(nvar,x,nf,gana,uiparm,urparm,fdum) -cd write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar) - icall=1 - do i=1,nvar - xi=x(i) - x(i)=xi-0.5D0*aincr - call var_to_geom(nvar,x) - call chainbuild - call etotal(energia1(0)) - etot1=energia1(0) - x(i)=xi+0.5D0*aincr - call var_to_geom(nvar,x) - call chainbuild - call etotal(energia2(0)) - etot2=energia2(0) - gg(i)=(etot2-etot1)/aincr - write (iout,*) i,etot1,etot2 - x(i)=xi - enddo - write (iout,'(/2a)')' Variable Numerical Analytical', - & ' RelDiff*100% ' - do i=1,nvar - if (i.le.nphi) then - ii=i - key = ' phi' - else if (i.le.nphi+ntheta) then - ii=i-nphi - key=' theta' - else if (i.le.nphi+ntheta+nside) then - ii=i-(nphi+ntheta) - key=' alpha' - else - ii=i-(nphi+ntheta+nside) - key=' omega' - endif - write (iout,'(i3,a,i3,3(1pd16.6))') - & i,key,ii,gg(i),gana(i), - & 100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr) - enddo - return - end diff --git a/source/unres/src_MD-M-newcorr/common.size b/source/unres/src_MD-M-newcorr/common.size deleted file mode 100644 index 3bc1f47..0000000 --- a/source/unres/src_MD-M-newcorr/common.size +++ /dev/null @@ -1,130 +0,0 @@ -info 0x4010 gen_rand_conf.o -from_zscore 0x8 unres.o -mdcalc 0x108 unres.o -bank_disulfid 0x1f0 readrtns_CSA.o -parfiles 0xb00 unres.o -body 0x6180 unres.o -pool 0x697dc readrtns_CSA.o -interact 0xed94 unres.o -sclocal 0x22cc chainbuild.o -restraints 0x8 unres.o -peptbond 0x28 chainbuild.o -srutu 0x4 unres.o -mucarem 0x8000 readrtns_CSA.o -oldgeo 0xd2ff4 unres.o -minvar 0xe278 readrtns_CSA.o -spinka 0x2a3c newconf.o -torsiond 0x14200 initialize_p.o -przechowalnia 0x7b98a04 rattle.o -langforc 0x31a5054 readrtns_CSA.o -thetas 0x960 chainbuild.o -iounits 0x6c unres.o -rotat_old 0xa8c0 unres.o -remdcommon 0x6030 unres.o -chuju 0x4 minimize_p.o -refstruct 0x151ec unres.o -traj1cache 0x3679c unres.o -stretch 0x600 unres.o -mvstat 0x250 readrtns_CSA.o -thread 0x148 readrtns_CSA.o -dih_control 0xc readrtns_CSA.o -mdpar 0x6c unres.o -types 0x14 unres.o -par 0x20 eigen.o -bounds 0x3840 readrtns_CSA.o -pizda 0xe10 readrtns_CSA.o -machsw 0xc initialize_p.o -links_split 0x8 unres.o -integer_muca 0xc readrtns_CSA.o -calc 0x1f0 gen_rand_conf.o -csafiles 0xc00 unres.o -sbridge 0x9c unres.o -back_constr 0x11acc unres.o -rotat 0x2a300 unres.o -mpipriv2 0x18 unres.o -remdrestart 0x411808 unres.o -stochcalc 0xa8c0 MD_A-MTS.o -scrot 0x28a0 parmread.o -stoptim 0x4 unres.o -c_frag 0x1c28 geomout.o -precomp2 0x54600 unres.o -move 0x38b8 initialize_p.o -loc_work 0x30c local_move.o -store0 0x4 geomout.o -torsion 0x5adc parmread.o -wagi 0x10 geomout.o -vrandd 0x3f0 randgens.o -lagrange 0x15a93de0 unres.o -accept_stats 0x2008 initialize_p.o -mdpmpi 0x8010 unres.o -invlen 0x3840 chainbuild.o -locel 0x208 energy_p_new.o -frag 0xa0 geomout.o -inertia 0x160 unres.o -time1 0x30 unres.o -derivat 0x2638028 initialize_p.o -langmat 0xc readrtns_CSA.o -banii 0xa8c0 banach.o -mdgrad 0x151b0 unres.o -bank 0x1c320 readrtns_CSA.o -refer 0x98 bond_move.o -diploc 0x3938 unres.o -syfek 0xa8c0 stochfric.o -fnames 0x1007 unres.o -$BLNK_COM 0xc djacob.o -sccalc 0x28 energy_p_new.o -geo 0x40 unres.o -iofile 0x65c initialize_p.o -mapp 0x2a304 readrtns_CSA.o -theta_abinitio 0x24a70 chainbuild.o -sumsl_flag 0x4 unres.o -restr 0xd2f4 unres.o -chain 0x3f500 unres.o -torcnstr 0x5478 initialize_p.o -cipiszcze 0x4 lagrangian_lesyng.o -double_muca 0x1c228 readrtns_CSA.o -links 0x93d24c unres.o -deriv_loc 0x1e0 initialize_p.o -cache 0x69850 mcm.o -minimm 0x20 initialize_p.o -diffcuta 0x8 readrtns_CSA.o -aaaa 0x8 MP.o -fourier 0x344 initialize_p.o -mce 0x230 readrtns_CSA.o -var 0x286f0 unres.o -csa_input 0x98 readrtns_CSA.o -header 0x50 unres.o -splitele 0x10 initialize_p.o -setup 0x4028 unres.o -mcm 0x20a4 initialize_p.o -mce_counters 0x14 readrtns_CSA.o -frozen 0xe10 geomout.o -struct 0xa2c readrtns_CSA.o -info1 0x4024 gen_rand_conf.o -cntrl 0x78 unres.o -mpiprivc 0x2 unres.o -timing 0x58 unres.o -kutas 0x4 energy_p_new.o -precomp1 0x50dc0 unres.o -loc_const 0x40 local_move.o -contacts1 0x18c630 unres.o -alphaa 0x16da8 readrtns_CSA.o -thread1 0x1cd0 readrtns_CSA.o -qmeas 0x6f2bc unres.o -dipmat 0x15f9000 unres.o -indices 0x8040 chainbuild.o -ffield 0x174 unres.o -vectors 0x49d40 energy_p_new.o -varin 0xe248 readrtns_CSA.o -csaunits 0x34 unres.o -contacts_hb 0x9c9c30 unres.o -contacts 0x2a308 unres.o -deriv_scloc 0x2f760 initialize_p.o -secondarys 0x384 dihed_cons.o -pochodne 0x6318d0 geomout.o -maxgrad 0xa8 energy_p_new.o -send2 0xfd50 readrtns_CSA.o -windows 0x2a34 initialize_p.o -gucio 0x18 MD_A-MTS.o -rotmat 0x3f480 unres.o - diff --git a/source/unres/src_MD-M-newcorr/common.size.orig b/source/unres/src_MD-M-newcorr/common.size.orig deleted file mode 100644 index d009a52..0000000 --- a/source/unres/src_MD-M-newcorr/common.size.orig +++ /dev/null @@ -1,130 +0,0 @@ -from_zscore 8 unres.o -mdcalc 108 unres.o -bank_disulfid 1f0 readrtns_CSA.o -parfiles b00 unres.o -body 6180 unres.o -mpipriv1 1c unres.o -pool 2459c readrtns_CSA.o -interact 6c84 unres.o -sclocal 22cc chainbuild.o -restraints 8 unres.o -peptbond 28 chainbuild.o -srutu 4 unres.o -mucarem 8000 readrtns_CSA.o -oldgeo 48b74 unres.o -minvar 4ef8 readrtns_CSA.o -spinka e88 newconf.o -torsiond 14200 initialize_p.o -langforc 34dc434 readrtns_CSA.o -thetas 960 chainbuild.o -iounits 6c unres.o -rotat_old 3a20 unres.o -remdcommon 6030 unres.o -chuju 4 minimize_p.o -dipint 31db480 unres.o -refstruct 74ac unres.o -traj1cache 13e7c unres.o -stretch 600 unres.o -mvstat 250 readrtns_CSA.o -thread 148 readrtns_CSA.o -dih_control c readrtns_CSA.o -mdpar 6c unres.o -types 14 unres.o -rattlemat ea9e84 rattle.o -par 20 eigen.o -bounds 1360 readrtns_CSA.o -pizda 4d8 readrtns_CSA.o -machsw c initialize_p.o -links_split 8 unres.o -integer_muca c readrtns_CSA.o -calc 1f0 gen_rand_conf.o -csafiles c00 unres.o -sbridge 9c unres.o -back_constr 874c unres.o -rotat e880 unres.o -mpipriv2 18 unres.o -remdrestart 411808 unres.o -stochcalc 3a20 MD_A-MTS.o -scrot 28a0 parmread.o -stoptim 4 unres.o -c_frag 9b0 geomout.o -precomp2 1d100 unres.o -move 13d8 initialize_p.o -loc_work 30c local_move.o -store0 4 geomout.o -torsion 5adc parmread.o -wagi bc4d0 geomout.o -vrandd 3f0 randgens.o -lagrange a468980 unres.o -accept_stats 2008 initialize_p.o -mdpmpi 8010 unres.o -invlen 1360 chainbuild.o -locel 208 energy_p_new.o -frag a0 geomout.o -inertia 160 unres.o -time1 30 unres.o -derivat 4cab48 initialize_p.o -langmat c readrtns_CSA.o -banii 3a20 banach.o -mdgrad 7470 unres.o -bank 9c20 readrtns_CSA.o -refer 98 bond_move.o -diploc 3938 unres.o -syfek 3a20 stochfric.o -fnames 1007 unres.o -$BLNK_COM c djacob.o -sccalc 28 energy_p_new.o -geo 40 unres.o -iofile 65c initialize_p.o -mapp e884 readrtns_CSA.o -theta_abinitio 24a70 chainbuild.o -sumsl_flag 4 unres.o -restr 48ac unres.o -chain 15d40 unres.o -torcnstr 1d28 initialize_p.o -cipiszcze 4 lagrangian_lesyng.o -double_muca 9b28 readrtns_CSA.o -links 116d34 unres.o -deriv_loc 1e0 initialize_p.o -cache 24610 mcm.o -minimm 20 initialize_p.o -diffcuta 8 readrtns_CSA.o -aaaa 8 MP.o -fourier 344 initialize_p.o -mce 230 readrtns_CSA.o -var dee0 unres.o -csa_input 98 readrtns_CSA.o -header 50 unres.o -splitele 10 initialize_p.o -setup 4028 unres.o -mcm 20a4 initialize_p.o -mce_counters 14 readrtns_CSA.o -frozen 4d8 geomout.o -struct a2c readrtns_CSA.o -info1 4024 gen_rand_conf.o -cntrl 78 unres.o -mpiprivc 2 unres.o -timing 58 unres.o -kutas 4 energy_p_new.o -precomp1 1bda0 unres.o -loc_const 40 local_move.o -contacts1 34cee8 unres.o -alphaa 7df8 readrtns_CSA.o -thread1 1cd0 readrtns_CSA.o -qmeas 6157c unres.o -dipmat 2eec800 unres.o -indices 8040 chainbuild.o -ffield 174 unres.o -vectors 196e0 energy_p_new.o -varin 4ec8 readrtns_CSA.o -csaunits 34 unres.o -contacts_hb 14e59e8 unres.o -contacts e888 unres.o -deriv_scloc 10590 initialize_p.o -secondarys 136 dihed_cons.o -pochodne 731d130 geomout.o -maxgrad a8 energy_p_new.o -send2 5760 readrtns_CSA.o -windows e8c initialize_p.o -gucio 18 MD_A-MTS.o -rotmat 15cc0 unres.o diff --git a/source/unres/src_MD-M-newcorr/compare_s1.F b/source/unres/src_MD-M-newcorr/compare_s1.F deleted file mode 100644 index 4e77c21..0000000 --- a/source/unres/src_MD-M-newcorr/compare_s1.F +++ /dev/null @@ -1,188 +0,0 @@ - subroutine compare_s1(n_thr,num_thread_save,energyx,x, - & icomp,enetbss,coordss,rms_d,modif,iprint) -C This subroutine compares the new conformation, whose variables are in X -C with the previously accumulated conformations whose energies and variables -C are stored in ENETBSS and COORDSS, respectively. The meaning of other -C variables is as follows: -C -C N_THR - on input the previous # of accumulated confs, on output the current -C # of accumulated confs. -C N_REPEAT - an array that indicates how many times the structure has already -C been used to start the reversed-reversing procedure. Addition of -C a new structure replacement of a structure with a similar, but -C lower-energy structure resets the respective entry in N_REPEAT to zero -C I9 - output unit -C ENERGYX,X - the energy and variables of the new conformations. -C ICOMP - comparison result: -C 0 - the new structure is similar to one of the previous ones and does -C not have a remarkably lower energy and is therefore rejected; -C 1 - the new structure is different and is added to the set, because -C there is still room in the COORDSS and ENETBSS arrays; -C 2 - the new structure is different, but higher in energy than any -C previous one and is therefore rejected -C 3 - there is no more room in the COORDSS and ENETBSS arrays, but -C the new structure is lower in energy than at least the highest- -C energy previous structure and therefore replaces it. -C 9 - the new structure is similar to a number of previous structures, -C but has a remarkably lower energy than any of them; therefore -C replaces all these structures; -C MODIF - a logical variable that shows whether to include the new structure -C in the set of accumulated structures - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' -crc include 'COMMON.DEFORM' - include 'COMMON.IOUNITS' -#ifdef UNRES - include 'COMMON.CHAIN' -#endif - - dimension x(maxvar) - dimension x1(maxvar) - double precision przes(3),obrot(3,3) - integer list(max_thread) - logical non_conv,modif - double precision enetbss(max_threadss) - double precision coordss(maxvar,max_threadss) - - nlist=0 -#ifdef UNRES - call var_to_geom(nvar,x) - call chainbuild - do k=1,2*nres - do kk=1,3 - cref(kk,k,1)=c(kk,k) - enddo - enddo -#endif -c write(iout,*)'*ene=',energyx - j=0 - enex_jp=-1.0d+99 - do i=1,n_thr - do k=1,nvar - x1(k)=coordss(k,i) - enddo - if (iprint.gt.3) then - write (iout,*) 'Compare_ss, i=',i - write (iout,*) 'New structure Energy:',energyx - write (iout,'(10f8.3)') (rad2deg*x(k),k=1,nvar) - write (iout,*) 'Template structure Energy:',enetbss(i) - write (iout,'(10f8.3)') (rad2deg*x1(k),k=1,nvar) - endif - -#ifdef UNRES - call var_to_geom(nvar,x1) - call chainbuild -cd write(iout,*)'C and CREF' -cd write(iout,'(i5,3f10.5,5x,3f10.5)')(k,(c(j,k),j=1,3), -cd & (cref(j,k),j=1,3),k=1,nres) - call fitsq(roznica,c(1,1),cref(1,1,1),nres,przes,obrot,non_conv) - if (non_conv) then - print *,'Problems in FITSQ!!!' - print *,'X' - print '(10f8.3)',(x(k),k=1,nvar) - print *,'X1' - print '(10f8.3)',(x1(k),k=1,nvar) - print *,'C and CREF' - print '(i5,3f10.5,5x,3f10.5)',(k,(c(j,k),j=1,3), - & (cref(j,k,1),j=1,3),k=1,nres) - endif - roznica=dsqrt(dabs(roznica)) - iresult = 1 - if (roznica.lt.rms_d) iresult = 0 -#else - energyy=enetbss(i) - call cmprs(x,x1,roznica,energyx,energyy,iresult) -#endif - if (iprint.gt.1) write(iout,'(i5,f10.6,$)') i,roznica -c print '(i5,f8.3)',i,roznica - if(iresult.eq.0) then - nlist = nlist + 1 - list(nlist)=i - if (iprint.gt.1) write(iout,*) - if(energyx.ge.enetbss(i)) then - if (iprint.gt.1) - & write(iout,*)'s*>> structure rejected - same as nr ',i, - & ' RMS',roznica - minimize_s_flag=0 - icomp=0 - go to 1106 - endif - endif - if(energyx.lt.enetbss(i).and.enex_jp.lt.enetbss(i))then - j=i - enex_jp=enetbss(i) - endif - enddo - if (iprint.gt.1) write(iout,*) - if(nlist.gt.0) then - if (modif) then - if (iprint.gt.1) - & write(iout,'(a,i3,$)')'s*>> structure accepted1 - repl nr ', - & list(1) - else - if (iprint.gt.1) - & write(iout,'(a,i3)') - & 's*>> structure accepted1 - would repl nr ',list(1) - endif - icomp=9 - if (.not. modif) goto 1106 - j=list(1) - enetbss(j)=energyx - do i=1,nvar - coordss(i,j)=x(i) - enddo - do j=2,nlist - if (iprint.gt.1) write(iout,'(i3,$)')list(j) - do kk=list(j)+1,nlist - enetbss(kk-1)=enetbss(kk) - do i=1,nvar - coordss(i,kk-1)=coordss(i,kk) - enddo - enddo - enddo - if (iprint.gt.1) write(iout,*) - go to 1106 - endif - if(n_thr.lt.num_thread_save) then - icomp=1 - if (modif) then - if (iprint.gt.1) - & write(iout,*)'s*>> structure accepted - add with nr ',n_thr+1 - else - if (iprint.gt.1) - & write(iout,*)'s*>> structure accepted - would add with nr ', - & n_thr+1 - goto 1106 - endif - n_thr=n_thr+1 - enetbss(n_thr)=energyx - do i=1,nvar - coordss(i,n_thr)=x(i) - enddo - else - if(j.eq.0) then - if (iprint.gt.1) - & write(iout,*)'s*>> structure rejected - too high energy' - icomp=2 - go to 1106 - end if - icomp=3 - if (modif) then - if (iprint.gt.1) - & write(iout,*)'s*>> structure accepted - repl nr ',j - else - if (iprint.gt.1) - & write(iout,*)'s*>> structure accepted - would repl nr ',j - goto 1106 - endif - enetbss(j)=energyx - do i=1,nvar - coordss(i,j)=x(i) - enddo - end if - -1106 continue - return - end diff --git a/source/unres/src_MD-M-newcorr/compinfo.c b/source/unres/src_MD-M-newcorr/compinfo.c deleted file mode 100644 index e28f686..0000000 --- a/source/unres/src_MD-M-newcorr/compinfo.c +++ /dev/null @@ -1,82 +0,0 @@ -#include -#include -#include -#include -#include - -main() -{ -FILE *in, *in1, *out; -int i,j,k,iv1,iv2,iv3; -char *p1,buf[500],buf1[500],buf2[100],buf3[100]; -struct utsname Name; -time_t Tp; - -in=fopen("cinfo.f","r"); -out=fopen("cinfo.f.new","w"); -if (fgets(buf,498,in) != NULL) - fprintf(out,"C DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C\n"); -if (fgets(buf,498,in) != NULL) - sscanf(&buf[1],"%d %d %d",&iv1,&iv2,&iv3); -iv3++; -fprintf(out,"C %d %d %d\n",iv1,iv2,iv3); -fprintf(out," subroutine cinfo\n"); -fprintf(out," include 'COMMON.IOUNITS'\n"); -fprintf(out," write(iout,*)'++++ Compile info ++++'\n"); -fprintf(out," write(iout,*)'Version %d.%-d build %d'\n",iv1,iv2,iv3); -uname(&Name); -time(&Tp); -system("whoami > tmptmp"); -in1=fopen("tmptmp","r"); -if (fscanf(in1,"%s",buf1) != EOF) -{ -p1=ctime(&Tp); -p1[strlen(p1)-1]='\0'; -fprintf(out," write(iout,*)'compiled %s'\n",p1); -fprintf(out," write(iout,*)'compiled by %s@%s'\n",buf1,Name.nodename); -fprintf(out," write(iout,*)'OS name: %s '\n",Name.sysname); -fprintf(out," write(iout,*)'OS release: %s '\n",Name.release); -fprintf(out," write(iout,*)'OS version:',\n"); -fprintf(out," & ' %s '\n",Name.version); -fprintf(out," write(iout,*)'flags:'\n"); -} -system("rm tmptmp"); -fclose(in1); -in1=fopen("Makefile","r"); -while(fgets(buf,498,in1) != NULL) - { - if((p1=strchr(buf,'=')) != NULL && buf[0] != '#') - { - buf[strlen(buf)-1]='\0'; - if(strlen(buf) > 49) - { - buf[47]='\0'; - strcat(buf,"..."); - } - else - { - while(buf[strlen(buf)-1]=='\\') - { - strcat(buf,"\\"); - fprintf(out," write(iout,*)'%s'\n",buf); - if (fgets(buf,498,in1) != NULL) - buf[strlen(buf)-1]='\0'; - if(strlen(buf) > 49) - { - buf[47]='\0'; - strcat(buf,"..."); - } - } - } - - fprintf(out," write(iout,*)'%s'\n",buf); - } - } -fprintf(out," write(iout,*)'++++ End of compile info ++++'\n"); -fprintf(out," return\n"); -fprintf(out," end\n"); -fclose(out); -fclose(in1); -fclose(in); -system("mv cinfo.f.new cinfo.f"); -} diff --git a/source/unres/src_MD-M-newcorr/contact.f b/source/unres/src_MD-M-newcorr/contact.f deleted file mode 100644 index 24b11d6..0000000 --- a/source/unres/src_MD-M-newcorr/contact.f +++ /dev/null @@ -1,195 +0,0 @@ - subroutine contact(lprint,ncont,icont,co) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.NAMES' - real*8 facont /1.569D0/ ! facont = (2/(1-sqrt(1-1/4)))**(1/6) - integer ncont,icont(2,maxcont) - logical lprint - ncont=0 - kkk=3 - do i=nnt+kkk,nct - iti=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 - co = 0.0d0 - do i=1,ncont - co = co + dfloat(iabs(icont(1,i)-icont(2,i))) - enddo - co = co / (nres*ncont) - return - end -c---------------------------------------------------------------------------- - double precision function contact_fract(ncont,ncont_ref, - & icont,icont_ref) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - integer ncont,ncont_ref,icont(2,maxcont),icont_ref(2,maxcont) - nmatch=0 -c print *,'ncont=',ncont,' ncont_ref=',ncont_ref -c write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) -c write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) -c write (iout,'(20i4)') (icont(1,i),i=1,ncont) -c write (iout,'(20i4)') (icont(2,i),i=1,ncont) - do i=1,ncont - do j=1,ncont_ref - if (icont(1,i).eq.icont_ref(1,j) .and. - & icont(2,i).eq.icont_ref(2,j)) nmatch=nmatch+1 - enddo - enddo -c print *,' nmatch=',nmatch -c contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) - contact_fract=dfloat(nmatch)/dfloat(ncont_ref) - return - end -c---------------------------------------------------------------------------- - double precision function contact_fract_nn(ncont,ncont_ref, - & icont,icont_ref) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - integer ncont,ncont_ref,icont(2,maxcont),icont_ref(2,maxcont) - nmatch=0 -c print *,'ncont=',ncont,' ncont_ref=',ncont_ref -c write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) -c write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) -c write (iout,'(20i4)') (icont(1,i),i=1,ncont) -c write (iout,'(20i4)') (icont(2,i),i=1,ncont) - do i=1,ncont - do j=1,ncont_ref - if (icont(1,i).eq.icont_ref(1,j) .and. - & icont(2,i).eq.icont_ref(2,j)) nmatch=nmatch+1 - enddo - enddo -c print *,' nmatch=',nmatch -c contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) - contact_fract_nn=dfloat(ncont-nmatch)/dfloat(ncont) - return - end -c---------------------------------------------------------------------------- - subroutine hairpin(lprint,nharp,iharp) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.NAMES' - integer ncont,icont(2,maxcont) - integer nharp,iharp(4,maxres/3) - logical lprint,not_done - real*8 rcomp /6.0d0/ - ncont=0 - kkk=0 -c print *,'nnt=',nnt,' nct=',nct - do i=nnt,nct-3 - do k=1,3 - c(k,2*nres+1)=0.5d0*(c(k,i)+c(k,i+1)) - enddo - do j=i+2,nct-1 - do k=1,3 - c(k,2*nres+2)=0.5d0*(c(k,j)+c(k,j+1)) - enddo - if (dist(2*nres+1,2*nres+2).lt.rcomp) then - ncont=ncont+1 - icont(1,ncont)=i - icont(2,ncont)=j - endif - enddo - enddo - if (lprint) then - write (iout,'(a)') 'PP contact map:' - do i=1,ncont - i1=icont(1,i) - i2=icont(2,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4)') - & i,restyp(it1),i1,restyp(it2),i2 - enddo - endif -c finding hairpins - nharp=0 - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if (j1.eq.i1+2 .and. i1.gt.nnt .and. j1.lt.nct) then -c write (iout,*) "found turn at ",i1,j1 - ii1=i1 - jj1=j1 - not_done=.true. - do while (not_done) - i1=i1-1 - j1=j1+1 - do j=1,ncont - if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10 - enddo - not_done=.false. - 10 continue -c write (iout,*) i1,j1,not_done - enddo - i1=i1+1 - j1=j1-1 - if (j1-i1.gt.4) then - nharp=nharp+1 - iharp(1,nharp)=i1 - iharp(2,nharp)=j1 - iharp(3,nharp)=ii1 - iharp(4,nharp)=jj1 -c write (iout,*)'nharp',nharp,' iharp',(iharp(k,nharp),k=1,4) - endif - endif - enddo -c do i=1,nharp -c write (iout,*)'i',i,' iharp',(iharp(k,i),k=1,4) -c enddo - if (lprint) then - write (iout,*) "Hairpins:" - do i=1,nharp - i1=iharp(1,i) - j1=iharp(2,i) - ii1=iharp(3,i) - jj1=iharp(4,i) - write (iout,*) - write (iout,'(20(a,i3,1x))') (restyp(itype(k)),k,k=i1,ii1) - write (iout,'(20(a,i3,1x))') (restyp(itype(k)),k,k=j1,jj1,-1) -c do k=jj1,j1,-1 -c write (iout,'(a,i3,$)') restyp(itype(k)),k -c enddo - enddo - endif - return - end -c---------------------------------------------------------------------------- - diff --git a/source/unres/src_MD-M-newcorr/convert.f b/source/unres/src_MD-M-newcorr/convert.f deleted file mode 100644 index dc0cccd..0000000 --- a/source/unres/src_MD-M-newcorr/convert.f +++ /dev/null @@ -1,196 +0,0 @@ - subroutine geom_to_var(n,x) -C -C Transfer the geometry parameters to the variable array. -C The positions of variables are as follows: -C 1. Virtual-bond torsional angles: 1 thru nres-3 -C 2. Virtual-bond valence angles: nres-2 thru 2*nres-5 -C 3. The polar angles alpha of local SC orientation: 2*nres-4 thru -C 2*nres-4+nside -C 4. The torsional angles omega of SC orientation: 2*nres-4+nside+1 -C thru 2*nre-4+2*nside -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - double precision x(n) -cd print *,'nres',nres,' nphi',nphi,' ntheta',ntheta,' nvar',nvar - do i=4,nres - x(i-3)=phi(i) -cd print *,i,i-3,phi(i) - enddo - if (n.eq.nphi) return - do i=3,nres - x(i-2+nphi)=theta(i) -cd print *,i,i-2+nphi,theta(i) - enddo - if (n.eq.nphi+ntheta) return - do i=2,nres-1 - if (ialph(i,1).gt.0) then - x(ialph(i,1))=alph(i) - x(ialph(i,1)+nside)=omeg(i) -cd print *,i,ialph(i,1),ialph(i,1)+nside,alph(i),omeg(i) - endif - enddo - return - end -C-------------------------------------------------------------------- - subroutine var_to_geom(n,x) -C -C Update geometry parameters according to the variable array. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - dimension x(n) - logical change,reduce - change=reduce(x) - if (n.gt.nphi+ntheta) then - do i=1,nside - ii=ialph(i,2) - alph(ii)=x(nphi+ntheta+i) - omeg(ii)=pinorm(x(nphi+ntheta+nside+i)) - enddo - endif - do i=4,nres - phi(i)=x(i-3) - enddo - if (n.eq.nphi) return - do i=3,nres - theta(i)=x(i-2+nphi) - if (theta(i).eq.pi) theta(i)=0.99d0*pi - x(i-2+nphi)=theta(i) - enddo - return - end -c------------------------------------------------------------------------- - logical function convert_side(alphi,omegi) - implicit none - double precision alphi,omegi - double precision pinorm - include 'COMMON.GEO' - convert_side=.false. -C Apply periodicity restrictions. - if (alphi.gt.pi) then - alphi=dwapi-alphi - omegi=pinorm(omegi+pi) - convert_side=.true. - endif - return - end -c------------------------------------------------------------------------- - logical function reduce(x) -C -C Apply periodic restrictions to variables. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - logical zm,zmiana,convert_side - dimension x(nvar) - zmiana=.false. - do i=4,nres - x(i-3)=pinorm(x(i-3)) - enddo - if (nvar.gt.nphi+ntheta) then - do i=1,nside - ii=nphi+ntheta+i - iii=ii+nside - x(ii)=thetnorm(x(ii)) - x(iii)=pinorm(x(iii)) -C Apply periodic restrictions. - zm=convert_side(x(ii),x(iii)) - zmiana=zmiana.or.zm - enddo - endif - if (nvar.eq.nphi) return - do i=3,nres - ii=i-2+nphi - iii=i-3 - x(ii)=dmod(x(ii),dwapi) -C Apply periodic restrictions. - if (x(ii).gt.pi) then - zmiana=.true. - x(ii)=dwapi-x(ii) - if (iii.gt.0) x(iii)=pinorm(x(iii)+pi) - if (i.lt.nres) x(iii+1)=pinorm(x(iii+1)+pi) - ii=ialph(i-1,1) - if (ii.gt.0) then - x(ii)=dmod(pi-x(ii),dwapi) - x(ii+nside)=pinorm(-x(ii+nside)) - zm=convert_side(x(ii),x(ii+nside)) - endif - else if (x(ii).lt.-pi) then - zmiana=.true. - x(ii)=dwapi+x(ii) - ii=ialph(i-1,1) - if (ii.gt.0) then - x(ii)=dmod(pi-x(ii),dwapi) - x(ii+nside)=pinorm(-pi-x(ii+nside)) - zm=convert_side(x(ii),x(ii+nside)) - endif - else if (x(ii).lt.0.0d0) then - zmiana=.true. - x(ii)=-x(ii) - if (iii.gt.0) x(iii)=pinorm(x(iii)+pi) - if (i.lt.nres) x(iii+1)=pinorm(x(iii+1)+pi) - ii=ialph(i-1,1) - if (ii.gt.0) then - x(ii+nside)=pinorm(-x(ii+nside)) - zm=convert_side(x(ii),x(ii+nside)) - endif - endif - enddo - reduce=zmiana - return - end -c-------------------------------------------------------------------------- - double precision function thetnorm(x) -C This function puts x within [0,2Pi]. - implicit none - double precision x,xx - include 'COMMON.GEO' - xx=dmod(x,dwapi) - if (xx.lt.0.0d0) xx=xx+dwapi - if (xx.gt.0.9999d0*pi) xx=0.9999d0*pi - thetnorm=xx - return - end -C-------------------------------------------------------------------- - subroutine var_to_geom_restr(n,xx) -C -C Update geometry parameters according to the variable array. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - dimension x(maxvar),xx(maxvar) - logical change,reduce - - call xx2x(x,xx) - change=reduce(x) - do i=1,nside - ii=ialph(i,2) - alph(ii)=x(nphi+ntheta+i) - omeg(ii)=pinorm(x(nphi+ntheta+nside+i)) - enddo - do i=4,nres - phi(i)=x(i-3) - enddo - do i=3,nres - theta(i)=x(i-2+nphi) - if (theta(i).eq.pi) theta(i)=0.99d0*pi - x(i-2+nphi)=theta(i) - enddo - return - end -c------------------------------------------------------------------------- diff --git a/source/unres/src_MD-M-newcorr/cored.f b/source/unres/src_MD-M-newcorr/cored.f deleted file mode 100644 index 1cf25e5..0000000 --- a/source/unres/src_MD-M-newcorr/cored.f +++ /dev/null @@ -1,3151 +0,0 @@ - subroutine assst(iv, liv, lv, v) -c -c *** assess candidate step (***sol version 2.3) *** -c - integer liv, l - integer iv(liv) - double precision v(lv) -c -c *** purpose *** -c -c this subroutine is called by an unconstrained minimization -c routine to assess the next candidate step. it may recommend one -c of several courses of action, such as accepting the step, recom- -c puting it using the same or a new quadratic model, or halting due -c to convergence or false convergence. see the return code listing -c below. -c -c-------------------------- parameter usage -------------------------- -c -c iv (i/o) integer parameter and scratch vector -- see description -c below of iv values referenced. -c liv (in) length of iv array. -c lv (in) length of v array. -c v (i/o) real parameter and scratch vector -- see description -c below of v values referenced. -c -c *** iv values referenced *** -c -c iv(irc) (i/o) on input for the first step tried in a new iteration, -c iv(irc) should be set to 3 or 4 (the value to which it is -c set when step is definitely to be accepted). on input -c after step has been recomputed, iv(irc) should be -c unchanged since the previous return of assst. -c on output, iv(irc) is a return code having one of the -c following values... -c 1 = switch models or try smaller step. -c 2 = switch models or accept step. -c 3 = accept step and determine v(radfac) by gradient -c tests. -c 4 = accept step, v(radfac) has been determined. -c 5 = recompute step (using the same model). -c 6 = recompute step with radius = v(lmaxs) but do not -c evaulate the objective function. -c 7 = x-convergence (see v(xctol)). -c 8 = relative function convergence (see v(rfctol)). -c 9 = both x- and relative function convergence. -c 10 = absolute function convergence (see v(afctol)). -c 11 = singular convergence (see v(lmaxs)). -c 12 = false convergence (see v(xftol)). -c 13 = iv(irc) was out of range on input. -c return code i has precdence over i+1 for i = 9, 10, 11. -c iv(mlstgd) (i/o) saved value of iv(model). -c iv(model) (i/o) on input, iv(model) should be an integer identifying -c the current quadratic model of the objective function. -c if a previous step yielded a better function reduction, -c then iv(model) will be set to iv(mlstgd) on output. -c iv(nfcall) (in) invocation count for the objective function. -c iv(nfgcal) (i/o) value of iv(nfcall) at step that gave the biggest -c function reduction this iteration. iv(nfgcal) remains -c unchanged until a function reduction is obtained. -c iv(radinc) (i/o) the number of radius increases (or minus the number -c of decreases) so far this iteration. -c iv(restor) (out) set to 1 if v(f) has been restored and x should be -c restored to its initial value, to 2 if x should be saved, -c to 3 if x should be restored from the saved value, and to -c 0 otherwise. -c iv(stage) (i/o) count of the number of models tried so far in the -c current iteration. -c iv(stglim) (in) maximum number of models to consider. -c iv(switch) (out) set to 0 unless a new model is being tried and it -c gives a smaller function value than the previous model, -c in which case assst sets iv(switch) = 1. -c iv(toobig) (in) is nonzero if step was too big (e.g. if it caused -c overflow). -c iv(xirc) (i/o) value that iv(irc) would have in the absence of -c convergence, false convergence, and oversized steps. -c -c *** v values referenced *** -c -c v(afctol) (in) absolute function convergence tolerance. if the -c absolute value of the current function value v(f) is less -c than v(afctol), then assst returns with iv(irc) = 10. -c v(decfac) (in) factor by which to decrease radius when iv(toobig) is -c nonzero. -c v(dstnrm) (in) the 2-norm of d*step. -c v(dstsav) (i/o) value of v(dstnrm) on saved step. -c v(dst0) (in) the 2-norm of d times the newton step (when defined, -c i.e., for v(nreduc) .ge. 0). -c v(f) (i/o) on both input and output, v(f) is the objective func- -c tion value at x. if x is restored to a previous value, -c then v(f) is restored to the corresponding value. -c v(fdif) (out) the function reduction v(f0) - v(f) (for the output -c value of v(f) if an earlier step gave a bigger function -c decrease, and for the input value of v(f) otherwise). -c v(flstgd) (i/o) saved value of v(f). -c v(f0) (in) objective function value at start of iteration. -c v(gtslst) (i/o) value of v(gtstep) on saved step. -c v(gtstep) (in) inner product between step and gradient. -c v(incfac) (in) minimum factor by which to increase radius. -c v(lmaxs) (in) maximum reasonable step size (and initial step bound). -c if the actual function decrease is no more than twice -c what was predicted, if a return with iv(irc) = 7, 8, 9, -c or 10 does not occur, if v(dstnrm) .gt. v(lmaxs), and if -c v(preduc) .le. v(sctol) * abs(v(f0)), then assst re- -c turns with iv(irc) = 11. if so doing appears worthwhile, -c then assst repeats this test with v(preduc) computed for -c a step of length v(lmaxs) (by a return with iv(irc) = 6). -c v(nreduc) (i/o) function reduction predicted by quadratic model for -c newton step. if assst is called with iv(irc) = 6, i.e., -c if v(preduc) has been computed with radius = v(lmaxs) for -c use in the singular convervence test, then v(nreduc) is -c set to -v(preduc) before the latter is restored. -c v(plstgd) (i/o) value of v(preduc) on saved step. -c v(preduc) (i/o) function reduction predicted by quadratic model for -c current step. -c v(radfac) (out) factor to be used in determining the new radius, -c which should be v(radfac)*dst, where dst is either the -c output value of v(dstnrm) or the 2-norm of -c diag(newd)*step for the output value of step and the -c updated version, newd, of the scale vector d. for -c iv(irc) = 3, v(radfac) = 1.0 is returned. -c v(rdfcmn) (in) minimum value for v(radfac) in terms of the input -c value of v(dstnrm) -- suggested value = 0.1. -c v(rdfcmx) (in) maximum value for v(radfac) -- suggested value = 4.0. -c v(reldx) (in) scaled relative change in x caused by step, computed -c (e.g.) by function reldst as -c max (d(i)*abs(x(i)-x0(i)), 1 .le. i .le. p) / -c max (d(i)*(abs(x(i))+abs(x0(i))), 1 .le. i .le. p). -c v(rfctol) (in) relative function convergence tolerance. if the -c actual function reduction is at most twice what was pre- -c dicted and v(nreduc) .le. v(rfctol)*abs(v(f0)), then -c assst returns with iv(irc) = 8 or 9. -c v(stppar) (in) marquardt parameter -- 0 means full newton step. -c v(tuner1) (in) tuning constant used to decide if the function -c reduction was much less than expected. suggested -c value = 0.1. -c v(tuner2) (in) tuning constant used to decide if the function -c reduction was large enough to accept step. suggested -c value = 10**-4. -c v(tuner3) (in) tuning constant used to decide if the radius -c should be increased. suggested value = 0.75. -c v(xctol) (in) x-convergence criterion. if step is a newton step -c (v(stppar) = 0) having v(reldx) .le. v(xctol) and giving -c at most twice the predicted function decrease, then -c assst returns iv(irc) = 7 or 9. -c v(xftol) (in) false convergence tolerance. if step gave no or only -c a small function decrease and v(reldx) .le. v(xftol), -c then assst returns with iv(irc) = 12. -c -c------------------------------- notes ------------------------------- -c -c *** application and usage restrictions *** -c -c this routine is called as part of the nl2sol (nonlinear -c least-squares) package. it may be used in any unconstrained -c minimization solver that uses dogleg, goldfeld-quandt-trotter, -c or levenberg-marquardt steps. -c -c *** algorithm notes *** -c -c see (1) for further discussion of the assessing and model -c switching strategies. while nl2sol considers only two models, -c assst is designed to handle any number of models. -c -c *** usage notes *** -c -c on the first call of an iteration, only the i/o variables -c step, x, iv(irc), iv(model), v(f), v(dstnrm), v(gtstep), and -c v(preduc) need have been initialized. between calls, no i/o -c values execpt step, x, iv(model), v(f) and the stopping toler- -c ances should be changed. -c after a return for convergence or false convergence, one can -c change the stopping tolerances and call assst again, in which -c case the stopping tests will be repeated. -c -c *** references *** -c -c (1) dennis, j.e., jr., gay, d.m., and welsch, r.e. (1981), -c an adaptive nonlinear least-squares algorithm, -c acm trans. math. software, vol. 7, no. 3. -c -c (2) powell, m.j.d. (1970) a fortran subroutine for solving -c systems of nonlinear algebraic equations, in numerical -c methods for nonlinear algebraic equations, edited by -c p. rabinowitz, gordon and breach, london. -c -c *** history *** -c -c john dennis designed much of this routine, starting with -c ideas in (2). roy welsch suggested the model switching strategy. -c david gay and stephen peters cast this subroutine into a more -c portable form (winter 1977), and david gay cast it into its -c present form (fall 1978). -c -c *** general *** -c -c this subroutine was written in connection with research -c supported by the national science foundation under grants -c mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, and -c mcs-7906671. -c -c------------------------ external quantities ------------------------ -c -c *** no external functions and subroutines *** -c -c *** intrinsic functions *** -c/+ - double precision dabs, dmax1 -c/ -c *** no common blocks *** -c -c-------------------------- local variables -------------------------- -c - logical goodx - integer i, nfc - double precision emax, emaxs, gts, rfac1, xmax - double precision half, one, onep2, two, zero -c -c *** subscripts for iv and v *** -c - integer afctol, decfac, dstnrm, dstsav, dst0, f, fdif, flstgd, f0, - 1 gtslst, gtstep, incfac, irc, lmaxs, mlstgd, model, nfcall, - 2 nfgcal, nreduc, plstgd, preduc, radfac, radinc, rdfcmn, - 3 rdfcmx, reldx, restor, rfctol, sctol, stage, stglim, - 4 stppar, switch, toobig, tuner1, tuner2, tuner3, xctol, - 5 xftol, xirc -c -c *** data initializations *** -c -c/6 -c data half/0.5d+0/, one/1.d+0/, onep2/1.2d+0/, two/2.d+0/, -c 1 zero/0.d+0/ -c/7 - parameter (half=0.5d+0, one=1.d+0, onep2=1.2d+0, two=2.d+0, - 1 zero=0.d+0) -c/ -c -c/6 -c data irc/29/, mlstgd/32/, model/5/, nfcall/6/, nfgcal/7/, -c 1 radinc/8/, restor/9/, stage/10/, stglim/11/, switch/12/, -c 2 toobig/2/, xirc/13/ -c/7 - parameter (irc=29, mlstgd=32, model=5, nfcall=6, nfgcal=7, - 1 radinc=8, restor=9, stage=10, stglim=11, switch=12, - 2 toobig=2, xirc=13) -c/ -c/6 -c data afctol/31/, decfac/22/, dstnrm/2/, dst0/3/, dstsav/18/, -c 1 f/10/, fdif/11/, flstgd/12/, f0/13/, gtslst/14/, gtstep/4/, -c 2 incfac/23/, lmaxs/36/, nreduc/6/, plstgd/15/, preduc/7/, -c 3 radfac/16/, rdfcmn/24/, rdfcmx/25/, reldx/17/, rfctol/32/, -c 4 sctol/37/, stppar/5/, tuner1/26/, tuner2/27/, tuner3/28/, -c 5 xctol/33/, xftol/34/ -c/7 - parameter (afctol=31, decfac=22, dstnrm=2, dst0=3, dstsav=18, - 1 f=10, fdif=11, flstgd=12, f0=13, gtslst=14, gtstep=4, - 2 incfac=23, lmaxs=36, nreduc=6, plstgd=15, preduc=7, - 3 radfac=16, rdfcmn=24, rdfcmx=25, reldx=17, rfctol=32, - 4 sctol=37, stppar=5, tuner1=26, tuner2=27, tuner3=28, - 5 xctol=33, xftol=34) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - nfc = iv(nfcall) - iv(switch) = 0 - iv(restor) = 0 - rfac1 = one - goodx = .true. - i = iv(irc) - if (i .ge. 1 .and. i .le. 12) - 1 go to (20,30,10,10,40,280,220,220,220,220,220,170), i - iv(irc) = 13 - go to 999 -c -c *** initialize for new iteration *** -c - 10 iv(stage) = 1 - iv(radinc) = 0 - v(flstgd) = v(f0) - if (iv(toobig) .eq. 0) go to 110 - iv(stage) = -1 - iv(xirc) = i - go to 60 -c -c *** step was recomputed with new model or smaller radius *** -c *** first decide which *** -c - 20 if (iv(model) .ne. iv(mlstgd)) go to 30 -c *** old model retained, smaller radius tried *** -c *** do not consider any more new models this iteration *** - iv(stage) = iv(stglim) - iv(radinc) = -1 - go to 110 -c -c *** a new model is being tried. decide whether to keep it. *** -c - 30 iv(stage) = iv(stage) + 1 -c -c *** now we add the possibiltiy that step was recomputed with *** -c *** the same model, perhaps because of an oversized step. *** -c - 40 if (iv(stage) .gt. 0) go to 50 -c -c *** step was recomputed because it was too big. *** -c - if (iv(toobig) .ne. 0) go to 60 -c -c *** restore iv(stage) and pick up where we left off. *** -c - iv(stage) = -iv(stage) - i = iv(xirc) - go to (20, 30, 110, 110, 70), i -c - 50 if (iv(toobig) .eq. 0) go to 70 -c -c *** handle oversize step *** -c - if (iv(radinc) .gt. 0) go to 80 - iv(stage) = -iv(stage) - iv(xirc) = iv(irc) -c - 60 v(radfac) = v(decfac) - iv(radinc) = iv(radinc) - 1 - iv(irc) = 5 - iv(restor) = 1 - go to 999 -c - 70 if (v(f) .lt. v(flstgd)) go to 110 -c -c *** the new step is a loser. restore old model. *** -c - if (iv(model) .eq. iv(mlstgd)) go to 80 - iv(model) = iv(mlstgd) - iv(switch) = 1 -c -c *** restore step, etc. only if a previous step decreased v(f). -c - 80 if (v(flstgd) .ge. v(f0)) go to 110 - iv(restor) = 1 - v(f) = v(flstgd) - v(preduc) = v(plstgd) - v(gtstep) = v(gtslst) - if (iv(switch) .eq. 0) rfac1 = v(dstnrm) / v(dstsav) - v(dstnrm) = v(dstsav) - nfc = iv(nfgcal) - goodx = .false. -c - 110 v(fdif) = v(f0) - v(f) - if (v(fdif) .gt. v(tuner2) * v(preduc)) go to 140 - if(iv(radinc).gt.0) go to 140 -c -c *** no (or only a trivial) function decrease -c *** -- so try new model or smaller radius -c - if (v(f) .lt. v(f0)) go to 120 - iv(mlstgd) = iv(model) - v(flstgd) = v(f) - v(f) = v(f0) - iv(restor) = 1 - go to 130 - 120 iv(nfgcal) = nfc - 130 iv(irc) = 1 - if (iv(stage) .lt. iv(stglim)) go to 160 - iv(irc) = 5 - iv(radinc) = iv(radinc) - 1 - go to 160 -c -c *** nontrivial function decrease achieved *** -c - 140 iv(nfgcal) = nfc - rfac1 = one - v(dstsav) = v(dstnrm) - if (v(fdif) .gt. v(preduc)*v(tuner1)) go to 190 -c -c *** decrease was much less than predicted -- either change models -c *** or accept step with decreased radius. -c - if (iv(stage) .ge. iv(stglim)) go to 150 -c *** consider switching models *** - iv(irc) = 2 - go to 160 -c -c *** accept step with decreased radius *** -c - 150 iv(irc) = 4 -c -c *** set v(radfac) to fletcher*s decrease factor *** -c - 160 iv(xirc) = iv(irc) - emax = v(gtstep) + v(fdif) - v(radfac) = half * rfac1 - if (emax .lt. v(gtstep)) v(radfac) = rfac1 * dmax1(v(rdfcmn), - 1 half * v(gtstep)/emax) -c -c *** do false convergence test *** -c - 170 if (v(reldx) .le. v(xftol)) go to 180 - iv(irc) = iv(xirc) - if (v(f) .lt. v(f0)) go to 200 - go to 230 -c - 180 iv(irc) = 12 - go to 240 -c -c *** handle good function decrease *** -c - 190 if (v(fdif) .lt. (-v(tuner3) * v(gtstep))) go to 210 -c -c *** increasing radius looks worthwhile. see if we just -c *** recomputed step with a decreased radius or restored step -c *** after recomputing it with a larger radius. -c - if (iv(radinc) .lt. 0) go to 210 - if (iv(restor) .eq. 1) go to 210 -c -c *** we did not. try a longer step unless this was a newton -c *** step. -c - v(radfac) = v(rdfcmx) - gts = v(gtstep) - if (v(fdif) .lt. (half/v(radfac) - one) * gts) - 1 v(radfac) = dmax1(v(incfac), half*gts/(gts + v(fdif))) - iv(irc) = 4 - if (v(stppar) .eq. zero) go to 230 - if (v(dst0) .ge. zero .and. (v(dst0) .lt. two*v(dstnrm) - 1 .or. v(nreduc) .lt. onep2*v(fdif))) go to 230 -c *** step was not a newton step. recompute it with -c *** a larger radius. - iv(irc) = 5 - iv(radinc) = iv(radinc) + 1 -c -c *** save values corresponding to good step *** -c - 200 v(flstgd) = v(f) - iv(mlstgd) = iv(model) - if (iv(restor) .ne. 1) iv(restor) = 2 - v(dstsav) = v(dstnrm) - iv(nfgcal) = nfc - v(plstgd) = v(preduc) - v(gtslst) = v(gtstep) - go to 230 -c -c *** accept step with radius unchanged *** -c - 210 v(radfac) = one - iv(irc) = 3 - go to 230 -c -c *** come here for a restart after convergence *** -c - 220 iv(irc) = iv(xirc) - if (v(dstsav) .ge. zero) go to 240 - iv(irc) = 12 - go to 240 -c -c *** perform convergence tests *** -c - 230 iv(xirc) = iv(irc) - 240 if (iv(restor) .eq. 1 .and. v(flstgd) .lt. v(f0)) iv(restor) = 3 - if (half * v(fdif) .gt. v(preduc)) go to 999 - emax = v(rfctol) * dabs(v(f0)) - emaxs = v(sctol) * dabs(v(f0)) - if (v(dstnrm) .gt. v(lmaxs) .and. v(preduc) .le. emaxs) - 1 iv(irc) = 11 - if (v(dst0) .lt. zero) go to 250 - i = 0 - if ((v(nreduc) .gt. zero .and. v(nreduc) .le. emax) .or. - 1 (v(nreduc) .eq. zero. and. v(preduc) .eq. zero)) i = 2 - if (v(stppar) .eq. zero .and. v(reldx) .le. v(xctol) - 1 .and. goodx) i = i + 1 - if (i .gt. 0) iv(irc) = i + 6 -c -c *** consider recomputing step of length v(lmaxs) for singular -c *** convergence test. -c - 250 if (iv(irc) .gt. 5 .and. iv(irc) .ne. 12) go to 999 - if (v(dstnrm) .gt. v(lmaxs)) go to 260 - if (v(preduc) .ge. emaxs) go to 999 - if (v(dst0) .le. zero) go to 270 - if (half * v(dst0) .le. v(lmaxs)) go to 999 - go to 270 - 260 if (half * v(dstnrm) .le. v(lmaxs)) go to 999 - xmax = v(lmaxs) / v(dstnrm) - if (xmax * (two - xmax) * v(preduc) .ge. emaxs) go to 999 - 270 if (v(nreduc) .lt. zero) go to 290 -c -c *** recompute v(preduc) for use in singular convergence test *** -c - v(gtslst) = v(gtstep) - v(dstsav) = v(dstnrm) - if (iv(irc) .eq. 12) v(dstsav) = -v(dstsav) - v(plstgd) = v(preduc) - i = iv(restor) - iv(restor) = 2 - if (i .eq. 3) iv(restor) = 0 - iv(irc) = 6 - go to 999 -c -c *** perform singular convergence test with recomputed v(preduc) *** -c - 280 v(gtstep) = v(gtslst) - v(dstnrm) = dabs(v(dstsav)) - iv(irc) = iv(xirc) - if (v(dstsav) .le. zero) iv(irc) = 12 - v(nreduc) = -v(preduc) - v(preduc) = v(plstgd) - iv(restor) = 3 - 290 if (-v(nreduc) .le. v(sctol) * dabs(v(f0))) iv(irc) = 11 -c - 999 return -c -c *** last card of assst follows *** - end - subroutine deflt(alg, iv, liv, lv, v) -c -c *** supply ***sol (version 2.3) default values to iv and v *** -c -c *** alg = 1 means regression constants. -c *** alg = 2 means general unconstrained optimization constants. -c - integer liv, l - integer alg, iv(liv) - double precision v(lv) -c - external imdcon, vdflt - integer imdcon -c imdcon... returns machine-dependent integer constants. -c vdflt.... provides default values to v. -c - integer miv, m - integer miniv(2), minv(2) -c -c *** subscripts for iv *** -c - integer algsav, covprt, covreq, dtype, hc, ierr, inith, inits, - 1 ipivot, ivneed, lastiv, lastv, lmat, mxfcal, mxiter, - 2 nfcov, ngcov, nvdflt, outlev, parprt, parsav, perm, - 3 prunit, qrtyp, rdreq, rmat, solprt, statpr, vneed, - 4 vsave, x0prt -c -c *** iv subscript values *** -c -c/6 -c data algsav/51/, covprt/14/, covreq/15/, dtype/16/, hc/71/, -c 1 ierr/75/, inith/25/, inits/25/, ipivot/76/, ivneed/3/, -c 2 lastiv/44/, lastv/45/, lmat/42/, mxfcal/17/, mxiter/18/, -c 3 nfcov/52/, ngcov/53/, nvdflt/50/, outlev/19/, parprt/20/, -c 4 parsav/49/, perm/58/, prunit/21/, qrtyp/80/, rdreq/57/, -c 5 rmat/78/, solprt/22/, statpr/23/, vneed/4/, vsave/60/, -c 6 x0prt/24/ -c/7 - parameter (algsav=51, covprt=14, covreq=15, dtype=16, hc=71, - 1 ierr=75, inith=25, inits=25, ipivot=76, ivneed=3, - 2 lastiv=44, lastv=45, lmat=42, mxfcal=17, mxiter=18, - 3 nfcov=52, ngcov=53, nvdflt=50, outlev=19, parprt=20, - 4 parsav=49, perm=58, prunit=21, qrtyp=80, rdreq=57, - 5 rmat=78, solprt=22, statpr=23, vneed=4, vsave=60, - 6 x0prt=24) -c/ - data miniv(1)/80/, miniv(2)/59/, minv(1)/98/, minv(2)/71/ -c -c------------------------------- body -------------------------------- -c - if (alg .lt. 1 .or. alg .gt. 2) go to 40 - miv = miniv(alg) - if (liv .lt. miv) go to 20 - mv = minv(alg) - if (lv .lt. mv) go to 30 - call vdflt(alg, lv, v) - iv(1) = 12 - iv(algsav) = alg - iv(ivneed) = 0 - iv(lastiv) = miv - iv(lastv) = mv - iv(lmat) = mv + 1 - iv(mxfcal) = 200 - iv(mxiter) = 150 - iv(outlev) = 1 - iv(parprt) = 1 - iv(perm) = miv + 1 - iv(prunit) = imdcon(1) - iv(solprt) = 1 - iv(statpr) = 1 - iv(vneed) = 0 - iv(x0prt) = 1 -c - if (alg .ge. 2) go to 10 -c -c *** regression values -c - iv(covprt) = 3 - iv(covreq) = 1 - iv(dtype) = 1 - iv(hc) = 0 - iv(ierr) = 0 - iv(inits) = 0 - iv(ipivot) = 0 - iv(nvdflt) = 32 - iv(parsav) = 67 - iv(qrtyp) = 1 - iv(rdreq) = 3 - iv(rmat) = 0 - iv(vsave) = 58 - go to 999 -c -c *** general optimization values -c - 10 iv(dtype) = 0 - iv(inith) = 1 - iv(nfcov) = 0 - iv(ngcov) = 0 - iv(nvdflt) = 25 - iv(parsav) = 47 - go to 999 -c - 20 iv(1) = 15 - go to 999 -c - 30 iv(1) = 16 - go to 999 -c - 40 iv(1) = 67 -c - 999 return -c *** last card of deflt follows *** - end - double precision function dotprd(p, x, y) -c -c *** return the inner product of the p-vectors x and y. *** -c - integer p - double precision x(p), y(p) -c - integer i - double precision one, sqteta, t, zero -c/+ - double precision dmax1, dabs -c/ - external rmdcon - double precision rmdcon -c -c *** rmdcon(2) returns a machine-dependent constant, sqteta, which -c *** is slightly larger than the smallest positive number that -c *** can be squared without underflowing. -c -c/6 -c data one/1.d+0/, sqteta/0.d+0/, zero/0.d+0/ -c/7 - parameter (one=1.d+0, zero=0.d+0) - data sqteta/0.d+0/ -c/ -c - dotprd = zero - if (p .le. 0) go to 999 -crc if (sqteta .eq. zero) sqteta = rmdcon(2) - do 20 i = 1, p -crc t = dmax1(dabs(x(i)), dabs(y(i))) -crc if (t .gt. one) go to 10 -crc if (t .lt. sqteta) go to 20 -crc t = (x(i)/sqteta)*y(i) -crc if (dabs(t) .lt. sqteta) go to 20 - 10 dotprd = dotprd + x(i)*y(i) - 20 continue -c - 999 return -c *** last card of dotprd follows *** - end - subroutine itsum(d, g, iv, liv, lv, p, v, x) -c -c *** print iteration summary for ***sol (version 2.3) *** -c -c *** parameter declarations *** -c - integer liv, lv, p - integer iv(liv) - double precision d(p), g(p), v(lv), x(p) -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** local variables *** -c - integer alg, i, iv1, m, nf, ng, ol, pu -c/6 -c real model1(6), model2(6) -c/7 - character*4 model1(6), model2(6) -c/ - double precision nreldf, oldf, preldf, reldf, zero -c -c *** intrinsic functions *** -c/+ - integer iabs - double precision dabs, dmax1 -c/ -c *** no external functions or subroutines *** -c -c *** subscripts for iv and v *** -c - integer algsav, dstnrm, f, fdif, f0, needhd, nfcall, nfcov, ngcov, - 1 ngcall, niter, nreduc, outlev, preduc, prntit, prunit, - 2 reldx, solprt, statpr, stppar, sused, x0prt -c -c *** iv subscript values *** -c -c/6 -c data algsav/51/, needhd/36/, nfcall/6/, nfcov/52/, ngcall/30/, -c 1 ngcov/53/, niter/31/, outlev/19/, prntit/39/, prunit/21/, -c 2 solprt/22/, statpr/23/, sused/64/, x0prt/24/ -c/7 - parameter (algsav=51, needhd=36, nfcall=6, nfcov=52, ngcall=30, - 1 ngcov=53, niter=31, outlev=19, prntit=39, prunit=21, - 2 solprt=22, statpr=23, sused=64, x0prt=24) -c/ -c -c *** v subscript values *** -c -c/6 -c data dstnrm/2/, f/10/, f0/13/, fdif/11/, nreduc/6/, preduc/7/, -c 1 reldx/17/, stppar/5/ -c/7 - parameter (dstnrm=2, f=10, f0=13, fdif=11, nreduc=6, preduc=7, - 1 reldx=17, stppar=5) -c/ -c -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c/6 -c data model1(1)/4h /, model1(2)/4h /, model1(3)/4h /, -c 1 model1(4)/4h /, model1(5)/4h g /, model1(6)/4h s /, -c 2 model2(1)/4h g /, model2(2)/4h s /, model2(3)/4hg-s /, -c 3 model2(4)/4hs-g /, model2(5)/4h-s-g/, model2(6)/4h-g-s/ -c/7 - data model1/' ',' ',' ',' ',' g ',' s '/, - 1 model2/' g ',' s ','g-s ','s-g ','-s-g','-g-s'/ -c/ -c -c------------------------------- body -------------------------------- -c - pu = iv(prunit) - if (pu .eq. 0) go to 999 - iv1 = iv(1) - if (iv1 .gt. 62) iv1 = iv1 - 51 - ol = iv(outlev) - alg = iv(algsav) - if (iv1 .lt. 2 .or. iv1 .gt. 15) go to 370 - if (iv1 .ge. 12) go to 120 - if (iv1 .eq. 2 .and. iv(niter) .eq. 0) go to 390 - if (ol .eq. 0) go to 120 - if (iv1 .ge. 10 .and. iv(prntit) .eq. 0) go to 120 - if (iv1 .gt. 2) go to 10 - iv(prntit) = iv(prntit) + 1 - if (iv(prntit) .lt. iabs(ol)) go to 999 - 10 nf = iv(nfcall) - iabs(iv(nfcov)) - iv(prntit) = 0 - reldf = zero - preldf = zero - oldf = dmax1(dabs(v(f0)), dabs(v(f))) - if (oldf .le. zero) go to 20 - reldf = v(fdif) / oldf - preldf = v(preduc) / oldf - 20 if (ol .gt. 0) go to 60 -c -c *** print short summary line *** -c - if (iv(needhd) .eq. 1 .and. alg .eq. 1) write(pu,30) - 30 format(/10h it nf,6x,1hf,7x,5hreldf,3x,6hpreldf,3x,5hreldx, - 1 2x,13hmodel stppar) - if (iv(needhd) .eq. 1 .and. alg .eq. 2) write(pu,40) - 40 format(/11h it nf,7x,1hf,8x,5hreldf,4x,6hpreldf,4x,5hreldx, - 1 3x,6hstppar) - iv(needhd) = 0 - if (alg .eq. 2) go to 50 - m = iv(sused) - write(pu,100) iv(niter), nf, v(f), reldf, preldf, v(reldx), - 1 model1(m), model2(m), v(stppar) - go to 120 -c - 50 write(pu,110) iv(niter), nf, v(f), reldf, preldf, v(reldx), - 1 v(stppar) - go to 120 -c -c *** print long summary line *** -c - 60 if (iv(needhd) .eq. 1 .and. alg .eq. 1) write(pu,70) - 70 format(/11h it nf,6x,1hf,7x,5hreldf,3x,6hpreldf,3x,5hreldx, - 1 2x,13hmodel stppar,2x,6hd*step,2x,7hnpreldf) - if (iv(needhd) .eq. 1 .and. alg .eq. 2) write(pu,80) - 80 format(/11h it nf,7x,1hf,8x,5hreldf,4x,6hpreldf,4x,5hreldx, - 1 3x,6hstppar,3x,6hd*step,3x,7hnpreldf) - iv(needhd) = 0 - nreldf = zero - if (oldf .gt. zero) nreldf = v(nreduc) / oldf - if (alg .eq. 2) go to 90 - m = iv(sused) - write(pu,100) iv(niter), nf, v(f), reldf, preldf, v(reldx), - 1 model1(m), model2(m), v(stppar), v(dstnrm), nreldf - go to 120 -c - 90 write(pu,110) iv(niter), nf, v(f), reldf, preldf, - 1 v(reldx), v(stppar), v(dstnrm), nreldf - 100 format(i6,i5,d10.3,2d9.2,d8.1,a3,a4,2d8.1,d9.2) - 110 format(i6,i5,d11.3,2d10.2,3d9.1,d10.2) -c - 120 if (iv(statpr) .lt. 0) go to 430 - go to (999, 999, 130, 150, 170, 190, 210, 230, 250, 270, 290, 310, - 1 330, 350, 520), iv1 -c - 130 write(pu,140) - 140 format(/26h ***** x-convergence *****) - go to 430 -c - 150 write(pu,160) - 160 format(/42h ***** relative function convergence *****) - go to 430 -c - 170 write(pu,180) - 180 format(/49h ***** x- and relative function convergence *****) - go to 430 -c - 190 write(pu,200) - 200 format(/42h ***** absolute function convergence *****) - go to 430 -c - 210 write(pu,220) - 220 format(/33h ***** singular convergence *****) - go to 430 -c - 230 write(pu,240) - 240 format(/30h ***** false convergence *****) - go to 430 -c - 250 write(pu,260) - 260 format(/38h ***** function evaluation limit *****) - go to 430 -c - 270 write(pu,280) - 280 format(/28h ***** iteration limit *****) - go to 430 -c - 290 write(pu,300) - 300 format(/18h ***** stopx *****) - go to 430 -c - 310 write(pu,320) - 320 format(/44h ***** initial f(x) cannot be computed *****) -c - go to 390 -c - 330 write(pu,340) - 340 format(/37h ***** bad parameters to assess *****) - go to 999 -c - 350 write(pu,360) - 360 format(/43h ***** gradient could not be computed *****) - if (iv(niter) .gt. 0) go to 480 - go to 390 -c - 370 write(pu,380) iv(1) - 380 format(/14h ***** iv(1) =,i5,6h *****) - go to 999 -c -c *** initial call on itsum *** -c - 390 if (iv(x0prt) .ne. 0) write(pu,400) (i, x(i), d(i), i = 1, p) - 400 format(/23h i initial x(i),8x,4hd(i)//(1x,i5,d17.6,d14.3)) -c *** the following are to avoid undefined variables when the -c *** function evaluation limit is 1... - v(dstnrm) = zero - v(fdif) = zero - v(nreduc) = zero - v(preduc) = zero - v(reldx) = zero - if (iv1 .ge. 12) go to 999 - iv(needhd) = 0 - iv(prntit) = 0 - if (ol .eq. 0) go to 999 - if (ol .lt. 0 .and. alg .eq. 1) write(pu,30) - if (ol .lt. 0 .and. alg .eq. 2) write(pu,40) - if (ol .gt. 0 .and. alg .eq. 1) write(pu,70) - if (ol .gt. 0 .and. alg .eq. 2) write(pu,80) - if (alg .eq. 1) write(pu,410) v(f) - if (alg .eq. 2) write(pu,420) v(f) - 410 format(/11h 0 1,d10.3) -c365 format(/11h 0 1,e11.3) - 420 format(/11h 0 1,d11.3) - go to 999 -c -c *** print various information requested on solution *** -c - 430 iv(needhd) = 1 - if (iv(statpr) .eq. 0) go to 480 - oldf = dmax1(dabs(v(f0)), dabs(v(f))) - preldf = zero - nreldf = zero - if (oldf .le. zero) go to 440 - preldf = v(preduc) / oldf - nreldf = v(nreduc) / oldf - 440 nf = iv(nfcall) - iv(nfcov) - ng = iv(ngcall) - iv(ngcov) - write(pu,450) v(f), v(reldx), nf, ng, preldf, nreldf - 450 format(/9h function,d17.6,8h reldx,d17.3/12h func. evals, - 1 i8,9x,11hgrad. evals,i8/7h preldf,d16.3,6x,7hnpreldf,d15.3) -c - if (iv(nfcov) .gt. 0) write(pu,460) iv(nfcov) - 460 format(/1x,i4,50h extra func. evals for covariance and diagnost - 1ics.) - if (iv(ngcov) .gt. 0) write(pu,470) iv(ngcov) - 470 format(1x,i4,50h extra grad. evals for covariance and diagnosti - 1cs.) -c - 480 if (iv(solprt) .eq. 0) go to 999 - iv(needhd) = 1 - write(pu,490) - 490 format(/22h i final x(i),8x,4hd(i),10x,4hg(i)/) - do 500 i = 1, p - write(pu,510) i, x(i), d(i), g(i) - 500 continue - 510 format(1x,i5,d16.6,2d14.3) - go to 999 -c - 520 write(pu,530) - 530 format(/24h inconsistent dimensions) - 999 return -c *** last card of itsum follows *** - end - subroutine litvmu(n, x, l, y) -c -c *** solve (l**t)*x = y, where l is an n x n lower triangular -c *** matrix stored compactly by rows. x and y may occupy the same -c *** storage. *** -c - integer n -cal double precision x(n), l(1), y(n) - double precision x(n), l(n*(n+1)/2), y(n) - integer i, ii, ij, im1, i0, j, np1 - double precision xi, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - do 10 i = 1, n - 10 x(i) = y(i) - np1 = n + 1 - i0 = n*(n+1)/2 - do 30 ii = 1, n - i = np1 - ii - xi = x(i)/l(i0) - x(i) = xi - if (i .le. 1) go to 999 - i0 = i0 - i - if (xi .eq. zero) go to 30 - im1 = i - 1 - do 20 j = 1, im1 - ij = i0 + j - x(j) = x(j) - xi*l(ij) - 20 continue - 30 continue - 999 return -c *** last card of litvmu follows *** - end - subroutine livmul(n, x, l, y) -c -c *** solve l*x = y, where l is an n x n lower triangular -c *** matrix stored compactly by rows. x and y may occupy the same -c *** storage. *** -c - integer n -cal double precision x(n), l(1), y(n) - double precision x(n), l(n*(n+1)/2), y(n) - external dotprd - double precision dotprd - integer i, j, k - double precision t, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - do 10 k = 1, n - if (y(k) .ne. zero) go to 20 - x(k) = zero - 10 continue - go to 999 - 20 j = k*(k+1)/2 - x(k) = y(k) / l(j) - if (k .ge. n) go to 999 - k = k + 1 - do 30 i = k, n - t = dotprd(i-1, l(j+1), x) - j = j + i - x(i) = (y(i) - t)/l(j) - 30 continue - 999 return -c *** last card of livmul follows *** - end - subroutine parck(alg, d, iv, liv, lv, n, v) -c -c *** check ***sol (version 2.3) parameters, print changed values *** -c -c *** alg = 1 for regression, alg = 2 for general unconstrained opt. -c - integer alg, liv, lv, n - integer iv(liv) - double precision d(n), v(lv) -c - external rmdcon, vcopy, vdflt - double precision rmdcon -c rmdcon -- returns machine-dependent constants. -c vcopy -- copies one vector to another. -c vdflt -- supplies default parameter values to v alone. -c/+ - integer max0 -c/ -c -c *** local variables *** -c - integer i, ii, iv1, j, k, l, m, miv1, miv2, ndfalt, parsv1, pu - integer ijmp, jlim(2), miniv(2), ndflt(2) -c/6 -c integer varnm(2), sh(2) -c real cngd(3), dflt(3), vn(2,34), which(3) -c/7 - character*1 varnm(2), sh(2) - character*4 cngd(3), dflt(3), vn(2,34), which(3) -c/ - double precision big, machep, tiny, vk, vm(34), vx(34), zero -c -c *** iv and v subscripts *** -c - integer algsav, dinit, dtype, dtype0, epslon, inits, ivneed, - 1 lastiv, lastv, lmat, nextiv, nextv, nvdflt, oldn, - 2 parprt, parsav, perm, prunit, vneed -c -c -c/6 -c data algsav/51/, dinit/38/, dtype/16/, dtype0/54/, epslon/19/, -c 1 inits/25/, ivneed/3/, lastiv/44/, lastv/45/, lmat/42/, -c 2 nextiv/46/, nextv/47/, nvdflt/50/, oldn/38/, parprt/20/, -c 3 parsav/49/, perm/58/, prunit/21/, vneed/4/ -c/7 - parameter (algsav=51, dinit=38, dtype=16, dtype0=54, epslon=19, - 1 inits=25, ivneed=3, lastiv=44, lastv=45, lmat=42, - 2 nextiv=46, nextv=47, nvdflt=50, oldn=38, parprt=20, - 3 parsav=49, perm=58, prunit=21, vneed=4) - save big, machep, tiny -c/ -c - data big/0.d+0/, machep/-1.d+0/, tiny/1.d+0/, zero/0.d+0/ -c/6 -c data vn(1,1),vn(2,1)/4hepsl,4hon../ -c data vn(1,2),vn(2,2)/4hphmn,4hfc../ -c data vn(1,3),vn(2,3)/4hphmx,4hfc../ -c data vn(1,4),vn(2,4)/4hdecf,4hac../ -c data vn(1,5),vn(2,5)/4hincf,4hac../ -c data vn(1,6),vn(2,6)/4hrdfc,4hmn../ -c data vn(1,7),vn(2,7)/4hrdfc,4hmx../ -c data vn(1,8),vn(2,8)/4htune,4hr1../ -c data vn(1,9),vn(2,9)/4htune,4hr2../ -c data vn(1,10),vn(2,10)/4htune,4hr3../ -c data vn(1,11),vn(2,11)/4htune,4hr4../ -c data vn(1,12),vn(2,12)/4htune,4hr5../ -c data vn(1,13),vn(2,13)/4hafct,4hol../ -c data vn(1,14),vn(2,14)/4hrfct,4hol../ -c data vn(1,15),vn(2,15)/4hxcto,4hl.../ -c data vn(1,16),vn(2,16)/4hxfto,4hl.../ -c data vn(1,17),vn(2,17)/4hlmax,4h0.../ -c data vn(1,18),vn(2,18)/4hlmax,4hs.../ -c data vn(1,19),vn(2,19)/4hscto,4hl.../ -c data vn(1,20),vn(2,20)/4hdini,4ht.../ -c data vn(1,21),vn(2,21)/4hdtin,4hit../ -c data vn(1,22),vn(2,22)/4hd0in,4hit../ -c data vn(1,23),vn(2,23)/4hdfac,4h..../ -c data vn(1,24),vn(2,24)/4hdltf,4hdc../ -c data vn(1,25),vn(2,25)/4hdltf,4hdj../ -c data vn(1,26),vn(2,26)/4hdelt,4ha0../ -c data vn(1,27),vn(2,27)/4hfuzz,4h..../ -c data vn(1,28),vn(2,28)/4hrlim,4hit../ -c data vn(1,29),vn(2,29)/4hcosm,4hin../ -c data vn(1,30),vn(2,30)/4hhube,4hrc../ -c data vn(1,31),vn(2,31)/4hrspt,4hol../ -c data vn(1,32),vn(2,32)/4hsigm,4hin../ -c data vn(1,33),vn(2,33)/4heta0,4h..../ -c data vn(1,34),vn(2,34)/4hbias,4h..../ -c/7 - data vn(1,1),vn(2,1)/'epsl','on..'/ - data vn(1,2),vn(2,2)/'phmn','fc..'/ - data vn(1,3),vn(2,3)/'phmx','fc..'/ - data vn(1,4),vn(2,4)/'decf','ac..'/ - data vn(1,5),vn(2,5)/'incf','ac..'/ - data vn(1,6),vn(2,6)/'rdfc','mn..'/ - data vn(1,7),vn(2,7)/'rdfc','mx..'/ - data vn(1,8),vn(2,8)/'tune','r1..'/ - data vn(1,9),vn(2,9)/'tune','r2..'/ - data vn(1,10),vn(2,10)/'tune','r3..'/ - data vn(1,11),vn(2,11)/'tune','r4..'/ - data vn(1,12),vn(2,12)/'tune','r5..'/ - data vn(1,13),vn(2,13)/'afct','ol..'/ - data vn(1,14),vn(2,14)/'rfct','ol..'/ - data vn(1,15),vn(2,15)/'xcto','l...'/ - data vn(1,16),vn(2,16)/'xfto','l...'/ - data vn(1,17),vn(2,17)/'lmax','0...'/ - data vn(1,18),vn(2,18)/'lmax','s...'/ - data vn(1,19),vn(2,19)/'scto','l...'/ - data vn(1,20),vn(2,20)/'dini','t...'/ - data vn(1,21),vn(2,21)/'dtin','it..'/ - data vn(1,22),vn(2,22)/'d0in','it..'/ - data vn(1,23),vn(2,23)/'dfac','....'/ - data vn(1,24),vn(2,24)/'dltf','dc..'/ - data vn(1,25),vn(2,25)/'dltf','dj..'/ - data vn(1,26),vn(2,26)/'delt','a0..'/ - data vn(1,27),vn(2,27)/'fuzz','....'/ - data vn(1,28),vn(2,28)/'rlim','it..'/ - data vn(1,29),vn(2,29)/'cosm','in..'/ - data vn(1,30),vn(2,30)/'hube','rc..'/ - data vn(1,31),vn(2,31)/'rspt','ol..'/ - data vn(1,32),vn(2,32)/'sigm','in..'/ - data vn(1,33),vn(2,33)/'eta0','....'/ - data vn(1,34),vn(2,34)/'bias','....'/ -c/ -c - data vm(1)/1.0d-3/, vm(2)/-0.99d+0/, vm(3)/1.0d-3/, vm(4)/1.0d-2/, - 1 vm(5)/1.2d+0/, vm(6)/1.d-2/, vm(7)/1.2d+0/, vm(8)/0.d+0/, - 2 vm(9)/0.d+0/, vm(10)/1.d-3/, vm(11)/-1.d+0/, vm(13)/0.d+0/, - 3 vm(15)/0.d+0/, vm(16)/0.d+0/, vm(19)/0.d+0/, vm(20)/-10.d+0/, - 4 vm(21)/0.d+0/, vm(22)/0.d+0/, vm(23)/0.d+0/, vm(27)/1.01d+0/, - 5 vm(28)/1.d+10/, vm(30)/0.d+0/, vm(31)/0.d+0/, vm(32)/0.d+0/, - 6 vm(34)/0.d+0/ - data vx(1)/0.9d+0/, vx(2)/-1.d-3/, vx(3)/1.d+1/, vx(4)/0.8d+0/, - 1 vx(5)/1.d+2/, vx(6)/0.8d+0/, vx(7)/1.d+2/, vx(8)/0.5d+0/, - 2 vx(9)/0.5d+0/, vx(10)/1.d+0/, vx(11)/1.d+0/, vx(14)/0.1d+0/, - 3 vx(15)/1.d+0/, vx(16)/1.d+0/, vx(19)/1.d+0/, vx(23)/1.d+0/, - 4 vx(24)/1.d+0/, vx(25)/1.d+0/, vx(26)/1.d+0/, vx(27)/1.d+10/, - 5 vx(29)/1.d+0/, vx(31)/1.d+0/, vx(32)/1.d+0/, vx(33)/1.d+0/, - 6 vx(34)/1.d+0/ -c -c/6 -c data varnm(1)/1hp/, varnm(2)/1hn/, sh(1)/1hs/, sh(2)/1hh/ -c data cngd(1),cngd(2),cngd(3)/4h---c,4hhang,4hed v/, -c 1 dflt(1),dflt(2),dflt(3)/4hnond,4hefau,4hlt v/ -c/7 - data varnm(1)/'p'/, varnm(2)/'n'/, sh(1)/'s'/, sh(2)/'h'/ - data cngd(1),cngd(2),cngd(3)/'---c','hang','ed v'/, - 1 dflt(1),dflt(2),dflt(3)/'nond','efau','lt v'/ -c/ - data ijmp/33/, jlim(1)/0/, jlim(2)/24/, ndflt(1)/32/, ndflt(2)/25/ - data miniv(1)/80/, miniv(2)/59/ -c -c............................... body ................................ -c - pu = 0 - if (prunit .le. liv) pu = iv(prunit) - if (alg .lt. 1 .or. alg .gt. 2) go to 340 - if (iv(1) .eq. 0) call deflt(alg, iv, liv, lv, v) - iv1 = iv(1) - if (iv1 .ne. 13 .and. iv1 .ne. 12) go to 10 - miv1 = miniv(alg) - if (perm .le. liv) miv1 = max0(miv1, iv(perm) - 1) - if (ivneed .le. liv) miv2 = miv1 + max0(iv(ivneed), 0) - if (lastiv .le. liv) iv(lastiv) = miv2 - if (liv .lt. miv1) go to 300 - iv(ivneed) = 0 - iv(lastv) = max0(iv(vneed), 0) + iv(lmat) - 1 - iv(vneed) = 0 - if (liv .lt. miv2) go to 300 - if (lv .lt. iv(lastv)) go to 320 - 10 if (alg .eq. iv(algsav)) go to 30 - if (pu .ne. 0) write(pu,20) alg, iv(algsav) - 20 format(/39h the first parameter to deflt should be,i3, - 1 12h rather than,i3) - iv(1) = 82 - go to 999 - 30 if (iv1 .lt. 12 .or. iv1 .gt. 14) go to 60 - if (n .ge. 1) go to 50 - iv(1) = 81 - if (pu .eq. 0) go to 999 - write(pu,40) varnm(alg), n - 40 format(/8h /// bad,a1,2h =,i5) - go to 999 - 50 if (iv1 .ne. 14) iv(nextiv) = iv(perm) - if (iv1 .ne. 14) iv(nextv) = iv(lmat) - if (iv1 .eq. 13) go to 999 - k = iv(parsav) - epslon - call vdflt(alg, lv-k, v(k+1)) - iv(dtype0) = 2 - alg - iv(oldn) = n - which(1) = dflt(1) - which(2) = dflt(2) - which(3) = dflt(3) - go to 110 - 60 if (n .eq. iv(oldn)) go to 80 - iv(1) = 17 - if (pu .eq. 0) go to 999 - write(pu,70) varnm(alg), iv(oldn), n - 70 format(/5h /// ,1a1,14h changed from ,i5,4h to ,i5) - go to 999 -c - 80 if (iv1 .le. 11 .and. iv1 .ge. 1) go to 100 - iv(1) = 80 - if (pu .ne. 0) write(pu,90) iv1 - 90 format(/13h /// iv(1) =,i5,28h should be between 0 and 14.) - go to 999 -c - 100 which(1) = cngd(1) - which(2) = cngd(2) - which(3) = cngd(3) -c - 110 if (iv1 .eq. 14) iv1 = 12 - if (big .gt. tiny) go to 120 - tiny = rmdcon(1) - machep = rmdcon(3) - big = rmdcon(6) - vm(12) = machep - vx(12) = big - vx(13) = big - vm(14) = machep - vm(17) = tiny - vx(17) = big - vm(18) = tiny - vx(18) = big - vx(20) = big - vx(21) = big - vx(22) = big - vm(24) = machep - vm(25) = machep - vm(26) = machep - vx(28) = rmdcon(5) - vm(29) = machep - vx(30) = big - vm(33) = machep - 120 m = 0 - i = 1 - j = jlim(alg) - k = epslon - ndfalt = ndflt(alg) - do 150 l = 1, ndfalt - vk = v(k) - if (vk .ge. vm(i) .and. vk .le. vx(i)) go to 140 - m = k - if (pu .ne. 0) write(pu,130) vn(1,i), vn(2,i), k, vk, - 1 vm(i), vx(i) - 130 format(/6h /// ,2a4,5h.. v(,i2,3h) =,d11.3,7h should, - 1 11h be between,d11.3,4h and,d11.3) - 140 k = k + 1 - i = i + 1 - if (i .eq. j) i = ijmp - 150 continue -c - if (iv(nvdflt) .eq. ndfalt) go to 170 - iv(1) = 51 - if (pu .eq. 0) go to 999 - write(pu,160) iv(nvdflt), ndfalt - 160 format(/13h iv(nvdflt) =,i5,13h rather than ,i5) - go to 999 - 170 if ((iv(dtype) .gt. 0 .or. v(dinit) .gt. zero) .and. iv1 .eq. 12) - 1 go to 200 - do 190 i = 1, n - if (d(i) .gt. zero) go to 190 - m = 18 - if (pu .ne. 0) write(pu,180) i, d(i) - 180 format(/8h /// d(,i3,3h) =,d11.3,19h should be positive) - 190 continue - 200 if (m .eq. 0) go to 210 - iv(1) = m - go to 999 -c - 210 if (pu .eq. 0 .or. iv(parprt) .eq. 0) go to 999 - if (iv1 .ne. 12 .or. iv(inits) .eq. alg-1) go to 230 - m = 1 - write(pu,220) sh(alg), iv(inits) - 220 format(/22h nondefault values..../5h init,a1,14h..... iv(25) =, - 1 i3) - 230 if (iv(dtype) .eq. iv(dtype0)) go to 250 - if (m .eq. 0) write(pu,260) which - m = 1 - write(pu,240) iv(dtype) - 240 format(20h dtype..... iv(16) =,i3) - 250 i = 1 - j = jlim(alg) - k = epslon - l = iv(parsav) - ndfalt = ndflt(alg) - do 290 ii = 1, ndfalt - if (v(k) .eq. v(l)) go to 280 - if (m .eq. 0) write(pu,260) which - 260 format(/1h ,3a4,9halues..../) - m = 1 - write(pu,270) vn(1,i), vn(2,i), k, v(k) - 270 format(1x,2a4,5h.. v(,i2,3h) =,d15.7) - 280 k = k + 1 - l = l + 1 - i = i + 1 - if (i .eq. j) i = ijmp - 290 continue -c - iv(dtype0) = iv(dtype) - parsv1 = iv(parsav) - call vcopy(iv(nvdflt), v(parsv1), v(epslon)) - go to 999 -c - 300 iv(1) = 15 - if (pu .eq. 0) go to 999 - write(pu,310) liv, miv2 - 310 format(/10h /// liv =,i5,17h must be at least,i5) - if (liv .lt. miv1) go to 999 - if (lv .lt. iv(lastv)) go to 320 - go to 999 -c - 320 iv(1) = 16 - if (pu .eq. 0) go to 999 - write(pu,330) lv, iv(lastv) - 330 format(/9h /// lv =,i5,17h must be at least,i5) - go to 999 -c - 340 iv(1) = 67 - if (pu .eq. 0) go to 999 - write(pu,350) alg - 350 format(/10h /// alg =,i5,15h must be 1 or 2) -c - 999 return -c *** last card of parck follows *** - end - double precision function reldst(p, d, x, x0) -c -c *** compute and return relative difference between x and x0 *** -c *** nl2sol version 2.2 *** -c - integer p - double precision d(p), x(p), x0(p) -c/+ - double precision dabs -c/ - integer i - double precision emax, t, xmax, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - emax = zero - xmax = zero - do 10 i = 1, p - t = dabs(d(i) * (x(i) - x0(i))) - if (emax .lt. t) emax = t - t = d(i) * (dabs(x(i)) + dabs(x0(i))) - if (xmax .lt. t) xmax = t - 10 continue - reldst = zero - if (xmax .gt. zero) reldst = emax / xmax - 999 return -c *** last card of reldst follows *** - end -c logical function stopx(idummy) -c *****parameters... -c integer idummy -c -c .................................................................. -c -c *****purpose... -c this function may serve as the stopx (asynchronous interruption) -c function for the nl2sol (nonlinear least-squares) package at -c those installations which do not wish to implement a -c dynamic stopx. -c -c *****algorithm notes... -c at installations where the nl2sol system is used -c interactively, this dummy stopx should be replaced by a -c function that returns .true. if and only if the interrupt -c (break) key has been pressed since the last call on stopx. -c -c .................................................................. -c -c stopx = .false. -c return -c end - subroutine vaxpy(p, w, a, x, y) -c -c *** set w = a*x + y -- w, x, y = p-vectors, a = scalar *** -c - integer p - double precision a, w(p), x(p), y(p) -c - integer i -c - do 10 i = 1, p - 10 w(i) = a*x(i) + y(i) - return - end - subroutine vcopy(p, y, x) -c -c *** set y = x, where x and y are p-vectors *** -c - integer p - double precision x(p), y(p) -c - integer i -c - do 10 i = 1, p - 10 y(i) = x(i) - return - end - subroutine vdflt(alg, lv, v) -c -c *** supply ***sol (version 2.3) default values to v *** -c -c *** alg = 1 means regression constants. -c *** alg = 2 means general unconstrained optimization constants. -c - integer alg, l - double precision v(lv) -c/+ - double precision dmax1 -c/ - external rmdcon - double precision rmdcon -c rmdcon... returns machine-dependent constants -c - double precision machep, mepcrt, one, sqteps, three -c -c *** subscripts for v *** -c - integer afctol, bias, cosmin, decfac, delta0, dfac, dinit, dltfdc, - 1 dltfdj, dtinit, d0init, epslon, eta0, fuzz, huberc, - 2 incfac, lmax0, lmaxs, phmnfc, phmxfc, rdfcmn, rdfcmx, - 3 rfctol, rlimit, rsptol, sctol, sigmin, tuner1, tuner2, - 4 tuner3, tuner4, tuner5, xctol, xftol -c -c/6 -c data one/1.d+0/, three/3.d+0/ -c/7 - parameter (one=1.d+0, three=3.d+0) -c/ -c -c *** v subscript values *** -c -c/6 -c data afctol/31/, bias/43/, cosmin/47/, decfac/22/, delta0/44/, -c 1 dfac/41/, dinit/38/, dltfdc/42/, dltfdj/43/, dtinit/39/, -c 2 d0init/40/, epslon/19/, eta0/42/, fuzz/45/, huberc/48/, -c 3 incfac/23/, lmax0/35/, lmaxs/36/, phmnfc/20/, phmxfc/21/, -c 4 rdfcmn/24/, rdfcmx/25/, rfctol/32/, rlimit/46/, rsptol/49/, -c 5 sctol/37/, sigmin/50/, tuner1/26/, tuner2/27/, tuner3/28/, -c 6 tuner4/29/, tuner5/30/, xctol/33/, xftol/34/ -c/7 - parameter (afctol=31, bias=43, cosmin=47, decfac=22, delta0=44, - 1 dfac=41, dinit=38, dltfdc=42, dltfdj=43, dtinit=39, - 2 d0init=40, epslon=19, eta0=42, fuzz=45, huberc=48, - 3 incfac=23, lmax0=35, lmaxs=36, phmnfc=20, phmxfc=21, - 4 rdfcmn=24, rdfcmx=25, rfctol=32, rlimit=46, rsptol=49, - 5 sctol=37, sigmin=50, tuner1=26, tuner2=27, tuner3=28, - 6 tuner4=29, tuner5=30, xctol=33, xftol=34) -c/ -c -c------------------------------- body -------------------------------- -c - machep = rmdcon(3) - v(afctol) = 1.d-20 - if (machep .gt. 1.d-10) v(afctol) = machep**2 - v(decfac) = 0.5d+0 - sqteps = rmdcon(4) - v(dfac) = 0.6d+0 - v(delta0) = sqteps - v(dtinit) = 1.d-6 - mepcrt = machep ** (one/three) - v(d0init) = 1.d+0 - v(epslon) = 0.1d+0 - v(incfac) = 2.d+0 - v(lmax0) = 1.d+0 - v(lmaxs) = 1.d+0 - v(phmnfc) = -0.1d+0 - v(phmxfc) = 0.1d+0 - v(rdfcmn) = 0.1d+0 - v(rdfcmx) = 4.d+0 - v(rfctol) = dmax1(1.d-10, mepcrt**2) - v(sctol) = v(rfctol) - v(tuner1) = 0.1d+0 - v(tuner2) = 1.d-4 - v(tuner3) = 0.75d+0 - v(tuner4) = 0.5d+0 - v(tuner5) = 0.75d+0 - v(xctol) = sqteps - v(xftol) = 1.d+2 * machep -c - if (alg .ge. 2) go to 10 -c -c *** regression values -c - v(cosmin) = dmax1(1.d-6, 1.d+2 * machep) - v(dinit) = 0.d+0 - v(dltfdc) = mepcrt - v(dltfdj) = sqteps - v(fuzz) = 1.5d+0 - v(huberc) = 0.7d+0 - v(rlimit) = rmdcon(5) - v(rsptol) = 1.d-3 - v(sigmin) = 1.d-4 - go to 999 -c -c *** general optimization values -c - 10 v(bias) = 0.8d+0 - v(dinit) = -1.0d+0 - v(eta0) = 1.0d+3 * machep -c - 999 return -c *** last card of vdflt follows *** - end - subroutine vscopy(p, y, s) -c -c *** set p-vector y to scalar s *** -c - integer p - double precision s, y(p) -c - integer i -c - do 10 i = 1, p - 10 y(i) = s - return - end - double precision function v2norm(p, x) -c -c *** return the 2-norm of the p-vector x, taking *** -c *** care to avoid the most likely underflows. *** -c - integer p - double precision x(p) -c - integer i, j - double precision one, r, scale, sqteta, t, xi, zero -c/+ - double precision dabs, dsqrt -c/ - external rmdcon - double precision rmdcon -c -c/6 -c data one/1.d+0/, zero/0.d+0/ -c/7 - parameter (one=1.d+0, zero=0.d+0) - save sqteta -c/ - data sqteta/0.d+0/ -c - if (p .gt. 0) go to 10 - v2norm = zero - go to 999 - 10 do 20 i = 1, p - if (x(i) .ne. zero) go to 30 - 20 continue - v2norm = zero - go to 999 -c - 30 scale = dabs(x(i)) - if (i .lt. p) go to 40 - v2norm = scale - go to 999 - 40 t = one - if (sqteta .eq. zero) sqteta = rmdcon(2) -c -c *** sqteta is (slightly larger than) the square root of the -c *** smallest positive floating point number on the machine. -c *** the tests involving sqteta are done to prevent underflows. -c - j = i + 1 - do 60 i = j, p - xi = dabs(x(i)) - if (xi .gt. scale) go to 50 - r = xi / scale - if (r .gt. sqteta) t = t + r*r - go to 60 - 50 r = scale / xi - if (r .le. sqteta) r = zero - t = one + t * r*r - scale = xi - 60 continue -c - v2norm = scale * dsqrt(t) - 999 return -c *** last card of v2norm follows *** - end - subroutine humsl(n, d, x, calcf, calcgh, iv, liv, lv, v, - 1 uiparm, urparm, ufparm) -c -c *** minimize general unconstrained objective function using *** -c *** (analytic) gradient and hessian provided by the caller. *** -c - integer liv, lv, n - integer iv(liv), uiparm(1) - double precision d(n), x(n), v(lv), urparm(1) -c dimension v(78 + n*(n+12)), uiparm(*), urparm(*) - external calcf, calcgh, ufparm -c -c------------------------------ discussion --------------------------- -c -c this routine is like sumsl, except that the subroutine para- -c meter calcg of sumsl (which computes the gradient of the objec- -c tive function) is replaced by the subroutine parameter calcgh, -c which computes both the gradient and (lower triangle of the) -c hessian of the objective function. the calling sequence is... -c call calcgh(n, x, nf, g, h, uiparm, urparm, ufparm) -c parameters n, x, nf, g, uiparm, urparm, and ufparm are the same -c as for sumsl, while h is an array of length n*(n+1)/2 in which -c calcgh must store the lower triangle of the hessian at x. start- -c ing at h(1), calcgh must store the hessian entries in the order -c (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ... -c the value printed (by itsum) in the column labelled stppar -c is the levenberg-marquardt used in computing the current step. -c zero means a full newton step. if the special case described in -c ref. 1 is detected, then stppar is negated. the value printed -c in the column labelled npreldf is zero if the current hessian -c is not positive definite. -c it sometimes proves worthwhile to let d be determined from the -c diagonal of the hessian matrix by setting iv(dtype) = 1 and -c v(dinit) = 0. the following iv and v components are relevant... -c -c iv(dtol)..... iv(59) gives the starting subscript in v of the dtol -c array used when d is updated. (iv(dtol) can be -c initialized by calling humsl with iv(1) = 13.) -c iv(dtype).... iv(16) tells how the scale vector d should be chosen. -c iv(dtype) .le. 0 means that d should not be updated, and -c iv(dtype) .ge. 1 means that d should be updated as -c described below with v(dfac). default = 0. -c v(dfac)..... v(41) and the dtol and d0 arrays (see v(dtinit) and -c v(d0init)) are used in updating the scale vector d when -c iv(dtype) .gt. 0. (d is initialized according to -c v(dinit), described in sumsl.) let -c d1(i) = max(sqrt(abs(h(i,i))), v(dfac)*d(i)), -c where h(i,i) is the i-th diagonal element of the current -c hessian. if iv(dtype) = 1, then d(i) is set to d1(i) -c unless d1(i) .lt. dtol(i), in which case d(i) is set to -c max(d0(i), dtol(i)). -c if iv(dtype) .ge. 2, then d is updated during the first -c iteration as for iv(dtype) = 1 (after any initialization -c due to v(dinit)) and is left unchanged thereafter. -c default = 0.6. -c v(dtinit)... v(39), if positive, is the value to which all components -c of the dtol array (see v(dfac)) are initialized. if -c v(dtinit) = 0, then it is assumed that the caller has -c stored dtol in v starting at v(iv(dtol)). -c default = 10**-6. -c v(d0init)... v(40), if positive, is the value to which all components -c of the d0 vector (see v(dfac)) are initialized. if -c v(dfac) = 0, then it is assumed that the caller has -c stored d0 in v starting at v(iv(dtol)+n). default = 1.0. -c -c *** reference *** -c -c 1. gay, d.m. (1981), computing optimal locally constrained steps, -c siam j. sci. statist. comput. 2, pp. 186-197. -c. -c *** general *** -c -c coded by david m. gay (winter 1980). revised sept. 1982. -c this subroutine was written in connection with research supported -c in part by the national science foundation under grants -c mcs-7600324 and mcs-7906671. -c -c---------------------------- declarations --------------------------- -c - external deflt, humit -c -c deflt... provides default input values for iv and v. -c humit... reverse-communication routine that does humsl algorithm. -c - integer g1, h1, iv1, lh, nf - double precision f -c -c *** subscripts for iv *** -c - integer g, h, nextv, nfcall, nfgcal, toobig, vneed -c -c/6 -c data nextv/47/, nfcall/6/, nfgcal/7/, g/28/, h/56/, toobig/2/, -c 1 vneed/4/ -c/7 - parameter (nextv=47, nfcall=6, nfgcal=7, g=28, h=56, toobig=2, - 1 vneed=4) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - lh = n * (n + 1) / 2 - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - if (iv(1) .eq. 12 .or. iv(1) .eq. 13) - 1 iv(vneed) = iv(vneed) + n*(n+3)/2 - iv1 = iv(1) - if (iv1 .eq. 14) go to 10 - if (iv1 .gt. 2 .and. iv1 .lt. 12) go to 10 - g1 = 1 - h1 = 1 - if (iv1 .eq. 12) iv(1) = 13 - go to 20 -c - 10 g1 = iv(g) - h1 = iv(h) -c - 20 call humit(d, f, v(g1), v(h1), iv, lh, liv, lv, n, v, x) - if (iv(1) - 2) 30, 40, 50 -c - 30 nf = iv(nfcall) - call calcf(n, x, nf, f, uiparm, urparm, ufparm) - if (nf .le. 0) iv(toobig) = 1 - go to 20 -c - 40 call calcgh(n, x, iv(nfgcal), v(g1), v(h1), uiparm, urparm, - 1 ufparm) - go to 20 -c - 50 if (iv(1) .ne. 14) go to 999 -c -c *** storage allocation -c - iv(g) = iv(nextv) - iv(h) = iv(g) + n - iv(nextv) = iv(h) + n*(n+1)/2 - if (iv1 .ne. 13) go to 10 -c - 999 return -c *** last card of humsl follows *** - end - subroutine humit(d, fx, g, h, iv, lh, liv, lv, n, v, x) -c -c *** carry out humsl (unconstrained minimization) iterations, using -c *** hessian matrix provided by the caller. -c -c *** parameter declarations *** -c - integer lh, liv, lv, n - integer iv(liv) - double precision d(n), fx, g(n), h(lh), v(lv), x(n) -c -c-------------------------- parameter usage -------------------------- -c -c d.... scale vector. -c fx... function value. -c g.... gradient vector. -c h.... lower triangle of the hessian, stored rowwise. -c iv... integer value array. -c lh... length of h = p*(p+1)/2. -c liv.. length of iv (at least 60). -c lv... length of v (at least 78 + n*(n+21)/2). -c n.... number of variables (components in x and g). -c v.... floating-point value array. -c x.... parameter vector. -c -c *** discussion *** -c -c parameters iv, n, v, and x are the same as the corresponding -c ones to humsl (which see), except that v can be shorter (since -c the part of v that humsl uses for storing g and h is not needed). -c moreover, compared with humsl, iv(1) may have the two additional -c output values 1 and 2, which are explained below, as is the use -c of iv(toobig) and iv(nfgcal). the value iv(g), which is an -c output value from humsl, is not referenced by humit or the -c subroutines it calls. -c -c iv(1) = 1 means the caller should set fx to f(x), the function value -c at x, and call humit again, having changed none of the -c other parameters. an exception occurs if f(x) cannot be -c computed (e.g. if overflow would occur), which may happen -c because of an oversized step. in this case the caller -c should set iv(toobig) = iv(2) to 1, which will cause -c humit to ignore fx and try a smaller step. the para- -c meter nf that humsl passes to calcf (for possible use by -c calcgh) is a copy of iv(nfcall) = iv(6). -c iv(1) = 2 means the caller should set g to g(x), the gradient of f at -c x, and h to the lower triangle of h(x), the hessian of f -c at x, and call humit again, having changed none of the -c other parameters except perhaps the scale vector d. -c the parameter nf that humsl passes to calcg is -c iv(nfgcal) = iv(7). if g(x) and h(x) cannot be evaluated, -c then the caller may set iv(nfgcal) to 0, in which case -c humit will return with iv(1) = 65. -c note -- humit overwrites h with the lower triangle -c of diag(d)**-1 * h(x) * diag(d)**-1. -c. -c *** general *** -c -c coded by david m. gay (winter 1980). revised sept. 1982. -c this subroutine was written in connection with research supported -c in part by the national science foundation under grants -c mcs-7600324 and mcs-7906671. -c -c (see sumsl and humsl for references.) -c -c+++++++++++++++++++++++++++ declarations ++++++++++++++++++++++++++++ -c -c *** local variables *** -c - integer dg1, dummy, i, j, k, l, lstgst, nn1o2, step1, - 1 temp1, w1, x01 - double precision t -c -c *** constants *** -c - double precision one, onep2, zero -c -c *** no intrinsic functions *** -c -c *** external functions and subroutines *** -c - external assst, deflt, dotprd, dupdu, gqtst, itsum, parck, - 1 reldst, slvmul, stopx, vaxpy, vcopy, vscopy, v2norm - logical stopx - double precision dotprd, reldst, v2norm -c -c assst.... assesses candidate step. -c deflt.... provides default iv and v input values. -c dotprd... returns inner product of two vectors. -c dupdu.... updates scale vector d. -c gqtst.... computes optimally locally constrained step. -c itsum.... prints iteration summary and info on initial and final x. -c parck.... checks validity of input iv and v values. -c reldst... computes v(reldx) = relative step size. -c slvmul... multiplies symmetric matrix times vector, given the lower -c triangle of the matrix. -c stopx.... returns .true. if the break key has been pressed. -c vaxpy.... computes scalar times one vector plus another. -c vcopy.... copies one vector to another. -c vscopy... sets all elements of a vector to a scalar. -c v2norm... returns the 2-norm of a vector. -c -c *** subscripts for iv and v *** -c - integer cnvcod, dg, dgnorm, dinit, dstnrm, dtinit, dtol, - 1 dtype, d0init, f, f0, fdif, gtstep, incfac, irc, kagqt, - 2 lmat, lmax0, lmaxs, mode, model, mxfcal, mxiter, nextv, - 3 nfcall, nfgcal, ngcall, niter, preduc, radfac, radinc, - 4 radius, rad0, reldx, restor, step, stglim, stlstg, stppar, - 5 toobig, tuner4, tuner5, vneed, w, xirc, x0 -c -c *** iv subscript values *** -c -c/6 -c data cnvcod/55/, dg/37/, dtol/59/, dtype/16/, irc/29/, kagqt/33/, -c 1 lmat/42/, mode/35/, model/5/, mxfcal/17/, mxiter/18/, -c 2 nextv/47/, nfcall/6/, nfgcal/7/, ngcall/30/, niter/31/, -c 3 radinc/8/, restor/9/, step/40/, stglim/11/, stlstg/41/, -c 4 toobig/2/, vneed/4/, w/34/, xirc/13/, x0/43/ -c/7 - parameter (cnvcod=55, dg=37, dtol=59, dtype=16, irc=29, kagqt=33, - 1 lmat=42, mode=35, model=5, mxfcal=17, mxiter=18, - 2 nextv=47, nfcall=6, nfgcal=7, ngcall=30, niter=31, - 3 radinc=8, restor=9, step=40, stglim=11, stlstg=41, - 4 toobig=2, vneed=4, w=34, xirc=13, x0=43) -c/ -c -c *** v subscript values *** -c -c/6 -c data dgnorm/1/, dinit/38/, dstnrm/2/, dtinit/39/, d0init/40/, -c 1 f/10/, f0/13/, fdif/11/, gtstep/4/, incfac/23/, lmax0/35/, -c 2 lmaxs/36/, preduc/7/, radfac/16/, radius/8/, rad0/9/, -c 3 reldx/17/, stppar/5/, tuner4/29/, tuner5/30/ -c/7 - parameter (dgnorm=1, dinit=38, dstnrm=2, dtinit=39, d0init=40, - 1 f=10, f0=13, fdif=11, gtstep=4, incfac=23, lmax0=35, - 2 lmaxs=36, preduc=7, radfac=16, radius=8, rad0=9, - 3 reldx=17, stppar=5, tuner4=29, tuner5=30) -c/ -c -c/6 -c data one/1.d+0/, onep2/1.2d+0/, zero/0.d+0/ -c/7 - parameter (one=1.d+0, onep2=1.2d+0, zero=0.d+0) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - i = iv(1) - if (i .eq. 1) go to 30 - if (i .eq. 2) go to 40 -c -c *** check validity of iv and v input values *** -c - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - if (iv(1) .eq. 12 .or. iv(1) .eq. 13) - 1 iv(vneed) = iv(vneed) + n*(n+21)/2 + 7 - call parck(2, d, iv, liv, lv, n, v) - i = iv(1) - 2 - if (i .gt. 12) go to 999 - nn1o2 = n * (n + 1) / 2 - if (lh .ge. nn1o2) go to (210,210,210,210,210,210,160,120,160, - 1 10,10,20), i - iv(1) = 66 - go to 350 -c -c *** storage allocation *** -c - 10 iv(dtol) = iv(lmat) + nn1o2 - iv(x0) = iv(dtol) + 2*n - iv(step) = iv(x0) + n - iv(stlstg) = iv(step) + n - iv(dg) = iv(stlstg) + n - iv(w) = iv(dg) + n - iv(nextv) = iv(w) + 4*n + 7 - if (iv(1) .ne. 13) go to 20 - iv(1) = 14 - go to 999 -c -c *** initialization *** -c - 20 iv(niter) = 0 - iv(nfcall) = 1 - iv(ngcall) = 1 - iv(nfgcal) = 1 - iv(mode) = -1 - iv(model) = 1 - iv(stglim) = 1 - iv(toobig) = 0 - iv(cnvcod) = 0 - iv(radinc) = 0 - v(rad0) = zero - v(stppar) = zero - if (v(dinit) .ge. zero) call vscopy(n, d, v(dinit)) - k = iv(dtol) - if (v(dtinit) .gt. zero) call vscopy(n, v(k), v(dtinit)) - k = k + n - if (v(d0init) .gt. zero) call vscopy(n, v(k), v(d0init)) - iv(1) = 1 - go to 999 -c - 30 v(f) = fx - if (iv(mode) .ge. 0) go to 210 - iv(1) = 2 - if (iv(toobig) .eq. 0) go to 999 - iv(1) = 63 - go to 350 -c -c *** make sure gradient could be computed *** -c - 40 if (iv(nfgcal) .ne. 0) go to 50 - iv(1) = 65 - go to 350 -c -c *** update the scale vector d *** -c - 50 dg1 = iv(dg) - if (iv(dtype) .le. 0) go to 70 - k = dg1 - j = 0 - do 60 i = 1, n - j = j + i - v(k) = h(j) - k = k + 1 - 60 continue - call dupdu(d, v(dg1), iv, liv, lv, n, v) -c -c *** compute scaled gradient and its norm *** -c - 70 dg1 = iv(dg) - k = dg1 - do 80 i = 1, n - v(k) = g(i) / d(i) - k = k + 1 - 80 continue - v(dgnorm) = v2norm(n, v(dg1)) -c -c *** compute scaled hessian *** -c - k = 1 - do 100 i = 1, n - t = one / d(i) - do 90 j = 1, i - h(k) = t * h(k) / d(j) - k = k + 1 - 90 continue - 100 continue -c - if (iv(cnvcod) .ne. 0) go to 340 - if (iv(mode) .eq. 0) go to 300 -c -c *** allow first step to have scaled 2-norm at most v(lmax0) *** -c - v(radius) = v(lmax0) -c - iv(mode) = 0 -c -c -c----------------------------- main loop ----------------------------- -c -c -c *** print iteration summary, check iteration limit *** -c - 110 call itsum(d, g, iv, liv, lv, n, v, x) - 120 k = iv(niter) - if (k .lt. iv(mxiter)) go to 130 - iv(1) = 10 - go to 350 -c - 130 iv(niter) = k + 1 -c -c *** initialize for start of next iteration *** -c - dg1 = iv(dg) - x01 = iv(x0) - v(f0) = v(f) - iv(irc) = 4 - iv(kagqt) = -1 -c -c *** copy x to x0 *** -c - call vcopy(n, v(x01), x) -c -c *** update radius *** -c - if (k .eq. 0) go to 150 - step1 = iv(step) - k = step1 - do 140 i = 1, n - v(k) = d(i) * v(k) - k = k + 1 - 140 continue - v(radius) = v(radfac) * v2norm(n, v(step1)) -c -c *** check stopx and function evaluation limit *** -c -C AL 4/30/95 - dummy=iv(nfcall) - 150 if (.not. stopx(dummy)) go to 170 - iv(1) = 11 - go to 180 -c -c *** come here when restarting after func. eval. limit or stopx. -c - 160 if (v(f) .ge. v(f0)) go to 170 - v(radfac) = one - k = iv(niter) - go to 130 -c - 170 if (iv(nfcall) .lt. iv(mxfcal)) go to 190 - iv(1) = 9 - 180 if (v(f) .ge. v(f0)) go to 350 -c -c *** in case of stopx or function evaluation limit with -c *** improved v(f), evaluate the gradient at x. -c - iv(cnvcod) = iv(1) - go to 290 -c -c. . . . . . . . . . . . . compute candidate step . . . . . . . . . . -c - 190 step1 = iv(step) - dg1 = iv(dg) - l = iv(lmat) - w1 = iv(w) - call gqtst(d, v(dg1), h, iv(kagqt), v(l), n, v(step1), v, v(w1)) - if (iv(irc) .eq. 6) go to 210 -c -c *** check whether evaluating f(x0 + step) looks worthwhile *** -c - if (v(dstnrm) .le. zero) go to 210 - if (iv(irc) .ne. 5) go to 200 - if (v(radfac) .le. one) go to 200 - if (v(preduc) .le. onep2 * v(fdif)) go to 210 -c -c *** compute f(x0 + step) *** -c - 200 x01 = iv(x0) - step1 = iv(step) - call vaxpy(n, x, one, v(step1), v(x01)) - iv(nfcall) = iv(nfcall) + 1 - iv(1) = 1 - iv(toobig) = 0 - go to 999 -c -c. . . . . . . . . . . . . assess candidate step . . . . . . . . . . . -c - 210 x01 = iv(x0) - v(reldx) = reldst(n, d, x, v(x01)) - call assst(iv, liv, lv, v) - step1 = iv(step) - lstgst = iv(stlstg) - if (iv(restor) .eq. 1) call vcopy(n, x, v(x01)) - if (iv(restor) .eq. 2) call vcopy(n, v(lstgst), v(step1)) - if (iv(restor) .ne. 3) go to 220 - call vcopy(n, v(step1), v(lstgst)) - call vaxpy(n, x, one, v(step1), v(x01)) - v(reldx) = reldst(n, d, x, v(x01)) -c - 220 k = iv(irc) - go to (230,260,260,260,230,240,250,250,250,250,250,250,330,300), k -c -c *** recompute step with new radius *** -c - 230 v(radius) = v(radfac) * v(dstnrm) - go to 150 -c -c *** compute step of length v(lmaxs) for singular convergence test. -c - 240 v(radius) = v(lmaxs) - go to 190 -c -c *** convergence or false convergence *** -c - 250 iv(cnvcod) = k - 4 - if (v(f) .ge. v(f0)) go to 340 - if (iv(xirc) .eq. 14) go to 340 - iv(xirc) = 14 -c -c. . . . . . . . . . . . process acceptable step . . . . . . . . . . . -c - 260 if (iv(irc) .ne. 3) go to 290 - temp1 = lstgst -c -c *** prepare for gradient tests *** -c *** set temp1 = hessian * step + g(x0) -c *** = diag(d) * (h * step + g(x0)) -c -c use x0 vector as temporary. - k = x01 - do 270 i = 1, n - v(k) = d(i) * v(step1) - k = k + 1 - step1 = step1 + 1 - 270 continue - call slvmul(n, v(temp1), h, v(x01)) - do 280 i = 1, n - v(temp1) = d(i) * v(temp1) + g(i) - temp1 = temp1 + 1 - 280 continue -c -c *** compute gradient and hessian *** -c - 290 iv(ngcall) = iv(ngcall) + 1 - iv(1) = 2 - go to 999 -c - 300 iv(1) = 2 - if (iv(irc) .ne. 3) go to 110 -c -c *** set v(radfac) by gradient tests *** -c - temp1 = iv(stlstg) - step1 = iv(step) -c -c *** set temp1 = diag(d)**-1 * (hessian*step + (g(x0)-g(x))) *** -c - k = temp1 - do 310 i = 1, n - v(k) = (v(k) - g(i)) / d(i) - k = k + 1 - 310 continue -c -c *** do gradient tests *** -c - if (v2norm(n, v(temp1)) .le. v(dgnorm) * v(tuner4)) go to 320 - if (dotprd(n, g, v(step1)) - 1 .ge. v(gtstep) * v(tuner5)) go to 110 - 320 v(radfac) = v(incfac) - go to 110 -c -c. . . . . . . . . . . . . . misc. details . . . . . . . . . . . . . . -c -c *** bad parameters to assess *** -c - 330 iv(1) = 64 - go to 350 -c -c *** print summary of final iteration and other requested items *** -c - 340 iv(1) = iv(cnvcod) - iv(cnvcod) = 0 - 350 call itsum(d, g, iv, liv, lv, n, v, x) -c - 999 return -c -c *** last card of humit follows *** - end - subroutine dupdu(d, hdiag, iv, liv, lv, n, v) -c -c *** update scale vector d for humsl *** -c -c *** parameter declarations *** -c - integer liv, lv, n - integer iv(liv) - double precision d(n), hdiag(n), v(lv) -c -c *** local variables *** -c - integer dtoli, d0i, i - double precision t, vdfac -c -c *** intrinsic functions *** -c/+ - double precision dabs, dmax1, dsqrt -c/ -c *** subscripts for iv and v *** -c - integer dfac, dtol, dtype, niter -c/6 -c data dfac/41/, dtol/59/, dtype/16/, niter/31/ -c/7 - parameter (dfac=41, dtol=59, dtype=16, niter=31) -c/ -c -c------------------------------- body -------------------------------- -c - i = iv(dtype) - if (i .eq. 1) go to 10 - if (iv(niter) .gt. 0) go to 999 -c - 10 dtoli = iv(dtol) - d0i = dtoli + n - vdfac = v(dfac) - do 20 i = 1, n - t = dmax1(dsqrt(dabs(hdiag(i))), vdfac*d(i)) - if (t .lt. v(dtoli)) t = dmax1(v(dtoli), v(d0i)) - d(i) = t - dtoli = dtoli + 1 - d0i = d0i + 1 - 20 continue -c - 999 return -c *** last card of dupdu follows *** - end - subroutine gqtst(d, dig, dihdi, ka, l, p, step, v, w) -c -c *** compute goldfeld-quandt-trotter step by more-hebden technique *** -c *** (nl2sol version 2.2), modified a la more and sorensen *** -c -c *** parameter declarations *** -c - integer ka, p -cal double precision d(p), dig(p), dihdi(1), l(1), v(21), step(p), -cal 1 w(1) - double precision d(p), dig(p), dihdi(p*(p+1)/2), l(p*(p+1)/2), - 1 v(21), step(p),w(4*p+7) -c dimension dihdi(p*(p+1)/2), l(p*(p+1)/2), w(4*p+7) -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** purpose *** -c -c given the (compactly stored) lower triangle of a scaled -c hessian (approximation) and a nonzero scaled gradient vector, -c this subroutine computes a goldfeld-quandt-trotter step of -c approximate length v(radius) by the more-hebden technique. in -c other words, step is computed to (approximately) minimize -c psi(step) = (g**t)*step + 0.5*(step**t)*h*step such that the -c 2-norm of d*step is at most (approximately) v(radius), where -c g is the gradient, h is the hessian, and d is a diagonal -c scale matrix whose diagonal is stored in the parameter d. -c (gqtst assumes dig = d**-1 * g and dihdi = d**-1 * h * d**-1.) -c -c *** parameter description *** -c -c d (in) = the scale vector, i.e. the diagonal of the scale -c matrix d mentioned above under purpose. -c dig (in) = the scaled gradient vector, d**-1 * g. if g = 0, then -c step = 0 and v(stppar) = 0 are returned. -c dihdi (in) = lower triangle of the scaled hessian (approximation), -c i.e., d**-1 * h * d**-1, stored compactly by rows., i.e., -c in the order (1,1), (2,1), (2,2), (3,1), (3,2), etc. -c ka (i/o) = the number of hebden iterations (so far) taken to deter- -c mine step. ka .lt. 0 on input means this is the first -c attempt to determine step (for the present dig and dihdi) -c -- ka is initialized to 0 in this case. output with -c ka = 0 (or v(stppar) = 0) means step = -(h**-1)*g. -c l (i/o) = workspace of length p*(p+1)/2 for cholesky factors. -c p (in) = number of parameters -- the hessian is a p x p matrix. -c step (i/o) = the step computed. -c v (i/o) contains various constants and variables described below. -c w (i/o) = workspace of length 4*p + 6. -c -c *** entries in v *** -c -c v(dgnorm) (i/o) = 2-norm of (d**-1)*g. -c v(dstnrm) (output) = 2-norm of d*step. -c v(dst0) (i/o) = 2-norm of d*(h**-1)*g (for pos. def. h only), or -c overestimate of smallest eigenvalue of (d**-1)*h*(d**-1). -c v(epslon) (in) = max. rel. error allowed for psi(step). for the -c step returned, psi(step) will exceed its optimal value -c by less than -v(epslon)*psi(step). suggested value = 0.1. -c v(gtstep) (out) = inner product between g and step. -c v(nreduc) (out) = psi(-(h**-1)*g) = psi(newton step) (for pos. def. -c h only -- v(nreduc) is set to zero otherwise). -c v(phmnfc) (in) = tol. (together with v(phmxfc)) for accepting step -c (more*s sigma). the error v(dstnrm) - v(radius) must lie -c between v(phmnfc)*v(radius) and v(phmxfc)*v(radius). -c v(phmxfc) (in) (see v(phmnfc).) -c suggested values -- v(phmnfc) = -0.25, v(phmxfc) = 0.5. -c v(preduc) (out) = psi(step) = predicted obj. func. reduction for step. -c v(radius) (in) = radius of current (scaled) trust region. -c v(rad0) (i/o) = value of v(radius) from previous call. -c v(stppar) (i/o) is normally the marquardt parameter, i.e. the alpha -c described below under algorithm notes. if h + alpha*d**2 -c (see algorithm notes) is (nearly) singular, however, -c then v(stppar) = -alpha. -c -c *** usage notes *** -c -c if it is desired to recompute step using a different value of -c v(radius), then this routine may be restarted by calling it -c with all parameters unchanged except v(radius). (this explains -c why step and w are listed as i/o). on an initial call (one with -c ka .lt. 0), step and w need not be initialized and only compo- -c nents v(epslon), v(stppar), v(phmnfc), v(phmxfc), v(radius), and -c v(rad0) of v must be initialized. -c -c *** algorithm notes *** -c -c the desired g-q-t step (ref. 2, 3, 4, 6) satisfies -c (h + alpha*d**2)*step = -g for some nonnegative alpha such that -c h + alpha*d**2 is positive semidefinite. alpha and step are -c computed by a scheme analogous to the one described in ref. 5. -c estimates of the smallest and largest eigenvalues of the hessian -c are obtained from the gerschgorin circle theorem enhanced by a -c simple form of the scaling described in ref. 7. cases in which -c h + alpha*d**2 is nearly (or exactly) singular are handled by -c the technique discussed in ref. 2. in these cases, a step of -c (exact) length v(radius) is returned for which psi(step) exceeds -c its optimal value by less than -v(epslon)*psi(step). the test -c suggested in ref. 6 for detecting the special case is performed -c once two matrix factorizations have been done -- doing so sooner -c seems to degrade the performance of optimization routines that -c call this routine. -c -c *** functions and subroutines called *** -c -c dotprd - returns inner product of two vectors. -c litvmu - applies inverse-transpose of compact lower triang. matrix. -c livmul - applies inverse of compact lower triang. matrix. -c lsqrt - finds cholesky factor (of compactly stored lower triang.). -c lsvmin - returns approx. to min. sing. value of lower triang. matrix. -c rmdcon - returns machine-dependent constants. -c v2norm - returns 2-norm of a vector. -c -c *** references *** -c -c 1. dennis, j.e., gay, d.m., and welsch, r.e. (1981), an adaptive -c nonlinear least-squares algorithm, acm trans. math. -c software, vol. 7, no. 3. -c 2. gay, d.m. (1981), computing optimal locally constrained steps, -c siam j. sci. statist. computing, vol. 2, no. 2, pp. -c 186-197. -c 3. goldfeld, s.m., quandt, r.e., and trotter, h.f. (1966), -c maximization by quadratic hill-climbing, econometrica 34, -c pp. 541-551. -c 4. hebden, m.d. (1973), an algorithm for minimization using exact -c second derivatives, report t.p. 515, theoretical physics -c div., a.e.r.e. harwell, oxon., england. -c 5. more, j.j. (1978), the levenberg-marquardt algorithm, implemen- -c tation and theory, pp.105-116 of springer lecture notes -c in mathematics no. 630, edited by g.a. watson, springer- -c verlag, berlin and new york. -c 6. more, j.j., and sorensen, d.c. (1981), computing a trust region -c step, technical report anl-81-83, argonne national lab. -c 7. varga, r.s. (1965), minimal gerschgorin sets, pacific j. math. 15, -c pp. 719-729. -c -c *** general *** -c -c coded by david m. gay. -c this subroutine was written in connection with research -c supported by the national science foundation under grants -c mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, and -c mcs-7906671. -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** local variables *** -c - logical restrt - integer dggdmx, diag, diag0, dstsav, emax, emin, i, im1, inc, irc, - 1 j, k, kalim, kamin, k1, lk0, phipin, q, q0, uk0, x - double precision alphak, aki, akk, delta, dst, eps, gtsta, lk, - 1 oldphi, phi, phimax, phimin, psifac, rad, radsq, - 2 root, si, sk, sw, t, twopsi, t1, t2, uk, wi -c -c *** constants *** - double precision big, dgxfac, epsfac, four, half, kappa, negone, - 1 one, p001, six, three, two, zero -c -c *** intrinsic functions *** -c/+ - double precision dabs, dmax1, dmin1, dsqrt -c/ -c *** external functions and subroutines *** -c - external dotprd, litvmu, livmul, lsqrt, lsvmin, rmdcon, v2norm - double precision dotprd, lsvmin, rmdcon, v2norm -c -c *** subscripts for v *** -c - integer dgnorm, dstnrm, dst0, epslon, gtstep, stppar, nreduc, - 1 phmnfc, phmxfc, preduc, radius, rad0 -c/6 -c data dgnorm/1/, dstnrm/2/, dst0/3/, epslon/19/, gtstep/4/, -c 1 nreduc/6/, phmnfc/20/, phmxfc/21/, preduc/7/, radius/8/, -c 2 rad0/9/, stppar/5/ -c/7 - parameter (dgnorm=1, dstnrm=2, dst0=3, epslon=19, gtstep=4, - 1 nreduc=6, phmnfc=20, phmxfc=21, preduc=7, radius=8, - 2 rad0=9, stppar=5) -c/ -c -c/6 -c data epsfac/50.0d+0/, four/4.0d+0/, half/0.5d+0/, -c 1 kappa/2.0d+0/, negone/-1.0d+0/, one/1.0d+0/, p001/1.0d-3/, -c 2 six/6.0d+0/, three/3.0d+0/, two/2.0d+0/, zero/0.0d+0/ -c/7 - parameter (epsfac=50.0d+0, four=4.0d+0, half=0.5d+0, - 1 kappa=2.0d+0, negone=-1.0d+0, one=1.0d+0, p001=1.0d-3, - 2 six=6.0d+0, three=3.0d+0, two=2.0d+0, zero=0.0d+0) - save dgxfac -c/ - data big/0.d+0/, dgxfac/0.d+0/ -c -c *** body *** -c -c *** store largest abs. entry in (d**-1)*h*(d**-1) at w(dggdmx). - dggdmx = p + 1 -c *** store gerschgorin over- and underestimates of the largest -c *** and smallest eigenvalues of (d**-1)*h*(d**-1) at w(emax) -c *** and w(emin) respectively. - emax = dggdmx + 1 - emin = emax + 1 -c *** for use in recomputing step, the final values of lk, uk, dst, -c *** and the inverse derivative of more*s phi at 0 (for pos. def. -c *** h) are stored in w(lk0), w(uk0), w(dstsav), and w(phipin) -c *** respectively. - lk0 = emin + 1 - phipin = lk0 + 1 - uk0 = phipin + 1 - dstsav = uk0 + 1 -c *** store diag of (d**-1)*h*(d**-1) in w(diag),...,w(diag0+p). - diag0 = dstsav - diag = diag0 + 1 -c *** store -d*step in w(q),...,w(q0+p). - q0 = diag0 + p - q = q0 + 1 -c *** allocate storage for scratch vector x *** - x = q + p - rad = v(radius) - radsq = rad**2 -c *** phitol = max. error allowed in dst = v(dstnrm) = 2-norm of -c *** d*step. - phimax = v(phmxfc) * rad - phimin = v(phmnfc) * rad - psifac = two * v(epslon) / (three * (four * (v(phmnfc) + one) * - 1 (kappa + one) + kappa + two) * rad**2) -c *** oldphi is used to detect limits of numerical accuracy. if -c *** we recompute step and it does not change, then we accept it. - oldphi = zero - eps = v(epslon) - irc = 0 - restrt = .false. - kalim = ka + 50 -c -c *** start or restart, depending on ka *** -c - if (ka .ge. 0) go to 290 -c -c *** fresh start *** -c - k = 0 - uk = negone - ka = 0 - kalim = 50 - v(dgnorm) = v2norm(p, dig) - v(nreduc) = zero - v(dst0) = zero - kamin = 3 - if (v(dgnorm) .eq. zero) kamin = 0 -c -c *** store diag(dihdi) in w(diag0+1),...,w(diag0+p) *** -c - j = 0 - do 10 i = 1, p - j = j + i - k1 = diag0 + i - w(k1) = dihdi(j) - 10 continue -c -c *** determine w(dggdmx), the largest element of dihdi *** -c - t1 = zero - j = p * (p + 1) / 2 - do 20 i = 1, j - t = dabs(dihdi(i)) - if (t1 .lt. t) t1 = t - 20 continue - w(dggdmx) = t1 -c -c *** try alpha = 0 *** -c - 30 call lsqrt(1, p, l, dihdi, irc) - if (irc .eq. 0) go to 50 -c *** indef. h -- underestimate smallest eigenvalue, use this -c *** estimate to initialize lower bound lk on alpha. - j = irc*(irc+1)/2 - t = l(j) - l(j) = one - do 40 i = 1, irc - 40 w(i) = zero - w(irc) = one - call litvmu(irc, w, l, w) - t1 = v2norm(irc, w) - lk = -t / t1 / t1 - v(dst0) = -lk - if (restrt) go to 210 - go to 70 -c -c *** positive definite h -- compute unmodified newton step. *** - 50 lk = zero - t = lsvmin(p, l, w(q), w(q)) - if (t .ge. one) go to 60 - if (big .le. zero) big = rmdcon(6) - if (v(dgnorm) .ge. t*t*big) go to 70 - 60 call livmul(p, w(q), l, dig) - gtsta = dotprd(p, w(q), w(q)) - v(nreduc) = half * gtsta - call litvmu(p, w(q), l, w(q)) - dst = v2norm(p, w(q)) - v(dst0) = dst - phi = dst - rad - if (phi .le. phimax) go to 260 - if (restrt) go to 210 -c -c *** prepare to compute gerschgorin estimates of largest (and -c *** smallest) eigenvalues. *** -c - 70 k = 0 - do 100 i = 1, p - wi = zero - if (i .eq. 1) go to 90 - im1 = i - 1 - do 80 j = 1, im1 - k = k + 1 - t = dabs(dihdi(k)) - wi = wi + t - w(j) = w(j) + t - 80 continue - 90 w(i) = wi - k = k + 1 - 100 continue -c -c *** (under-)estimate smallest eigenvalue of (d**-1)*h*(d**-1) *** -c - k = 1 - t1 = w(diag) - w(1) - if (p .le. 1) go to 120 - do 110 i = 2, p - j = diag0 + i - t = w(j) - w(i) - if (t .ge. t1) go to 110 - t1 = t - k = i - 110 continue -c - 120 sk = w(k) - j = diag0 + k - akk = w(j) - k1 = k*(k-1)/2 + 1 - inc = 1 - t = zero - do 150 i = 1, p - if (i .eq. k) go to 130 - aki = dabs(dihdi(k1)) - si = w(i) - j = diag0 + i - t1 = half * (akk - w(j) + si - aki) - t1 = t1 + dsqrt(t1*t1 + sk*aki) - if (t .lt. t1) t = t1 - if (i .lt. k) go to 140 - 130 inc = i - 140 k1 = k1 + inc - 150 continue -c - w(emin) = akk - t - uk = v(dgnorm)/rad - w(emin) - if (v(dgnorm) .eq. zero) uk = uk + p001 + p001*uk - if (uk .le. zero) uk = p001 -c -c *** compute gerschgorin (over-)estimate of largest eigenvalue *** -c - k = 1 - t1 = w(diag) + w(1) - if (p .le. 1) go to 170 - do 160 i = 2, p - j = diag0 + i - t = w(j) + w(i) - if (t .le. t1) go to 160 - t1 = t - k = i - 160 continue -c - 170 sk = w(k) - j = diag0 + k - akk = w(j) - k1 = k*(k-1)/2 + 1 - inc = 1 - t = zero - do 200 i = 1, p - if (i .eq. k) go to 180 - aki = dabs(dihdi(k1)) - si = w(i) - j = diag0 + i - t1 = half * (w(j) + si - aki - akk) - t1 = t1 + dsqrt(t1*t1 + sk*aki) - if (t .lt. t1) t = t1 - if (i .lt. k) go to 190 - 180 inc = i - 190 k1 = k1 + inc - 200 continue -c - w(emax) = akk + t - lk = dmax1(lk, v(dgnorm)/rad - w(emax)) -c -c *** alphak = current value of alpha (see alg. notes above). we -c *** use more*s scheme for initializing it. - alphak = dabs(v(stppar)) * v(rad0)/rad -c - if (irc .ne. 0) go to 210 -c -c *** compute l0 for positive definite h *** -c - call livmul(p, w, l, w(q)) - t = v2norm(p, w) - w(phipin) = dst / t / t - lk = dmax1(lk, phi*w(phipin)) -c -c *** safeguard alphak and add alphak*i to (d**-1)*h*(d**-1) *** -c - 210 ka = ka + 1 - if (-v(dst0) .ge. alphak .or. alphak .lt. lk .or. alphak .ge. uk) - 1 alphak = uk * dmax1(p001, dsqrt(lk/uk)) - if (alphak .le. zero) alphak = half * uk - if (alphak .le. zero) alphak = uk - k = 0 - do 220 i = 1, p - k = k + i - j = diag0 + i - dihdi(k) = w(j) + alphak - 220 continue -c -c *** try computing cholesky decomposition *** -c - call lsqrt(1, p, l, dihdi, irc) - if (irc .eq. 0) go to 240 -c -c *** (d**-1)*h*(d**-1) + alphak*i is indefinite -- overestimate -c *** smallest eigenvalue for use in updating lk *** -c - j = (irc*(irc+1))/2 - t = l(j) - l(j) = one - do 230 i = 1, irc - 230 w(i) = zero - w(irc) = one - call litvmu(irc, w, l, w) - t1 = v2norm(irc, w) - lk = alphak - t/t1/t1 - v(dst0) = -lk - go to 210 -c -c *** alphak makes (d**-1)*h*(d**-1) positive definite. -c *** compute q = -d*step, check for convergence. *** -c - 240 call livmul(p, w(q), l, dig) - gtsta = dotprd(p, w(q), w(q)) - call litvmu(p, w(q), l, w(q)) - dst = v2norm(p, w(q)) - phi = dst - rad - if (phi .le. phimax .and. phi .ge. phimin) go to 270 - if (phi .eq. oldphi) go to 270 - oldphi = phi - if (phi .lt. zero) go to 330 -c -c *** unacceptable alphak -- update lk, uk, alphak *** -c - 250 if (ka .ge. kalim) go to 270 -c *** the following dmin1 is necessary because of restarts *** - if (phi .lt. zero) uk = dmin1(uk, alphak) -c *** kamin = 0 only iff the gradient vanishes *** - if (kamin .eq. 0) go to 210 - call livmul(p, w, l, w(q)) - t1 = v2norm(p, w) - alphak = alphak + (phi/t1) * (dst/t1) * (dst/rad) - lk = dmax1(lk, alphak) - go to 210 -c -c *** acceptable step on first try *** -c - 260 alphak = zero -c -c *** successful step in general. compute step = -(d**-1)*q *** -c - 270 do 280 i = 1, p - j = q0 + i - step(i) = -w(j)/d(i) - 280 continue - v(gtstep) = -gtsta - v(preduc) = half * (dabs(alphak)*dst*dst + gtsta) - go to 410 -c -c -c *** restart with new radius *** -c - 290 if (v(dst0) .le. zero .or. v(dst0) - rad .gt. phimax) go to 310 -c -c *** prepare to return newton step *** -c - restrt = .true. - ka = ka + 1 - k = 0 - do 300 i = 1, p - k = k + i - j = diag0 + i - dihdi(k) = w(j) - 300 continue - uk = negone - go to 30 -c - 310 kamin = ka + 3 - if (v(dgnorm) .eq. zero) kamin = 0 - if (ka .eq. 0) go to 50 -c - dst = w(dstsav) - alphak = dabs(v(stppar)) - phi = dst - rad - t = v(dgnorm)/rad - uk = t - w(emin) - if (v(dgnorm) .eq. zero) uk = uk + p001 + p001*uk - if (uk .le. zero) uk = p001 - if (rad .gt. v(rad0)) go to 320 -c -c *** smaller radius *** - lk = zero - if (alphak .gt. zero) lk = w(lk0) - lk = dmax1(lk, t - w(emax)) - if (v(dst0) .gt. zero) lk = dmax1(lk, (v(dst0)-rad)*w(phipin)) - go to 250 -c -c *** bigger radius *** - 320 if (alphak .gt. zero) uk = dmin1(uk, w(uk0)) - lk = dmax1(zero, -v(dst0), t - w(emax)) - if (v(dst0) .gt. zero) lk = dmax1(lk, (v(dst0)-rad)*w(phipin)) - go to 250 -c -c *** decide whether to check for special case... in practice (from -c *** the standpoint of the calling optimization code) it seems best -c *** not to check until a few iterations have failed -- hence the -c *** test on kamin below. -c - 330 delta = alphak + dmin1(zero, v(dst0)) - twopsi = alphak*dst*dst + gtsta - if (ka .ge. kamin) go to 340 -c *** if the test in ref. 2 is satisfied, fall through to handle -c *** the special case (as soon as the more-sorensen test detects -c *** it). - if (delta .ge. psifac*twopsi) go to 370 -c -c *** check for the special case of h + alpha*d**2 (nearly) -c *** singular. use one step of inverse power method with start -c *** from lsvmin to obtain approximate eigenvector corresponding -c *** to smallest eigenvalue of (d**-1)*h*(d**-1). lsvmin returns -c *** x and w with l*w = x. -c - 340 t = lsvmin(p, l, w(x), w) -c -c *** normalize w *** - do 350 i = 1, p - 350 w(i) = t*w(i) -c *** complete current inv. power iter. -- replace w by (l**-t)*w. - call litvmu(p, w, l, w) - t2 = one/v2norm(p, w) - do 360 i = 1, p - 360 w(i) = t2*w(i) - t = t2 * t -c -c *** now w is the desired approximate (unit) eigenvector and -c *** t*x = ((d**-1)*h*(d**-1) + alphak*i)*w. -c - sw = dotprd(p, w(q), w) - t1 = (rad + dst) * (rad - dst) - root = dsqrt(sw*sw + t1) - if (sw .lt. zero) root = -root - si = t1 / (sw + root) -c -c *** the actual test for the special case... -c - if ((t2*si)**2 .le. eps*(dst**2 + alphak*radsq)) go to 380 -c -c *** update upper bound on smallest eigenvalue (when not positive) -c *** (as recommended by more and sorensen) and continue... -c - if (v(dst0) .le. zero) v(dst0) = dmin1(v(dst0), t2**2 - alphak) - lk = dmax1(lk, -v(dst0)) -c -c *** check whether we can hope to detect the special case in -c *** the available arithmetic. accept step as it is if not. -c -c *** if not yet available, obtain machine dependent value dgxfac. - 370 if (dgxfac .eq. zero) dgxfac = epsfac * rmdcon(3) -c - if (delta .gt. dgxfac*w(dggdmx)) go to 250 - go to 270 -c -c *** special case detected... negate alphak to indicate special case -c - 380 alphak = -alphak - v(preduc) = half * twopsi -c -c *** accept current step if adding si*w would lead to a -c *** further relative reduction in psi of less than v(epslon)/3. -c - t1 = zero - t = si*(alphak*sw - half*si*(alphak + t*dotprd(p,w(x),w))) - if (t .lt. eps*twopsi/six) go to 390 - v(preduc) = v(preduc) + t - dst = rad - t1 = -si - 390 do 400 i = 1, p - j = q0 + i - w(j) = t1*w(i) - w(j) - step(i) = w(j) / d(i) - 400 continue - v(gtstep) = dotprd(p, dig, w(q)) -c -c *** save values for use in a possible restart *** -c - 410 v(dstnrm) = dst - v(stppar) = alphak - w(lk0) = lk - w(uk0) = uk - v(rad0) = rad - w(dstsav) = dst -c -c *** restore diagonal of dihdi *** -c - j = 0 - do 420 i = 1, p - j = j + i - k = diag0 + i - dihdi(j) = w(k) - 420 continue -c - 999 return -c -c *** last card of gqtst follows *** - end - subroutine lsqrt(n1, n, l, a, irc) -c -c *** compute rows n1 through n of the cholesky factor l of -c *** a = l*(l**t), where l and the lower triangle of a are both -c *** stored compactly by rows (and may occupy the same storage). -c *** irc = 0 means all went well. irc = j means the leading -c *** principal j x j submatrix of a is not positive definite -- -c *** and l(j*(j+1)/2) contains the (nonpos.) reduced j-th diagonal. -c -c *** parameters *** -c - integer n1, n, irc -cal double precision l(1), a(1) - double precision l(n*(n+1)/2), a(n*(n+1)/2) -c dimension l(n*(n+1)/2), a(n*(n+1)/2) -c -c *** local variables *** -c - integer i, ij, ik, im1, i0, j, jk, jm1, j0, k - double precision t, td, zero -c -c *** intrinsic functions *** -c/+ - double precision dsqrt -c/ -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c -c *** body *** -c - i0 = n1 * (n1 - 1) / 2 - do 50 i = n1, n - td = zero - if (i .eq. 1) go to 40 - j0 = 0 - im1 = i - 1 - do 30 j = 1, im1 - t = zero - if (j .eq. 1) go to 20 - jm1 = j - 1 - do 10 k = 1, jm1 - ik = i0 + k - jk = j0 + k - t = t + l(ik)*l(jk) - 10 continue - 20 ij = i0 + j - j0 = j0 + j - t = (a(ij) - t) / l(j0) - l(ij) = t - td = td + t*t - 30 continue - 40 i0 = i0 + i - t = a(i0) - td - if (t .le. zero) go to 60 - l(i0) = dsqrt(t) - 50 continue -c - irc = 0 - go to 999 -c - 60 l(i0) = t - irc = i -c - 999 return -c -c *** last card of lsqrt *** - end - double precision function lsvmin(p, l, x, y) -c -c *** estimate smallest sing. value of packed lower triang. matrix l -c -c *** parameter declarations *** -c - integer p -cal double precision l(1), x(p), y(p) - double precision l(p*(p+1)/2), x(p), y(p) -c dimension l(p*(p+1)/2) -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** purpose *** -c -c this function returns a good over-estimate of the smallest -c singular value of the packed lower triangular matrix l. -c -c *** parameter description *** -c -c p (in) = the order of l. l is a p x p lower triangular matrix. -c l (in) = array holding the elements of l in row order, i.e. -c l(1,1), l(2,1), l(2,2), l(3,1), l(3,2), l(3,3), etc. -c x (out) if lsvmin returns a positive value, then x is a normalized -c approximate left singular vector corresponding to the -c smallest singular value. this approximation may be very -c crude. if lsvmin returns zero, then some components of x -c are zero and the rest retain their input values. -c y (out) if lsvmin returns a positive value, then y = (l**-1)*x is an -c unnormalized approximate right singular vector correspond- -c ing to the smallest singular value. this approximation -c may be crude. if lsvmin returns zero, then y retains its -c input value. the caller may pass the same vector for x -c and y (nonstandard fortran usage), in which case y over- -c writes x (for nonzero lsvmin returns). -c -c *** algorithm notes *** -c -c the algorithm is based on (1), with the additional provision that -c lsvmin = 0 is returned if the smallest diagonal element of l -c (in magnitude) is not more than the unit roundoff times the -c largest. the algorithm uses a random number generator proposed -c in (4), which passes the spectral test with flying colors -- see -c (2) and (3). -c -c *** subroutines and functions called *** -c -c v2norm - function, returns the 2-norm of a vector. -c -c *** references *** -c -c (1) cline, a., moler, c., stewart, g., and wilkinson, j.h.(1977), -c an estimate for the condition number of a matrix, report -c tm-310, applied math. div., argonne national laboratory. -c -c (2) hoaglin, d.c. (1976), theoretical properties of congruential -c random-number generators -- an empirical view, -c memorandum ns-340, dept. of statistics, harvard univ. -c -c (3) knuth, d.e. (1969), the art of computer programming, vol. 2 -c (seminumerical algorithms), addison-wesley, reading, mass. -c -c (4) smith, c.s. (1971), multiplicative pseudo-random number -c generators with prime modulus, j. assoc. comput. mach. 18, -c pp. 586-593. -c -c *** history *** -c -c designed and coded by david m. gay (winter 1977/summer 1978). -c -c *** general *** -c -c this subroutine was written in connection with research -c supported by the national science foundation under grants -c mcs-7600324, dcr75-10143, 76-14311dss, and mcs76-11989. -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** local variables *** -c - integer i, ii, ix, j, ji, jj, jjj, jm1, j0, pm1 - double precision b, sminus, splus, t, xminus, xplus -c -c *** constants *** -c - double precision half, one, r9973, zero -c -c *** intrinsic functions *** -c/+ - integer mod - real float - double precision dabs -c/ -c *** external functions and subroutines *** -c - external dotprd, v2norm, vaxpy - double precision dotprd, v2norm -c -c/6 -c data half/0.5d+0/, one/1.d+0/, r9973/9973.d+0/, zero/0.d+0/ -c/7 - parameter (half=0.5d+0, one=1.d+0, r9973=9973.d+0, zero=0.d+0) -c/ -c -c *** body *** -c - ix = 2 - pm1 = p - 1 -c -c *** first check whether to return lsvmin = 0 and initialize x *** -c - ii = 0 - j0 = p*pm1/2 - jj = j0 + p - if (l(jj) .eq. zero) go to 110 - ix = mod(3432*ix, 9973) - b = half*(one + float(ix)/r9973) - xplus = b / l(jj) - x(p) = xplus - if (p .le. 1) go to 60 - do 10 i = 1, pm1 - ii = ii + i - if (l(ii) .eq. zero) go to 110 - ji = j0 + i - x(i) = xplus * l(ji) - 10 continue -c -c *** solve (l**t)*x = b, where the components of b have randomly -c *** chosen magnitudes in (.5,1) with signs chosen to make x large. -c -c do j = p-1 to 1 by -1... - do 50 jjj = 1, pm1 - j = p - jjj -c *** determine x(j) in this iteration. note for i = 1,2,...,j -c *** that x(i) holds the current partial sum for row i. - ix = mod(3432*ix, 9973) - b = half*(one + float(ix)/r9973) - xplus = (b - x(j)) - xminus = (-b - x(j)) - splus = dabs(xplus) - sminus = dabs(xminus) - jm1 = j - 1 - j0 = j*jm1/2 - jj = j0 + j - xplus = xplus/l(jj) - xminus = xminus/l(jj) - if (jm1 .eq. 0) go to 30 - do 20 i = 1, jm1 - ji = j0 + i - splus = splus + dabs(x(i) + l(ji)*xplus) - sminus = sminus + dabs(x(i) + l(ji)*xminus) - 20 continue - 30 if (sminus .gt. splus) xplus = xminus - x(j) = xplus -c *** update partial sums *** - if (jm1 .gt. 0) call vaxpy(jm1, x, xplus, l(j0+1), x) - 50 continue -c -c *** normalize x *** -c - 60 t = one/v2norm(p, x) - do 70 i = 1, p - 70 x(i) = t*x(i) -c -c *** solve l*y = x and return lsvmin = 1/twonorm(y) *** -c - do 100 j = 1, p - jm1 = j - 1 - j0 = j*jm1/2 - jj = j0 + j - t = zero - if (jm1 .gt. 0) t = dotprd(jm1, l(j0+1), y) - y(j) = (x(j) - t) / l(jj) - 100 continue -c - lsvmin = one/v2norm(p, y) - go to 999 -c - 110 lsvmin = zero - 999 return -c *** last card of lsvmin follows *** - end - subroutine slvmul(p, y, s, x) -c -c *** set y = s * x, s = p x p symmetric matrix. *** -c *** lower triangle of s stored rowwise. *** -c -c *** parameter declarations *** -c - integer p -cal double precision s(1), x(p), y(p) - double precision s(p*(p+1)/2), x(p), y(p) -c dimension s(p*(p+1)/2) -c -c *** local variables *** -c - integer i, im1, j, k - double precision xi -c -c *** no intrinsic functions *** -c -c *** external function *** -c - external dotprd - double precision dotprd -c -c----------------------------------------------------------------------- -c - j = 1 - do 10 i = 1, p - y(i) = dotprd(i, s(j), x) - j = j + i - 10 continue -c - if (p .le. 1) go to 999 - j = 1 - do 40 i = 2, p - xi = x(i) - im1 = i - 1 - j = j + 1 - do 30 k = 1, im1 - y(k) = y(k) + s(j)*xi - j = j + 1 - 30 continue - 40 continue -c - 999 return -c *** last card of slvmul follows *** - end diff --git a/source/unres/src_MD-M-newcorr/csa.f b/source/unres/src_MD-M-newcorr/csa.f deleted file mode 100644 index 3c2e8e9..0000000 --- a/source/unres/src_MD-M-newcorr/csa.f +++ /dev/null @@ -1,364 +0,0 @@ - subroutine make_array - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.CSA' - -ccccccccccccccccccccccccc -c Level-2: group -ccccccccccccccccccccccccc - - indg=0 - do k=1,numch -ccccccccccccccccccccccccccccccccccccccccc -! Groups the THETAs and the GAMMAs - do j=2,nres-1 - indg=indg+1 - if (j.lt.nres-1) then - ngroup(indg)=2 - else - ngroup(indg)=1 - endif - do i=1,ngroup(indg) - igroup(1,i,indg)=i - igroup(2,i,indg)=j - igroup(3,i,indg)=k - enddo - enddo -ccccccccccccccccccccccccccccccccccccccccc - enddo -! Groups the ALPHAs and the BETAs - do k=1,numch - do j=2,nres-1 - if(itype(j).ne.10) then - indg=indg+1 - ngroup(indg)=2 - do i=1,ngroup(indg) - igroup(1,i,indg)=i+2 - igroup(2,i,indg)=j - igroup(3,i,indg)=k - enddo - endif - enddo - enddo - - ntotgr=indg - write(iout,*) - write(iout,*) "# of groups: ",ntotgr - do i=1,ntotgr - write(iout,41) i,ngroup(i),((igroup(k,j,i),k=1,3),j=1,ngroup(i)) - enddo -! close(iout) - - 40 format(i3,3x,3i3) - 41 format(2i3,3x,6(3i3,2x)) - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine make_ranvar(n,m,idum) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.BANK' -c al m=0 - print *,'HOHOHOHO Make_RanVar!!!!!',n,m - itrial=0 - do while(m.lt.n .and. itrial.le.10000) - itrial=itrial+1 - jeden=1 - call gen_rand_conf(jeden,*10) -! call intout - m=m+1 - do j=2,nres-1 - dihang_in(1,j,1,m)=theta(j+1) - dihang_in(2,j,1,m)=phi(j+2) - dihang_in(3,j,1,m)=alph(j) - dihang_in(4,j,1,m)=omeg(j) - enddo - dihang_in(2,nres-1,1,m)=0.0d0 - goto 20 - 10 write (iout,*) 'Failed to generate conformation #',m+1, - & ' itrial=',itrial - 20 continue - enddo - print *,'Make_RanVar!!!!! m=',m,' itrial=',itrial - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine make_ranvar_reg(n,idum) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.BANK' - include 'COMMON.GEO' - m=0 - print *,'HOHOHOHO Make_RanVar!!!!!' - itrial=0 - do while(m.lt.n .and. itrial.le.10000) - itrial=itrial+1 - jeden=1 - call gen_rand_conf(jeden,*10) -! call intout - m=m+1 - do j=2,nres-1 - dihang_in(1,j,1,m)=theta(j+1) - dihang_in(2,j,1,m)=phi(j+2) - dihang_in(3,j,1,m)=alph(j) - dihang_in(4,j,1,m)=omeg(j) - if(m.le.n*0.1) then - dihang_in(1,j,1,m)=90.0*deg2rad - dihang_in(2,j,1,m)=50.0*deg2rad - endif - enddo - dihang_in(2,nres-1,1,m)=0.0d0 - goto 20 - 10 write (iout,*) 'Failed to generate conformation #',m+1, - & ' itrial=',itrial - 20 continue - enddo - print *,'Make_RanVar!!!!! m=',m,' itrial=',itrial - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine from_pdb(n,idum) -c This subroutine stores the UNRES int variables generated from -c subroutine readpdb into the 1st conformation of in dihang_in. -c Subsequent n-1 conformations of dihang_in have identical values -c of theta and phi as the 1st conformation but random values for -c alph and omeg. -c The array cref (also generated from subroutine readpdb) is stored -c to crefjlee to be used for rmsd calculation in CSA, if necessary. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.BANK' - include 'COMMON.GEO' - - m=1 - do j=2,nres-1 - dihang_in(1,j,1,m)=theta(j+1) - dihang_in(2,j,1,m)=phi(j+2) - dihang_in(3,j,1,m)=alph(j) - dihang_in(4,j,1,m)=omeg(j) - enddo - dihang_in(2,nres-1,1,k)=0.0d0 - - do m=2,n - do k=2,nres-1 - dihang_in(1,k,1,m)=dihang_in(1,k,1,1) - dihang_in(2,k,1,m)=dihang_in(2,k,1,1) - if(dabs(dihang_in(3,k,1,1)).gt.1.d-6) then - dihang_in(3,k,1,m)=90.d0*ran1(idum)+90.d0 - dihang_in(3,k,1,m)=dihang_in(3,k,1,m)*deg2rad - endif - if(dabs(dihang_in(4,k,1,1)).gt.1.d-6) then - dihang_in(4,k,1,m)=360.d0*ran1(idum)-180.d0 - dihang_in(4,k,1,m)=dihang_in(4,k,1,m)*deg2rad - endif - enddo - enddo - -c Store cref to crefjlee (they are in COMMON.CHAIN). - do k=1,2*nres - do kk=1,3 - kkk=1 - crefjlee(kk,k)=cref(kk,k,kkk) - enddo - enddo - - open(icsa_native_int,file=csa_native_int,status="old") - do m=1,n - write(icsa_native_int,*) m,e - write(icsa_native_int,200) - & (dihang_in(1,k,1,m)*rad2deg,k=2,nres-1) - write(icsa_native_int,200) - & (dihang_in(2,k,1,m)*rad2deg,k=2,nres-2) - write(icsa_native_int,200) - & (dihang_in(3,k,1,m)*rad2deg,k=2,nres-1) - write(icsa_native_int,200) - & (dihang_in(4,k,1,m)*rad2deg,k=2,nres-1) - enddo - - do k=1,nres - write(icsa_native_int,200) (crefjlee(i,k),i=1,3) - enddo - close(icsa_native_int) - - 200 format (8f10.4) - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine from_int(n,mm,idum) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.BANK' - include 'COMMON.GEO' - include 'COMMON.CONTACTS' - integer ilen - external ilen - logical fail - double precision energia(0:n_ene) - - open(icsa_native_int,file=csa_native_int,status="old") - read (icsa_native_int,*) - call read_angles(icsa_native_int,*10) - goto 11 - 10 write (iout,'(2a)') "CHUJ NASTAPIL - error in ", - & csa_native_int(:ilen(csa_native_int)) - 11 continue - call intout - do j=2,nres-1 - dihang_in(1,j,1,1)=theta(j+1) - dihang_in(2,j,1,1)=phi(j+2) - dihang_in(3,j,1,1)=alph(j) - dihang_in(4,j,1,1)=omeg(j) - enddo - dihang_in(2,nres-1,1,1)=0.0d0 - -c read(icsa_native_int,*) ind,e -c read(icsa_native_int,200) (dihang_in(1,k,1,1),k=2,nres-1) -c read(icsa_native_int,200) (dihang_in(2,k,1,1),k=2,nres-2) -c read(icsa_native_int,200) (dihang_in(3,k,1,1),k=2,nres-1) -c read(icsa_native_int,200) (dihang_in(4,k,1,1),k=2,nres-1) -c dihang_in(2,nres-1,1,1)=0.d0 - - maxsi=100 - maxcount_fail=100 - - do m=mm+2,n -c do k=2,nres-1 -c dihang_in(1,k,1,m)=dihang_in(1,k,1,1) -c dihang_in(2,k,1,m)=dihang_in(2,k,1,1) -c if(abs(dihang_in(3,k,1,1)).gt.1.d-3) then -c dihang_in(3,k,1,m)=90.d0*ran1(idum)+90.d0 -c endif -c if(abs(dihang_in(4,k,1,1)).gt.1.d-3) then -c dihang_in(4,k,1,m)=360.d0*ran1(idum)-180.d0 -c endif -c enddo -c call intout - fail=.true. - - icount_fail=0 - - DO WHILE (FAIL .AND. ICOUNT_FAIL .LE. MAXCOUNT_FAIL) - - do i=nnt,nct - if (itype(i).ne.10) then -cd print *,'i=',i,' itype=',itype(i),' theta=',theta(i+1) - fail=.true. - ii=0 - do while (fail .and. ii .le. maxsi) - call gen_side(itype(i),theta(i+1),alph(i),omeg(i),fail) - ii = ii+1 - enddo - endif - enddo - call chainbuild - call etotal(energia(0)) - fail = (energia(0).ge.1.0d20) - icount_fail=icount_fail+1 - - ENDDO - - if (icount_fail.gt.maxcount_fail) then - write (iout,*) - & 'Failed to generate non-overlaping near-native conf.', - & m - endif - - do j=2,nres-1 - dihang_in(1,j,1,m)=theta(j+1) - dihang_in(2,j,1,m)=phi(j+2) - dihang_in(3,j,1,m)=alph(j) - dihang_in(4,j,1,m)=omeg(j) - enddo - dihang_in(2,nres-1,1,m)=0.0d0 - enddo - -c do m=1,n -c write(icsa_native_int,*) m,e -c write(icsa_native_int,200) (dihang_in(1,k,1,m),k=2,nres-1) -c write(icsa_native_int,200) (dihang_in(2,k,1,m),k=2,nres-2) -c write(icsa_native_int,200) (dihang_in(3,k,1,m),k=2,nres-1) -c write(icsa_native_int,200) (dihang_in(4,k,1,m),k=2,nres-1) -c enddo -c close(icsa_native_int) - -c do m=mm+2,n -c do i=1,4 -c do j=2,nres-1 -c dihang_in(i,j,1,m)=dihang_in(i,j,1,m)*deg2rad -c enddo -c enddo -c enddo - - call dihang_to_c(dihang_in(1,1,1,1)) - -c Store c to cref (they are in COMMON.CHAIN). - do k=1,2*nres - do kk=1,3 - crefjlee(kk,k)=c(kk,k) - enddo - enddo - - call contact(.true.,ncont_ref,icont_ref,co) - -c do k=1,nres -c write(icsa_native_int,200) (crefjlee(i,k),i=1,3) -c enddo - close(icsa_native_int) - - 200 format (8f10.4) - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine dihang_to_c(aarray) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.VAR' - - dimension aarray(mxang,maxres,mxch) - -c do i=4,nres -c phi(i)=dihang_in(1,i-2,1,1) -c enddo - do i=2,nres-1 - theta(i+1)=aarray(1,i,1) - phi(i+2)=aarray(2,i,1) - alph(i)=aarray(3,i,1) - omeg(i)=aarray(4,i,1) - enddo - - call chainbuild - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc diff --git a/source/unres/src_MD-M-newcorr/diff12.f b/source/unres/src_MD-M-newcorr/diff12.f deleted file mode 100644 index 3d347ed..0000000 --- a/source/unres/src_MD-M-newcorr/diff12.f +++ /dev/null @@ -1,27 +0,0 @@ -cccccccccccccccccccccccccccccccccc - subroutine get_diff12(aarray,barray,diff) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - dimension aarray(mxang,maxres,mxch), - & barray(mxang,maxres,mxch) - - diff=0.d0 - do k=1,numch - do j=2,nres-1 -c do i=1,4 -c do i=1,2 - do i=1,ndiff - dif=rad2deg*dabs(aarray(i,j,k)-barray(i,j,k)) - if(dif.gt.180.) dif=360.-dif - if (dif.gt.diffcut) diff=diff+dif - enddo - enddo - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc diff --git a/source/unres/src_MD-M-newcorr/dihed_cons.F b/source/unres/src_MD-M-newcorr/dihed_cons.F deleted file mode 100644 index 1fb6c53..0000000 --- a/source/unres/src_MD-M-newcorr/dihed_cons.F +++ /dev/null @@ -1,185 +0,0 @@ - subroutine secstrp2dihc - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.BOUNDS' - include 'COMMON.CHAIN' - include 'COMMON.TORCNSTR' - include 'COMMON.IOUNITS' - character*1 secstruc(maxres) - COMMON/SECONDARYS/secstruc - character*80 line - logical errflag - external ilen - -cdr call getenv_loc('SECPREDFIL',secpred) - lenpre=ilen(prefix) - secpred=prefix(:lenpre)//'.spred' - -#if defined(WINIFL) || defined(WINPGI) - open(isecpred,file=secpred,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open(isecpred,file=secpred,status='old',action='read') -#elif (defined G77) - open(isecpred,file=secpred,status='old') -#else - open(isecpred,file=secpred,status='old',readonly) -#endif -C read secondary structure prediction from JPRED here! -! read(isecpred,'(A80)',err=100,end=100) line -! read(line,'(f10.3)',err=110) ftors - read(isecpred,'(f10.3)',err=110) ftors - - write (iout,*) 'FTORS factor =',ftors -! initialize secstruc to any - do i=1,nres - secstruc(i) ='-' - enddo - ndih_constr=0 - ndih_nconstr=0 - - call read_secstr_pred(isecpred,iout,errflag) - if (errflag) then - write(iout,*)'There is a problem with the list of secondary-', - & 'structure prediction' - goto 100 - endif -C 8/13/98 Set limits to generating the dihedral angles - do i=1,nres - phibound(1,i)=-pi - phibound(2,i)=pi - enddo - - ii=0 - do i=1,nres - if ( secstruc(i) .eq. 'H') then -C Helix restraints for this residue - ii=ii+1 - idih_constr(ii)=i - phi0(ii) = 45.0D0*deg2rad - drange(ii)= 5.0D0*deg2rad - phibound(1,i) = phi0(ii)-drange(ii) - phibound(2,i) = phi0(ii)+drange(ii) - else if (secstruc(i) .eq. 'E') then -C strand restraints for this residue - ii=ii+1 - idih_constr(ii)=i - phi0(ii) = 180.0D0*deg2rad - drange(ii)= 5.0D0*deg2rad - phibound(1,i) = phi0(ii)-drange(ii) - phibound(2,i) = phi0(ii)+drange(ii) - else -C no restraints for this residue - ndih_nconstr=ndih_nconstr+1 - idih_nconstr(ndih_nconstr)=i - endif - enddo - ndih_constr=ii - return -100 continue - write(iout,'(A30,A80)')'Error reading file SECPRED',secpred - return - 110 continue - write(iout,'(A20)')'Error reading FTORS' - return - end - - subroutine read_secstr_pred(jin,jout,errors) - - implicit real*8 (a-h,o-z) - INCLUDE 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - character*1 secstruc(maxres) - COMMON/SECONDARYS/secstruc - EXTERNAL ILEN - character*80 line,line1,ucase - logical errflag,errors,blankline - - errors=.false. - read (jin,'(a)') line - write (jout,'(2a)') '> ',line(1:78) - line1=ucase(line) -C Remember that we number full residues starting from 2, then, iseq=1 and iseq=nres -C correspond to the end-groups. ADD to the secondary structure prediction "-" for the -C end-groups in the input file "*.spred" - - iseq=1 - do while (index(line1,'$END').eq.0) -* Override commented lines. - ipos=1 - blankline=.false. - do while (.not.blankline) - line1=' ' - call mykey(line,line1,ipos,blankline,errflag) - if (errflag) write (jout,'(2a)') - & 'Error when reading sequence in line: ',line - errors=errors .or. errflag - if (.not. blankline .and. .not. errflag) then - ipos1=2 - iend=ilen(line1) - if (iseq.le.maxres) then - if (line1(1:1).eq.'-' ) then - secstruc(iseq)=line1(1:1) - else if ( ( ucase(line1(1:1)).eq.'E' ) .or. - & ( ucase(line1(1:1)).eq.'H' ) ) then - secstruc(iseq)=ucase(line1(1:1)) - else - errors=.true. - write (jout,1010) line1(1:1), iseq - goto 80 - endif - else - errors=.true. - write (jout,1000) iseq,maxres - goto 80 - endif - do while (ipos1.le.iend) - - iseq=iseq+1 - il=1 - ipos1=ipos1+1 - if (iseq.le.maxres) then - if (line1(ipos1-1:ipos1-1).eq.'-' ) then - secstruc(iseq)=line1(ipos1-1:ipos1-1) - else if((ucase(line1(ipos1-1:ipos1-1)).eq.'E').or. - & (ucase(line1(ipos1-1:ipos1-1)).eq.'H') ) then - secstruc(iseq)=ucase(line1(ipos1-1:ipos1-1)) - else - errors=.true. - write (jout,1010) line1(ipos1-1:ipos1-1), iseq - goto 80 - endif - else - errors=.true. - write (jout,1000) iseq,maxres - goto 80 - endif - enddo - iseq=iseq+1 - endif - enddo - read (jin,'(a)') line - write (jout,'(2a)') '> ',line(1:78) - line1=ucase(line) - enddo - -cd write (jout,'(10a8)') (sequence(i),i=1,iseq-1) - -cd check whether the found length of the chain is correct. - length_of_chain=iseq-1 - if (length_of_chain .ne. nres) then -! errors=.true. - write (jout,'(a,i4,a,i4,a)') - & 'Error: the number of labels specified in $SEC_STRUC_PRED (' - & ,length_of_chain,') does not match with the number of residues (' - & ,nres,').' - endif - 80 continue - - 1000 format('Error - the number of residues (',i4, - & ') has exceeded maximum (',i4,').') - 1010 format ('Error - unrecognized secondary structure label',a4, - & ' in position',i4) - return - end diff --git a/source/unres/src_MD-M-newcorr/distfit.f b/source/unres/src_MD-M-newcorr/distfit.f deleted file mode 100644 index 80e8fe4..0000000 --- a/source/unres/src_MD-M-newcorr/distfit.f +++ /dev/null @@ -1,207 +0,0 @@ - subroutine distfit(debug,maxit) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - DIMENSION X(MAXRES),DIAGH(MAXRES),phiold(maxres) - logical debug,sing - -cinput------------------------------------ -c NX=NRES-3 -c NY=((NRES-4)*(NRES-5))/2 -cinput------------------------------------ -ctest MAXIT=20 - TOL=0.5 - MAXMAR=10 - RL=100.0 - - CALL TRANSFER(NRES,phi,phiold) - - F0=RDIF() - -cd WRITE (IOUT,*) 'DISTFIT: F0=',F0 - - - DO IT=1,MAXIT - CALL RDERIV - CALL HEVAL - - DO I=1,NX - DIAGH(I)=H(I,I) - ENDDO - RL=RL*0.1 - - DO IMAR=1,MAXMAR - DO I=1,NX - H(I,I)=DIAGH(I)+RL - ENDDO - CALL TRANSFER(NX,XX,X) - CALL BANACH(NX,MAXRES,H,X,sing) - AIN=0.0 - DO I=1,NX - AIN=AIN+DABS(X(I)) - ENDDO - IF (AIN.LT.0.1*TOL .AND. RL.LT.1.0E-4) THEN - if (debug) then - WRITE (IOUT,*) 'DISTFIT: CONVERGENCE HAS BEEN ACHIEVED' - WRITE (IOUT,*) 'IT=',it,'F=',F0 - endif - RETURN - ENDIF - DO I=4,NRES - phi(I)=phiold(I)+mask(i)*X(I-3) -c print *,X(I-3) - ENDDO - - F1=RDIF() -cd WRITE (IOUT,*) 'IMAR=',IMAR,' RL=',RL,' F1=',F1 - IF (F1.LT.F0) THEN - CALL TRANSFER(NRES,phi,phiold) - F0=F1 - GOTO 1 - ELSE IF (DABS(F1-F0).LT.1.0E-5) THEN - if (debug) then - WRITE (IOUT,*) 'DISTFIT: CANNOT IMPROVE DISTANCE FIT' - WRITE (IOUT,*) 'IT=',it,'F=',F1 - endif - RETURN - ENDIF - RL=RL*10.0 - ENDDO - WRITE (IOUT,*) 'DISTFIT: MARQUARDT PROCEDURE HAS FAILED' - WRITE (IOUT,*) 'IT=',it,'F=',F0 - CALL TRANSFER(NRES,phiold,phi) - RETURN - 1 continue -cd write (iout,*) "it",it," imar",imar," f0",f0 - enddo - WRITE (IOUT,*) 'DISTFIT: FINAL F=',F0,'after MAXIT=',maxit - return - END - - double precision FUNCTION RDIF() - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DISTFIT' - -c print *,'in rdif' - - suma=0.0 - ind=0 - call chainbuild - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if (w(ind).ne.0.0) then - DIJ=DIST(i,j) - suma=suma+w(ind)*(DIJ-d0(ind))*(DIJ-d0(ind)) - DD(ind)=DIJ -c print '(2i3,i4,4f12.2)',i,j,ind,dij,d0(ind),w(ind),suma - endif - enddo - enddo - - RDIF=suma - RETURN - END - - SUBROUTINE RDERIV - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DISTFIT' - include 'COMMON.GEO' - DIMENSION E12(3),R13(3),R24(3),PRODU(3) - - DO I=1,NY - DO J=1,NX - DRDG(I,J)=0.0 - ENDDO - ENDDO - DO I=1,NX - I1=I+1 - I2=I+2 - CALL VEC(I1,I2,E12) - DO J=1,I - DO K=1,3 - R13(K)=C(K,J)-C(K,I1) - ENDDO - DO K=I2+1,NRES - DO L=1,3 - R24(L)=C(L,K)-C(L,I2) - ENDDO - IND=((J-1)*(2*NRES-J-6))/2+K-3 - PRODU(1)=R13(2)*R24(3)-R13(3)*R24(2) - PRODU(2)=R13(3)*R24(1)-R13(1)*R24(3) - PRODU(3)=R13(1)*R24(2)-R13(2)*R24(1) - DRDG(IND,I)=SCALAR(E12,PRODU)/DIST(J,K) - ENDDO - ENDDO - ENDDO - RETURN - END - - SUBROUTINE HEVAL - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DISTFIT' - - DO I=1,NX - XI=0.0 - HII=0.0 - DO K=1,NY - BKI=DRDG(K,I) - BKIWK=w(K)*BKI - XI=XI+BKIWK*(D0(K)-DD(K)) - HII=HII+BKI*BKIWK - ENDDO - H(I,I)=HII - XX(I)=XI - DO J=I+1,NX - HIJ=0.0 - DO K=1,NY - HIJ=HIJ+DRDG(K,I)*DRDG(K,J)*w(K) - ENDDO - H(I,J)=HIJ - H(J,I)=HIJ - ENDDO - ENDDO - RETURN - END - - - SUBROUTINE VEC(I,J,U) -* -* Find the unit vector from atom (I) to atom (J). Store in U. -* - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - DIMENSION U(3) - - ANORM=0.0 - DO K=1,3 - UK=C(K,J)-C(K,I) - ANORM=ANORM+UK*UK - U(K)=UK - ENDDO - ANORM=SQRT(ANORM) - DO K=1,3 - U(K)=U(K)/ANORM - ENDDO - RETURN - END - - SUBROUTINE TRANSFER(N,X1,X2) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION X1(N),X2(N) - DO 1 I=1,N - 1 X2(I)=X1(I) - RETURN - END - diff --git a/source/unres/src_MD-M-newcorr/djacob.f b/source/unres/src_MD-M-newcorr/djacob.f deleted file mode 100644 index e3f46bc..0000000 --- a/source/unres/src_MD-M-newcorr/djacob.f +++ /dev/null @@ -1,107 +0,0 @@ - SUBROUTINE DJACOB(N,NMAX,MAXJAC,E,A,C,AII) - IMPLICIT REAL*8 (A-H,O-Z) -C THE JACOBI DIAGONALIZATION PROCEDURE - COMMON INP,IOUT,IPN - DIMENSION A(NMAX,N),C(NMAX,N),AII(150),AJJ(150) - SIN45 = .70710678 - COS45 = .70710678 - S45SQ = 0.50 - C45SQ = 0.50 -C UNIT EIGENVECTOR MATRIX - DO 70 I = 1,N - DO 7 J = I,N - A(J,I)=A(I,J) - C(I,J) = 0.0 - 7 C(J,I) = 0.0 - 70 C(I,I) = 1.0 -C DETERMINATION OF SEARCH ARGUMENT, TEST - AMAX = 0.0 - DO 1 I = 1,N - DO 1 J = 1,I - TEMPA=DABS(A(I,J)) - IF (AMAX-TEMPA) 2,1,1 - 2 AMAX = TEMPA - 1 CONTINUE - TEST = AMAX*E -C SEARCH FOR LARGEST OFF DIAGONAL ELEMENT - DO 72 IJAC=1,MAXJAC - AIJMAX = 0.0 - DO 3 I = 2,N - LIM = I-1 - DO 3 J = 1,LIM - TAIJ=DABS(A(I,J)) - IF (AIJMAX-TAIJ) 4,3,3 - 4 AIJMAX = TAIJ - IPIV = I - JPIV = J - 3 CONTINUE - IF(AIJMAX-TEST)300,300,5 -C PARAMETERS FOR ROTATION - 5 TAII = A(IPIV,IPIV) - TAJJ = A(JPIV,JPIV) - TAIJ = A(IPIV,JPIV) - TMT = TAII-TAJJ - IF(DABS(TMT/TAIJ)-1.0D-12) 60,60,6 - 60 IF(TAIJ) 10,10,11 - 6 ZAMMA=TAIJ/(2.0*TMT) - 90 IF(DABS(ZAMMA)-0.38268)8,8,9 - 9 IF(ZAMMA)10,10,11 - 10 SINT = -SIN45 - GO TO 12 - 11 SINT = SIN45 - 12 COST = COS45 - SINSQ = S45SQ - COSSQ = C45SQ - GO TO 120 - 8 GAMSQ=ZAMMA*ZAMMA - SINT=2.0*ZAMMA/(1.0+GAMSQ) - COST = (1.0-GAMSQ)/(1.0+GAMSQ) - SINSQ=SINT*SINT - COSSQ=COST*COST -C ROTATION - 120 DO 13 K = 1,N - TAIK = A(IPIV,K) - TAJK = A(JPIV,K) - A(IPIV,K) = TAIK*COST+TAJK*SINT - A(JPIV,K) = TAJK*COST-TAIK*SINT - TCIK = C(IPIV,K) - TCJK = C(JPIV,K) - C(IPIV,K) = TCIK*COST+TCJK*SINT - 13 C(JPIV,K) = TCJK*COST-TCIK*SINT - A(IPIV,IPIV) = TAII*COSSQ+TAJJ*SINSQ+2.0*TAIJ*SINT*COST - A(JPIV,JPIV) = TAII*SINSQ+TAJJ*COSSQ-2.0*TAIJ*SINT*COST - A(IPIV,JPIV) = TAIJ*(COSSQ-SINSQ)-SINT*COST*TMT - A(JPIV,IPIV) = A(IPIV,JPIV) - DO 30 K = 1,N - A(K,IPIV) = A(IPIV,K) - 30 A(K,JPIV) = A(JPIV,K) - 72 CONTINUE - WRITE (IOUT,1000) AIJMAX - 1000 FORMAT (/1X,'NONCONVERGENT JACOBI. LARGEST OFF-DIAGONAL ELE', - 1 'MENT = ',1PE14.7) -C ARRANGEMENT OF EIGENVALUES IN ASCENDING ORDER - 300 DO 14 I=1,N - 14 AJJ(I)=A(I,I) - LT=N+1 - DO15 L=1,N - LT=LT-1 - AIIMIN=1.0E+30 - DO16 I=1,N - IF(AJJ(I)-AIIMIN)17,16,16 - 17 AIIMIN=AJJ(I) - IT=I - 16 CONTINUE - IN=L - AII(IN)=AIIMIN - AJJ(IT)=1.0E+30 - DO15 K=1,N - 15 A(IN,K)=C(IT,K) - DO 18 I=1,N - IF(A(I,1))19,22,22 - 19 T=-1.0 - GO TO 91 - 22 T=1.0 - 91 DO 18 J=1,N - 18 C(J,I)=T*A(I,J) - RETURN - END diff --git a/source/unres/src_MD-M-newcorr/econstr_local.F b/source/unres/src_MD-M-newcorr/econstr_local.F deleted file mode 100644 index f11acfb..0000000 --- a/source/unres/src_MD-M-newcorr/econstr_local.F +++ /dev/null @@ -1,91 +0,0 @@ - subroutine Econstr_back -c MD with umbrella_sampling using Wolyne's distance measure as a constraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - Uconst_back=0.0d0 - do i=1,nres - dutheta(i)=0.0d0 - dugamma(i)=0.0d0 - do j=1,3 - duscdiff(j,i)=0.0d0 - duscdiffx(j,i)=0.0d0 - enddo - enddo - do i=1,nfrag_back - ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) -c -c Deviations from theta angles -c - utheta_i=0.0d0 - do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) - dtheta_i=theta(j)-thetaref(j) - utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i - dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) - enddo - utheta(i)=utheta_i/(ii-1) -c -c Deviations from gamma angles -c - ugamma_i=0.0d0 - do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset) - dgamma_i=pinorm(phi(j)-phiref(j)) -c write (iout,*) j,phi(j),phi(j)-phiref(j) - ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i - dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2) -c write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3) - enddo - ugamma(i)=ugamma_i/(ii-2) -c -c Deviations from local SC geometry -c - uscdiff(i)=0.0d0 - do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 - dxx=xxtab(j)-xxref(j) - dyy=yytab(j)-yyref(j) - dzz=zztab(j)-zzref(j) - uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz - do k=1,3 - duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* - & (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ - & (ii-1) - duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* - & (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ - & (ii-1) - duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* - & (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) - & /(ii-1) - enddo -c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), -c & xxref(j),yyref(j),zzref(j) - enddo - uscdiff(i)=0.5d0*uscdiff(i)/(ii-1) -c write (iout,*) i," uscdiff",uscdiff(i) -c -c Put together deviations from local geometry -c - Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ - & wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i) -c write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i), -c & " uconst_back",uconst_back - utheta(i)=dsqrt(utheta(i)) - ugamma(i)=dsqrt(ugamma(i)) - uscdiff(i)=dsqrt(uscdiff(i)) - enddo - return - end diff --git a/source/unres/src_MD-M-newcorr/ecorr_num.f b/source/unres/src_MD-M-newcorr/ecorr_num.f deleted file mode 100644 index 3afecb9..0000000 --- a/source/unres/src_MD-M-newcorr/ecorr_num.f +++ /dev/null @@ -1,593 +0,0 @@ -C------------------------------------------------------------------------------ -C Set of diagnostic routines for checking cumulant terms by numerical -C integration. They are not required unless new correlation terms need -C to be checked. -C------------------------------------------------------------------------------ - subroutine checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa, - & eel_loc_ij) -C Calculate third-order correlation terms by numerical integration. - 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.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' -! real*8 mu(2,maxres),muder(2,maxres), -! & muij(4),mu1(2,maxres),mu2(2,maxres),auxvec(2) - real*8 muij(4),auxvec(2) - iti=itortyp(itype(i)) - itj=itortyp(itype(j)) - eel_loc_1=a22*b1(1,iti)*b1(1,itj)+a23*b1(1,iti)*b1(2,itj)+ - & a32*b1(2,iti)*b1(1,itj)+a33*b1(2,iti)*b1(2,itj) - eel_loc_2=a22*b1(1,iti)*Ub2(1,j)+a23*b1(1,iti)*Ub2(2,j)+ - & a32*b1(2,iti)*Ub2(1,j)+a33*b1(2,iti)*Ub2(2,j) - eel_loc_3=a22*Ub2(1,i)*b1(1,itj)+a23*Ub2(1,i)*b1(2,itj)+ - & a32*Ub2(2,i)*b1(1,itj)+a33*Ub2(2,i)*b1(2,itj) - eel_loc_4=a22*Ub2(1,i)*Ub2(1,j)+a23*Ub2(1,i)*Ub2(2,j)+ - & a32*Ub2(2,i)*Ub2(1,j)+a33*Ub2(2,i)*Ub2(2,j) - if (i.gt.iatel_s) then - iti1=itortyp(itype(i)) - else - iti1=4 - endif - iti2=itortyp(itype(i+1)) - itj1=itortyp(itype(j)) - if (j.lt.iatel_e+2) then - itj2=itortyp(itype(j+1)) - else - itj2=4 - endif - if (j.lt.nres-1) then - call integral3(phi(i+2),phi(j+2),iti1,iti2,itj1,itj2, - & acipa,.false.,eel_1,eel_2,eel_3,eel_4) - else - call integral3(phi(i+2),phi(j+2),iti1,iti2,itj1,itj2, - & acipa,.true.,eel_1,eel_2,eel_3,eel_4) - endif -cd write (iout,*) 'eel_1',eel_loc_1,' eel_1_num',4*eel_1 -cd write (iout,*) 'eel_2',eel_loc_2,' eel_2_num',4*eel_2 -cd write (iout,*) 'eel_3',eel_loc_3,' eel_3_num',4*eel_3 -cd write (iout,*) 'eel_4',eel_loc_4,' eel_4_num',4*eel_4 - write (iout,*) 'eel',eel_loc_ij,' eel_num', - &4*(eel_1+eel_2+eel_3+eel_4) - return - end -c---------------------------------------------------------------------- - subroutine checkint4(i,j,k,l,jj,kk,eel4_num) -c Calculate fourth-order correlation terms by numerical integration. - 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 gx(3),gx1(3) - double precision ee1t(2,2),ee2t(2,2),ee1ta1(2,2),ee2ta2(2,2), - & ee1ta1_der(2,2,3,5),ee2ta2_der(2,2,3,5),aa1(2,2),aa2(2,2), - & aa2t(2,2),uugk(2,2),uugl(2,2),uugj(2,2),pizda(2,2) - itk = itortyp(itype(k)) -C Check integrals -C Copy dipole matrices to temporary arrays - 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 -C Apply inverse transformation - do iii=1,2 - aa1(1,iii)=-aa1(1,iii) - enddo - if (j.lt.nres-1) then - do iii=1,2 - aa1(iii,1)=-aa1(iii,1) - enddo - else - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=-aa1(iii,jjj) - enddo - enddo - endif - if (k.lt.nres-1) then - do iii=1,2 - aa2(1,iii)=-aa2(1,iii) - enddo - else - do iii=1,2 - do jjj=1,2 - aa2(iii,jjj)=-aa2(iii,jjj) - enddo - enddo - endif - if (l.lt.nres-1) then - do iii=1,2 - aa2(iii,1)=-aa2(iii,1) - enddo - else - do iii=1,2 - do jjj=1,2 - aa2(iii,jjj)=-aa2(iii,jjj) - enddo - enddo - endif - if (l.eq.j+1) then - itl = itortyp(itype(l)) -c Compute numerical integrals - print *,phi(k+2),phi(l+2),itk,itl - if (l.lt.nres-1) then -cd write(2,*)'1 ',itk,itl,a_chuj(:,:,jj,i),a_chuj(:,:,kk,k) -c call integral(0.0d0,0.0d0,itk,itl,aa1(1,1), -c & aa2(1,1),1.0d0,1.0d0,-1.0d0,-1.0d0,.false.,eel4_num) - call integral(0.0d0,phi(k+2)-pi,0.0d0,phi(l+2)-pi,itk,itl, - & aa1(1,1),aa2(1,1), - & 1.0d0,-1.0d0,1.0d0,-1.0d0,.false.,eel4_num) - else -cd write(2,*)'2 ',itk,itl,a_chuj(:,:,jj,i),a_chuj(:,:,kk,k) -c call integral(0.0d0,0.0d0,itk,itl,aa1(1,1), -c & aa2(1,1),1.0d0,1.0d0,1.0d0,1.0d0,.false.,eel4_num) - call integral(0.0d0,phi(k+2)-pi,0.0d0,0.0d0,itk,itl, - & aa1(1,1),aa2(1,1), - & 1.0d0,-1.0d0,1.0d0,-1.0d0,.false.,eel4_num) - endif - else - itl = itortyp(itype(j)) - if (j.lt.nres-1) then - call integral(0.0d0,phi(k+2)-pi,phi(j+2)-pi,0.0d0,itk,itl, - & aa1(1,1),aa2(1,1),1.0d0,-1.0d0,-1.0d0,1.0d0,.true.,eel4_num) - else - call integral(0.0d0,phi(k+2)-pi,0.0d0,0.0d0,itk,itl,aa1(1,1), - & aa2(1,1),1.0d0,-1.0d0,-1.0d0,1.0d0,.true.,eel4_num) - endif - endif -c end check - return - end -c----------------------------------------------------------------------------- - subroutine checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, - & eel5_3_num,eel5_4_num) -c Calculate fifth-order correlation terms by numerical integration. - 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 gx(3),gx1(3) - double precision ee1t(2,2),ee2t(2,2),ee1ta1(2,2),ee2ta2(2,2), - & ee1ta1_der(2,2,3,5),ee2ta2_der(2,2,3,5),aa1(2,2),aa2(2,2), - & aa2t(2,2),uugk(2,2),uugl(2,2),uugj(2,2),pizda(2,2) - iti = itortyp(itype(i)) - itk = itortyp(itype(k)) - itk1= itortyp(itype(k+1)) -C Check integrals -C Copy dipole matrices to temporary arrays - 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 -C Apply inverse transformation - do iii=1,2 - aa1(1,iii)=-aa1(1,iii) - enddo - if (j.lt.nres-1) then - do iii=1,2 - aa1(iii,1)=-aa1(iii,1) - enddo - else - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=-aa1(iii,jjj) - enddo - enddo - endif - if (k.lt.nres-1) then - do iii=1,2 - aa2(1,iii)=-aa2(1,iii) - enddo - else - do iii=1,2 - do jjj=1,2 - aa2(iii,jjj)=-aa2(iii,jjj) - enddo - enddo - endif - if (l.lt.nres-1) then - do iii=1,2 - aa2(iii,1)=-aa2(iii,1) - enddo - else - do iii=1,2 - do jjj=1,2 - aa2(iii,jjj)=-aa2(iii,jjj) - enddo - enddo - endif - eel5_1_num=0.0d0 - eel5_2_num=0.0d0 - eel5_3_num=0.0d0 - eel5_4_num=0.0d0 - if (l.eq.j+1) then - itj = itortyp(itype(j)) - itl = itortyp(itype(l)) - itl1= itortyp(itype(l+1)) -c Compute numerical integrals - if (l.lt.nres-1) then - if (i.gt.1) then - call integral5(phi(i+2),phi(k+2),phi(j+2),phi(l+2), - & iti,itk,itk1,itj,itl,itl1,aa1(1,1),aa2(1,1), - & 1,1,1,1,.false.,eel5_1_num,eel5_2_num,eel5_3_num,eel5_4_num) - else - call integral5(phi(i+2),phi(k+2),phi(j+2),phi(l+2), - & iti,itk,itk1,itj,itl,itl1,aa1(1,1),aa2(1,1), - & -1,1,1,1,.false.,eel5_1_num,eel5_2_num,eel5_3_num,eel5_4_num) - endif - else - if (i.gt.1) then - call integral5(phi(i+2),phi(k+2),phi(j+2),pi, - & iti,itk,itk1,itj,itl,itl1,aa1(1,1),aa2(1,1), - & 1,1,1,-1,.false.,eel5_1_num,eel5_2_num,eel5_3_num,eel5_4_num) - else - call integral5(phi(i+2),phi(k+2),phi(j+2),pi, - & iti,itk,itk1,itj,itl,itl1,aa1(1,1),aa2(1,1), - & -1,1,1,-1,.false.,eel5_1_num,eel5_2_num,eel5_3_num,eel5_4_num) - endif - endif - else - itj = itortyp(itype(j)) - itl = itortyp(itype(l)) - itj1= itortyp(itype(j+1)) - if (j.lt.nres-1) then - if (i.gt.1) then - call integral5(phi(i+2),phi(k+2),phi(l+2),phi(j+2), - & iti,itk,itk1,itl,itj,itj1,aa1(1,1),aa2(1,1), - & 1,1,1,1,.true.,eel5_1_num,eel5_2_num,eel5_3_num,eel5_4_num) - else - call integral5(phi(i+2),phi(k+2),phi(l+2),phi(j+2), - & iti,itk,itk1,itl,itj,itj1,aa1(1,1),aa2(1,1), - & -1,1,1,1,.true.,eel5_1_num,eel5_2_num,eel5_3_num,eel5_4_num) - endif - else - if (i.gt.1) then - call integral5(phi(i+2),phi(k+2),phi(l+2),pi, - & iti,itk,itk1,itl,itj,itj1,aa1(1,1),aa2(1,1), - & 1,1,1,-1,.true.,eel5_1_num,eel5_2_num,eel5_3_num,eel5_4_num) - else - call integral5(phi(i+2),phi(k+2),phi(l+2),pi, - & iti,itk,itk1,itl,itj,itj1,aa1(1,1),aa2(1,1), - & -1,1,1,-1,.true.,eel5_1_num,eel5_2_num,eel5_3_num,eel5_4_num) - endif - endif - endif -c end check - return - end -c----------------------------------------------------------------------------- - subroutine checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, - & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) -c Calculate sixth-order correlation terms by numerical integration. - 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 gx(3),gx1(3) - double precision ee1t(2,2),ee2t(2,2),ee1ta1(2,2),ee2ta2(2,2), - & ee1ta1_der(2,2,3,5),ee2ta2_der(2,2,3,5),aa1(2,2),aa2(2,2), - & aa2t(2,2),uugk(2,2),uugl(2,2),uugj(2,2),pizda(2,2) - iti = itortyp(itype(i)) - itk = itortyp(itype(k)) - itk1= itortyp(itype(k+1)) -C Check integrals -C Copy dipole matrices to temporary arrays - 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 -C Apply inverse transformation - do iii=1,2 - aa1(1,iii)=-aa1(1,iii) - enddo - if (j.lt.nres-1) then - do iii=1,2 - aa1(iii,1)=-aa1(iii,1) - enddo - else - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=-aa1(iii,jjj) - enddo - enddo - endif - if (k.lt.nres-1) then - do iii=1,2 - aa2(1,iii)=-aa2(1,iii) - enddo - else - do iii=1,2 - do jjj=1,2 - aa2(iii,jjj)=-aa2(iii,jjj) - enddo - enddo - endif - if (l.lt.nres-1) then - do iii=1,2 - aa2(iii,1)=-aa2(iii,1) - enddo - else - do iii=1,2 - do jjj=1,2 - aa2(iii,jjj)=-aa2(iii,jjj) - enddo - enddo - endif - eel6_1_num=0.0d0 - eel6_2_num=0.0d0 - eel6_3_num=0.0d0 - eel6_4_num=0.0d0 - eel6_5_num=0.0d0 - eel6_6_num=0.0d0 - if (l.eq.j+1) then - itj = itortyp(itype(j)) - itl = itortyp(itype(l)) - itl1= itortyp(itype(l+1)) -c Compute numerical integrals - if (l.lt.nres-1) then - if (i.gt.1) then - call integral6(phi(i+2),phi(k+2),phi(j+2),phi(l+2), - & iti,itk,itk1,itj,itl,itl1,aa1(1,1),aa2(1,1), - & 1,1,1,1,.false.,eel6_1_num,eel6_2_num,eel6_3_num,eel6_4_num, - & eel6_5_num,eel6_6_num) - else - call integral6(phi(i+2),phi(k+2),phi(j+2),phi(l+2), - & iti,itk,itk1,itj,itl,itl1,aa1(1,1),aa2(1,1), - & -1,1,1,1,.false.,eel6_1_num,eel6_2_num,eel6_3_num,eel6_4_num, - & eel6_5_num,eel6_6_num) - endif - else - if (i.gt.1) then - call integral6(phi(i+2),phi(k+2),phi(j+2),pi, - & iti,itk,itk1,itj,itl,itl1,aa1(1,1),aa2(1,1), - & 1,1,1,-1,.false.,eel6_1_num,eel6_2_num,eel6_3_num,eel6_4_num, - & eel6_5_num,eel6_6_num) - else - call integral6(phi(i+2),phi(k+2),phi(j+2),pi, - & iti,itk,itk1,itj,itl,itl1,aa1(1,1),aa2(1,1), - & -1,1,1,-1,.false.,eel6_1_num,eel6_2_num,eel6_3_num,eel6_4_num, - & eel6_5_num,eel6_6_num) - endif - endif - else - itj = itortyp(itype(j)) - itl = itortyp(itype(l)) - itj1= itortyp(itype(j+1)) - if (j.lt.nres-1) then - if (i.gt.1) then - call integral6(phi(i+2),phi(k+2),phi(l+2),phi(j+2), - & iti,itk,itk1,itl,itj,itj1,aa1(1,1),aa2(1,1), - & 1,1,1,1,.true.,eel6_1_num,eel6_2_num,eel6_3_num,eel6_4_num, - & eel6_5_num,eel6_6_num) - else - call integral6(phi(i+2),phi(k+2),phi(l+2),phi(j+2), - & iti,itk,itk1,itl,itj,itj1,aa1(1,1),aa2(1,1), - & -1,1,1,1,.true.,eel6_1_num,eel6_2_num,eel6_3_num,eel6_4_num, - & eel6_5_num,eel6_6_num) - endif - else - if (i.gt.1) then - call integral6(phi(i+2),phi(k+2),phi(l+2),pi, - & iti,itk,itk1,itl,itj,itj1,aa1(1,1),aa2(1,1), - & 1,1,1,-1,.true.,eel6_1_num,eel6_2_num,eel6_3_num,eel6_4_num, - & eel6_5_num,eel6_6_num) - else - call integral6(phi(i+2),phi(k+2),phi(l+2),pi, - & iti,itk,itk1,itl,itj,itj1,aa1(1,1),aa2(1,1), - & -1,1,1,-1,.true.,eel6_1_num,eel6_2_num,eel6_3_num,eel6_4_num, - & eel6_5_num,eel6_6_num) - endif - endif - endif -c end check - return - end -c----------------------------------------------------------------------------- - subroutine checkint_turn6(i,jj,kk,eel_turn6_num) -c Calculate sixth-order turn correlation terms by numerical integration. - 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 gx(3),gx1(3) - double precision ee1t(2,2),ee2t(2,2),ee1ta1(2,2),ee2ta2(2,2), - & ee1ta1_der(2,2,3,5),ee2ta2_der(2,2,3,5),aa1(2,2),aa2(2,2), - & aa2t(2,2),uugk(2,2),uugl(2,2),uugj(2,2),pizda(2,2) - k = i+1 - l = i+3 - j = i+4 - iti = itortyp(itype(i)) - itk = itortyp(itype(k)) - itk1= itortyp(itype(k+1)) -C Check integrals -C Copy dipole matrices to temporary arrays - 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 -C Apply inverse transformation - do iii=1,2 - aa1(1,iii)=-aa1(1,iii) - enddo - if (j.lt.nres-1) then - do iii=1,2 - aa1(iii,1)=-aa1(iii,1) - enddo - else - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=-aa1(iii,jjj) - enddo - enddo - endif - if (k.lt.nres-1) then - do iii=1,2 - aa2(1,iii)=-aa2(1,iii) - enddo - else - do iii=1,2 - do jjj=1,2 - aa2(iii,jjj)=-aa2(iii,jjj) - enddo - enddo - endif - if (l.lt.nres-1) then - do iii=1,2 - aa2(iii,1)=-aa2(iii,1) - enddo - else - do iii=1,2 - do jjj=1,2 - aa2(iii,jjj)=-aa2(iii,jjj) - enddo - enddo - endif - eel_turn6_num=0.0d0 - itj = itortyp(itype(j)) - itl = itortyp(itype(l)) - itj1= itortyp(itype(j+1)) - call integral_turn6(phi(i+2),phi(i+3),phi(i+4),phi(i+5), - & iti,itk,itk1,itl,itj,itj1,aa1(1,1),aa2(1,1),eel_turn6_num) - write (2,*) 'eel_turn6_num',eel_turn6_num -c end check - return - end -c----------------------------------------------------------------------------- - subroutine checkint_turn3(i,a_temp,eel_turn3_num) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -c Calculate third-order turn correlation terms by numerical integration. - 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 a_temp(2,2),aa1(2,2) - iti1 = itortyp(itype(i+1)) - iti2 = itortyp(itype(i+2)) -C Check integrals -C Apply inverse transformation - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=a_temp(iii,jjj) - enddo - enddo - do iii=1,2 - aa1(1,iii)=-aa1(1,iii) - enddo - if (i.lt.nres-3) then - do iii=1,2 - aa1(iii,1)=-aa1(iii,1) - enddo - else - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=-aa1(iii,jjj) - enddo - enddo - endif - eel_turn3_num=0.0d0 -c Compute numerical integrals - if (i.lt.nres-3) then - call integral3a(phi(i+3),phi(i+4),iti1,iti2, - & aa1(1,1), 1,eel_turn3_num) - else - call integral3a(phi(i+3),phi(i+4),iti1,iti2, - & aa1(1,1),-1,eel_turn3_num) - endif -c end check - return - end -c----------------------------------------------------------------------------- - subroutine checkint_turn4(i,a_temp,eel_turn4_num) -c Calculate fourth-order turn correlation terms by numerical integration. - 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 a_temp(2,2),aa1(2,2) - iti1 = itortyp(itype(i+1)) - iti2 = itortyp(itype(i+2)) - iti3 = itortyp(itype(i+3)) -C Check integrals -C Apply inverse transformation - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=a_temp(iii,jjj) - enddo - enddo - do iii=1,2 - aa1(1,iii)=-aa1(1,iii) - enddo - if (i.lt.nres-4) then - do iii=1,2 - aa1(iii,1)=-aa1(iii,1) - enddo - else - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=-aa1(iii,jjj) - enddo - enddo - endif - eel_turn4_num=0.0d0 -c Compute numerical integrals - if (i.lt.nres-4) then - call integral4a(phi(i+3),phi(i+4),phi(i+5), - & iti1,iti2,iti3,aa1(1,1),1,eel_turn4_num) - else - call integral4a(phi(i+3),phi(i+4),phi(i+5), - & iti1,iti2,iti3,aa1(1,1),-1,eel_turn4_num) - endif -c end check - return - end diff --git a/source/unres/src_MD-M-newcorr/eelec.F b/source/unres/src_MD-M-newcorr/eelec.F deleted file mode 100644 index 492d5db..0000000 --- a/source/unres/src_MD-M-newcorr/eelec.F +++ /dev/null @@ -1,278 +0,0 @@ - subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) -C -C This subroutine calculates the average interaction energy and its gradient -C in the virtual-bond vectors between non-adjacent peptide groups, based on -C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. -C The potential depends both on the distance of peptide-group centers and on -C the orientation of the CA-CA virtual bonds. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), - & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) - double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), - & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) - common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2 -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - double precision scal_el /1.0d0/ -#else - double precision scal_el /0.5d0/ -#endif -C 12/13/98 -C 13-go grudnia roku pamietnego... - double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, - & 0.0d0,1.0d0,0.0d0, - & 0.0d0,0.0d0,1.0d0/ -cd write(iout,*) 'In EELEC' -cd do i=1,nloctyp -cd write(iout,*) 'Type',i -cd write(iout,*) 'B1',B1(:,i) -cd write(iout,*) 'B2',B2(:,i) -cd write(iout,*) 'CC',CC(:,:,i) -cd write(iout,*) 'DD',DD(:,:,i) -cd write(iout,*) 'EE',EE(:,:,i) -cd enddo -cd call check_vecgrad -cd stop - if (icheckgrad.eq.1) then - do i=1,nres-1 - fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) - do k=1,3 - dc_norm(k,i)=dc(k,i)*fac - enddo -c write (iout,*) 'i',i,' fac',fac - enddo - endif - if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. - & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then -c call vec_and_deriv - call set_matrices - endif -cd do i=1,nres-1 -cd write (iout,*) 'i=',i -cd do k=1,3 -cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) -cd enddo -cd do k=1,3 -cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') -cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) -cd enddo -cd enddo - num_conti_hb=0 - ees=0.0D0 - evdw1=0.0D0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 - ind=0 - do i=1,nres - num_cont_hb(i)=0 - enddo -cd print '(a)','Enter EELEC' -cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e - do i=1,nres - gel_loc_loc(i)=0.0d0 - gcorr_loc(i)=0.0d0 - enddo - do i=iatel_s,iatel_e - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 -c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) - do j=ielstart(i),ielend(i) - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - aaa=app(iteli,itelj) - bbb=bpp(iteli,itelj) - ael6i=ael6(iteli,itelj) - ael3i=ael3(iteli,itelj) -C Diagnostics only!!! -c aaa=0.0D0 -c bbb=0.0D0 -c ael6i=0.0D0 -c ael3i=0.0D0 -C End diagnostics - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - rmij=1.0D0/rij - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj - cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij - cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij - fac=cosa-3.0D0*cosb*cosg - ev1=aaa*r6ij*r6ij -c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - fac3=ael6i*r6ij - fac4=ael3i*r3ij - evdwij=ev1+ev2 - el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - eesij=el1+el2 -C 12/26/95 - for the evaluation of multi-body H-bonding interactions - ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) - ees=ees+eesij - evdw1=evdw1+evdwij -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)') 'evdw1',i,j,evdwij - 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) - facel=-3*rrmij*(el1+eesij) - fac1=fac - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=facel*xj - ggg(2)=facel*yj - ggg(3)=facel*zj - do k=1,3 - ghalf=0.5D0*ggg(k) - gelc(k,i)=gelc(k,i)+ghalf - gelc(k,j)=gelc(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* -caug8 do k=i+1,j-1 -caug8 do l=1,3 -caug8 gelc(l,k)=gelc(l,k)+ggg(l) -caug8 enddo -caug8 enddo - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - do k=1,3 - ghalf=0.5D0*ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)+ghalf - gvdwpp(k,j)=gvdwpp(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* -caug8 do k=i+1,j-1 -caug8 do l=1,3 -caug8 gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) -caug8 enddo -caug8 enddo -#else - facvdw=ev1+evdwij - facel=el1+eesij - fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=fac*xj - ggg(2)=fac*yj - ggg(3)=fac*zj - do k=1,3 - ghalf=0.5D0*ggg(k) - gelc(k,i)=gelc(k,i)+ghalf - gelc(k,j)=gelc(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* -caug8 do k=i+1,j-1 -caug8 do l=1,3 -caug8 gelc(l,k)=gelc(l,k)+ggg(l) -caug8 enddo -caug8 enddo -#endif -* -* Angular part -* - ecosa=2.0D0*fac3*fac1+fac4 - fac4=-3.0D0*fac4 - fac3=-6.0D0*fac3 - ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) - ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo -cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), -cd & (dcosg(k),k=1,3) - do k=1,3 - ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) - enddo - do k=1,3 - ghalf=0.5D0*ggg(k) - gelc(k,i)=gelc(k,i)+ghalf - & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gelc(k,j)=gelc(k,j)+ghalf - & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - enddo -caug8 do k=i+1,j-1 -caug8 do l=1,3 -caug8 gelc(l,k)=gelc(l,k)+ggg(l) -caug8 enddo -caug8 enddo - - enddo ! j - num_cont_hb(i)=num_conti - enddo ! i -c write (iout,*) "Number of loop steps in EELEC:",ind -cd do i=1,nres -cd write (iout,'(i3,3f10.5,5x,3f10.5)') -cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) -cd enddo -c 12/7/99 Adam eello_turn3 will be considered as a separate energy term -ccc eel_loc=eel_loc+eello_turn3 - return - end - diff --git a/source/unres/src_MD-M-newcorr/eigen.f b/source/unres/src_MD-M-newcorr/eigen.f deleted file mode 100644 index e4088ee..0000000 --- a/source/unres/src_MD-M-newcorr/eigen.f +++ /dev/null @@ -1,2351 +0,0 @@ -C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS -C 31 MAR 94 - MWS - ADD A VARIABLE TO END OF MACHSW COMMON -C 26 JUN 93 - MWS - ETRED3: ADD RETURN FOR SPECIAL CASE N=1 -C 4 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR -C 30 AUG 91 - MWS - JACDIA: LIMIT ITERATIONS, USE EPSLON IN TEST. -C 14 JUL 91 - MWS - JACOBI DIAGONALIZATION ALLOWS FOR LDVEC.NE.N -C 29 JAN 91 - TLW - GLDIAG: CHANGED COMMON DIAGSW TO MACHSW -C 29 OCT 90 - STE - FIX JACDIA UNDEFINED VARIABLE BUG -C 14 SEP 90 - MK - NEW JACOBI DIAGONALIZATION (KDIAG=3) -C 27 MAR 88 - MWS - ALLOW FOR VECTOR ROUTINE IN GLDIAG -C 11 AUG 87 - MWS - SANITIZE CONSTANTS IN EQLRAT -C 15 FEB 87 - STE - FIX EINVIT SUB-MATRIX LOOP LIMIT -C SCRATCH ARRAYS ARE N*8 REAL AND N INTEGER -C 8 DEC 86 - STE - USE PERF INDEX FROM ESTPI1 TO JUDGE EINVIT FAILURE -C 30 NOV 86 - STE - DELETE LIGENB, MAKE EVVRSP DEFAULT -C (GIVEIS FAILS ON CRAY FOR BENCHMC AND BENCHCI) -C 7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS -C 11 OCT 85 - STE - LIGENB,TQL2: USE DROT,DSWAP; TINVTB: SCALE VECTOR -C BEFORE NORMALIZING; GENERIC FUNCTIONS -C 24 FEB 84 - STE - INITIALIZE INDEX ARRAY FOR LIGENB IN GLDIAG -C 1 DEC 83 - STE - CHANGE MACHEP FROM 2**-54 TO 2**-50 -C 28 SEP 82 - MWS - CONVERT TO IBM -C -C*MODULE EIGEN *DECK EINVIT - SUBROUTINE EINVIT(NM,N,D,E,E2,M,W,IND,Z,IERR,RV1,RV2,RV3,RV4,RV6) -C* -C* AUTHORS- -C* THIS IS A MODIFICATION OF TINVIT FROM EISPACK EDITION 3 -C* DATED AUGUST 1983. -C* TINVIT IS A TRANSLATION OF THE INVERSE ITERATION TECHNIQUE -C* IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. -C* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). -C* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) -C* -C* PURPOSE - -C* THIS ROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL -C* SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES. -C* -C* METHOD - -C* INVERSE ITERATION. -C* -C* ON ENTRY - -C* NM - INTEGER -C* MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C* ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -C* DIMENSION STATEMENT. -C* N - INTEGER -C* D - W.P. REAL (N) -C* CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. -C* E - W.P. REAL (N) -C* CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -C* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. -C* E2 - W.P. REAL (N) -C* CONTAINS THE SQUARES OF CORRESPONDING ELEMENTS OF E, -C* WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. -C* E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN -C* THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE -C* SUM OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST -C* CONTAIN 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, -C* OR 2.0 IF THE EIGENVALUES ARE IN DESCENDING ORDER. -C* IF TQLRAT, BISECT, TRIDIB, OR IMTQLV -C* HAS BEEN USED TO FIND THE EIGENVALUES, THEIR -C* OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE. -C* M - INTEGER -C* THE NUMBER OF SPECIFIED EIGENVECTORS. -C* W - W.P. REAL (M) -C* CONTAINS THE M EIGENVALUES IN ASCENDING -C* OR DESCENDING ORDER. -C* IND - INTEGER (M) -C* CONTAINS IN FIRST M POSITIONS THE SUBMATRIX INDICES -C* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- -C* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX -C* FROM THE TOP, 2 FOR THOSE BELONGING TO THE SECOND -C* SUBMATRIX, ETC. -C* IERR - INTEGER (LOGICAL UNIT NUMBER) -C* LOGICAL UNIT FOR ERROR MESSAGES -C* -C* ON EXIT - -C* ALL INPUT ARRAYS ARE UNALTERED. -C* Z - W.P. REAL (NM,M) -C* CONTAINS THE ASSOCIATED SET OF ORTHONORMAL -C* EIGENVECTORS. ANY VECTOR WHICH WHICH FAILS TO CONVERGE -C* IS LEFT AS IS (BUT NORMALIZED) WHEN ITERATING STOPPED. -C* IERR - INTEGER -C* SET TO -C* ZERO FOR NORMAL RETURN, -C* -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH -C* EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS. -C* (ONLY LAST FAILURE TO CONVERGE IS REPORTED) -C* -C* RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. -C* -C* RV1 - W.P. REAL (N) -C* DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION -C* RV2 - W.P. REAL (N) -C* SUPER(1)-DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION -C* RV3 - W.P. REAL (N) -C* SUPER(2)-DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION -C* RV4 - W.P. REAL (N) -C* ELEMENTS DEFINING L IN LU DECOMPOSITION -C* RV6 - W.P. REAL (N) -C* APPROXIMATE EIGENVECTOR -C* -C* DIFFERENCES FROM EISPACK 3 - -C* EPS3 IS SCALED BY EPSCAL (ENHANCES CONVERGENCE, BUT -C* LOWERS ACCURACY)! -C* ONE MORE ITERATION (MINIMUM 2) IS PERFORMED AFTER CONVERGENCE -C* (ENHANCES ACCURACY)! -C* REPLACE LOOP WITH PYTHAG WITH SINGLE CALL TO DNRM2! -C* IF NOT CONVERGED, USE PERFORMANCE INDEX TO DECIDE ON ERROR -C* VALUE SETTING, BUT DO NOT STOP! -C* L.U. FOR ERROR MESSAGES PASSED THROUGH IERR -C* USE PARAMETER STATEMENTS AND GENERIC INTRINSIC FUNCTIONS -C* USE LEVEL 1 BLAS -C* USE IF-THEN-ELSE TO CLARIFY LOGIC -C* LOOP OVER SUBSPACES MADE INTO DO LOOP. -C* LOOP OVER INVERSE ITERATIONS MADE INTO DO LOOP -C* ZERO ONLY REQUIRED PORTIONS OF OUTPUT VECTOR -C* -C* NOTE - -C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -C* -C - LOGICAL CONVGD,GOPARR,DSKWRK,MASWRK -C - INTEGER GROUP,I,IERR,ITS,J,JJ,M,N,NM,P,Q,R,S,SUBMAT,TAG - INTEGER IND(M) -C - DOUBLE PRECISION D(N),E(N),E2(N),W(M),Z(NM,M) - DOUBLE PRECISION RV1(N),RV2(N),RV3(N),RV4(N),RV6(N) - DOUBLE PRECISION ANORM,EPS2,EPS3,EPS4,NORM,ORDER,RHO,U,UK,V - DOUBLE PRECISION X0,X1,XU - DOUBLE PRECISION EPSCAL,GRPTOL,HUNDRD,ONE,TEN,ZERO - DOUBLE PRECISION EPSLON, ESTPI1, DASUM, DDOT, DNRM2 -C - COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK -C - PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00, GRPTOL = 0.001D+00) - PARAMETER (EPSCAL = 0.5D+00, HUNDRD = 100.0D+00, TEN = 10.0D+00) -C - 001 FORMAT(' EIGENVECTOR ROUTINE EINVIT DID NOT CONVERGE FOR VECTOR' - * ,I5,'. NORM =',1P,E10.2,' PERFORMANCE INDEX =',E10.2/ - * ' (AN ERROR HALT WILL OCCUR IF THE PI IS GREATER THAN 100)') -C -C----------------------------------------------------------------------- -C - LUEMSG = IERR - IERR = 0 - X0 = ZERO - UK = ZERO - NORM = ZERO - EPS2 = ZERO - EPS3 = ZERO - EPS4 = ZERO - GROUP = 0 - TAG = 0 - ORDER = ONE - E2(1) - Q = 0 - DO 930 SUBMAT = 1, N - P = Q + 1 -C -C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX .......... -C - DO 120 Q = P, N-1 - IF (E2(Q+1) .EQ. ZERO) GO TO 140 - 120 CONTINUE - Q = N -C -C .......... FIND VECTORS BY INVERSE ITERATION .......... -C - 140 CONTINUE - TAG = TAG + 1 - ANORM = ZERO - S = 0 -C - DO 920 R = 1, M - IF (IND(R) .NE. TAG) GO TO 920 - ITS = 1 - X1 = W(R) - IF (S .NE. 0) GO TO 510 -C -C .......... CHECK FOR ISOLATED ROOT .......... -C - XU = ONE - IF (P .EQ. Q) THEN - RV6(P) = ONE - CONVGD = .TRUE. - GO TO 860 -C - END IF - NORM = ABS(D(P)) - DO 500 I = P+1, Q - NORM = MAX( NORM, ABS(D(I)) + ABS(E(I)) ) - 500 CONTINUE -C -C .......... EPS2 IS THE CRITERION FOR GROUPING, -C EPS3 REPLACES ZERO PIVOTS AND EQUAL -C ROOTS ARE MODIFIED BY EPS3, -C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ......... -C - EPS2 = GRPTOL * NORM - EPS3 = EPSCAL * EPSLON(NORM) - UK = Q - P + 1 - EPS4 = UK * EPS3 - UK = EPS4 / SQRT(UK) - S = P - GROUP = 0 - GO TO 520 -C -C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... -C - 510 IF (ABS(X1-X0) .GE. EPS2) THEN -C -C ROOTS ARE SEPERATE -C - GROUP = 0 - ELSE -C -C ROOTS ARE CLOSE -C - GROUP = GROUP + 1 - IF (ORDER * (X1 - X0) .LE. EPS3) X1 = X0 + ORDER * EPS3 - END IF -C -C .......... ELIMINATION WITH INTERCHANGES AND -C INITIALIZATION OF VECTOR .......... -C - 520 CONTINUE -C - U = D(P) - X1 - V = E(P+1) - RV6(P) = UK - DO 550 I = P+1, Q - RV6(I) = UK - IF (ABS(E(I)) .GT. ABS(U)) THEN -C -C EXCHANGE ROWS BEFORE ELIMINATION -C -C *** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF -C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ....... -C - XU = U / E(I) - RV4(I) = XU - RV1(I-1) = E(I) - RV2(I-1) = D(I) - X1 - RV3(I-1) = E(I+1) - U = V - XU * RV2(I-1) - V = -XU * RV3(I-1) -C - ELSE -C -C STRAIGHT ELIMINATION -C - XU = E(I) / U - RV4(I) = XU - RV1(I-1) = U - RV2(I-1) = V - RV3(I-1) = ZERO - U = D(I) - X1 - XU * V - V = E(I+1) - END IF - 550 CONTINUE -C - IF (ABS(U) .LE. EPS3) U = EPS3 - RV1(Q) = U - RV2(Q) = ZERO - RV3(Q) = ZERO -C -C DO INVERSE ITERATIONS -C - CONVGD = .FALSE. - DO 800 ITS = 1, 5 - IF (ITS .EQ. 1) GO TO 600 -C -C .......... FORWARD SUBSTITUTION .......... -C - IF (NORM .EQ. ZERO) THEN - RV6(S) = EPS4 - S = S + 1 - IF (S .GT. Q) S = P - ELSE - XU = EPS4 / NORM - CALL DSCAL (Q-P+1, XU, RV6(P), 1) - END IF -C -C ... ELIMINATION OPERATIONS ON NEXT VECTOR -C - DO 590 I = P+1, Q - U = RV6(I) -C -C IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE -C WAS PERFORMED EARLIER IN THE -C TRIANGULARIZATION PROCESS .......... -C - IF (RV1(I-1) .EQ. E(I)) THEN - U = RV6(I-1) - RV6(I-1) = RV6(I) - ELSE - U = RV6(I) - END IF - RV6(I) = U - RV4(I) * RV6(I-1) - 590 CONTINUE - 600 CONTINUE -C -C .......... BACK SUBSTITUTION -C - RV6(Q) = RV6(Q) / RV1(Q) - V = U - U = RV6(Q) - NORM = ABS(U) - DO 620 I = Q-1, P, -1 - RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) - V = U - U = RV6(I) - NORM = NORM + ABS(U) - 620 CONTINUE - IF (GROUP .EQ. 0) GO TO 700 -C -C ....... ORTHOGONALIZE WITH RESPECT TO PREVIOUS -C MEMBERS OF GROUP .......... -C - J = R - DO 680 JJ = 1, GROUP - 630 J = J - 1 - IF (IND(J) .NE. TAG) GO TO 630 - CALL DAXPY(Q-P+1, -DDOT(Q-P+1,RV6(P),1,Z(P,J),1), - * Z(P,J),1,RV6(P),1) - 680 CONTINUE - NORM = DASUM(Q-P+1, RV6(P), 1) - 700 CONTINUE -C - IF (CONVGD) GO TO 840 - IF (NORM .GE. ONE) CONVGD = .TRUE. - 800 CONTINUE -C -C .......... NORMALIZE SO THAT SUM OF SQUARES IS -C 1 AND EXPAND TO FULL ORDER .......... -C - 840 CONTINUE -C - XU = ONE / DNRM2(Q-P+1,RV6(P),1) -C - 860 CONTINUE - DO 870 I = 1, P-1 - Z(I,R) = ZERO - 870 CONTINUE - DO 890 I = P,Q - Z(I,R) = RV6(I) * XU - 890 CONTINUE - DO 900 I = Q+1, N - Z(I,R) = ZERO - 900 CONTINUE -C - IF (.NOT.CONVGD) THEN - RHO = ESTPI1(Q-P+1,X1,D(P),E(P),Z(P,R),ANORM) - IF (RHO .GE. TEN .AND. LUEMSG .GT. 0 .AND. MASWRK) - * WRITE(LUEMSG,001) R,NORM,RHO -C -C *** SET ERROR -- NON-CONVERGED EIGENVECTOR .......... -C - IF (RHO .GT. HUNDRD) IERR = -R - END IF -C - X0 = X1 - 920 CONTINUE -C - IF (Q .EQ. N) GO TO 940 - 930 CONTINUE - 940 CONTINUE - RETURN - END -C*MODULE EIGEN *DECK ELAUM - SUBROUTINE ELAU(HINV,L,D,A,E) -C - DOUBLE PRECISION A(*) - DOUBLE PRECISION D(L) - DOUBLE PRECISION E(L) - DOUBLE PRECISION F - DOUBLE PRECISION G - DOUBLE PRECISION HALF - DOUBLE PRECISION HH - DOUBLE PRECISION HINV - DOUBLE PRECISION ZERO -C - PARAMETER (ZERO = 0.0D+00, HALF = 0.5D+00) -C - JL = L - E(1) = A(1) * D(1) - JK = 2 - DO 210 J = 2, JL - F = D(J) - G = ZERO - JM1 = J - 1 -C - DO 200 K = 1, JM1 - G = G + A(JK) * D(K) - E(K) = E(K) + A(JK) * F - JK = JK + 1 - 200 CONTINUE -C - E(J) = G + A(JK) * F - JK = JK + 1 - 210 CONTINUE -C -C .......... FORM P .......... -C - F = ZERO - DO 245 J = 1, L - E(J) = E(J) * HINV - F = F + E(J) * D(J) - 245 CONTINUE -C -C .......... FORM Q .......... -C - HH = F * HALF * HINV - DO 250 J = 1, L - 250 E(J) = E(J) - HH * D(J) -C - RETURN - END -C*MODULE EIGEN *DECK EPSLON - DOUBLE PRECISION FUNCTION EPSLON (X) -C* -C* AUTHORS - -C* THIS ROUTINE WAS TAKEN FROM EISPACK EDITION 3 DATED 4/6/83 -C* THIS VERSION IS BY S. T. ELBERT, AMES LABORATORY-USDOE NOV 1986 -C* -C* PURPOSE - -C* ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. -C* -C* ON ENTRY - -C* X - WORKING PRECISION REAL -C* VALUES TO FIND EPSLON FOR -C* -C* ON EXIT - -C* EPSLON - WORKING PRECISION REAL -C* SMALLEST POSITIVE VALUE SUCH THAT X+EPSLON .NE. ZERO -C* -C* QUALIFICATIONS - -C* THIS ROUTINE SHOULD PERFORM PROPERLY ON ALL SYSTEMS -C* SATISFYING THE FOLLOWING TWO ASSUMPTIONS, -C* 1. THE BASE USED IN REPRESENTING FLOATING POINT -C* NUMBERS IS NOT A POWER OF THREE. -C* 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO -C* THE ACCURACY USED IN FLOATING POINT VARIABLES -C* THAT ARE STORED IN MEMORY. -C* THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO -C* FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING -C* ASSUMPTION 2. -C* UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, -C* A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, -C* B HAS A ZERO FOR ITS LAST BIT OR DIGIT, -C* C IS NOT EXACTLY EQUAL TO ONE, -C* EPS MEASURES THE SEPARATION OF 1.0 FROM -C* THE NEXT LARGER FLOATING POINT NUMBER. -C* THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED -C* ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD. -C* -C* DIFFERENCES FROM EISPACK 3 - -C* USE IS MADE OF PARAMETER STATEMENTS AND INTRINSIC FUNCTIONS -C* --NO EXECUTEABLE CODE CHANGES-- -C* -C* NOTE - -C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -C - DOUBLE PRECISION A,B,C,EPS,X - DOUBLE PRECISION ZERO, ONE, THREE, FOUR -C - PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, THREE=3.0D+00, FOUR=4.0D+00) -C -C----------------------------------------------------------------------- -C - A = FOUR/THREE - 10 B = A - ONE - C = B + B + B - EPS = ABS(C - ONE) - IF (EPS .EQ. ZERO) GO TO 10 - EPSLON = EPS*ABS(X) - RETURN - END -C*MODULE EIGEN *DECK EQLRAT - SUBROUTINE EQLRAT(N,DIAG,E,E2IN,D,IND,IERR,E2) -C* -C* AUTHORS - -C* THIS IS A MODIFICATION OF ROUTINE EQLRAT FROM EISPACK EDITION 3 -C* DATED AUGUST 1983. -C* TQLRAT IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, -C* ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. -C* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) -C* -C* PURPOSE - -C* THIS ROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC -C* TRIDIAGONAL MATRIX -C* -C* METHOD - -C* RATIONAL QL -C* -C* ON ENTRY - -C* N - INTEGER -C* THE ORDER OF THE MATRIX. -C* D - W.P. REAL (N) -C* CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. -C* E2 - W.P. REAL (N) -C* CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF -C* THE INPUT MATRIX IN ITS LAST N-1 POSITIONS. -C* E2(1) IS ARBITRARY. -C* -C* ON EXIT - -C* D - W.P. REAL (N) -C* CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN -C* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND -C* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE -C* THE SMALLEST EIGENVALUES. -C* E2 - W.P. REAL (N) -C* DESTROYED. -C* IERR - INTEGER -C* SET TO -C* ZERO FOR NORMAL RETURN, -C* J IF THE J-TH EIGENVALUE HAS NOT BEEN -C* DETERMINED AFTER 30 ITERATIONS. -C* -C* DIFFERENCES FROM EISPACK 3 - -C* G=G+B INSTEAD OF IF(G.EQ.0) G=B ; B=B/4 -C* F77 BACKWARD LOOPS INSTEAD OF F66 CONSTRUCT -C* GENERIC INTRINSIC FUNCTIONS -C* ARRARY IND ADDED FOR USE BY EINVIT -C* -C* NOTE - -C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -C - INTEGER I,J,L,M,N,II,L1,IERR - INTEGER IND(N) -C - DOUBLE PRECISION D(N),E(N),E2(N),DIAG(N),E2IN(N) - DOUBLE PRECISION B,C,F,G,H,P,R,S,T,EPSLON - DOUBLE PRECISION SCALE,ZERO,ONE -C - PARAMETER (ZERO = 0.0D+00, SCALE= 1.0D+00/64.0D+00, ONE = 1.0D+00) -C -C----------------------------------------------------------------------- - IERR = 0 - D(1)=DIAG(1) - IND(1) = 1 - K = 0 - ITAG = 0 - IF (N .EQ. 1) GO TO 1001 -C - DO 100 I = 2, N - D(I)=DIAG(I) - 100 E2(I-1) = E2IN(I) -C - F = ZERO - T = ZERO - B = EPSLON(ONE) - C = B *B - B = B * SCALE - E2(N) = ZERO -C - DO 290 L = 1, N - H = ABS(D(L)) + ABS(E(L)) - IF (T .GE. H) GO TO 105 - T = H - B = EPSLON(T) - C = B * B - B = B * SCALE - 105 CONTINUE -C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... - M = L - 1 - 110 M = M + 1 - IF (E2(M) .GT. C) GO TO 110 -C .......... E2(N) IS ALWAYS ZERO, SO THERE IS AN EXIT -C FROM THE LOOP .......... -C - IF (M .LE. K) GO TO 125 - IF (M .NE. N) E2IN(M+1) = ZERO - K = M - ITAG = ITAG + 1 - 125 CONTINUE - IF (M .EQ. L) GO TO 210 -C -C ITERATE -C - DO 205 J = 1, 30 -C .......... FORM SHIFT .......... - L1 = L + 1 - S = SQRT(E2(L)) - G = D(L) - P = (D(L1) - G) / (2.0D+00 * S) - R = SQRT(P*P+1.0D+00) - D(L) = S / (P + SIGN(R,P)) - H = G - D(L) -C - DO 140 I = L1, N - 140 D(I) = D(I) - H -C - F = F + H -C .......... RATIONAL QL TRANSFORMATION .......... - G = D(M) + B - H = G - S = ZERO - DO 200 I = M-1,L,-1 - P = G * H - R = P + E2(I) - E2(I+1) = S * R - S = E2(I) / R - D(I+1) = H + S * (H + D(I)) - G = D(I) - E2(I) / G + B - H = G * P / R - 200 CONTINUE -C - E2(L) = S * G - D(L) = H -C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST - IF (H .EQ. ZERO) GO TO 210 - IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210 - E2(L) = H * E2(L) - IF (E2(L) .EQ. ZERO) GO TO 210 - 205 CONTINUE -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS .......... - IERR = L - GO TO 1001 -C -C CONVERGED -C - 210 P = D(L) + F -C .......... ORDER EIGENVALUES .......... - I = 1 - IF (L .EQ. 1) GO TO 250 - IF (P .LT. D(1)) GO TO 230 - I = L -C .......... LOOP TO FIND ORDERED POSITION - 220 I = I - 1 - IF (P .LT. D(I)) GO TO 220 -C - I = I + 1 - IF (I .EQ. L) GO TO 250 - 230 CONTINUE - DO 240 II = L, I+1, -1 - D(II) = D(II-1) - IND(II) = IND(II-1) - 240 CONTINUE -C - 250 CONTINUE - D(I) = P - IND(I) = ITAG - 290 CONTINUE -C - 1001 RETURN - END -C*MODULE EIGEN *DECK ESTPI1 - DOUBLE PRECISION FUNCTION ESTPI1 (N,EVAL,D,E,X,ANORM) -C* -C* AUTHOR - -C* STEPHEN T. ELBERT (AMES LABORATORY-USDOE) DATE: 5 DEC 1986 -C* -C* PURPOSE - -C* EVALUATE SYMMETRIC TRIDIAGONAL MATRIX PERFORMANCE INDEX -C* * * * * * -C* FOR 1 EIGENVECTOR -C* * -C* -C* METHOD - -C* THIS ROUTINE FORMS THE 1-NORM OF THE RESIDUAL MATRIX A*X-X*EVAL -C* WHERE A IS A SYMMETRIC TRIDIAGONAL MATRIX STORED -C* IN THE DIAGONAL (D) AND SUB-DIAGONAL (E) VECTORS, EVAL IS THE -C* EIGENVALUE OF AN EIGENVECTOR OF A, NAMELY X. -C* THIS NORM IS SCALED BY MACHINE ACCURACY FOR THE PROBLEM SIZE. -C* ALL NORMS APPEARING IN THE COMMENTS BELOW ARE 1-NORMS. -C* -C* ON ENTRY - -C* N - INTEGER -C* THE ORDER OF THE MATRIX A. -C* EVAL - W.P. REAL -C* THE EIGENVALUE CORRESPONDING TO VECTOR X. -C* D - W.P. REAL (N) -C* THE DIAGONAL VECTOR OF A. -C* E - W.P. REAL (N) -C* THE SUB-DIAGONAL VECTOR OF A. -C* X - W.P. REAL (N) -C* AN EIGENVECTOR OF A. -C* ANORM - W.P. REAL -C* THE NORM OF A IF IT HAS BEEN PREVIOUSLY COMPUTED. -C* -C* ON EXIT - -C* ANORM - W.P. REAL -C* THE NORM OF A, COMPUTED IF INITIALLY ZERO. -C* ESTPI1 - W.P. REAL -C* !!A*X-X*EVAL!! / (EPSLON(10*N)*!!A!!*!!X!!); -C* WHERE EPSLON(X) IS THE SMALLEST NUMBER SUCH THAT -C* X + EPSLON(X) .NE. X -C* -C* ESTPI1 .LT. 1 == SATISFACTORY PERFORMANCE -C* .GE. 1 AND .LE. 100 == MARGINAL PERFORMANCE -C* .GT. 100 == POOR PERFORMANCE -C* (SEE LECT. NOTES IN COMP. SCI. VOL.6 PP 124-125) -C - DOUBLE PRECISION ANORM,EVAL,RNORM,SIZE,XNORM - DOUBLE PRECISION D(N), E(N), X(N) - DOUBLE PRECISION EPSLON, ONE, ZERO -C - PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00) -C -C----------------------------------------------------------------------- -C - ESTPI1 = ZERO - IF( N .LE. 1 ) RETURN - SIZE = 10 * N - IF (ANORM .EQ. ZERO) THEN -C -C COMPUTE NORM OF A -C - ANORM = MAX( ABS(D(1)) + ABS(E(2)) - * ,ABS(D(N)) + ABS(E(N))) - DO 110 I = 2, N-1 - ANORM = MAX( ANORM, ABS(E(I))+ABS(D(I))+ABS(E(I+1))) - 110 CONTINUE - IF(ANORM .EQ. ZERO) ANORM = ONE - END IF -C -C COMPUTE NORMS OF RESIDUAL AND EIGENVECTOR -C - XNORM = ABS(X(1)) + ABS(X(N)) - RNORM = ABS( (D(1)-EVAL)*X(1) + E(2)*X(2)) - * +ABS( (D(N)-EVAL)*X(N) + E(N)*X(N-1)) - DO 120 I = 2, N-1 - XNORM = XNORM + ABS(X(I)) - RNORM = RNORM + ABS(E(I)*X(I-1) + (D(I)-EVAL)*X(I) - * + E(I+1)*X(I+1)) - 120 CONTINUE -C - ESTPI1 = RNORM / (EPSLON(SIZE)*ANORM*XNORM) - RETURN - END -C*MODULE EIGEN *DECK ETRBK3 - SUBROUTINE ETRBK3(NM,N,NV,A,M,Z) -C* -C* AUTHORS- -C* THIS IS A MODIFICATION OF ROUTINE TRBAK3 FROM EISPACK EDITION 3 -C* DATED AUGUST 1983. -C* EISPACK TRBAK3 IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, -C* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -C* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) -C* -C* PURPOSE - -C* THIS ROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC -C* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING -C* SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY ETRED3. -C* -C* METHOD - -C* THE CALCULATION IS CARRIED OUT BY FORMING THE MATRIX PRODUCT -C* Q*Z -C* WHERE Q IS A PRODUCT OF THE ORTHOGONAL SYMMETRIC MATRICES -C* Q = PROD(I)[1 - U(I)*.TRANSPOSE.U(I)*H(I)] -C* U IS THE AUGMENTED SUB-DIAGONAL ROWS OF A AND -C* Z IS THE SET OF EIGENVECTORS OF THE TRIDIAGONAL -C* MATRIX F WHICH WAS FORMED FROM THE ORIGINAL SYMMETRIC -C* MATRIX C BY THE SIMILARITY TRANSFORMATION -C* F = Q(TRANSPOSE) C Q -C* NOTE THAT ETRBK3 PRESERVES VECTOR EUCLIDEAN NORMS. -C* -C* -C* COMPLEXITY - -C* M*N**2 -C* -C* ON ENTRY- -C* NM - INTEGER -C* MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C* ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -C* DIMENSION STATEMENT. -C* N - INTEGER -C* THE ORDER OF THE MATRIX A. -C* NV - INTEGER -C* MUST BE SET TO THE DIMENSION OF THE ARRAY A AS -C* DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT. -C* A - W.P. REAL (NV) -C* CONTAINS INFORMATION ABOUT THE ORTHOGONAL -C* TRANSFORMATIONS USED IN THE REDUCTION BY ETRED3 IN -C* ITS FIRST NV = N*(N+1)/2 POSITIONS. -C* M - INTEGER -C* THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. -C* Z - W.P REAL (NM,M) -C* CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED -C* IN ITS FIRST M COLUMNS. -C* -C* ON EXIT- -C* Z - W.P. REAL (NM,M) -C* CONTAINS THE TRANSFORMED EIGENVECTORS -C* IN ITS FIRST M COLUMNS. -C* -C* DIFFERENCES WITH EISPACK 3 - -C* THE TWO INNER LOOPS ARE REPLACED BY DDOT AND DAXPY. -C* MULTIPLICATION USED INSTEAD OF DIVISION TO FIND S. -C* OUTER LOOP RANGE CHANGED FROM 2,N TO 3,N. -C* ADDRESS POINTERS FOR A SIMPLIFIED. -C* -C* NOTE - -C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -C - INTEGER I,II,IM1,IZ,J,M,N,NM,NV -C - DOUBLE PRECISION A(NV),Z(NM,M) - DOUBLE PRECISION H,S,DDOT,ZERO -C - PARAMETER (ZERO = 0.0D+00) -C -C----------------------------------------------------------------------- -C - IF (M .EQ. 0) RETURN - IF (N .LE. 2) RETURN -C - II=3 - DO 140 I = 3, N - IZ=II+1 - II=II+I - H = A(II) - IF (H .EQ. ZERO) GO TO 140 - IM1 = I - 1 - DO 130 J = 1, M - S = -( DDOT(IM1,A(IZ),1,Z(1,J),1) * H) * H - CALL DAXPY(IM1,S,A(IZ),1,Z(1,J),1) - 130 CONTINUE - 140 CONTINUE - RETURN - END -C*MODULE EIGEN *DECK ETRED3 - SUBROUTINE ETRED3(N,NV,A,D,E,E2) -C* -C* AUTHORS - -C* THIS IS A MODIFICATION OF ROUTINE TRED3 FROM EISPACK EDITION 3 -C* DATED AUGUST 1983. -C* EISPACK TRED3 IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, -C* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -C* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C* THIS VERSION IS BY S. T. ELBERT, AMES LABORATORY-USDOE JUN 1986 -C* -C* PURPOSE - -C* THIS ROUTINE REDUCES A REAL SYMMETRIC (PACKED) MATRIX, STORED -C* AS A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX -C* USING ORTHOGONAL SIMILARITY TRANSFORMATIONS, PRESERVING THE -C* INFORMATION ABOUT THE TRANSFORMATIONS IN A. -C* -C* METHOD - -C* THE TRIDIAGONAL REDUCTION IS PERFORMED IN THE FOLLOWING WAY. -C* STARTING WITH J=N, THE ELEMENTS IN THE J-TH ROW TO THE -C* LEFT OF THE DIAGONAL ARE FIRST SCALED, TO AVOID POSSIBLE -C* UNDERFLOW IN THE TRANSFORMATION THAT MIGHT RESULT IN SEVERE -C* DEPARTURE FROM ORTHOGONALITY. THE SUM OF SQUARES SIGMA OF -C* THESE SCALED ELEMENTS IS NEXT FORMED. THEN, A VECTOR U AND -C* A SCALAR -C* H = U(TRANSPOSE) * U / 2 -C* DEFINE A REFLECTION OPERATOR -C* P = I - U * U(TRANSPOSE) / H -C* WHICH IS ORTHOGONAL AND SYMMETRIC AND FOR WHICH THE -C* SIMILIARITY TRANSFORMATION PAP ELIMINATES THE ELEMENTS IN -C* THE J-TH ROW OF A TO THE LEFT OF THE SUBDIAGONAL AND THE -C* SYMMETRICAL ELEMENTS IN THE J-TH COLUMN. -C* -C* THE NON-ZERO COMPONENTS OF U ARE THE ELEMENTS OF THE J-TH -C* ROW TO THE LEFT OF THE DIAGONAL WITH THE LAST OF THEM -C* AUGMENTED BY THE SQUARE ROOT OF SIGMA PREFIXED BY THE SIGN -C* OF THE SUBDIAGONAL ELEMENT. BY STORING THE TRANSFORMED SUB- -C* DIAGONAL ELEMENT IN E(J) AND NOT OVERWRITING THE ROW -C* ELEMENTS ELIMINATED IN THE TRANSFORMATION, FULL INFORMATION -C* ABOUT P IS SAVE FOR LATER USE IN ETRBK3. -C* -C* THE TRANSFORMATION SETS E2(J) EQUAL TO SIGMA AND E(J) -C* EQUAL TO THE SQUARE ROOT OF SIGMA PREFIXED BY THE SIGN -C* OF THE REPLACED SUBDIAGONAL ELEMENT. -C* -C* THE ABOVE STEPS ARE REPEATED ON FURTHER ROWS OF THE -C* TRANSFORMED A IN REVERSE ORDER UNTIL A IS REDUCED TO TRI- -C* DIAGONAL FORM, THAT IS, REPEATED FOR J = N-1,N-2,...,3. -C* -C* COMPLEXITY - -C* 2/3 N**3 -C* -C* ON ENTRY- -C* N - INTEGER -C* THE ORDER OF THE MATRIX. -C* NV - INTEGER -C* MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A -C* AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT -C* A - W.P. REAL (NV) -C* CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC -C* INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL -C* ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. -C* -C* ON EXIT- -C* A - W.P. REAL (NV) -C* CONTAINS INFORMATION ABOUT THE ORTHOGONAL -C* TRANSFORMATIONS USED IN THE REDUCTION. -C* D - W.P. REAL (N) -C* CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL -C* MATRIX. -C* E - W.P. REAL (N) -C* CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL -C* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO -C* E2 - W.P. REAL (N) -C* CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF -C* E. MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. -C* -C* DIFFERENCES FROM EISPACK 3 - -C* OUTER LOOP CHANGED FROM II=1,N TO I=N,3,-1 -C* PARAMETER STATEMENT AND GENERIC INTRINSIC FUNCTIONS USED -C* SCALE.NE.0 TEST NOW SPOTS TRI-DIAGONAL FORM -C* VALUES LESS THAN EPSLON CLEARED TO ZERO -C* USE BLAS(1) -C* U NOT COPIED TO D, LEFT IN A -C* E2 COMPUTED FROM E -C* INNER LOOPS SPLIT INTO ROUTINES ELAU AND FREDA -C* INVERSE OF H STORED INSTEAD OF H -C* -C* NOTE - -C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -C - INTEGER I,IIA,IZ0,L,N,NV -C - DOUBLE PRECISION A(NV),D(N),E(N),E2(N) - DOUBLE PRECISION AIIMAX,F,G,H,HROOT,SCALE,SCALEI - DOUBLE PRECISION DASUM, DNRM2 - DOUBLE PRECISION ONE, ZERO -C - PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00) -C -C----------------------------------------------------------------------- -C - IF (N .LE. 2) GO TO 310 - IZ0 = (N*N+N)/2 - AIIMAX = ABS(A(IZ0)) - DO 300 I = N, 3, -1 - L = I - 1 - IIA = IZ0 - IZ0 = IZ0 - I - AIIMAX = MAX(AIIMAX, ABS(A(IIA))) - SCALE = DASUM (L, A(IZ0+1), 1) - IF(SCALE .EQ. ABS(A(IIA-1)) .OR. AIIMAX+SCALE .EQ. AIIMAX) THEN -C -C THIS ROW IS ALREADY IN TRI-DIAGONAL FORM -C - D(I) = A(IIA) - IF (AIIMAX+D(I) .EQ. AIIMAX) D(I) = ZERO - E(I) = A(IIA-1) - IF (AIIMAX+E(I) .EQ. AIIMAX) E(I) = ZERO - E2(I) = E(I)*E(I) - A(IIA) = ZERO - GO TO 300 -C - END IF -C - SCALEI = ONE / SCALE - CALL DSCAL(L,SCALEI,A(IZ0+1),1) - HROOT = DNRM2(L,A(IZ0+1),1) -C - F = A(IZ0+L) - G = -SIGN(HROOT,F) - E(I) = SCALE * G - E2(I) = E(I)*E(I) - H = HROOT*HROOT - F * G - A(IZ0+L) = F - G - D(I) = A(IIA) - A(IIA) = ONE / SQRT(H) -C .......... FORM P THEN Q IN E(1:L) .......... - CALL ELAU(ONE/H,L,A(IZ0+1),A,E) -C .......... FORM REDUCED A .......... - CALL FREDA(L,A(IZ0+1),A,E) -C - 300 CONTINUE - 310 CONTINUE - E(1) = ZERO - E2(1)= ZERO - D(1) = A(1) - IF(N.EQ.1) RETURN -C - E(2) = A(2) - E2(2)= A(2)*A(2) - D(2) = A(3) - RETURN - END -C*MODULE EIGEN *DECK EVVRSP - SUBROUTINE EVVRSP(MSGFL,N,NVECT,LENA,NV,A,B,IND,ROOT, - * VECT,IORDER,IERR) -C* -C* AUTHOR: S. T. ELBERT, AMES LABORATORY-USDOE, JUNE 1985 -C* -C* PURPOSE - -C* FINDS (ALL) EIGENVALUES AND (SOME OR ALL) EIGENVECTORS -C* * * * -C* OF A REAL SYMMETRIC PACKED MATRIX. -C* * * * -C* -C* METHOD - -C* THE METHOD AS PRESENTED IN THIS ROUTINE CONSISTS OF FOUR STEPS: -C* FIRST, THE INPUT MATRIX IS REDUCED TO TRIDIAGONAL FORM BY THE -C* HOUSEHOLDER TECHNIQUE (ORTHOGONAL SIMILARITY TRANSFORMATIONS). -C* SECOND, THE ROOTS ARE LOCATED USING THE RATIONAL QL METHOD. -C* THIRD, THE VECTORS OF THE TRIDIAGONAL FORM ARE EVALUATED BY THE -C* INVERSE ITERATION TECHNIQUE. VECTORS FOR DEGENERATE OR NEAR- -C* DEGENERATE ROOTS ARE FORCED TO BE ORTHOGONAL. -C* FOURTH, THE TRIDIAGONAL VECTORS ARE ROTATED TO VECTORS OF THE -C* ORIGINAL ARRAY. -C* -C* THESE ROUTINES ARE MODIFICATIONS OF THE EISPACK 3 -C* ROUTINES TRED3, TQLRAT, TINVIT AND TRBAK3 -C* -C* FOR FURTHER DETAILS, SEE EISPACK USERS GUIDE, B. T. SMITH -C* ET AL, SPRINGER-VERLAG, LECTURE NOTES IN COMPUTER SCIENCE, -C* VOL. 6, 2-ND EDITION, 1976. ANOTHER GOOD REFERENCE IS -C* THE SYMMETRIC EIGENVALUE PROBLEM BY B. N. PARLETT -C* PUBLISHED BY PRENTICE-HALL, INC., ENGLEWOOD CLIFFS, N.J. (1980) -C* -C* ON ENTRY - -C* MSGFL - INTEGER (LOGICAL UNIT NO.) -C* FILE WHERE ERROR MESSAGES WILL BE PRINTED. -C* IF MSGFL IS 0, ERROR MESSAGES WILL BE PRINTED ON LU 6. -C* IF MSGFL IS NEGATIVE, NO ERROR MESSAGES PRINTED. -C* N - INTEGER -C* ORDER OF MATRIX A. -C* NVECT - INTEGER -C* NUMBER OF VECTORS DESIRED. 0 .LE. NVECT .LE. N. -C* LENA - INTEGER -C* DIMENSION OF A IN CALLING ROUTINE. MUST NOT BE LESS -C* THAN (N*N+N)/2. -C* NV - INTEGER -C* ROW DIMENSION OF VECT IN CALLING ROUTINE. N .LE. NV. -C* A - WORKING PRECISION REAL (LENA) -C* INPUT MATRIX, ROWS OF THE LOWER TRIANGLE PACKED INTO -C* LINEAR ARRAY OF DIMENSION N*(N+1)/2. THE PACKED ORDER -C* IS A(1,1), A(2,1), A(2,2), A(3,1), A(3,2), ... -C* B - WORKING PRECISION REAL (N,8) -C* SCRATCH ARRAY, 8*N ELEMENTS -C* IND - INTEGER (N) -C* SCRATCH ARRAY OF LENGTH N. -C* IORDER - INTEGER -C* ROOT ORDERING FLAG. -C* = 0, ROOTS WILL BE PUT IN ASCENDING ORDER. -C* = 2, ROOTS WILL BE PUT IN DESCENDING ORDER. -C* -C* ON EXIT - -C* A - DESTORYED. NOW HOLDS REFLECTION OPERATORS. -C* ROOT - WORKING PRECISION REAL (N) -C* ALL EIGENVALUES IN ASCENDING OR DESCENDING ORDER. -C* IF IORDER = 0, ROOT(1) .LE. ... .LE. ROOT(N) -C* IF IORDER = 2, ROOT(1) .GE. ... .GE. ROOT(N) -C* VECT - WORKING PRECISION REAL (NV,NVECT) -C* EIGENVECTORS FOR ROOT(1), ..., ROOT(NVECT). -C* IERR - INTEGER -C* = 0 IF NO ERROR DETECTED, -C* = K IF ITERATION FOR K-TH EIGENVALUE FAILED, -C* = -K IF ITERATION FOR K-TH EIGENVECTOR FAILED. -C* (FAILURES SHOULD BE VERY RARE. CONTACT C. MOLER.) -C* -C - LOGICAL GOPARR,DSKWRK,MASWRK -C - DOUBLE PRECISION A(LENA) - DOUBLE PRECISION B(N,8) - DOUBLE PRECISION ROOT(N) - DOUBLE PRECISION T - DOUBLE PRECISION VECT(NV,*) -C - INTEGER IND(N) -C - COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK -C - 900 FORMAT(26H0*** EVVRSP PARAMETERS ***/ - + 14H *** N = ,I8,4H ***/ - + 14H *** NVECT = ,I8,4H ***/ - + 14H *** LENA = ,I8,4H ***/ - + 14H *** NV = ,I8,4H ***/ - + 14H *** IORDER = ,I8,4H ***/ - + 14H *** IERR = ,I8,4H ***) - 901 FORMAT(37H VALUE OF LENA IS LESS THAN (N*N+N)/2) - 902 FORMAT(39H EQLRAT HAS FAILED TO CONVERGE FOR ROOT,I5) - 903 FORMAT(18H NV IS LESS THAN N) - 904 FORMAT(41H EINVIT HAS FAILED TO CONVERGE FOR VECTOR,I5) - 905 FORMAT(51H VALUE OF IORDER MUST BE 0 (SMALLEST ROOT FIRST) OR - * ,23H 2 (LARGEST ROOT FIRST)) - 906 FORMAT(' VALUE OF N IS LESS THAN OR EQUAL ZERO') -C -C----------------------------------------------------------------------- -C - LMSGFL=MSGFL - IF (MSGFL .EQ. 0) LMSGFL=6 - IERR = N - 1 - IF (N .LE. 0) GO TO 800 - IERR = N + 1 - IF ( (N*N+N)/2 .GT. LENA) GO TO 810 -C -C REDUCE REAL SYMMETRIC MATRIX A TO TRIDIAGONAL FORM -C - CALL ETRED3(N,LENA,A,B(1,1),B(1,2),B(1,3)) -C -C FIND ALL EIGENVALUES OF TRIDIAGONAL MATRIX -C - CALL EQLRAT(N,B(1,1),B(1,2),B(1,3),ROOT,IND,IERR,B(1,4)) - IF (IERR .NE. 0) GO TO 820 -C -C CHECK THE DESIRED ORDER OF THE EIGENVALUES -C - B(1,3) = IORDER - IF (IORDER .EQ. 0) GO TO 300 - IF (IORDER .NE. 2) GO TO 850 -C -C ORDER ROOTS IN DESCENDING ORDER (LARGEST FIRST)... -C TURN ROOT AND IND ARRAYS END FOR END -C - DO 210 I = 1, N/2 - J = N+1-I - T = ROOT(I) - ROOT(I) = ROOT(J) - ROOT(J) = T - L = IND(I) - IND(I) = IND(J) - IND(J) = L - 210 CONTINUE -C -C FIND I AND J MARKING THE START AND END OF A SEQUENCE -C OF DEGENERATE ROOTS -C - I=0 - 220 CONTINUE - I = I+1 - IF (I .GT. N) GO TO 300 - DO 230 J=I,N - IF (ROOT(J) .NE. ROOT(I)) GO TO 240 - 230 CONTINUE - J = N+1 - 240 CONTINUE - J = J-1 - IF (J .EQ. I) GO TO 220 -C -C TURN AROUND IND BETWEEN I AND J -C - JSV = J - KLIM = (J-I+1)/2 - DO 250 K=1,KLIM - L = IND(J) - IND(J) = IND(I) - IND(I) = L - I = I+1 - J = J-1 - 250 CONTINUE - I = JSV - GO TO 220 -C - 300 CONTINUE -C - IF (NVECT .LE. 0) RETURN - IF (NV .LT. N) GO TO 830 -C -C FIND EIGENVECTORS OF TRI-DIAGONAL MATRIX VIA INVERSE ITERATION -C - IERR = LMSGFL - CALL EINVIT(NV,N,B(1,1),B(1,2),B(1,3),NVECT,ROOT,IND, - + VECT,IERR,B(1,4),B(1,5),B(1,6),B(1,7),B(1,8)) - IF (IERR .NE. 0) GO TO 840 -C -C FIND EIGENVECTORS OF SYMMETRIC MATRIX VIA BACK TRANSFORMATION -C - 400 CONTINUE - CALL ETRBK3(NV,N,LENA,A,NVECT,VECT) - RETURN -C -C ERROR MESSAGE SECTION -C - 800 IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,906) - GO TO 890 -C - 810 IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,901) - GO TO 890 -C - 820 IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,902) IERR - GO TO 890 -C - 830 IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,903) - GO TO 890 -C - 840 CONTINUE - IF ((LMSGFL .GT. 0).AND.MASWRK) WRITE(LMSGFL,904) -IERR - GO TO 400 -C - 850 IERR=-1 - IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,905) - GO TO 890 -C - 890 CONTINUE - IF (MASWRK) WRITE(LMSGFL,900) N,NVECT,LENA,NV,IORDER,IERR - RETURN - END -C*MODULE EIGEN *DECK FREDA - SUBROUTINE FREDA(L,D,A,E) -C - DOUBLE PRECISION A(*) - DOUBLE PRECISION D(L) - DOUBLE PRECISION E(L) - DOUBLE PRECISION F - DOUBLE PRECISION G -C - JK = 1 -C -C .......... FORM REDUCED A .......... -C - DO 280 J = 1, L - F = D(J) - G = E(J) -C - DO 260 K = 1, J - A(JK) = A(JK) - F * E(K) - G * D(K) - JK = JK + 1 - 260 CONTINUE -C - 280 CONTINUE - RETURN - END -C*MODULE EIGEN *DECK GIVEIS - SUBROUTINE GIVEIS(N,NVECT,NV,A,B,INDB,ROOT,VECT,IERR) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION A(*),B(N,8),INDB(N),ROOT(N),VECT(NV,NVECT) -C -C EISPACK-BASED SUBSTITUTE FOR QCPE ROUTINE GIVENS. -C FINDS ALL EIGENVALUES AND SOME EIGENVECTORS OF A REAL SYMMETRIC -C MATRIX. AUTHOR.. C. MOLER AND D. SPANGLER, N.R.C.C., 4/1/79. -C -C INPUT.. -C N = ORDER OF MATRIX . -C NVECT = NUMBER OF VECTORS DESIRED. 0 .LE. NVECT .LE. N . -C NV = LEADING DIMENSION OF VECT . -C A = INPUT MATRIX, COLUMNS OF THE UPPER TRIANGLE PACKED INTO -C LINEAR ARRAY OF DIMENSION N*(N+1)/2 . -C B = SCRATCH ARRAY, 8*N ELEMENTS (NOTE THIS IS MORE THAN -C PREVIOUS VERSIONS OF GIVENS.) -C IND = INDEX ARRAY OF N ELEMENTS -C -C OUTPUT.. -C A DESTROYED . -C ROOT = ALL EIGENVALUES, ROOT(1) .LE. ... .LE. ROOT(N) . -C (FOR OTHER ORDERINGS, SEE BELOW.) -C VECT = EIGENVECTORS FOR ROOT(1),..., ROOT(NVECT) . -C IERR = 0 IF NO ERROR DETECTED, -C = K IF ITERATION FOR K-TH EIGENVALUE FAILED, -C = -K IF ITERATION FOR K-TH EIGENVECTOR FAILED. -C (FAILURES SHOULD BE VERY RARE. CONTACT MOLER.) -C -C CALLS MODIFIED EISPACK ROUTINES TRED3B, IMTQLV, TINVTB, AND -C TRBK3B. THE ROUTINES TRED3B, TINVTB, AND TRBK3B. -C THE ORIGINAL EISPACK ROUTINES TRED3, TINVIT, AND TRBAK3 -C WERE MODIFIED BY THE INTRODUCTION OF TWO ROUTINES FROM THE -C BLAS LIBRARY - DDOT AND DAXPY. -C -C IF TINVIT FAILS TO CONVERGE, TQL2 IS CALLED -C -C SEE EISPACK USERS GUIDE, B. T. SMITH ET AL, SPRINGER-VERLAG -C LECTURE NOTES IN COMPUTER SCIENCE, VOL. 6, 2-ND EDITION, 1976 . -C NOTE THAT IMTQLV AND TINVTB HAVE INTERNAL MACHINE -C DEPENDENT CONSTANTS. -C - DATA ONE, ZERO /1.0D+00, 0.0D+00/ - CALL TRED3B(N,(N*N+N)/2,A,B(1,1),B(1,2),B(1,3)) - CALL IMTQLV(N,B(1,1),B(1,2),B(1,3),ROOT,INDB,IERR,B(1,4)) - IF (IERR .NE. 0) RETURN -C -C TO REORDER ROOTS... -C K = N/2 -C B(1,3) = 2.0D+00 -C DO 50 I = 1, K -C J = N+1-I -C T = ROOT(I) -C ROOT(I) = ROOT(J) -C ROOT(J) = T -C 50 CONTINUE -C - IF (NVECT .LE. 0) RETURN - CALL TINVTB(NV,N,B(1,1),B(1,2),B(1,3),NVECT,ROOT,INDB,VECT,IERR, - + B(1,4),B(1,5),B(1,6),B(1,7),B(1,8)) - IF (IERR .EQ. 0) GO TO 160 -C -C IF INVERSE ITERATION GIVES AN ERROR IN DETERMINING THE -C EIGENVECTORS, TRY THE QL ALGORITHM IF ALL THE EIGENVECTORS -C ARE DESIRED. -C - IF (NVECT .NE. N) RETURN - DO 120 I = 1, NVECT - DO 100 J = 1, N - VECT(I,J) = ZERO - 100 CONTINUE - VECT(I,I) = ONE - 120 CONTINUE - CALL TQL2 (NV,N,B(1,1),B(1,2),VECT,IERR) - DO 140 I = 1, NVECT - ROOT(I) = B(I,1) - 140 CONTINUE - IF (IERR .NE. 0) RETURN - 160 CALL TRBK3B(NV,N,(N*N+N)/2,A,NVECT,VECT) - RETURN - END -C*MODULE EIGEN *DECK GLDIAG - SUBROUTINE GLDIAG(LDVECT,NVECT,N,H,WRK,EIG,VECTOR,IERR,IWRK) -C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) -C - LOGICAL GOPARR,DSKWRK,MASWRK -C - DIMENSION H(*),WRK(N,8),EIG(N),VECTOR(LDVECT,NVECT),IWRK(N) -C - COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) - COMMON /MACHSW/ KDIAG,ICORFL,IXDR - COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK -C -C ----- GENERAL ROUTINE TO DIAGONALIZE A SYMMETRIC MATRIX ----- -C IF KDIAG = 0, USE A ROUTINE FROM THE VECTOR LIBRARY, -C IF AVAILABLE (SEE THE SUBROUTINE 'GLDIAG' -C IN VECTOR.SRC), OR EVVRSP OTHERWISE -C = 1, USE EVVRSP -C = 2, USE GIVEIS -C = 3, USE JACOBI -C -C N = DIMENSION (ORDER) OF MATRIX TO BE SOLVED -C LDVECT = LEADING DIMENSION OF VECTOR -C NVECT = NUMBER OF VECTORS DESIRED -C H = MATRIX TO BE DIAGONALIZED -C WRK = N*8 W.P. REAL WORDS OF SCRATCH SPACE -C EIG = EIGENVECTORS (OUTPUT) -C VECTOR = EIGENVECTORS (OUTPUT) -C IERR = ERROR FLAG (OUTPUT) -C IWRK = N INTEGER WORDS OF SCRATCH SPACE -C - IERR = 0 -C -C ----- USE STEVE ELBERT'S ROUTINE ----- -C - IF(KDIAG.LE.1 .OR. KDIAG.GT.3) THEN - LENH = (N*N+N)/2 - KORDER =0 - CALL EVVRSP(IW,N,NVECT,LENH,LDVECT,H,WRK,IWRK,EIG,VECTOR - * ,KORDER,IERR) - END IF -C -C ----- USE MODIFIED EISPAK ROUTINE ----- -C - IF(KDIAG.EQ.2) - * CALL GIVEIS(N,NVECT,LDVECT,H,WRK,IWRK,EIG,VECTOR,IERR) -C -C ----- USE JACOBI ROTATION ROUTINE ----- -C - IF(KDIAG.EQ.3) THEN - IF(NVECT.EQ.N) THEN - CALL JACDG(H,VECTOR,EIG,IWRK,WRK,LDVECT,N) - ELSE - IF (MASWRK) WRITE(IW,9000) N,NVECT,LDVECT - CALL ABRT - END IF - END IF - RETURN -C - 9000 FORMAT(1X,'IN -GLDIAG-, N,NVECT,LDVECT=',3I8/ - * 1X,'THE JACOBI CODE CANNOT COPE WITH N.NE.NVECT!'/ - * 1X,'SO THIS RUN DOES NOT PERMIT KDIAG=3.') - END -C*MODULE EIGEN *DECK IMTQLV - SUBROUTINE IMTQLV(N,D,E,E2,W,IND,IERR,RV1) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER TAG - DOUBLE PRECISION MACHEP - DIMENSION D(N),E(N),E2(N),W(N),RV1(N),IND(N) -C -C THIS ROUTINE IS A VARIANT OF IMTQL1 WHICH IS A TRANSLATION OF -C ALGOL PROCEDURE IMTQL1, NUM. MATH. 12, 377-383(1968) BY MARTIN AND -C WILKINSON, AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). -C -C THIS ROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL -C MATRIX BY THE IMPLICIT QL METHOD AND ASSOCIATES WITH THEM -C THEIR CORRESPONDING SUBMATRIX INDICES. -C -C ON INPUT- -C -C N IS THE ORDER OF THE MATRIX, -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, -C -C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, -C -C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. -C E2(1) IS ARBITRARY. -C -C ON OUTPUT- -C -C D AND E ARE UNALTERED, -C -C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED -C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE -C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. -C E2(1) IS ALSO SET TO ZERO, -C -C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN -C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND -C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE -C THE SMALLEST EIGENVALUES, -C -C IND CONTAINS THE SUBMATRIX INDICES ASSOCIATED WITH THE -C CORRESPONDING EIGENVALUES IN W -- 1 FOR EIGENVALUES -C BELONGING TO THE FIRST SUBMATRIX FROM THE TOP, -C 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC., -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C J IF THE J-TH EIGENVALUE HAS NOT BEEN -C DETERMINED AFTER 30 ITERATIONS, -C -C RV1 IS A TEMPORARY STORAGE ARRAY. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C -C ------------------------------------------------------------------ -C -C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING -C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. -C -C ********** - MACHEP = 2.0D+00**(-50) -C - IERR = 0 - K = 0 - TAG = 0 -C - DO 100 I = 1, N - W(I) = D(I) - IF (I .NE. 1) RV1(I-1) = E(I) - 100 CONTINUE -C - E2(1) = 0.0D+00 - RV1(N) = 0.0D+00 -C - DO 360 L = 1, N - J = 0 -C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** - 120 DO 140 M = L, N - IF (M .EQ. N) GO TO 160 - IF (ABS(RV1(M)) .LE. MACHEP * (ABS(W(M)) + ABS(W(M+1)))) GO TO - + 160 -C ********** GUARD AGAINST UNDERFLOWED ELEMENT OF E2 ********** - IF (E2(M+1) .EQ. 0.0D+00) GO TO 180 - 140 CONTINUE -C - 160 IF (M .LE. K) GO TO 200 - IF (M .NE. N) E2(M+1) = 0.0D+00 - 180 K = M - TAG = TAG + 1 - 200 P = W(L) - IF (M .EQ. L) GO TO 280 - IF (J .EQ. 30) GO TO 380 - J = J + 1 -C ********** FORM SHIFT ********** - G = (W(L+1) - P) / (2.0D+00 * RV1(L)) - R = SQRT(G*G+1.0D+00) - G = W(M) - P + RV1(L) / (G + SIGN(R,G)) - S = 1.0D+00 - C = 1.0D+00 - P = 0.0D+00 - MML = M - L -C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** - DO 260 II = 1, MML - I = M - II - F = S * RV1(I) - B = C * RV1(I) - IF (ABS(F) .LT. ABS(G)) GO TO 220 - C = G / F - R = SQRT(C*C+1.0D+00) - RV1(I+1) = F * R - S = 1.0D+00 / R - C = C * S - GO TO 240 - 220 S = F / G - R = SQRT(S*S+1.0D+00) - RV1(I+1) = G * R - C = 1.0D+00 / R - S = S * C - 240 G = W(I+1) - P - R = (W(I) - G) * S + 2.0D+00 * C * B - P = S * R - W(I+1) = G + P - G = C * R - B - 260 CONTINUE -C - W(L) = W(L) - P - RV1(L) = G - RV1(M) = 0.0D+00 - GO TO 120 -C ********** ORDER EIGENVALUES ********** - 280 IF (L .EQ. 1) GO TO 320 -C ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** - DO 300 II = 2, L - I = L + 2 - II - IF (P .GE. W(I-1)) GO TO 340 - W(I) = W(I-1) - IND(I) = IND(I-1) - 300 CONTINUE -C - 320 I = 1 - 340 W(I) = P - IND(I) = TAG - 360 CONTINUE -C - GO TO 400 -C ********** SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS ********** - 380 IERR = L - 400 RETURN -C ********** LAST CARD OF IMTQLV ********** - END -C*MODULE EIGEN *DECK JACDG - SUBROUTINE JACDG(A,VEC,EIG,JBIG,BIG,LDVEC,N) -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) -C - DIMENSION A(*),VEC(LDVEC,N),EIG(N),JBIG(N),BIG(N) -C - PARAMETER (ONE=1.0D+00) -C -C ----- JACOBI DIAGONALIZATION OF SYMMETRIC MATRIX ----- -C SYMMETRIC MATRIX -A- OF DIMENSION -N- IS DESTROYED ON EXIT. -C ALL EIGENVECTORS ARE FOUND, SO -VEC- MUST BE SQUARE, -C UNLESS SOMEONE TAKES THE TROUBLE TO LOOK AT -NMAX- BELOW. -C -BIG- AND -JBIG- ARE SCRATCH WORK ARRAYS. -C - CALL VCLR(VEC,1,LDVEC*N) - DO 20 I = 1,N - VEC(I,I) = ONE - 20 CONTINUE -C - NB1 = N - NB2 = (NB1*NB1+NB1)/2 - NMIN = 1 - NMAX = NB1 -C - CALL JACDIA(A,VEC,NB1,NB2,LDVEC,NMIN,NMAX,BIG,JBIG) -C - DO 30 I=1,N - EIG(I) = A((I*I+I)/2) - 30 CONTINUE -C - CALL JACORD(VEC,EIG,NB1,LDVEC) - RETURN - END -C*MODULE EIGEN *DECK JACDIA - SUBROUTINE JACDIA(F,VEC,NB1,NB2,LDVEC,NMIN,NMAX,BIG,JBIG) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL GOPARR,DSKWRK,MASWRK - DIMENSION F(NB2),VEC(LDVEC,NB1),BIG(NB1),JBIG(NB1) -C - COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK -C - PARAMETER (ROOT2=0.707106781186548D+00 ) - PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, D1050=1.05D+00, - * D1500=1.5D+00, D3875=3.875D+00, - * D0500=0.5D+00, D1375=1.375D+00, D0250=0.25D+00 ) - PARAMETER (C2=1.0D-12, C3=4.0D-16, - * C4=2.0D-16, C5=8.0D-09, C6=3.0D-06 ) -C -C F IS THE MATRIX TO BE DIAGONALIZED, F IS STORED TRIANGULAR -C VEC IS THE ARRAY OF EIGENVECTORS, DIMENSION NB1*NB1 -C BIG AND JBIG ARE TEMPORARY SCRATCH AREAS OF DIMENSION NB1 -C THE ROTATIONS AMONG THE FIRST NMIN BASIS FUNCTIONS ARE NOT -C ACCOUNTED FOR. -C THE ROTATIONS AMONG THE LAST NB1-NMAX BASIS FUNCTIONS ARE NOT -C ACCOUNTED FOR. -C - IEAA=0 - IEAB=0 - TT=ZERO - EPS = 64.0D+00*EPSLON(ONE) -C -C LOOP OVER COLUMNS (K) OF TRIANGULAR MATRIX TO DETERMINE -C LARGEST OFF-DIAGONAL ELEMENTS IN ROW(I). -C - DO 20 I=1,NB1 - BIG(I)=ZERO - JBIG(I)=0 - IF(I.LT.NMIN .OR. I.EQ.1) GO TO 20 - II = (I*I-I)/2 - J=MIN(I-1,NMAX) - DO 10 K=1,J - IF(ABS(BIG(I)).GE.ABS(F(II+K))) GO TO 10 - BIG(I)=F(II+K) - JBIG(I)=K - 10 CONTINUE - 20 CONTINUE -C -C ----- 2X2 JACOBI ITERATIONS BEGIN HERE ----- -C - MAXIT=MAX(NB2*20,500) - ITER=0 - 30 CONTINUE - ITER=ITER+1 -C -C FIND SMALLEST DIAGONAL ELEMENT -C - SD=D1050 - JJ=0 - DO 40 J=1,NB1 - JJ=JJ+J - SD= MIN(SD,ABS(F(JJ))) - 40 CONTINUE - TEST = MAX(EPS, C2*MAX(SD,C6)) -C -C FIND LARGEST OFF-DIAGONAL ELEMENT -C - T=ZERO - I1=MAX(2,NMIN) - IB = I1 - DO 50 I=I1,NB1 - IF(T.GE.ABS(BIG(I))) GO TO 50 - T= ABS(BIG(I)) - IB=I - 50 CONTINUE -C -C TEST FOR CONVERGENCE, THEN DETERMINE ROTATION. -C - IF(T.LT.TEST) RETURN -C ****** -C - IF(ITER.GT.MAXIT) THEN - IF (MASWRK) THEN - WRITE(6,*) 'JACOBI DIAGONALIZATION FAILS, DIMENSION=',NB1 - WRITE(6,9020) ITER,T,TEST,SD - ENDIF - CALL ABRT - STOP - END IF -C - IA=JBIG(IB) - IAA=IA*(IA-1)/2 - IBB=IB*(IB-1)/2 - DIF=F(IAA+IA)-F(IBB+IB) - IF(ABS(DIF).GT.C3*T) GO TO 70 - SX=ROOT2 - CX=ROOT2 - GO TO 110 - 70 T2X2=BIG(IB)/DIF - T2X25=T2X2*T2X2 - IF(T2X25 . GT . C4) GO TO 80 - CX=ONE - SX=T2X2 - GO TO 110 - 80 IF(T2X25 . GT . C5) GO TO 90 - SX=T2X2*(ONE-D1500*T2X25) - CX=ONE-D0500*T2X25 - GO TO 110 - 90 IF(T2X25 . GT . C6) GO TO 100 - CX=ONE+T2X25*(T2X25*D1375 - D0500) - SX= T2X2*(ONE + T2X25*(T2X25*D3875 - D1500)) - GO TO 110 - 100 T=D0250 / SQRT(D0250 + T2X25) - CX= SQRT(D0500 + T) - SX= SIGN( SQRT(D0500 - T),T2X2) - 110 IEAR=IAA+1 - IEBR=IBB+1 -C - DO 230 IR=1,NB1 - T=F(IEAR)*SX - F(IEAR)=F(IEAR)*CX+F(IEBR)*SX - F(IEBR)=T-F(IEBR)*CX - IF(IR-IA) 220,120,130 - 120 TT=F(IEBR) - IEAA=IEAR - IEAB=IEBR - F(IEBR)=BIG(IB) - IEAR=IEAR+IR-1 - IF(JBIG(IR)) 200,220,200 - 130 T=F(IEAR) - IT=IA - IEAR=IEAR+IR-1 - IF(IR-IB) 180,150,160 - 150 F(IEAA)=F(IEAA)*CX+F(IEAB)*SX - F(IEAB)=TT*CX+F(IEBR)*SX - F(IEBR)=TT*SX-F(IEBR)*CX - IEBR=IEBR+IR-1 - GO TO 200 - 160 IF( ABS(T) . GE . ABS(F(IEBR))) GO TO 170 - IF(IB.GT.NMAX) GO TO 170 - T=F(IEBR) - IT=IB - 170 IEBR=IEBR+IR-1 - 180 IF( ABS(T) . LT . ABS(BIG(IR))) GO TO 190 - BIG(IR) = T - JBIG(IR) = IT - GO TO 220 - 190 IF(IA . NE . JBIG(IR) . AND . IB . NE . JBIG(IR)) GO TO 220 - 200 KQ=IEAR-IR-IA+1 - BIG(IR)=ZERO - IR1=MIN(IR-1,NMAX) - DO 210 I=1,IR1 - K=KQ+I - IF(ABS(BIG(IR)) . GE . ABS(F(K))) GO TO 210 - BIG(IR) = F(K) - JBIG(IR)=I - 210 CONTINUE - 220 IEAR=IEAR+1 - 230 IEBR=IEBR+1 -C - DO 240 I=1,NB1 - T1=VEC(I,IA)*CX + VEC(I,IB)*SX - T2=VEC(I,IA)*SX - VEC(I,IB)*CX - VEC(I,IA)=T1 - VEC(I,IB)=T2 - 240 CONTINUE - GO TO 30 -C - 9020 FORMAT(1X,'ITER=',I6,' T,TEST,SD=',1P,3E20.10) - END -C*MODULE EIGEN *DECK JACORD - SUBROUTINE JACORD(VEC,EIG,N,LDVEC) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION VEC(LDVEC,N),EIG(N) -C -C ---- SORT EIGENDATA INTO ASCENDING ORDER ----- -C - DO 290 I = 1, N - JJ = I - DO 270 J = I, N - IF (EIG(J) .LT. EIG(JJ)) JJ = J - 270 CONTINUE - IF (JJ .EQ. I) GO TO 290 - T = EIG(JJ) - EIG(JJ) = EIG(I) - EIG(I) = T - DO 280 J = 1, N - T = VEC(J,JJ) - VEC(J,JJ) = VEC(J,I) - VEC(J,I) = T - 280 CONTINUE - 290 CONTINUE - RETURN - END -C*MODULE EIGEN *DECK TINVTB - SUBROUTINE TINVTB(NM,N,D,E,E2,M,W,IND,Z, - * IERR,RV1,RV2,RV3,RV4,RV6) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION D(N),E(N),E2(N),W(M),Z(NM,M), - * RV1(N),RV2(N),RV3(N),RV4(N),RV6(N),IND(M) - DOUBLE PRECISION MACHEP,NORM - INTEGER P,Q,R,S,TAG,GROUP -C ------------------------------------------------------------------ -C -C THIS ROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH- -C NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). -C -C THIS ROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL -C SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, -C USING INVERSE ITERATION. -C -C ON INPUT- -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -C DIMENSION STATEMENT, -C -C N IS THE ORDER OF THE MATRIX, -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, -C -C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, -C -C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E, -C WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. -C E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN -C THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM -C OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN -C 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0 -C IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT, -C TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES, -C THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE, -C -C M IS THE NUMBER OF SPECIFIED EIGENVALUES, -C -C W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER, -C -C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES -C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- -C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM -C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC. -C -C ON OUTPUT- -C -C ALL INPUT ARRAYS ARE UNALTERED, -C -C Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. -C ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO, -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH -C EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS, -C -C RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C -C ------------------------------------------------------------------ -C -C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING -C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. -C -C ********** - MACHEP = 2.0D+00**(-50) -C - IERR = 0 - IF (M .EQ. 0) GO TO 680 - TAG = 0 - ORDER = 1.0D+00 - E2(1) - XU = 0.0D+00 - UK = 0.0D+00 - X0 = 0.0D+00 - U = 0.0D+00 - EPS2 = 0.0D+00 - EPS3 = 0.0D+00 - EPS4 = 0.0D+00 - GROUP = 0 - Q = 0 -C ********** ESTABLISH AND PROCESS NEXT SUBMATRIX ********** - 100 P = Q + 1 - IP = P + 1 -C - DO 120 Q = P, N - IF (Q .EQ. N) GO TO 140 - IF (E2(Q+1) .EQ. 0.0D+00) GO TO 140 - 120 CONTINUE -C ********** FIND VECTORS BY INVERSE ITERATION ********** - 140 TAG = TAG + 1 - IQMP = Q - P + 1 - S = 0 -C - DO 660 R = 1, M - IF (IND(R) .NE. TAG) GO TO 660 - ITS = 1 - X1 = W(R) - IF (S .NE. 0) GO TO 220 -C ********** CHECK FOR ISOLATED ROOT ********** - XU = 1.0D+00 - IF (P .NE. Q) GO TO 160 - RV6(P) = 1.0D+00 - GO TO 600 - 160 NORM = ABS(D(P)) -C - DO 180 I = IP, Q - 180 NORM = NORM + ABS(D(I)) + ABS(E(I)) -C ********** EPS2 IS THE CRITERION FOR GROUPING, -C EPS3 REPLACES ZERO PIVOTS AND EQUAL -C ROOTS ARE MODIFIED BY EPS3, -C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ********** - EPS2 = 1.0D-03 * NORM - EPS3 = MACHEP * NORM - UK = IQMP - EPS4 = UK * EPS3 - UK = EPS4 / SQRT(UK) - S = P - 200 GROUP = 0 - GO TO 240 -C ********** LOOK FOR CLOSE OR COINCIDENT ROOTS ********** - 220 IF (ABS(X1-X0) .GE. EPS2) GO TO 200 - GROUP = GROUP + 1 - IF (ORDER * (X1 - X0) .LE. 0.0D+00) X1 = X0 + ORDER * EPS3 -C ********** ELIMINATION WITH INTERCHANGES AND -C INITIALIZATION OF VECTOR ********** - 240 V = 0.0D+00 -C - DO 300 I = P, Q - RV6(I) = UK - IF (I .EQ. P) GO TO 280 - IF (ABS(E(I)) .LT. ABS(U)) GO TO 260 -C ********** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF -C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ********** - XU = U / E(I) - RV4(I) = XU - RV1(I-1) = E(I) - RV2(I-1) = D(I) - X1 - RV3(I-1) = 0.0D+00 - IF (I .NE. Q) RV3(I-1) = E(I+1) - U = V - XU * RV2(I-1) - V = -XU * RV3(I-1) - GO TO 300 - 260 XU = E(I) / U - RV4(I) = XU - RV1(I-1) = U - RV2(I-1) = V - RV3(I-1) = 0.0D+00 - 280 U = D(I) - X1 - XU * V - IF (I .NE. Q) V = E(I+1) - 300 CONTINUE -C - IF (U .EQ. 0.0D+00) U = EPS3 - RV1(Q) = U - RV2(Q) = 0.0D+00 - RV3(Q) = 0.0D+00 -C ********** BACK SUBSTITUTION -C FOR I=Q STEP -1 UNTIL P DO -- ********** - 320 DO 340 II = P, Q - I = P + Q - II - RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) - V = U - U = RV6(I) - 340 CONTINUE -C ********** ORTHOGONALIZE WITH RESPECT TO PREVIOUS -C MEMBERS OF GROUP ********** - IF (GROUP .EQ. 0) GO TO 400 - J = R -C - DO 380 JJ = 1, GROUP - 360 J = J - 1 - IF (IND(J) .NE. TAG) GO TO 360 - XU = DDOT(IQMP,RV6(P),1,Z(P,J),1) -C - CALL DAXPY(IQMP,-XU,Z(P,J),1,RV6(P),1) -C - 380 CONTINUE -C - 400 NORM = 0.0D+00 -C - DO 420 I = P, Q - 420 NORM = NORM + ABS(RV6(I)) -C - IF (NORM .GE. 1.0D+00) GO TO 560 -C ********** FORWARD SUBSTITUTION ********** - IF (ITS .EQ. 5) GO TO 540 - IF (NORM .NE. 0.0D+00) GO TO 440 - RV6(S) = EPS4 - S = S + 1 - IF (S .GT. Q) S = P - GO TO 480 - 440 XU = EPS4 / NORM -C - DO 460 I = P, Q - 460 RV6(I) = RV6(I) * XU -C ********** ELIMINATION OPERATIONS ON NEXT VECTOR -C ITERATE ********** - 480 DO 520 I = IP, Q - U = RV6(I) -C ********** IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE -C WAS PERFORMED EARLIER IN THE -C TRIANGULARIZATION PROCESS ********** - IF (RV1(I-1) .NE. E(I)) GO TO 500 - U = RV6(I-1) - RV6(I-1) = RV6(I) - 500 RV6(I) = U - RV4(I) * RV6(I-1) - 520 CONTINUE -C - ITS = ITS + 1 - GO TO 320 -C ********** SET ERROR -- NON-CONVERGED EIGENVECTOR ********** - 540 IERR = -R - XU = 0.0D+00 - GO TO 600 -C ********** NORMALIZE SO THAT SUM OF SQUARES IS -C 1 AND EXPAND TO FULL ORDER ********** - 560 U = 0.0D+00 -C - DO 580 I = P, Q - RV6(I) = RV6(I) / NORM - 580 U = U + RV6(I)**2 -C - XU = 1.0D+00 / SQRT(U) -C - 600 DO 620 I = 1, N - 620 Z(I,R) = 0.0D+00 -C - DO 640 I = P, Q - 640 Z(I,R) = RV6(I) * XU -C - X0 = X1 - 660 CONTINUE -C - IF (Q .LT. N) GO TO 100 - 680 RETURN -C ********** LAST CARD OF TINVIT ********** - END -C*MODULE EIGEN *DECK TQL2 -C -C ------------------------------------------------------------------ -C - SUBROUTINE TQL2(NM,N,D,E,Z,IERR) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DOUBLE PRECISION MACHEP - DIMENSION D(N),E(N),Z(NM,N) -C -C THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, -C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND -C WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). -C -C THIS ROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS -C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. -C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO -C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS -C FULL MATRIX TO TRIDIAGONAL FORM. -C -C ON INPUT- -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -C DIMENSION STATEMENT, -C -C N IS THE ORDER OF THE MATRIX, -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, -C -C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, -C -C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE -C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS -C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN -C THE IDENTITY MATRIX. -C -C ON OUTPUT- -C -C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN -C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT -C UNORDERED FOR INDICES 1,2,...,IERR-1, -C -C E HAS BEEN DESTROYED, -C -C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC -C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, -C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED -C EIGENVALUES, -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C J IF THE J-TH EIGENVALUE HAS NOT BEEN -C DETERMINED AFTER 30 ITERATIONS. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C -C ------------------------------------------------------------------ -C -C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING -C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. -C -C ********** - MACHEP = 2.0D+00**(-50) -C - IERR = 0 - IF (N .EQ. 1) GO TO 400 -C - DO 100 I = 2, N - 100 E(I-1) = E(I) -C - F = 0.0D+00 - B = 0.0D+00 - E(N) = 0.0D+00 -C - DO 300 L = 1, N - J = 0 - H = MACHEP * (ABS(D(L)) + ABS(E(L))) - IF (B .LT. H) B = H -C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** - DO 120 M = L, N - IF (ABS(E(M)) .LE. B) GO TO 140 -C ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT -C THROUGH THE BOTTOM OF THE LOOP ********** - 120 CONTINUE -C - 140 IF (M .EQ. L) GO TO 280 - 160 IF (J .EQ. 30) GO TO 380 - J = J + 1 -C ********** FORM SHIFT ********** - L1 = L + 1 - G = D(L) - P = (D(L1) - G) / (2.0D+00 * E(L)) - R = SQRT(P*P+1.0D+00) - D(L) = E(L) / (P + SIGN(R,P)) - H = G - D(L) -C - DO 180 I = L1, N - 180 D(I) = D(I) - H -C - F = F + H -C ********** QL TRANSFORMATION ********** - P = D(M) - C = 1.0D+00 - S = 0.0D+00 - MML = M - L -C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** - DO 260 II = 1, MML - I = M - II - G = C * E(I) - H = C * P - IF (ABS(P) .LT. ABS(E(I))) GO TO 200 - C = E(I) / P - R = SQRT(C*C+1.0D+00) - E(I+1) = S * P * R - S = C / R - C = 1.0D+00 / R - GO TO 220 - 200 C = P / E(I) - R = SQRT(C*C+1.0D+00) - E(I+1) = S * E(I) * R - S = 1.0D+00 / R - C = C * S - 220 P = C * D(I) - S * G - D(I+1) = H + S * (C * G + S * D(I)) -C ********** FORM VECTOR ********** - CALL DROT(N,Z(1,I+1),1,Z(1,I),1,C,S) -C - 260 CONTINUE -C - E(L) = S * P - D(L) = C * P - IF (ABS(E(L)) .GT. B) GO TO 160 - 280 D(L) = D(L) + F - 300 CONTINUE -C ********** ORDER EIGENVALUES AND EIGENVECTORS ********** - DO 360 II = 2, N - I = II - 1 - K = I - P = D(I) -C - DO 320 J = II, N - IF (D(J) .GE. P) GO TO 320 - K = J - P = D(J) - 320 CONTINUE -C - IF (K .EQ. I) GO TO 360 - D(K) = D(I) - D(I) = P -C - CALL DSWAP(N,Z(1,I),1,Z(1,K),1) -C - 360 CONTINUE -C - GO TO 400 -C ********** SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS ********** - 380 IERR = L - 400 RETURN -C ********** LAST CARD OF TQL2 ********** - END -C*MODULE EIGEN *DECK TRBK3B -C -C ------------------------------------------------------------------ -C - SUBROUTINE TRBK3B(NM,N,NV,A,M,Z) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION A(NV),Z(NM,M) -C -C THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, -C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C THIS ROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC -C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING -C SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED3B. -C -C ON INPUT- -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -C DIMENSION STATEMENT, -C -C N IS THE ORDER OF THE MATRIX, -C -C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A -C AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT, -C -C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS -C USED IN THE REDUCTION BY TRED3B IN ITS FIRST -C N*(N+1)/2 POSITIONS, -C -C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED, -C -C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED -C IN ITS FIRST M COLUMNS. -C -C ON OUTPUT- -C -C Z CONTAINS THE TRANSFORMED EIGENVECTORS -C IN ITS FIRST M COLUMNS. -C -C NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C -C ------------------------------------------------------------------ -C - IF (M .EQ. 0) GO TO 140 - IF (N .EQ. 1) GO TO 140 -C - DO 120 I = 2, N - L = I - 1 - IZ = (I * L) / 2 - IK = IZ + I - H = A(IK) - IF (H .EQ. 0.0D+00) GO TO 120 -C - DO 100 J = 1, M - S = -DDOT(L,A(IZ+1),1,Z(1,J),1) -C -C ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** - S = (S / H) / H -C - CALL DAXPY(L,S,A(IZ+1),1,Z(1,J),1) -C - 100 CONTINUE -C - 120 CONTINUE -C - 140 RETURN -C ********** LAST CARD OF TRBAK3 ********** - END -C*MODULE EIGEN *DECK TRED3B -C -C ------------------------------------------------------------------ -C - SUBROUTINE TRED3B(N,NV,A,D,E,E2) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION A(NV),D(N),E(N),E2(N) -C -C THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, -C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C THIS ROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS -C A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX -C USING ORTHOGONAL SIMILARITY TRANSFORMATIONS. -C -C ON INPUT- -C -C N IS THE ORDER OF THE MATRIX, -C -C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A -C AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT, -C -C A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC -C INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL -C ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. -C -C ON OUTPUT- -C -C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL -C TRANSFORMATIONS USED IN THE REDUCTION, -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX, -C -C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL -C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO, -C -C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. -C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C -C ------------------------------------------------------------------ -C -C ********** FOR I=N STEP -1 UNTIL 1 DO -- ********** - DO 300 II = 1, N - I = N + 1 - II - L = I - 1 - IZ = (I * L) / 2 - H = 0.0D+00 - SCALE = 0.0D+00 - IF (L .LT. 1) GO TO 120 -C ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) ********** - DO 100 K = 1, L - IZ = IZ + 1 - D(K) = A(IZ) - SCALE = SCALE + ABS(D(K)) - 100 CONTINUE -C - IF (SCALE .NE. 0.0D+00) GO TO 140 - 120 E(I) = 0.0D+00 - E2(I) = 0.0D+00 - GO TO 280 -C - 140 DO 160 K = 1, L - D(K) = D(K) / SCALE - H = H + D(K) * D(K) - 160 CONTINUE -C - E2(I) = SCALE * SCALE * H - F = D(L) - G = -SIGN(SQRT(H),F) - E(I) = SCALE * G - H = H - F * G - D(L) = F - G - A(IZ) = SCALE * D(L) - IF (L .EQ. 1) GO TO 280 - F = 0.0D+00 -C - JK = 1 - DO 220 J = 1, L - JM1 = J - 1 - DT = D(J) - G = 0.0D+00 -C ********** FORM ELEMENT OF A*U ********** - IF (JM1 .EQ. 0) GO TO 200 - DO 180 K = 1, JM1 - E(K) = E(K) + DT * A(JK) - G = G + D(K) * A(JK) - JK = JK + 1 - 180 CONTINUE - 200 E(J) = G + A(JK) * DT - JK = JK + 1 -C ********** FORM ELEMENT OF P ********** - 220 CONTINUE - F = 0.0D+00 - DO 240 J = 1, L - E(J) = E(J) / H - F = F + E(J) * D(J) - 240 CONTINUE -C - HH = F / (H + H) - JK = 0 -C ********** FORM REDUCED A ********** - DO 260 J = 1, L - F = D(J) - G = E(J) - HH * F - E(J) = G -C - DO 260 K = 1, J - JK = JK + 1 - A(JK) = A(JK) - F * E(K) - G * D(K) - 260 CONTINUE -C - 280 D(I) = A(IZ+1) - A(IZ+1) = SCALE * SQRT(H) - 300 CONTINUE -C - RETURN -C ********** LAST CARD OF TRED3 ********** - END diff --git a/source/unres/src_MD-M-newcorr/elecont.f b/source/unres/src_MD-M-newcorr/elecont.f deleted file mode 100644 index a962630..0000000 --- a/source/unres/src_MD-M-newcorr/elecont.f +++ /dev/null @@ -1,511 +0,0 @@ - subroutine elecont(lprint,ncont,icont) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.FFIELD' - include 'COMMON.NAMES' - logical lprint - double precision elpp_6(2,2),elpp_3(2,2),ael6_(2,2),ael3_(2,2) - double precision app_(2,2),bpp_(2,2),rpp_(2,2) - integer ncont,icont(2,maxcont) - double precision econt(maxcont) -* -* Load the constants of peptide bond - peptide bond interactions. -* Type 1 - ordinary peptide bond, type 2 - alkylated peptide bond (e.g. -* proline) - determined by averaging ECEPP energy. -* -* as of 7/06/91. -* -c data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ - data rpp_ / 4.5088d0, 4.5395d0, 4.5395d0, 4.4846d0/ - data elpp_6 /-0.2379d0,-0.2056d0,-0.2056d0,-0.0610d0/ - data elpp_3 / 0.0503d0, 0.0000d0, 0.0000d0, 0.0692d0/ - data elcutoff /-0.3d0/,elecutoff_14 /-0.5d0/ - if (lprint) write (iout,'(a)') - & "Constants of electrostatic interaction energy expression." - do i=1,2 - do j=1,2 - rri=rpp_(i,j)**6 - app_(i,j)=epp(i,j)*rri*rri - bpp_(i,j)=-2.0*epp(i,j)*rri - ael6_(i,j)=elpp_6(i,j)*4.2**6 - ael3_(i,j)=elpp_3(i,j)*4.2**3 - if (lprint) - & write (iout,'(2i2,4e15.4)') i,j,app_(i,j),bpp_(i,j),ael6_(i,j), - & ael3_(i,j) - enddo - enddo - ncont=0 - ees=0.0 - evdw=0.0 - do 1 i=nnt,nct-2 - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) goto 1 - xi=c(1,i) - yi=c(2,i) - zi=c(3,i) - dxi=c(1,i+1)-c(1,i) - dyi=c(2,i+1)-c(2,i) - dzi=c(3,i+1)-c(3,i) - xmedi=xi+0.5*dxi - ymedi=yi+0.5*dyi - zmedi=zi+0.5*dzi - do 4 j=i+2,nct-1 - if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) goto 4 - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - if (iteli.eq.2 .and. itelj.eq.2) goto 4 - aaa=app_(iteli,itelj) - bbb=bpp_(iteli,itelj) - ael6_i=ael6_(iteli,itelj) - ael3_i=ael3_(iteli,itelj) - dxj=c(1,j+1)-c(1,j) - dyj=c(2,j+1)-c(2,j) - dzj=c(3,j+1)-c(3,j) - xj=c(1,j)+0.5*dxj-xmedi - yj=c(2,j)+0.5*dyj-ymedi - zj=c(3,j)+0.5*dzj-zmedi - rrmij=1.0/(xj*xj+yj*yj+zj*zj) - rmij=sqrt(rrmij) - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - vrmij=vblinv*rmij - cosa=(dxi*dxj+dyi*dyj+dzi*dzj)*vblinv2 - cosb=(xj*dxi+yj*dyi+zj*dzi)*vrmij - cosg=(xj*dxj+yj*dyj+zj*dzj)*vrmij - fac=cosa-3.0*cosb*cosg - ev1=aaa*r6ij*r6ij - ev2=bbb*r6ij - fac3=ael6_i*r6ij - fac4=ael3_i*r3ij - evdwij=ev1+ev2 - el1=fac3*(4.0+fac*fac-3.0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - eesij=el1+el2 - if (j.gt.i+2 .and. eesij.le.elcutoff .or. - & j.eq.i+2 .and. eesij.le.elecutoff_14) then - ncont=ncont+1 - icont(1,ncont)=i - icont(2,ncont)=j - econt(ncont)=eesij - endif - ees=ees+eesij - evdw=evdw+evdwij - 4 continue - 1 continue - if (lprint) then - write (iout,*) 'Total average electrostatic energy: ',ees - write (iout,*) 'VDW energy between peptide-group centers: ',evdw - write (iout,*) - write (iout,*) 'Electrostatic contacts before pruning: ' - do i=1,ncont - i1=icont(1,i) - i2=icont(2,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4,f10.5)') - & i,restyp(it1),i1,restyp(it2),i2,econt(i) - enddo - endif -c For given residues keep only the contacts with the greatest energy. - i=0 - do while (i.lt.ncont) - i=i+1 - ene=econt(i) - ic1=icont(1,i) - ic2=icont(2,i) - j=i - do while (j.lt.ncont) - j=j+1 - if (ic1.eq.icont(1,j).and.iabs(icont(2,j)-ic2).le.2 .or. - & ic2.eq.icont(2,j).and.iabs(icont(1,j)-ic1).le.2) then -c write (iout,*) "i",i," j",j," ic1",ic1," ic2",ic2, -c & " jc1",icont(1,j)," jc2",icont(2,j)," ncont",ncont - if (econt(j).lt.ene .and. icont(2,j).ne.icont(1,j)+2) then - if (ic1.eq.icont(1,j)) then - do k=1,ncont - if (k.ne.i .and. k.ne.j .and. icont(2,k).eq.icont(2,j) - & .and. iabs(icont(1,k)-ic1).le.2 .and. - & econt(k).lt.econt(j) ) goto 21 - enddo - else if (ic2.eq.icont(2,j) ) then - do k=1,ncont - if (k.ne.i .and. k.ne.j .and. icont(1,k).eq.icont(1,j) - & .and. iabs(icont(2,k)-ic2).le.2 .and. - & econt(k).lt.econt(j) ) goto 21 - enddo - endif -c Remove ith contact - do k=i+1,ncont - icont(1,k-1)=icont(1,k) - icont(2,k-1)=icont(2,k) - econt(k-1)=econt(k) - enddo - i=i-1 - ncont=ncont-1 -c write (iout,*) "ncont",ncont -c do k=1,ncont -c write (iout,*) icont(1,k),icont(2,k) -c enddo - goto 20 - else if (econt(j).gt.ene .and. ic2.ne.ic1+2) - & then - if (ic1.eq.icont(1,j)) then - do k=1,ncont - if (k.ne.i .and. k.ne.j .and. icont(2,k).eq.ic2 - & .and. iabs(icont(1,k)-icont(1,j)).le.2 .and. - & econt(k).lt.econt(i) ) goto 21 - enddo - else if (ic2.eq.icont(2,j) ) then - do k=1,ncont - if (k.ne.i .and. k.ne.j .and. icont(1,k).eq.ic1 - & .and. iabs(icont(2,k)-icont(2,j)).le.2 .and. - & econt(k).lt.econt(i) ) goto 21 - enddo - endif -c Remove jth contact - do k=j+1,ncont - icont(1,k-1)=icont(1,k) - icont(2,k-1)=icont(2,k) - econt(k-1)=econt(k) - enddo - ncont=ncont-1 -c write (iout,*) "ncont",ncont -c do k=1,ncont -c write (iout,*) icont(1,k),icont(2,k) -c enddo - j=j-1 - endif - endif - 21 continue - enddo - 20 continue - enddo - if (lprint) then - write (iout,*) - write (iout,*) 'Electrostatic contacts after pruning: ' - do i=1,ncont - i1=icont(1,i) - i2=icont(2,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4,f10.5)') - & i,restyp(it1),i1,restyp(it2),i2,econt(i) - enddo - endif - return - end -c-------------------------------------------- - subroutine secondary2(lprint) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.CONTROL' - integer ncont,icont(2,maxcont),isec(maxres,4),nsec(maxres) - logical lprint,not_done,freeres - double precision p1,p2 - external freeres - - if(.not.dccart) call chainbuild -cd call write_pdb(99,'sec structure',0d0) - ncont=0 - nbfrag=0 - nhfrag=0 - do i=1,nres - isec(i,1)=0 - isec(i,2)=0 - nsec(i)=0 - enddo - - call elecont(lprint,ncont,icont) - -c finding parallel beta -cd write (iout,*) '------- looking for parallel beta -----------' - nbeta=0 - nstrand=0 - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if(j1-i1.gt.5 .and. freeres(i1,j1,nsec,isec)) then - ii1=i1 - jj1=j1 -cd write (iout,*) i1,j1 - not_done=.true. - do while (not_done) - i1=i1+1 - j1=j1+1 - do j=1,ncont - if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j) .and. - & freeres(i1,j1,nsec,isec)) goto 5 - enddo - not_done=.false. - 5 continue -cd write (iout,*) i1,j1,not_done - enddo - j1=j1-1 - i1=i1-1 - if (i1-ii1.gt.1) then - ii1=max0(ii1-1,1) - jj1=max0(jj1-1,1) - nbeta=nbeta+1 - if(lprint)write(iout,'(a,i3,4i4)')'parallel beta', - & nbeta,ii1,i1,jj1,j1 - - nbfrag=nbfrag+1 - bfrag(1,nbfrag)=ii1+1 - bfrag(2,nbfrag)=i1+1 - bfrag(3,nbfrag)=jj1+1 - bfrag(4,nbfrag)=min0(j1+1,nres) - - do ij=ii1,i1 - nsec(ij)=nsec(ij)+1 - isec(ij,nsec(ij))=nbeta - enddo - do ij=jj1,j1 - nsec(ij)=nsec(ij)+1 - isec(ij,nsec(ij))=nbeta - enddo - - if(lprint) then - nstrand=nstrand+1 - if (nbeta.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-1,"..",i1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-1,"..",i1-1,"'" - endif - nstrand=nstrand+1 - if (nbeta.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",jj1-1,"..",j1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",jj1-1,"..",j1-1,"'" - endif - write(12,'(a8,4i4)') - & "SetNeigh",ii1-1,i1-1,jj1-1,j1-1 - endif - endif - endif - enddo - -c finding alpha or 310 helix - - nhelix=0 - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - p1=phi(i1+2)*rad2deg - p2=0.0 - if (j1+2.le.nres) p2=phi(j1+2)*rad2deg - - - if (j1.eq.i1+3 .and. - & ((p1.ge.10.and.p1.le.80).or.i1.le.2).and. - & ((p2.ge.10.and.p2.le.80).or.j1.le.2.or.j1.ge.nres-3) )then -cd if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,p1,p2 -co if (j1.eq.i1+4) write (iout,*) "found 1-5 ",i1,j1,p1,p2 - ii1=i1 - jj1=j1 - if (nsec(ii1).eq.0) then - not_done=.true. - else - not_done=.false. - endif - do while (not_done) - i1=i1+1 - j1=j1+1 - do j=1,ncont - if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10 - enddo - not_done=.false. - 10 continue - p1=phi(i1+2)*rad2deg - p2=phi(j1+2)*rad2deg - if (p1.lt.10.or.p1.gt.80.or.p2.lt.10.or.p2.gt.80) - & not_done=.false. -cd write (iout,*) i1,j1,not_done,p1,p2 - enddo - j1=j1+1 - if (j1-ii1.gt.5) then - nhelix=nhelix+1 -cd write (iout,*)'helix',nhelix,ii1,j1 - - nhfrag=nhfrag+1 - hfrag(1,nhfrag)=ii1 - hfrag(2,nhfrag)=j1 - - do ij=ii1,j1 - nsec(ij)=-1 - enddo - if (lprint) then - write (iout,'(a,i3,2i4)') "Helix",nhelix,ii1-1,j1-1 - if (nhelix.le.9) then - write(12,'(a17,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'helix",nhelix, - & "' 'num = ",ii1-1,"..",j1-2,"'" - else - write(12,'(a17,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'helix",nhelix, - & "' 'num = ",ii1-1,"..",j1-2,"'" - endif - endif - endif - endif - enddo - - if (nhelix.gt.0.and.lprint) then - write(12,'(a26,$)') "DefPropRes 'helix' 'helix1" - do i=2,nhelix - if (nhelix.le.9) then - write(12,'(a8,i1,$)') " | helix",i - else - write(12,'(a8,i2,$)') " | helix",i - endif - enddo - write(12,'(a1)') "'" - endif - - -c finding antiparallel beta -cd write (iout,*) '--------- looking for antiparallel beta ---------' - - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if (freeres(i1,j1,nsec,isec)) then - ii1=i1 - jj1=j1 -cd write (iout,*) i1,j1 - - not_done=.true. - do while (not_done) - i1=i1+1 - j1=j1-1 - do j=1,ncont - if (i1.eq.icont(1,j).and.j1.eq.icont(2,j) .and. - & freeres(i1,j1,nsec,isec)) goto 6 - enddo - not_done=.false. - 6 continue -cd write (iout,*) i1,j1,not_done - enddo - i1=i1-1 - j1=j1+1 - if (i1-ii1.gt.1) then - - nbfrag=nbfrag+1 - bfrag(1,nbfrag)=ii1 - bfrag(2,nbfrag)=min0(i1+1,nres) - bfrag(3,nbfrag)=min0(jj1+1,nres) - bfrag(4,nbfrag)=j1 - - nbeta=nbeta+1 - iii1=max0(ii1-1,1) - do ij=iii1,i1 - nsec(ij)=nsec(ij)+1 - if (nsec(ij).le.2) then - isec(ij,nsec(ij))=nbeta - endif - enddo - jjj1=max0(j1-1,1) - do ij=jjj1,jj1 - nsec(ij)=nsec(ij)+1 - if (nsec(ij).le.2 .and. nsec(ij).gt.0) then - isec(ij,nsec(ij))=nbeta - endif - enddo - - - if (lprint) then - write (iout,'(a,i3,4i4)')'antiparallel beta', - & nbeta,ii1-1,i1,jj1,j1-1 - nstrand=nstrand+1 - if (nstrand.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-2,"..",i1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-2,"..",i1-1,"'" - endif - nstrand=nstrand+1 - if (nstrand.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",j1-2,"..",jj1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",j1-2,"..",jj1-1,"'" - endif - write(12,'(a8,4i4)') - & "SetNeigh",ii1-2,i1-1,jj1-1,j1-2 - endif - endif - endif - enddo - - if (nstrand.gt.0.and.lprint) then - write(12,'(a27,$)') "DefPropRes 'sheet' 'strand1" - do i=2,nstrand - if (i.le.9) then - write(12,'(a9,i1,$)') " | strand",i - else - write(12,'(a9,i2,$)') " | strand",i - endif - enddo - write(12,'(a1)') "'" - endif - - - - if (lprint) then - write(12,'(a37)') "DefPropRes 'coil' '! (helix | sheet)'" - write(12,'(a20)') "XMacStand ribbon.mac" - - - write(iout,*) 'UNRES seq:' - do j=1,nbfrag - write(iout,*) 'beta ',(bfrag(i,j),i=1,4) - enddo - - do j=1,nhfrag - write(iout,*) 'helix ',(hfrag(i,j),i=1,2) - enddo - endif - - return - end -c------------------------------------------------- - logical function freeres(i,j,nsec,isec) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - integer isec(maxres,4),nsec(maxres) - freeres=.false. - - if (nsec(i).lt.0.or.nsec(j).lt.0) return - if (nsec(i).gt.1.or.nsec(j).gt.1) return - do k=1,nsec(i) - do l=1,nsec(j) - if (isec(i,k).eq.isec(j,l)) return - enddo - enddo - freeres=.true. - return - end - diff --git a/source/unres/src_MD-M-newcorr/energy_p_new-sep.F b/source/unres/src_MD-M-newcorr/energy_p_new-sep.F deleted file mode 100644 index 0b8f27b..0000000 --- a/source/unres/src_MD-M-newcorr/energy_p_new-sep.F +++ /dev/null @@ -1,2505 +0,0 @@ -C----------------------------------------------------------------------- - double precision function sscale(r) - double precision r,gamm - include "COMMON.SPLITELE" - if(r.lt.r_cut-rlamb) then - sscale=1.0d0 - else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then - gamm=(r-(r_cut-rlamb))/rlamb - sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) - else - sscale=0d0 - endif - return - end -C----------------------------------------------------------------------- - subroutine elj_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJ potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) -cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -cd & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rij=xj*xj+yj*yj+zj*zj - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) - if (sss.lt.1.0d0) then - rrij=1.0D0/rij - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 - evdw=evdw+(1.0d0-sss)*evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij)*(1.0d0-sss) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - enddo - do k=i,j-1 - do l=1,3 - gvdwc(l,k)=gvdwc(l,k)+gg(l) - enddo - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time, the factor of EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C----------------------------------------------------------------------- - subroutine elj_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJ potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) -cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -cd & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rij=xj*xj+yj*yj+zj*zj - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) - if (sss.gt.0.0d0) then - rrij=1.0D0/rij - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 - evdw=evdw+sss*evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij)*sss - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - enddo - do k=i,j-1 - do l=1,3 - gvdwc(l,k)=gvdwc(l,k)+gg(l) - enddo - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time, the factor of EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C----------------------------------------------------------------------------- - subroutine eljk_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJK potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - dimension gg(3) - logical scheck -c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - r_inv_ij=dsqrt(rrij) - rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) - - if (sss.lt.1.0d0) then - - r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) - fac=r_shift_inv**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e_augm+e1+e2 -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, -cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+evdwij*(1.0d0-sss) -C -C Calculate the components of the gradient in DC and X -C - fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) - fac=fac*(1.0d0-sss) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - enddo - do k=i,j-1 - do l=1,3 - gvdwc(l,k)=gvdwc(l,k)+gg(l) - enddo - enddo - - endif - - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo - return - end -C----------------------------------------------------------------------------- - subroutine eljk_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJK potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - dimension gg(3) - logical scheck -c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - r_inv_ij=dsqrt(rrij) - rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) - - if (sss.gt.0.0d0) then - - r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) - fac=r_shift_inv**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e_augm+e1+e2 -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, -cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+evdwij*sss -C -C Calculate the components of the gradient in DC and X -C - fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) - fac=fac*sss - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - enddo - do k=i,j-1 - do l=1,3 - gvdwc(l,k)=gvdwc(l,k)+gg(l) - enddo - enddo - - endif - - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo - return - end -C----------------------------------------------------------------------------- - subroutine ebp_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Berne-Pechukas potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - common /srutu/ icall -c double precision rrsave(maxdim) - logical lprn - evdw=0.0D0 -c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 -c if (icall.eq.0) then -c lprn=.true. -c else - lprn=.false. -c endif - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) -C For diagnostics only!!! -c chi1=0.0D0 -c chi2=0.0D0 -c chi12=0.0D0 -c chip1=0.0D0 -c chip2=0.0D0 -c chip12=0.0D0 -c alf1=0.0D0 -c alf2=0.0D0 -c alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) -cd if (icall.eq.0) then -cd rrsave(ind)=rrij -cd else -cd rrij=rrsave(ind) -cd endif - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -C Calculate the angle-dependent terms of energy & contributions to derivatives. - call sc_angular -C Calculate whole angle-dependent part of epsilon and contributions -C to its derivatives - fac=(rrij*sigsq)**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),15(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & epsi,sigm,chi1,chi2,chip1,chip2, -cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), -cd & om1,om2,om12,1.0D0/dsqrt(rrij), -cd & evdwij - endif -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij) - sigder=fac/sigsq - fac=rrij*fac -C Calculate radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate the angular part of the gradient and sum add the contributions -C to the appropriate components of the Cartesian gradient. - call sc_grad_scale(1.0d0-sss) - - endif - - enddo ! j - enddo ! iint - enddo ! i -c stop - return - end -C----------------------------------------------------------------------------- - subroutine ebp_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Berne-Pechukas potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - common /srutu/ icall -c double precision rrsave(maxdim) - logical lprn - evdw=0.0D0 -c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 -c if (icall.eq.0) then -c lprn=.true. -c else - lprn=.false. -c endif - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) -C For diagnostics only!!! -c chi1=0.0D0 -c chi2=0.0D0 -c chi12=0.0D0 -c chip1=0.0D0 -c chip2=0.0D0 -c chip12=0.0D0 -c alf1=0.0D0 -c alf2=0.0D0 -c alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) -cd if (icall.eq.0) then -cd rrsave(ind)=rrij -cd else -cd rrij=rrsave(ind) -cd endif - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -C Calculate the angle-dependent terms of energy & contributions to derivatives. - call sc_angular -C Calculate whole angle-dependent part of epsilon and contributions -C to its derivatives - fac=(rrij*sigsq)**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*sss - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),15(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & epsi,sigm,chi1,chi2,chip1,chip2, -cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), -cd & om1,om2,om12,1.0D0/dsqrt(rrij), -cd & evdwij - endif -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij) - sigder=fac/sigsq - fac=rrij*fac -C Calculate radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate the angular part of the gradient and sum add the contributions -C to the appropriate components of the Cartesian gradient. - call sc_grad_scale(sss) - - endif - - enddo ! j - enddo ! iint - enddo ! i -c stop - return - end -C----------------------------------------------------------------------------- - subroutine egb_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - include 'COMMON.CONTROL' - logical lprn - evdw=0.0D0 -ccccc energy_dec=.false. -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.false. - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) -c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) -c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, -c & 1.0d0/vbld(j+nres) -c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) -C For diagnostics only!!! -c chi1=0.0D0 -c chi2=0.0D0 -c chi12=0.0D0 -c chip1=0.0D0 -c chip2=0.0D0 -c chip12=0.0D0 -c alf1=0.0D0 -c alf2=0.0D0 -c alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) -c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi -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*sigmaii(itypi,itypj))) -c write(iout,*) "long",i,itypi,j,itypj," rij",1.0d0/rij, -c & " sigmaii",sigmaii(itypi,itypj)," sss",sss - - if (sss.lt.1.0d0) then - -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij -c for diagnostics; uncomment -c rij_shift=1.2*sig0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 -cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt -c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, -c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*(1.0d0-sss) -c write (iout,*) "evdwij",evdwij," evdw",evdw - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij - -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -c fac=0.0d0 -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad_scale(1.0d0-sss) - - endif - - enddo ! j - enddo ! iint - enddo ! i -cccc energy_dec=.false. - return - end -C----------------------------------------------------------------------------- - subroutine egb_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - include 'COMMON.CONTROL' - logical lprn - evdw=0.0D0 -ccccc energy_dec=.false. -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.false. - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) -c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) -c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, -c & 1.0d0/vbld(j+nres) -c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) -C For diagnostics only!!! -c chi1=0.0D0 -c chi2=0.0D0 -c chi12=0.0D0 -c chip1=0.0D0 -c chip2=0.0D0 -c chip12=0.0D0 -c alf1=0.0D0 -c alf2=0.0D0 -c alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) -c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi -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*sigmaii(itypi,itypj))) -c write(iout,*) "short",i,itypi,j,itypj," rij",1.0d0/rij, -c & " sigmaii",sigmaii(itypi,itypj)," sss",sss - if (sss.gt.0.0d0) then - -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij -c for diagnostics; uncomment -c rij_shift=1.2*sig0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 -cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt -c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, -c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*sss -c write (iout,*) "evdwij",evdwij," evdw",evdw - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij - -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -c fac=0.0d0 -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad_scale(sss) - - endif - - enddo ! j - enddo ! iint - enddo ! i -cccc energy_dec=.false. - return - end -C----------------------------------------------------------------------------- - subroutine egbv_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne-Vorobjev potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - common /srutu/ icall - logical lprn - evdw=0.0D0 -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.true. - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - sig0ij=sigma(itypi,itypj) - r0ij=r0(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) -C For diagnostics only!!! -c chi1=0.0D0 -c chi2=0.0D0 -c chi12=0.0D0 -c chip1=0.0D0 -c chip2=0.0D0 -c chip12=0.0D0 -c alf1=0.0D0 -c alf2=0.0D0 -c alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+r0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+(evdwij+e_augm)*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0), - & chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij+e_augm - endif -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac-2*expon*rrij*e_augm -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad_scale(1.0d0-sss) - - endif - - enddo ! j - enddo ! iint - enddo ! i - end -C----------------------------------------------------------------------------- - subroutine egbv_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne-Vorobjev potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - common /srutu/ icall - logical lprn - evdw=0.0D0 -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.true. - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - sig0ij=sigma(itypi,itypj) - r0ij=r0(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) -C For diagnostics only!!! -c chi1=0.0D0 -c chi2=0.0D0 -c chi12=0.0D0 -c chip1=0.0D0 -c chip2=0.0D0 -c chip12=0.0D0 -c alf1=0.0D0 -c alf2=0.0D0 -c alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+r0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+(evdwij+e_augm)*sss - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0), - & chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij+e_augm - endif -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac-2*expon*rrij*e_augm -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad_scale(sss) - - endif - - enddo ! j - enddo ! iint - enddo ! i - end -C---------------------------------------------------------------------------- - subroutine sc_grad_scale(scalfac) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.CALC' - include 'COMMON.IOUNITS' - double precision dcosom1(3),dcosom2(3) - double precision scalfac - eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 - eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 - eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 - & -2.0D0*alf12*eps3der+sigder*sigsq_om12 -c diagnostics only -c eom1=0.0d0 -c eom2=0.0d0 -c eom12=evdwij*eps1_om12 -c end diagnostics -c write (iout,*) "eps2der",eps2der," eps3der",eps3der, -c & " sigder",sigder -c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 -c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - do k=1,3 - gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac - enddo -c write (iout,*) "gg",(gg(k),k=1,3) - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - & +((eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv)*scalfac - gvdwx(k,j)=gvdwx(k,j)+gg(k) - & +((eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv)*scalfac -c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) -c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv -c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) -c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - enddo -C -C Calculate the components of the gradient in DC and X -C - do k=i,j-1 - do l=1,3 - gvdwc(l,k)=gvdwc(l,k)+gg(l) - enddo - enddo - return - end -C-------------------------------------------------------------------------- - subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) -C -C This subroutine calculates the average interaction energy and its gradient -C in the virtual-bond vectors between non-adjacent peptide groups, based on -C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. -C The potential depends both on the distance of peptide-group centers and on -C the orientation of the CA-CA virtual bonds. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), - & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) - double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), - & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) - common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2 -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - double precision scal_el /1.0d0/ -#else - double precision scal_el /0.5d0/ -#endif -C 12/13/98 -C 13-go grudnia roku pamietnego... - double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, - & 0.0d0,1.0d0,0.0d0, - & 0.0d0,0.0d0,1.0d0/ -cd write(iout,*) 'In EELEC' -cd do i=1,nloctyp -cd write(iout,*) 'Type',i -cd write(iout,*) 'B1',B1(:,i) -cd write(iout,*) 'B2',B2(:,i) -cd write(iout,*) 'CC',CC(:,:,i) -cd write(iout,*) 'DD',DD(:,:,i) -cd write(iout,*) 'EE',EE(:,:,i) -cd enddo -cd call check_vecgrad -cd stop - if (icheckgrad.eq.1) then - do i=1,nres-1 - fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) - do k=1,3 - dc_norm(k,i)=dc(k,i)*fac - enddo -c write (iout,*) 'i',i,' fac',fac - enddo - endif - if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. - & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then -c call vec_and_deriv - call set_matrices - endif -cd do i=1,nres-1 -cd write (iout,*) 'i=',i -cd do k=1,3 -cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) -cd enddo -cd do k=1,3 -cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') -cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) -cd enddo -cd enddo - num_conti_hb=0 - ees=0.0D0 - evdw1=0.0D0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 - ind=0 - do i=1,nres - num_cont_hb(i)=0 - enddo -cd print '(a)','Enter EELEC' -cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e - do i=1,nres - gel_loc_loc(i)=0.0d0 - gcorr_loc(i)=0.0d0 - enddo -cd do i=1,nres -cd write (iout,'(i3,3f10.5,5x,3f10.5)') -cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) -cd enddo -c -c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms -C -C Loop over i,i+2 and i,i+3 pairs of the peptide groups -C - do i=iturn3_start,iturn3_end - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 - call eelecij_scale(i,i+2,ees,evdw1,eel_loc) - if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) - num_cont_hb(i)=num_conti - enddo - do i=iturn4_start,iturn4_end - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 - call eelecij_scale(i,i+3,ees,evdw1,eel_loc) - if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4) - num_cont_hb(i)=num_cont_hb(i)+num_conti - enddo ! i -c -c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 -c - do i=iatel_s,iatel_e - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 -c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) - do j=ielstart(i),ielend(i) - call eelecij_scale(i,j,ees,evdw1,eel_loc) - enddo ! j - num_cont_hb(i)=num_cont_hb(i)+num_conti - enddo ! i - return - end -C------------------------------------------------------------------------------- - subroutine eelecij_scale(i,j,ees,evdw1,eel_loc) -C -C This subroutine calculates the average interaction energy and its gradient -C in the virtual-bond vectors between non-adjacent peptide groups, based on -C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. -C The potential depends both on the distance of peptide-group centers and on -C the orientation of the CA-CA virtual bonds. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), - & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) - double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), - & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) - common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, - & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, - & num_conti,j1,j2 -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - double precision scal_el /1.0d0/ -#else - double precision scal_el /0.5d0/ -#endif -C 12/13/98 -C 13-go grudnia roku pamietnego... - double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, - & 0.0d0,1.0d0,0.0d0, - & 0.0d0,0.0d0,1.0d0/ - 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) -C Diagnostics only!!! -c aaa=0.0D0 -c bbb=0.0D0 -c ael6i=0.0D0 -c ael3i=0.0D0 -C End diagnostics - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - rmij=1.0D0/rij -c For extracting the short-range part of Evdwpp - sss=sscale(rij/rpp(iteli,itelj)) -c - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj - cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij - cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij - fac=cosa-3.0D0*cosb*cosg - ev1=aaa*r6ij*r6ij -c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - fac3=ael6i*r6ij - fac4=ael3i*r3ij - evdwij=ev1+ev2 - el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - eesij=el1+el2 -C 12/26/95 - for the evaluation of multi-body H-bonding interactions - ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) - ees=ees+eesij - evdw1=evdw1+evdwij*(1.0d0-sss) -cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, -cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, -cd & xmedi,ymedi,zmedi,xj,yj,zj - - if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij - write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij - endif - -C -C Calculate contributions to the Cartesian gradient. -C -#ifdef SPLITELE - facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss) - facel=-3*rrmij*(el1+eesij) - fac1=fac - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=facel*xj - ggg(2)=facel*yj - ggg(3)=facel*zj - do k=1,3 - ghalf=0.5D0*ggg(k) - gelc(k,i)=gelc(k,i)+ghalf - gelc(k,j)=gelc(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* - do k=i+1,j-1 - do l=1,3 - gelc(l,k)=gelc(l,k)+ggg(l) - enddo - enddo - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - do k=1,3 - ghalf=0.5D0*ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)+ghalf - gvdwpp(k,j)=gvdwpp(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* - do k=i+1,j-1 - do l=1,3 - gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) - enddo - enddo -#else - facvdw=(ev1+evdwij)*(1.0d0-sss) - facel=el1+eesij - fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=fac*xj - ggg(2)=fac*yj - ggg(3)=fac*zj - do k=1,3 - ghalf=0.5D0*ggg(k) - gelc(k,i)=gelc(k,i)+ghalf - gelc(k,j)=gelc(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* - do k=i+1,j-1 - do l=1,3 - gelc(l,k)=gelc(l,k)+ggg(l) - enddo - enddo -#endif -* -* Angular part -* - ecosa=2.0D0*fac3*fac1+fac4 - fac4=-3.0D0*fac4 - fac3=-6.0D0*fac3 - ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) - ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo -cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), -cd & (dcosg(k),k=1,3) - do k=1,3 - ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) - enddo - do k=1,3 - ghalf=0.5D0*ggg(k) - gelc(k,i)=gelc(k,i)+ghalf - & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gelc(k,j)=gelc(k,j)+ghalf - & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - enddo - do k=i+1,j-1 - do l=1,3 - gelc(l,k)=gelc(l,k)+ggg(l) - enddo - enddo - - IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 - & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -C -C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction -C energy of a peptide unit is assumed in the form of a second-order -C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. -C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms -C are computed for EVERY pair of non-contiguous peptide groups. -C - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - kkk=0 - do k=1,2 - do l=1,2 - kkk=kkk+1 - muij(kkk)=mu(k,i)*mu(l,j) - enddo - enddo -cd write (iout,*) 'EELEC: i',i,' j',j -cd write (iout,*) 'j',j,' j1',j1,' j2',j2 -cd write(iout,*) 'muij',muij - ury=scalar(uy(1,i),erij) - urz=scalar(uz(1,i),erij) - vry=scalar(uy(1,j),erij) - vrz=scalar(uz(1,j),erij) - a22=scalar(uy(1,i),uy(1,j))-3*ury*vry - a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz - a32=scalar(uz(1,i),uy(1,j))-3*urz*vry - a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz -C For diagnostics only -cd a22=1.0d0 -cd a23=1.0d0 -cd a32=1.0d0 -cd a33=1.0d0 - fac=dsqrt(-ael6i)*r3ij -cd write (2,*) 'fac=',fac -C For diagnostics only -cd fac=1.0d0 - a22=a22*fac - a23=a23*fac - a32=a32*fac - a33=a33*fac -cd write (iout,'(4i5,4f10.5)') -cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 -cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij -cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i), -cd & uy(:,j),uz(:,j) -cd write (iout,'(4f10.5)') -cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)), -cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j)) -cd write (iout,'(4f10.5)') ury,urz,vry,vrz -cd write (iout,'(9f10.5/)') -cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij -C Derivatives of the elements of A in virtual-bond vectors - call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) -cd do k=1,3 -cd do l=1,3 -cd erder(k,l)=0.0d0 -cd enddo -cd enddo - 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 -cd do k=1,3 -cd do l=1,3 -cd uryg(k,l)=0.0d0 -cd urzg(k,l)=0.0d0 -cd vryg(k,l)=0.0d0 -cd vrzg(k,l)=0.0d0 -cd enddo -cd enddo -C Compute radial contributions to the gradient - facr=-3.0d0*rrmij - a22der=a22*facr - a23der=a23*facr - a32der=a32*facr - a33der=a33*facr -cd a22der=0.0d0 -cd a23der=0.0d0 -cd a32der=0.0d0 -cd a33der=0.0d0 - agg(1,1)=a22der*xj - agg(2,1)=a22der*yj - agg(3,1)=a22der*zj - agg(1,2)=a23der*xj - agg(2,2)=a23der*yj - agg(3,2)=a23der*zj - agg(1,3)=a32der*xj - agg(2,3)=a32der*yj - agg(3,3)=a32der*zj - agg(1,4)=a33der*xj - agg(2,4)=a33der*yj - agg(3,4)=a33der*zj -C Add the contributions coming from er - fac3=-3.0d0*fac - do k=1,3 - agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) - agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) - agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) - agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) - enddo - do k=1,3 -C Derivatives in DC(i) - ghalf1=0.5d0*agg(k,1) - ghalf2=0.5d0*agg(k,2) - ghalf3=0.5d0*agg(k,3) - ghalf4=0.5d0*agg(k,4) - aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) - & -3.0d0*uryg(k,2)*vry)+ghalf1 - aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) - & -3.0d0*uryg(k,2)*vrz)+ghalf2 - aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) - & -3.0d0*urzg(k,2)*vry)+ghalf3 - aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) - & -3.0d0*urzg(k,2)*vrz)+ghalf4 -C Derivatives in DC(i+1) - aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) - & -3.0d0*uryg(k,3)*vry)+agg(k,1) - aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) - & -3.0d0*uryg(k,3)*vrz)+agg(k,2) - aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) - & -3.0d0*urzg(k,3)*vry)+agg(k,3) - aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) - & -3.0d0*urzg(k,3)*vrz)+agg(k,4) -C Derivatives in DC(j) - aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) - & -3.0d0*vryg(k,2)*ury)+ghalf1 - aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) - & -3.0d0*vrzg(k,2)*ury)+ghalf2 - aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) - & -3.0d0*vryg(k,2)*urz)+ghalf3 - aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) - & -3.0d0*vrzg(k,2)*urz)+ghalf4 -C Derivatives in DC(j+1) or DC(nres-1) - aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) - & -3.0d0*vryg(k,3)*ury) - aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) - & -3.0d0*vrzg(k,3)*ury) - aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) - & -3.0d0*vryg(k,3)*urz) - aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) - & -3.0d0*vrzg(k,3)*urz) -cd aggi(k,1)=ghalf1 -cd aggi(k,2)=ghalf2 -cd aggi(k,3)=ghalf3 -cd aggi(k,4)=ghalf4 -C Derivatives in DC(i+1) -cd aggi1(k,1)=agg(k,1) -cd aggi1(k,2)=agg(k,2) -cd aggi1(k,3)=agg(k,3) -cd aggi1(k,4)=agg(k,4) -C Derivatives in DC(j) -cd aggj(k,1)=ghalf1 -cd aggj(k,2)=ghalf2 -cd aggj(k,3)=ghalf3 -cd aggj(k,4)=ghalf4 -C Derivatives in DC(j+1) -cd aggj1(k,1)=0.0d0 -cd aggj1(k,2)=0.0d0 -cd aggj1(k,3)=0.0d0 -cd aggj1(k,4)=0.0d0 - if (j.eq.nres-1 .and. i.lt.j-2) then - do l=1,4 - aggj1(k,l)=aggj1(k,l)+agg(k,l) -cd aggj1(k,l)=agg(k,l) - enddo - endif - enddo -c goto 11111 -C Check the loc-el terms by numerical integration - acipa(1,1)=a22 - acipa(1,2)=a23 - acipa(2,1)=a32 - acipa(2,2)=a33 - a22=-a22 - a23=-a23 - do l=1,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - if (j.lt.nres-1) then - a22=-a22 - a32=-a32 - do l=1,3,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - else - a22=-a22 - a23=-a23 - a32=-a32 - a33=-a33 - do l=1,4 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - endif - ENDIF ! WCORR -11111 continue - IF (wel_loc.gt.0.0d0) THEN -C Contribution to the local-electrostatic energy coming from the i-j pair - eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) - & +a33*muij(4) -cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'eelloc',i,j,eel_loc_ij - - eel_loc=eel_loc+eel_loc_ij -C Partial derivatives in virtual-bond dihedral angles gamma - if (i.gt.1) - & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ - & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) - & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j) - gel_loc_loc(j-1)=gel_loc_loc(j-1)+ - & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) - & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j) -cd call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij) -cd write(iout,*) 'agg ',agg -cd write(iout,*) 'aggi ',aggi -cd write(iout,*) 'aggi1',aggi1 -cd write(iout,*) 'aggj ',aggj -cd write(iout,*) 'aggj1',aggj1 - -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) - enddo - do k=i+2,j2 - do l=1,3 - gel_loc(l,k)=gel_loc(l,k)+ggg(l) - enddo - enddo -C Remaining derivatives of eello - do l=1,3 - gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ - & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4) - gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ - & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) - gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ - & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) - gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ - & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) - enddo - ENDIF -C Change 12/26/95 to calculate four-body contributions to H-bonding energy - if (j.gt.i+1 .and. num_conti.le.maxconts) then -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 - IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. - & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el -C terms. - d_cont(num_conti,i)=rij -cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij -C --- Electrostatic-interaction matrix --- - a_chuj(1,1,num_conti,i)=a22 - a_chuj(1,2,num_conti,i)=a23 - a_chuj(2,1,num_conti,i)=a32 - a_chuj(2,2,num_conti,i)=a33 -C --- Gradient of rij - do kkk=1,3 - grij_hb_cont(kkk,num_conti,i)=erij(kkk) - enddo -c if (i.eq.1) then -c a_chuj(1,1,num_conti,i)=-0.61d0 -c a_chuj(1,2,num_conti,i)= 0.4d0 -c a_chuj(2,1,num_conti,i)= 0.65d0 -c a_chuj(2,2,num_conti,i)= 0.50d0 -c else if (i.eq.2) then -c a_chuj(1,1,num_conti,i)= 0.0d0 -c a_chuj(1,2,num_conti,i)= 0.0d0 -c a_chuj(2,1,num_conti,i)= 0.0d0 -c a_chuj(2,2,num_conti,i)= 0.0d0 -c endif -C --- and its gradients -cd write (iout,*) 'i',i,' j',j -cd do kkk=1,3 -cd write (iout,*) 'iii 1 kkk',kkk -cd write (iout,*) agg(kkk,:) -cd enddo -cd do kkk=1,3 -cd write (iout,*) 'iii 2 kkk',kkk -cd write (iout,*) aggi(kkk,:) -cd enddo -cd do kkk=1,3 -cd write (iout,*) 'iii 3 kkk',kkk -cd write (iout,*) aggi1(kkk,:) -cd enddo -cd do kkk=1,3 -cd write (iout,*) 'iii 4 kkk',kkk -cd write (iout,*) aggj(kkk,:) -cd enddo -cd do kkk=1,3 -cd write (iout,*) 'iii 5 kkk',kkk -cd write (iout,*) aggj1(kkk,:) -cd 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) -c do mm=1,5 -c a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0 -c enddo - enddo - enddo - enddo - ENDIF - IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN -C Calculate contact energies - cosa4=4.0D0*cosa - wij=cosa-3.0D0*cosb*cosg - cosbg1=cosb+cosg - cosbg2=cosb-cosg -c fac3=dsqrt(-ael6i)/r0ij**3 - fac3=dsqrt(-ael6i)*r3ij -c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) - ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 - if (ees0tmp.gt.0) then - ees0pij=dsqrt(ees0tmp) - else - ees0pij=0 - endif -c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) - ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 - if (ees0tmp.gt.0) then - ees0mij=dsqrt(ees0tmp) - else - ees0mij=0 - endif -c ees0mij=0.0D0 - ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) - ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) -C Diagnostics. Comment out or remove after debugging! -c ees0p(num_conti,i)=0.5D0*fac3*ees0pij -c ees0m(num_conti,i)=0.5D0*fac3*ees0mij -c ees0m(num_conti,i)=0.0D0 -C End diagnostics. -c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, -c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont -C Angular derivatives of the contact function - ees0pij1=fac3/ees0pij - ees0mij1=fac3/ees0mij - fac3p=-3.0D0*fac3*rrmij - ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) - ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) -c ees0mij1=0.0D0 - ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) - ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) - ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) - ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) - ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) - ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) - ecosap=ecosa1+ecosa2 - ecosbp=ecosb1+ecosb2 - ecosgp=ecosg1+ecosg2 - ecosam=ecosa1-ecosa2 - ecosbm=ecosb1-ecosb2 - ecosgm=ecosg1-ecosg2 -C Diagnostics -c ecosap=ecosa1 -c ecosbp=ecosb1 -c ecosgp=ecosg1 -c ecosam=0.0D0 -c ecosbm=0.0D0 -c ecosgm=0.0D0 -C End diagnostics - facont_hb(num_conti,i)=fcont - fprimcont=fprimcont/rij -cd facont_hb(num_conti,i)=1.0D0 -C Following line is for diagnostics. -cd fprimcont=0.0D0 - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo - do k=1,3 - gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) - gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) - enddo - gggp(1)=gggp(1)+ees0pijp*xj - gggp(2)=gggp(2)+ees0pijp*yj - gggp(3)=gggp(3)+ees0pijp*zj - gggm(1)=gggm(1)+ees0mijp*xj - gggm(2)=gggm(2)+ees0mijp*yj - gggm(3)=gggm(3)+ees0mijp*zj -C Derivatives due to the contact function - gacont_hbr(1,num_conti,i)=fprimcont*xj - gacont_hbr(2,num_conti,i)=fprimcont*yj - gacont_hbr(3,num_conti,i)=fprimcont*zj - do k=1,3 - ghalfp=0.5D0*gggp(k) - ghalfm=0.5D0*gggm(k) - gacontp_hb1(k,num_conti,i)=ghalfp - & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontp_hb2(k,num_conti,i)=ghalfp - & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontp_hb3(k,num_conti,i)=gggp(k) - gacontm_hb1(k,num_conti,i)=ghalfm - & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontm_hb2(k,num_conti,i)=ghalfm - & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontm_hb3(k,num_conti,i)=gggm(k) - enddo -C Diagnostics. Comment out or remove after debugging! -cdiag do k=1,3 -cdiag gacontp_hb1(k,num_conti,i)=0.0D0 -cdiag gacontp_hb2(k,num_conti,i)=0.0D0 -cdiag gacontp_hb3(k,num_conti,i)=0.0D0 -cdiag gacontm_hb1(k,num_conti,i)=0.0D0 -cdiag gacontm_hb2(k,num_conti,i)=0.0D0 -cdiag gacontm_hb3(k,num_conti,i)=0.0D0 -cdiag enddo - ENDIF ! wcorr - endif ! num_conti.le.maxconts - endif ! fcont.gt.0 - endif ! j.gt.i+1 - return - end -C----------------------------------------------------------------------- - subroutine evdwpp_long(evdw1) -C -C Compute Evdwpp -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - dimension ggg(3) -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - double precision scal_el /1.0d0/ -#else - double precision scal_el /0.5d0/ -#endif - evdw1=0.0D0 - do i=iatel_s,iatel_e - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 -c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) - do j=ielstart(i),ielend(i) - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - aaa=app(iteli,itelj) - bbb=bpp(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - sss=sscale(rij/rpp(iteli,itelj)) - if (sss.lt.1.0d0) then - rmij=1.0D0/rij - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - ev1=aaa*r6ij*r6ij -c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - evdwij=ev1+ev2 - if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij - write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij - endif - evdw1=evdw1+evdwij*(1.0d0-sss) -C -C Calculate contributions to the Cartesian gradient. -C - facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss) - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - - do k=1,3 - ghalf=0.5D0*ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)+ghalf - gvdwpp(k,j)=gvdwpp(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* - do k=i+1,j-1 - do l=1,3 - gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) - enddo - enddo - endif - enddo ! j - enddo ! i - return - end -C----------------------------------------------------------------------- - subroutine evdwpp_short(evdw1) -C -C Compute Evdwpp -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - dimension ggg(3) -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - double precision scal_el /1.0d0/ -#else - double precision scal_el /0.5d0/ -#endif - evdw1=0.0D0 - do i=iatel_s,iatel_e - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 -c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) - do j=ielstart(i),ielend(i) - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - aaa=app(iteli,itelj) - bbb=bpp(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - sss=sscale(rij/rpp(iteli,itelj)) - if (sss.gt.0.0d0) then - rmij=1.0D0/rij - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - ev1=aaa*r6ij*r6ij -c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - evdwij=ev1+ev2 - if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij - write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij - endif - evdw1=evdw1+evdwij*sss -C -C Calculate contributions to the Cartesian gradient. -C - facvdw=-6*rrmij*(ev1+evdwij)*sss - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - - do k=1,3 - ghalf=0.5D0*ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)+ghalf - gvdwpp(k,j)=gvdwpp(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* - do k=i+1,j-1 - do l=1,3 - gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) - enddo - enddo - endif - enddo ! j - enddo ! i - return - end -C----------------------------------------------------------------------------- - subroutine escp_long(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - - sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - - if (sss.lt.1.0d0) then - - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss) - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij*(1.0d0-sss) - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw2',i,j,evdwij -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij*(1.0d0-sss) - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac - if (j.lt.i) then -cd write (iout,*) 'ji' - 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 - 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 escp_short(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - - sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - - if (sss.gt.0.0d0) then - - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+(e1+e2)*sss - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij*sss - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw2',i,j,evdwij -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij*sss - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac - if (j.lt.i) then -cd write (iout,*) 'ji' - 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 - 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 diff --git a/source/unres/src_MD-M-newcorr/energy_p_new-sep_barrier.F b/source/unres/src_MD-M-newcorr/energy_p_new-sep_barrier.F deleted file mode 100644 index 6592ace..0000000 --- a/source/unres/src_MD-M-newcorr/energy_p_new-sep_barrier.F +++ /dev/null @@ -1,2268 +0,0 @@ -C----------------------------------------------------------------------- - double precision function sscale(r) - double precision r,gamm - include "COMMON.SPLITELE" - if(r.lt.r_cut-rlamb) then - sscale=1.0d0 - else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then - gamm=(r-(r_cut-rlamb))/rlamb - sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) - else - sscale=0d0 - endif - return - end -C----------------------------------------------------------------------- - subroutine elj_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJ potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) -cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -cd & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - if (itypj.eq.ntyp1) cycle - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rij=xj*xj+yj*yj+zj*zj - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) - if (sss.lt.1.0d0) then - rrij=1.0D0/rij - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 - evdw=evdw+(1.0d0-sss)*evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij)*(1.0d0-sss) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time, the factor of EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C----------------------------------------------------------------------- - subroutine elj_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJ potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - 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) - 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)) - if (sss.gt.0.0d0) then - rrij=1.0D0/rij - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 - evdw=evdw+sss*evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij)*sss - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time, the factor of EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C----------------------------------------------------------------------------- - subroutine eljk_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJK potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - dimension gg(3) - logical scheck -c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - if (itypj.eq.ntyp1) cycle - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - r_inv_ij=dsqrt(rrij) - rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) - if (sss.lt.1.0d0) then - r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) - fac=r_shift_inv**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e_augm+e1+e2 -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, -cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+(1.0d0-sss)*evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) - fac=fac*(1.0d0-sss) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo - return - end -C----------------------------------------------------------------------------- - subroutine eljk_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJK potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - dimension gg(3) - logical scheck -c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - if (itypj.eq.ntyp1) cycle - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - r_inv_ij=dsqrt(rrij) - rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) - if (sss.gt.0.0d0) then - r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) - fac=r_shift_inv**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e_augm+e1+e2 -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, -cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+sss*evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) - fac=fac*sss - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo - return - end -C----------------------------------------------------------------------------- - subroutine ebp_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Berne-Pechukas potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - common /srutu/ icall -c double precision rrsave(maxdim) - logical lprn - evdw=0.0D0 -c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 -c if (icall.eq.0) then -c lprn=.true. -c else - lprn=.false. -c endif - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -C Calculate the angle-dependent terms of energy & contributions to derivatives. - call sc_angular -C Calculate whole angle-dependent part of epsilon and contributions -C to its derivatives - fac=(rrij*sigsq)**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),15(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & epsi,sigm,chi1,chi2,chip1,chip2, -cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), -cd & om1,om2,om12,1.0D0/dsqrt(rrij), -cd & evdwij - endif -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij) - sigder=fac/sigsq - fac=rrij*fac -C Calculate radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate the angular part of the gradient and sum add the contributions -C to the appropriate components of the Cartesian gradient. - call sc_grad_scale(1.0d0-sss) - endif - enddo ! j - enddo ! iint - enddo ! i -c stop - return - end -C----------------------------------------------------------------------------- - subroutine ebp_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Berne-Pechukas potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - common /srutu/ icall -c double precision rrsave(maxdim) - logical lprn - evdw=0.0D0 -c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 -c if (icall.eq.0) then -c lprn=.true. -c else - lprn=.false. -c endif - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -C Calculate the angle-dependent terms of energy & contributions to derivatives. - call sc_angular -C Calculate whole angle-dependent part of epsilon and contributions -C to its derivatives - fac=(rrij*sigsq)**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*sss - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),15(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & epsi,sigm,chi1,chi2,chip1,chip2, -cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), -cd & om1,om2,om12,1.0D0/dsqrt(rrij), -cd & evdwij - endif -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij) - sigder=fac/sigsq - fac=rrij*fac -C Calculate radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate the angular part of the gradient and sum add the contributions -C to the appropriate components of the Cartesian gradient. - call sc_grad_scale(sss) - endif - enddo ! j - enddo ! iint - enddo ! i -c stop - return - end -C----------------------------------------------------------------------------- - subroutine egb_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - include 'COMMON.CONTROL' - logical lprn - evdw=0.0D0 -ccccc energy_dec=.false. -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.false. - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) -c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) -c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, -c & 1.0d0/vbld(j+nres) -c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij -c for diagnostics; uncomment -c rij_shift=1.2*sig0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 -cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt -c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, -c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij - -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -c fac=0.0d0 -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad_scale(1.0d0-sss) - endif - enddo ! j - enddo ! iint - enddo ! i -c write (iout,*) "Number of loop steps in EGB:",ind -cccc energy_dec=.false. - return - end -C----------------------------------------------------------------------------- - subroutine egb_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - include 'COMMON.CONTROL' - logical lprn - evdw=0.0D0 -ccccc energy_dec=.false. -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.false. - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) -c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) -c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, -c & 1.0d0/vbld(j+nres) -c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij -c for diagnostics; uncomment -c rij_shift=1.2*sig0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 -cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt -c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, -c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*sss - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij - -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -c fac=0.0d0 -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad_scale(sss) - endif - enddo ! j - enddo ! iint - enddo ! i -c write (iout,*) "Number of loop steps in EGB:",ind -cccc energy_dec=.false. - return - end -C----------------------------------------------------------------------------- - subroutine egbv_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne-Vorobjev potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - common /srutu/ icall - logical lprn - evdw=0.0D0 -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.true. - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - sig0ij=sigma(itypi,itypj) - r0ij=r0(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+r0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+(evdwij+e_augm)*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0), - & chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij+e_augm - endif -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac-2*expon*rrij*e_augm -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad_scale(1.0d0-sss) - endif - enddo ! j - enddo ! iint - enddo ! i - end -C----------------------------------------------------------------------------- - subroutine egbv_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne-Vorobjev potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - common /srutu/ icall - logical lprn - evdw=0.0D0 -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.true. - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - sig0ij=sigma(itypi,itypj) - r0ij=r0(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+r0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+(evdwij+e_augm)*sss - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0), - & chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij+e_augm - endif -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac-2*expon*rrij*e_augm -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad_scale(sss) - endif - enddo ! j - enddo ! iint - enddo ! i - end -C---------------------------------------------------------------------------- - subroutine sc_grad_scale(scalfac) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.CALC' - include 'COMMON.IOUNITS' - double precision dcosom1(3),dcosom2(3) - double precision scalfac - eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 - eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 - eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 - & -2.0D0*alf12*eps3der+sigder*sigsq_om12 -c diagnostics only -c eom1=0.0d0 -c eom2=0.0d0 -c eom12=evdwij*eps1_om12 -c end diagnostics -c write (iout,*) "eps2der",eps2der," eps3der",eps3der, -c & " sigder",sigder -c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 -c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - do k=1,3 - gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac - enddo -c write (iout,*) "gg",(gg(k),k=1,3) - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac - gvdwx(k,j)=gvdwx(k,j)+gg(k) - & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac -c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) -c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv -c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) -c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - enddo -C -C Calculate the components of the gradient in DC and X -C - do l=1,3 - gvdwc(l,i)=gvdwc(l,i)-gg(l) - gvdwc(l,j)=gvdwc(l,j)+gg(l) - enddo - return - end -C-------------------------------------------------------------------------- - subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) -C -C This subroutine calculates the average interaction energy and its gradient -C in the virtual-bond vectors between non-adjacent peptide groups, based on -C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. -C The potential depends both on the distance of peptide-group centers and on -C the orientation of the CA-CA virtual bonds. -C - implicit real*8 (a-h,o-z) -#ifdef MPI - include 'mpif.h' -#endif - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - include 'COMMON.TIME1' - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), - & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) - double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), - & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) - common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, - & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, - & num_conti,j1,j2 -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - double precision scal_el /1.0d0/ -#else - double precision scal_el /0.5d0/ -#endif -C 12/13/98 -C 13-go grudnia roku pamietnego... - double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, - & 0.0d0,1.0d0,0.0d0, - & 0.0d0,0.0d0,1.0d0/ -cd write(iout,*) 'In EELEC' -cd do i=1,nloctyp -cd write(iout,*) 'Type',i -cd write(iout,*) 'B1',B1(:,i) -cd write(iout,*) 'B2',B2(:,i) -cd write(iout,*) 'CC',CC(:,:,i) -cd write(iout,*) 'DD',DD(:,:,i) -cd write(iout,*) 'EE',EE(:,:,i) -cd enddo -cd call check_vecgrad -cd stop - if (icheckgrad.eq.1) then - do i=1,nres-1 - fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) - do k=1,3 - dc_norm(k,i)=dc(k,i)*fac - enddo -c write (iout,*) 'i',i,' fac',fac - enddo - endif - if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. - & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then -c call vec_and_deriv -#ifdef TIMING - time01=MPI_Wtime() -#endif - call set_matrices -#ifdef TIMING - time_mat=time_mat+MPI_Wtime()-time01 -#endif - endif -cd do i=1,nres-1 -cd write (iout,*) 'i=',i -cd do k=1,3 -cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) -cd enddo -cd do k=1,3 -cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') -cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) -cd enddo -cd enddo - t_eelecij=0.0d0 - ees=0.0D0 - evdw1=0.0D0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 - ind=0 - do i=1,nres - num_cont_hb(i)=0 - enddo -cd print '(a)','Enter EELEC' -cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e - do i=1,nres - gel_loc_loc(i)=0.0d0 - gcorr_loc(i)=0.0d0 - enddo -c -c -c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms -C -C Loop over i,i+2 and i,i+3 pairs of the peptide groups -C - do i=iturn3_start,iturn3_end - if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 - & .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 - call eelecij_scale(i,i+2,ees,evdw1,eel_loc) - if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) - num_cont_hb(i)=num_conti - enddo - do i=iturn4_start,iturn4_end - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 - & .or. itype(i+3).eq.ntyp1 - & .or. itype(i+4).eq.ntyp1) cycle - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=num_cont_hb(i) - call eelecij_scale(i,i+3,ees,evdw1,eel_loc) - if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) - & call eturn4(i,eello_turn4) - num_cont_hb(i)=num_conti - enddo ! i -c -c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 -c - do i=iatel_s,iatel_e - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi -c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) - num_conti=num_cont_hb(i) - do j=ielstart(i),ielend(i) - if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle - call eelecij_scale(i,j,ees,evdw1,eel_loc) - enddo ! j - num_cont_hb(i)=num_conti - enddo ! i -c write (iout,*) "Number of loop steps in EELEC:",ind -cd do i=1,nres -cd write (iout,'(i3,3f10.5,5x,3f10.5)') -cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) -cd enddo -c 12/7/99 Adam eello_turn3 will be considered as a separate energy term -ccc eel_loc=eel_loc+eello_turn3 -cd print *,"Processor",fg_rank," t_eelecij",t_eelecij - return - end -C------------------------------------------------------------------------------- - subroutine eelecij_scale(i,j,ees,evdw1,eel_loc) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - include 'COMMON.TIME1' - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), - & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) - double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), - & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) - common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, - & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, - & num_conti,j1,j2 -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - double precision scal_el /1.0d0/ -#else - double precision scal_el /0.5d0/ -#endif -C 12/13/98 -C 13-go grudnia roku pamietnego... - double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, - & 0.0d0,1.0d0,0.0d0, - & 0.0d0,0.0d0,1.0d0/ -c time00=MPI_Wtime() -cd write (iout,*) "eelecij",i,j - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - aaa=app(iteli,itelj) - bbb=bpp(iteli,itelj) - ael6i=ael6(iteli,itelj) - ael3i=ael3(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - rmij=1.0D0/rij -c For extracting the short-range part of Evdwpp - sss=sscale(rij/rpp(iteli,itelj)) - - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj - cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij - cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij - fac=cosa-3.0D0*cosb*cosg - ev1=aaa*r6ij*r6ij -c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - fac3=ael6i*r6ij - fac4=ael3i*r3ij - evdwij=ev1+ev2 - el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - eesij=el1+el2 -C 12/26/95 - for the evaluation of multi-body H-bonding interactions - ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) - ees=ees+eesij - evdw1=evdw1+evdwij*(1.0d0-sss) -cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, -cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, -cd & xmedi,ymedi,zmedi,xj,yj,zj - - if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss - write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij - endif - -C -C Calculate contributions to the Cartesian gradient. -C -#ifdef SPLITELE - facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss) - facel=-3*rrmij*(el1+eesij) - fac1=fac - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=facel*xj - ggg(2)=facel*yj - ggg(3)=facel*zj -c do k=1,3 -c ghalf=0.5D0*ggg(k) -c gelc(k,i)=gelc(k,i)+ghalf -c gelc(k,j)=gelc(k,j)+ghalf -c enddo -c 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gelc_long(k,j)=gelc_long(k,j)+ggg(k) - gelc_long(k,i)=gelc_long(k,i)-ggg(k) - enddo -* -* Loop over residues i+1 thru j-1. -* -cgrad do k=i+1,j-1 -cgrad do l=1,3 -cgrad gelc(l,k)=gelc(l,k)+ggg(l) -cgrad enddo -cgrad enddo - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj -c do k=1,3 -c ghalf=0.5D0*ggg(k) -c gvdwpp(k,i)=gvdwpp(k,i)+ghalf -c gvdwpp(k,j)=gvdwpp(k,j)+ghalf -c enddo -c 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo -* -* Loop over residues i+1 thru j-1. -* -cgrad do k=i+1,j-1 -cgrad do l=1,3 -cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) -cgrad enddo -cgrad enddo -#else - facvdw=ev1+evdwij*(1.0d0-sss) - facel=el1+eesij - fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=fac*xj - ggg(2)=fac*yj - ggg(3)=fac*zj -c do k=1,3 -c ghalf=0.5D0*ggg(k) -c gelc(k,i)=gelc(k,i)+ghalf -c gelc(k,j)=gelc(k,j)+ghalf -c enddo -c 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gelc_long(k,j)=gelc(k,j)+ggg(k) - gelc_long(k,i)=gelc(k,i)-ggg(k) - enddo -* -* Loop over residues i+1 thru j-1. -* -cgrad do k=i+1,j-1 -cgrad do l=1,3 -cgrad gelc(l,k)=gelc(l,k)+ggg(l) -cgrad enddo -cgrad enddo -c 9/28/08 AL Gradient compotents will be summed only at the end - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo -#endif -* -* Angular part -* - ecosa=2.0D0*fac3*fac1+fac4 - fac4=-3.0D0*fac4 - fac3=-6.0D0*fac3 - ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) - ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo -cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), -cd & (dcosg(k),k=1,3) - do k=1,3 - ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) - enddo -c do k=1,3 -c ghalf=0.5D0*ggg(k) -c gelc(k,i)=gelc(k,i)+ghalf -c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) -c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) -c gelc(k,j)=gelc(k,j)+ghalf -c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) -c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) -c enddo -cgrad do k=i+1,j-1 -cgrad do l=1,3 -cgrad gelc(l,k)=gelc(l,k)+ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gelc(k,i)=gelc(k,i) - & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gelc(k,j)=gelc(k,j) - & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gelc_long(k,j)=gelc_long(k,j)+ggg(k) - gelc_long(k,i)=gelc_long(k,i)-ggg(k) - enddo - IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 - & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -C -C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction -C energy of a peptide unit is assumed in the form of a second-order -C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. -C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms -C are computed for EVERY pair of non-contiguous peptide groups. -C - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - kkk=0 - do k=1,2 - do l=1,2 - kkk=kkk+1 - muij(kkk)=mu(k,i)*mu(l,j) - enddo - enddo -cd write (iout,*) 'EELEC: i',i,' j',j -cd write (iout,*) 'j',j,' j1',j1,' j2',j2 -cd write(iout,*) 'muij',muij - ury=scalar(uy(1,i),erij) - urz=scalar(uz(1,i),erij) - vry=scalar(uy(1,j),erij) - vrz=scalar(uz(1,j),erij) - a22=scalar(uy(1,i),uy(1,j))-3*ury*vry - a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz - a32=scalar(uz(1,i),uy(1,j))-3*urz*vry - a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz - fac=dsqrt(-ael6i)*r3ij - a22=a22*fac - a23=a23*fac - a32=a32*fac - a33=a33*fac -cd write (iout,'(4i5,4f10.5)') -cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 -cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij -cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i), -cd & uy(:,j),uz(:,j) -cd write (iout,'(4f10.5)') -cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)), -cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j)) -cd write (iout,'(4f10.5)') ury,urz,vry,vrz -cd write (iout,'(9f10.5/)') -cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij -C Derivatives of the elements of A in virtual-bond vectors - call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) - do k=1,3 - uryg(k,1)=scalar(erder(1,k),uy(1,i)) - uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) - uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) - urzg(k,1)=scalar(erder(1,k),uz(1,i)) - urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) - urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) - vryg(k,1)=scalar(erder(1,k),uy(1,j)) - vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) - vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) - vrzg(k,1)=scalar(erder(1,k),uz(1,j)) - vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) - vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) - enddo -C Compute radial contributions to the gradient - facr=-3.0d0*rrmij - a22der=a22*facr - a23der=a23*facr - a32der=a32*facr - a33der=a33*facr - agg(1,1)=a22der*xj - agg(2,1)=a22der*yj - agg(3,1)=a22der*zj - agg(1,2)=a23der*xj - agg(2,2)=a23der*yj - agg(3,2)=a23der*zj - agg(1,3)=a32der*xj - agg(2,3)=a32der*yj - agg(3,3)=a32der*zj - agg(1,4)=a33der*xj - agg(2,4)=a33der*yj - agg(3,4)=a33der*zj -C Add the contributions coming from er - fac3=-3.0d0*fac - do k=1,3 - agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) - agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) - agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) - agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) - enddo - do k=1,3 -C Derivatives in DC(i) -cgrad ghalf1=0.5d0*agg(k,1) -cgrad ghalf2=0.5d0*agg(k,2) -cgrad ghalf3=0.5d0*agg(k,3) -cgrad ghalf4=0.5d0*agg(k,4) - aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) - & -3.0d0*uryg(k,2)*vry)!+ghalf1 - aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) - & -3.0d0*uryg(k,2)*vrz)!+ghalf2 - aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) - & -3.0d0*urzg(k,2)*vry)!+ghalf3 - aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) - & -3.0d0*urzg(k,2)*vrz)!+ghalf4 -C Derivatives in DC(i+1) - aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) - & -3.0d0*uryg(k,3)*vry)!+agg(k,1) - aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) - & -3.0d0*uryg(k,3)*vrz)!+agg(k,2) - aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) - & -3.0d0*urzg(k,3)*vry)!+agg(k,3) - aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) - & -3.0d0*urzg(k,3)*vrz)!+agg(k,4) -C Derivatives in DC(j) - aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) - & -3.0d0*vryg(k,2)*ury)!+ghalf1 - aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) - & -3.0d0*vrzg(k,2)*ury)!+ghalf2 - aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) - & -3.0d0*vryg(k,2)*urz)!+ghalf3 - aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) - & -3.0d0*vrzg(k,2)*urz)!+ghalf4 -C Derivatives in DC(j+1) or DC(nres-1) - aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) - & -3.0d0*vryg(k,3)*ury) - aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) - & -3.0d0*vrzg(k,3)*ury) - aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) - & -3.0d0*vryg(k,3)*urz) - aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) - & -3.0d0*vrzg(k,3)*urz) -cgrad if (j.eq.nres-1 .and. i.lt.j-2) then -cgrad do l=1,4 -cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l) -cgrad enddo -cgrad endif - enddo - acipa(1,1)=a22 - acipa(1,2)=a23 - acipa(2,1)=a32 - acipa(2,2)=a33 - a22=-a22 - a23=-a23 - do l=1,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - if (j.lt.nres-1) then - a22=-a22 - a32=-a32 - do l=1,3,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - else - a22=-a22 - a23=-a23 - a32=-a32 - a33=-a33 - do l=1,4 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - endif - ENDIF ! WCORR - IF (wel_loc.gt.0.0d0) THEN -C Contribution to the local-electrostatic energy coming from the i-j pair - eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) - & +a33*muij(4) -cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'eelloc',i,j,eel_loc_ij - - eel_loc=eel_loc+eel_loc_ij -C Partial derivatives in virtual-bond dihedral angles gamma - if (i.gt.1) - & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ - & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) - & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j) - gel_loc_loc(j-1)=gel_loc_loc(j-1)+ - & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) - & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j) -C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) - do l=1,3 - ggg(l)=agg(l,1)*muij(1)+ - & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4) - gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) - gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) -cgrad ghalf=0.5d0*ggg(l) -cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf -cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf - enddo -cgrad do k=i+1,j2 -cgrad do l=1,3 -cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l) -cgrad enddo -cgrad enddo -C Remaining derivatives of eello - do l=1,3 - gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ - & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4) - gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ - & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) - gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ - & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) - gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ - & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) - enddo - ENDIF -C Change 12/26/95 to calculate four-body contributions to H-bonding energy -c if (j.gt.i+1 .and. num_conti.le.maxconts) then - if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 - & .and. num_conti.le.maxconts) then -c write (iout,*) i,j," entered corr" -C -C Calculate the contact function. The ith column of the array JCONT will -C contain the numbers of atoms that make contacts with the atom I (of numbers -C greater than I). The arrays FACONT and GACONT will contain the values of -C the contact function and its derivative. -c r0ij=1.02D0*rpp(iteli,itelj) -c r0ij=1.11D0*rpp(iteli,itelj) - r0ij=2.20D0*rpp(iteli,itelj) -c r0ij=1.55D0*rpp(iteli,itelj) - call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) - if (fcont.gt.0.0D0) then - num_conti=num_conti+1 - if (num_conti.gt.maxconts) then - write (iout,*) 'WARNING - max. # of contacts exceeded;', - & ' will skip next contacts for this conf.' - else - jcont_hb(num_conti,i)=j -cd write (iout,*) "i",i," j",j," num_conti",num_conti, -cd & " jcont_hb",jcont_hb(num_conti,i) - IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. - & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el -C terms. - d_cont(num_conti,i)=rij -cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij -C --- Electrostatic-interaction matrix --- - a_chuj(1,1,num_conti,i)=a22 - a_chuj(1,2,num_conti,i)=a23 - a_chuj(2,1,num_conti,i)=a32 - a_chuj(2,2,num_conti,i)=a33 -C --- Gradient of rij - do kkk=1,3 - grij_hb_cont(kkk,num_conti,i)=erij(kkk) - enddo - kkll=0 - do k=1,2 - do l=1,2 - kkll=kkll+1 - do m=1,3 - a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll) - a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll) - a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll) - a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll) - a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll) - enddo - enddo - enddo - ENDIF - IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN -C Calculate contact energies - cosa4=4.0D0*cosa - wij=cosa-3.0D0*cosb*cosg - cosbg1=cosb+cosg - cosbg2=cosb-cosg -c fac3=dsqrt(-ael6i)/r0ij**3 - fac3=dsqrt(-ael6i)*r3ij -c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) - ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 - if (ees0tmp.gt.0) then - ees0pij=dsqrt(ees0tmp) - else - ees0pij=0 - endif -c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) - ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 - if (ees0tmp.gt.0) then - ees0mij=dsqrt(ees0tmp) - else - ees0mij=0 - endif -c ees0mij=0.0D0 - ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) - ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) -C Diagnostics. Comment out or remove after debugging! -c ees0p(num_conti,i)=0.5D0*fac3*ees0pij -c ees0m(num_conti,i)=0.5D0*fac3*ees0mij -c ees0m(num_conti,i)=0.0D0 -C End diagnostics. -c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, -c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont -C Angular derivatives of the contact function - ees0pij1=fac3/ees0pij - ees0mij1=fac3/ees0mij - fac3p=-3.0D0*fac3*rrmij - ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) - ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) -c ees0mij1=0.0D0 - ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) - ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) - ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) - ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) - ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) - ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) - ecosap=ecosa1+ecosa2 - ecosbp=ecosb1+ecosb2 - ecosgp=ecosg1+ecosg2 - ecosam=ecosa1-ecosa2 - ecosbm=ecosb1-ecosb2 - ecosgm=ecosg1-ecosg2 -C Diagnostics -c ecosap=ecosa1 -c ecosbp=ecosb1 -c ecosgp=ecosg1 -c ecosam=0.0D0 -c ecosbm=0.0D0 -c ecosgm=0.0D0 -C End diagnostics - facont_hb(num_conti,i)=fcont - fprimcont=fprimcont/rij -cd facont_hb(num_conti,i)=1.0D0 -C Following line is for diagnostics. -cd fprimcont=0.0D0 - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo - do k=1,3 - gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) - gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) - enddo - gggp(1)=gggp(1)+ees0pijp*xj - gggp(2)=gggp(2)+ees0pijp*yj - gggp(3)=gggp(3)+ees0pijp*zj - gggm(1)=gggm(1)+ees0mijp*xj - gggm(2)=gggm(2)+ees0mijp*yj - gggm(3)=gggm(3)+ees0mijp*zj -C Derivatives due to the contact function - gacont_hbr(1,num_conti,i)=fprimcont*xj - gacont_hbr(2,num_conti,i)=fprimcont*yj - gacont_hbr(3,num_conti,i)=fprimcont*zj - do k=1,3 -c -c 10/24/08 cgrad and ! comments indicate the parts of the code removed -c following the change of gradient-summation algorithm. -c -cgrad ghalfp=0.5D0*gggp(k) -cgrad ghalfm=0.5D0*gggm(k) - gacontp_hb1(k,num_conti,i)=!ghalfp - & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontp_hb2(k,num_conti,i)=!ghalfp - & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontp_hb3(k,num_conti,i)=gggp(k) - gacontm_hb1(k,num_conti,i)=!ghalfm - & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontm_hb2(k,num_conti,i)=!ghalfm - & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontm_hb3(k,num_conti,i)=gggm(k) - enddo - ENDIF ! wcorr - endif ! num_conti.le.maxconts - endif ! fcont.gt.0 - endif ! j.gt.i+1 - if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then - do k=1,4 - do l=1,3 - ghalf=0.5d0*agg(l,k) - aggi(l,k)=aggi(l,k)+ghalf - aggi1(l,k)=aggi1(l,k)+agg(l,k) - aggj(l,k)=aggj(l,k)+ghalf - enddo - enddo - if (j.eq.nres-1 .and. i.lt.j-2) then - do k=1,4 - do l=1,3 - aggj1(l,k)=aggj1(l,k)+agg(l,k) - enddo - enddo - endif - endif -c t_eelecij=t_eelecij+MPI_Wtime()-time00 - return - end -C----------------------------------------------------------------------- - subroutine evdwpp_short(evdw1) -C -C Compute Evdwpp -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - dimension ggg(3) -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - double precision scal_el /1.0d0/ -#else - double precision scal_el /0.5d0/ -#endif - evdw1=0.0D0 -c write (iout,*) "iatel_s_vdw",iatel_s_vdw, -c & " iatel_e_vdw",iatel_e_vdw - call flush(iout) - do i=iatel_s_vdw,iatel_e_vdw - if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 -c write (iout,*) 'i',i,' ielstart',ielstart_vdw(i), -c & ' ielend',ielend_vdw(i) - call flush(iout) - do j=ielstart_vdw(i),ielend_vdw(i) - if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - aaa=app(iteli,itelj) - bbb=bpp(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - sss=sscale(rij/rpp(iteli,itelj)) - if (sss.gt.0.0d0) then - rmij=1.0D0/rij - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - ev1=aaa*r6ij*r6ij -c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - evdwij=ev1+ev2 - if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss - endif - evdw1=evdw1+evdwij*sss -C -C Calculate contributions to the Cartesian gradient. -C - facvdw=-6*rrmij*(ev1+evdwij)*sss - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo - endif - enddo ! j - enddo ! i - return - end -C----------------------------------------------------------------------------- - subroutine escp_long(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - - sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - - if (sss.lt.1.0d0) then - - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss) - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij*(1.0d0-sss) - if (energy_dec) write (iout,'(a6,2i5,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) - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -C Uncomment following three lines for SC-p interactions -c do k=1,3 -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -c enddo -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - endif - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time the factor EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C----------------------------------------------------------------------------- - subroutine escp_short(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) - if (itypj.eq.ntyp1) cycle -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - - sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - - if (sss.gt.0.0d0) then - - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+(e1+e2)*sss - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij*sss - if (energy_dec) write (iout,'(a6,2i5,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*sss - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -C Uncomment following three lines for SC-p interactions -c do k=1,3 -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -c enddo -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - endif - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time the factor EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end diff --git a/source/unres/src_MD-M-newcorr/energy_p_new.F b/source/unres/src_MD-M-newcorr/energy_p_new.F deleted file mode 100644 index 0b25cb2..0000000 --- a/source/unres/src_MD-M-newcorr/energy_p_new.F +++ /dev/null @@ -1,8381 +0,0 @@ - subroutine etotal(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.LOCAL' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' -#ifdef MPI -c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, -c & " nfgtasks",nfgtasks - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR) -c print *,"Processor",myrank," BROADCAST iorder" -C FG master sets up the WEIGHTS_ array which will be broadcast to the -C FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -C FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -C FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - endif - time_Bcast=time_Bcast+MPI_Wtime()-time00 -c call chainbuild_cart - endif -c print *,'Processor',myrank,' calling etotal ipot=',ipot -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#else -c if (modecalc.eq.12.or.modecalc.eq.14) then -c call int_from_cart1(.false.) -c endif -#endif -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105,106) ipot -C Lennard-Jones potential. - 101 call elj(evdw) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk(evdw) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp(evdw) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb(evdw) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv(evdw) - goto 107 -C Soft-sphere potential - 106 call e_softsphere(evdw) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 continue -c print *,"Processor",myrank," computed USCSC" - call vec_and_deriv -c print *,"Processor",myrank," left VEC_AND_DERIV" - if (ipot.lt.6) then -#ifdef SPLITELE - if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0) then -#else - if (welec.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0) then -#endif - call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) - else - ees=0 - evdw1=0 - eel_loc=0 - eello_turn3=0 - eello_turn4=0 - endif - else -c write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, - & eello_turn4) - endif -c print *,"Processor",myrank," computed UELEC" -C -C Calculate excluded-volume interaction energy between peptide groups -C and side chains. -C - if (ipot.lt.6) then - if(wscp.gt.0d0) then - call escp(evdw2,evdw2_14) - else - evdw2=0 - evdw2_14=0 - endif - else -c write (iout,*) "Soft-sphere SCP potential" - call escp_soft_sphere(evdw2,evdw2_14) - endif -c -c Calculate the bond-stretching energy -c - call ebond(estr) -C -C Calculate the disulfide-bridge and other energy and the contributions -C from other distance constraints. -cd print *,'Calling EHPB' - call edis(ehpb) -cd print *,'EHPB exitted succesfully.' -C -C Calculate the virtual-bond-angle energy. -C - if (wang.gt.0d0) then - call ebend(ebe) - else - ebe=0 - endif -c print *,"Processor",myrank," computed UB" -C -C Calculate the SC local energy. -C - call esc(escloc) -c print *,"Processor",myrank," computed USC" -C -C Calculate the virtual-bond torsional energy. -C -cd print *,'nterm=',nterm - if (wtor.gt.0) then - call etor(etors,edihcnstr) - else - etors=0 - edihcnstr=0 - endif -c print *,"Processor",myrank," computed Utor" -C -C 6/23/01 Calculate double-torsional energy -C - if (wtor_d.gt.0) then - call etor_d(etors_d) - else - etors_d=0 - endif -c print *,"Processor",myrank," computed Utord" -C -C 21/5/07 Calculate local sicdechain correlation energy -C - if (wsccor.gt.0.0d0) then - call eback_sc_corr(esccor) - else - esccor=0.0d0 - endif -c print *,"Processor",myrank," computed Usccorr" -C -C 12/1/95 Multi-body terms -C - n_corr=0 - n_corr1=0 - if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 - & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then - call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -c write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1, -c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0 - ecorr5=0 - ecorr6=0 - eturn6=0 - endif - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) - else - ecorr=0 - ecorr5=0 - ecorr6=0 - eturn6=0 - endif -c print *,"Processor",myrank," computed Ucorr" -C -C If performing constraint dynamics, call the constraint energy -C after the equilibration time - if(usampl.and.totT.gt.eq_time) then - call EconstrQ - call Econstr_back - else - Uconst=0.0d0 - Uconst_back=0.0d0 - endif -c print *,"Processor",myrank," computed Uconstr" -c -C Sum the energies -C - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(19)=edihcnstr - energia(17)=estr - energia(20)=Uconst+Uconst_back - energia(21)=esccor -c print *," Processor",myrank," calls SUM_ENERGY" - call sum_energy(energia,.true.) -c print *," Processor",myrank," left SUM_ENERGY" - return - end -c------------------------------------------------------------------------------- - subroutine sum_energy(energia,reduce) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene),enebuff(0:n_ene+1) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - logical reduce -#ifdef MPI - if (nfgtasks.gt.1 .and. reduce) then -#ifdef DEBUG - write (iout,*) "energies before REDUCE" - call enerprint(energia) - call flush(iout) -#endif - do i=0,n_ene - enebuff(i)=energia(i) - enddo - time00=MPI_Wtime() - call MPI_Reduce(enebuff(0),energia(0),n_ene+1, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) -#ifdef DEBUG - write (iout,*) "energies after REDUCE" - call enerprint(energia) - call flush(iout) -#endif - time_Reduce=time_Reduce+MPI_Wtime()-time00 - endif - if (fg_rank.eq.0) then -#endif - evdw=energia(1) -#ifdef SCP14 - evdw2=energia(2)+energia(18) - evdw2_14=energia(18) -#else - evdw2=energia(2) -#endif -#ifdef SPLITELE - ees=energia(3) - evdw1=energia(16) -#else - ees=energia(3) - evdw1=0.0d0 -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eturn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor -#else - etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor -#endif - energia(0)=etot -c detecting NaNQ -#ifdef ISNAN -#ifdef AIX - if (isnan(etot).ne.0) energia(0)=1.0d+99 -#else - if (isnan(etot)) energia(0)=1.0d+99 -#endif -#else - i=0 -#ifdef WINPGI - idumm=proc_proc(etot,i) -#else - call proc_proc(etot,i) -#endif - if(i.eq.1)energia(0)=1.0d+99 -#endif -#ifdef MPI - endif -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sum_gradient - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include 'mpif.h' - double precision gradbufc(3,maxres),gradbufx(3,maxres), - & glocbuf(4*maxres) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - include 'COMMON.MAXGRAD' -C -C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient -C in virtual-bond-vector coordinates -C -#ifdef TIMING - time01=MPI_Wtime() -#endif -#ifdef DEBUG - write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" - do i=1,nres-1 - write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') - & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) - enddo - write (iout,*) "gcorr4_turn, gel_loc_turn4" - do i=1,nres-1 - write (iout,'(i5,3f10.5,2x,f10.5)') - & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) - enddo -#endif - do i=nnt,nres-1 - do k=1,3 - gvdwc(k,i)=0.0d0 - gvdwc_scp(k,i)=0.0d0 - enddo - do j=i+1,nres - do k=1,3 - gvdwc(k,i)=gvdwc(k,i)+gvdwc(k,j) - gvdwc_scp(k,i)=gvdwc_scp(k,i)+gvdwc_scp(k,j) - enddo - enddo - enddo - do i=nnt,nct-1 - do k=1,3 - gelc(k,i)=gelc(k,i)+0.5d0*gelc_long(k,i) - gvdwpp(k,i)=0.5d0*gvdwpp(k,i) - gvdwc_scp(k,i)=gvdwc_scp(k,i)+0.5d0*gvdwc_scpp(k,i) - enddo - do j=i+1,nct-1 - do k=1,3 - gelc(k,i)=gelc(k,i)+gelc_long(k,j) - gvdwpp(k,i)=gvdwpp(k,i)+gvdwpp(k,j) - gvdwc_scp(k,i)=gvdwc_scp(k,i)+gvdwc_scpp(k,j) - enddo - enddo - enddo - do i=nnt,nct-1 - do k=1,3 - gel_loc(k,i)=gel_loc(k,i)+0.5d0*gel_loc_long(k,i) - enddo - do j=i+1,nres-1 - do k=1,3 - gel_loc(k,i)=gel_loc(k,i)+gel_loc_long(k,j) - enddo - enddo - enddo - do k=1,3 - gvdwc_scp(k,nres)=0.0d0 - gvdwc(k,nres)=0.0d0 - gel_loc(k,nres)=0.0d0 - enddo -C -C Sum up the components of the Cartesian gradient. -C -#ifdef SPLITELE - 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)+wvdwpp*gvdwpp(j,i)+ - & wbond*gradb(j,i)+ - & wstrain*ghpbc(j,i)+ - & wcorr*gradcorr(j,i)+ - & wel_loc*gel_loc(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) - gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*gsccorx(j,i) - & +wscloc*gsclocx(j,i) - enddo - enddo -#else - 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)+ - & wbond*gradb(j,i)+ - & wcorr*gradcorr(j,i)+ - & wel_loc*gel_loc(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) - gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*gsccorx(j,i) - & +wscloc*gsclocx(j,i) - enddo - enddo -#endif -#ifdef DEBUG - write (iout,*) "gloc before adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) - & +wcorr5*g_corr5_loc(i) - & +wcorr6*g_corr6_loc(i) - & +wturn4*gel_loc_turn4(i) - & +wturn3*gel_loc_turn3(i) - & +wturn6*gel_loc_turn6(i) - & +wel_loc*gel_loc_loc(i) - & +wsccor*gsccor_loc(i) - enddo -#ifdef DEBUG - write (iout,*) "gloc after adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - do j=1,3 - do i=1,nres - gradbufc(j,i)=gradc(j,i,icg) - gradbufx(j,i)=gradx(j,i,icg) - enddo - enddo - do i=1,4*nres - glocbuf(i)=gloc(i,icg) - enddo -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) call MPI_Bcast(1,1,MPI_INTEGER, - & king,FG_COMM,IERROR) - time00=MPI_Wtime() - call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -#ifdef DEBUG - write (iout,*) "gloc after reduce" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - endif -#endif - if (gnorm_check) then -c -c Compute the maximum elements of the gradient -c - gvdwc_max=0.0d0 - gvdwc_scp_max=0.0d0 - gelc_max=0.0d0 - gvdwpp_max=0.0d0 - gradb_max=0.0d0 - ghpbc_max=0.0d0 - gradcorr_max=0.0d0 - gel_loc_max=0.0d0 - gcorr3_turn_max=0.0d0 - gcorr4_turn_max=0.0d0 - gradcorr5_max=0.0d0 - gradcorr6_max=0.0d0 - gcorr6_turn_max=0.0d0 - gsccorc_max=0.0d0 - gscloc_max=0.0d0 - gvdwx_max=0.0d0 - gradx_scp_max=0.0d0 - ghpbx_max=0.0d0 - gradxorr_max=0.0d0 - gsccorx_max=0.0d0 - gsclocx_max=0.0d0 - do i=1,nct - gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) - if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm - gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i))) - if (gvdwc_scp_norm.gt.gvdwc_scp_max) - & gvdwc_scp_max=gvdwc_scp_norm - gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i))) - if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm - gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i))) - if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm - gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i))) - if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm - ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i))) - if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm - gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i))) - if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm - gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i))) - if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm - gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i), - & gcorr3_turn(1,i))) - if (gcorr3_turn_norm.gt.gcorr3_turn_max) - & gcorr3_turn_max=gcorr3_turn_norm - gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i), - & gcorr4_turn(1,i))) - if (gcorr4_turn_norm.gt.gcorr4_turn_max) - & gcorr4_turn_max=gcorr4_turn_norm - gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i))) - if (gradcorr5_norm.gt.gradcorr5_max) - & gradcorr5_max=gradcorr5_norm - gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i))) - if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm - gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i), - & gcorr6_turn(1,i))) - if (gcorr6_turn_norm.gt.gcorr6_turn_max) - & gcorr6_turn_max=gcorr6_turn_norm - gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) - if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm - gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) - if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm - gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) - if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm - gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i))) - if (gradx_scp_norm.gt.gradx_scp_max) - & gradx_scp_max=gradx_scp_norm - ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i))) - if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm - gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i))) - if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm - gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i))) - if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm - gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i))) - if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm - enddo - if (gradout) then -#ifdef AIX - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif - write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max, - & gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max - close(istat) - if (gvdwc_max.gt.1.0d4) then - write (iout,*) "gvdwc gvdwx gradb gradbx" - do i=nnt,nct - write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i), - & gradb(j,i),gradbx(j,i),j=1,3) - enddo - call pdbout(0.0d0,'cipiszcze',iout) - call flush(iout) - endif - endif - endif -#ifdef DEBUG - write (iout,*) "gradc gradx gloc" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) - enddo -#endif -#ifdef TIMING - time_sumgradient=time_sumgradient+MPI_Wtime()-time01 -#endif - return - end -c------------------------------------------------------------------------------- - subroutine rescale_weights(t_bath) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - double precision kfac /2.4d0/ - double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/ -c facT=temp0/t_bath -c facT=2*temp0/(t_bath+temp0) - if (rescale_mode.eq.0) then - facT=1.0d0 - facT2=1.0d0 - facT3=1.0d0 - facT4=1.0d0 - facT5=1.0d0 - else if (rescale_mode.eq.1) then - facT=kfac/(kfac-1.0d0+t_bath/temp0) - facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) - facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) - facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) - facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) - else if (rescale_mode.eq.2) then - x=t_bath/temp0 - x2=x*x - x3=x2*x - x4=x3*x - x5=x4*x - facT=licznik/dlog(dexp(x)+dexp(-x)) - facT2=licznik/dlog(dexp(x2)+dexp(-x2)) - facT3=licznik/dlog(dexp(x3)+dexp(-x3)) - facT4=licznik/dlog(dexp(x4)+dexp(-x4)) - facT5=licznik/dlog(dexp(x5)+dexp(-x5)) - else - write (iout,*) "Wrong RESCALE_MODE",rescale_mode - write (*,*) "Wrong RESCALE_MODE",rescale_mode -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) -#endif - stop 555 - endif - welec=weights(3)*fact - wcorr=weights(4)*fact3 - wcorr5=weights(5)*fact4 - wcorr6=weights(6)*fact5 - wel_loc=weights(7)*fact2 - wturn3=weights(8)*fact2 - wturn4=weights(9)*fact3 - wturn6=weights(10)*fact5 - wtor=weights(13)*fact - wtor_d=weights(14)*fact2 - wsccor=weights(21)*fact - - return - end -C------------------------------------------------------------------------ - subroutine enerprint(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.MD' - double precision energia(0:n_ene) - etot=energia(0) - evdw=energia(1) - evdw2=energia(2) -#ifdef SCP14 - evdw2=energia(2)+energia(18) -#else - evdw2=energia(2) -#endif - ees=energia(3) -#ifdef SPLITELE - evdw1=energia(16) -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eello_turn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor, - & edihcnstr,ebr*nss, - & Uconst,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST= ',1pE16.6,' (Constraint energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#else - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr, - & ebr*nss,Uconst,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST=',1pE16.6,' (Constraint energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#endif - return - end -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' - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C Change 12/1/95 - num_conti=0 -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) -cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -cd & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi -C Change 12/1/95 to calculate four-body interactions - rij=xj*xj+yj*yj+zj*zj - rrij=1.0D0/rij -c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+evdwij -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) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - 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 -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 - enddo - - enddo ! iint - enddo ! i - return - end -C----------------------------------------------------------------------------- - subroutine escp(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+e1+e2 - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw2',i,j,evdwij -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -cgrad if (j.lt.i) then -cd write (iout,*) 'ji' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time the factor EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C-------------------------------------------------------------------------- - subroutine edis(ehpb) -C -C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - 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. - if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then - call ssbond_ene(iii,jjj,eij) - ehpb=ehpb+2*eij - else -C Calculate the distance between the two points and its difference from the -C target distance. - dd=dist(ii,jj) - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd -cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, -cd & ' waga=',waga,' fac=',fac - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo -cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) -C If this is a SC-SC distance, we need to calculate the contributions to the -C Cartesian gradient in the SC vectors (ghpbx). - if (iii.lt.ii) then - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - endif - do j=iii,jjj-1 - do k=1,3 - ghpbc(k,j)=ghpbc(k,j)+ggg(k) - enddo - enddo - endif - enddo - ehpb=0.5D0*ehpb - return - end -C-------------------------------------------------------------------------- - subroutine ssbond_ene(i,j,eij) -C -C Calculate the distance and angle dependent SS-bond potential energy -C using a free-energy function derived based on RHF/6-31G** ab initio -C calculations of diethyl disulfide. -C -C A. Liwo and U. Kozlowska, 11/24/03 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - double precision erij(3),dcosom1(3),dcosom2(3),gg(3) - itypi=itype(i) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) - dsci_inv=dsc_inv(itypi) - itypj=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' - include 'COMMON.SETUP' - double precision u(3),ud(3) - estr=0.0d0 - do i=ibondp_start,ibondp_end - diff = vbld(i)-vbldp0 -c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff - estr=estr+diff*diff - do j=1,3 - gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) - enddo -c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) - enddo - estr=0.5d0*AKP*estr -c -c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included -c - do i=ibond_start,ibond_end - iti=itype(i) - if (iti.ne.10) then - nbi=nbondterm(iti) - if (nbi.eq.1) then - diff=vbld(i+nres)-vbldsc0(1,iti) -c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, -c & AKSC(1,iti),AKSC(1,iti)*diff*diff - estr=estr+0.5d0*AKSC(1,iti)*diff*diff - do j=1,3 - gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) - enddo - else - do j=1,nbi - diff=vbld(i+nres)-vbldsc0(j,iti) - ud(j)=aksc(j,iti)*diff - u(j)=abond0(j,iti)+0.5d0*ud(j)*diff - enddo - uprod=u(1) - do j=2,nbi - uprod=uprod*u(j) - enddo - usum=0.0d0 - usumsqder=0.0d0 - do j=1,nbi - uprod1=1.0d0 - uprod2=1.0d0 - do k=1,nbi - if (k.ne.j) then - uprod1=uprod1*u(k) - uprod2=uprod2*u(k)*u(k) - endif - enddo - usum=usum+uprod1 - usumsqder=usumsqder+ud(j)*uprod2 - enddo - estr=estr+uprod/usum - do j=1,3 - gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) - enddo - endif - endif - enddo - return - end -#ifdef CRYST_THETA -C-------------------------------------------------------------------------- - subroutine ebend(etheta) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - double precision y(2),z(2) - delta=0.02d0*pi -c time11=dexp(-2*time) -c time12=1.0d0 - etheta=0.0D0 -c write (*,'(a,i2)') 'EBEND ICG=',icg - do i=ithet_start,ithet_end -C Zero the energy function and its derivative at 0 or pi. - call splinthet(theta(i),0.5d0*delta,ss,ssd) - it=itype(i-1) - if (i.gt.3) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - y(1)=dcos(phii) - y(2)=dsin(phii) - else - y(1)=0.0D0 - y(2)=0.0D0 - endif - if (i.lt.nres) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) - z(1)=cos(phii1) -#else - phii1=phi(i+1) - z(1)=dcos(phii1) -#endif - z(2)=dsin(phii1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif -C Calculate the "mean" value of theta from the part of the distribution -C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). -C In following comments this theta will be referred to as t_c. - thet_pred_mean=0.0d0 - do k=1,2 - athetk=athet(k,it) - bthetk=bthet(k,it) - thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) - enddo - dthett=thet_pred_mean*ssd - thet_pred_mean=thet_pred_mean*ss+a0thet(it) -C Derivatives of the "mean" values in gamma1 and gamma2. - dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss - dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss - if (theta(i).gt.pi-delta) then - call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, - & E_tc0) - call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) - call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, - & E_theta) - call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else if (theta(i).lt.delta) then - call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) - call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, - & E_theta) - call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) - call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else - call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, - & E_theta,E_tc) - endif - etheta=etheta+ethetai - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'ebend',i,ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 - gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) - enddo -C Ufff.... We've done all this!!! - return - end -C--------------------------------------------------------------------------- - subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, - & E_tc) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it -C Calculate the contributions to both Gaussian lobes. -C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) -C The "polynomial part" of the "standard deviation" of this part of -C the distribution. - sig=polthet(3,it) - do j=2,0,-1 - sig=sig*thet_pred_mean+polthet(j,it) - enddo -C Derivative of the "interior part" of the "standard deviation of the" -C gamma-dependent Gaussian lobe in t_c. - sigtc=3*polthet(3,it) - do j=2,1,-1 - sigtc=sigtc*thet_pred_mean+j*polthet(j,it) - enddo - sigtc=sig*sigtc -C Set the parameters of both Gaussian lobes of the distribution. -C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) - fac=sig*sig+sigc0(it) - sigcsq=fac+fac - sigc=1.0D0/sigcsq -C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c - sigsqtc=-4.0D0*sigcsq*sigtc -c print *,i,sig,sigtc,sigsqtc -C Following variable (sigtc) is d[sigma(t_c)]/dt_c - sigtc=-sigtc/(fac*fac) -C Following variable is sigma(t_c)**(-2) - sigcsq=sigcsq*sigcsq - sig0i=sig0(it) - sig0inv=1.0D0/sig0i**2 - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i - term1=-0.5D0*sigcsq*delthec*delthec - term2=-0.5D0*sig0inv*delthe0*delthe0 -C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and -C NaNs in taking the logarithm. We extract the largest exponent which is added -C to the energy (this being the log of the distribution) at the end of energy -C term evaluation for this virtual-bond angle. - if (term1.gt.term2) then - termm=term1 - term2=dexp(term2-termm) - term1=1.0d0 - else - termm=term2 - term1=dexp(term1-termm) - term2=1.0d0 - endif -C The ratio between the gamma-independent and gamma-dependent lobes of -C the distribution is a Gaussian function of thet_pred_mean too. - diffak=gthet(2,it)-thet_pred_mean - ratak=diffak/gthet(3,it)**2 - ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) -C Let's differentiate it in thet_pred_mean NOW. - aktc=ak*ratak -C Now put together the distribution terms to make complete distribution. - termexp=term1+ak*term2 - termpre=sigc+ak*sig0i -C Contribution of the bending energy from this theta is just the -log of -C the sum of the contributions from the two lobes and the pre-exponential -C factor. Simple enough, isn't it? - ethetai=(-dlog(termexp)-termm+dlog(termpre)) -C NOW the derivatives!!! -C 6/6/97 Take into account the deformation. - E_theta=(delthec*sigcsq*term1 - & +ak*delthe0*sig0inv*term2)/termexp - E_tc=((sigtc+aktc*sig0i)/termpre - & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ - & aktc*term2)/termexp) - return - end -c----------------------------------------------------------------------------- - subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i -C "Thank you" to MAPLE (probably spared one day of hand-differentiation). - t3 = thetai-thet_pred_mean - t6 = t3**2 - t9 = term1 - t12 = t3*sigcsq - t14 = t12+t6*sigsqtc - t16 = 1.0d0 - t21 = thetai-theta0i - t23 = t21**2 - t26 = term2 - t27 = t21*t26 - t32 = termexp - t40 = t32**2 - E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 - & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 - & *(-t12*t9-ak*sig0inv*t27) - return - end -#else -C-------------------------------------------------------------------------- - subroutine ebend(etheta) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C ab initio-derived potentials from -c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), - & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), - & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), - & sinph1ph2(maxdouble,maxdouble) - logical lprn /.false./, lprn1 /.false./ - etheta=0.0D0 - do i=ithet_start,ithet_end - dethetai=0.0d0 - dephii=0.0d0 - dephii1=0.0d0 - theti2=0.5d0*theta(i) - ityp2=ithetyp(itype(i-1)) - do k=1,nntheterm - coskt(k)=dcos(k*theti2) - sinkt(k)=dsin(k*theti2) - enddo - if (i.gt.3) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - ityp1=ithetyp(itype(i-2)) - do k=1,nsingle - cosph1(k)=dcos(k*phii) - sinph1(k)=dsin(k*phii) - enddo - else - phii=0.0d0 - ityp1=nthetyp+1 - do k=1,nsingle - cosph1(k)=0.0d0 - sinph1(k)=0.0d0 - enddo - endif - if (i.lt.nres) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) -#else - phii1=phi(i+1) -#endif - ityp3=ithetyp(itype(i)) - do k=1,nsingle - cosph2(k)=dcos(k*phii1) - sinph2(k)=dsin(k*phii1) - enddo - else - phii1=0.0d0 - ityp3=nthetyp+1 - do k=1,nsingle - cosph2(k)=0.0d0 - sinph2(k)=0.0d0 - enddo - endif - ethetai=aa0thet(ityp1,ityp2,ityp3) - do k=1,ndouble - do l=1,k-1 - ccl=cosph1(l)*cosph2(k-l) - ssl=sinph1(l)*sinph2(k-l) - scl=sinph1(l)*cosph2(k-l) - csl=cosph1(l)*sinph2(k-l) - cosph1ph2(l,k)=ccl-ssl - cosph1ph2(k,l)=ccl+ssl - sinph1ph2(l,k)=scl+csl - sinph1ph2(k,l)=scl-csl - enddo - enddo - if (lprn) then - write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, - & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 - write (iout,*) "coskt and sinkt" - do k=1,nntheterm - write (iout,*) k,coskt(k),sinkt(k) - enddo - endif - do k=1,ntheterm - ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k) - dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3) - & *coskt(k) - if (lprn) - & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), - & " ethetai",ethetai - enddo - if (lprn) then - write (iout,*) "cosph and sinph" - do k=1,nsingle - write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) - enddo - write (iout,*) "cosph1ph2 and sinph2ph2" - do k=2,ndouble - do l=1,k-1 - write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), - & sinph1ph2(l,k),sinph1ph2(k,l) - enddo - enddo - write(iout,*) "ethetai",ethetai - endif - do m=1,ntheterm2 - do k=1,nsingle - aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k) - & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k) - & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k) - & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*aux*coskt(m) - dephii=dephii+k*sinkt(m)*( - & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)- - & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) - dephii1=dephii1+k*sinkt(m)*( - & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- - & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) - if (lprn) - & write (iout,*) "m",m," k",k," bbthet", - & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", - & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", - & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", - & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai - enddo - enddo - if (lprn) - & write(iout,*) "ethetai",ethetai - do m=1,ntheterm3 - do k=2,ndouble - do l=1,k-1 - aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*coskt(m)*aux - dephii=dephii+l*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)- - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - dephii1=dephii1+(k-l)*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)- - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - if (lprn) then - write (iout,*) "m",m," k",k," l",l," ffthet", - & ffthet(l,k,m,ityp1,ityp2,ityp3), - & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", - & ggthet(l,k,m,ityp1,ityp2,ityp3), - & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai - write (iout,*) cosph1ph2(l,k)*sinkt(m), - & cosph1ph2(k,l)*sinkt(m), - & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) - endif - enddo - enddo - enddo -10 continue - if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') - & i,theta(i)*rad2deg,phii*rad2deg, - & phii1*rad2deg,ethetai - etheta=etheta+ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 - gloc(nphi+i-2,icg)=wang*dethetai - enddo - return - end -#endif -#ifdef CRYST_SC -c----------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), - & ddersc0(3),ddummy(3),xtemp(3),temp(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 -c write (iout,'(a)') 'ESC' - do i=loc_start,loc_end - it=itype(i) - if (it.eq.10) goto 1 - nlobit=nlob(it) -c print *,'i=',i,' it=',it,' nlobit=',nlobit -c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad - theti=theta(i+1)-pipol - x(1)=dtan(theti) - x(2)=alph(i) - x(3)=omeg(i) - - if (x(2).gt.pi-delta) then - xtemp(1)=x(1) - xtemp(2)=pi-delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=pi - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=pi-delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=pi - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - call splinthet(x(2),0.5d0*delta,ss,ssd) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c escloci=esclocbi -c write (iout,*) escloci - else if (x(2).lt.delta) then - xtemp(1)=x(1) - xtemp(2)=delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=0.0d0 - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=0.0d0 - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - call splinthet(x(2),0.5d0*delta,ss,ssd) - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c write (iout,*) escloci - else - call enesc(x,escloci,dersc,ddummy,.false.) - endif - - escloc=escloc+escloci - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'escloc',i,escloci -c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc - - gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ - & wscloc*dersc(1) - gloc(ialph(i,1),icg)=wscloc*dersc(2) - gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) - 1 continue - enddo - return - end -C--------------------------------------------------------------------------- - subroutine enesc(x,escloci,dersc,ddersc,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) - double precision contr(maxlob,-1:1) - logical mixed -c write (iout,*) 'it=',it,' nlobit=',nlobit - escloc_i=0.0D0 - do j=1,3 - dersc(j)=0.0D0 - if (mixed) ddersc(j)=0.0d0 - enddo - x3=x(3) - -C Because of periodicity of the dependence of the SC energy in omega we have -C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). -C To avoid underflows, first compute & store the exponents. - - do iii=-1,1 - - x(3)=x3+iii*dwapi - - do j=1,nlobit - do k=1,3 - z(k)=x(k)-censc(k,j,it) - enddo - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j,iii)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j,iii)*z(k) - enddo - contr(j,iii)=expfac - enddo ! j - - enddo ! iii - - x(3)=x3 -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1,-1) - do iii=-1,1 - do j=1,nlobit - if (emin.gt.contr(j,iii)) emin=contr(j,iii) - enddo - enddo - emin=0.5D0*emin -cd print *,'it=',it,' emin=',emin - -C Compute the contribution to SC energy and derivatives - do iii=-1,1 - - do j=1,nlobit -#ifdef OSF - adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin - if(adexp.ne.adexp) adexp=1.0 - expfac=dexp(adexp) -#else - expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin) -#endif -cd print *,'j=',j,' expfac=',expfac - escloc_i=escloc_i+expfac - do k=1,3 - dersc(k)=dersc(k)+Ax(k,j,iii)*expfac - enddo - if (mixed) then - do k=1,3,2 - ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) - & +gaussc(k,2,j,it))*expfac - enddo - endif - enddo - - enddo ! iii - - dersc(1)=dersc(1)/cos(theti)**2 - ddersc(1)=ddersc(1)/cos(theti)**2 - ddersc(3)=ddersc(3) - - escloci=-(dlog(escloc_i)-emin) - do j=1,3 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) then - do j=1,3,2 - ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) - enddo - endif - return - end -C------------------------------------------------------------------------------ - subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob),dersc(3) - double precision contr(maxlob) - logical mixed - - escloc_i=0.0D0 - - do j=1,3 - dersc(j)=0.0D0 - enddo - - do j=1,nlobit - do k=1,2 - z(k)=x(k)-censc(k,j,it) - enddo - z(3)=dwapi - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j)*z(k) - enddo - contr(j)=expfac - enddo ! j - -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1) - do j=1,nlobit - if (emin.gt.contr(j)) emin=contr(j) - enddo - emin=0.5D0*emin - -C Compute the contribution to SC energy and derivatives - - dersc12=0.0d0 - do j=1,nlobit - expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin) - escloc_i=escloc_i+expfac - do k=1,2 - dersc(k)=dersc(k)+Ax(k,j)*expfac - enddo - if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) - & +gaussc(1,2,j,it))*expfac - dersc(3)=0.0d0 - enddo - - dersc(1)=dersc(1)/cos(theti)**2 - dersc12=dersc12/cos(theti)**2 - escloci=-(dlog(escloc_i)-emin) - do j=1,2 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) - return - end -#else -c---------------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA derived from AM1 all-atom calculations. -C added by Urszula Kozlowska. 07/11/2007 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.SCROT' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - include 'COMMON.VECTORS' - double precision x_prime(3),y_prime(3),z_prime(3) - & , sumene,dsc_i,dp2_i,x(65), - & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, - & de_dxx,de_dyy,de_dzz,de_dt - double precision s1_t,s1_6_t,s2_t,s2_6_t - double precision - & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), - & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), - & dt_dCi(3),dt_dCi1(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 - do i=loc_start,loc_end - costtab(i+1) =dcos(theta(i+1)) - sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) - cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) - sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) - cosfac2=0.5d0/(1.0d0+costtab(i+1)) - cosfac=dsqrt(cosfac2) - sinfac2=0.5d0/(1.0d0-costtab(i+1)) - sinfac=dsqrt(sinfac2) - it=itype(i) - if (it.eq.10) goto 1 -c -C Compute the axes of tghe local cartesian coordinates system; store in -c x_prime, y_prime and z_prime -c - do j=1,3 - x_prime(j) = 0.00 - y_prime(j) = 0.00 - z_prime(j) = 0.00 - enddo -C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), -C & dc_norm(3,i+nres) - do j = 1,3 - x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac - y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac - enddo - do j = 1,3 - z_prime(j) = -uz(j,i-1) - enddo -c write (2,*) "i",i -c write (2,*) "x_prime",(x_prime(j),j=1,3) -c write (2,*) "y_prime",(y_prime(j),j=1,3) -c write (2,*) "z_prime",(z_prime(j),j=1,3) -c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), -c & " xy",scalar(x_prime(1),y_prime(1)), -c & " xz",scalar(x_prime(1),z_prime(1)), -c & " yy",scalar(y_prime(1),y_prime(1)), -c & " yz",scalar(y_prime(1),z_prime(1)), -c & " zz",scalar(z_prime(1),z_prime(1)) -c -C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), -C to local coordinate system. Store in xx, yy, zz. -c - xx=0.0d0 - yy=0.0d0 - zz=0.0d0 - do j = 1,3 - xx = xx + x_prime(j)*dc_norm(j,i+nres) - yy = yy + y_prime(j)*dc_norm(j,i+nres) - zz = zz + z_prime(j)*dc_norm(j,i+nres) - enddo - - xxtab(i)=xx - yytab(i)=yy - zztab(i)=zz -C -C Compute the energy of the ith side cbain -C -c write (2,*) "xx",xx," yy",yy," zz",zz - it=itype(i) - do j = 1,65 - x(j) = sc_parmin(j,it) - enddo -#ifdef CHECK_COORD -Cc diagnostics - remove later - xx1 = dcos(alph(2)) - yy1 = dsin(alph(2))*dcos(omeg(2)) - zz1 = -dsin(alph(2))*dsin(omeg(2)) - write(2,'(3f8.1,3f9.3,1x,3f9.3)') - & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, - & xx1,yy1,zz1 -C," --- ", xx_w,yy_w,zz_w -c end diagnostics -#endif - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) - & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) -c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, -c & sumene4, -c & dscp1,dscp2,sumene -c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - escloc = escloc + sumene -c write (2,*) "i",i," escloc",sumene,escloc -#ifdef DEBUG -C -C This section to check the numerical derivatives of the energy of ith side -C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert -C #define DEBUG in the code to turn it on. -C - write (2,*) "sumene =",sumene - aincr=1.0d-7 - xxsave=xx - xx=xx+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dxx_num=(sumenep-sumene)/aincr - xx=xxsave - write (2,*) "xx+ sumene from enesc=",sumenep - yysave=yy - yy=yy+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dyy_num=(sumenep-sumene)/aincr - yy=yysave - write (2,*) "yy+ sumene from enesc=",sumenep - zzsave=zz - zz=zz+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dzz_num=(sumenep-sumene)/aincr - zz=zzsave - write (2,*) "zz+ sumene from enesc=",sumenep - costsave=cost2tab(i+1) - sintsave=sint2tab(i+1) - cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) - sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dt_num=(sumenep-sumene)/aincr - write (2,*) " t+ sumene from enesc=",sumenep - cost2tab(i+1)=costsave - sint2tab(i+1)=sintsave -C End of diagnostics section. -#endif -C -C Compute the gradient of esc -C - pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 - pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 - pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 - pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 - pom_dx=dsc_i*dp2_i*cost2tab(i+1) - pom_dy=dsc_i*dp2_i*sint2tab(i+1) - pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) - pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) - pom1=(sumene3*sint2tab(i+1)+sumene1) - & *(pom_s1/dscp1+pom_s16*dscp1**4) - pom2=(sumene4*cost2tab(i+1)+sumene2) - & *(pom_s2/dscp2+pom_s26*dscp2**4) - sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy - sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 - & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) - & +x(40)*yy*zz - sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy - sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 - & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) - & +x(60)*yy*zz - de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) - & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) - & +(pom1+pom2)*pom_dx -#ifdef DEBUG - write(2,*), "de_dxx = ", de_dxx,de_dxx_num -#endif -C - sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz - sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 - & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) - & +x(40)*xx*zz - sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz - sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz - & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz - & +x(59)*zz**2 +x(60)*xx*zz - de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) - & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) - & +(pom1-pom2)*pom_dy -#ifdef DEBUG - write(2,*), "de_dyy = ", de_dyy,de_dyy_num -#endif -C - de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy - & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx - & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) - & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) - & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 - & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy - & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) - & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) -#ifdef DEBUG - write(2,*), "de_dzz = ", de_dzz,de_dzz_num -#endif -C - de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) - & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) - & +pom1*pom_dt1+pom2*pom_dt2 -#ifdef DEBUG - write(2,*), "de_dt = ", de_dt,de_dt_num -#endif -c -C - cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) - cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) - cosfac2xx=cosfac2*xx - sinfac2yy=sinfac2*yy - do k = 1,3 - dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* - & vbld_inv(i+1) - dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* - & vbld_inv(i) - pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) - pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) -c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, -c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) -c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), -c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) - dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx - dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx - dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy - dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy - dZZ_Ci1(k)=0.0d0 - dZZ_Ci(k)=0.0d0 - do j=1,3 - dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres) - dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres) - enddo - - dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) - dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) - dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) -c - dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) - dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) - enddo - - do k=1,3 - dXX_Ctab(k,i)=dXX_Ci(k) - dXX_C1tab(k,i)=dXX_Ci1(k) - dYY_Ctab(k,i)=dYY_Ci(k) - dYY_C1tab(k,i)=dYY_Ci1(k) - dZZ_Ctab(k,i)=dZZ_Ci(k) - dZZ_C1tab(k,i)=dZZ_Ci1(k) - dXX_XYZtab(k,i)=dXX_XYZ(k) - dYY_XYZtab(k,i)=dYY_XYZ(k) - dZZ_XYZtab(k,i)=dZZ_XYZ(k) - enddo - - do k = 1,3 -c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", -c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) -c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", -c & dyy_ci(k)," dzz_ci",dzz_ci(k) -c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", -c & dt_dci(k) -c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", -c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) - gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) - & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) - gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) - & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) - gsclocx(k,i)= de_dxx*dxx_XYZ(k) - & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) - enddo -c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), -c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) - -C to check gradient call subroutine check_grad - - 1 continue - enddo - return - end -c------------------------------------------------------------------------------ - double precision function enesc(x,xx,yy,zz,cost2,sint2) - implicit none - double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2, - & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6 - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2+yy*sint2)) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2-yy*sint2)) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) - & + (sumene4*cost2 +sumene2)*(s2+s2_6) - enesc=sumene - return - end -#endif -c------------------------------------------------------------------------------ - subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) -C -C This procedure calculates two-body contact function g(rij) and its derivative: -C -C eps0ij ! x < -1 -C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 -C 0 ! x > 1 -C -C where x=(rij-r0ij)/delta -C -C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy -C - implicit none - double precision rij,r0ij,eps0ij,fcont,fprimcont - double precision x,x2,x4,delta -c delta=0.02D0*r0ij -c delta=0.2D0*r0ij - x=(rij-r0ij)/delta - if (x.lt.-1.0D0) then - fcont=eps0ij - fprimcont=0.0D0 - else if (x.le.1.0D0) then - x2=x*x - x4=x2*x2 - fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) - fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta - else - fcont=0.0D0 - fprimcont=0.0D0 - endif - return - end -c------------------------------------------------------------------------------ - subroutine splinthet(theti,delta,ss,ssder) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - thetup=pi-delta - thetlow=delta - if (theti.gt.pipol) then - call gcont(theti,thetup,1.0d0,delta,ss,ssder) - else - call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) - ssder=-ssder - endif - return - end -c------------------------------------------------------------------------------ - subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) - implicit none - double precision x,x0,delta,f0,f1,fprim0,f,fprim - double precision ksi,ksi2,ksi3,a1,a2,a3 - a1=fprim0*delta/(f1-f0) - a2=3.0d0-2.0d0*a1 - a3=a1-2.0d0 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) - fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) - return - end -c------------------------------------------------------------------------------ - subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) - implicit none - double precision x,x0,delta,f0x,f1x,fprim0x,fx - double precision ksi,ksi2,ksi3,a1,a2,a3 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - a1=fprim0x*delta - a2=3*(f1x-f0x)-2*fprim0x*delta - a3=fprim0x*delta-2*(f1x-f0x) - fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 - return - end -C----------------------------------------------------------------------------- -#ifdef CRYST_TOR -C----------------------------------------------------------------------------- - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - etors_ii=0.0D0 - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -C Proline-Proline pair is a special case... - if (itori.eq.3 .and. itori1.eq.3) then - if (phii.gt.-dwapi3) then - cosphi=dcos(3*phii) - fac=1.0D0/(1.0D0-cosphi) - etorsi=v1(1,3,3)*fac - etorsi=etorsi+etorsi - etors=etors+etorsi-v1(1,3,3) - if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) - gloci=gloci-3*fac*etorsi*dsin(3*phii) - endif - do j=1,3 - v1ij=v1(j+1,itori,itori1) - v2ij=v2(j+1,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ - & v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - else - do j=1,nterm_old - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ - & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - endif - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - 'etor',i,etors_ii - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 - do i=1,ndih_constr - itori=idih_constr(i) - phii=phi(itori) - difi=phii-phi0(i) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - endif -! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, -! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -! write (iout,*) 'edihcnstr',edihcnstr - return - end -c------------------------------------------------------------------------------ - subroutine etor_d(etors_d) - etors_d=0.0d0 - return - end -c---------------------------------------------------------------------------- -#else - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - etors_ii=0.0D0 - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -C Regular cosine and sine terms - do j=1,nterm(itori,itori1) - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi - if (energy_dec) etors_ii=etors_ii+ - & v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo -C Lorentz terms -C v1 -C E = SUM ----------------------------------- - v1 -C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 -C - cosphi=dcos(0.5d0*phii) - sinphi=dsin(0.5d0*phii) - do j=1,nlor(itori,itori1) - vl1ij=vlor1(j,itori,itori1) - vl2ij=vlor2(j,itori,itori1) - vl3ij=vlor3(j,itori,itori1) - pom=vl2ij*cosphi+vl3ij*sinphi - pom1=1.0d0/(pom*pom+1.0d0) - etors=etors+vl1ij*pom1 - if (energy_dec) etors_ii=etors_ii+ - & vl1ij*pom1 - pom=-pom*pom1*pom1 - gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom - enddo -C Subtract the constant term - etors=etors-v0(itori,itori1) - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'etor',i,etors_ii-v0(itori,itori1) - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 -c do i=1,ndih_constr - do i=idihconstr_start,idihconstr_end - itori=idih_constr(i) - phii=phi(itori) - difi=pinorm(phii-phi0(i)) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else - difi=0.0 - endif -cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, -cd & rad2deg*phi0(i), rad2deg*drange(i), -cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -cd write (iout,*) 'edihcnstr',edihcnstr - return - end -c---------------------------------------------------------------------------- - subroutine etor_d(etors_d) -C 6/23/01 Compute double torsional energy - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors_d=0.0D0 - do i=iphid_start,iphid_end - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - itori2=itortyp(itype(i)) - phii=phi(i) - phii1=phi(i+1) - gloci1=0.0D0 - gloci2=0.0D0 -C Regular cosine and sine terms - do j=1,ntermd_1(itori,itori1,itori2) - v1cij=v1c(1,j,itori,itori1,itori2) - v1sij=v1s(1,j,itori,itori1,itori2) - v2cij=v1c(2,j,itori,itori1,itori2) - v2sij=v1s(2,j,itori,itori1,itori2) - cosphi1=dcos(j*phii) - sinphi1=dsin(j*phii) - cosphi2=dcos(j*phii1) - sinphi2=dsin(j*phii1) - etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ - & v2cij*cosphi2+v2sij*sinphi2 - gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) - gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) - enddo - do k=2,ntermd_2(itori,itori1,itori2) - do l=1,k-1 - v1cdij = v2c(k,l,itori,itori1,itori2) - v2cdij = v2c(l,k,itori,itori1,itori2) - v1sdij = v2s(k,l,itori,itori1,itori2) - v2sdij = v2s(l,k,itori,itori1,itori2) - cosphi1p2=dcos(l*phii+(k-l)*phii1) - cosphi1m2=dcos(l*phii-(k-l)*phii1) - sinphi1p2=dsin(l*phii+(k-l)*phii1) - sinphi1m2=dsin(l*phii-(k-l)*phii1) - etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ - & v1sdij*sinphi1p2+v2sdij*sinphi1m2 - gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) - gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) - enddo - enddo - gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 - gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 - enddo - return - end -#endif -c------------------------------------------------------------------------------ - subroutine eback_sc_corr(esccor) -c 7/21/2007 Correlations between the backbone-local and side-chain-local -c conformational states; temporarily implemented as differences -c between UNRES torsional potentials (dependent on three types of -c residues) and the torsional potentials dependent on all 20 types -c of residues computed from AM1 energy surfaces of terminally-blocked -c amino-acid residues. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.SCCOR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. -c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor - esccor=0.0D0 - do i=iphi_start,iphi_end - esccor_ii=0.0D0 - itori=itype(i-2) - itori1=itype(i-1) - phii=phi(i) - gloci=0.0D0 - do j=1,nterm_sccor - v1ij=v1sccor(j,itori,itori1) - v2ij=v2sccor(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - esccor=esccor+v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6) - gsccor_loc(i-3)=gsccor_loc(i-3)+gloci - enddo - return - end -c---------------------------------------------------------------------------- - subroutine multibody(ecorr) -C This subroutine calculates multi-body contributions to energy following -C the idea of Skolnick et al. If side chains I and J make a contact and -C at the same time side chains I+1 and J+1 make a contact, an extra -C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - 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 MPI - 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,maxconts,maxres,8), - & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), - & ees0m(maxconts,maxres),d_cont(maxconts,maxres), - & num_cont_hb(maxres),jcont_hb(maxconts,maxres) - num_kont=num_cont_hb(atom) - do i=1,num_kont - do k=1,8 - do j=1,3 - buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k) - enddo ! j - enddo ! k - buffer(i,indx+25)=facont_hb(i,atom) - buffer(i,indx+26)=ees0p(i,atom) - buffer(i,indx+27)=ees0m(i,atom) - buffer(i,indx+28)=d_cont(i,atom) - buffer(i,indx+29)=dfloat(jcont_hb(i,atom)) - enddo ! i - buffer(1,indx+30)=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,maxconts,maxres,8), - & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), - & ees0m(maxconts,maxres),d_cont(maxconts,maxres), - & num_cont_hb(maxres),jcont_hb(maxconts,maxres) - num_kont=buffer(1,indx+30) - 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,8 - 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+25) - ees0p(ii,atom)=buffer(i,indx+26) - ees0m(ii,atom)=buffer(i,indx+27) - d_cont(i,atom)=buffer(i,indx+28) - jcont_hb(ii,atom)=buffer(i,indx+29) - 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 'COMMON.IOUNITS' -#ifdef MPI - include "mpif.h" - parameter (max_cont=maxconts) - parameter (max_dim=2*(8*3+6)) - parameter (msglen1=max_cont*max_dim) - parameter (msglen2=2*msglen1) - integer source,CorrelType,CorrelID,Error - double precision buffer(max_cont,max_dim) - integer status(MPI_STATUS_SIZE) -#endif - include 'COMMON.SETUP' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - double precision gx(3),gx1(3),time00 - logical lprn,ldone - -C Set lprn=.true. for debugging - lprn=.false. -#ifdef MPI - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values:' - 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=fg_rank+1 - ldone=.false. - do i=1,max_cont - do j=1,max_dim - buffer(i,j)=0.0D0 - enddo - enddo - mm=mod(fg_rank,2) -c write (*,*) 'MyRank',MyRank,' mm',mm - if (mm) 20,20,10 - 10 continue -c write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone - if (fg_rank.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) -c write (*,*) 'The BUFFER array:' -c do i=1,nn -c write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30) -c enddo - if (ielstart(iatel_s).gt.iatel_s+ispp) then - msglen=msglen2 - call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer) -C Clear the contacts of the atom passed to the neighboring processor - nn=num_cont_hb(iatel_s+1) -c do i=1,nn -c write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30) -c enddo - num_cont_hb(iatel_s)=0 - endif -cd write (iout,*) 'Processor ',fg_rank,MyRank, -cd & ' is sending correlation contribution to processor',fg_rank-1, -cd & ' msglen=',msglen -c write (*,*) 'Processor ',fg_rank,MyRank, -c & ' is sending correlation contribution to processor',fg_rank-1, -c & ' msglen=',msglen,' CorrelType=',CorrelType - time00=MPI_Wtime() - call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, - & CorrelType,FG_COMM,IERROR) - time_sendrecv=time_sendrecv+MPI_Wtime()-time00 -cd write (iout,*) 'Processor ',fg_rank, -cd & ' has sent correlation contribution to processor',fg_rank-1, -cd & ' msglen=',msglen,' CorrelID=',CorrelID -c write (*,*) 'Processor ',fg_rank, -c & ' has sent correlation contribution to processor',fg_rank-1, -c & ' msglen=',msglen,' CorrelID=',CorrelID -c msglen=msglen1 - endif ! (fg_rank.gt.0) - if (ldone) goto 30 - ldone=.true. - 20 continue -c write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone - if (fg_rank.lt.nfgtasks-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',fg_rank, -cd & ' is receiving correlation contribution from processor',fg_rank+1, -cd & ' msglen=',msglen,' CorrelType=',CorrelType -c write (*,*) 'Processor',fg_rank, -c &' is receiving correlation contribution from processor',fg_rank+1, -c & ' msglen=',msglen,' CorrelType=',CorrelType - time00=MPI_Wtime() - nbytes=-1 - do while (nbytes.le.0) - call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR) - call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR) - enddo -c print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes - call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, - & fg_rank+1,CorrelType,FG_COMM,status,IERROR) - time_sendrecv=time_sendrecv+MPI_Wtime()-time00 -c write (*,*) 'Processor',fg_rank, -c &' has received correlation contribution from processor',fg_rank+1, -c & ' msglen=',msglen,' nbytes=',nbytes -c write (*,*) 'The received BUFFER array:' -c do i=1,max_cont -c write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60) -c 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,30,buffer) - else - write (iout,*) - & 'ERROR!!!! message length changed while processing correlations.' - write (*,*) - & 'ERROR!!!! message length changed while processing correlations.' - call MPI_Abort(MPI_COMM_WORLD,Error,IERROR) - endif ! msglen.eq.msglen1 - endif ! fg_rank.lt.nfgtasks-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) - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) - n_corr=n_corr+1 - else if (j1.eq.j) then -C Contacts I-J and I-(J+1) occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) - endif - enddo ! kk - do kk=1,num_conti - j1=jcont_hb(kk,i) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if (j1.eq.j+1) then -C Contacts I-J and (I+1)-J occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) - endif ! j1==j+1 - enddo ! kk - enddo ! jj - enddo ! i - return - end -c------------------------------------------------------------------------------ - subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, - & n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPI - include 'mpif.h' - parameter (max_cont=maxconts) - parameter (max_dim=2*(8*3+6)) -c parameter (msglen1=max_cont*max_dim*4) - parameter (msglen1=max_cont*max_dim/2) - parameter (msglen2=2*msglen1) - integer source,CorrelType,CorrelID,Error - double precision buffer(max_cont,max_dim) - integer status(MPI_STATUS_SIZE) -#endif - include 'COMMON.SETUP' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - double precision gx(3),gx1(3) - logical lprn,ldone -C Set lprn=.true. for debugging - lprn=.false. - eturn6=0.0d0 -#ifdef MPI - 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,30) -cd enddo - if (ielstart(iatel_s).gt.iatel_s+ispp) then - msglen=msglen2 - call pack_buffer(max_cont,max_dim,iatel_s+1,30,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+30),j=1,30) -cd enddo - num_cont_hb(iatel_s)=0 - endif -cd write (*,*) 'Processor ',fg_rank,MyRank, -cd & ' is sending correlation contribution to processor',fg_rank-1, -cd & ' msglen=',msglen -cd write (*,*) 'Processor ',MyID,MyRank, -cd & ' is sending correlation contribution to processor',fg_rank-1, -cd & ' msglen=',msglen,' CorrelType=',CorrelType - time00=MPI_Wtime() - call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, - & CorrelType,FG_COMM,IERROR) - time_sendrecv=time_sendrecv+MPI_Wtime()-time00 -cd write (*,*) 'Processor ',fg_rank,MyRank, -cd & ' has sent correlation contribution to processor',fg_rank-1, -cd & ' msglen=',msglen,' CorrelID=',CorrelID -cd write (*,*) 'Processor ',fg_rank, -cd & ' has sent correlation contribution to processor',fg_rank-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 (fg_rank.lt.nfgtasks-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',fg_rank, -cd & ' is receiving correlation contribution from processor',fg_rank+1, -cd & ' msglen=',msglen,' CorrelType=',CorrelType -cd write (*,*) 'Processor',fg_rank, -cd & ' is receiving correlation contribution from processor',fg_rank+1, -cd & ' msglen=',msglen,' CorrelType=',CorrelType - time00=MPI_Wtime() - nbytes=-1 - do while (nbytes.le.0) - call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR) - call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR) - enddo -cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes - call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, - & fg_rank+1,CorrelType,status,IERROR) - time_sendrecv=time_sendrecv+MPI_Wtime()-time00 -cd write (iout,*) 'Processor',fg_rank, -cd & ' has received correlation contribution from processor',fg_rank+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,30,buffer) - else - write (iout,*) - & 'ERROR!!!! message length changed while processing correlations.' - write (*,*) - & 'ERROR!!!! message length changed while processing correlations.' - call MPI_Abort(MPI_COMM_WORLD,Error,IERROR) - endif ! msglen.eq.msglen1 - endif ! fg_rank.lt.nfgtasks-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) -#ifdef MOMENT - call dipole(i,j,jj) -#endif - 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 (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. - 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=',j,' i1=',i1,' j1=',j1, -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 - 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 (energy_dec.and.wcorr4.gt.0.0d0) - 1 write (iout,'(a6,2i5,0pf7.3)') - 2 'ecorr4',i,j,eello4(i,j,i+1,j1,jj,kk) - if (wcorr5.gt.0.0d0) - & ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk) - if (energy_dec.and.wcorr5.gt.0.0d0) - 1 write (iout,'(a6,2i5,0pf7.3)') - 2 'ecorr5',i,j,eello5(i,j,i+1,j1,jj,kk) -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) - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - 1 'ecorr6',i,j,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) - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - 1 'eturn6',i,j,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 -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 - ehbcorr=ekont*ees - return - end -#ifdef MOMENT -C--------------------------------------------------------------------------- - subroutine dipole(i,j,jj) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), - & auxmat(2,2) - iti1 = itortyp(itype(i+1)) - if (j.lt.nres-1) then - itj1 = itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - do iii=1,2 - dipi(iii,1)=Ub2(iii,i) - dipderi(iii)=Ub2der(iii,i) - dipi(iii,2)=b1(iii,iti1) - dipj(iii,1)=Ub2(iii,j) - dipderj(iii)=Ub2der(iii,j) - dipj(iii,2)=b1(iii,itj1) - enddo - kkk=0 - do iii=1,2 - call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) - do jjj=1,2 - kkk=kkk+1 - dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - do kkk=1,5 - do lll=1,3 - mmm=0 - do iii=1,2 - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), - & auxvec(1)) - do jjj=1,2 - mmm=mmm+1 - dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - enddo - enddo - call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) - call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) - do iii=1,2 - dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) - enddo - call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) - do iii=1,2 - dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) - enddo - return - end -#endif -C--------------------------------------------------------------------------- - subroutine calc_eello(i,j,k,l,jj,kk) -C -C This subroutine computes matrices and vectors needed to calculate -C the fourth-, fifth-, and sixth-order local-electrostatic terms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), - & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) - logical lprn - common /kutas/ lprn -cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, -cd & ' jj=',jj,' kk=',kk -cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) - aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) - enddo - enddo - call transpose2(aa1(1,1),aa1t(1,1)) - call transpose2(aa2(1,1),aa2t(1,1)) - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), - & aa1tder(1,1,lll,kkk)) - call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), - & aa2tder(1,1,lll,kkk)) - enddo - enddo - if (l.eq.j+1) then -C parallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itj=itortyp(itype(j)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -C A1 kernel(j+1) A2T -cd do iii=1,2 -cd write (iout,'(3f10.5,5x,3f10.5)') -cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) -cd enddo - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), - & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - lprn=.false. - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), - & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants -cd lprn=.false. -cd if (lprn) then -cd write (2,*) 'In calc_eello6' -cd do iii=1,2 -cd write (2,*) 'iii=',iii -cd do kkk=1,5 -cd write (2,*) 'kkk=',kkk -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) -cd enddo -cd enddo -cd enddo -cd endif - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A1T kernel(i+1) A2 - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) -C Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - else -C Antiparallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif -C A2 kernel(j-1)T A1T - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. - & j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), - & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), - & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A2T kernel(i+1)T A1 - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. - & j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. - & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) -C Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - endif - return - end -C--------------------------------------------------------------------------- - subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, - & KK,KKderg,AKA,AKAderg,AKAderx) - implicit none - integer nderg - logical transp - double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), - & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), - & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) - integer iii,kkk,lll - integer jjj,mmm - logical lprn - common /kutas/ lprn - call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) - do iii=1,nderg - call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, - & AKAderg(1,1,iii)) - enddo -cd if (lprn) write (2,*) 'In kernel' - do kkk=1,5 -cd if (lprn) write (2,*) 'kkk=',kkk - do lll=1,3 - call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), - & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) -cd if (lprn) then -cd write (2,*) 'lll=',lll -cd write (2,*) 'iii=1' -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) -cd enddo -cd endif - call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), - & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) -cd if (lprn) then -cd write (2,*) 'lll=',lll -cd write (2,*) 'iii=2' -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) -cd enddo -cd endif - enddo - enddo - return - end -C--------------------------------------------------------------------------- - double precision function eello4(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then -cd eello4=0.0d0 -cd return -cd endif -cd print *,'eello4:',i,j,k,l,jj,kk -cd write (2,*) 'i',i,' j',j,' k',k,' l',l -cd call checkint4(i,j,k,l,jj,kk,eel4_num) -cold eij=facont_hb(jj,i) -cold ekl=facont_hb(kk,k) -cold ekont=eij*ekl - eel4=-EAEA(1,1,1)-EAEA(2,2,1) -cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) - gcorr_loc(k-1)=gcorr_loc(k-1) - & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) - if (l.eq.j+1) then - gcorr_loc(l-1)=gcorr_loc(l-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - else - gcorr_loc(j-1)=gcorr_loc(j-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) - & -EAEAderx(2,2,lll,kkk,iii,1) -cd derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd gcorr_loc(l-1)=0.0d0 -cd gcorr_loc(j-1)=0.0d0 -cd gcorr_loc(k-1)=0.0d0 -cd eel4=1.0d0 -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l, -cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -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 - eello4=ekont*eel4 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello4',ekont*eel4 - return - end -C--------------------------------------------------------------------------- - double precision function eello5(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) - double precision ggg1(3),ggg2(3) -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel chains C -C C -C o o o o C -C /l\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j| o |l1 | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C Antiparallel chains C -C C -C o o o o C -C /j\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j1| o |l | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C o denotes a local interaction, vertical lines an electrostatic interaction. C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then -cd eello5=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - itk=itortyp(itype(k)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - eello5_1=0.0d0 - eello5_2=0.0d0 - eello5_3=0.0d0 - eello5_4=0.0d0 -cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, -cd & eel5_3_num,eel5_4_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l -cd goto 1111 -C Contribution from the graph I. -cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) -cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) -C Explicit gradient in virtual-dihedral angles. - if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - if (l.eq.j+1) then - if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - else - if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) - enddo - enddo - enddo -c goto 1112 -c1111 continue -C Contribution from graph II - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - if (l.eq.j+1) then - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - else - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) - enddo - enddo - enddo -cd goto 1112 -cd1111 continue - if (l.eq.j+1) then -cd goto 1110 -C Parallel orientation -C Contribution from graph III - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) - call transpose2(EUgder(1,1,l),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) - enddo - enddo - enddo -cd goto 1112 -C Contribution from graph IV -cd1110 continue - call transpose2(EE(1,1,itl),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) - enddo - enddo - enddo - else -C Antiparallel orientation -C Contribution from graph III -c goto 1110 - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) - call transpose2(EUgder(1,1,j),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) - enddo - enddo - enddo -cd goto 1112 -C Contribution from graph IV -1110 continue - call transpose2(EE(1,1,itj),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) - enddo - enddo - enddo - endif -1112 continue - eel5=eello5_1+eello5_2+eello5_3+eello5_4 -cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then -cd write (2,*) 'ijkl',i,j,k,l -cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, -cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 -cd endif -cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num -cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num -cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num -cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 -cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont - 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 - eello5=ekont*eel5 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello5',ekont*eel5 - return - end -c-------------------------------------------------------------------------- - double precision function eello6(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - eello6_1=0.0d0 - eello6_2=0.0d0 - eello6_3=0.0d0 - eello6_4=0.0d0 - eello6_5=0.0d0 - eello6_6=0.0d0 -cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, -cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - if (l.eq.j+1) then - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(j,i,l,k,2,.false.) - eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) - eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) - else - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(l,k,j,i,2,.true.) - eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - if (wturn6.eq.0.0d0 .or. j.ne.i+4) then - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) - else - eello6_5=0.0d0 - endif - eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) - endif -C If turn contributions are considered, they will be handled separately. - eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 -cd write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num -cd write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num -cd write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num -cd write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num -cd write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num -cd write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num -cd goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 - 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 - eello6=ekont*eel6 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello6',ekont*eel6 - return - end -c-------------------------------------------------------------------------- - double precision function eello6_graph1(i,j,k,l,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) - logical swap - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C Parallel Antiparallel -C -C o o -C /l\ /j\ -C / \ / \ -C /| o | | o |\ -C \ j|/k\| / \ |/k\|l / -C \ / \ / \ / \ / -C o o o o -C i i -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - itk=itortyp(itype(k)) - s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) - vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 - eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) - if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) - & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) - & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) - & +scalar2(vv(1),Dtobr2der(1,i))) - call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) - vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) - if (l.eq.j+1) then - g_corr6_loc(l-1)=g_corr6_loc(l-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - endif - call transpose2(EUgCder(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) - & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) - & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) - do iii=1,2 - if (swap) then - ind=3-iii - else - ind=iii - endif - do kkk=1,5 - do lll=1,3 - s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) - & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) - vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) - & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) - derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph2(i,j,k,l,jj,kk,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - logical swap - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxvec2(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 -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 -C Derivatives in gamma(k-1) - call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) -C Derivatives in gamma(l-1) - call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) -C Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) - else - s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif -c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxmat1(2,2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 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 -C Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - if (imat.eq.1) then - s1=dipderg(2,jj,i)*dip(3,kk,k) - else - s1=dipderg(4,jj,j)*dip(2,kk,l) - endif -#endif - s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -cd write (2,*) 'turn6 derivatives' -#ifdef MOMENT - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif - endif - endif -C Derivatives in gamma(k-1) -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderg(2,kk,k) - else - s1=dip(2,jj,j)*dipderg(4,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif - endif -C Derivatives in gamma(j-1) or gamma(l-1) - if (l.eq.j+1 .and. l.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) - else if (j.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then - gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) - endif - endif -C Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - if (imat.eq.1) then - s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) - else - s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) - endif - else - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) - else - s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) - endif - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), - & auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itj1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) - else - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itl1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) - endif - call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (swap) then - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s1+s2+s4) -#else - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s2+s4) -#endif - derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 - else -#ifdef MOMENT - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) -#else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) -#endif - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - else -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (l.eq.j+1) then - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - endif - endif - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello_turn6(i,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), - & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), - & ggg1(3),ggg2(3) - double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), - & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) -C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to -C the respective energy moment and not to the cluster cumulant. - s1=0.0d0 - s8=0.0d0 - s13=0.0d0 -c - eello_turn6=0.0d0 - j=i+4 - k=i+1 - l=i+3 - iti=itortyp(itype(i)) - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) -cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj -cd write (2,*) 'i',i,' k',k,' j',j,' l',l -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l -cd call checkint_turn6(i,jj,kk,eel_turn6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx_turn(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) -cd eello6_5=0.0d0 -cd write (2,*) 'eello6_5',eello6_5 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) - ss1=scalar2(Ub2(1,i+2),b1(1,itl)) - s1 = (auxmat(1,1)+auxmat(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) - s2 = scalar2(b1(1,itk),vtemp1(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atemp(1,1)) - call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) - call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) - s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) - s12 = scalar2(Ub2(1,i+2),vtemp3(1)) -#ifdef MOMENT - call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) - call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) - call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) - ss13 = scalar2(b1(1,itk),vtemp4(1)) - s13 = (gtemp(1,1)+gtemp(2,2))*ss13 -#endif -c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 -c s1=0.0d0 -c s2=0.0d0 -c s8=0.0d0 -c s12=0.0d0 -c s13=0.0d0 - eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) -C Derivatives in gamma(i+2) - s1d =0.0d0 - s8d =0.0d0 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 - call transpose2(AEAderg(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 - gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) -C Derivatives in gamma(i+3) -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d -#endif - call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) - s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) -#endif - s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) - & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) - & -0.5d0*ekont*(s2d+s12d) -#endif -C Derivatives in gamma(i+4) - call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -C s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) -#else - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) -#endif -C Derivatives in gamma(i+5) -#ifdef MOMENT - call transpose2(AEAderg(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) - & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) - & -0.5d0*ekont*(s2d+s12d) -#endif -C Cartesian derivatives - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), - & vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))* - & scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), - & auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) - & - 0.5d0*(s1d+s2d) -#else - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) - & - 0.5d0*s2d -#endif -#ifdef MOMENT - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) - & - 0.5d0*(s8d+s12d) -#else - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) - & - 0.5d0*s12d -#endif - enddo - enddo - enddo -#ifdef MOMENT - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), - & achuj_tempd(1,1)) - call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d=(gtempd(1,1)+gtempd(2,2))*ss13 - derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), - & vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d - derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d - enddo - enddo -#endif -cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', -cd & 16*eel_turn6_num -cd goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 - 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 - eello_turn6=ekont*eel_turn6 -cd write (2,*) 'ekont',ekont -cd write (2,*) 'eel_turn6',ekont*eel_turn6 - return - end - -C----------------------------------------------------------------------------- - double precision function scalar(u,v) -!DIR$ INLINEALWAYS scalar -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::scalar -#endif - implicit none - double precision u(3),v(3) -cd double precision sc -cd integer i -cd sc=0.0d0 -cd do i=1,3 -cd sc=sc+u(i)*v(i) -cd enddo -cd scalar=sc - - scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3) - return - end -crc------------------------------------------------- - SUBROUTINE MATVEC2(A1,V1,V2) -!DIR$ INLINEALWAYS MATVEC2 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2 -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),V1(2),V2(2) -c DO 1 I=1,2 -c VI=0.0 -c DO 3 K=1,2 -c 3 VI=VI+A1(I,K)*V1(K) -c Vaux(I)=VI -c 1 CONTINUE - - vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) - vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) - - v2(1)=vaux1 - v2(2)=vaux2 - END -C--------------------------------------- - SUBROUTINE MATMAT2(A1,A2,A3) -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2 -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),A2(2,2),A3(2,2) -c DIMENSION AI3(2,2) -c DO J=1,2 -c A3IJ=0.0 -c DO K=1,2 -c A3IJ=A3IJ+A1(I,K)*A2(K,J) -c enddo -c A3(I,J)=A3IJ -c enddo -c enddo - - ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) - ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) - ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) - ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) - - A3(1,1)=AI3_11 - A3(2,1)=AI3_21 - A3(1,2)=AI3_12 - A3(2,2)=AI3_22 - END - -c------------------------------------------------------------------------- - double precision function scalar2(u,v) -!DIR$ INLINEALWAYS scalar2 - implicit none - double precision u(2),v(2) - double precision sc - integer i - scalar2=u(1)*v(1)+u(2)*v(2) - return - end - -C----------------------------------------------------------------------------- - - subroutine transpose2(a,at) -!DIR$ INLINEALWAYS transpose2 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::transpose2 -#endif - implicit none - double precision a(2,2),at(2,2) - at(1,1)=a(1,1) - at(1,2)=a(2,1) - at(2,1)=a(1,2) - at(2,2)=a(2,2) - return - end -c-------------------------------------------------------------------------- - subroutine transpose(n,a,at) - implicit none - integer n,i,j - double precision a(n,n),at(n,n) - do i=1,n - do j=1,n - at(j,i)=a(i,j) - enddo - enddo - return - end -C--------------------------------------------------------------------------- - subroutine prodmat3(a1,a2,kk,transp,prod) -!DIR$ INLINEALWAYS prodmat3 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::prodmat3 -#endif - implicit none - integer i,j - double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) - logical transp -crc double precision auxmat(2,2),prod_(2,2) - - if (transp) then -crc call transpose2(kk(1,1),auxmat(1,1)) -crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) - - else -crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) - - endif -c call transpose2(a2(1,1),a2t(1,1)) - -crc print *,transp -crc print *,((prod_(i,j),i=1,2),j=1,2) -crc print *,((prod(i,j),i=1,2),j=1,2) - - return - end - diff --git a/source/unres/src_MD-M-newcorr/energy_p_new_barrier.F b/source/unres/src_MD-M-newcorr/energy_p_new_barrier.F deleted file mode 100644 index 5e90c17..0000000 --- a/source/unres/src_MD-M-newcorr/energy_p_new_barrier.F +++ /dev/null @@ -1,9268 +0,0 @@ - subroutine etotal(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.LOCAL' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' -#ifdef MPI -c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, -c & " nfgtasks",nfgtasks - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR) -c print *,"Processor",myrank," BROADCAST iorder" -C FG master sets up the WEIGHTS_ array which will be broadcast to the -C FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -C FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -C FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - endif - time_Bcast=time_Bcast+MPI_Wtime()-time00 - time_Bcastw=time_Bcastw+MPI_Wtime()-time00 -c call chainbuild_cart - endif -c print *,'Processor',myrank,' calling etotal ipot=',ipot -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#else -c if (modecalc.eq.12.or.modecalc.eq.14) then -c call int_from_cart1(.false.) -c endif -#endif -#ifdef TIMING - time00=MPI_Wtime() -#endif -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105,106) ipot -C Lennard-Jones potential. - 101 call elj(evdw) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk(evdw) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp(evdw) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb(evdw) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv(evdw) - goto 107 -C Soft-sphere potential - 106 call e_softsphere(evdw) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 continue -cmc -cmc Sep-06: egb takes care of dynamic ss bonds too -cmc -C if (dyn_ss) call dyn_set_nss -c print *,"Processor",myrank," computed USCSC" -#ifdef TIMING - time01=MPI_Wtime() -#endif - call vec_and_deriv -#ifdef TIMING - time_vec=time_vec+MPI_Wtime()-time01 -#endif -c print *,"Processor",myrank," left VEC_AND_DERIV" - if (ipot.lt.6) then -#ifdef SPLITELE - if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#else - if (welec.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#endif - call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) - else - ees=0.0d0 - evdw1=0.0d0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 - endif - else -c write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, - & eello_turn4) - endif -c print *,"Processor",myrank," computed UELEC" -C -C Calculate excluded-volume interaction energy between peptide groups -C and side chains. -C - if (ipot.lt.6) then - if(wscp.gt.0d0) then - call escp(evdw2,evdw2_14) - else - evdw2=0 - evdw2_14=0 - endif - else -c write (iout,*) "Soft-sphere SCP potential" - call escp_soft_sphere(evdw2,evdw2_14) - endif -c -c Calculate the bond-stretching energy -c - call ebond(estr) -C -C Calculate the disulfide-bridge and other energy and the contributions -C from other distance constraints. -cd print *,'Calling EHPB' - call edis(ehpb) -cd print *,'EHPB exitted succesfully.' -C -C Calculate the virtual-bond-angle energy. -C - if (wang.gt.0d0) then - call ebend(ebe) - else - ebe=0 - endif -c print *,"Processor",myrank," computed UB" -C -C Calculate the SC local energy. -C - call esc(escloc) -c print *,"Processor",myrank," computed USC" -C -C Calculate the virtual-bond torsional energy. -C -cd print *,'nterm=',nterm - if (wtor.gt.0) then - call etor(etors,edihcnstr) - else - etors=0 - edihcnstr=0 - endif -c print *,"Processor",myrank," computed Utor" -C -C 6/23/01 Calculate double-torsional energy -C - if (wtor_d.gt.0) then - call etor_d(etors_d) - else - etors_d=0 - endif -c print *,"Processor",myrank," computed Utord" -C -C 21/5/07 Calculate local sicdechain correlation energy -C - if (wsccor.gt.0.0d0) then - call eback_sc_corr(esccor) - else - esccor=0.0d0 - endif -c print *,"Processor",myrank," computed Usccorr" -C -C 12/1/95 Multi-body terms -C - n_corr=0 - n_corr1=0 - if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 - & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then - call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1, -cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -cd write (iout,*) "multibody_hb ecorr",ecorr - endif -c print *,"Processor",myrank," computed Ucorr" -C -C If performing constraint dynamics, call the constraint energy -C after the equilibration time - if(usampl.and.totT.gt.eq_time) then - call EconstrQ - call Econstr_back - else - Uconst=0.0d0 - Uconst_back=0.0d0 - endif -#ifdef TIMING - time_enecalc=time_enecalc+MPI_Wtime()-time00 -#endif -c print *,"Processor",myrank," computed Uconstr" -#ifdef TIMING - time00=MPI_Wtime() -#endif -c -C Sum the energies -C - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(19)=edihcnstr - energia(17)=estr - energia(20)=Uconst+Uconst_back - energia(21)=esccor -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 -c print *," Processor",myrank," calls SUM_ENERGY" - call sum_energy(energia,.true.) - if (dyn_ss) call dyn_set_nss -c print *," Processor",myrank," left SUM_ENERGY" -#ifdef TIMING - time_sumene=time_sumene+MPI_Wtime()-time00 -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sum_energy(energia,reduce) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene),enebuff(0:n_ene+1) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - logical reduce -#ifdef MPI - if (nfgtasks.gt.1 .and. reduce) then -#ifdef DEBUG - write (iout,*) "energies before REDUCE" - call enerprint(energia) - call flush(iout) -#endif - do i=0,n_ene - enebuff(i)=energia(i) - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_e=time_barrier_e+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(enebuff(0),energia(0),n_ene+1, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) -#ifdef DEBUG - write (iout,*) "energies after REDUCE" - call enerprint(energia) - call flush(iout) -#endif - time_Reduce=time_Reduce+MPI_Wtime()-time00 - endif - if (fg_rank.eq.0) then -#endif - evdw=energia(1) -#ifdef SCP14 - evdw2=energia(2)+energia(18) - evdw2_14=energia(18) -#else - evdw2=energia(2) -#endif -#ifdef SPLITELE - ees=energia(3) - evdw1=energia(16) -#else - ees=energia(3) - evdw1=0.0d0 -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eturn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor -#else - etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor -#endif - energia(0)=etot -c detecting NaNQ -#ifdef ISNAN -#ifdef AIX - if (isnan(etot).ne.0) energia(0)=1.0d+99 -#else - if (isnan(etot)) energia(0)=1.0d+99 -#endif -#else - i=0 -#ifdef WINPGI - idumm=proc_proc(etot,i) -#else - call proc_proc(etot,i) -#endif - if(i.eq.1)energia(0)=1.0d+99 -#endif -#ifdef MPI - endif -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sum_gradient - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include 'mpif.h' - double precision gradbufc(3,maxres),gradbufx(3,maxres), - & glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - include 'COMMON.MAXGRAD' - include 'COMMON.SCCOR' -#ifdef TIMING - time01=MPI_Wtime() -#endif -#ifdef DEBUG - write (iout,*) "sum_gradient gvdwc, gvdwx" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef MPI -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (nfgtasks.gt.1 .and. fg_rank.eq.0) - & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif -C -C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient -C in virtual-bond-vector coordinates -C -#ifdef DEBUG -c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" -c do i=1,nres-1 -c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') -c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) -c enddo -c write (iout,*) "gel_loc_tur3 gel_loc_turn4" -c do i=1,nres-1 -c write (iout,'(i5,3f10.5,2x,f10.5)') -c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) -c enddo - write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3), - & g_corr5_loc(i) - enddo - call flush(iout) -#endif -#ifdef SPLITELE - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i) - enddo - enddo -#else - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+ - & wbond*gradb(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i) - enddo - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -#ifdef DEBUG - write (iout,*) "gradbufc before allreduce" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - do i=1,nres - do j=1,3 - gradbufc_sum(j,i)=gradbufc(j,i) - enddo - enddo -c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, -c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) -c time_reduce=time_reduce+MPI_Wtime()-time00 -#ifdef DEBUG -c write (iout,*) "gradbufc_sum after allreduce" -c do i=1,nres -c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) -c enddo -c call flush(iout) -#endif -#ifdef TIMING -c time_allreduce=time_allreduce+MPI_Wtime()-time00 -#endif - do i=nnt,nres - do k=1,3 - gradbufc(k,i)=0.0d0 - enddo - enddo -#ifdef DEBUG - write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end - write (iout,*) (i," jgrad_start",jgrad_start(i), - & " jgrad_end ",jgrad_end(i), - & i=igrad_start,igrad_end) -#endif -c -c Obsolete and inefficient code; we can make the effort O(n) and, therefore, -c do not parallelize this part. -c -c do i=igrad_start,igrad_end -c do j=jgrad_start(i),jgrad_end(i) -c do k=1,3 -c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) -c enddo -c enddo -c enddo - do j=1,3 - gradbufc(j,nres-1)=gradbufc_sum(j,nres) - enddo - do i=nres-2,nnt,-1 - do j=1,3 - gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) - enddo - enddo -#ifdef DEBUG - write (iout,*) "gradbufc after summing" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - else -#endif -#ifdef DEBUG - write (iout,*) "gradbufc" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - do i=1,nres - do j=1,3 - gradbufc_sum(j,i)=gradbufc(j,i) - gradbufc(j,i)=0.0d0 - enddo - enddo - do j=1,3 - gradbufc(j,nres-1)=gradbufc_sum(j,nres) - enddo - do i=nres-2,nnt,-1 - do j=1,3 - gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) - enddo - enddo -c do i=nnt,nres-1 -c do k=1,3 -c gradbufc(k,i)=0.0d0 -c enddo -c do j=i+1,nres -c do k=1,3 -c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) -c enddo -c enddo -c enddo -#ifdef DEBUG - write (iout,*) "gradbufc after summing" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef MPI - endif -#endif - do k=1,3 - gradbufc(k,nres)=0.0d0 - enddo - do i=1,nct - do j=1,3 -#ifdef SPLITELE - gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ - & wel_loc*gel_loc(j,i)+ - & 0.5d0*(wscp*gvdwc_scpp(j,i)+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i))+ - & wbond*gradb(j,i)+ - & wcorr*gradcorr(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) -#else - gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ - & wel_loc*gel_loc(j,i)+ - & 0.5d0*(wscp*gvdwc_scpp(j,i)+ - & welec*gelc_long(j,i) - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i))+ - & wbond*gradb(j,i)+ - & wcorr*gradcorr(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) -#endif - gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*gsccorx(j,i) - & +wscloc*gsclocx(j,i) - enddo - enddo -#ifdef DEBUG - write (iout,*) "gloc before adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) - & +wcorr5*g_corr5_loc(i) - & +wcorr6*g_corr6_loc(i) - & +wturn4*gel_loc_turn4(i) - & +wturn3*gel_loc_turn3(i) - & +wturn6*gel_loc_turn6(i) - & +wel_loc*gel_loc_loc(i) - enddo -#ifdef DEBUG - write (iout,*) "gloc after adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - do j=1,3 - do i=1,nres - gradbufc(j,i)=gradc(j,i,icg) - gradbufx(j,i)=gradx(j,i,icg) - enddo - enddo - do i=1,4*nres - glocbuf(i)=gloc(i,icg) - enddo -#define DEBUG -#ifdef DEBUG - write (iout,*) "gloc_sc before reduce" - do i=1,nres - do j=1,1 - write (iout,*) i,j,gloc_sc(j,i,icg) - enddo - enddo -#endif -#undef DEBUG - do i=1,nres - do j=1,3 - gloc_scbuf(j,i)=gloc_sc(j,i,icg) - enddo - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_g=time_barrier_g+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 - call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -#define DEBUG -#ifdef DEBUG - write (iout,*) "gloc_sc after reduce" - do i=1,nres - do j=1,1 - write (iout,*) i,j,gloc_sc(j,i,icg) - enddo - enddo -#endif -#undef DEBUG -#ifdef DEBUG - write (iout,*) "gloc after reduce" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - endif -#endif - if (gnorm_check) then -c -c Compute the maximum elements of the gradient -c - gvdwc_max=0.0d0 - gvdwc_scp_max=0.0d0 - gelc_max=0.0d0 - gvdwpp_max=0.0d0 - gradb_max=0.0d0 - ghpbc_max=0.0d0 - gradcorr_max=0.0d0 - gel_loc_max=0.0d0 - gcorr3_turn_max=0.0d0 - gcorr4_turn_max=0.0d0 - gradcorr5_max=0.0d0 - gradcorr6_max=0.0d0 - gcorr6_turn_max=0.0d0 - gsccorc_max=0.0d0 - gscloc_max=0.0d0 - gvdwx_max=0.0d0 - gradx_scp_max=0.0d0 - ghpbx_max=0.0d0 - gradxorr_max=0.0d0 - gsccorx_max=0.0d0 - gsclocx_max=0.0d0 - do i=1,nct - gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) - if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm - gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i))) - if (gvdwc_scp_norm.gt.gvdwc_scp_max) - & gvdwc_scp_max=gvdwc_scp_norm - gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i))) - if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm - gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i))) - if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm - gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i))) - if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm - ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i))) - if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm - gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i))) - if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm - gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i))) - if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm - gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i), - & gcorr3_turn(1,i))) - if (gcorr3_turn_norm.gt.gcorr3_turn_max) - & gcorr3_turn_max=gcorr3_turn_norm - gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i), - & gcorr4_turn(1,i))) - if (gcorr4_turn_norm.gt.gcorr4_turn_max) - & gcorr4_turn_max=gcorr4_turn_norm - gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i))) - if (gradcorr5_norm.gt.gradcorr5_max) - & gradcorr5_max=gradcorr5_norm - gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i))) - if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm - gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i), - & gcorr6_turn(1,i))) - if (gcorr6_turn_norm.gt.gcorr6_turn_max) - & gcorr6_turn_max=gcorr6_turn_norm - gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) - if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm - gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) - if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm - gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) - if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm - gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i))) - if (gradx_scp_norm.gt.gradx_scp_max) - & gradx_scp_max=gradx_scp_norm - ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i))) - if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm - gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i))) - if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm - gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i))) - if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm - gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i))) - if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm - enddo - if (gradout) then -#ifdef AIX - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif - write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max, - & gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max - close(istat) - if (gvdwc_max.gt.1.0d4) then - write (iout,*) "gvdwc gvdwx gradb gradbx" - do i=nnt,nct - write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i), - & gradb(j,i),gradbx(j,i),j=1,3) - enddo - call pdbout(0.0d0,'cipiszcze',iout) - call flush(iout) - endif - endif - endif -#ifdef DEBUG - write (iout,*) "gradc gradx gloc" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) - enddo -#endif -#ifdef TIMING - time_sumgradient=time_sumgradient+MPI_Wtime()-time01 -#endif - return - end -c------------------------------------------------------------------------------- - subroutine rescale_weights(t_bath) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - double precision kfac /2.4d0/ - double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/ -c facT=temp0/t_bath -c facT=2*temp0/(t_bath+temp0) - if (rescale_mode.eq.0) then - facT=1.0d0 - facT2=1.0d0 - facT3=1.0d0 - facT4=1.0d0 - facT5=1.0d0 - else if (rescale_mode.eq.1) then - facT=kfac/(kfac-1.0d0+t_bath/temp0) - facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) - facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) - facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) - facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) - else if (rescale_mode.eq.2) then - x=t_bath/temp0 - x2=x*x - x3=x2*x - x4=x3*x - x5=x4*x - facT=licznik/dlog(dexp(x)+dexp(-x)) - facT2=licznik/dlog(dexp(x2)+dexp(-x2)) - facT3=licznik/dlog(dexp(x3)+dexp(-x3)) - facT4=licznik/dlog(dexp(x4)+dexp(-x4)) - facT5=licznik/dlog(dexp(x5)+dexp(-x5)) - else - write (iout,*) "Wrong RESCALE_MODE",rescale_mode - write (*,*) "Wrong RESCALE_MODE",rescale_mode -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) -#endif - stop 555 - endif - welec=weights(3)*fact - wcorr=weights(4)*fact3 - wcorr5=weights(5)*fact4 - wcorr6=weights(6)*fact5 - wel_loc=weights(7)*fact2 - wturn3=weights(8)*fact2 - wturn4=weights(9)*fact3 - wturn6=weights(10)*fact5 - wtor=weights(13)*fact - wtor_d=weights(14)*fact2 - wsccor=weights(21)*fact - - return - end -C------------------------------------------------------------------------ - subroutine enerprint(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.MD' - double precision energia(0:n_ene) - etot=energia(0) - evdw=energia(1) - evdw2=energia(2) -#ifdef SCP14 - evdw2=energia(2)+energia(18) -#else - evdw2=energia(2) -#endif - ees=energia(3) -#ifdef SPLITELE - evdw1=energia(16) -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eello_turn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor, - & edihcnstr,ebr*nss, - & Uconst,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST= ',1pE16.6,' (Constraint energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#else - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr, - & ebr*nss,Uconst,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST=',1pE16.6,' (Constraint energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#endif - return - end -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' - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=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(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+evdwij -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) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - 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 -C -C 12/1/95, revised on 5/20/97 -C -C Calculate the contact function. The ith column of the array JCONT will -C contain the numbers of atoms that make contacts with the atom I (of numbers -C greater than I). The arrays FACONT and GACONT will contain the values of -C the contact function and its derivative. -C -C Uncomment next line, if the correlation interactions include EVDW explicitly. -c if (j.gt.i+1 .and. evdwij.le.0.0D0) then -C Uncomment next line, if the correlation interactions are contact function only - if (j.gt.i+1.and. eps0ij.gt.0.0D0) then - rij=dsqrt(rij) - sigij=sigma(itypi,itypj) - r0ij=rs0(itypi,itypj) -C -C Check whether the SC's are not too far to make a contact. -C - rcut=1.5d0*r0ij - call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) -C Add a new contact, if the SC's are close enough, but not too close (ri' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - return - end -C----------------------------------------------------------------------------- - subroutine escp(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=iabs(itype(j)) - if (itypj.eq.ntyp1) cycle -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+e1+e2 - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij - if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') - & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli), - & bad(itypj,iteli) -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -cgrad if (j.lt.i) then -cd write (iout,*) 'ji' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time the factor EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C-------------------------------------------------------------------------- - subroutine edis(ehpb) -C -C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - dimension ggg(3) - ehpb=0.0D0 -cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr -cd write(iout,*)'link_start=',link_start,' link_end=',link_end - if (link_end.eq.0) return - do i=link_start,link_end -C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a -C CA-CA distance used in regularization of structure. - ii=ihpb(i) - jj=jhpb(i) -C iii and jjj point to the residues for which the distance is assigned. - if (ii.gt.nres) then - iii=ii-nres - jjj=jj-nres - else - iii=ii - jjj=jj - endif -cd write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj -C 24/11/03 AL: SS bridges handled separately because of introducing a specific -C distance and angle dependent SS bond potential. -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 -c if (.not.dyn_ss .and. i.le.nss) then -C 15/02/13 CC dynamic SSbond -C if (.not.dyn_ss.and. -C & ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then - - if (.not.dyn_ss .and. i.le.nss) then -C 15/02/13 CC dynamic SSbond - additional check - if (ii.gt.nres - & .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then - call ssbond_ene(iii,jjj,eij) - ehpb=ehpb+2*eij - endif -cd write (iout,*) "eij",eij - else -C Calculate the distance between the two points and its difference from the -C target distance. - dd=dist(ii,jj) - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd -cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, -cd & ' waga=',waga,' fac=',fac - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo -cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) -C If this is a SC-SC distance, we need to calculate the contributions to the -C Cartesian gradient in the SC vectors (ghpbx). - if (iii.lt.ii) then - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - endif -cgrad do j=iii,jjj-1 -cgrad do k=1,3 -cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k) -cgrad enddo -cgrad enddo - do k=1,3 - ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) - ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) - enddo - endif - enddo - ehpb=0.5D0*ehpb - return - end -C-------------------------------------------------------------------------- - subroutine ssbond_ene(i,j,eij) -C -C Calculate the distance and angle dependent SS-bond potential energy -C using a free-energy function derived based on RHF/6-31G** ab initio -C calculations of diethyl disulfide. -C -C A. Liwo and U. Kozlowska, 11/24/03 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - double precision erij(3),dcosom1(3),dcosom2(3),gg(3) - itypi=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) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(nres+i) - itypj=iabs(itype(j)) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(nres+j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - erij(1)=xj*rij - erij(2)=yj*rij - erij(3)=zj*rij - om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) - om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) - om12=dxi*dxj+dyi*dyj+dzi*dzj - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - rij=1.0d0/rij - deltad=rij-d0cm - deltat1=1.0d0-om1 - deltat2=1.0d0+om2 - deltat12=om2-om1+2.0d0 - cosphi=om12-om1*om2 - eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) - & +akct*deltad*deltat12 - & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr -c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, -c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, -c & " deltat12",deltat12," eij",eij - ed=2*akcm*deltad+akct*deltat12 - pom1=akct*deltad - pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi - eom1=-2*akth*deltat1-pom1-om2*pom2 - eom2= 2*akth*deltat2+pom1-om1*pom2 - eom12=pom2 - do k=1,3 - ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) - ghpbx(k,i)=ghpbx(k,i)-ggk - & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv - ghpbx(k,j)=ghpbx(k,j)+ggk - & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - ghpbc(k,i)=ghpbc(k,i)-ggk - ghpbc(k,j)=ghpbc(k,j)+ggk - enddo -C -C Calculate the components of the gradient in DC and X -C -cgrad do k=i,j-1 -cgrad do l=1,3 -cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l) -cgrad enddo -cgrad enddo - return - end -C-------------------------------------------------------------------------- - subroutine ebond(estr) -c -c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - double precision u(3),ud(3) - estr=0.0d0 - estr1=0.0d0 - do i=ibondp_start,ibondp_end - if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then - estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) - do j=1,3 - gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) - & *dc(j,i-1)/vbld(i) - enddo - if (energy_dec) write(iout,*) - & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax) - else - diff = vbld(i)-vbldp0 - if (energy_dec) write (iout,*) - & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff - estr=estr+diff*diff - do j=1,3 - gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) - enddo -c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) - endif - 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=ibond_start,ibond_end - iti=iabs(itype(i)) - if (iti.ne.10 .and. iti.ne.ntyp1) then - nbi=nbondterm(iti) - if (nbi.eq.1) then - diff=vbld(i+nres)-vbldsc0(1,iti) - if (energy_dec) write (iout,*) - & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff, - & AKSC(1,iti),AKSC(1,iti)*diff*diff - estr=estr+0.5d0*AKSC(1,iti)*diff*diff - do j=1,3 - gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) - enddo - else - do j=1,nbi - diff=vbld(i+nres)-vbldsc0(j,iti) - ud(j)=aksc(j,iti)*diff - u(j)=abond0(j,iti)+0.5d0*ud(j)*diff - enddo - uprod=u(1) - do j=2,nbi - uprod=uprod*u(j) - enddo - usum=0.0d0 - usumsqder=0.0d0 - do j=1,nbi - uprod1=1.0d0 - uprod2=1.0d0 - do k=1,nbi - if (k.ne.j) then - uprod1=uprod1*u(k) - uprod2=uprod2*u(k)*u(k) - endif - enddo - usum=usum+uprod1 - usumsqder=usumsqder+ud(j)*uprod2 - enddo - estr=estr+uprod/usum - do j=1,3 - gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) - enddo - endif - endif - enddo - return - end -#ifdef CRYST_THETA -C-------------------------------------------------------------------------- - subroutine ebend(etheta) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - double precision y(2),z(2) - delta=0.02d0*pi -c time11=dexp(-2*time) -c time12=1.0d0 - etheta=0.0D0 -c write (*,'(a,i2)') 'EBEND ICG=',icg - do i=ithet_start,ithet_end - if (itype(i-1).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.gt.3 .and. itype(i-2).ne.ntyp1) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - y(1)=dcos(phii) - y(2)=dsin(phii) - else - y(1)=0.0D0 - y(2)=0.0D0 - endif - if (i.lt.nres .and. itype(i).ne.ntyp1) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) - z(1)=cos(phii1) -#else - phii1=phi(i+1) - z(1)=dcos(phii1) -#endif - z(2)=dsin(phii1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif -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 - dthett=thet_pred_mean*ssd - thet_pred_mean=thet_pred_mean*ss+a0thet(it) -C Derivatives of the "mean" values in gamma1 and gamma2. - dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) - &+athet(2,it,ichir1,ichir2)*y(1))*ss - dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) - & +bthet(2,it,ichir1,ichir2)*z(1))*ss - if (it.eq.10) then - dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) - &+athet(2,itype1,ichir11,ichir12)*y(1))*ss - dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) - & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss - endif - if (theta(i).gt.pi-delta) then - call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, - & E_tc0) - call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) - call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, - & E_theta) - call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else if (theta(i).lt.delta) then - call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) - call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, - & E_theta) - call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) - call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else - call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, - & E_theta,E_tc) - endif - etheta=etheta+ethetai - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'ebend',i,ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 - gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg) - enddo -C Ufff.... We've done all this!!! - return - end -C--------------------------------------------------------------------------- - subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, - & E_tc) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it -C Calculate the contributions to both Gaussian lobes. -C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) -C The "polynomial part" of the "standard deviation" of this part of -C the distribution. - sig=polthet(3,it) - do j=2,0,-1 - sig=sig*thet_pred_mean+polthet(j,it) - enddo -C Derivative of the "interior part" of the "standard deviation of the" -C gamma-dependent Gaussian lobe in t_c. - sigtc=3*polthet(3,it) - do j=2,1,-1 - sigtc=sigtc*thet_pred_mean+j*polthet(j,it) - enddo - sigtc=sig*sigtc -C Set the parameters of both Gaussian lobes of the distribution. -C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) - fac=sig*sig+sigc0(it) - sigcsq=fac+fac - sigc=1.0D0/sigcsq -C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c - sigsqtc=-4.0D0*sigcsq*sigtc -c print *,i,sig,sigtc,sigsqtc -C Following variable (sigtc) is d[sigma(t_c)]/dt_c - sigtc=-sigtc/(fac*fac) -C Following variable is sigma(t_c)**(-2) - sigcsq=sigcsq*sigcsq - sig0i=sig0(it) - sig0inv=1.0D0/sig0i**2 - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i - term1=-0.5D0*sigcsq*delthec*delthec - term2=-0.5D0*sig0inv*delthe0*delthe0 -C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and -C NaNs in taking the logarithm. We extract the largest exponent which is added -C to the energy (this being the log of the distribution) at the end of energy -C term evaluation for this virtual-bond angle. - if (term1.gt.term2) then - termm=term1 - term2=dexp(term2-termm) - term1=1.0d0 - else - termm=term2 - term1=dexp(term1-termm) - term2=1.0d0 - endif -C The ratio between the gamma-independent and gamma-dependent lobes of -C the distribution is a Gaussian function of thet_pred_mean too. - diffak=gthet(2,it)-thet_pred_mean - ratak=diffak/gthet(3,it)**2 - ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) -C Let's differentiate it in thet_pred_mean NOW. - aktc=ak*ratak -C Now put together the distribution terms to make complete distribution. - termexp=term1+ak*term2 - termpre=sigc+ak*sig0i -C Contribution of the bending energy from this theta is just the -log of -C the sum of the contributions from the two lobes and the pre-exponential -C factor. Simple enough, isn't it? - ethetai=(-dlog(termexp)-termm+dlog(termpre)) -C NOW the derivatives!!! -C 6/6/97 Take into account the deformation. - E_theta=(delthec*sigcsq*term1 - & +ak*delthe0*sig0inv*term2)/termexp - E_tc=((sigtc+aktc*sig0i)/termpre - & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ - & aktc*term2)/termexp) - return - end -c----------------------------------------------------------------------------- - subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i -C "Thank you" to MAPLE (probably spared one day of hand-differentiation). - t3 = thetai-thet_pred_mean - t6 = t3**2 - t9 = term1 - t12 = t3*sigcsq - t14 = t12+t6*sigsqtc - t16 = 1.0d0 - t21 = thetai-theta0i - t23 = t21**2 - t26 = term2 - t27 = t21*t26 - t32 = termexp - t40 = t32**2 - E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 - & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 - & *(-t12*t9-ak*sig0inv*t27) - return - end -#else -C-------------------------------------------------------------------------- - subroutine ebend(etheta) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C ab initio-derived potentials from -c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), - & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), - & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), - & sinph1ph2(maxdouble,maxdouble) - logical lprn /.false./, lprn1 /.false./ - etheta=0.0D0 - do i=ithet_start,ithet_end - 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.gt.3 .and. itype(i-2).ne.ntyp1) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - ityp1=ithetyp((itype(i-2))) -C propagation of chirality for glycine type - do k=1,nsingle - cosph1(k)=dcos(k*phii) - sinph1(k)=dsin(k*phii) - enddo - else - phii=0.0d0 - ityp1=nthetyp+1 - do k=1,nsingle - cosph1(k)=0.0d0 - sinph1(k)=0.0d0 - enddo - endif - if (i.lt.nres .and. itype(i).ne.ntyp1) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) -#else - phii1=phi(i+1) -#endif - ityp3=ithetyp((itype(i))) - do k=1,nsingle - cosph2(k)=dcos(k*phii1) - sinph2(k)=dsin(k*phii1) - enddo - else - phii1=0.0d0 - ityp3=nthetyp+1 - do k=1,nsingle - cosph2(k)=0.0d0 - sinph2(k)=0.0d0 - enddo - endif - ethetai=aa0thet(ityp1,ityp2,ityp3,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 -c lprn1=.true. - if (lprn1) - & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') - & i,theta(i)*rad2deg,phii*rad2deg, - & phii1*rad2deg,ethetai -c lprn1=.false. - etheta=etheta+ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 - gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg) - enddo - return - end -#endif -#ifdef CRYST_SC -c----------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), - & ddersc0(3),ddummy(3),xtemp(3),temp(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 -c write (iout,'(a)') 'ESC' - do i=loc_start,loc_end - it=itype(i) - if (it.eq.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) - - if (x(2).gt.pi-delta) then - xtemp(1)=x(1) - xtemp(2)=pi-delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=pi - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=pi-delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=pi - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - call splinthet(x(2),0.5d0*delta,ss,ssd) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c escloci=esclocbi -c write (iout,*) escloci - else if (x(2).lt.delta) then - xtemp(1)=x(1) - xtemp(2)=delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=0.0d0 - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=0.0d0 - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - call splinthet(x(2),0.5d0*delta,ss,ssd) - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c write (iout,*) escloci - else - call enesc(x,escloci,dersc,ddummy,.false.) - endif - - escloc=escloc+escloci - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'escloc',i,escloci -c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc - - gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ - & wscloc*dersc(1) - gloc(ialph(i,1),icg)=wscloc*dersc(2) - gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) - 1 continue - enddo - return - end -C--------------------------------------------------------------------------- - subroutine enesc(x,escloci,dersc,ddersc,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) - double precision contr(maxlob,-1:1) - logical mixed -c write (iout,*) 'it=',it,' nlobit=',nlobit - escloc_i=0.0D0 - do j=1,3 - dersc(j)=0.0D0 - if (mixed) ddersc(j)=0.0d0 - enddo - x3=x(3) - -C Because of periodicity of the dependence of the SC energy in omega we have -C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). -C To avoid underflows, first compute & store the exponents. - - do iii=-1,1 - - x(3)=x3+iii*dwapi - - do j=1,nlobit - do k=1,3 - z(k)=x(k)-censc(k,j,it) - enddo - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j,iii)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j,iii)*z(k) - enddo - contr(j,iii)=expfac - enddo ! j - - enddo ! iii - - x(3)=x3 -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1,-1) - do iii=-1,1 - do j=1,nlobit - if (emin.gt.contr(j,iii)) emin=contr(j,iii) - enddo - enddo - emin=0.5D0*emin -cd print *,'it=',it,' emin=',emin - -C Compute the contribution to SC energy and derivatives - do iii=-1,1 - - do j=1,nlobit -#ifdef OSF - adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin - if(adexp.ne.adexp) adexp=1.0 - expfac=dexp(adexp) -#else - expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) -#endif -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.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2)) - write(2,'(3f8.1,3f9.3,1x,3f9.3)') - & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, - & xx1,yy1,zz1 -C," --- ", xx_w,yy_w,zz_w -c end diagnostics -#endif - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) - & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) -c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, -c & sumene4, -c & dscp1,dscp2,sumene -c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - escloc = escloc + sumene -c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i) -c & ,zz,xx,yy -c#define DEBUG -#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 -c zz=zz*dsign(1.0,dfloat(itype(i))) - pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 - pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 - pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 - pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 - pom_dx=dsc_i*dp2_i*cost2tab(i+1) - pom_dy=dsc_i*dp2_i*sint2tab(i+1) - pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) - pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) - pom1=(sumene3*sint2tab(i+1)+sumene1) - & *(pom_s1/dscp1+pom_s16*dscp1**4) - pom2=(sumene4*cost2tab(i+1)+sumene2) - & *(pom_s2/dscp2+pom_s26*dscp2**4) - sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy - sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 - & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) - & +x(40)*yy*zz - sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy - sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 - & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) - & +x(60)*yy*zz - de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) - & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) - & +(pom1+pom2)*pom_dx -#ifdef DEBUG - write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i) -#endif -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,itype(i) -#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,itype(i) -#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,itype(i) -#endif -c#undef DEBUG -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 -c------------------------------------------------------------------------------ - double precision function enesc(x,xx,yy,zz,cost2,sint2) - implicit none - double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2, - & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6 - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2+yy*sint2)) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2-yy*sint2)) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) - & + (sumene4*cost2 +sumene2)*(s2+s2_6) - enesc=sumene - return - end -#endif -c------------------------------------------------------------------------------ - subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) -C -C This procedure calculates two-body contact function g(rij) and its derivative: -C -C eps0ij ! x < -1 -C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 -C 0 ! x > 1 -C -C where x=(rij-r0ij)/delta -C -C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy -C - implicit none - double precision rij,r0ij,eps0ij,fcont,fprimcont - double precision x,x2,x4,delta -c delta=0.02D0*r0ij -c delta=0.2D0*r0ij - x=(rij-r0ij)/delta - if (x.lt.-1.0D0) then - fcont=eps0ij - fprimcont=0.0D0 - else if (x.le.1.0D0) then - x2=x*x - x4=x2*x2 - fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) - fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta - else - fcont=0.0D0 - fprimcont=0.0D0 - endif - return - end -c------------------------------------------------------------------------------ - subroutine splinthet(theti,delta,ss,ssder) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - thetup=pi-delta - thetlow=delta - if (theti.gt.pipol) then - call gcont(theti,thetup,1.0d0,delta,ss,ssder) - else - call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) - ssder=-ssder - endif - return - end -c------------------------------------------------------------------------------ - subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) - implicit none - double precision x,x0,delta,f0,f1,fprim0,f,fprim - double precision ksi,ksi2,ksi3,a1,a2,a3 - a1=fprim0*delta/(f1-f0) - a2=3.0d0-2.0d0*a1 - a3=a1-2.0d0 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) - fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) - return - end -c------------------------------------------------------------------------------ - subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) - implicit none - double precision x,x0,delta,f0x,f1x,fprim0x,fx - double precision ksi,ksi2,ksi3,a1,a2,a3 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - a1=fprim0x*delta - a2=3*(f1x-f0x)-2*fprim0x*delta - a3=fprim0x*delta-2*(f1x-f0x) - fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 - return - end -C----------------------------------------------------------------------------- -#ifdef CRYST_TOR -C----------------------------------------------------------------------------- - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - etors_ii=0.0D0 - 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) - if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) - gloci=gloci-3*fac*etorsi*dsin(3*phii) - endif - do j=1,3 - v1ij=v1(j+1,itori,itori1) - v2ij=v2(j+1,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ - & v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - else - do j=1,nterm_old - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ - & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - endif - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - 'etor',i,etors_ii - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 - do i=1,ndih_constr - itori=idih_constr(i) - phii=phi(itori) - difi=phii-phi0(i) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - endif -! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, -! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -! write (iout,*) 'edihcnstr',edihcnstr - return - end -c------------------------------------------------------------------------------ - subroutine etor_d(etors_d) - etors_d=0.0d0 - return - end -c---------------------------------------------------------------------------- -#else - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 - & .or. itype(i).eq.ntyp1) cycle - etors_ii=0.0D0 - if (iabs(itype(i)).eq.20) then - iblock=2 - else - iblock=1 - endif - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -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 - if (energy_dec) etors_ii=etors_ii+ - & v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo -C Lorentz terms -C v1 -C E = SUM ----------------------------------- - v1 -C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 -C - cosphi=dcos(0.5d0*phii) - sinphi=dsin(0.5d0*phii) - do j=1,nlor(itori,itori1,iblock) - vl1ij=vlor1(j,itori,itori1) - vl2ij=vlor2(j,itori,itori1) - vl3ij=vlor3(j,itori,itori1) - pom=vl2ij*cosphi+vl3ij*sinphi - pom1=1.0d0/(pom*pom+1.0d0) - etors=etors+vl1ij*pom1 - if (energy_dec) etors_ii=etors_ii+ - & vl1ij*pom1 - pom=-pom*pom1*pom1 - gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom - enddo -C Subtract the constant term - etors=etors-v0(itori,itori1,iblock) - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'etor',i,etors_ii-v0(itori,itori1,iblock) - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1,iblock),j=1,6), - & (v2(j,itori,itori1,iblock),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 -c do i=1,ndih_constr - do i=idihconstr_start,idihconstr_end - itori=idih_constr(i) - phii=phi(itori) - difi=pinorm(phii-phi0(i)) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else - difi=0.0 - endif -cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, -cd & rad2deg*phi0(i), rad2deg*drange(i), -cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -cd write (iout,*) 'edihcnstr',edihcnstr - return - end -c---------------------------------------------------------------------------- - subroutine etor_d(etors_d) -C 6/23/01 Compute double torsional energy - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors_d=0.0D0 -c write(iout,*) "a tu??" - do i=iphid_start,iphid_end - if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 - & .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - itori2=itortyp(itype(i)) - phii=phi(i) - phii1=phi(i+1) - gloci1=0.0D0 - gloci2=0.0D0 - iblock=1 - if (iabs(itype(i+1)).eq.20) iblock=2 - -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*gloci1 - gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 - enddo - return - end -#endif -c------------------------------------------------------------------------------ - subroutine eback_sc_corr(esccor) -c 7/21/2007 Correlations between the backbone-local and side-chain-local -c conformational states; temporarily implemented as differences -c between UNRES torsional potentials (dependent on three types of -c residues) and the torsional potentials dependent on all 20 types -c of residues computed from AM1 energy surfaces of terminally-blocked -c amino-acid residues. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.SCCOR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. -c write (iout,*) "EBACK_SC_COR",itau_start,itau_end - esccor=0.0D0 - do i=itau_start,itau_end - if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle - esccor_ii=0.0D0 - isccori=isccortyp(itype(i-2)) - isccori1=isccortyp(itype(i-1)) -c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1) - 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",i,v1ij*cosphi+v2ij*sinphi,intertyp - gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1, - & (v1sccor(j,intertyp,isccori,isccori1),j=1,6) - & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6) - gsccor_loc(i-3)=gsccor_loc(i-3)+gloci - enddo !intertyp - enddo - - return - end -c---------------------------------------------------------------------------- - subroutine multibody(ecorr) -C This subroutine calculates multi-body contributions to energy following -C the idea of Skolnick et al. If side chains I and J make a contact and -C at the same time side chains I+1 and J+1 make a contact, an extra -C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - -C Set lprn=.true. for debugging - lprn=.false. - - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(i2,20(1x,i2,f10.5))') - & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) - enddo - endif - ecorr=0.0D0 - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo - do i=nnt,nct-2 - - DO ISHIFT = 3,4 - - i1=i+ishift - num_conti=num_cont(i) - num_conti1=num_cont(i1) - do jj=1,num_conti - j=jcont(jj,i) - do kk=1,num_conti1 - j1=jcont(kk,i1) - if (j1.eq.j+ishift .or. j1.eq.j-ishift) then -cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, -cd & ' ishift=',ishift -C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) - endif ! j1==j+-ishift - enddo ! kk - enddo ! jj - - ENDDO ! ISHIFT - - enddo ! i - return - end -c------------------------------------------------------------------------------ - double precision function esccorr(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont(jj,i) - ekl=facont(kk,k) -cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl -C Calculate the multi-body contribution to energy. -C Calculate multi-body contributions to the gradient. -cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), -cd & k,l,(gacont(m,kk,k),m=1,3) - do m=1,3 - gx(m) =ekl*gacont(m,jj,i) - gx1(m)=eij*gacont(m,kk,k) - gradxorr(m,i)=gradxorr(m,i)-gx(m) - gradxorr(m,j)=gradxorr(m,j)+gx(m) - gradxorr(m,k)=gradxorr(m,k)-gx1(m) - gradxorr(m,l)=gradxorr(m,l)+gx1(m) - enddo - do m=i,j-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) - enddo - enddo - do m=k,l-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) - enddo - enddo - esccorr=-eij*ekl - return - end -c------------------------------------------------------------------------------ - subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPI - include "mpif.h" - parameter (max_cont=maxconts) - parameter (max_dim=26) - integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer status(MPI_STATUS_SIZE),req(maxconts*2), - & status_array(MPI_STATUS_SIZE,maxconts*2) -#endif - include 'COMMON.SETUP' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.LOCAL' - double precision gx(3),gx1(3),time00 - logical lprn,ldone - -C Set lprn=.true. for debugging - lprn=.false. -#ifdef MPI - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values before RECEIVE:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", -c & ntask_cont_to -C Make the list of contacts to send to send to other procesors -c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end -c call flush(iout) - do i=iturn3_start,iturn3_end -c write (iout,*) "make contact list turn3",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact(i,i+2,iturn3_sent_local(1,i)) - enddo - do i=iturn4_start,iturn4_end -c write (iout,*) "make contact list turn4",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact(i,i+3,iturn4_sent_local(1,i)) - enddo - do ii=1,nat_sent - i=iat_sent(ii) -c write (iout,*) "make contact list longrange",i,ii," num_cont", -c & num_cont_hb(i) - do j=1,num_cont_hb(i) - do k=1,4 - jjc=jcont_hb(j,i) - iproc=iint_sent_local(k,jjc,ii) -c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc - if (iproc.gt.0) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=i - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=facont_hb(j,i) - zapas(4,nn,iproc)=ees0p(j,i) - zapas(5,nn,iproc)=ees0m(j,i) - zapas(6,nn,iproc)=gacont_hbr(1,j,i) - zapas(7,nn,iproc)=gacont_hbr(2,j,i) - zapas(8,nn,iproc)=gacont_hbr(3,j,i) - zapas(9,nn,iproc)=gacontm_hb1(1,j,i) - zapas(10,nn,iproc)=gacontm_hb1(2,j,i) - zapas(11,nn,iproc)=gacontm_hb1(3,j,i) - zapas(12,nn,iproc)=gacontp_hb1(1,j,i) - zapas(13,nn,iproc)=gacontp_hb1(2,j,i) - zapas(14,nn,iproc)=gacontp_hb1(3,j,i) - zapas(15,nn,iproc)=gacontm_hb2(1,j,i) - zapas(16,nn,iproc)=gacontm_hb2(2,j,i) - zapas(17,nn,iproc)=gacontm_hb2(3,j,i) - zapas(18,nn,iproc)=gacontp_hb2(1,j,i) - zapas(19,nn,iproc)=gacontp_hb2(2,j,i) - zapas(20,nn,iproc)=gacontp_hb2(3,j,i) - zapas(21,nn,iproc)=gacontm_hb3(1,j,i) - zapas(22,nn,iproc)=gacontm_hb3(2,j,i) - zapas(23,nn,iproc)=gacontm_hb3(3,j,i) - zapas(24,nn,iproc)=gacontp_hb3(1,j,i) - zapas(25,nn,iproc)=gacontp_hb3(2,j,i) - zapas(26,nn,iproc)=gacontp_hb3(3,j,i) - endif - enddo - enddo - enddo - if (lprn) then - write (iout,*) - & "Numbers of contacts to be sent to other processors", - & (ncont_sent(i),i=1,ntask_cont_to) - write (iout,*) "Contacts sent" - do ii=1,ntask_cont_to - nn=ncont_sent(ii) - iproc=itask_cont_to(ii) - write (iout,*) nn," contacts to processor",iproc, - & " of CONT_TO_COMM group" - do i=1,nn - write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) - enddo - enddo - call flush(iout) - endif - CorrelType=477 - CorrelID=fg_rank+1 - CorrelType1=478 - CorrelID1=nfgtasks+fg_rank+1 - ireq=0 -C Receive the numbers of needed contacts from other processors - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - ireq=ireq+1 - call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "IRECV ended" -c call flush(iout) -C Send the number of contacts needed by other processors - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - ireq=ireq+1 - call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "ISEND ended" -c write (iout,*) "number of requests (nn)",ireq - call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) -c write (iout,*) -c & "Numbers of contacts to be received from other processors", -c & (ncont_recv(i),i=1,ntask_cont_from) -c call flush(iout) -C Receive contacts - ireq=0 - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - nn=ncont_recv(ii) -c write (iout,*) "Receiving",nn," contacts from processor",iproc, -c & " of CONT_TO_COMM group" - call flush(iout) - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, - & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) - endif - enddo -C Send the contacts to processors that need them - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - nn=ncont_sent(ii) -c write (iout,*) nn," contacts to processor",iproc, -c & " of CONT_TO_COMM group" - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, - & iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) -c do i=1,nn -c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) -c enddo - endif - enddo -c write (iout,*) "number of requests (contacts)",ireq -c write (iout,*) "req",(req(i),i=1,4) -c call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) - do iii=1,ntask_cont_from - iproc=itask_cont_from(iii) - nn=ncont_recv(iii) - if (lprn) then - write (iout,*) "Received",nn," contacts from processor",iproc, - & " of CONT_FROM_COMM group" - call flush(iout) - do i=1,nn - write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5) - enddo - call flush(iout) - endif - do i=1,nn - ii=zapas_recv(1,i,iii) -c Flag the received contacts to prevent double-counting - jj=-zapas_recv(2,i,iii) -c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj -c call flush(iout) - nnn=num_cont_hb(ii)+1 - num_cont_hb(ii)=nnn - jcont_hb(nnn,ii)=jj - facont_hb(nnn,ii)=zapas_recv(3,i,iii) - ees0p(nnn,ii)=zapas_recv(4,i,iii) - ees0m(nnn,ii)=zapas_recv(5,i,iii) - gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii) - gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii) - gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii) - gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii) - gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii) - gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii) - gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii) - gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii) - gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii) - gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii) - gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii) - gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii) - gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii) - gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii) - gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii) - gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii) - gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii) - gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii) - gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii) - gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii) - gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii) - enddo - enddo - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 -C Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -C Calculate the local-electrostatic correlation terms - do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end) - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - jp=iabs(j) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) - jp1=iabs(j1) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 - & .or. j.lt.0 .and. j1.gt.0) .and. - & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then -C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) - n_corr=n_corr+1 - else if (j1.eq.j) then -C Contacts I-J and I-(J+1) occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) - endif - enddo ! kk - do kk=1,num_conti - j1=jcont_hb(kk,i) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if (j1.eq.j+1) then -C Contacts I-J and (I+1)-J occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) - endif ! j1==j+1 - enddo ! kk - enddo ! jj - enddo ! i - return - end -c------------------------------------------------------------------------------ - subroutine add_hb_contact(ii,jj,itask) - implicit real*8 (a-h,o-z) - include "DIMENSIONS" - include "COMMON.IOUNITS" - integer max_cont - integer max_dim - parameter (max_cont=maxconts) - parameter (max_dim=26) - include "COMMON.CONTACTS" - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer i,j,ii,jj,iproc,itask(4),nn -c write (iout,*) "itask",itask - do i=1,2 - iproc=itask(i) - if (iproc.gt.0) then - do j=1,num_cont_hb(ii) - jjc=jcont_hb(j,ii) -c write (iout,*) "i",ii," j",jj," jjc",jjc - if (jjc.eq.jj) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=ii - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=facont_hb(j,ii) - zapas(4,nn,iproc)=ees0p(j,ii) - zapas(5,nn,iproc)=ees0m(j,ii) - zapas(6,nn,iproc)=gacont_hbr(1,j,ii) - zapas(7,nn,iproc)=gacont_hbr(2,j,ii) - zapas(8,nn,iproc)=gacont_hbr(3,j,ii) - zapas(9,nn,iproc)=gacontm_hb1(1,j,ii) - zapas(10,nn,iproc)=gacontm_hb1(2,j,ii) - zapas(11,nn,iproc)=gacontm_hb1(3,j,ii) - zapas(12,nn,iproc)=gacontp_hb1(1,j,ii) - zapas(13,nn,iproc)=gacontp_hb1(2,j,ii) - zapas(14,nn,iproc)=gacontp_hb1(3,j,ii) - zapas(15,nn,iproc)=gacontm_hb2(1,j,ii) - zapas(16,nn,iproc)=gacontm_hb2(2,j,ii) - zapas(17,nn,iproc)=gacontm_hb2(3,j,ii) - zapas(18,nn,iproc)=gacontp_hb2(1,j,ii) - zapas(19,nn,iproc)=gacontp_hb2(2,j,ii) - zapas(20,nn,iproc)=gacontp_hb2(3,j,ii) - zapas(21,nn,iproc)=gacontm_hb3(1,j,ii) - zapas(22,nn,iproc)=gacontm_hb3(2,j,ii) - zapas(23,nn,iproc)=gacontm_hb3(3,j,ii) - zapas(24,nn,iproc)=gacontp_hb3(1,j,ii) - zapas(25,nn,iproc)=gacontp_hb3(2,j,ii) - zapas(26,nn,iproc)=gacontp_hb3(3,j,ii) - exit - endif - enddo - endif - enddo - return - end -c------------------------------------------------------------------------------ - subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, - & n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPI - include "mpif.h" - parameter (max_cont=maxconts) - parameter (max_dim=70) - integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer status(MPI_STATUS_SIZE),req(maxconts*2), - & status_array(MPI_STATUS_SIZE,maxconts*2) -#endif - include 'COMMON.SETUP' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.CONTROL' - double precision gx(3),gx1(3) - integer num_cont_hb_old(maxres) - logical lprn,ldone - double precision eello4,eello5,eelo6,eello_turn6 - external eello4,eello5,eello6,eello_turn6 -C Set lprn=.true. for debugging - lprn=.false. - eturn6=0.0d0 -#ifdef MPI - do i=1,nres - num_cont_hb_old(i)=num_cont_hb(i) - enddo - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values before RECEIVE:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", -c & ntask_cont_to -C Make the list of contacts to send to send to other procesors - do i=iturn3_start,iturn3_end -c write (iout,*) "make contact list turn3",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i)) - enddo - do i=iturn4_start,iturn4_end -c write (iout,*) "make contact list turn4",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i)) - enddo - do ii=1,nat_sent - i=iat_sent(ii) -c write (iout,*) "make contact list longrange",i,ii," num_cont", -c & num_cont_hb(i) - do j=1,num_cont_hb(i) - do k=1,4 - jjc=jcont_hb(j,i) - iproc=iint_sent_local(k,jjc,ii) -c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc - if (iproc.ne.0) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=i - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=d_cont(j,i) - ind=3 - do kk=1,3 - ind=ind+1 - zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i) - enddo - enddo - enddo - enddo - endif - enddo - enddo - enddo - if (lprn) then - write (iout,*) - & "Numbers of contacts to be sent to other processors", - & (ncont_sent(i),i=1,ntask_cont_to) - write (iout,*) "Contacts sent" - do ii=1,ntask_cont_to - nn=ncont_sent(ii) - iproc=itask_cont_to(ii) - write (iout,*) nn," contacts to processor",iproc, - & " of CONT_TO_COMM group" - do i=1,nn - write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10) - enddo - enddo - call flush(iout) - endif - CorrelType=477 - CorrelID=fg_rank+1 - CorrelType1=478 - CorrelID1=nfgtasks+fg_rank+1 - ireq=0 -C Receive the numbers of needed contacts from other processors - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - ireq=ireq+1 - call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "IRECV ended" -c call flush(iout) -C Send the number of contacts needed by other processors - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - ireq=ireq+1 - call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "ISEND ended" -c write (iout,*) "number of requests (nn)",ireq - call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) -c write (iout,*) -c & "Numbers of contacts to be received from other processors", -c & (ncont_recv(i),i=1,ntask_cont_from) -c call flush(iout) -C Receive contacts - ireq=0 - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - nn=ncont_recv(ii) -c write (iout,*) "Receiving",nn," contacts from processor",iproc, -c & " of CONT_TO_COMM group" - call flush(iout) - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, - & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) - endif - enddo -C Send the contacts to processors that need them - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - nn=ncont_sent(ii) -c write (iout,*) nn," contacts to processor",iproc, -c & " of CONT_TO_COMM group" - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, - & iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) -c do i=1,nn -c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) -c enddo - endif - enddo -c write (iout,*) "number of requests (contacts)",ireq -c write (iout,*) "req",(req(i),i=1,4) -c call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) - do iii=1,ntask_cont_from - iproc=itask_cont_from(iii) - nn=ncont_recv(iii) - if (lprn) then - write (iout,*) "Received",nn," contacts from processor",iproc, - & " of CONT_FROM_COMM group" - call flush(iout) - do i=1,nn - write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10) - enddo - call flush(iout) - endif - do i=1,nn - ii=zapas_recv(1,i,iii) -c Flag the received contacts to prevent double-counting - jj=-zapas_recv(2,i,iii) -c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj -c call flush(iout) - nnn=num_cont_hb(ii)+1 - num_cont_hb(ii)=nnn - jcont_hb(nnn,ii)=jj - d_cont(nnn,ii)=zapas_recv(3,i,iii) - ind=3 - do kk=1,3 - ind=ind+1 - grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii) - enddo - enddo - enddo - enddo - enddo - enddo - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,5f6.3))') - & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), - & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,5f6.3))') - & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), - & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 - ecorr5=0.0d0 - ecorr6=0.0d0 -C Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -C Calculate the dipole-dipole interaction energies - if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then - do i=iatel_s,iatel_e+1 - num_conti=num_cont_hb(i) - do jj=1,num_conti - j=jcont_hb(jj,i) -#ifdef MOMENT - call dipole(i,j,jj) -#endif - enddo - enddo - endif -C Calculate the local-electrostatic correlation terms -c write (iout,*) "gradcorr5 in eello5 before loop" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) -c write (iout,*) "corr loop i",i - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - jp=iabs(j) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) - jp1=iabs(j1) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk -c if (j1.eq.j+1 .or. j1.eq.j-1) then - if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 - & .or. j.lt.0 .and. j1.gt.0) .and. - & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then -C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -C The system gains extra energy. - n_corr=n_corr+1 - sqd1=dsqrt(d_cont(jj,i)) - sqd2=dsqrt(d_cont(kk,i1)) - sred_geom = sqd1*sqd2 - IF (sred_geom.lt.cutoff_corr) THEN - call gcont(sred_geom,r0_corr,1.0D0,delt_corr, - & ekont,fprimcont) -cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, -cd & ' jj=',jj,' kk=',kk - fac_prim1=0.5d0*sqd2/sqd1*fprimcont - fac_prim2=0.5d0*sqd1/sqd2*fprimcont - do l=1,3 - g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) - g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) - enddo - n_corr1=n_corr1+1 -cd write (iout,*) 'sred_geom=',sred_geom, -cd & ' ekont=',ekont,' fprim=',fprimcont, -cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 -cd write (iout,*) "g_contij",g_contij -cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) -cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) - call calc_eello(i,jp,i+1,jp1,jj,kk) - if (wcorr4.gt.0.0d0) - & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) - if (energy_dec.and.wcorr4.gt.0.0d0) - 1 write (iout,'(a6,4i5,0pf7.3)') - 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) -c write (iout,*) "gradcorr5 before eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - if (wcorr5.gt.0.0d0) - & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) -c write (iout,*) "gradcorr5 after eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - if (energy_dec.and.wcorr5.gt.0.0d0) - 1 write (iout,'(a6,4i5,0pf7.3)') - 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) -cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 -cd write(2,*)'ijkl',i,jp,i+1,jp1 - if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 - & .or. wturn6.eq.0.0d0))then -cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 - ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) - if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') - 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) -cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, -cd & 'ecorr6=',ecorr6 -cd write (iout,'(4e15.5)') sred_geom, -cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)), -cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)), -cd & dabs(eello6(i,jp,i+1,jp1,jj,kk)) - else if (wturn6.gt.0.0d0 - & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then -cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 - eturn6=eturn6+eello_turn6(i,jj,kk) - if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') - 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) -cd write (2,*) 'multibody_eello:eturn6',eturn6 - endif - ENDIF -1111 continue - endif - enddo ! kk - enddo ! jj - enddo ! i - do i=1,nres - num_cont_hb(i)=num_cont_hb_old(i) - enddo -c write (iout,*) "gradcorr5 in eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - return - end -c------------------------------------------------------------------------------ - subroutine add_hb_contact_eello(ii,jj,itask) - implicit real*8 (a-h,o-z) - include "DIMENSIONS" - include "COMMON.IOUNITS" - integer max_cont - integer max_dim - parameter (max_cont=maxconts) - parameter (max_dim=70) - include "COMMON.CONTACTS" - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer i,j,ii,jj,iproc,itask(4),nn -c write (iout,*) "itask",itask - do i=1,2 - iproc=itask(i) - if (iproc.gt.0) then - do j=1,num_cont_hb(ii) - jjc=jcont_hb(j,ii) -c write (iout,*) "send turns i",ii," j",jj," jjc",jjc - if (jjc.eq.jj) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=ii - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=d_cont(j,ii) - ind=3 - do kk=1,3 - ind=ind+1 - zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii) - enddo - enddo - enddo - enddo - exit - endif - enddo - endif - enddo - return - end -c------------------------------------------------------------------------------ - double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont_hb(jj,i) - ekl=facont_hb(kk,k) - ees0pij=ees0p(jj,i) - ees0pkl=ees0p(kk,k) - ees0mij=ees0m(jj,i) - ees0mkl=ees0m(kk,k) - ekont=eij*ekl - ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) -cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) -C Following 4 lines for diagnostics. -cd ees0pkl=0.0D0 -cd ees0pij=1.0D0 -cd ees0mkl=0.0D0 -cd ees0mij=1.0D0 -c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') -c & 'Contacts ',i,j, -c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l -c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, -c & 'gradcorr_long' -C Calculate the multi-body contribution to energy. -c ecorr=ecorr+ekont*ees -C Calculate multi-body contributions to the gradient. - coeffpees0pij=coeffp*ees0pij - coeffmees0mij=coeffm*ees0mij - coeffpees0pkl=coeffp*ees0pkl - coeffmees0mkl=coeffm*ees0mkl - do ll=1,3 -cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) - gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi - & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb1(ll,jj,i)) - gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi - & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb2(ll,jj,i)) -cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k) - gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk - & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ - & coeffmees0mij*gacontm_hb1(ll,kk,k)) - gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk - & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ - & coeffmees0mij*gacontm_hb2(ll,kk,k)) - gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- - & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb3(ll,jj,i)) - gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij - gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij - gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- - & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ - & coeffmees0mij*gacontm_hb3(ll,kk,k)) - gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl - gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl -c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl - enddo -c write (iout,*) -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ -cgrad & ees*ekl*gacont_hbr(ll,jj,i)- -cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ -cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ -cgrad & ees*eij*gacont_hbr(ll,kk,k)- -cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ -cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) -cgrad enddo -cgrad enddo -c write (iout,*) "ehbcorr",ekont*ees - ehbcorr=ekont*ees - return - end -#ifdef MOMENT -C--------------------------------------------------------------------------- - subroutine dipole(i,j,jj) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), - & auxmat(2,2) - iti1 = itortyp(itype(i+1)) - if (j.lt.nres-1) then - itj1 = itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - do iii=1,2 - dipi(iii,1)=Ub2(iii,i) - dipderi(iii)=Ub2der(iii,i) - dipi(iii,2)=b1(iii,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.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), - & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) - logical lprn - common /kutas/ lprn -cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, -cd & ' jj=',jj,' kk=',kk -cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return -cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) -cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) - aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) - enddo - enddo - call transpose2(aa1(1,1),aa1t(1,1)) - call transpose2(aa2(1,1),aa2t(1,1)) - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), - & aa1tder(1,1,lll,kkk)) - call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), - & aa2tder(1,1,lll,kkk)) - enddo - enddo - if (l.eq.j+1) then -C parallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itj=itortyp(itype(j)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -C A1 kernel(j+1) A2T -cd do iii=1,2 -cd write (iout,'(3f10.5,5x,3f10.5)') -cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) -cd enddo - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), - & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - lprn=.false. - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), - & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants -cd lprn=.false. -cd if (lprn) then -cd write (2,*) 'In calc_eello6' -cd do iii=1,2 -cd write (2,*) 'iii=',iii -cd do kkk=1,5 -cd write (2,*) 'kkk=',kkk -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) -cd enddo -cd enddo -cd enddo -cd endif - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A1T kernel(i+1) A2 - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,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=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,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.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then -cd eello4=0.0d0 -cd return -cd endif -cd print *,'eello4:',i,j,k,l,jj,kk -cd write (2,*) 'i',i,' j',j,' k',k,' l',l -cd call checkint4(i,j,k,l,jj,kk,eel4_num) -cold eij=facont_hb(jj,i) -cold ekl=facont_hb(kk,k) -cold ekont=eij*ekl - eel4=-EAEA(1,1,1)-EAEA(2,2,1) -cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) - gcorr_loc(k-1)=gcorr_loc(k-1) - & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) - if (l.eq.j+1) then - gcorr_loc(l-1)=gcorr_loc(l-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - else - gcorr_loc(j-1)=gcorr_loc(j-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) - & -EAEAderx(2,2,lll,kkk,iii,1) -cd derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd gcorr_loc(l-1)=0.0d0 -cd gcorr_loc(j-1)=0.0d0 -cd gcorr_loc(k-1)=0.0d0 -cd eel4=1.0d0 -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l, -cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel4*g_contij(ll,1) -cgrad ggg2(ll)=eel4*g_contij(ll,2) - glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) - glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) -cgrad ghalf=0.5d0*ggg1(ll) - gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) - gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) - gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) - gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) - gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij - gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij -cgrad ghalf=0.5d0*ggg2(ll) - gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) - gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) - gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) - gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) - gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl - gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl - enddo -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,gcorr_loc(iii) -cd enddo - eello4=ekont*eel4 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello4',ekont*eel4 - return - end -C--------------------------------------------------------------------------- - double precision function eello5(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) - double precision ggg1(3),ggg2(3) -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel chains C -C C -C o o o o C -C /l\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j| o |l1 | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C Antiparallel chains C -C C -C o o o o C -C /j\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j1| o |l | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C o denotes a local interaction, vertical lines an electrostatic interaction. C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then -cd eello5=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - itk=itortyp(itype(k)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - eello5_1=0.0d0 - eello5_2=0.0d0 - eello5_3=0.0d0 - eello5_4=0.0d0 -cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, -cd & eel5_3_num,eel5_4_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l -cd goto 1111 -C Contribution from the graph I. -cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) -cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) -C Explicit gradient in virtual-dihedral angles. - if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - if (l.eq.j+1) then - if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - else - if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) - enddo - enddo - enddo -c goto 1112 -c1111 continue -C Contribution from graph II - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_2=scalar2(AEAb1(1,2,1),b1(1,k)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - if (l.eq.j+1) then - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,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 -cd goto 1112 -cd1111 continue - if (l.eq.j+1) then -cd goto 1110 -C Parallel orientation -C Contribution from graph III - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) - call transpose2(EUgder(1,1,l),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) - enddo - enddo - enddo -cd goto 1112 -C Contribution from graph IV -cd1110 continue - call transpose2(EE(1,1,itl),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,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 - else -C Antiparallel orientation -C Contribution from graph III -c goto 1110 - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) - call transpose2(EUgder(1,1,j),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) - enddo - enddo - enddo -cd goto 1112 -C Contribution from graph IV -1110 continue - call transpose2(EE(1,1,itj),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,j)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,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 -1112 continue - eel5=eello5_1+eello5_2+eello5_3+eello5_4 -cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then -cd write (2,*) 'ijkl',i,j,k,l -cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, -cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 -cd endif -cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num -cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num -cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num -cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 -cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont -C 2/11/08 AL Gradients over DC's connecting interacting sites will be -C summed up outside the subrouine as for the other subroutines -C handling long-range interactions. The old code is commented out -C with "cgrad" to keep track of changes. - do ll=1,3 -cgrad ggg1(ll)=eel5*g_contij(ll,1) -cgrad ggg2(ll)=eel5*g_contij(ll,2) - gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) - gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) -c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') -c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), -c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), -c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont -c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') -c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), -c & gradcorr5ij, -c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl -cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) - gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) - gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) - gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) - gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij - gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij -cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) -cgrad ghalf=0.5d0*ggg2(ll) -cd ghalf=0.0d0 - gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) - gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) - gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) - gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) - gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl - gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -c1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr5_loc(iii) -cd enddo - eello5=ekont*eel5 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello5',ekont*eel5 - return - end -c-------------------------------------------------------------------------- - double precision function eello6(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - eello6_1=0.0d0 - eello6_2=0.0d0 - eello6_3=0.0d0 - eello6_4=0.0d0 - eello6_5=0.0d0 - eello6_6=0.0d0 -cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, -cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - if (l.eq.j+1) then - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(j,i,l,k,2,.false.) - eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) - eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) - else - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(l,k,j,i,2,.true.) - eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - if (wturn6.eq.0.0d0 .or. j.ne.i+4) then - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) - else - eello6_5=0.0d0 - endif - eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) - endif -C If turn contributions are considered, they will be handled separately. - eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 -cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num -cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num -cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num -cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num -cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num -cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num -cd goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel6*g_contij(ll,1) -cgrad ggg2(ll)=eel6*g_contij(ll,2) -cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) - gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) - gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) - gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) - gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) - gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) - gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij - gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij -cgrad ghalf=0.5d0*ggg2(ll) -cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) -cd ghalf=0.0d0 - gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) - gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) - gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) - gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) - gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl - gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr6_loc(iii) -cd enddo - eello6=ekont*eel6 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello6',ekont*eel6 - return - end -c-------------------------------------------------------------------------- - double precision function eello6_graph1(i,j,k,l,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) - logical swap - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -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,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 (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 - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph2(i,j,k,l,jj,kk,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - logical swap - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxvec2(2),auxmat1(2,2) - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C \ /l\ /j\ / C -C \ / \ / \ / C -C o| o | | o |o C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l -C AL 7/4/01 s1 would occur in the sixth-order moment, -C but not in a cluster cumulant -#ifdef MOMENT - s1=dip(1,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph2=-(s1+s2+s3+s4) -#else - eello6_graph2=-(s2+s3+s4) -#endif -c eello6_graph2=-s3 -C Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - s1=dipderg(1,jj,i)*dip(1,kk,k) -#endif - s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif -c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 - endif -C Derivatives in gamma(k-1) -#ifdef MOMENT - s1=dip(1,jj,i)*dipderg(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif -c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 -C Derivatives in gamma(j-1) or gamma(l-1) - if (j.gt.1) then -#ifdef MOMENT - s1=dipderg(3,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) - call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - if (swap) then - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 - endif -#endif - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) -c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 - endif -C Derivatives in gamma(l-1) or gamma(j-1) - if (l.gt.1) then -#ifdef MOMENT - s1=dip(1,jj,i)*dipderg(3,kk,k) -#endif - call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - if (swap) then - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 - else - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 - endif -#endif - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) -c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 - endif -C Cartesian derivatives. - if (lprn) then - write (2,*) 'In eello6_graph2' - do iii=1,2 - write (2,*) 'iii=',iii - do kkk=1,5 - write (2,*) 'kkk=',kkk - do jjj=1,2 - write (2,'(3(2f10.5),5x)') - & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) - enddo - enddo - enddo - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) - else - s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) - endif -#endif - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), - & auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), - & auxvec(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph3(i,j,k,l,jj,kk,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C j|/k\| / |/k\|l / C -C / \ / / \ / C -C / o / o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. - iti=itortyp(itype(i)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -#ifdef MOMENT - s1=dip(4,jj,i)*dip(4,kk,k) -#endif - call matvec2(AECA(1,1,1),b1(1,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,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, -cd & "sum",-(s2+s3+s4) -#ifdef MOMENT - eello6_graph3=-(s1+s2+s3+s4) -#else - eello6_graph3=-(s2+s3+s4) -#endif -c eello6_graph3=-s4 -C Derivatives in gamma(k-1) - call matvec2(AECAderg(1,1,2),b1(1,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 - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxmat1(2,2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o \ o \ C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. -cd write (2,*) 'eello_graph4: wturn6',wturn6 - iti=itortyp(itype(i)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - if (k.lt.nres-1) then - itk1=itortyp(itype(k+1)) - else - itk1=ntortyp+1 - endif - itl=itortyp(itype(l)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l -cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, -cd & ' itl',itl,' itl1',itl1 -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dip(3,kk,k) - else - s1=dip(2,jj,j)*dip(2,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1(1,1,3-imat),b1(1,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 (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 - return - end -c---------------------------------------------------------------------------- - double precision function eello_turn6(i,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), - & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), - & ggg1(3),ggg2(3) - double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), - & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) -C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to -C the respective energy moment and not to the cluster cumulant. - s1=0.0d0 - s8=0.0d0 - s13=0.0d0 -c - eello_turn6=0.0d0 - j=i+4 - k=i+1 - l=i+3 - iti=itortyp(itype(i)) - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) -cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj -cd write (2,*) 'i',i,' k',k,' j',j,' l',l -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l -cd call checkint_turn6(i,jj,kk,eel_turn6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx_turn(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) -cd eello6_5=0.0d0 -cd write (2,*) 'eello6_5',eello6_5 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) - ss1=scalar2(Ub2(1,i+2),b1(1,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,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,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) - s1d =0.0d0 - s8d =0.0d0 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 - call transpose2(AEAderg(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 - gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) -C Derivatives in gamma(i+3) -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - ss1d=scalar2(Ub2der(1,i+2),b1(1,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,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,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,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,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,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,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 - eello_turn6=ekont*eel_turn6 -cd write (2,*) 'ekont',ekont -cd write (2,*) 'eel_turn6',ekont*eel_turn6 - return - end - -C----------------------------------------------------------------------------- - double precision function scalar(u,v) -!DIR$ INLINEALWAYS scalar -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::scalar -#endif - implicit none - double precision u(3),v(3) -cd double precision sc -cd integer i -cd sc=0.0d0 -cd do i=1,3 -cd sc=sc+u(i)*v(i) -cd enddo -cd scalar=sc - - scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3) - return - end -crc------------------------------------------------- - SUBROUTINE MATVEC2(A1,V1,V2) -!DIR$ INLINEALWAYS MATVEC2 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2 -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),V1(2),V2(2) -c DO 1 I=1,2 -c VI=0.0 -c DO 3 K=1,2 -c 3 VI=VI+A1(I,K)*V1(K) -c Vaux(I)=VI -c 1 CONTINUE - - vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) - vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) - - v2(1)=vaux1 - v2(2)=vaux2 - END -C--------------------------------------- - SUBROUTINE MATMAT2(A1,A2,A3) -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2 -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),A2(2,2),A3(2,2) -c DIMENSION AI3(2,2) -c DO J=1,2 -c A3IJ=0.0 -c DO K=1,2 -c A3IJ=A3IJ+A1(I,K)*A2(K,J) -c enddo -c A3(I,J)=A3IJ -c enddo -c enddo - - ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) - ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) - ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) - ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) - - A3(1,1)=AI3_11 - A3(2,1)=AI3_21 - A3(1,2)=AI3_12 - A3(2,2)=AI3_22 - END - -c------------------------------------------------------------------------- - double precision function scalar2(u,v) -!DIR$ INLINEALWAYS scalar2 - implicit none - double precision u(2),v(2) - double precision sc - integer i - scalar2=u(1)*v(1)+u(2)*v(2) - return - end - -C----------------------------------------------------------------------------- - - subroutine transpose2(a,at) -!DIR$ INLINEALWAYS transpose2 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::transpose2 -#endif - implicit none - double precision a(2,2),at(2,2) - at(1,1)=a(1,1) - at(1,2)=a(2,1) - at(2,1)=a(1,2) - at(2,2)=a(2,2) - return - end -c-------------------------------------------------------------------------- - subroutine transpose(n,a,at) - implicit none - integer n,i,j - double precision a(n,n),at(n,n) - do i=1,n - do j=1,n - at(j,i)=a(i,j) - enddo - enddo - return - end -C--------------------------------------------------------------------------- - subroutine prodmat3(a1,a2,kk,transp,prod) -!DIR$ INLINEALWAYS prodmat3 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::prodmat3 -#endif - implicit none - integer i,j - double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) - logical transp -crc double precision auxmat(2,2),prod_(2,2) - - if (transp) then -crc call transpose2(kk(1,1),auxmat(1,1)) -crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) - - else -crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) - - endif -c call transpose2(a2(1,1),a2t(1,1)) - -crc print *,transp -crc print *,((prod_(i,j),i=1,2),j=1,2) -crc print *,((prod(i,j),i=1,2),j=1,2) - - return - end - diff --git a/source/unres/src_MD-M-newcorr/energy_p_new_barrier.F.safe b/source/unres/src_MD-M-newcorr/energy_p_new_barrier.F.safe deleted file mode 100644 index 828b4cd..0000000 --- a/source/unres/src_MD-M-newcorr/energy_p_new_barrier.F.safe +++ /dev/null @@ -1,8916 +0,0 @@ - subroutine etotal(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.LOCAL' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' -#ifdef MPI -c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, -c & " nfgtasks",nfgtasks - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR) -c print *,"Processor",myrank," BROADCAST iorder" -C FG master sets up the WEIGHTS_ array which will be broadcast to the -C FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -C FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -C FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - endif - time_Bcast=time_Bcast+MPI_Wtime()-time00 - time_Bcastw=time_Bcastw+MPI_Wtime()-time00 -c call chainbuild_cart - endif -c print *,'Processor',myrank,' calling etotal ipot=',ipot -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#else -c if (modecalc.eq.12.or.modecalc.eq.14) then -c call int_from_cart1(.false.) -c endif -#endif -#ifdef TIMING - time00=MPI_Wtime() -#endif -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105,106) ipot -C Lennard-Jones potential. - 101 call elj(evdw) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk(evdw) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp(evdw) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb(evdw) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv(evdw) - goto 107 -C Soft-sphere potential - 106 call e_softsphere(evdw) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 continue -c print *,"Processor",myrank," computed USCSC" -#ifdef TIMING - time01=MPI_Wtime() -#endif - call vec_and_deriv -#ifdef TIMING - time_vec=time_vec+MPI_Wtime()-time01 -#endif -c print *,"Processor",myrank," left VEC_AND_DERIV" - if (ipot.lt.6) then -#ifdef SPLITELE - if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#else - if (welec.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#endif - call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) - else - ees=0.0d0 - evdw1=0.0d0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 - endif - else -c write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, - & eello_turn4) - endif -c print *,"Processor",myrank," computed UELEC" -C -C Calculate excluded-volume interaction energy between peptide groups -C and side chains. -C - if (ipot.lt.6) then - if(wscp.gt.0d0) then - call escp(evdw2,evdw2_14) - else - evdw2=0 - evdw2_14=0 - endif - else -c write (iout,*) "Soft-sphere SCP potential" - call escp_soft_sphere(evdw2,evdw2_14) - endif -c -c Calculate the bond-stretching energy -c - call ebond(estr) -C -C Calculate the disulfide-bridge and other energy and the contributions -C from other distance constraints. -cd print *,'Calling EHPB' - call edis(ehpb) -cd print *,'EHPB exitted succesfully.' -C -C Calculate the virtual-bond-angle energy. -C - if (wang.gt.0d0) then - call ebend(ebe) - else - ebe=0 - endif -c print *,"Processor",myrank," computed UB" -C -C Calculate the SC local energy. -C - call esc(escloc) -c print *,"Processor",myrank," computed USC" -C -C Calculate the virtual-bond torsional energy. -C -cd print *,'nterm=',nterm - if (wtor.gt.0) then - call etor(etors,edihcnstr) - else - etors=0 - edihcnstr=0 - endif -c print *,"Processor",myrank," computed Utor" -C -C 6/23/01 Calculate double-torsional energy -C - if (wtor_d.gt.0) then - call etor_d(etors_d) - else - etors_d=0 - endif -c print *,"Processor",myrank," computed Utord" -C -C 21/5/07 Calculate local sicdechain correlation energy -C - if (wsccor.gt.0.0d0) then - call eback_sc_corr(esccor) - else - esccor=0.0d0 - endif -c print *,"Processor",myrank," computed Usccorr" -C -C 12/1/95 Multi-body terms -C - n_corr=0 - n_corr1=0 - if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 - & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then - call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1, -cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -cd write (iout,*) "multibody_hb ecorr",ecorr - endif -c print *,"Processor",myrank," computed Ucorr" -C -C If performing constraint dynamics, call the constraint energy -C after the equilibration time - if(usampl.and.totT.gt.eq_time) then - call EconstrQ - call Econstr_back - else - Uconst=0.0d0 - Uconst_back=0.0d0 - endif -#ifdef TIMING - time_enecalc=time_enecalc+MPI_Wtime()-time00 -#endif -c print *,"Processor",myrank," computed Uconstr" -#ifdef TIMING - time00=MPI_Wtime() -#endif -c -C Sum the energies -C - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(19)=edihcnstr - energia(17)=estr - energia(20)=Uconst+Uconst_back - energia(21)=esccor -c print *," Processor",myrank," calls SUM_ENERGY" - call sum_energy(energia,.true.) -c print *," Processor",myrank," left SUM_ENERGY" -#ifdef TIMING - time_sumene=time_sumene+MPI_Wtime()-time00 -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sum_energy(energia,reduce) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene),enebuff(0:n_ene+1) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - logical reduce -#ifdef MPI - if (nfgtasks.gt.1 .and. reduce) then -#ifdef DEBUG - write (iout,*) "energies before REDUCE" - call enerprint(energia) - call flush(iout) -#endif - do i=0,n_ene - enebuff(i)=energia(i) - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_e=time_barrier_e+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(enebuff(0),energia(0),n_ene+1, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) -#ifdef DEBUG - write (iout,*) "energies after REDUCE" - call enerprint(energia) - call flush(iout) -#endif - time_Reduce=time_Reduce+MPI_Wtime()-time00 - endif - if (fg_rank.eq.0) then -#endif - evdw=energia(1) -#ifdef SCP14 - evdw2=energia(2)+energia(18) - evdw2_14=energia(18) -#else - evdw2=energia(2) -#endif -#ifdef SPLITELE - ees=energia(3) - evdw1=energia(16) -#else - ees=energia(3) - evdw1=0.0d0 -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eturn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor -#else - etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor -#endif - energia(0)=etot -c detecting NaNQ -#ifdef ISNAN -#ifdef AIX - if (isnan(etot).ne.0) energia(0)=1.0d+99 -#else - if (isnan(etot)) energia(0)=1.0d+99 -#endif -#else - i=0 -#ifdef WINPGI - idumm=proc_proc(etot,i) -#else - call proc_proc(etot,i) -#endif - if(i.eq.1)energia(0)=1.0d+99 -#endif -#ifdef MPI - endif -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sum_gradient - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include 'mpif.h' - double precision gradbufc(3,maxres),gradbufx(3,maxres), - & glocbuf(4*maxres),gradbufc_sum(3,maxres) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - include 'COMMON.MAXGRAD' -#ifdef TIMING - time01=MPI_Wtime() -#endif -#ifdef DEBUG - write (iout,*) "sum_gradient gvdwc, gvdwx" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef MPI -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (nfgtasks.gt.1 .and. fg_rank.eq.0) - & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif -C -C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient -C in virtual-bond-vector coordinates -C -#ifdef DEBUG -c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" -c do i=1,nres-1 -c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') -c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) -c enddo -c write (iout,*) "gel_loc_tur3 gel_loc_turn4" -c do i=1,nres-1 -c write (iout,'(i5,3f10.5,2x,f10.5)') -c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) -c enddo - write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3), - & g_corr5_loc(i) - enddo - call flush(iout) -#endif -#ifdef SPLITELE - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i) - enddo - enddo -#else - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+ - & wbond*gradb(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i) - enddo - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -#ifdef DEBUG - write (iout,*) "gradbufc before allreduce" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -#ifdef DEBUG - write (iout,*) "gradbufc_sum after allreduce" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef TIMING - time_allreduce=time_allreduce+MPI_Wtime()-time00 -#endif - do i=nnt,nres - do k=1,3 - gradbufc(k,i)=0.0d0 - enddo - enddo -#ifdef DEBUG - write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end - write (iout,*) (i," jgrad_start",jgrad_start(i), - & " jgrad_end ",jgrad_end(i), - & i=igrad_start,igrad_end) -#endif -c -c Obsolete and inefficient code; we can make the effort O(n) and, therefore, -c do not parallelize this part. -c -c do i=igrad_start,igrad_end -c do j=jgrad_start(i),jgrad_end(i) -c do k=1,3 -c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) -c enddo -c enddo -c enddo - do j=1,3 - gradbufc(j,nres-1)=gradbufc_sum(j,nres) - enddo - do i=nres-2,nnt,-1 - do j=1,3 - gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) - enddo - enddo -#ifdef DEBUG - write (iout,*) "gradbufc after summing" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - else -#endif -#ifdef DEBUG - write (iout,*) "gradbufc" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - do i=1,nres - do j=1,3 - gradbufc_sum(j,i)=gradbufc(j,i) - gradbufc(j,i)=0.0d0 - enddo - enddo - do j=1,3 - gradbufc(j,nres-1)=gradbufc_sum(j,nres) - enddo - do i=nres-2,nnt,-1 - do j=1,3 - gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) - enddo - enddo -c do i=nnt,nres-1 -c do k=1,3 -c gradbufc(k,i)=0.0d0 -c enddo -c do j=i+1,nres -c do k=1,3 -c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) -c enddo -c enddo -c enddo -#ifdef DEBUG - write (iout,*) "gradbufc after summing" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef MPI - endif -#endif - do k=1,3 - gradbufc(k,nres)=0.0d0 - enddo - do i=1,nct - do j=1,3 -#ifdef SPLITELE -c gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ - gradc(j,i,icg)=welec*gelc(j,i)+ - & wel_loc*gel_loc(j,i)+ - & 0.5d0*(wscp*gvdwc_scpp(j,i)+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i))+ - & wbond*gradb(j,i)+ - & wcorr*gradcorr(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) -#else -c gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ - gradc(j,i,icg)=welec*gelc(j,i)+ - & wel_loc*gel_loc(j,i)+ - & 0.5d0*(wscp*gvdwc_scpp(j,i)+ - & welec*gelc_long(j,i) - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i))+ - & wbond*gradb(j,i)+ - & wcorr*gradcorr(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) -#endif - gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*gsccorx(j,i) - & +wscloc*gsclocx(j,i) - enddo - enddo -#ifdef DEBUG - write (iout,*) "gloc before adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) - & +wcorr5*g_corr5_loc(i) - & +wcorr6*g_corr6_loc(i) - & +wturn4*gel_loc_turn4(i) - & +wturn3*gel_loc_turn3(i) - & +wturn6*gel_loc_turn6(i) - & +wel_loc*gel_loc_loc(i) - & +wsccor*gsccor_loc(i) - enddo -#ifdef DEBUG - write (iout,*) "gloc after adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - do j=1,3 - do i=1,nres - gradbufc_sum(j,i)=gradc(j,i,icg) - gradbufx(j,i)=gradx(j,i,icg) - enddo - enddo - do i=1,4*nres - glocbuf(i)=gloc(i,icg) - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_g=time_barrier_g+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(gradbufc_sum(1,1),gradc(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -#ifdef DEBUG - write (iout,*) "gloc after reduce" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - endif -#endif - do i=1,nres - do j=1,3 - gradc(j,i,icg)=gradc(j,i,icg)+gradbufc(j,i) - enddo - enddo - if (gnorm_check) then -c -c Compute the maximum elements of the gradient -c - gvdwc_max=0.0d0 - gvdwc_scp_max=0.0d0 - gelc_max=0.0d0 - gvdwpp_max=0.0d0 - gradb_max=0.0d0 - ghpbc_max=0.0d0 - gradcorr_max=0.0d0 - gel_loc_max=0.0d0 - gcorr3_turn_max=0.0d0 - gcorr4_turn_max=0.0d0 - gradcorr5_max=0.0d0 - gradcorr6_max=0.0d0 - gcorr6_turn_max=0.0d0 - gsccorc_max=0.0d0 - gscloc_max=0.0d0 - gvdwx_max=0.0d0 - gradx_scp_max=0.0d0 - ghpbx_max=0.0d0 - gradxorr_max=0.0d0 - gsccorx_max=0.0d0 - gsclocx_max=0.0d0 - do i=1,nct - gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) - if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm - gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i))) - if (gvdwc_scp_norm.gt.gvdwc_scp_max) - & gvdwc_scp_max=gvdwc_scp_norm - gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i))) - if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm - gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i))) - if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm - gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i))) - if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm - ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i))) - if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm - gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i))) - if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm - gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i))) - if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm - gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i), - & gcorr3_turn(1,i))) - if (gcorr3_turn_norm.gt.gcorr3_turn_max) - & gcorr3_turn_max=gcorr3_turn_norm - gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i), - & gcorr4_turn(1,i))) - if (gcorr4_turn_norm.gt.gcorr4_turn_max) - & gcorr4_turn_max=gcorr4_turn_norm - gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i))) - if (gradcorr5_norm.gt.gradcorr5_max) - & gradcorr5_max=gradcorr5_norm - gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i))) - if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm - gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i), - & gcorr6_turn(1,i))) - if (gcorr6_turn_norm.gt.gcorr6_turn_max) - & gcorr6_turn_max=gcorr6_turn_norm - gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) - if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm - gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) - if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm - gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) - if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm - gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i))) - if (gradx_scp_norm.gt.gradx_scp_max) - & gradx_scp_max=gradx_scp_norm - ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i))) - if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm - gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i))) - if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm - gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i))) - if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm - gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i))) - if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm - enddo - if (gradout) then -#ifdef AIX - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif - write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max, - & gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max - close(istat) - if (gvdwc_max.gt.1.0d4) then - write (iout,*) "gvdwc gvdwx gradb gradbx" - do i=nnt,nct - write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i), - & gradb(j,i),gradbx(j,i),j=1,3) - enddo - call pdbout(0.0d0,'cipiszcze',iout) - call flush(iout) - endif - endif - endif -#ifdef DEBUG - write (iout,*) "gradc gradx gloc" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) - enddo -#endif -#ifdef TIMING - time_sumgradient=time_sumgradient+MPI_Wtime()-time01 -#endif - return - end -c------------------------------------------------------------------------------- - subroutine rescale_weights(t_bath) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - double precision kfac /2.4d0/ - double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/ -c facT=temp0/t_bath -c facT=2*temp0/(t_bath+temp0) - if (rescale_mode.eq.0) then - facT=1.0d0 - facT2=1.0d0 - facT3=1.0d0 - facT4=1.0d0 - facT5=1.0d0 - else if (rescale_mode.eq.1) then - facT=kfac/(kfac-1.0d0+t_bath/temp0) - facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) - facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) - facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) - facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) - else if (rescale_mode.eq.2) then - x=t_bath/temp0 - x2=x*x - x3=x2*x - x4=x3*x - x5=x4*x - facT=licznik/dlog(dexp(x)+dexp(-x)) - facT2=licznik/dlog(dexp(x2)+dexp(-x2)) - facT3=licznik/dlog(dexp(x3)+dexp(-x3)) - facT4=licznik/dlog(dexp(x4)+dexp(-x4)) - facT5=licznik/dlog(dexp(x5)+dexp(-x5)) - else - write (iout,*) "Wrong RESCALE_MODE",rescale_mode - write (*,*) "Wrong RESCALE_MODE",rescale_mode -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) -#endif - stop 555 - endif - welec=weights(3)*fact - wcorr=weights(4)*fact3 - wcorr5=weights(5)*fact4 - wcorr6=weights(6)*fact5 - wel_loc=weights(7)*fact2 - wturn3=weights(8)*fact2 - wturn4=weights(9)*fact3 - wturn6=weights(10)*fact5 - wtor=weights(13)*fact - wtor_d=weights(14)*fact2 - wsccor=weights(21)*fact - - return - end -C------------------------------------------------------------------------ - subroutine enerprint(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.MD' - double precision energia(0:n_ene) - etot=energia(0) - evdw=energia(1) - evdw2=energia(2) -#ifdef SCP14 - evdw2=energia(2)+energia(18) -#else - evdw2=energia(2) -#endif - ees=energia(3) -#ifdef SPLITELE - evdw1=energia(16) -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eello_turn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor, - & edihcnstr,ebr*nss, - & Uconst,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST= ',1pE16.6,' (Constraint energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#else - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr, - & ebr*nss,Uconst,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST=',1pE16.6,' (Constraint energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#endif - return - end -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' - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.21) cycle - 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) - if (itypj.eq.21) 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(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+evdwij -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) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - 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 -C -C 12/1/95, revised on 5/20/97 -C -C Calculate the contact function. The ith column of the array JCONT will -C contain the numbers of atoms that make contacts with the atom I (of numbers -C greater than I). The arrays FACONT and GACONT will contain the values of -C the contact function and its derivative. -C -C Uncomment next line, if the correlation interactions include EVDW explicitly. -c if (j.gt.i+1 .and. evdwij.le.0.0D0) then -C Uncomment next line, if the correlation interactions are contact function only - if (j.gt.i+1.and. eps0ij.gt.0.0D0) then - rij=dsqrt(rij) - sigij=sigma(itypi,itypj) - r0ij=rs0(itypi,itypj) -C -C Check whether the SC's are not too far to make a contact. -C - rcut=1.5d0*r0ij - call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) -C Add a new contact, if the SC's are close enough, but not too close (ri' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - return - end -C----------------------------------------------------------------------------- - subroutine escp(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) - if (itypj.eq.21) cycle -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+e1+e2 - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw2',i,j,evdwij -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -cgrad if (j.lt.i) then -cd write (iout,*) 'ji' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time the factor EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C-------------------------------------------------------------------------- - subroutine edis(ehpb) -C -C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - dimension ggg(3) - ehpb=0.0D0 -cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr -cd write(iout,*)'link_start=',link_start,' link_end=',link_end - if (link_end.eq.0) return - do i=link_start,link_end -C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a -C CA-CA distance used in regularization of structure. - ii=ihpb(i) - jj=jhpb(i) -C iii and jjj point to the residues for which the distance is assigned. - if (ii.gt.nres) then - iii=ii-nres - jjj=jj-nres - else - iii=ii - jjj=jj - endif -cd write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj -C 24/11/03 AL: SS bridges handled separately because of introducing a specific -C distance and angle dependent SS bond potential. - if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then - call ssbond_ene(iii,jjj,eij) - ehpb=ehpb+2*eij -cd write (iout,*) "eij",eij - else -C Calculate the distance between the two points and its difference from the -C target distance. - dd=dist(ii,jj) - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd -cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, -cd & ' waga=',waga,' fac=',fac - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo -cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) -C If this is a SC-SC distance, we need to calculate the contributions to the -C Cartesian gradient in the SC vectors (ghpbx). - if (iii.lt.ii) then - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - endif -cgrad do j=iii,jjj-1 -cgrad do k=1,3 -cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k) -cgrad enddo -cgrad enddo - do k=1,3 - ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) - ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) - enddo - endif - enddo - ehpb=0.5D0*ehpb - return - end -C-------------------------------------------------------------------------- - subroutine ssbond_ene(i,j,eij) -C -C Calculate the distance and angle dependent SS-bond potential energy -C using a free-energy function derived based on RHF/6-31G** ab initio -C calculations of diethyl disulfide. -C -C A. Liwo and U. Kozlowska, 11/24/03 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - double precision erij(3),dcosom1(3),dcosom2(3),gg(3) - itypi=itype(i) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(nres+i) - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(nres+j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - erij(1)=xj*rij - erij(2)=yj*rij - erij(3)=zj*rij - om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) - om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) - om12=dxi*dxj+dyi*dyj+dzi*dzj - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - rij=1.0d0/rij - deltad=rij-d0cm - deltat1=1.0d0-om1 - deltat2=1.0d0+om2 - deltat12=om2-om1+2.0d0 - cosphi=om12-om1*om2 - eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) - & +akct*deltad*deltat12 - & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi -c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, -c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, -c & " deltat12",deltat12," eij",eij - ed=2*akcm*deltad+akct*deltat12 - pom1=akct*deltad - pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi - eom1=-2*akth*deltat1-pom1-om2*pom2 - eom2= 2*akth*deltat2+pom1-om1*pom2 - eom12=pom2 - do k=1,3 - ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) - ghpbx(k,i)=ghpbx(k,i)-ggk - & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv - ghpbx(k,j)=ghpbx(k,j)+ggk - & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - ghpbc(k,i)=ghpbc(k,i)-ggk - ghpbc(k,j)=ghpbc(k,j)+ggk - enddo -C -C Calculate the components of the gradient in DC and X -C -cgrad do k=i,j-1 -cgrad do l=1,3 -cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l) -cgrad enddo -cgrad enddo - return - end -C-------------------------------------------------------------------------- - subroutine ebond(estr) -c -c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - double precision u(3),ud(3) - estr=0.0d0 - estr1=0.0d0 - do i=ibondp_start,ibondp_end - if (itype(i-1).eq.21 .or. itype(i).eq.21) then - estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) - do j=1,3 - gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) - & *dc(j,i-1)/vbld(i) - enddo - if (energy_dec) write(iout,*) - & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax) - else - diff = vbld(i)-vbldp0 - if (energy_dec) write (iout,*) - & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff - estr=estr+diff*diff - do j=1,3 - gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) - enddo -c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) - endif - 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=ibond_start,ibond_end - iti=itype(i) - if (iti.ne.10 .and. iti.ne.21) then - nbi=nbondterm(iti) - if (nbi.eq.1) then - diff=vbld(i+nres)-vbldsc0(1,iti) - if (energy_dec) write (iout,*) - & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff, - & AKSC(1,iti),AKSC(1,iti)*diff*diff - estr=estr+0.5d0*AKSC(1,iti)*diff*diff - do j=1,3 - gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) - enddo - else - do j=1,nbi - diff=vbld(i+nres)-vbldsc0(j,iti) - ud(j)=aksc(j,iti)*diff - u(j)=abond0(j,iti)+0.5d0*ud(j)*diff - enddo - uprod=u(1) - do j=2,nbi - uprod=uprod*u(j) - enddo - usum=0.0d0 - usumsqder=0.0d0 - do j=1,nbi - uprod1=1.0d0 - uprod2=1.0d0 - do k=1,nbi - if (k.ne.j) then - uprod1=uprod1*u(k) - uprod2=uprod2*u(k)*u(k) - endif - enddo - usum=usum+uprod1 - usumsqder=usumsqder+ud(j)*uprod2 - enddo - estr=estr+uprod/usum - do j=1,3 - gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) - enddo - endif - endif - enddo - return - end -#ifdef CRYST_THETA -C-------------------------------------------------------------------------- - subroutine ebend(etheta) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - double precision y(2),z(2) - delta=0.02d0*pi -c time11=dexp(-2*time) -c time12=1.0d0 - etheta=0.0D0 -c write (*,'(a,i2)') 'EBEND ICG=',icg - do i=ithet_start,ithet_end - if (itype(i-1).eq.21) 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) - if (i.gt.3 .and. itype(i-2).ne.21) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - y(1)=dcos(phii) - y(2)=dsin(phii) - else - y(1)=0.0D0 - y(2)=0.0D0 - endif - if (i.lt.nres .and. itype(i).ne.21) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) - z(1)=cos(phii1) -#else - phii1=phi(i+1) - z(1)=dcos(phii1) -#endif - z(2)=dsin(phii1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif -C Calculate the "mean" value of theta from the part of the distribution -C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). -C In following comments this theta will be referred to as t_c. - thet_pred_mean=0.0d0 - do k=1,2 - athetk=athet(k,it) - bthetk=bthet(k,it) - thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) - enddo - dthett=thet_pred_mean*ssd - thet_pred_mean=thet_pred_mean*ss+a0thet(it) -C Derivatives of the "mean" values in gamma1 and gamma2. - dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss - dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss - if (theta(i).gt.pi-delta) then - call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, - & E_tc0) - call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) - call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, - & E_theta) - call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else if (theta(i).lt.delta) then - call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) - call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, - & E_theta) - call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) - call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else - call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, - & E_theta,E_tc) - endif - etheta=etheta+ethetai - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'ebend',i,ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 - gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) - enddo -C Ufff.... We've done all this!!! - return - end -C--------------------------------------------------------------------------- - subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, - & E_tc) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it -C Calculate the contributions to both Gaussian lobes. -C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) -C The "polynomial part" of the "standard deviation" of this part of -C the distribution. - sig=polthet(3,it) - do j=2,0,-1 - sig=sig*thet_pred_mean+polthet(j,it) - enddo -C Derivative of the "interior part" of the "standard deviation of the" -C gamma-dependent Gaussian lobe in t_c. - sigtc=3*polthet(3,it) - do j=2,1,-1 - sigtc=sigtc*thet_pred_mean+j*polthet(j,it) - enddo - sigtc=sig*sigtc -C Set the parameters of both Gaussian lobes of the distribution. -C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) - fac=sig*sig+sigc0(it) - sigcsq=fac+fac - sigc=1.0D0/sigcsq -C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c - sigsqtc=-4.0D0*sigcsq*sigtc -c print *,i,sig,sigtc,sigsqtc -C Following variable (sigtc) is d[sigma(t_c)]/dt_c - sigtc=-sigtc/(fac*fac) -C Following variable is sigma(t_c)**(-2) - sigcsq=sigcsq*sigcsq - sig0i=sig0(it) - sig0inv=1.0D0/sig0i**2 - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i - term1=-0.5D0*sigcsq*delthec*delthec - term2=-0.5D0*sig0inv*delthe0*delthe0 -C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and -C NaNs in taking the logarithm. We extract the largest exponent which is added -C to the energy (this being the log of the distribution) at the end of energy -C term evaluation for this virtual-bond angle. - if (term1.gt.term2) then - termm=term1 - term2=dexp(term2-termm) - term1=1.0d0 - else - termm=term2 - term1=dexp(term1-termm) - term2=1.0d0 - endif -C The ratio between the gamma-independent and gamma-dependent lobes of -C the distribution is a Gaussian function of thet_pred_mean too. - diffak=gthet(2,it)-thet_pred_mean - ratak=diffak/gthet(3,it)**2 - ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) -C Let's differentiate it in thet_pred_mean NOW. - aktc=ak*ratak -C Now put together the distribution terms to make complete distribution. - termexp=term1+ak*term2 - termpre=sigc+ak*sig0i -C Contribution of the bending energy from this theta is just the -log of -C the sum of the contributions from the two lobes and the pre-exponential -C factor. Simple enough, isn't it? - ethetai=(-dlog(termexp)-termm+dlog(termpre)) -C NOW the derivatives!!! -C 6/6/97 Take into account the deformation. - E_theta=(delthec*sigcsq*term1 - & +ak*delthe0*sig0inv*term2)/termexp - E_tc=((sigtc+aktc*sig0i)/termpre - & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ - & aktc*term2)/termexp) - return - end -c----------------------------------------------------------------------------- - subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i -C "Thank you" to MAPLE (probably spared one day of hand-differentiation). - t3 = thetai-thet_pred_mean - t6 = t3**2 - t9 = term1 - t12 = t3*sigcsq - t14 = t12+t6*sigsqtc - t16 = 1.0d0 - t21 = thetai-theta0i - t23 = t21**2 - t26 = term2 - t27 = t21*t26 - t32 = termexp - t40 = t32**2 - E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 - & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 - & *(-t12*t9-ak*sig0inv*t27) - return - end -#else -C-------------------------------------------------------------------------- - subroutine ebend(etheta) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C ab initio-derived potentials from -c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), - & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), - & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), - & sinph1ph2(maxdouble,maxdouble) - logical lprn /.false./, lprn1 /.false./ - etheta=0.0D0 - do i=ithet_start,ithet_end - if (itype(i-1).eq.21) cycle - dethetai=0.0d0 - dephii=0.0d0 - dephii1=0.0d0 - theti2=0.5d0*theta(i) - ityp2=ithetyp(itype(i-1)) - do k=1,nntheterm - coskt(k)=dcos(k*theti2) - sinkt(k)=dsin(k*theti2) - enddo - if (i.gt.3) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - ityp1=ithetyp(itype(i-2)) - do k=1,nsingle - cosph1(k)=dcos(k*phii) - sinph1(k)=dsin(k*phii) - enddo - else - phii=0.0d0 - ityp1=nthetyp+1 - do k=1,nsingle - cosph1(k)=0.0d0 - sinph1(k)=0.0d0 - enddo - endif - if (i.lt.nres) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) -#else - phii1=phi(i+1) -#endif - ityp3=ithetyp(itype(i)) - do k=1,nsingle - cosph2(k)=dcos(k*phii1) - sinph2(k)=dsin(k*phii1) - enddo - else - phii1=0.0d0 - ityp3=nthetyp+1 - do k=1,nsingle - cosph2(k)=0.0d0 - sinph2(k)=0.0d0 - enddo - endif - ethetai=aa0thet(ityp1,ityp2,ityp3) - do k=1,ndouble - do l=1,k-1 - ccl=cosph1(l)*cosph2(k-l) - ssl=sinph1(l)*sinph2(k-l) - scl=sinph1(l)*cosph2(k-l) - csl=cosph1(l)*sinph2(k-l) - cosph1ph2(l,k)=ccl-ssl - cosph1ph2(k,l)=ccl+ssl - sinph1ph2(l,k)=scl+csl - sinph1ph2(k,l)=scl-csl - enddo - enddo - if (lprn) then - write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, - & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 - write (iout,*) "coskt and sinkt" - do k=1,nntheterm - write (iout,*) k,coskt(k),sinkt(k) - enddo - endif - do k=1,ntheterm - ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k) - dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3) - & *coskt(k) - if (lprn) - & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), - & " ethetai",ethetai - enddo - if (lprn) then - write (iout,*) "cosph and sinph" - do k=1,nsingle - write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) - enddo - write (iout,*) "cosph1ph2 and sinph2ph2" - do k=2,ndouble - do l=1,k-1 - write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), - & sinph1ph2(l,k),sinph1ph2(k,l) - enddo - enddo - write(iout,*) "ethetai",ethetai - endif - do m=1,ntheterm2 - do k=1,nsingle - aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k) - & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k) - & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k) - & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*aux*coskt(m) - dephii=dephii+k*sinkt(m)*( - & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)- - & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) - dephii1=dephii1+k*sinkt(m)*( - & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- - & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) - if (lprn) - & write (iout,*) "m",m," k",k," bbthet", - & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", - & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", - & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", - & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai - enddo - enddo - if (lprn) - & write(iout,*) "ethetai",ethetai - do m=1,ntheterm3 - do k=2,ndouble - do l=1,k-1 - aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*coskt(m)*aux - dephii=dephii+l*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)- - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - dephii1=dephii1+(k-l)*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)- - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - if (lprn) then - write (iout,*) "m",m," k",k," l",l," ffthet", - & ffthet(l,k,m,ityp1,ityp2,ityp3), - & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", - & ggthet(l,k,m,ityp1,ityp2,ityp3), - & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai - write (iout,*) cosph1ph2(l,k)*sinkt(m), - & cosph1ph2(k,l)*sinkt(m), - & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) - endif - enddo - enddo - enddo -10 continue - if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') - & i,theta(i)*rad2deg,phii*rad2deg, - & phii1*rad2deg,ethetai - etheta=etheta+ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 - gloc(nphi+i-2,icg)=wang*dethetai - enddo - return - end -#endif -#ifdef CRYST_SC -c----------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), - & ddersc0(3),ddummy(3),xtemp(3),temp(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 -c write (iout,'(a)') 'ESC' - do i=loc_start,loc_end - it=itype(i) - if (it.eq.21) cycle - if (it.eq.10) goto 1 - nlobit=nlob(it) -c print *,'i=',i,' it=',it,' nlobit=',nlobit -c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad - theti=theta(i+1)-pipol - x(1)=dtan(theti) - x(2)=alph(i) - x(3)=omeg(i) - - if (x(2).gt.pi-delta) then - xtemp(1)=x(1) - xtemp(2)=pi-delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=pi - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=pi-delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=pi - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - call splinthet(x(2),0.5d0*delta,ss,ssd) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c escloci=esclocbi -c write (iout,*) escloci - else if (x(2).lt.delta) then - xtemp(1)=x(1) - xtemp(2)=delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=0.0d0 - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=0.0d0 - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - call splinthet(x(2),0.5d0*delta,ss,ssd) - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c write (iout,*) escloci - else - call enesc(x,escloci,dersc,ddummy,.false.) - endif - - escloc=escloc+escloci - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'escloc',i,escloci -c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc - - gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ - & wscloc*dersc(1) - gloc(ialph(i,1),icg)=wscloc*dersc(2) - gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) - 1 continue - enddo - return - end -C--------------------------------------------------------------------------- - subroutine enesc(x,escloci,dersc,ddersc,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) - double precision contr(maxlob,-1:1) - logical mixed -c write (iout,*) 'it=',it,' nlobit=',nlobit - escloc_i=0.0D0 - do j=1,3 - dersc(j)=0.0D0 - if (mixed) ddersc(j)=0.0d0 - enddo - x3=x(3) - -C Because of periodicity of the dependence of the SC energy in omega we have -C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). -C To avoid underflows, first compute & store the exponents. - - do iii=-1,1 - - x(3)=x3+iii*dwapi - - do j=1,nlobit - do k=1,3 - z(k)=x(k)-censc(k,j,it) - enddo - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j,iii)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j,iii)*z(k) - enddo - contr(j,iii)=expfac - enddo ! j - - enddo ! iii - - x(3)=x3 -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1,-1) - do iii=-1,1 - do j=1,nlobit - if (emin.gt.contr(j,iii)) emin=contr(j,iii) - enddo - enddo - emin=0.5D0*emin -cd print *,'it=',it,' emin=',emin - -C Compute the contribution to SC energy and derivatives - do iii=-1,1 - - do j=1,nlobit -#ifdef OSF - adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin - if(adexp.ne.adexp) adexp=1.0 - expfac=dexp(adexp) -#else - expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin) -#endif -cd print *,'j=',j,' expfac=',expfac - escloc_i=escloc_i+expfac - do k=1,3 - dersc(k)=dersc(k)+Ax(k,j,iii)*expfac - enddo - if (mixed) then - do k=1,3,2 - ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) - & +gaussc(k,2,j,it))*expfac - enddo - endif - enddo - - enddo ! iii - - dersc(1)=dersc(1)/cos(theti)**2 - ddersc(1)=ddersc(1)/cos(theti)**2 - ddersc(3)=ddersc(3) - - escloci=-(dlog(escloc_i)-emin) - do j=1,3 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) then - do j=1,3,2 - ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) - enddo - endif - return - end -C------------------------------------------------------------------------------ - subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob),dersc(3) - double precision contr(maxlob) - logical mixed - - escloc_i=0.0D0 - - do j=1,3 - dersc(j)=0.0D0 - enddo - - do j=1,nlobit - do k=1,2 - z(k)=x(k)-censc(k,j,it) - enddo - z(3)=dwapi - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j)*z(k) - enddo - contr(j)=expfac - enddo ! j - -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1) - do j=1,nlobit - if (emin.gt.contr(j)) emin=contr(j) - enddo - emin=0.5D0*emin - -C Compute the contribution to SC energy and derivatives - - dersc12=0.0d0 - do j=1,nlobit - expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin) - escloc_i=escloc_i+expfac - do k=1,2 - dersc(k)=dersc(k)+Ax(k,j)*expfac - enddo - if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) - & +gaussc(1,2,j,it))*expfac - dersc(3)=0.0d0 - enddo - - dersc(1)=dersc(1)/cos(theti)**2 - dersc12=dersc12/cos(theti)**2 - escloci=-(dlog(escloc_i)-emin) - do j=1,2 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) - return - end -#else -c---------------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA derived from AM1 all-atom calculations. -C added by Urszula Kozlowska. 07/11/2007 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.SCROT' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - include 'COMMON.VECTORS' - double precision x_prime(3),y_prime(3),z_prime(3) - & , sumene,dsc_i,dp2_i,x(65), - & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, - & de_dxx,de_dyy,de_dzz,de_dt - double precision s1_t,s1_6_t,s2_t,s2_6_t - double precision - & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), - & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), - & dt_dCi(3),dt_dCi1(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 - do i=loc_start,loc_end - if (itype(i).eq.21) 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=itype(i) - if (it.eq.10) goto 1 -c -C Compute the axes of tghe local cartesian coordinates system; store in -c x_prime, y_prime and z_prime -c - do j=1,3 - x_prime(j) = 0.00 - y_prime(j) = 0.00 - z_prime(j) = 0.00 - enddo -C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), -C & dc_norm(3,i+nres) - do j = 1,3 - x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac - y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac - enddo - do j = 1,3 - z_prime(j) = -uz(j,i-1) - enddo -c write (2,*) "i",i -c write (2,*) "x_prime",(x_prime(j),j=1,3) -c write (2,*) "y_prime",(y_prime(j),j=1,3) -c write (2,*) "z_prime",(z_prime(j),j=1,3) -c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), -c & " xy",scalar(x_prime(1),y_prime(1)), -c & " xz",scalar(x_prime(1),z_prime(1)), -c & " yy",scalar(y_prime(1),y_prime(1)), -c & " yz",scalar(y_prime(1),z_prime(1)), -c & " zz",scalar(z_prime(1),z_prime(1)) -c -C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), -C to local coordinate system. Store in xx, yy, zz. -c - xx=0.0d0 - yy=0.0d0 - zz=0.0d0 - do j = 1,3 - xx = xx + x_prime(j)*dc_norm(j,i+nres) - yy = yy + y_prime(j)*dc_norm(j,i+nres) - zz = zz + z_prime(j)*dc_norm(j,i+nres) - enddo - - xxtab(i)=xx - yytab(i)=yy - zztab(i)=zz -C -C Compute the energy of the ith side cbain -C -c write (2,*) "xx",xx," yy",yy," zz",zz - it=itype(i) - do j = 1,65 - x(j) = sc_parmin(j,it) - enddo -#ifdef CHECK_COORD -Cc diagnostics - remove later - xx1 = dcos(alph(2)) - yy1 = dsin(alph(2))*dcos(omeg(2)) - zz1 = -dsin(alph(2))*dsin(omeg(2)) - write(2,'(3f8.1,3f9.3,1x,3f9.3)') - & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, - & xx1,yy1,zz1 -C," --- ", xx_w,yy_w,zz_w -c end diagnostics -#endif - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) - & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) -c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, -c & sumene4, -c & dscp1,dscp2,sumene -c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - escloc = escloc + sumene -c write (2,*) "i",i," escloc",sumene,escloc -#ifdef DEBUG -C -C This section to check the numerical derivatives of the energy of ith side -C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert -C #define DEBUG in the code to turn it on. -C - write (2,*) "sumene =",sumene - aincr=1.0d-7 - xxsave=xx - xx=xx+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dxx_num=(sumenep-sumene)/aincr - xx=xxsave - write (2,*) "xx+ sumene from enesc=",sumenep - yysave=yy - yy=yy+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dyy_num=(sumenep-sumene)/aincr - yy=yysave - write (2,*) "yy+ sumene from enesc=",sumenep - zzsave=zz - zz=zz+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dzz_num=(sumenep-sumene)/aincr - zz=zzsave - write (2,*) "zz+ sumene from enesc=",sumenep - costsave=cost2tab(i+1) - sintsave=sint2tab(i+1) - cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) - sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dt_num=(sumenep-sumene)/aincr - write (2,*) " t+ sumene from enesc=",sumenep - cost2tab(i+1)=costsave - sint2tab(i+1)=sintsave -C End of diagnostics section. -#endif -C -C Compute the gradient of esc -C - pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 - pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 - pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 - pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 - pom_dx=dsc_i*dp2_i*cost2tab(i+1) - pom_dy=dsc_i*dp2_i*sint2tab(i+1) - pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) - pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) - pom1=(sumene3*sint2tab(i+1)+sumene1) - & *(pom_s1/dscp1+pom_s16*dscp1**4) - pom2=(sumene4*cost2tab(i+1)+sumene2) - & *(pom_s2/dscp2+pom_s26*dscp2**4) - sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy - sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 - & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) - & +x(40)*yy*zz - sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy - sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 - & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) - & +x(60)*yy*zz - de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) - & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) - & +(pom1+pom2)*pom_dx -#ifdef DEBUG - write(2,*), "de_dxx = ", de_dxx,de_dxx_num -#endif -C - sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz - sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 - & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) - & +x(40)*xx*zz - sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz - sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz - & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz - & +x(59)*zz**2 +x(60)*xx*zz - de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) - & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) - & +(pom1-pom2)*pom_dy -#ifdef DEBUG - write(2,*), "de_dyy = ", de_dyy,de_dyy_num -#endif -C - de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy - & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx - & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) - & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) - & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 - & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy - & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) - & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) -#ifdef DEBUG - write(2,*), "de_dzz = ", de_dzz,de_dzz_num -#endif -C - de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) - & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) - & +pom1*pom_dt1+pom2*pom_dt2 -#ifdef DEBUG - write(2,*), "de_dt = ", de_dt,de_dt_num -#endif -c -C - cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) - cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) - cosfac2xx=cosfac2*xx - sinfac2yy=sinfac2*yy - do k = 1,3 - dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* - & vbld_inv(i+1) - dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* - & vbld_inv(i) - pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) - pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) -c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, -c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) -c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), -c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) - dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx - dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx - dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy - dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy - dZZ_Ci1(k)=0.0d0 - dZZ_Ci(k)=0.0d0 - do j=1,3 - dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres) - dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres) - enddo - - dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) - dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) - dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) -c - dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) - dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) - enddo - - do k=1,3 - dXX_Ctab(k,i)=dXX_Ci(k) - dXX_C1tab(k,i)=dXX_Ci1(k) - dYY_Ctab(k,i)=dYY_Ci(k) - dYY_C1tab(k,i)=dYY_Ci1(k) - dZZ_Ctab(k,i)=dZZ_Ci(k) - dZZ_C1tab(k,i)=dZZ_Ci1(k) - dXX_XYZtab(k,i)=dXX_XYZ(k) - dYY_XYZtab(k,i)=dYY_XYZ(k) - dZZ_XYZtab(k,i)=dZZ_XYZ(k) - enddo - - do k = 1,3 -c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", -c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) -c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", -c & dyy_ci(k)," dzz_ci",dzz_ci(k) -c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", -c & dt_dci(k) -c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", -c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) - gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) - & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) - gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) - & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) - gsclocx(k,i)= de_dxx*dxx_XYZ(k) - & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) - enddo -c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), -c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) - -C to check gradient call subroutine check_grad - - 1 continue - enddo - return - end -c------------------------------------------------------------------------------ - double precision function enesc(x,xx,yy,zz,cost2,sint2) - implicit none - double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2, - & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6 - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2+yy*sint2)) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2-yy*sint2)) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) - & + (sumene4*cost2 +sumene2)*(s2+s2_6) - enesc=sumene - return - end -#endif -c------------------------------------------------------------------------------ - subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) -C -C This procedure calculates two-body contact function g(rij) and its derivative: -C -C eps0ij ! x < -1 -C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 -C 0 ! x > 1 -C -C where x=(rij-r0ij)/delta -C -C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy -C - implicit none - double precision rij,r0ij,eps0ij,fcont,fprimcont - double precision x,x2,x4,delta -c delta=0.02D0*r0ij -c delta=0.2D0*r0ij - x=(rij-r0ij)/delta - if (x.lt.-1.0D0) then - fcont=eps0ij - fprimcont=0.0D0 - else if (x.le.1.0D0) then - x2=x*x - x4=x2*x2 - fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) - fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta - else - fcont=0.0D0 - fprimcont=0.0D0 - endif - return - end -c------------------------------------------------------------------------------ - subroutine splinthet(theti,delta,ss,ssder) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - thetup=pi-delta - thetlow=delta - if (theti.gt.pipol) then - call gcont(theti,thetup,1.0d0,delta,ss,ssder) - else - call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) - ssder=-ssder - endif - return - end -c------------------------------------------------------------------------------ - subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) - implicit none - double precision x,x0,delta,f0,f1,fprim0,f,fprim - double precision ksi,ksi2,ksi3,a1,a2,a3 - a1=fprim0*delta/(f1-f0) - a2=3.0d0-2.0d0*a1 - a3=a1-2.0d0 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) - fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) - return - end -c------------------------------------------------------------------------------ - subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) - implicit none - double precision x,x0,delta,f0x,f1x,fprim0x,fx - double precision ksi,ksi2,ksi3,a1,a2,a3 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - a1=fprim0x*delta - a2=3*(f1x-f0x)-2*fprim0x*delta - a3=fprim0x*delta-2*(f1x-f0x) - fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 - return - end -C----------------------------------------------------------------------------- -#ifdef CRYST_TOR -C----------------------------------------------------------------------------- - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - etors_ii=0.0D0 - if (itype(i-2).eq.21 .or. itype(i-1).eq.21 - & .or. itype(i).eq.21) 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) - if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) - gloci=gloci-3*fac*etorsi*dsin(3*phii) - endif - do j=1,3 - v1ij=v1(j+1,itori,itori1) - v2ij=v2(j+1,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ - & v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - else - do j=1,nterm_old - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ - & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - endif - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - 'etor',i,etors_ii - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 - do i=1,ndih_constr - itori=idih_constr(i) - phii=phi(itori) - difi=phii-phi0(i) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - endif -! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, -! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -! write (iout,*) 'edihcnstr',edihcnstr - return - end -c------------------------------------------------------------------------------ - subroutine etor_d(etors_d) - etors_d=0.0d0 - return - end -c---------------------------------------------------------------------------- -#else - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - if (itype(i-2).eq.21 .or. itype(i-1).eq.21 - & .or. itype(i).eq.21) cycle - etors_ii=0.0D0 - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -C Regular cosine and sine terms - do j=1,nterm(itori,itori1) - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi - if (energy_dec) etors_ii=etors_ii+ - & v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo -C Lorentz terms -C v1 -C E = SUM ----------------------------------- - v1 -C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 -C - cosphi=dcos(0.5d0*phii) - sinphi=dsin(0.5d0*phii) - do j=1,nlor(itori,itori1) - vl1ij=vlor1(j,itori,itori1) - vl2ij=vlor2(j,itori,itori1) - vl3ij=vlor3(j,itori,itori1) - pom=vl2ij*cosphi+vl3ij*sinphi - pom1=1.0d0/(pom*pom+1.0d0) - etors=etors+vl1ij*pom1 - if (energy_dec) etors_ii=etors_ii+ - & vl1ij*pom1 - pom=-pom*pom1*pom1 - gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom - enddo -C Subtract the constant term - etors=etors-v0(itori,itori1) - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'etor',i,etors_ii-v0(itori,itori1) - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 -c do i=1,ndih_constr - do i=idihconstr_start,idihconstr_end - itori=idih_constr(i) - phii=phi(itori) - difi=pinorm(phii-phi0(i)) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else - difi=0.0 - endif -cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, -cd & rad2deg*phi0(i), rad2deg*drange(i), -cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -cd write (iout,*) 'edihcnstr',edihcnstr - return - end -c---------------------------------------------------------------------------- - subroutine etor_d(etors_d) -C 6/23/01 Compute double torsional energy - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors_d=0.0D0 - do i=iphid_start,iphid_end - if (itype(i-2).eq.21 .or. itype(i-1).eq.21 - & .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - itori2=itortyp(itype(i)) - phii=phi(i) - phii1=phi(i+1) - gloci1=0.0D0 - gloci2=0.0D0 -C Regular cosine and sine terms - do j=1,ntermd_1(itori,itori1,itori2) - v1cij=v1c(1,j,itori,itori1,itori2) - v1sij=v1s(1,j,itori,itori1,itori2) - v2cij=v1c(2,j,itori,itori1,itori2) - v2sij=v1s(2,j,itori,itori1,itori2) - cosphi1=dcos(j*phii) - sinphi1=dsin(j*phii) - cosphi2=dcos(j*phii1) - sinphi2=dsin(j*phii1) - etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ - & v2cij*cosphi2+v2sij*sinphi2 - gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) - gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) - enddo - do k=2,ntermd_2(itori,itori1,itori2) - do l=1,k-1 - v1cdij = v2c(k,l,itori,itori1,itori2) - v2cdij = v2c(l,k,itori,itori1,itori2) - v1sdij = v2s(k,l,itori,itori1,itori2) - v2sdij = v2s(l,k,itori,itori1,itori2) - cosphi1p2=dcos(l*phii+(k-l)*phii1) - cosphi1m2=dcos(l*phii-(k-l)*phii1) - sinphi1p2=dsin(l*phii+(k-l)*phii1) - sinphi1m2=dsin(l*phii-(k-l)*phii1) - etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ - & v1sdij*sinphi1p2+v2sdij*sinphi1m2 - gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) - gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) - enddo - enddo - gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 - gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 - enddo - return - end -#endif -c------------------------------------------------------------------------------ - subroutine eback_sc_corr(esccor) -c 7/21/2007 Correlations between the backbone-local and side-chain-local -c conformational states; temporarily implemented as differences -c between UNRES torsional potentials (dependent on three types of -c residues) and the torsional potentials dependent on all 20 types -c of residues computed from AM1 energy surfaces of terminally-blocked -c amino-acid residues. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.SCCOR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. -c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor - esccor=0.0D0 - do i=iphi_start,iphi_end - if (itype(i-2).eq.21 .or. itype(i-1).eq.21) cycle - esccor_ii=0.0D0 - itori=itype(i-2) - itori1=itype(i-1) - phii=phi(i) - gloci=0.0D0 - do j=1,nterm_sccor - v1ij=v1sccor(j,itori,itori1) - v2ij=v2sccor(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - esccor=esccor+v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6) - gsccor_loc(i-3)=gsccor_loc(i-3)+gloci - enddo - return - end -c---------------------------------------------------------------------------- - subroutine multibody(ecorr) -C This subroutine calculates multi-body contributions to energy following -C the idea of Skolnick et al. If side chains I and J make a contact and -C at the same time side chains I+1 and J+1 make a contact, an extra -C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - -C Set lprn=.true. for debugging - lprn=.false. - - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(i2,20(1x,i2,f10.5))') - & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) - enddo - endif - ecorr=0.0D0 - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo - do i=nnt,nct-2 - - DO ISHIFT = 3,4 - - i1=i+ishift - num_conti=num_cont(i) - num_conti1=num_cont(i1) - do jj=1,num_conti - j=jcont(jj,i) - do kk=1,num_conti1 - j1=jcont(kk,i1) - if (j1.eq.j+ishift .or. j1.eq.j-ishift) then -cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, -cd & ' ishift=',ishift -C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) - endif ! j1==j+-ishift - enddo ! kk - enddo ! jj - - ENDDO ! ISHIFT - - enddo ! i - return - end -c------------------------------------------------------------------------------ - double precision function esccorr(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont(jj,i) - ekl=facont(kk,k) -cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl -C Calculate the multi-body contribution to energy. -C Calculate multi-body contributions to the gradient. -cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), -cd & k,l,(gacont(m,kk,k),m=1,3) - do m=1,3 - gx(m) =ekl*gacont(m,jj,i) - gx1(m)=eij*gacont(m,kk,k) - gradxorr(m,i)=gradxorr(m,i)-gx(m) - gradxorr(m,j)=gradxorr(m,j)+gx(m) - gradxorr(m,k)=gradxorr(m,k)-gx1(m) - gradxorr(m,l)=gradxorr(m,l)+gx1(m) - enddo - do m=i,j-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) - enddo - enddo - do m=k,l-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) - enddo - enddo - esccorr=-eij*ekl - return - end -c------------------------------------------------------------------------------ - subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPI - include "mpif.h" - parameter (max_cont=maxconts) - parameter (max_dim=26) - integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer status(MPI_STATUS_SIZE),req(maxconts*2), - & status_array(MPI_STATUS_SIZE,maxconts*2) -#endif - include 'COMMON.SETUP' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.LOCAL' - double precision gx(3),gx1(3),time00 - logical lprn,ldone - -C Set lprn=.true. for debugging - lprn=.false. -#ifdef MPI - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values before RECEIVE:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", -c & ntask_cont_to -C Make the list of contacts to send to send to other procesors -c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end -c call flush(iout) - do i=iturn3_start,iturn3_end -c write (iout,*) "make contact list turn3",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact(i,i+2,iturn3_sent_local(1,i)) - enddo - do i=iturn4_start,iturn4_end -c write (iout,*) "make contact list turn4",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact(i,i+3,iturn4_sent_local(1,i)) - enddo - do ii=1,nat_sent - i=iat_sent(ii) -c write (iout,*) "make contact list longrange",i,ii," num_cont", -c & num_cont_hb(i) - do j=1,num_cont_hb(i) - do k=1,4 - jjc=jcont_hb(j,i) - iproc=iint_sent_local(k,jjc,ii) -c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc - if (iproc.gt.0) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=i - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=facont_hb(j,i) - zapas(4,nn,iproc)=ees0p(j,i) - zapas(5,nn,iproc)=ees0m(j,i) - zapas(6,nn,iproc)=gacont_hbr(1,j,i) - zapas(7,nn,iproc)=gacont_hbr(2,j,i) - zapas(8,nn,iproc)=gacont_hbr(3,j,i) - zapas(9,nn,iproc)=gacontm_hb1(1,j,i) - zapas(10,nn,iproc)=gacontm_hb1(2,j,i) - zapas(11,nn,iproc)=gacontm_hb1(3,j,i) - zapas(12,nn,iproc)=gacontp_hb1(1,j,i) - zapas(13,nn,iproc)=gacontp_hb1(2,j,i) - zapas(14,nn,iproc)=gacontp_hb1(3,j,i) - zapas(15,nn,iproc)=gacontm_hb2(1,j,i) - zapas(16,nn,iproc)=gacontm_hb2(2,j,i) - zapas(17,nn,iproc)=gacontm_hb2(3,j,i) - zapas(18,nn,iproc)=gacontp_hb2(1,j,i) - zapas(19,nn,iproc)=gacontp_hb2(2,j,i) - zapas(20,nn,iproc)=gacontp_hb2(3,j,i) - zapas(21,nn,iproc)=gacontm_hb3(1,j,i) - zapas(22,nn,iproc)=gacontm_hb3(2,j,i) - zapas(23,nn,iproc)=gacontm_hb3(3,j,i) - zapas(24,nn,iproc)=gacontp_hb3(1,j,i) - zapas(25,nn,iproc)=gacontp_hb3(2,j,i) - zapas(26,nn,iproc)=gacontp_hb3(3,j,i) - endif - enddo - enddo - enddo - if (lprn) then - write (iout,*) - & "Numbers of contacts to be sent to other processors", - & (ncont_sent(i),i=1,ntask_cont_to) - write (iout,*) "Contacts sent" - do ii=1,ntask_cont_to - nn=ncont_sent(ii) - iproc=itask_cont_to(ii) - write (iout,*) nn," contacts to processor",iproc, - & " of CONT_TO_COMM group" - do i=1,nn - write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) - enddo - enddo - call flush(iout) - endif - CorrelType=477 - CorrelID=fg_rank+1 - CorrelType1=478 - CorrelID1=nfgtasks+fg_rank+1 - ireq=0 -C Receive the numbers of needed contacts from other processors - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - ireq=ireq+1 - call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "IRECV ended" -c call flush(iout) -C Send the number of contacts needed by other processors - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - ireq=ireq+1 - call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "ISEND ended" -c write (iout,*) "number of requests (nn)",ireq - call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) -c write (iout,*) -c & "Numbers of contacts to be received from other processors", -c & (ncont_recv(i),i=1,ntask_cont_from) -c call flush(iout) -C Receive contacts - ireq=0 - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - nn=ncont_recv(ii) -c write (iout,*) "Receiving",nn," contacts from processor",iproc, -c & " of CONT_TO_COMM group" - call flush(iout) - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, - & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) - endif - enddo -C Send the contacts to processors that need them - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - nn=ncont_sent(ii) -c write (iout,*) nn," contacts to processor",iproc, -c & " of CONT_TO_COMM group" - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, - & iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) -c do i=1,nn -c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) -c enddo - endif - enddo -c write (iout,*) "number of requests (contacts)",ireq -c write (iout,*) "req",(req(i),i=1,4) -c call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) - do iii=1,ntask_cont_from - iproc=itask_cont_from(iii) - nn=ncont_recv(iii) - if (lprn) then - write (iout,*) "Received",nn," contacts from processor",iproc, - & " of CONT_FROM_COMM group" - call flush(iout) - do i=1,nn - write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5) - enddo - call flush(iout) - endif - do i=1,nn - ii=zapas_recv(1,i,iii) -c Flag the received contacts to prevent double-counting - jj=-zapas_recv(2,i,iii) -c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj -c call flush(iout) - nnn=num_cont_hb(ii)+1 - num_cont_hb(ii)=nnn - jcont_hb(nnn,ii)=jj - facont_hb(nnn,ii)=zapas_recv(3,i,iii) - ees0p(nnn,ii)=zapas_recv(4,i,iii) - ees0m(nnn,ii)=zapas_recv(5,i,iii) - gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii) - gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii) - gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii) - gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii) - gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii) - gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii) - gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii) - gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii) - gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii) - gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii) - gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii) - gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii) - gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii) - gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii) - gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii) - gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii) - gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii) - gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii) - gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii) - gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii) - gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii) - enddo - enddo - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 -C Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -C Calculate the local-electrostatic correlation terms - do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end) - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - jp=iabs(j) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) - jp1=iabs(j1) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 - & .or. j.lt.0 .and. j1.gt.0) .and. - & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then -C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) - n_corr=n_corr+1 - else if (j1.eq.j) then -C Contacts I-J and I-(J+1) occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) - endif - enddo ! kk - do kk=1,num_conti - j1=jcont_hb(kk,i) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if (j1.eq.j+1) then -C Contacts I-J and (I+1)-J occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) - endif ! j1==j+1 - enddo ! kk - enddo ! jj - enddo ! i - return - end -c------------------------------------------------------------------------------ - subroutine add_hb_contact(ii,jj,itask) - implicit real*8 (a-h,o-z) - include "DIMENSIONS" - include "COMMON.IOUNITS" - integer max_cont - integer max_dim - parameter (max_cont=maxconts) - parameter (max_dim=26) - include "COMMON.CONTACTS" - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer i,j,ii,jj,iproc,itask(4),nn -c write (iout,*) "itask",itask - do i=1,2 - iproc=itask(i) - if (iproc.gt.0) then - do j=1,num_cont_hb(ii) - jjc=jcont_hb(j,ii) -c write (iout,*) "i",ii," j",jj," jjc",jjc - if (jjc.eq.jj) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=ii - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=facont_hb(j,ii) - zapas(4,nn,iproc)=ees0p(j,ii) - zapas(5,nn,iproc)=ees0m(j,ii) - zapas(6,nn,iproc)=gacont_hbr(1,j,ii) - zapas(7,nn,iproc)=gacont_hbr(2,j,ii) - zapas(8,nn,iproc)=gacont_hbr(3,j,ii) - zapas(9,nn,iproc)=gacontm_hb1(1,j,ii) - zapas(10,nn,iproc)=gacontm_hb1(2,j,ii) - zapas(11,nn,iproc)=gacontm_hb1(3,j,ii) - zapas(12,nn,iproc)=gacontp_hb1(1,j,ii) - zapas(13,nn,iproc)=gacontp_hb1(2,j,ii) - zapas(14,nn,iproc)=gacontp_hb1(3,j,ii) - zapas(15,nn,iproc)=gacontm_hb2(1,j,ii) - zapas(16,nn,iproc)=gacontm_hb2(2,j,ii) - zapas(17,nn,iproc)=gacontm_hb2(3,j,ii) - zapas(18,nn,iproc)=gacontp_hb2(1,j,ii) - zapas(19,nn,iproc)=gacontp_hb2(2,j,ii) - zapas(20,nn,iproc)=gacontp_hb2(3,j,ii) - zapas(21,nn,iproc)=gacontm_hb3(1,j,ii) - zapas(22,nn,iproc)=gacontm_hb3(2,j,ii) - zapas(23,nn,iproc)=gacontm_hb3(3,j,ii) - zapas(24,nn,iproc)=gacontp_hb3(1,j,ii) - zapas(25,nn,iproc)=gacontp_hb3(2,j,ii) - zapas(26,nn,iproc)=gacontp_hb3(3,j,ii) - exit - endif - enddo - endif - enddo - return - end -c------------------------------------------------------------------------------ - subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, - & n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPI - include "mpif.h" - parameter (max_cont=maxconts) - parameter (max_dim=70) - integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer status(MPI_STATUS_SIZE),req(maxconts*2), - & status_array(MPI_STATUS_SIZE,maxconts*2) -#endif - include 'COMMON.SETUP' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.CONTROL' - double precision gx(3),gx1(3) - integer num_cont_hb_old(maxres) - logical lprn,ldone - double precision eello4,eello5,eelo6,eello_turn6 - external eello4,eello5,eello6,eello_turn6 -C Set lprn=.true. for debugging - lprn=.false. - eturn6=0.0d0 -#ifdef MPI - do i=1,nres - num_cont_hb_old(i)=num_cont_hb(i) - enddo - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values before RECEIVE:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", -c & ntask_cont_to -C Make the list of contacts to send to send to other procesors - do i=iturn3_start,iturn3_end -c write (iout,*) "make contact list turn3",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i)) - enddo - do i=iturn4_start,iturn4_end -c write (iout,*) "make contact list turn4",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i)) - enddo - do ii=1,nat_sent - i=iat_sent(ii) -c write (iout,*) "make contact list longrange",i,ii," num_cont", -c & num_cont_hb(i) - do j=1,num_cont_hb(i) - do k=1,4 - jjc=jcont_hb(j,i) - iproc=iint_sent_local(k,jjc,ii) -c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc - if (iproc.ne.0) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=i - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=d_cont(j,i) - ind=3 - do kk=1,3 - ind=ind+1 - zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i) - enddo - enddo - enddo - enddo - endif - enddo - enddo - enddo - if (lprn) then - write (iout,*) - & "Numbers of contacts to be sent to other processors", - & (ncont_sent(i),i=1,ntask_cont_to) - write (iout,*) "Contacts sent" - do ii=1,ntask_cont_to - nn=ncont_sent(ii) - iproc=itask_cont_to(ii) - write (iout,*) nn," contacts to processor",iproc, - & " of CONT_TO_COMM group" - do i=1,nn - write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10) - enddo - enddo - call flush(iout) - endif - CorrelType=477 - CorrelID=fg_rank+1 - CorrelType1=478 - CorrelID1=nfgtasks+fg_rank+1 - ireq=0 -C Receive the numbers of needed contacts from other processors - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - ireq=ireq+1 - call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "IRECV ended" -c call flush(iout) -C Send the number of contacts needed by other processors - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - ireq=ireq+1 - call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "ISEND ended" -c write (iout,*) "number of requests (nn)",ireq - call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) -c write (iout,*) -c & "Numbers of contacts to be received from other processors", -c & (ncont_recv(i),i=1,ntask_cont_from) -c call flush(iout) -C Receive contacts - ireq=0 - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - nn=ncont_recv(ii) -c write (iout,*) "Receiving",nn," contacts from processor",iproc, -c & " of CONT_TO_COMM group" - call flush(iout) - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, - & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) - endif - enddo -C Send the contacts to processors that need them - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - nn=ncont_sent(ii) -c write (iout,*) nn," contacts to processor",iproc, -c & " of CONT_TO_COMM group" - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, - & iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) -c do i=1,nn -c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) -c enddo - endif - enddo -c write (iout,*) "number of requests (contacts)",ireq -c write (iout,*) "req",(req(i),i=1,4) -c call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) - do iii=1,ntask_cont_from - iproc=itask_cont_from(iii) - nn=ncont_recv(iii) - if (lprn) then - write (iout,*) "Received",nn," contacts from processor",iproc, - & " of CONT_FROM_COMM group" - call flush(iout) - do i=1,nn - write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10) - enddo - call flush(iout) - endif - do i=1,nn - ii=zapas_recv(1,i,iii) -c Flag the received contacts to prevent double-counting - jj=-zapas_recv(2,i,iii) -c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj -c call flush(iout) - nnn=num_cont_hb(ii)+1 - num_cont_hb(ii)=nnn - jcont_hb(nnn,ii)=jj - d_cont(nnn,ii)=zapas_recv(3,i,iii) - ind=3 - do kk=1,3 - ind=ind+1 - grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii) - enddo - enddo - enddo - enddo - enddo - enddo - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,5f6.3))') - & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), - & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,5f6.3))') - & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), - & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 - ecorr5=0.0d0 - ecorr6=0.0d0 -C Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -C Calculate the dipole-dipole interaction energies - if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then - do i=iatel_s,iatel_e+1 - num_conti=num_cont_hb(i) - do jj=1,num_conti - j=jcont_hb(jj,i) -#ifdef MOMENT - call dipole(i,j,jj) -#endif - enddo - enddo - endif -C Calculate the local-electrostatic correlation terms -c write (iout,*) "gradcorr5 in eello5 before loop" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) -c write (iout,*) "corr loop i",i - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - jp=iabs(j) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) - jp1=iabs(j1) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk -c if (j1.eq.j+1 .or. j1.eq.j-1) then - if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 - & .or. j.lt.0 .and. j1.gt.0) .and. - & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then -C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -C The system gains extra energy. - n_corr=n_corr+1 - sqd1=dsqrt(d_cont(jj,i)) - sqd2=dsqrt(d_cont(kk,i1)) - sred_geom = sqd1*sqd2 - IF (sred_geom.lt.cutoff_corr) THEN - call gcont(sred_geom,r0_corr,1.0D0,delt_corr, - & ekont,fprimcont) -cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, -cd & ' jj=',jj,' kk=',kk - fac_prim1=0.5d0*sqd2/sqd1*fprimcont - fac_prim2=0.5d0*sqd1/sqd2*fprimcont - do l=1,3 - g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) - g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) - enddo - n_corr1=n_corr1+1 -cd write (iout,*) 'sred_geom=',sred_geom, -cd & ' ekont=',ekont,' fprim=',fprimcont, -cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 -cd write (iout,*) "g_contij",g_contij -cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) -cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) - call calc_eello(i,jp,i+1,jp1,jj,kk) - if (wcorr4.gt.0.0d0) - & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) - if (energy_dec.and.wcorr4.gt.0.0d0) - 1 write (iout,'(a6,4i5,0pf7.3)') - 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) -c write (iout,*) "gradcorr5 before eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - if (wcorr5.gt.0.0d0) - & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) -c write (iout,*) "gradcorr5 after eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - if (energy_dec.and.wcorr5.gt.0.0d0) - 1 write (iout,'(a6,4i5,0pf7.3)') - 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) -cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 -cd write(2,*)'ijkl',i,jp,i+1,jp1 - if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 - & .or. wturn6.eq.0.0d0))then -cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 - ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) - if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') - 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) -cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, -cd & 'ecorr6=',ecorr6 -cd write (iout,'(4e15.5)') sred_geom, -cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)), -cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)), -cd & dabs(eello6(i,jp,i+1,jp1,jj,kk)) - else if (wturn6.gt.0.0d0 - & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then -cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 - eturn6=eturn6+eello_turn6(i,jj,kk) - if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') - 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) -cd write (2,*) 'multibody_eello:eturn6',eturn6 - endif - ENDIF -1111 continue - endif - enddo ! kk - enddo ! jj - enddo ! i - do i=1,nres - num_cont_hb(i)=num_cont_hb_old(i) - enddo -c write (iout,*) "gradcorr5 in eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - return - end -c------------------------------------------------------------------------------ - subroutine add_hb_contact_eello(ii,jj,itask) - implicit real*8 (a-h,o-z) - include "DIMENSIONS" - include "COMMON.IOUNITS" - integer max_cont - integer max_dim - parameter (max_cont=maxconts) - parameter (max_dim=70) - include "COMMON.CONTACTS" - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer i,j,ii,jj,iproc,itask(4),nn -c write (iout,*) "itask",itask - do i=1,2 - iproc=itask(i) - if (iproc.gt.0) then - do j=1,num_cont_hb(ii) - jjc=jcont_hb(j,ii) -c write (iout,*) "send turns i",ii," j",jj," jjc",jjc - if (jjc.eq.jj) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=ii - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=d_cont(j,ii) - ind=3 - do kk=1,3 - ind=ind+1 - zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii) - enddo - enddo - enddo - enddo - exit - endif - enddo - endif - enddo - return - end -c------------------------------------------------------------------------------ - double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont_hb(jj,i) - ekl=facont_hb(kk,k) - ees0pij=ees0p(jj,i) - ees0pkl=ees0p(kk,k) - ees0mij=ees0m(jj,i) - ees0mkl=ees0m(kk,k) - ekont=eij*ekl - ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) -cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) -C Following 4 lines for diagnostics. -cd ees0pkl=0.0D0 -cd ees0pij=1.0D0 -cd ees0mkl=0.0D0 -cd ees0mij=1.0D0 -c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') -c & 'Contacts ',i,j, -c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l -c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, -c & 'gradcorr_long' -C Calculate the multi-body contribution to energy. -c ecorr=ecorr+ekont*ees -C Calculate multi-body contributions to the gradient. - coeffpees0pij=coeffp*ees0pij - coeffmees0mij=coeffm*ees0mij - coeffpees0pkl=coeffp*ees0pkl - coeffmees0mkl=coeffm*ees0mkl - do ll=1,3 -cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) - gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi - & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb1(ll,jj,i)) - gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi - & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb2(ll,jj,i)) -cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k) - gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk - & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ - & coeffmees0mij*gacontm_hb1(ll,kk,k)) - gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk - & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ - & coeffmees0mij*gacontm_hb2(ll,kk,k)) - gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- - & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb3(ll,jj,i)) - gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij - gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij - gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- - & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ - & coeffmees0mij*gacontm_hb3(ll,kk,k)) - gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl - gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl -c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl - enddo -c write (iout,*) -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ -cgrad & ees*ekl*gacont_hbr(ll,jj,i)- -cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ -cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ -cgrad & ees*eij*gacont_hbr(ll,kk,k)- -cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ -cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) -cgrad enddo -cgrad enddo -c write (iout,*) "ehbcorr",ekont*ees - ehbcorr=ekont*ees - return - end -#ifdef MOMENT -C--------------------------------------------------------------------------- - subroutine dipole(i,j,jj) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), - & auxmat(2,2) - iti1 = itortyp(itype(i+1)) - if (j.lt.nres-1) then - itj1 = itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - do iii=1,2 - dipi(iii,1)=Ub2(iii,i) - dipderi(iii)=Ub2der(iii,i) - dipi(iii,2)=b1(iii,iti1) - dipj(iii,1)=Ub2(iii,j) - dipderj(iii)=Ub2der(iii,j) - dipj(iii,2)=b1(iii,itj1) - enddo - kkk=0 - do iii=1,2 - call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) - do jjj=1,2 - kkk=kkk+1 - dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - do kkk=1,5 - do lll=1,3 - mmm=0 - do iii=1,2 - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), - & auxvec(1)) - do jjj=1,2 - mmm=mmm+1 - dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - enddo - enddo - call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) - call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) - do iii=1,2 - dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) - enddo - call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) - do iii=1,2 - dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) - enddo - return - end -#endif -C--------------------------------------------------------------------------- - subroutine calc_eello(i,j,k,l,jj,kk) -C -C This subroutine computes matrices and vectors needed to calculate -C the fourth-, fifth-, and sixth-order local-electrostatic terms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), - & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) - logical lprn - common /kutas/ lprn -cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, -cd & ' jj=',jj,' kk=',kk -cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return -cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) -cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) - aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) - enddo - enddo - call transpose2(aa1(1,1),aa1t(1,1)) - call transpose2(aa2(1,1),aa2t(1,1)) - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), - & aa1tder(1,1,lll,kkk)) - call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), - & aa2tder(1,1,lll,kkk)) - enddo - enddo - if (l.eq.j+1) then -C parallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itj=itortyp(itype(j)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -C A1 kernel(j+1) A2T -cd do iii=1,2 -cd write (iout,'(3f10.5,5x,3f10.5)') -cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) -cd enddo - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), - & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - lprn=.false. - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), - & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants -cd lprn=.false. -cd if (lprn) then -cd write (2,*) 'In calc_eello6' -cd do iii=1,2 -cd write (2,*) 'iii=',iii -cd do kkk=1,5 -cd write (2,*) 'kkk=',kkk -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) -cd enddo -cd enddo -cd enddo -cd endif - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A1T kernel(i+1) A2 - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) -C Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - else -C Antiparallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif -C A2 kernel(j-1)T A1T - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. - & j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), - & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), - & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A2T kernel(i+1)T A1 - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. - & j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. - & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) -C Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - endif - return - end -C--------------------------------------------------------------------------- - subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, - & KK,KKderg,AKA,AKAderg,AKAderx) - implicit none - integer nderg - logical transp - double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), - & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), - & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) - integer iii,kkk,lll - integer jjj,mmm - logical lprn - common /kutas/ lprn - call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) - do iii=1,nderg - call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, - & AKAderg(1,1,iii)) - enddo -cd if (lprn) write (2,*) 'In kernel' - do kkk=1,5 -cd if (lprn) write (2,*) 'kkk=',kkk - do lll=1,3 - call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), - & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) -cd if (lprn) then -cd write (2,*) 'lll=',lll -cd write (2,*) 'iii=1' -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) -cd enddo -cd endif - call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), - & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) -cd if (lprn) then -cd write (2,*) 'lll=',lll -cd write (2,*) 'iii=2' -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) -cd enddo -cd endif - enddo - enddo - return - end -C--------------------------------------------------------------------------- - double precision function eello4(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then -cd eello4=0.0d0 -cd return -cd endif -cd print *,'eello4:',i,j,k,l,jj,kk -cd write (2,*) 'i',i,' j',j,' k',k,' l',l -cd call checkint4(i,j,k,l,jj,kk,eel4_num) -cold eij=facont_hb(jj,i) -cold ekl=facont_hb(kk,k) -cold ekont=eij*ekl - eel4=-EAEA(1,1,1)-EAEA(2,2,1) -cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) - gcorr_loc(k-1)=gcorr_loc(k-1) - & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) - if (l.eq.j+1) then - gcorr_loc(l-1)=gcorr_loc(l-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - else - gcorr_loc(j-1)=gcorr_loc(j-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) - & -EAEAderx(2,2,lll,kkk,iii,1) -cd derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd gcorr_loc(l-1)=0.0d0 -cd gcorr_loc(j-1)=0.0d0 -cd gcorr_loc(k-1)=0.0d0 -cd eel4=1.0d0 -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l, -cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel4*g_contij(ll,1) -cgrad ggg2(ll)=eel4*g_contij(ll,2) - glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) - glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) -cgrad ghalf=0.5d0*ggg1(ll) - gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) - gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) - gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) - gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) - gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij - gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij -cgrad ghalf=0.5d0*ggg2(ll) - gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) - gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) - gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) - gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) - gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl - gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl - enddo -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,gcorr_loc(iii) -cd enddo - eello4=ekont*eel4 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello4',ekont*eel4 - return - end -C--------------------------------------------------------------------------- - double precision function eello5(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) - double precision ggg1(3),ggg2(3) -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel chains C -C C -C o o o o C -C /l\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j| o |l1 | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C Antiparallel chains C -C C -C o o o o C -C /j\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j1| o |l | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C o denotes a local interaction, vertical lines an electrostatic interaction. C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then -cd eello5=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - itk=itortyp(itype(k)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - eello5_1=0.0d0 - eello5_2=0.0d0 - eello5_3=0.0d0 - eello5_4=0.0d0 -cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, -cd & eel5_3_num,eel5_4_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l -cd goto 1111 -C Contribution from the graph I. -cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) -cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) -C Explicit gradient in virtual-dihedral angles. - if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - if (l.eq.j+1) then - if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - else - if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) - enddo - enddo - enddo -c goto 1112 -c1111 continue -C Contribution from graph II - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - if (l.eq.j+1) then - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - else - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) - enddo - enddo - enddo -cd goto 1112 -cd1111 continue - if (l.eq.j+1) then -cd goto 1110 -C Parallel orientation -C Contribution from graph III - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) - call transpose2(EUgder(1,1,l),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) - enddo - enddo - enddo -cd goto 1112 -C Contribution from graph IV -cd1110 continue - call transpose2(EE(1,1,itl),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) - enddo - enddo - enddo - else -C Antiparallel orientation -C Contribution from graph III -c goto 1110 - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) - call transpose2(EUgder(1,1,j),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) - enddo - enddo - enddo -cd goto 1112 -C Contribution from graph IV -1110 continue - call transpose2(EE(1,1,itj),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) - enddo - enddo - enddo - endif -1112 continue - eel5=eello5_1+eello5_2+eello5_3+eello5_4 -cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then -cd write (2,*) 'ijkl',i,j,k,l -cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, -cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 -cd endif -cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num -cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num -cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num -cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 -cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont -C 2/11/08 AL Gradients over DC's connecting interacting sites will be -C summed up outside the subrouine as for the other subroutines -C handling long-range interactions. The old code is commented out -C with "cgrad" to keep track of changes. - do ll=1,3 -cgrad ggg1(ll)=eel5*g_contij(ll,1) -cgrad ggg2(ll)=eel5*g_contij(ll,2) - gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) - gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) -c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') -c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), -c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), -c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont -c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') -c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), -c & gradcorr5ij, -c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl -cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) - gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) - gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) - gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) - gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij - gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij -cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) -cgrad ghalf=0.5d0*ggg2(ll) -cd ghalf=0.0d0 - gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) - gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) - gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) - gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) - gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl - gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -c1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr5_loc(iii) -cd enddo - eello5=ekont*eel5 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello5',ekont*eel5 - return - end -c-------------------------------------------------------------------------- - double precision function eello6(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - eello6_1=0.0d0 - eello6_2=0.0d0 - eello6_3=0.0d0 - eello6_4=0.0d0 - eello6_5=0.0d0 - eello6_6=0.0d0 -cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, -cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - if (l.eq.j+1) then - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(j,i,l,k,2,.false.) - eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) - eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) - else - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(l,k,j,i,2,.true.) - eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - if (wturn6.eq.0.0d0 .or. j.ne.i+4) then - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) - else - eello6_5=0.0d0 - endif - eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) - endif -C If turn contributions are considered, they will be handled separately. - eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 -cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num -cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num -cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num -cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num -cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num -cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num -cd goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel6*g_contij(ll,1) -cgrad ggg2(ll)=eel6*g_contij(ll,2) -cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) - gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) - gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) - gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) - gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) - gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) - gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij - gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij -cgrad ghalf=0.5d0*ggg2(ll) -cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) -cd ghalf=0.0d0 - gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) - gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) - gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) - gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) - gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl - gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr6_loc(iii) -cd enddo - eello6=ekont*eel6 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello6',ekont*eel6 - return - end -c-------------------------------------------------------------------------- - double precision function eello6_graph1(i,j,k,l,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) - logical swap - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C Parallel Antiparallel -C -C o o -C /l\ /j\ -C / \ / \ -C /| o | | o |\ -C \ j|/k\| / \ |/k\|l / -C \ / \ / \ / \ / -C o o o o -C i i -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - itk=itortyp(itype(k)) - s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) - vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 - eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) - if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) - & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) - & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) - & +scalar2(vv(1),Dtobr2der(1,i))) - call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) - vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) - if (l.eq.j+1) then - g_corr6_loc(l-1)=g_corr6_loc(l-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - endif - call transpose2(EUgCder(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) - & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) - & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) - do iii=1,2 - if (swap) then - ind=3-iii - else - ind=iii - endif - do kkk=1,5 - do lll=1,3 - s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) - & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) - vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) - & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) - derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph2(i,j,k,l,jj,kk,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - logical swap - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxvec2(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 -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, -cd & "sum",-(s2+s3+s4) -#ifdef MOMENT - eello6_graph3=-(s1+s2+s3+s4) -#else - eello6_graph3=-(s2+s3+s4) -#endif -c eello6_graph3=-s4 -C Derivatives in gamma(k-1) - call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) -C Derivatives in gamma(l-1) - call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) -C Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) - else - s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif -c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxmat1(2,2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 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 -C Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - if (imat.eq.1) then - s1=dipderg(2,jj,i)*dip(3,kk,k) - else - s1=dipderg(4,jj,j)*dip(2,kk,l) - endif -#endif - s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -cd write (2,*) 'turn6 derivatives' -#ifdef MOMENT - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif - endif - endif -C Derivatives in gamma(k-1) -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderg(2,kk,k) - else - s1=dip(2,jj,j)*dipderg(4,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif - endif -C Derivatives in gamma(j-1) or gamma(l-1) - if (l.eq.j+1 .and. l.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) - else if (j.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then - gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) - endif - endif -C Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - if (imat.eq.1) then - s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) - else - s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) - endif - else - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) - else - s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) - endif - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), - & auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itj1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) - else - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itl1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) - endif - call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (swap) then - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s1+s2+s4) -#else - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s2+s4) -#endif - derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 - else -#ifdef MOMENT - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) -#else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) -#endif - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - else -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (l.eq.j+1) then - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - endif - endif - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello_turn6(i,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), - & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), - & ggg1(3),ggg2(3) - double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), - & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) -C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to -C the respective energy moment and not to the cluster cumulant. - s1=0.0d0 - s8=0.0d0 - s13=0.0d0 -c - eello_turn6=0.0d0 - j=i+4 - k=i+1 - l=i+3 - iti=itortyp(itype(i)) - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) -cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj -cd write (2,*) 'i',i,' k',k,' j',j,' l',l -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l -cd call checkint_turn6(i,jj,kk,eel_turn6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx_turn(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) -cd eello6_5=0.0d0 -cd write (2,*) 'eello6_5',eello6_5 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) - ss1=scalar2(Ub2(1,i+2),b1(1,itl)) - s1 = (auxmat(1,1)+auxmat(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) - s2 = scalar2(b1(1,itk),vtemp1(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atemp(1,1)) - call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) - call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) - s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) - s12 = scalar2(Ub2(1,i+2),vtemp3(1)) -#ifdef MOMENT - call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) - call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) - call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) - ss13 = scalar2(b1(1,itk),vtemp4(1)) - s13 = (gtemp(1,1)+gtemp(2,2))*ss13 -#endif -c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 -c s1=0.0d0 -c s2=0.0d0 -c s8=0.0d0 -c s12=0.0d0 -c s13=0.0d0 - eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) -C Derivatives in gamma(i+2) - s1d =0.0d0 - s8d =0.0d0 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 - call transpose2(AEAderg(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 - gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) -C Derivatives in gamma(i+3) -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d -#endif - call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) - s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) -#endif - s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) - & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) - & -0.5d0*ekont*(s2d+s12d) -#endif -C Derivatives in gamma(i+4) - call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -C s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) -#else - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) -#endif -C Derivatives in gamma(i+5) -#ifdef MOMENT - call transpose2(AEAderg(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) - & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) - & -0.5d0*ekont*(s2d+s12d) -#endif -C Cartesian derivatives - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), - & vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))* - & scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), - & auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) - & - 0.5d0*(s1d+s2d) -#else - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) - & - 0.5d0*s2d -#endif -#ifdef MOMENT - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) - & - 0.5d0*(s8d+s12d) -#else - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) - & - 0.5d0*s12d -#endif - enddo - enddo - enddo -#ifdef MOMENT - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), - & achuj_tempd(1,1)) - call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d=(gtempd(1,1)+gtempd(2,2))*ss13 - derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), - & vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d - derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d - enddo - enddo -#endif -cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', -cd & 16*eel_turn6_num -cd goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel_turn6*g_contij(ll,1) -cgrad ggg2(ll)=eel_turn6*g_contij(ll,2) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) - gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) - gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf - & +ekont*derx_turn(ll,2,1) - gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) - gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf - & +ekont*derx_turn(ll,4,1) - gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) - gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij - gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij -cgrad ghalf=0.5d0*ggg2(ll) -cd ghalf=0.0d0 - gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf - & +ekont*derx_turn(ll,2,2) - gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) - gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf - & +ekont*derx_turn(ll,4,2) - gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) - gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl - gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr6_loc(iii) -cd enddo - eello_turn6=ekont*eel_turn6 -cd write (2,*) 'ekont',ekont -cd write (2,*) 'eel_turn6',ekont*eel_turn6 - return - end - -C----------------------------------------------------------------------------- - double precision function scalar(u,v) -!DIR$ INLINEALWAYS scalar -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::scalar -#endif - implicit none - double precision u(3),v(3) -cd double precision sc -cd integer i -cd sc=0.0d0 -cd do i=1,3 -cd sc=sc+u(i)*v(i) -cd enddo -cd scalar=sc - - scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3) - return - end -crc------------------------------------------------- - SUBROUTINE MATVEC2(A1,V1,V2) -!DIR$ INLINEALWAYS MATVEC2 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2 -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),V1(2),V2(2) -c DO 1 I=1,2 -c VI=0.0 -c DO 3 K=1,2 -c 3 VI=VI+A1(I,K)*V1(K) -c Vaux(I)=VI -c 1 CONTINUE - - vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) - vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) - - v2(1)=vaux1 - v2(2)=vaux2 - END -C--------------------------------------- - SUBROUTINE MATMAT2(A1,A2,A3) -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2 -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),A2(2,2),A3(2,2) -c DIMENSION AI3(2,2) -c DO J=1,2 -c A3IJ=0.0 -c DO K=1,2 -c A3IJ=A3IJ+A1(I,K)*A2(K,J) -c enddo -c A3(I,J)=A3IJ -c enddo -c enddo - - ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) - ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) - ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) - ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) - - A3(1,1)=AI3_11 - A3(2,1)=AI3_21 - A3(1,2)=AI3_12 - A3(2,2)=AI3_22 - END - -c------------------------------------------------------------------------- - double precision function scalar2(u,v) -!DIR$ INLINEALWAYS scalar2 - implicit none - double precision u(2),v(2) - double precision sc - integer i - scalar2=u(1)*v(1)+u(2)*v(2) - return - end - -C----------------------------------------------------------------------------- - - subroutine transpose2(a,at) -!DIR$ INLINEALWAYS transpose2 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::transpose2 -#endif - implicit none - double precision a(2,2),at(2,2) - at(1,1)=a(1,1) - at(1,2)=a(2,1) - at(2,1)=a(1,2) - at(2,2)=a(2,2) - return - end -c-------------------------------------------------------------------------- - subroutine transpose(n,a,at) - implicit none - integer n,i,j - double precision a(n,n),at(n,n) - do i=1,n - do j=1,n - at(j,i)=a(i,j) - enddo - enddo - return - end -C--------------------------------------------------------------------------- - subroutine prodmat3(a1,a2,kk,transp,prod) -!DIR$ INLINEALWAYS prodmat3 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::prodmat3 -#endif - implicit none - integer i,j - double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) - logical transp -crc double precision auxmat(2,2),prod_(2,2) - - if (transp) then -crc call transpose2(kk(1,1),auxmat(1,1)) -crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) - - else -crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) - - endif -c call transpose2(a2(1,1),a2t(1,1)) - -crc print *,transp -crc print *,((prod_(i,j),i=1,2),j=1,2) -crc print *,((prod(i,j),i=1,2),j=1,2) - - return - end - diff --git a/source/unres/src_MD-M-newcorr/energy_split-sep.F b/source/unres/src_MD-M-newcorr/energy_split-sep.F deleted file mode 100644 index 24ab8dd..0000000 --- a/source/unres/src_MD-M-newcorr/energy_split-sep.F +++ /dev/null @@ -1,472 +0,0 @@ - subroutine etotal_long(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -c -c Compute the long-range slow-varying contributions to the energy -c -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.MD' -c write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot - if (modecalc.eq.12.or.modecalc.eq.14) then -#ifdef MPI -c if (fg_rank.eq.0) call int_from_cart1(.false.) -#else - call int_from_cart1(.false.) -#endif - endif -#ifdef MPI -c write(iout,*) "ETOTAL_LONG Processor",fg_rank, -c & " absolute rank",myrank," nfgtasks",nfgtasks - call flush(iout) - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR) -c write (iout,*) "Processor",myrank," BROADCAST iorder" -c call flush(iout) -C FG master sets up the WEIGHTS_ array which will be broadcast to the -C FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -C FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -C FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - endif - call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 - time_Bcastw=time_Bcastw+MPI_Wtime()-time00 -c call chainbuild_cart -c call int_from_cart1(.false.) - endif -c write (iout,*) 'Processor',myrank, -c & ' calling etotal_short ipot=',ipot -c call flush(iout) -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#endif -cd print *,'nnt=',nnt,' nct=',nct -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105,106) ipot -C Lennard-Jones potential. - 101 call elj_long(evdw) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk_long(evdw) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp_long(evdw) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb_long(evdw) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv_long(evdw) - goto 107 -C Soft-sphere potential - 106 call e_softsphere(evdw) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 continue - call vec_and_deriv - if (ipot.lt.6) then -#ifdef SPLITELE - if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#else - if (welec.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#endif - call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) - else - ees=0 - evdw1=0 - eel_loc=0 - eello_turn3=0 - eello_turn4=0 - endif - else -c write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, - & eello_turn4) - endif -C -C Calculate excluded-volume interaction energy between peptide groups -C and side chains. -C - if (ipot.lt.6) then - if(wscp.gt.0d0) then - call escp_long(evdw2,evdw2_14) - else - evdw2=0 - evdw2_14=0 - endif - else - call escp_soft_sphere(evdw2,evdw2_14) - endif -C -C 12/1/95 Multi-body terms -C - n_corr=0 - n_corr1=0 - if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 - & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then - call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -c write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1, -c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) - endif -C -C If performing constraint dynamics, call the constraint energy -C after the equilibration time - if(usampl.and.totT.gt.eq_time) then - call EconstrQ - call Econstr_back - else - Uconst=0.0d0 - Uconst_back=0.0d0 - endif -C -C Sum the energies -C - do i=1,n_ene - energia(i)=0.0d0 - enddo - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(20)=Uconst+Uconst_back - call sum_energy(energia,.true.) -c write (iout,*) "Exit ETOTAL_LONG" - call flush(iout) - return - end -c------------------------------------------------------------------------------ - subroutine etotal_short(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -c -c Compute the short-range fast-varying contributions to the energy -c -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - -c write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot -c call flush(iout) - if (modecalc.eq.12.or.modecalc.eq.14) then -#ifdef MPI - if (fg_rank.eq.0) call int_from_cart1(.false.) -#else - call int_from_cart1(.false.) -#endif - endif -#ifdef MPI -c write(iout,*) "ETOTAL_SHORT Processor",fg_rank, -c & " absolute rank",myrank," nfgtasks",nfgtasks -c call flush(iout) - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR) -c write (iout,*) "Processor",myrank," BROADCAST iorder" -c call flush(iout) -C FG master sets up the WEIGHTS_ array which will be broadcast to the -C FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -C FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -C FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - endif -c write (iout,*),"Processor",myrank," BROADCAST weights" - call MPI_Bcast(c(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST c" - call MPI_Bcast(dc(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST dc" - call MPI_Bcast(dc_norm(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST dc_norm" - call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST theta" - call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST phi" - call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST alph" - call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST omeg" - call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST vbld" - call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -c write (iout,*) "Processor",myrank," BROADCAST vbld_inv" - endif -c write (iout,*) 'Processor',myrank, -c & ' calling etotal_short ipot=',ipot -c call flush(iout) -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#endif -c call int_from_cart1(.false.) -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105,106) ipot -C Lennard-Jones potential. - 101 call elj_short(evdw) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk_short(evdw) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp_short(evdw) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb_short(evdw) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv_short(evdw) - goto 107 -C Soft-sphere potential - already dealt with in the long-range part - 106 evdw=0.0d0 -c 106 call e_softsphere_short(evdw) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 continue -c -c Calculate the short-range part of Evdwpp -c - call evdwpp_short(evdw1) -c -c Calculate the short-range part of ESCp -c - if (ipot.lt.6) then - call escp_short(evdw2,evdw2_14) - endif -c -c Calculate the bond-stretching energy -c - call ebond(estr) -C -C Calculate the disulfide-bridge and other energy and the contributions -C from other distance constraints. - call edis(ehpb) -C -C Calculate the virtual-bond-angle energy. -C - call ebend(ebe) -C -C Calculate the SC local energy. -C - call vec_and_deriv - call esc(escloc) -C -C Calculate the virtual-bond torsional energy. -C - call etor(etors,edihcnstr) -C -C 6/23/01 Calculate double-torsional energy -C - call etor_d(etors_d) -C -C 21/5/07 Calculate local sicdechain correlation energy -C - if (wsccor.gt.0.0d0) then - call eback_sc_corr(esccor) - else - esccor=0.0d0 - endif -C -C Put energy components into an array -C - do i=1,n_ene - energia(i)=0.0d0 - enddo - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(16)=evdw1 -#else - energia(3)=evdw1 -#endif - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(17)=estr - energia(19)=edihcnstr - energia(21)=esccor -c write (iout,*) "ETOTAL_SHORT before SUM_ENERGY" - call flush(iout) - call sum_energy(energia,.true.) -c write (iout,*) "Exit ETOTAL_SHORT" - call flush(iout) - return - end diff --git a/source/unres/src_MD-M-newcorr/energy_split.F b/source/unres/src_MD-M-newcorr/energy_split.F deleted file mode 100644 index 4a09d29..0000000 --- a/source/unres/src_MD-M-newcorr/energy_split.F +++ /dev/null @@ -1,417 +0,0 @@ - subroutine etotal_long(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -c -c Compute the long-range slow-varying contributions to the energy -c -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' -c write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot - if (modecalc.eq.12.or.modecalc.eq.14) then -#ifdef MPI - if (fg_rank.eq.0) call int_from_cart1(.false.) -#else - call int_from_cart1(.false.) -#endif - endif -#ifdef MPI -c write(iout,*) "ETOTAL_LONG Processor",fg_rank, -c & " absolute rank",myrank," nfgtasks",nfgtasks - call flush(iout) - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR) -c write (iout,*) "Processor",myrank," BROADCAST iorder" - call flush(iout) -C FG master sets up the WEIGHTS_ array which will be broadcast to the -C FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -C FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -C FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor - endif -c write (iout,*),"Processor",myrank," BROADCAST weights" - call MPI_Bcast(c(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST c" - call MPI_Bcast(dc(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST dc" - call MPI_Bcast(dc_norm(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST dc_norm" - call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST theta" - call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST phi" - call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST alph" - call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST omeg" - call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST vbld" - call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -c write (iout,*) "Processor",myrank," BROADCAST vbld_inv" - endif -c write (iout,*) 'Processor',myrank, -c & ' calling etotal_short ipot=',ipot -c call flush(iout) -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#endif -c call int_from_cart1(.false.) - 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,106) ipot -C Lennard-Jones potential. - 101 call elj(evdw) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk(evdw) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp(evdw) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb(evdw) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv(evdw) - goto 107 -C Soft-sphere potential - 106 call e_softsphere(evdw) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 continue -c print *,"Processor",myrank," computed USCSC" - call vec_and_deriv -c print *,"Processor",myrank," left VEC_AND_DERIV" - if (ipot.lt.6) then -#ifdef SPLITELE - if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0) then -#else - if (welec.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0) then -#endif - call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) - else - ees=0 - evdw1=0 - eel_loc=0 - eello_turn3=0 - eello_turn4=0 - endif - else -c write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, - & eello_turn4) - endif -C -C Calculate excluded-volume interaction energy between peptide groups -C and side chains. -C - if (ipot.lt.6) then - call escp(evdw2,evdw2_14) - else -c write (iout,*) "Soft-sphere SCP potential" - call escp_soft_sphere(evdw2,evdw2_14) - endif -C -C 12/1/95 Multi-body terms -C - n_corr=0 - n_corr1=0 - if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 - & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then - call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -c write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1, -c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) - endif -C -C Sum the energies -C - do i=1,n_ene - energia(i)=0.0d0 - enddo - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(12)=escloc - call sum_energy(energia,.true.) -c write (iout,*) "Exit ETOTAL_LONG" - call flush(iout) - return - end -c------------------------------------------------------------------------------ - subroutine etotal_short(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -c -c Compute the short-range fast-varying contributions to the energy -c -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - -c write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot -c call flush(iout) - if (modecalc.eq.12.or.modecalc.eq.14) then -#ifdef MPI - if (fg_rank.eq.0) call int_from_cart1(.false.) -#else - call int_from_cart1(.false.) -#endif - endif -#ifdef MPI -c write(iout,*) "ETOTAL_SHORT Processor",fg_rank, -c & " absolute rank",myrank," nfgtasks",nfgtasks -c call flush(iout) - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR) -c write (iout,*) "Processor",myrank," BROADCAST iorder" -c call flush(iout) -C FG master sets up the WEIGHTS_ array which will be broadcast to the -C FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -C FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -C FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor - endif -c write (iout,*),"Processor",myrank," BROADCAST weights" - call MPI_Bcast(c(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST c" - call MPI_Bcast(dc(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST dc" - call MPI_Bcast(dc_norm(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST dc_norm" - call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST theta" - call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST phi" - call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST alph" - call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST omeg" - call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST vbld" - call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -c write (iout,*) "Processor",myrank," BROADCAST vbld_inv" - endif -c write (iout,*) 'Processor',myrank, -c & ' calling etotal_short ipot=',ipot - call flush(iout) -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#endif -c call int_from_cart1(.false.) -c -c Calculate the bond-stretching energy -c - call ebond(estr) -C -C Calculate the disulfide-bridge and other energy and the contributions -C from other distance constraints. - call edis(ehpb) -C -C Calculate the virtual-bond-angle energy. -C - call ebend(ebe) -C -C Calculate the SC local energy. -C - call vec_and_deriv - call esc(escloc) -C -C Calculate the virtual-bond torsional energy. -C - call etor(etors,edihcnstr) -C -C 6/23/01 Calculate double-torsional energy -C - call etor_d(etors_d) - do i=1,n_ene - energia(i)=0.0d0 - enddo - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(17)=estr -c write (iout,*) "ETOTAL_SHORT before SUM_ENERGY" - call flush(iout) - call sum_energy(energia,.true.) -c write (iout,*) "Exit ETOTAL_SHORT" - call flush(iout) - return - end diff --git a/source/unres/src_MD-M-newcorr/entmcm.F b/source/unres/src_MD-M-newcorr/entmcm.F deleted file mode 100644 index 14576d5..0000000 --- a/source/unres/src_MD-M-newcorr/entmcm.F +++ /dev/null @@ -1,688 +0,0 @@ - subroutine entmcm -C Does modified entropic sampling in the space of minima. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPL - include 'COMMON.INFO' -#endif - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.THREAD' - include 'COMMON.NAMES' - logical accepted,not_done,over,ovrtim,error,lprint - integer MoveType,nbond - integer conf_comp - double precision RandOrPert - double precision varia(maxvar),elowest,ehighest,eold - double precision przes(3),obr(3,3) - double precision varold(maxvar) - logical non_conv - double precision energia(0:n_ene),energia_ave(0:n_ene) -C -cd write (iout,*) 'print_mc=',print_mc - WhatsUp=0 - maxtrial_iter=50 -c--------------------------------------------------------------------------- -C Initialize counters. -c--------------------------------------------------------------------------- -C Total number of generated confs. - ngen=0 -C Total number of moves. In general this won't be equal to the number of -C attempted moves, because we may want to reject some "bad" confs just by -C overlap check. - nmove=0 -C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... -C motions. - do i=1,nres - nbond_move(i)=0 - enddo -C Initialize total and accepted number of moves of various kind. - do i=0,MaxMoveType - moves(i)=0 - moves_acc(i)=0 - enddo -C Total number of energy evaluations. - neneval=0 - nfun=0 - indminn=-max_ene - indmaxx=max_ene - delte=0.5D0 - facee=1.0D0/(maxacc*delte) - conste=dlog(facee) -C Read entropy from previous simulations. - if (ent_read) then - read (ientin,*) indminn,indmaxx,emin,emax - print *,'indminn=',indminn,' indmaxx=',indmaxx,' emin=',emin, - & ' emax=',emax - do i=-max_ene,max_ene - entropy(i)=(emin+i*delte)*betbol - enddo - read (ientin,*) (ijunk,ejunk,entropy(i),i=indminn,indmaxx) - indmin=indminn - indmax=indmaxx - write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx, - & ' emin=',emin,' emax=',emax - write (iout,'(/a)') 'Initial entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - endif ! ent_read -C Read the pool of conformations - call read_pool -C---------------------------------------------------------------------------- -C Entropy-sampling simulations with continually updated entropy -C Loop thru simulations -C---------------------------------------------------------------------------- - DO ISWEEP=1,NSWEEP -C---------------------------------------------------------------------------- -C Take a conformation from the pool -C---------------------------------------------------------------------------- - if (npool.gt.0) then - ii=iran_num(1,npool) - do i=1,nvar - varia(i)=xpool(i,ii) - enddo - write (iout,*) 'Took conformation',ii,' from the pool energy=', - & epool(ii) - call var_to_geom(nvar,varia) -C Print internal coordinates of the initial conformation - call intout - else - call gen_rand_conf(1,*20) - endif -C---------------------------------------------------------------------------- -C Compute and print initial energies. -C---------------------------------------------------------------------------- - nsave=0 -#ifdef MPL - if (MyID.eq.MasterID) then - do i=1,nctasks - nsave_part(i)=0 - enddo - endif -#endif - Kwita=0 - WhatsUp=0 - write (iout,'(/80(1h*)/a,i2/80(1h*)/)') 'MCE iteration #',isweep - write (iout,'(/80(1h*)/a)') 'Initial energies:' - call chainbuild - call etotal(energia(0)) - etot = energia(0) - call enerprint(energia(0)) -C Minimize the energy of the first conformation. - if (minim) then - call geom_to_var(nvar,varia) - call minimize(etot,varia,iretcode,nfun) - call etotal(energia(0)) - etot = energia(0) - write (iout,'(/80(1h*)/a/80(1h*))') - & 'Results of the first energy minimization:' - call enerprint(energia(0)) - endif - if (refstr) then - kkk=1 - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,kkk), - &nsup,przes, - & obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order:',co - write (istat,'(i5,11(1pe14.5))') 0, - & (energia(print_order(i)),i=1,nprint_ene),etot,rms,frac,co - else - write (istat,'(i5,9(1pe14.5))') 0, - & (energia(print_order(i)),i=1,nprint_ene),etot - endif - close(istat) - neneval=neneval+nfun+1 - if (.not. ent_read) then -C Initialize the entropy array - do i=-max_ene,max_ene - emin=etot -C Uncomment the line below for actual entropic sampling (start with uniform -C energy distribution). -c entropy(i)=0.0D0 -C Uncomment the line below for multicanonical sampling (start with Boltzmann -C distribution). - entropy(i)=(emin+i*delte)*betbol - enddo - emax=10000000.0D0 - emin=etot - write (iout,'(/a)') 'Initial entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - endif ! ent_read -#ifdef MPL - call recv_stop_sig(Kwita) - if (whatsup.eq.1) then - call send_stop_sig(-2) - not_done=.false. - else if (whatsup.le.-2) then - not_done=.false. - else if (whatsup.eq.2) then - not_done=.false. - else - not_done=.true. - endif -#else - not_done = (iretcode.ne.11) -#endif - write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Enter Monte Carlo procedure.' - close(igeom) - call briefout(0,etot) - do i=1,nvar - varold(i)=varia(i) - enddo - eold=etot - indeold=(eold-emin)/delte - deix=eold-(emin+indeold*delte) - dent=entropy(indeold+1)-entropy(indeold) -cd write (iout,*) 'indeold=',indeold,' deix=',deix,' dent=',dent -cd write (*,*) 'Processor',MyID,' indeold=',indeold,' deix=',deix, -cd & ' dent=',dent - sold=entropy(indeold)+(dent/delte)*deix - elowest=etot - write (iout,*) 'eold=',eold,' sold=',sold,' elowest=',etot - write (*,*) 'Processor',MyID,' eold=',eold,' sold=',sold, - & ' elowest=',etot - if (minim) call zapis(varia,etot) - nminima(1)=1.0D0 -C NACC is the counter for the accepted conformations of a given processor - nacc=0 -C NACC_TOT counts the total number of accepted conformations - nacc_tot=0 -#ifdef MPL - if (MyID.eq.MasterID) then - call receive_MCM_info - else - call send_MCM_info(2) - endif -#endif - do iene=indminn,indmaxx - nhist(iene)=0.0D0 - enddo - do i=2,maxsave - nminima(i)=0.0D0 - enddo -C Main loop. -c---------------------------------------------------------------------------- - elowest=1.0D10 - ehighest=-1.0D10 - it=0 - do while (not_done) - it=it+1 - if (print_mc.gt.0) write (iout,'(80(1h*)/20x,a,i7)') - & 'Beginning iteration #',it -C Initialize local counter. - ntrial=0 ! # of generated non-overlapping confs. - noverlap=0 ! # of overlapping confs. - accepted=.false. - do while (.not. accepted .and. WhatsUp.eq.0 .and. Kwita.eq.0) - ntrial=ntrial+1 -C Retrieve the angles of previously accepted conformation - do j=1,nvar - varia(j)=varold(j) - enddo -cd write (iout,'(a)') 'Old variables:' -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - call var_to_geom(nvar,varia) -C Rebuild the chain. - call chainbuild - MoveType=0 - nbond=0 - lprint=.true. -C Decide whether to generate a random conformation or perturb the old one - RandOrPert=ran_number(0.0D0,1.0D0) - if (RandOrPert.gt.RanFract) then - if (print_mc.gt.0) - & write (iout,'(a)') 'Perturbation-generated conformation.' - call perturb(error,lprint,MoveType,nbond,1.0D0) - if (error) goto 20 - if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then - write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=', - & MoveType,' returned from PERTURB.' - goto 20 - endif - call chainbuild - else - MoveType=0 - moves(0)=moves(0)+1 - nstart_grow=iran_num(3,nres) - if (print_mc.gt.0) - & write (iout,'(2a,i3)') 'Random-generated conformation', - & ' - chain regrown from residue',nstart_grow - call gen_rand_conf(nstart_grow,*30) - endif - call geom_to_var(nvar,varia) -cd write (iout,'(a)') 'New variables:' -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - ngen=ngen+1 - if (print_mc.gt.0) write (iout,'(a,i5,a,i10,a,i10)') - & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen - if (print_mc.gt.0) write (*,'(a,i5,a,i10,a,i10)') - & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen - call etotal(energia(0)) - etot = energia(0) -c call enerprint(energia(0)) -c write (iout,'(2(a,1pe14.5))') 'Etot=',Etot,' Elowest=',Elowest - if (etot-elowest.gt.overlap_cut) then - write (iout,'(a,i5,a,1pe14.5)') 'Iteration',it, - & ' Overlap detected in the current conf.; energy is',etot - neneval=neneval+1 - accepted=.false. - noverlap=noverlap+1 - if (noverlap.gt.maxoverlap) then - write (iout,'(a)') 'Too many overlapping confs.' - goto 20 - endif - else - if (minim) then - call minimize(etot,varia,iretcode,nfun) -cd write (iout,'(a)') 'Variables after minimization:' -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - call etotal(energia(0)) - etot = energia(0) - neneval=neneval+nfun+1 - endif - if (print_mc.gt.2) then - write (iout,'(a)') 'Total energies of trial conf:' - call enerprint(energia(0)) - else if (print_mc.eq.1) then - write (iout,'(a,i6,a,1pe16.6)') - & 'Trial conformation:',ngen,' energy:',etot - endif -C-------------------------------------------------------------------------- -C... Acceptance test -C-------------------------------------------------------------------------- - accepted=.false. - if (WhatsUp.eq.0) - & call accepting(etot,eold,scur,sold,varia,varold, - & accepted) - if (accepted) then - nacc=nacc+1 - nacc_tot=nacc_tot+1 - if (elowest.gt.etot) elowest=etot - if (ehighest.lt.etot) ehighest=etot - moves_acc(MoveType)=moves_acc(MoveType)+1 - if (MoveType.eq.1) then - nbond_acc(nbond)=nbond_acc(nbond)+1 - endif -C Check against conformation repetitions. - irep=conf_comp(varia,etot) -#if defined(AIX) || defined(PGI) - open (istat,file=statname,position='append') -#else - open (istat,file=statname,access='append') -#endif - if (refstr) then - kkk=1 - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,kkk), - & nsup, - & przes,obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - if (print_mc.gt.0) - & write (iout,'(a,f8.3,a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order:',co - if (print_stat) - & write (istat,'(i5,11(1pe14.5))') it, - & (energia(print_order(i)),i=1,nprint_ene),etot, - & rms,frac,co - elseif (print_stat) then - write (istat,'(i5,10(1pe14.5))') it, - & (energia(print_order(i)),i=1,nprint_ene),etot - endif - close(istat) - if (print_mc.gt.1) - & call statprint(nacc,nfun,iretcode,etot,elowest) -C Print internal coordinates. - if (print_int) call briefout(nacc,etot) -#ifdef MPL - if (MyID.ne.MasterID) then - call recv_stop_sig(Kwita) -cd print *,'Processor:',MyID,' STOP=',Kwita - if (irep.eq.0) then - call send_MCM_info(2) - else - call send_MCM_info(1) - endif - endif -#endif -C Store the accepted conf. and its energy. - eold=etot - sold=scur - do i=1,nvar - varold(i)=varia(i) - enddo - if (irep.eq.0) then - irep=nsave+1 -cd write (iout,*) 'Accepted conformation:' -cd write (iout,*) (rad2deg*varia(i),i=1,nphi) - if (minim) call zapis(varia,etot) - do i=1,n_ene - ener(i,nsave)=energia(i) - enddo - ener(n_ene+1,nsave)=etot - ener(n_ene+2,nsave)=frac - endif - nminima(irep)=nminima(irep)+1.0D0 -c print *,'irep=',irep,' nminima=',nminima(irep) -#ifdef MPL - if (Kwita.eq.0) call recv_stop_sig(kwita) -#endif - endif ! accepted - endif ! overlap -#ifdef MPL - if (MyID.eq.MasterID) then - call receive_MCM_info - if (nacc_tot.ge.maxacc) accepted=.true. - endif -#endif - if (ntrial.gt.maxtrial_iter .and. npool.gt.0) then -C Take a conformation from the pool - ii=iran_num(1,npool) - do i=1,nvar - varia(i)=xpool(i,ii) - enddo - write (iout,*) 'Iteration',it,' max. # of trials exceeded.' - write (iout,*) - & 'Take conformation',ii,' from the pool energy=',epool(ii) - if (print_mc.gt.2) - & write (iout,'(10f8.3)') (rad2deg*varia(i),i=1,nvar) - ntrial=0 - endif ! (ntrial.gt.maxtrial_iter .and. npool.gt.0) - 30 continue - enddo ! accepted -#ifdef MPL - if (MyID.eq.MasterID) then - call receive_MCM_info - endif - if (Kwita.eq.0) call recv_stop_sig(kwita) -#endif - if (ovrtim()) WhatsUp=-1 -cd write (iout,*) 'WhatsUp=',WhatsUp,' Kwita=',Kwita - not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) - & .and. (Kwita.eq.0) -cd write (iout,*) 'not_done=',not_done -#ifdef MPL - if (Kwita.lt.0) then - print *,'Processor',MyID, - & ' has received STOP signal =',Kwita,' in EntSamp.' -cd print *,'not_done=',not_done - if (Kwita.lt.-1) WhatsUp=Kwita - else if (nacc_tot.ge.maxacc) then - print *,'Processor',MyID,' calls send_stop_sig,', - & ' because a sufficient # of confs. have been collected.' -cd print *,'not_done=',not_done - call send_stop_sig(-1) - else if (WhatsUp.eq.-1) then - print *,'Processor',MyID, - & ' calls send_stop_sig because of timeout.' -cd print *,'not_done=',not_done - call send_stop_sig(-2) - endif -#endif - enddo ! not_done - -C----------------------------------------------------------------- -C... Construct energy histogram & update entropy -C----------------------------------------------------------------- - go to 21 - 20 WhatsUp=-3 -#ifdef MPL - write (iout,*) 'Processor',MyID, - & ' is broadcasting ERROR-STOP signal.' - write (*,*) 'Processor',MyID, - & ' is broadcasting ERROR-STOP signal.' - call send_stop_sig(-3) -#endif - 21 continue -#ifdef MPL - if (MyID.eq.MasterID) then -c call receive_MCM_results - call receive_energies -#endif - do i=1,nsave - if (esave(i).lt.elowest) elowest=esave(i) - if (esave(i).gt.ehighest) ehighest=esave(i) - enddo - write (iout,'(a,i10)') '# of accepted confs:',nacc_tot - write (iout,'(a,f10.5,a,f10.5)') 'Lowest energy:',elowest, - & ' Highest energy',ehighest - if (isweep.eq.1 .and. .not.ent_read) then - emin=elowest - emax=ehighest - write (iout,*) 'EMAX=',emax - indminn=0 - indmaxx=(ehighest-emin)/delte - indmin=indminn - indmax=indmaxx - do i=-max_ene,max_ene - entropy(i)=(emin+i*delte)*betbol - enddo - ent_read=.true. - else - indmin=(elowest-emin)/delte - indmax=(ehighest-emin)/delte - if (indmin.lt.indminn) indminn=indmin - if (indmax.gt.indmaxx) indmaxx=indmax - endif - write(iout,*)'indminn=',indminn,' indmaxx=',indmaxx -C Construct energy histogram - do i=1,nsave - inde=(esave(i)-emin)/delte - nhist(inde)=nhist(inde)+nminima(i) - enddo -C Update entropy (density of states) - do i=indmin,indmax - if (nhist(i).gt.0) then - entropy(i)=entropy(i)+dlog(nhist(i)+0.0D0) - endif - enddo -Cd do i=indmaxx+1 -Cd entropy(i)=1.0D+10 -Cd enddo - write (iout,'(/80(1h*)/a,i2/80(1h*)/)') - & 'End of macroiteration',isweep - write (iout,'(a,f10.5,a,f10.5)') 'Elowest=',elowest, - & ' Ehighest=',ehighest - write (iout,'(a)') 'Frequecies of minima' - do i=1,nsave - write (iout,'(i5,f5.0,f10.5)') i,nminima(i),esave(i) - enddo - write (iout,'(/a)') 'Energy histogram' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,nhist(i) - enddo - write (iout,'(/a)') 'Entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo -C----------------------------------------------------------------- -C... End of energy histogram construction -C----------------------------------------------------------------- -#ifdef MPL - entropy(-max_ene-4)=dfloat(indminn) - entropy(-max_ene-3)=dfloat(indmaxx) - entropy(-max_ene-2)=emin - entropy(-max_ene-1)=emax - call send_MCM_update -cd print *,entname,ientout - open (ientout,file=entname,status='unknown') - write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax - do i=indminn,indmaxx - write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) - enddo - close(ientout) - else - write (iout,'(a)') 'Frequecies of minima' - do i=1,nsave - write (iout,'(i5,f5.0,f10.5)') i,nminima(i),esave(i) - enddo -c call send_MCM_results - call send_energies - call receive_MCM_update - indminn=entropy(-max_ene-4) - indmaxx=entropy(-max_ene-3) - emin=entropy(-max_ene-2) - emax=entropy(-max_ene-1) - write (iout,*) 'Received from master:' - write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx, - & ' emin=',emin,' emax=',emax - write (iout,'(/a)') 'Entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - endif - if (WhatsUp.lt.-1) return -#else - if (ovrtim() .or. WhatsUp.lt.0) return -#endif - - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc,nfun,iretcode,etot,elowest) - write (iout,'(a)') - & 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) - write (iout,'(a,i10)') 'Number of chain regrowths:',nregrow - write (iout,'(a,i10)') 'Accepted chain regrowths:',nregrow_acc - -C--------------------------------------------------------------------------- - ENDDO ! ISWEEP -C--------------------------------------------------------------------------- - - runtime=tcpu() - - if (isweep.eq.nsweep .and. it.ge.maxacc) - &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' - return - end -c------------------------------------------------------------------------------ - subroutine accepting(ecur,eold,scur,sold,x,xold,accepted) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' -#ifdef MPL - include 'COMMON.INFO' -#endif - include 'COMMON.GEO' - double precision ecur,eold,xx,ran_number,bol - double precision x(maxvar),xold(maxvar) - double precision tole /1.0D-1/, tola /5.0D0/ - logical accepted -C Check if the conformation is similar. -cd write (iout,*) 'Enter ACCEPTING' -cd write (iout,*) 'Old PHI angles:' -cd write (iout,*) (rad2deg*xold(i),i=1,nphi) -cd write (iout,*) 'Current angles' -cd write (iout,*) (rad2deg*x(i),i=1,nphi) -cd ddif=dif_ang(nphi,x,xold) -cd write (iout,*) 'Angle norm:',ddif -cd write (iout,*) 'ecur=',ecur,' emax=',emax - if (ecur.gt.emax) then - accepted=.false. - if (print_mc.gt.0) - & write (iout,'(a)') 'Conformation rejected as too high in energy' - return - else if (dabs(ecur-eold).lt.tole .and. - & dif_ang(nphi,x,xold).lt.tola) then - accepted=.false. - if (print_mc.gt.0) - & write (iout,'(a)') 'Conformation rejected as too similar' - return - endif -C Else evaluate the entropy of the conf and compare it with that of the previous -C one. - indecur=(ecur-emin)/delte - if (iabs(indecur).gt.max_ene) then - write (iout,'(a,2i5)') - & 'Accepting: Index out of range:',indecur - scur=1000.0D0 - else if (indecur.eq.indmaxx) then - scur=entropy(indecur) - if (print_mc.gt.0) write (iout,*)'Energy boundary reached', - & indmaxx,indecur,entropy(indecur) - else - deix=ecur-(emin+indecur*delte) - dent=entropy(indecur+1)-entropy(indecur) - scur=entropy(indecur)+(dent/delte)*deix - endif -cd print *,'Processor',MyID,' ecur=',ecur,' indecur=',indecur, -cd & ' scur=',scur,' eold=',eold,' sold=',sold -cd print *,'deix=',deix,' dent=',dent,' delte=',delte - if (print_mc.gt.1) then - write(iout,*)'ecur=',ecur,' indecur=',indecur,' scur=',scur - write(iout,*)'eold=',eold,' sold=',sold - endif - if (scur.le.sold) then - accepted=.true. - else -C Else carry out acceptance test - xx=ran_number(0.0D0,1.0D0) - xxh=scur-sold - if (xxh.gt.50.0D0) then - bol=0.0D0 - else - bol=exp(-xxh) - endif - if (bol.gt.xx) then - accepted=.true. - if (print_mc.gt.0) write (iout,'(a)') - & 'Conformation accepted.' - else - accepted=.false. - if (print_mc.gt.0) write (iout,'(a)') - & 'Conformation rejected.' - endif - endif - return - end -c----------------------------------------------------------------------------- - subroutine read_pool - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.VAR' - double precision varia(maxvar) - print '(a)','Call READ_POOL' - do npool=1,max_pool - print *,'i=',i - read (intin,'(i5,f10.5)',end=10,err=10) iconf,epool(npool) - if (epool(npool).eq.0.0D0) goto 10 - call read_angles(intin,*10) - call geom_to_var(nvar,xpool(1,npool)) - enddo - goto 11 - 10 npool=npool-1 - 11 write (iout,'(a,i5)') 'Number of pool conformations:',npool - if (print_mc.gt.2) then - do i=1,npool - write (iout,'(a,i5,a,1pe14.5)') 'Pool conformation',i,' energy', - & epool(i) - write (iout,'(10f8.3)') (rad2deg*xpool(j,i),j=1,nvar) - enddo - endif ! (print_mc.gt.2) - return - end diff --git a/source/unres/src_MD-M-newcorr/env.log b/source/unres/src_MD-M-newcorr/env.log deleted file mode 100644 index 2e32370..0000000 --- a/source/unres/src_MD-M-newcorr/env.log +++ /dev/null @@ -1,97 +0,0 @@ -USER=liwo -LOGNAME=liwo -HOME=/usr/users/7/liwo -PATH=/usr/users/9/amorris/java/bin:/usr/local/packages/TAU-2.17/tau-2.17/x86_64/bin:/usr/local/packages/TAU-2.17/tau-2.17/xt3/bin:/usr/psc/bin:/opt/kde3/bin:/opt/gnome/bin:/usr/games:/usr/bin/X11:/usr/local/packages/dmover/1.0/bin:/usr/psc/gnu/bin:/usr/psc/krb5/bin:/usr/local/bin:/usr/local/packages/tg/bin:/opt/xt-lustre-ss/1.5.60/usr/sbin:/opt/xt-lustre-ss/1.5.60/usr/bin:/opt/cray/bin:/opt/cray/etc:/opt/xt-boot/1.5.60/bin/snos64:/opt/xt-catamount/1.5.60/bin/snos64:/opt/xt-os/1.5.60/bin/snos64:/opt/xt-service/1.5.60/bin/snos64:/opt/xt-pbs/5.3.5-6xt_psc/bin:/opt/xt-prgenv/1.5.60/bin:/opt/xt-pe/1.5.60/cnos/linux/64/bin:/opt/xt-pe/1.5.60/bin/snos64:/opt/xt-mpt/1.5.60/mpich2-64/P2/bin:/opt/toolworks/totalview.8.4.1b/bin:/opt/totalview-support/1.0.5/bin:/opt/pgi/7.2.2/linux86-64/7.2/bin:/opt/modules/3.1.6/bin:/usr/bin:/bin:/usr/sbin:/sbin:/usr/psc/gsissh/bin -MAIL=/var/mail/liwo -SHELL=/bin/tcsh -SSH_CLIENT=83.11.114.54 4271 22 -SSH_CONNECTION=83.11.114.54 4271 128.182.112.209 22 -SSH_TTY=/dev/pts/2 -TERM=xterm -KRB5CCNAME=FILE:/tmp/krb5cc_18087_SQvLWm6509 -HOSTTYPE=x86_64-linux -VENDOR=suse -OSTYPE=linux -MACHTYPE=x86_64 -SHLVL=1 -PWD=/usr/users/7/liwo/UNRES/src_TC_newmat.tau -GROUP=mtuamnp -HOST=tg-login9 -HOSTNAME=tg-login9.bigben.psc.teragrid.org -MANPATH=/usr/local/packages/dmover/1.0/man:/opt/xt-lustre-ss/1.5.60/lustre/man:/opt/cray_1.5.60/man:/opt/xt-os/1.5.60/ros/man:/opt/xt-libc/1.5.60/xt3_glibc/man:/opt/xt-pbs/5.3.5-6xt_psc/man:/opt/xt-pe/1.5.60/pe/man:/opt/xt-pe/1.5.60/papi/man:/opt/xt-mpt/1.5.60/romio/man:/opt/xt-mpt/1.5.60/mpich2-64/man:/opt/xt-libsci/10.0.0/man:/opt/toolworks/totalview.8.4.1b/man:/opt/pgi/7.2.2/linux86-64/7.2/man:/usr/share/man:/usr/X11R6/man:/usr/local/man:/opt/gnome/share/man -MINICOM=-c on -INFODIR=/usr/local/info:/usr/share/info:/usr/info -INFOPATH=/usr/local/info:/usr/share/info:/usr/info -LESS=-M -I -LESSOPEN=lessopen.sh %s -LESSCLOSE=lessclose.sh %s %s -LESSKEY=/etc/lesskey.bin -PAGER=/usr/bin/less -MORE=-sl -GZIP=-9 -CSHEDIT=emacs -COLORTERM=1 -NNTPSERVER=news -XFILESEARCHPATH=/usr/lib/X11/%L/%T/%N%C:/usr/lib/X11/%l/%T/%N%C:/usr/lib/X11/%T/%N%C:/usr/lib/X11/%L/%T/%N:/usr/lib/X11/%l/%T/%N:/usr/lib/X11/%T/%N:/var/X11R6/%T/%N%C:/var/X11R6/%T/%N -INPUTRC=/etc/inputrc -LANG=en_US.UTF-8 -QTDIR=/usr/lib/qt3 -no_proxy=localhost -WINDOWMANAGER=/usr/X11R6/bin/kde -CVS_RSH=ssh -G_BROKEN_FILENAMES=1 -GTK_PATH=/usr/local/lib64/gtk-2.0:/opt/gnome/lib64/gtk-2.0:/usr/lib64/gtk-2.0 -WHATAMI=x86_64 -TVDSVRLAUNCHCMD=ssh -CSHRCREAD=true -LS_COLORS=no=00:fi=00:di=01;34:ln=00;36:pi=40;33:so=01;35:do=01;35:bd=40;33;01:cd=40;33;01:or=40;31:ex=00;32:*.cmd=00;32:*.exe=01;32:*.com=01;32:*.bat=01;32:*.btm=01;32:*.dll=01;32:*.tar=00;31:*.tbz=00;31:*.tgz=00;31:*.rpm=00;31:*.deb=00;31:*.arj=00;31:*.taz=00;31:*.lzh=00;31:*.zip=00;31:*.zoo=00;31:*.z=00;31:*.Z=00;31:*.gz=00;31:*.bz2=00;31:*.tb2=00;31:*.tz2=00;31:*.tbz2=00;31:*.avi=01;35:*.bmp=01;35:*.fli=01;35:*.gif=01;35:*.jpg=01;35:*.jpeg=01;35:*.mng=01;35:*.mov=01;35:*.mpg=01;35:*.pcx=01;35:*.pbm=01;35:*.pgm=01;35:*.png=01;35:*.ppm=01;35:*.tga=01;35:*.tif=01;35:*.xbm=01;35:*.xpm=01;35:*.dl=01;35:*.gl=01;35:*.aiff=00;32:*.au=00;32:*.mid=00;32:*.mp3=00;32:*.ogg=00;32:*.voc=00;32:*.wav=00;32: -LS_OPTIONS=-N --color=tty -T 0 -MODULEPATH=/opt/modulefiles:/usr/local/modulefiles -MODULE_VERSION=3.1.6 -MODULE_VERSION_STACK=3.1.6 -MODULESHOME=/opt/modules/3.1.6 -LOADEDMODULES=modules/3.1.6:pgi/7.2.2:totalview-support/1.0.5:xt-totalview/8.4.1b:xt-libsci/10.0.0:xt-mpt/1.5.60:xt-pe/1.5.60:PrgEnv-pgi/1.5.60:xt-pbs/5.3.5-6xt_psc:xt-service/1.5.60:xt-libc/1.5.60:xt-os/1.5.60:xt-catamount/1.5.60:xt-boot/1.5.60:xt-crms/1.5.60:xt-lustre-ss/1.5.60:Base-opts/1.5.60:psc_path/1.0:dmover/1.0:tau/tau-2.17 -_MODULESBEGINENV_=/usr/users/7/liwo/.modulesbeginenv -_LMFILES_=/opt/modulefiles/modules/3.1.6:/opt/modulefiles/pgi/7.2.2:/opt/modulefiles/totalview-support/1.0.5:/opt/modulefiles/xt-totalview/8.4.1b:/opt/modulefiles/xt-libsci/10.0.0:/opt/modulefiles/xt-mpt/1.5.60:/opt/modulefiles/xt-pe/1.5.60:/opt/modulefiles/PrgEnv-pgi/1.5.60:/opt/modulefiles/xt-pbs/5.3.5-6xt_psc:/opt/modulefiles/xt-service/1.5.60:/opt/modulefiles/xt-libc/1.5.60:/opt/modulefiles/xt-os/1.5.60:/opt/modulefiles/xt-catamount/1.5.60:/opt/modulefiles/xt-boot/1.5.60:/opt/modulefiles/xt-crms/1.5.60:/opt/modulefiles/xt-lustre-ss/1.5.60:/opt/modulefiles/Base-opts/1.5.60:/usr/local/modulefiles/psc_path/1.0:/usr/local/modulefiles/dmover/1.0:/usr/local/modulefiles/tau/tau-2.17 -PE_PRODUCT_LIST=LUSTRE:CRMS:MPT:LIBSCI:TOTALVIEW:TOTALVIEW-SUPPORT:PGI -PE_PGI_VARIANT=P2 -LD_LIBRARY_PATH=/opt/cray/lib:/opt/xt-os/1.5.60/lib:/opt/xt-libc/1.5.60/amd64/lib:/opt/xt-pe/1.5.60/lib:/opt/xt-mpt/1.5.60/mpich2-64/P2/lib:/opt/pgi/7.2.2/linux86-64/7.2/libso:/opt/pgi/7.2.2/linux86-64/7.2/lib -C_DIR=/opt/xt-libc/1.5.60 -CATAMOUNT_DIR=/opt/xt-catamount/1.5.60 -LM_LICENSE_FILE=/opt/pgi/7.2.2/license.dat -CRMS_DIR=/opt/cray -PE_DIR=/opt/xt-pe/1.5.60 -MPICHBASEDIR=/opt/xt-mpt/1.5.60/mpich2-64 -PGI_PATH=/opt/pgi/7.2.2 -LUSTRE_DIR=/opt/xt-lustre-ss/1.5.60 -BUILD_OPTS=/opt/xt-pe/1.5.60/bin/snos64/build-opts -PE_ENV=PGI -MPICH_DIR=/opt/xt-mpt/1.5.60/mpich2-64/P2 -PGI_VERS_STR=7.2.2 -OS_DIR=/opt/xt-os/1.5.60 -PRGENV_DIR=/opt/xt-prgenv/1.5.60 -PGI=/opt/pgi/7.2.2 -TOTALVIEW_SUPPORT_LIB=/opt/totalview-support/1.0.5/lib -BOOT_DIR=/opt/xt-boot/1.5.60 -XTOS_VERSION=1.5.60 -MPICH_DIR_FTN_DEFAULT64=/opt/xt-mpt/1.5.60/mpich2-64/P2W -PGI_VERSION=7.2 -SE_DIR=/opt/xt-service/1.5.60 -LIBSCI_BASE_DIR=/opt/xt-libsci/10.0.0 -MPT_DIR=/opt/xt-mpt/1.5.60 -PTL_SNOS_NAL=SS -YOD_LOGFILE=syslog -RCLOCAL_PRGENV=true -DMOVER_HOME=/usr/users/3/rbudden/work/dmover -LIBLUSTRE_DEBUG_CONSOLE=0 -SCRATCH=/scratcha/liwo -TG_EXAMPLES=/usr/local/packages/tg/examples -TG_COMMUNITY=/usr/local/packages/tg -TG_CLUSTER_HOME=/usr/users/7/liwo -MYPROXY_SERVER=myproxy.teragrid.org -GLOBUS_LOCATION=/usr/local/globus/packages/globus/globus-4.0.1 -CORE_ACTION_FIRST=KILL -CORE_ACTION_OTHER=KILL -JAVA_ROOT_DIR=/usr/users/9/amorris/java/bin -TAU_MAKEFILE=/usr/local/packages/TAU-2.17/tau-2.17/xt3/lib/Makefile.tau-mpi-pdt-pgi -TAU_ROOT_DIR=/usr/local/packages/TAU-2.17/tau-2.17 diff --git a/source/unres/src_MD-M-newcorr/fitsq.f b/source/unres/src_MD-M-newcorr/fitsq.f deleted file mode 100644 index 1c97e6d..0000000 --- a/source/unres/src_MD-M-newcorr/fitsq.f +++ /dev/null @@ -1,364 +0,0 @@ - subroutine fitsq(rms,x,y,nn,t,b,non_conv) - implicit real*8 (a-h,o-z) - include 'COMMON.IOUNITS' -c x and y are the vectors of coordinates (dimensioned (3,n)) of the two -c structures to be superimposed. nn is 3*n, where n is the number of -c points. t and b are respectively the translation vector and the -c rotation matrix that transforms the second set of coordinates to the -c frame of the first set. -c eta = machine-specific variable - - dimension x(3*nn),y(3*nn),t(3) - dimension b(3,3),q(3,3),r(3,3),v(3),xav(3),yav(3),e(3),c(3,3) - logical non_conv -c eta = z00100000 -c small=25.0*rmdcon(3) -c small=25.0*eta -c small=25.0*10.e-10 -c the following is a very lenient value for 'small' - small = 0.0001D0 - non_conv=.false. - fn=nn - do 10 i=1,3 - xav(i)=0.0D0 - yav(i)=0.0D0 - do 10 j=1,3 - 10 b(j,i)=0.0D0 - nc=0 -c - do 30 n=1,nn - do 20 i=1,3 -c write(iout,*)'x = ',x(nc+i),' y = ',y(nc+i) - xav(i)=xav(i)+x(nc+i)/fn - 20 yav(i)=yav(i)+y(nc+i)/fn - 30 nc=nc+3 -c - do i=1,3 - t(i)=yav(i)-xav(i) - enddo - - rms=0.0d0 - do n=1,nn - do i=1,3 - rms=rms+(y(3*(n-1)+i)-x(3*(n-1)+i)-t(i))**2 - enddo - enddo - rms=dabs(rms/fn) - -c write(iout,*)'xav = ',(xav(j),j=1,3) -c write(iout,*)'yav = ',(yav(j),j=1,3) -c write(iout,*)'t = ',(t(j),j=1,3) -c write(iout,*)'rms=',rms - if (rms.lt.small) return - - - nc=0 - rms=0.0D0 - do 50 n=1,nn - do 40 i=1,3 - rms=rms+((x(nc+i)-xav(i))**2+(y(nc+i)-yav(i))**2)/fn - do 40 j=1,3 - b(j,i)=b(j,i)+(x(nc+i)-xav(i))*(y(nc+j)-yav(j))/fn - 40 c(j,i)=b(j,i) - 50 nc=nc+3 - call sivade(b,q,r,d,non_conv) - sn3=dsign(1.0d0,d) - do 120 i=1,3 - do 120 j=1,3 - 120 b(j,i)=-q(j,1)*r(i,1)-q(j,2)*r(i,2)-sn3*q(j,3)*r(i,3) - call mvvad(b,xav,yav,t) - do 130 i=1,3 - do 130 j=1,3 - rms=rms+2.0*c(j,i)*b(j,i) - 130 b(j,i)=-b(j,i) - if (dabs(rms).gt.small) go to 140 -* write (6,301) - return - 140 if (rms.gt.0.0d0) go to 150 -c write (iout,303) rms - rms=0.0d0 -* stop -c 150 write (iout,302) dsqrt(rms) - 150 continue - return - 301 format (5x,'rms deviation negligible') - 302 format (5x,'rms deviation ',f14.6) - 303 format (//,5x,'negative ms deviation - ',f14.6) - end -c - subroutine sivade(x,q,r,dt,non_conv) - implicit real*8(a-h,o-z) -c computes q,e and r such that q(t)xr = diag(e) - dimension x(3,3),q(3,3),r(3,3),e(3) - dimension h(3,3),p(3,3),u(3,3),d(3) - logical non_conv -c eta = z00100000 -c write (2,*) "SIVADE" - nit = 0 - small=25.0*10.d-10 -c small=25.0*eta -c small=2.0*rmdcon(3) - xnrm=0.0d0 - do 20 i=1,3 - do 10 j=1,3 - xnrm=xnrm+x(j,i)*x(j,i) - u(j,i)=0.0d0 - r(j,i)=0.0d0 - 10 h(j,i)=0.0d0 - u(i,i)=1.0 - 20 r(i,i)=1.0 - xnrm=dsqrt(xnrm) - do 110 n=1,2 - xmax=0.0d0 - do 30 j=n,3 - 30 if (dabs(x(j,n)).gt.xmax) xmax=dabs(x(j,n)) - a=0.0d0 - do 40 j=n,3 - h(j,n)=x(j,n)/xmax - 40 a=a+h(j,n)*h(j,n) - a=dsqrt(a) - den=a*(a+dabs(h(n,n))) - d(n)=1.0/den - h(n,n)=h(n,n)+dsign(a,h(n,n)) - do 70 i=n,3 - s=0.0d0 - do 50 j=n,3 - 50 s=s+h(j,n)*x(j,i) - s=d(n)*s - do 60 j=n,3 - 60 x(j,i)=x(j,i)-s*h(j,n) - 70 continue - if (n.gt.1) go to 110 - xmax=dmax1(dabs(x(1,2)),dabs(x(1,3))) - h(2,3)=x(1,2)/xmax - h(3,3)=x(1,3)/xmax - a=dsqrt(h(2,3)*h(2,3)+h(3,3)*h(3,3)) - den=a*(a+dabs(h(2,3))) - d(3)=1.0/den - h(2,3)=h(2,3)+sign(a,h(2,3)) - do 100 i=1,3 - s=0.0d0 - do 80 j=2,3 - 80 s=s+h(j,3)*x(i,j) - s=d(3)*s - do 90 j=2,3 - 90 x(i,j)=x(i,j)-s*h(j,3) - 100 continue - 110 continue - do 130 i=1,3 - do 120 j=1,3 - 120 p(j,i)=-d(1)*h(j,1)*h(i,1) - 130 p(i,i)=1.0+p(i,i) - do 140 i=2,3 - do 140 j=2,3 - u(j,i)=u(j,i)-d(2)*h(j,2)*h(i,2) - 140 r(j,i)=r(j,i)-d(3)*h(j,3)*h(i,3) - call mmmul(p,u,q) - 150 np=1 - nq=1 - nit=nit+1 -c write (2,*) "nit",nit," e",(x(i,i),i=1,3) - if (nit.gt.10000) then - print '(a)','!!!! Over 10000 iterations in SIVADE!!!!!' - non_conv=.true. - return - endif - if (dabs(x(2,3)).gt.small*(dabs(x(2,2))+abs(x(3,3)))) go to 160 - x(2,3)=0.0d0 - nq=nq+1 - 160 if (dabs(x(1,2)).gt.small*(dabs(x(1,1))+dabs(x(2,2)))) go to 180 - x(1,2)=0.0d0 - if (x(2,3).ne.0.0d0) go to 170 - nq=nq+1 - go to 180 - 170 np=np+1 - 180 if (nq.eq.3) go to 310 - npq=4-np-nq -c write (2,*) "np",np," npq",npq - if (np.gt.npq) go to 230 - n0=0 - do 220 n=np,npq - nn=n+np-1 -c write (2,*) "nn",nn - if (dabs(x(nn,nn)).gt.small*xnrm) go to 220 - x(nn,nn)=0.0d0 - if (x(nn,nn+1).eq.0.0d0) go to 220 - n0=n0+1 -c write (2,*) "nn",nn - go to (190,210,220),nn - 190 do 200 j=2,3 - 200 call givns(x,q,1,j) - go to 220 - 210 call givns(x,q,2,3) - 220 continue -c write (2,*) "nn",nn," np",np," nq",nq," n0",n0 -c write (2,*) "x",(x(i,i),i=1,3) - if (n0.ne.0) go to 150 - 230 nn=3-nq - a=x(nn,nn)*x(nn,nn) - if (nn.gt.1) a=a+x(nn-1,nn)*x(nn-1,nn) - b=x(nn+1,nn+1)*x(nn+1,nn+1)+x(nn,nn+1)*x(nn,nn+1) - c=x(nn,nn)*x(nn,nn+1) - dd=0.5*(a-b) - xn2=c*c - rt=b-xn2/(dd+sign(dsqrt(dd*dd+xn2),dd)) - y=x(np,np)*x(np,np)-rt - z=x(np,np)*x(np,np+1) - do 300 n=np,nn -c write (2,*) "n",n," a",a," b",b," c",c," y",y," z",z - if (dabs(y).lt.dabs(z)) go to 240 - t=z/y - c=1.0/dsqrt(1.0d0+t*t) - s=c*t - go to 250 - 240 t=y/z - s=1.0/dsqrt(1.0d0+t*t) - c=s*t - 250 do 260 j=1,3 - v=x(j,n) - w=x(j,n+1) - x(j,n)=c*v+s*w - x(j,n+1)=-s*v+c*w - a=r(j,n) - b=r(j,n+1) - r(j,n)=c*a+s*b - 260 r(j,n+1)=-s*a+c*b - y=x(n,n) - z=x(n+1,n) - if (dabs(y).lt.dabs(z)) go to 270 - t=z/y - c=1.0/dsqrt(1.0+t*t) - s=c*t - go to 280 - 270 t=y/z - s=1.0/dsqrt(1.0+t*t) - c=s*t - 280 do 290 j=1,3 - v=x(n,j) - w=x(n+1,j) - a=q(j,n) - b=q(j,n+1) - x(n,j)=c*v+s*w - x(n+1,j)=-s*v+c*w - q(j,n)=c*a+s*b - 290 q(j,n+1)=-s*a+c*b - if (n.ge.nn) go to 300 - y=x(n,n+1) - z=x(n,n+2) - 300 continue - go to 150 - 310 do 320 i=1,3 - 320 e(i)=x(i,i) - nit=0 - 330 n0=0 - nit=nit+1 - if (nit.gt.10000) then - print '(a)','!!!! Over 10000 iterations in SIVADE!!!!!' - non_conv=.true. - return - endif -c write (2,*) "e",(e(i),i=1,3) - do 360 i=1,3 - if (e(i).ge.0.0d0) go to 350 - e(i)=-e(i) - do 340 j=1,3 - 340 q(j,i)=-q(j,i) - 350 if (i.eq.1) go to 360 - if (dabs(e(i)).lt.dabs(e(i-1))) go to 360 - call switch(i,1,q,r,e) - n0=n0+1 - 360 continue - if (n0.ne.0) go to 330 -c write (2,*) "e",(e(i),i=1,3) - if (dabs(e(3)).gt.small*xnrm) go to 370 - e(3)=0.0d0 - if (dabs(e(2)).gt.small*xnrm) go to 370 - e(2)=0.0d0 - 370 dt=det(q(1,1),q(1,2),q(1,3))*det(r(1,1),r(1,2),r(1,3)) -c write (2,*) "nit",nit -c write (2,501) (e(i),i=1,3) - return - 501 format (/,5x,'singular values - ',3e15.5) - end - subroutine givns(a,b,m,n) - implicit real*8 (a-h,o-z) - dimension a(3,3),b(3,3) - if (dabs(a(m,n)).lt.dabs(a(n,n))) go to 10 - t=a(n,n)/a(m,n) - s=1.0/dsqrt(1.0+t*t) - c=s*t - go to 20 - 10 t=a(m,n)/a(n,n) - c=1.0/dsqrt(1.0+t*t) - s=c*t - 20 do 30 j=1,3 - v=a(m,j) - w=a(n,j) - x=b(j,m) - y=b(j,n) - a(m,j)=c*v-s*w - a(n,j)=s*v+c*w - b(j,m)=c*x-s*y - 30 b(j,n)=s*x+c*y - return - end - subroutine switch(n,m,u,v,d) - implicit real*8 (a-h,o-z) - dimension u(3,3),v(3,3),d(3) - do 10 i=1,3 - tem=u(i,n) - u(i,n)=u(i,n-1) - u(i,n-1)=tem - if (m.eq.0) go to 10 - tem=v(i,n) - v(i,n)=v(i,n-1) - v(i,n-1)=tem - 10 continue - tem=d(n) - d(n)=d(n-1) - d(n-1)=tem - return - end - subroutine mvvad(b,xav,yav,t) - implicit real*8 (a-h,o-z) - dimension b(3,3),xav(3),yav(3),t(3) -c dimension a(3,3),b(3),c(3),d(3) -c do 10 j=1,3 -c d(j)=c(j) -c do 10 i=1,3 -c 10 d(j)=d(j)+a(j,i)*b(i) - do 10 j=1,3 - t(j)=yav(j) - do 10 i=1,3 - 10 t(j)=t(j)+b(j,i)*xav(i) - return - end - double precision function det (a,b,c) - implicit real*8 (a-h,o-z) - dimension a(3),b(3),c(3) - det=a(1)*(b(2)*c(3)-b(3)*c(2))+a(2)*(b(3)*c(1)-b(1)*c(3)) - 1 +a(3)*(b(1)*c(2)-b(2)*c(1)) - return - end - subroutine mmmul(a,b,c) - implicit real*8 (a-h,o-z) - dimension a(3,3),b(3,3),c(3,3) - do 10 i=1,3 - do 10 j=1,3 - c(i,j)=0.0d0 - do 10 k=1,3 - 10 c(i,j)=c(i,j)+a(i,k)*b(k,j) - return - end - subroutine matvec(uvec,tmat,pvec,nback) - implicit real*8 (a-h,o-z) - real*8 tmat(3,3),uvec(3,nback), pvec(3,nback) -c - do 2 j=1,nback - do 1 i=1,3 - uvec(i,j) = 0.0d0 - do 1 k=1,3 - 1 uvec(i,j)=uvec(i,j)+tmat(i,k)*pvec(k,j) - 2 continue - return - end diff --git a/source/unres/src_MD-M-newcorr/gauss.f b/source/unres/src_MD-M-newcorr/gauss.f deleted file mode 100644 index 7ba6e1d..0000000 --- a/source/unres/src_MD-M-newcorr/gauss.f +++ /dev/null @@ -1,69 +0,0 @@ - subroutine gauss(RO,AP,MT,M,N,*) -c -c CALCULATES (RO**(-1))*AP BY GAUSS ELIMINATION -c RO IS A SQUARE MATRIX -c THE CALCULATED PRODUCT IS STORED IN AP -c ABNORMAL EXIT IF RO IS SINGULAR -c - integer MT, M, N, M1,I,J,IM, - & I1,MI,MI1 - double precision RO(MT,M),AP(MT,N),X,RM,PR, - & Y - if(M.ne.1)goto 10 - X=RO(1,1) - if(dabs(X).le.1.0D-13) return 1 - X=1.0/X - do 16 I=1,N -16 AP(1,I)=AP(1,I)*X - return -10 continue - M1=M-1 - DO1 I=1,M1 - IM=I - RM=DABS(RO(I,I)) - I1=I+1 - do 2 J=I1,M - if(DABS(RO(J,I)).LE.RM) goto 2 - RM=DABS(RO(J,I)) - IM=J -2 continue - If(IM.eq.I)goto 17 - do 3 J=1,N - PR=AP(I,J) - AP(I,J)=AP(IM,J) -3 AP(IM,J)=PR - do 4 J=I,M - PR=RO(I,J) - RO(I,J)=RO(IM,J) -4 RO(IM,J)=PR -17 X=RO(I,I) - if(dabs(X).le.1.0E-13) return 1 - X=1.0/X - do 5 J=1,N -5 AP(I,J)=X*AP(I,J) - do 6 J=I1,M -6 RO(I,J)=X*RO(I,J) - do 7 J=I1,M - Y=RO(J,I) - do 8 K=1,N -8 AP(J,K)=AP(J,K)-Y*AP(I,K) - do 9 K=I1,M -9 RO(J,K)=RO(J,K)-Y*RO(I,K) -7 continue -1 continue - X=RO(M,M) - if(dabs(X).le.1.0E-13) return 1 - X=1.0/X - do 11 J=1,N -11 AP(M,J)=X*AP(M,J) - do 12 I=1,M1 - MI=M-I - MI1=MI+1 - do 14 J=1,N - X=AP(MI,J) - do 15 K=MI1,M -15 X=X-AP(K,J)*RO(MI,K) -14 AP(MI,J)=X -12 continue - return - end diff --git a/source/unres/src_MD-M-newcorr/gen_rand_conf.F b/source/unres/src_MD-M-newcorr/gen_rand_conf.F deleted file mode 100644 index 6caa718..0000000 --- a/source/unres/src_MD-M-newcorr/gen_rand_conf.F +++ /dev/null @@ -1,911 +0,0 @@ - subroutine gen_rand_conf(nstart,*) -C Generate random conformation or chain cut and regrowth. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.MCM' - include 'COMMON.GEO' - include 'COMMON.CONTROL' - logical overlap,back,fail -cd print *,' CG Processor',me,' maxgen=',maxgen - maxsi=100 -cd write (iout,*) 'Gen_Rand_conf: nstart=',nstart - if (nstart.lt.5) then - it1=iabs(itype(2)) - phi(4)=gen_phi(4,iabs(itype(2)),iabs(itype(3))) -c write(iout,*)'phi(4)=',rad2deg*phi(4) - if (nstart.lt.3) theta(3)=gen_theta(iabs(itype(2)),pi,phi(4)) -c write(iout,*)'theta(3)=',rad2deg*theta(3) - if (it1.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(it1,theta(3),alph(2),omeg(2),fail) - nsi=nsi+1 - enddo - if (nsi.gt.maxsi) return1 - endif ! it1.ne.10 - call orig_frame - i=4 - nstart=4 - else - i=nstart - nstart=max0(i,4) - endif - - maxnit=0 - - nit=0 - niter=0 - back=.false. - do while (i.le.nres .and. niter.lt.maxgen) - if (i.lt.nstart) then - if(iprint.gt.1) then - write (iout,'(/80(1h*)/2a/80(1h*))') - & 'Generation procedure went down to ', - & 'chain beginning. Cannot continue...' - write (*,'(/80(1h*)/2a/80(1h*))') - & 'Generation procedure went down to ', - & 'chain beginning. Cannot continue...' - endif - return1 - endif - it1=iabs(itype(i-1)) - it2=iabs(itype(i-2)) - it=iabs(itype(i)) -c print *,'Gen_Rand_Conf: i=',i,' it=',it,' it1=',it1,' it2=',it2, -c & ' nit=',nit,' niter=',niter,' maxgen=',maxgen - phi(i+1)=gen_phi(i+1,it1,it) - if (back) then - phi(i)=gen_phi(i+1,it2,it1) -c print *,'phi(',i,')=',phi(i) - theta(i-1)=gen_theta(it2,phi(i-1),phi(i)) - if (it2.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(it2,theta(i-1),alph(i-2),omeg(i-2),fail) - nsi=nsi+1 - enddo - if (nsi.gt.maxsi) return1 - endif - call locate_next_res(i-1) - endif - theta(i)=gen_theta(it1,phi(i),phi(i+1)) - if (it1.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(it1,theta(i),alph(i-1),omeg(i-1),fail) - nsi=nsi+1 - enddo - if (nsi.gt.maxsi) return1 - endif - call locate_next_res(i) - if (overlap(i-1)) then - if (nit.lt.maxnit) then - back=.true. - nit=nit+1 - else - nit=0 - if (i.gt.3) then - back=.true. - i=i-1 - else - write (iout,'(a)') - & 'Cannot generate non-overlaping conformation. Increase MAXNIT.' - write (*,'(a)') - & 'Cannot generate non-overlaping conformation. Increase MAXNIT.' - return1 - endif - endif - else - back=.false. - nit=0 - i=i+1 - endif - niter=niter+1 - enddo - if (niter.ge.maxgen) then - write (iout,'(a,2i5)') - & 'Too many trials in conformation generation',niter,maxgen - write (*,'(a,2i5)') - & 'Too many trials in conformation generation',niter,maxgen - return1 - endif - do j=1,3 - c(j,nres+1)=c(j,1) - c(j,nres+nres)=c(j,nres) - enddo - return - end -c------------------------------------------------------------------------- - logical function overlap(i) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - data redfac /0.5D0/ - overlap=.false. - iti=iabs(itype(i)) - if (iti.gt.ntyp) return -C Check for SC-SC overlaps. -cd print *,'nnt=',nnt,' nct=',nct - do j=nnt,i-1 - itj=iabs(itype(j)) - if (j.lt.i-1 .or. ipot.ne.4) then - rcomp=sigmaii(iti,itj) - else - rcomp=sigma(iti,itj) - endif -cd print *,'j=',j - if (dist(nres+i,nres+j).lt.redfac*rcomp) then - overlap=.true. -c print *,'overlap, SC-SC: i=',i,' j=',j, -c & ' dist=',dist(nres+i,nres+j),' rcomp=', -c & rcomp - return - endif - enddo -C Check for overlaps between the added peptide group and the preceding -C SCs. - iteli=itel(i) - do j=1,3 - c(j,maxres2+1)=0.5D0*(c(j,i)+c(j,i+1)) - enddo - do j=nnt,i-2 - itj=iabs(itype(j)) -cd print *,'overlap, p-Sc: i=',i,' j=',j, -cd & ' dist=',dist(nres+j,maxres2+1) - if (dist(nres+j,maxres2+1).lt.4.0D0*redfac) then - overlap=.true. - return - endif - enddo -C Check for overlaps between the added side chain and the preceding peptide -C groups. - do j=1,nnt-2 - do k=1,3 - c(k,maxres2+1)=0.5D0*(c(k,j)+c(k,j+1)) - enddo -cd print *,'overlap, SC-p: i=',i,' j=',j, -cd & ' dist=',dist(nres+i,maxres2+1) - if (dist(nres+i,maxres2+1).lt.4.0D0*redfac) then - overlap=.true. - return - endif - enddo -C Check for p-p overlaps - do j=1,3 - c(j,maxres2+2)=0.5D0*(c(j,i)+c(j,i+1)) - enddo - do j=nnt,i-2 - itelj=itel(j) - do k=1,3 - c(k,maxres2+2)=0.5D0*(c(k,j)+c(k,j+1)) - enddo -cd print *,'overlap, p-p: i=',i,' j=',j, -cd & ' dist=',dist(maxres2+1,maxres2+2) - if(iteli.ne.0.and.itelj.ne.0)then - if (dist(maxres2+1,maxres2+2).lt.rpp(iteli,itelj)*redfac) then - overlap=.true. - return - endif - endif - enddo - return - end -c-------------------------------------------------------------------------- - double precision function gen_phi(i,it1,it2) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.BOUNDS' -c gen_phi=ran_number(-pi,pi) -C 8/13/98 Generate phi using pre-defined boundaries - gen_phi=ran_number(phibound(1,i),phibound(2,i)) - return - end -c--------------------------------------------------------------------------- - double precision function gen_theta(it,gama,gama1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - double precision y(2),z(2) - double precision theta_max,theta_min -c print *,'gen_theta: it=',it - theta_min=0.05D0*pi - theta_max=0.95D0*pi - if (dabs(gama).gt.dwapi) then - y(1)=dcos(gama) - y(2)=dsin(gama) - else - y(1)=0.0D0 - y(2)=0.0D0 - endif - if (dabs(gama1).gt.dwapi) then - z(1)=dcos(gama1) - z(2)=dsin(gama1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif - thet_pred_mean=a0thet(it) - do k=1,2 - thet_pred_mean=thet_pred_mean+athet(k,it,1,1)*y(k) - & +bthet(k,it,1,1)*z(k) - enddo - sig=polthet(3,it) - do j=2,0,-1 - sig=sig*thet_pred_mean+polthet(j,it) - enddo - sig=0.5D0/(sig*sig+sigc0(it)) - ak=dexp(gthet(1,it)- - &0.5D0*((gthet(2,it)-thet_pred_mean)/gthet(3,it))**2) -c print '(i5,5(1pe14.4))',it,(gthet(j,it),j=1,3) -c print '(5(1pe14.4))',thet_pred_mean,theta0(it),sig,sig0(it),ak - theta_temp=binorm(thet_pred_mean,theta0(it),sig,sig0(it),ak) - if (theta_temp.lt.theta_min) theta_temp=theta_min - if (theta_temp.gt.theta_max) theta_temp=theta_max - gen_theta=theta_temp -c print '(a)','Exiting GENTHETA.' - return - end -c------------------------------------------------------------------------- - subroutine gen_side(it,the,al,om,fail) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision MaxBoxLen /10.0D0/ - double precision Ap_inv(3,3),a(3,3),z(3,maxlob),W1(maxlob), - & sumW(0:maxlob),y(2),cm(2),eig(2),box(2,2),work(100),detAp(maxlob) - double precision eig_limit /1.0D-8/ - double precision Big /10.0D0/ - double precision vec(3,3) - logical lprint,fail,lcheck - lcheck=.false. - lprint=.false. - fail=.false. - if (the.eq.0.0D0 .or. the.eq.pi) then -#ifdef MPI - write (*,'(a,i4,a,i3,a,1pe14.5)') - & 'CG Processor:',me,' Error in GenSide: it=',it,' theta=',the -#else -cd write (iout,'(a,i3,a,1pe14.5)') -cd & 'Error in GenSide: it=',it,' theta=',the -#endif - fail=.true. - return - endif - tant=dtan(the-pipol) - nlobit=nlob(it) - if (lprint) then -#ifdef MPI - print '(a,i4,a)','CG Processor:',me,' Enter Gen_Side.' - write (iout,'(a,i4,a)') 'Processor:',me,' Enter Gen_Side.' -#endif - print *,'it=',it,' nlobit=',nlobit,' the=',the,' tant=',tant - write (iout,*) 'it=',it,' nlobit=',nlobit,' the=',the, - & ' tant=',tant - endif - do i=1,nlobit - zz1=tant-censc(1,i,it) - do k=1,3 - do l=1,3 - a(k,l)=gaussc(k,l,i,it) - enddo - enddo - detApi=a(2,2)*a(3,3)-a(2,3)**2 - Ap_inv(2,2)=a(3,3)/detApi - Ap_inv(2,3)=-a(2,3)/detApi - Ap_inv(3,2)=Ap_inv(2,3) - Ap_inv(3,3)=a(2,2)/detApi - if (lprint) then - write (*,'(/a,i2/)') 'Cluster #',i - write (*,'(3(1pe14.5),5x,1pe14.5)') - & ((a(l,k),l=1,3),censc(k,i,it),k=1,3) - write (iout,'(/a,i2/)') 'Cluster #',i - write (iout,'(3(1pe14.5),5x,1pe14.5)') - & ((a(l,k),l=1,3),censc(k,i,it),k=1,3) - endif - W1i=0.0D0 - do k=2,3 - do l=2,3 - W1i=W1i+a(k,1)*a(l,1)*Ap_inv(k,l) - enddo - enddo - W1i=a(1,1)-W1i - W1(i)=dexp(bsc(i,it)-0.5D0*W1i*zz1*zz1) -c if (lprint) write(*,'(a,3(1pe15.5)/)') -c & 'detAp, W1, anormi',detApi,W1i,anormi - do k=2,3 - zk=censc(k,i,it) - do l=2,3 - zk=zk+zz1*Ap_inv(k,l)*a(l,1) - enddo - z(k,i)=zk - enddo - detAp(i)=dsqrt(detApi) - enddo - - if (lprint) then - print *,'W1:',(w1(i),i=1,nlobit) - print *,'detAp:',(detAp(i),i=1,nlobit) - print *,'Z' - do i=1,nlobit - print '(i2,3f10.5)',i,(rad2deg*z(j,i),j=2,3) - enddo - write (iout,*) 'W1:',(w1(i),i=1,nlobit) - write (iout,*) 'detAp:',(detAp(i),i=1,nlobit) - write (iout,*) 'Z' - do i=1,nlobit - write (iout,'(i2,3f10.5)') i,(rad2deg*z(j,i),j=2,3) - enddo - endif - if (lcheck) then -C Writing the distribution just to check the procedure - fac=0.0D0 - dV=deg2rad**2*10.0D0 - sum=0.0D0 - sum1=0.0D0 - do i=1,nlobit - fac=fac+W1(i)/detAp(i) - enddo - fac=1.0D0/(2.0D0*fac*pi) -cd print *,it,'fac=',fac - do ial=90,180,2 - y(1)=deg2rad*ial - do iom=-180,180,5 - y(2)=deg2rad*iom - wart=0.0D0 - do i=1,nlobit - do j=2,3 - do k=2,3 - a(j-1,k-1)=gaussc(j,k,i,it) - enddo - enddo - y2=y(2) - - do iii=-1,1 - - y(2)=y2+iii*dwapi - - wykl=0.0D0 - do j=1,2 - do k=1,2 - wykl=wykl+a(j,k)*(y(j)-z(j+1,i))*(y(k)-z(k+1,i)) - enddo - enddo - wart=wart+W1(i)*dexp(-0.5D0*wykl) - - enddo - - y(2)=y2 - - enddo -c print *,'y',y(1),y(2),' fac=',fac - wart=fac*wart - write (20,'(2f10.3,1pd15.5)') y(1)*rad2deg,y(2)*rad2deg,wart - sum=sum+wart - sum1=sum1+1.0D0 - enddo - enddo -c print *,'it=',it,' sum=',sum*dV,' sum1=',sum1*dV - return - endif - -C Calculate the CM of the system -C - do i=1,nlobit - W1(i)=W1(i)/detAp(i) - enddo - sumW(0)=0.0D0 - do i=1,nlobit - sumW(i)=sumW(i-1)+W1(i) - enddo - cm(1)=z(2,1)*W1(1) - cm(2)=z(3,1)*W1(1) - do j=2,nlobit - cm(1)=cm(1)+z(2,j)*W1(j) - cm(2)=cm(2)+W1(j)*(z(3,1)+pinorm(z(3,j)-z(3,1))) - enddo - cm(1)=cm(1)/sumW(nlobit) - cm(2)=cm(2)/sumW(nlobit) - if (cm(1).gt.Big .or. cm(1).lt.-Big .or. - & cm(2).gt.Big .or. cm(2).lt.-Big) then -cd write (iout,'(a)') -cd & 'Unexpected error in GenSide - CM coordinates too large.' -cd write (iout,'(i5,2(1pe14.5))') it,cm(1),cm(2) -cd write (*,'(a)') -cd & 'Unexpected error in GenSide - CM coordinates too large.' -cd write (*,'(i5,2(1pe14.5))') it,cm(1),cm(2) - fail=.true. - return - endif -cd print *,'CM:',cm(1),cm(2) -C -C Find the largest search distance from CM -C - radmax=0.0D0 - do i=1,nlobit - do j=2,3 - do k=2,3 - a(j-1,k-1)=gaussc(j,k,i,it) - enddo - enddo -#ifdef NAG - call f02faf('N','U',2,a,3,eig,work,100,ifail) -#else - call djacob(2,3,10000,1.0d-10,a,vec,eig) -#endif -#ifdef MPI - if (lprint) then - print *,'*************** CG Processor',me - print *,'CM:',cm(1),cm(2) - write (iout,*) '*************** CG Processor',me - write (iout,*) 'CM:',cm(1),cm(2) - print '(A,8f10.5)','Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2) - write (iout,'(A,8f10.5)') - & 'Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2) - endif -#endif - if (eig(1).lt.eig_limit) then - write(iout,'(a)') - & 'From Mult_Norm: Eigenvalues of A are too small.' - write(*,'(a)') - & 'From Mult_Norm: Eigenvalues of A are too small.' - fail=.true. - return - endif - radius=0.0D0 -cd print *,'i=',i - do j=1,2 - radius=radius+pinorm(z(j+1,i)-cm(j))**2 - enddo - radius=dsqrt(radius)+3.0D0/dsqrt(eig(1)) - if (radius.gt.radmax) radmax=radius - enddo - if (radmax.gt.pi) radmax=pi -C -C Determine the boundaries of the search rectangle. -C - if (lprint) then - print '(a,4(1pe14.4))','W1: ',(W1(i),i=1,nlob(it) ) - print '(a,4(1pe14.4))','radmax: ',radmax - endif - box(1,1)=dmax1(cm(1)-radmax,0.0D0) - box(2,1)=dmin1(cm(1)+radmax,pi) - box(1,2)=cm(2)-radmax - box(2,2)=cm(2)+radmax - if (lprint) then -#ifdef MPI - print *,'CG Processor',me,' Array BOX:' -#else - print *,'Array BOX:' -#endif - print '(4(1pe14.4))',((box(k,j),k=1,2),j=1,2) - print '(a,4(1pe14.4))','sumW: ',(sumW(i),i=0,nlob(it) ) -#ifdef MPI - write (iout,*)'CG Processor',me,' Array BOX:' -#else - write (iout,*)'Array BOX:' -#endif - write(iout,'(4(1pe14.4))') ((box(k,j),k=1,2),j=1,2) - write(iout,'(a,4(1pe14.4))')'sumW: ',(sumW(i),i=0,nlob(it) ) - endif - if (box(1,2).lt.-MaxBoxLen .or. box(2,2).gt.MaxBoxLen) then -#ifdef MPI - write (iout,'(a,i4,a)') 'CG Processor:',me,': bad sampling box.' - write (*,'(a,i4,a)') 'CG Processor:',me,': bad sampling box.' -#else -c write (iout,'(a)') 'Bad sampling box.' -#endif - fail=.true. - return - endif - which_lobe=ran_number(0.0D0,sumW(nlobit)) -c print '(a,1pe14.4)','which_lobe=',which_lobe - do i=1,nlobit - if (sumW(i-1).le.which_lobe .and. sumW(i).ge.which_lobe) goto 1 - enddo - 1 ilob=i -c print *,'ilob=',ilob,' nlob=',nlob(it) - do i=2,3 - cm(i-1)=z(i,ilob) - do j=2,3 - a(i-1,j-1)=gaussc(i,j,ilob,it) - enddo - enddo -cd print '(a,i4,a)','CG Processor',me,' Calling MultNorm1.' - call mult_norm1(3,2,a,cm,box,y,fail) - if (fail) return - al=y(1) - om=pinorm(y(2)) -cd print *,'al=',al,' om=',om -cd stop - return - end -c--------------------------------------------------------------------------- - double precision function ran_number(x1,x2) -C Calculate a random real number from the range (x1,x2). - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - double precision x1,x2,fctor - data fctor /2147483647.0D0/ -#ifdef MPI - include "mpif.h" - include 'COMMON.SETUP' - ran_number=x1+(x2-x1)*prng_next(me) -#else - call vrnd(ix,1) - ran_number=x1+(x2-x1)*ix/fctor -#endif - return - end -c-------------------------------------------------------------------------- - integer function iran_num(n1,n2) -C Calculate a random integer number from the range (n1,n2). - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - integer n1,n2,ix - real fctor /2147483647.0/ -#ifdef MPI - include "mpif.h" - include 'COMMON.SETUP' - ix=n1+(n2-n1+1)*prng_next(me) - if (ix.lt.n1) ix=n1 - if (ix.gt.n2) ix=n2 - iran_num=ix -#else - call vrnd(ix,1) - ix=n1+(n2-n1+1)*(ix/fctor) - if (ix.gt.n2) ix=n2 - iran_num=ix -#endif - return - end -c-------------------------------------------------------------------------- - double precision function binorm(x1,x2,sigma1,sigma2,ak) - implicit real*8 (a-h,o-z) -c print '(a)','Enter BINORM.' - alowb=dmin1(x1-3.0D0*sigma1,x2-3.0D0*sigma2) - aupb=dmax1(x1+3.0D0*sigma1,x2+3.0D0*sigma2) - seg=sigma1/(sigma1+ak*sigma2) - alen=ran_number(0.0D0,1.0D0) - if (alen.lt.seg) then - binorm=anorm_distr(x1,sigma1,alowb,aupb) - else - binorm=anorm_distr(x2,sigma2,alowb,aupb) - endif -c print '(a)','Exiting BINORM.' - return - end -c----------------------------------------------------------------------- -c double precision function anorm_distr(x,sigma,alowb,aupb) -c implicit real*8 (a-h,o-z) -c print '(a)','Enter ANORM_DISTR.' -c 10 y=ran_number(alowb,aupb) -c expon=dexp(-0.5D0*((y-x)/sigma)**2) -c ran=ran_number(0.0D0,1.0D0) -c if (expon.lt.ran) goto 10 -c anorm_distr=y -c print '(a)','Exiting ANORM_DISTR.' -c return -c end -c----------------------------------------------------------------------- - double precision function anorm_distr(x,sigma,alowb,aupb) - implicit real*8 (a-h,o-z) -c to make a normally distributed deviate with zero mean and unit variance -c - integer iset - real fac,gset,rsq,v1,v2,ran1 - save iset,gset - data iset/0/ - if(iset.eq.0) then -1 v1=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0 - v2=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0 - rsq=v1**2+v2**2 - if(rsq.ge.1.d0.or.rsq.eq.0.0d0) goto 1 - fac=sqrt(-2.0d0*log(rsq)/rsq) - gset=v1*fac - gaussdev=v2*fac - iset=1 - else - gaussdev=gset - iset=0 - endif - anorm_distr=x+gaussdev*sigma - return - end -c------------------------------------------------------------------------ - subroutine mult_norm(lda,n,a,x,fail) -C -C Generate the vector X whose elements obey the multiple-normal distribution -C from exp(-0.5*X'AX). LDA is the leading dimension of the moment matrix A, -C n is the dimension of the problem. FAIL is set at .TRUE., if the smallest -C eigenvalue of the matrix A is close to 0. -C - implicit double precision (a-h,o-z) - double precision a(lda,n),x(n),eig(100),vec(3,3),work(100) - double precision eig_limit /1.0D-8/ - logical fail - fail=.false. -c print '(a)','Enter MULT_NORM.' -C -C Find the smallest eigenvalue of the matrix A. -C -c do i=1,n -c print '(8f10.5)',(a(i,j),j=1,n) -c enddo -#ifdef NAG - call f02faf('V','U',2,a,lda,eig,work,100,ifail) -#else - call djacob(2,lda,10000,1.0d-10,a,vec,eig) -#endif -c print '(8f10.5)',(eig(i),i=1,n) -C print '(a)' -c do i=1,n -c print '(8f10.5)',(a(i,j),j=1,n) -c enddo - if (eig(1).lt.eig_limit) then - print *,'From Mult_Norm: Eigenvalues of A are too small.' - fail=.true. - return - endif -C -C Generate points following the normal distributions along the principal -C axes of the moment matrix. Store in WORK. -C - do i=1,n - sigma=1.0D0/dsqrt(eig(i)) - alim=-3.0D0*sigma - work(i)=anorm_distr(0.0D0,sigma,-alim,alim) - enddo -C -C Transform the vector of normal variables back to the original basis. -C - do i=1,n - xi=0.0D0 - do j=1,n - xi=xi+a(i,j)*work(j) - enddo - x(i)=xi - enddo - return - end -c------------------------------------------------------------------------ - subroutine mult_norm1(lda,n,a,z,box,x,fail) -C -C Generate the vector X whose elements obey the multi-gaussian multi-dimensional -C distribution from sum_{i=1}^m W(i)exp[-0.5*X'(i)A(i)X(i)]. LDA is the -C leading dimension of the moment matrix A, n is the dimension of the -C distribution, nlob is the number of lobes. FAIL is set at .TRUE., if the -C smallest eigenvalue of the matrix A is close to 0. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - double precision a(lda,n),z(n),x(n),box(n,n) - double precision etmp - include 'COMMON.IOUNITS' -#ifdef MP - include 'COMMON.SETUP' -#endif - logical fail -C -C Generate points following the normal distributions along the principal -C axes of the moment matrix. Store in WORK. -C -cd print *,'CG Processor',me,' entered MultNorm1.' -cd print '(2(1pe14.4),3x,1pe14.4)',((a(i,j),j=1,2),z(i),i=1,2) -cd do i=1,n -cd print *,i,box(1,i),box(2,i) -cd enddo - istep = 0 - 10 istep = istep + 1 - if (istep.gt.10000) then -c write (iout,'(a,i4,2a)') 'CG Processor: ',me,': too many steps', -c & ' in MultNorm1.' -c write (*,'(a,i4,2a)') 'CG Processor: ',me,': too many steps', -c & ' in MultNorm1.' -c write (iout,*) 'box',box -c write (iout,*) 'a',a -c write (iout,*) 'z',z - fail=.true. - return - endif - do i=1,n - x(i)=ran_number(box(1,i),box(2,i)) - enddo - ww=0.0D0 - do i=1,n - xi=pinorm(x(i)-z(i)) - ww=ww+0.5D0*a(i,i)*xi*xi - do j=i+1,n - ww=ww+a(i,j)*xi*pinorm(x(j)-z(j)) - enddo - enddo - dec=ran_number(0.0D0,1.0D0) -c print *,(x(i),i=1,n),ww,dexp(-ww),dec -crc if (dec.gt.dexp(-ww)) goto 10 - if(-ww.lt.100) then - etmp=dexp(-ww) - else - return - endif - if (dec.gt.etmp) goto 10 -cd print *,'CG Processor',me,' exitting MultNorm1.' - return - end -c -crc-------------------------------------- - subroutine overlap_sc(scfail) -c Internal and cartesian coordinates must be consistent as input, -c and will be up-to-date on return. -c At the end of this procedure, scfail is true if there are -c overlapping residues left, or false otherwise (success) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.VAR' - include 'COMMON.SBRIDGE' - include 'COMMON.IOUNITS' - logical had_overlaps,fail,scfail - integer ioverlap(maxres),ioverlap_last - - had_overlaps=.false. - call overlap_sc_list(ioverlap,ioverlap_last) - if (ioverlap_last.gt.0) then - write (iout,*) '#OVERLAPing residues ',ioverlap_last - write (iout,'(20i4)') (ioverlap(k),k=1,ioverlap_last) - had_overlaps=.true. - endif - - maxsi=1000 - do k=1,1000 - if (ioverlap_last.eq.0) exit - - do ires=1,ioverlap_last - i=ioverlap(ires) - iti=iabs(itype(i)) - if (iti.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(iti,theta(i+1),alph(i),omeg(i),fail) - nsi=nsi+1 - enddo - if(fail) goto 999 - endif - enddo - - call chainbuild - call overlap_sc_list(ioverlap,ioverlap_last) -c write (iout,*) 'Overlaping residues ',ioverlap_last, -c & (ioverlap(j),j=1,ioverlap_last) - enddo - - if (k.le.1000.and.ioverlap_last.eq.0) then - scfail=.false. - if (had_overlaps) then - write (iout,*) '#OVERLAPing all corrected after ',k, - & ' random generation' - endif - else - scfail=.true. - write (iout,*) '#OVERLAPing NOT all corrected ',ioverlap_last - write (iout,'(20i4)') (ioverlap(j),j=1,ioverlap_last) - endif - - return - - 999 continue - write (iout,'(a30,i5,a12,i4)') - & '#OVERLAP FAIL in gen_side after',maxsi, - & 'iter for RES',i - scfail=.true. - return - end - - subroutine overlap_sc_list(ioverlap,ioverlap_last) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.VAR' - include 'COMMON.CALC' - logical fail - integer ioverlap(maxres),ioverlap_last - data redfac /0.5D0/ - - ioverlap_last=0 -C Check for SC-SC overlaps and mark residues -c print *,'>>overlap_sc nnt=',nnt,' nct=',nct - ind=0 - do i=iatsc_s,iatsc_e - itypi=iabs(itype(i)) - itypi1=iabs(itype(i+1)) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) - dsci_inv=dsc_inv(itypi) -c - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=iabs(itype(j)) - dscj_inv=dsc_inv(itypj) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - if (j.gt.i+1) then - rcomp=sigmaii(itypi,itypj) - else - rcomp=sigma(itypi,itypj) - endif -c print '(2(a3,2i3),a3,2f10.5)', -c & ' i=',i,iti,' j=',j,itj,' d=',dist(nres+i,nres+j) -c & ,rcomp - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij - -ct if ( 1.0/rij .lt. redfac*rcomp .or. -ct & rij_shift.le.0.0D0 ) then - if ( rij_shift.le.0.0D0 ) then -cd write (iout,'(a,i3,a,i3,a,f10.5,a,3f10.5)') -cd & 'overlap SC-SC: i=',i,' j=',j, -cd & ' dist=',dist(nres+i,nres+j),' rcomp=', -cd & rcomp,1.0/rij,rij_shift - ioverlap_last=ioverlap_last+1 - ioverlap(ioverlap_last)=i - do k=1,ioverlap_last-1 - if (ioverlap(k).eq.i) ioverlap_last=ioverlap_last-1 - enddo - ioverlap_last=ioverlap_last+1 - ioverlap(ioverlap_last)=j - do k=1,ioverlap_last-1 - if (ioverlap(k).eq.j) ioverlap_last=ioverlap_last-1 - enddo - endif - enddo - enddo - enddo - return - end diff --git a/source/unres/src_MD-M-newcorr/geomout.F b/source/unres/src_MD-M-newcorr/geomout.F deleted file mode 100644 index e869b4a..0000000 --- a/source/unres/src_MD-M-newcorr/geomout.F +++ /dev/null @@ -1,512 +0,0 @@ - subroutine pdbout(etot,tytul,iunit) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' - include 'COMMON.MD' - character*50 tytul - character*1 chainid(10) /'A','B','C','D','E','F','G','H','I','J'/ - dimension ica(maxres) - write (iunit,'(3a,1pe15.5)') 'REMARK ',tytul,' ENERGY ',etot -cmodel write (iunit,'(a5,i6)') 'MODEL',1 - if (nhfrag.gt.0) then - do j=1,nhfrag - iti=itype(hfrag(1,j)) - itj=itype(hfrag(2,j)) - if (j.lt.10) then - write (iunit,'(a5,i5,1x,a1,i1,2x,a3,i7,2x,a3,i7,i3,t76,i5)') - & 'HELIX',j,'H',j, - & restyp(iti),hfrag(1,j)-1, - & restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j) - else - write (iunit,'(a5,i5,1x,a1,i2,1x,a3,i7,2x,a3,i7,i3)') - & 'HELIX',j,'H',j, - & restyp(iti),hfrag(1,j)-1, - & restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j) - endif - enddo - endif - - if (nbfrag.gt.0) then - - do j=1,nbfrag - - iti=itype(bfrag(1,j)) - itj=itype(bfrag(2,j)-1) - - write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3)') - & 'SHEET',1,'B',j,2, - & restyp(iti),bfrag(1,j)-1, - & restyp(itj),bfrag(2,j)-2,0 - - if (bfrag(3,j).gt.bfrag(4,j)) then - - itk=itype(bfrag(3,j)) - itl=itype(bfrag(4,j)+1) - - write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3, - & 2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') - & 'SHEET',2,'B',j,2, - & restyp(itl),bfrag(4,j), - & restyp(itk),bfrag(3,j)-1,-1, - & "N",restyp(itk),bfrag(3,j)-1, - & "O",restyp(iti),bfrag(1,j)-1 - - else - - itk=itype(bfrag(3,j)) - itl=itype(bfrag(4,j)-1) - - - write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3, - & 2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') - & 'SHEET',2,'B',j,2, - & restyp(itk),bfrag(3,j)-1, - & restyp(itl),bfrag(4,j)-2,1, - & "N",restyp(itk),bfrag(3,j)-1, - & "O",restyp(iti),bfrag(1,j)-1 - - - - endif - - enddo - endif - - if (nss.gt.0) then - do i=1,nss - if (dyn_ss) then - write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') - & 'SSBOND',i,'CYS',idssb(i)-nnt+1, - & 'CYS',jdssb(i)-nnt+1 - else - write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') - & 'SSBOND',i,'CYS',ihpb(i)-nnt+1-nres, - & 'CYS',jhpb(i)-nnt+1-nres - endif - enddo - endif - - iatom=0 - ichain=1 - ires=0 - do i=nnt,nct - iti=itype(i) - if (iti.eq.ntyp1) then - ichain=ichain+1 - ires=0 - write (iunit,'(a)') 'TER' - else - ires=ires+1 - iatom=iatom+1 - ica(i)=iatom - write (iunit,10) iatom,restyp(iti),chainid(ichain), - & ires,(c(j,i),j=1,3),vtot(i) - if (iti.ne.10) then - iatom=iatom+1 - write (iunit,20) iatom,restyp(iti),chainid(ichain), - & ires,(c(j,nres+i),j=1,3), - & vtot(i+nres) - endif - endif - enddo - write (iunit,'(a)') 'TER' - do i=nnt,nct-1 - if (itype(i).eq.ntyp1) cycle - if (itype(i).eq.10 .and. itype(i+1).ne.ntyp1) then - write (iunit,30) ica(i),ica(i+1) - else if (itype(i).ne.10 .and. itype(i+1).ne.ntyp1) then - write (iunit,30) ica(i),ica(i+1),ica(i)+1 - else if (itype(i).ne.10 .and. itype(i+1).eq.ntyp1) then - write (iunit,30) ica(i),ica(i)+1 - endif - enddo - if (itype(nct).ne.10) then - write (iunit,30) ica(nct),ica(nct)+1 - endif - do i=1,nss -C write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 -c trzeba uporzdkowac -C write (iunit,30) ica(ihpb(i))+1,ica(jhpb(i))+1 - if (dyn_ss) then - write (iunit,30) ica(idssb(i))+1,ica(jdssb(i))+1 - else - write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 - endif - enddo - write (iunit,'(a6)') 'ENDMDL' - 10 FORMAT ('ATOM',I7,' CA ',A3,1X,A1,I4,4X,3F8.3,f15.3) - 20 FORMAT ('ATOM',I7,' CB ',A3,1X,A1,I4,4X,3F8.3,f15.3) - 30 FORMAT ('CONECT',8I5) - return - end -c------------------------------------------------------------------------------ - subroutine MOL2out(etot,tytul) -C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2 -C format. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - character*32 tytul,fd - character*3 zahl - character*6 res_num,pom,ucase -#ifdef AIX - call fdate_(fd) -#elif (defined CRAY) - call date(fd) -#else - call fdate(fd) -#endif - write (imol2,'(a)') '#' - write (imol2,'(a)') - & '# Creating user name: unres' - write (imol2,'(2a)') '# Creation time: ', - & fd - write (imol2,'(/a)') '\@MOLECULE' - write (imol2,'(a)') tytul - write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0 - write (imol2,'(a)') 'SMALL' - write (imol2,'(a)') 'USER_CHARGES' - write (imol2,'(a)') '\@ATOM' - do i=nnt,nct - write (zahl,'(i3)') i - pom=ucase(restyp(itype(i))) - res_num = pom(:3)//zahl(2:) - write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0 - enddo - write (imol2,'(a)') '\@BOND' - do i=nnt,nct-1 - write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1 - enddo - do i=1,nss - write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 - enddo - write (imol2,'(a)') '\@SUBSTRUCTURE' - do i=nnt,nct - write (zahl,'(i3)') i - pom = ucase(restyp(itype(i))) - res_num = pom(:3)//zahl(2:) - write (imol2,30) i-nnt+1,res_num,i-nnt+1,0 - enddo - 10 FORMAT (I7,' CA ',3F10.4,' C.3',I8,1X,A,F11.4,' ****') - 30 FORMAT (I7,1x,A,I14,' RESIDUE',I13,' **** ****') - return - end -c------------------------------------------------------------------------ - subroutine intout - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.TORSION' - write (iout,'(/a)') 'Geometry of the virtual chain.' - write (iout,'(7a)') ' Res ',' d',' Theta', - & ' Phi',' Dsc',' Alpha',' Omega' - do i=1,nres - iti=itype(i) - write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i), - & rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i), - & rad2deg*omeg(i) - enddo - return - end -c--------------------------------------------------------------------------- - subroutine briefout(it,ener) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.SBRIDGE' -c print '(a,i5)',intname,igeom -#if defined(AIX) || defined(PGI) - open (igeom,file=intname,position='append') -#else - open (igeom,file=intname,access='append') -#endif - IF (NSS.LE.9) THEN - WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS) - ELSE - WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9) - WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS) - ENDIF -c IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) - WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) - WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES) -c if (nvar.gt.nphi+ntheta) then - write (igeom,200) (rad2deg*alph(i),i=2,nres-1) - write (igeom,200) (rad2deg*omeg(i),i=2,nres-1) -c endif - close(igeom) - 180 format (I5,F12.3,I2,9(1X,2I3)) - 190 format (3X,11(1X,2I3)) - 200 format (8F10.4) - return - end -#ifdef WINIFL - subroutine fdate(fd) - character*32 fd - write(fd,'(32x)') - return - end -#endif -c---------------------------------------------------------------- -#ifdef NOXDR - subroutine cartout(time) -#else - subroutine cartoutx(time) -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' - include 'COMMON.MD' - double precision time -#if defined(AIX) || defined(PGI) - open(icart,file=cartname,position="append") -#else - open(icart,file=cartname,access="append") -#endif - write (icart,'(e15.8,2e15.5,f12.5,$)') time,potE,uconst,t_bath -C write (icart,'(i4,$)') - if (dyn_ss) then - write (icart,'(i4,$)') - & nss,(idssb(j)+nres,jdssb(j)+nres,j=1,nss) - else - write (icart,'(i4,$)') - & nss,(ihpb(j),jhpb(j),j=1,nss) - endif - write (icart,'(i4,20f7.4)') nfrag+npair+3*nfrag_back, - & (qfrag(i),i=1,nfrag),(qpair(i),i=1,npair), - & (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back) - write (icart,'(8f10.5)') - & ((c(k,j),k=1,3),j=1,nres), - & ((c(k,j+nres),k=1,3),j=nnt,nct) - close(icart) - return - end -c----------------------------------------------------------------- -#ifndef NOXDR - subroutine cartout(time) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - include 'COMMON.SETUP' -#else - parameter (me=0) -#endif - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' - include 'COMMON.MD' - double precision time - integer iret,itmp - real xcoord(3,maxres2+2),prec - -#ifdef AIX - call xdrfopen_(ixdrf,cartname, "a", iret) - call xdrffloat_(ixdrf, real(time), iret) - call xdrffloat_(ixdrf, real(potE), iret) - call xdrffloat_(ixdrf, real(uconst), iret) - call xdrffloat_(ixdrf, real(uconst_back), iret) - call xdrffloat_(ixdrf, real(t_bath), iret) - call xdrfint_(ixdrf, nss, iret) - do j=1,nss - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) - enddo - call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret) - do i=1,nfrag - call xdrffloat_(ixdrf, real(qfrag(i)), iret) - enddo - do i=1,npair - call xdrffloat_(ixdrf, real(qpair(i)), iret) - enddo - do i=1,nfrag_back - call xdrffloat_(ixdrf, real(utheta(i)), iret) - call xdrffloat_(ixdrf, real(ugamma(i)), iret) - call xdrffloat_(ixdrf, real(uscdiff(i)), iret) - enddo -#else - call xdrfopen(ixdrf,cartname, "a", iret) - call xdrffloat(ixdrf, real(time), iret) - call xdrffloat(ixdrf, real(potE), iret) - call xdrffloat(ixdrf, real(uconst), iret) - call xdrffloat(ixdrf, real(uconst_back), iret) - call xdrffloat(ixdrf, real(t_bath), iret) - call xdrfint(ixdrf, nss, iret) - do j=1,nss - if (dyn_ss) then - call xdrfint(ixdrf, idssb(j)+nres, iret) - call xdrfint(ixdrf, jdssb(j)+nres, iret) - else - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - endif - enddo - call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret) - do i=1,nfrag - call xdrffloat(ixdrf, real(qfrag(i)), iret) - enddo - do i=1,npair - call xdrffloat(ixdrf, real(qpair(i)), iret) - enddo - do i=1,nfrag_back - call xdrffloat(ixdrf, real(utheta(i)), iret) - call xdrffloat(ixdrf, real(ugamma(i)), iret) - call xdrffloat(ixdrf, real(uscdiff(i)), iret) - enddo -#endif - prec=10000.0 - do i=1,nres - do j=1,3 - xcoord(j,i)=c(j,i) - enddo - enddo - do i=nnt,nct - do j=1,3 - xcoord(j,nres+i-nnt+1)=c(j,i+nres) - enddo - enddo - - itmp=nres+nct-nnt+1 -#ifdef AIX - call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret) - call xdrfclose_(ixdrf, iret) -#else - call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) - call xdrfclose(ixdrf, iret) -#endif - return - end -#endif -c----------------------------------------------------------------- - subroutine statout(itime) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' - include 'COMMON.MD' - include 'COMMON.SETUP' - integer itime - double precision energia(0:n_ene) - double precision gyrate - external gyrate - common /gucio/ cm - character*256 line1,line2 - character*4 format1,format2 - character*30 format -#ifdef AIX - if(itime.eq.0) then - open(istat,file=statname,position="append") - endif -#else -#ifdef PGI - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif -#endif - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.false.) - write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)') - & itime,totT,EK,potE,totE, - & rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me - format1="a133" - else - write (line1,'(i10,f15.2,7f12.3,i5,$)') - & itime,totT,EK,potE,totE, - & amax,kinetic_T,t_bath,gyrate(),me - format1="a114" - endif - if(usampl.and.totT.gt.eq_time) then - write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back, - & (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair), - & (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back) - write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair - & +21*nfrag_back - else - format2="a001" - line2=' ' - endif - if (print_compon) then - write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2, - & ",20f12.3)" - write (istat,format) line1,line2, - & (potEcomp(print_order(i)),i=1,nprint_ene) - else - write(format,'(a1,a4,a1,a4,a1)') "(",format1,",",format2,")" - write (istat,format) line1,line2 - endif -#if defined(AIX) - call flush(istat) -#else - close(istat) -#endif - return - end -c--------------------------------------------------------------- - double precision function gyrate() - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.INTERACT' - include 'COMMON.CHAIN' - double precision cen(3),rg - - do j=1,3 - cen(j)=0.0d0 - enddo - - do i=nnt,nct - do j=1,3 - cen(j)=cen(j)+c(j,i) - enddo - enddo - do j=1,3 - cen(j)=cen(j)/dble(nct-nnt+1) - enddo - rg = 0.0d0 - do i = nnt, nct - do j=1,3 - rg = rg + (c(j,i)-cen(j))**2 - enddo - end do - gyrate = sqrt(rg/dble(nct-nnt+1)) - return - end - diff --git a/source/unres/src_MD-M-newcorr/gnmr1.f b/source/unres/src_MD-M-newcorr/gnmr1.f deleted file mode 100644 index 905e746..0000000 --- a/source/unres/src_MD-M-newcorr/gnmr1.f +++ /dev/null @@ -1,43 +0,0 @@ - double precision function gnmr1(y,ymin,ymax) - implicit none - double precision y,ymin,ymax - double precision wykl /4.0d0/ - if (y.lt.ymin) then - gnmr1=(ymin-y)**wykl/wykl - else if (y.gt.ymax) then - gnmr1=(y-ymax)**wykl/wykl - else - gnmr1=0.0d0 - endif - return - end -c------------------------------------------------------------------------------ - double precision function gnmr1prim(y,ymin,ymax) - implicit none - double precision y,ymin,ymax - double precision wykl /4.0d0/ - if (y.lt.ymin) then - gnmr1prim=-(ymin-y)**(wykl-1) - else if (y.gt.ymax) then - gnmr1prim=(y-ymax)**(wykl-1) - else - gnmr1prim=0.0d0 - endif - return - end -c------------------------------------------------------------------------------ - double precision function harmonic(y,ymax) - implicit none - double precision y,ymax - double precision wykl /2.0d0/ - harmonic=(y-ymax)**wykl - return - end -c------------------------------------------------------------------------------- - double precision function harmonicprim(y,ymax) - double precision y,ymin,ymax - double precision wykl /2.0d0/ - harmonicprim=(y-ymax)*wykl - return - end -c--------------------------------------------------------------------------------- diff --git a/source/unres/src_MD-M-newcorr/gradient_p.F b/source/unres/src_MD-M-newcorr/gradient_p.F deleted file mode 100644 index 2c670f2..0000000 --- a/source/unres/src_MD-M-newcorr/gradient_p.F +++ /dev/null @@ -1,418 +0,0 @@ - subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - external ufparm - integer uiparm(1) - double precision urparm(1) - dimension x(maxvar),g(maxvar) -c -c This subroutine calculates total internal coordinate gradient. -c Depending on the number of function evaluations, either whole energy -c is evaluated beforehand, Cartesian coordinates and their derivatives in -c internal coordinates are reevaluated or only the cartesian-in-internal -c coordinate derivatives are evaluated. The subroutine was designed to work -c with SUMSL. -c -c - icg=mod(nf,2)+1 - -cd print *,'grad',nf,icg - if (nf-nfl+1) 20,30,40 - 20 call func(n,x,nf,f,uiparm,urparm,ufparm) -c write (iout,*) 'grad 20' - if (nf.eq.0) return - goto 40 - 30 call var_to_geom(n,x) - call chainbuild -c write (iout,*) 'grad 30' -C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartder -c write (iout,*) 'grad 40' -c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon -C -C Convert the Cartesian gradient into internal-coordinate gradient. -C - ind=0 - ind1=0 - do i=1,nres-2 - gthetai=0.0D0 - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 -c ind=indmat(i,j) -c print *,'GRAD: i=',i,' jc=',j,' ind=',ind - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - enddo - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - enddo - enddo - do j=i+1,nres-1 - ind1=ind1+1 -c ind1=indmat(i,j) -c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 - do k=1,3 - gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) - gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) - enddo - enddo - if (i.gt.1) g(i-1)=gphii - if (n.gt.nphi) g(nphi+i)=gthetai - enddo - if (n.le.nphi+ntheta) goto 10 - do i=2,nres-1 - if (itype(i).ne.10) then - galphai=0.0D0 - gomegai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ialph(i,1))=galphai - g(ialph(i,1)+nside)=gomegai - endif - enddo -C -C Add the components corresponding to local energy terms. -C - 10 continue - do i=1,nvar -cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) - g(i)=g(i)+gloc(i,icg) - enddo -C Uncomment following three lines for diagnostics. -cd call intout -cd call briefout(0,0.0d0) -cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) - return - end -C------------------------------------------------------------------------- - subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - external ufparm - integer uiparm(1) - double precision urparm(1) - dimension x(maxvar),g(maxvar) - - icg=mod(nf,2)+1 - if (nf-nfl+1) 20,30,40 - 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm) -c write (iout,*) 'grad 20' - if (nf.eq.0) return - goto 40 - 30 continue -#ifdef OSF -c Intercept NaNs in the coordinates -c write(iout,*) (var(i),i=1,nvar) - x_sum=0.D0 - do i=1,n - x_sum=x_sum+x(i) - enddo - if (x_sum.ne.x_sum) then - write(iout,*)" *** grad_restr : Found NaN in coordinates" - call flush(iout) - print *," *** grad_restr : Found NaN in coordinates" - return - endif -#endif - call var_to_geom_restr(n,x) - call chainbuild -C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartder -C -C Convert the Cartesian gradient into internal-coordinate gradient. -C - - ig=0 - ind=nres-2 - do i=2,nres-2 - IF (mask_phi(i+2).eq.1) THEN - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) - enddo - enddo - ig=ig+1 - g(ig)=gphii - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - - ind=0 - do i=1,nres-2 - IF (mask_theta(i+2).eq.1) THEN - ig=ig+1 - gthetai=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) - enddo - enddo - g(ig)=gthetai - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - galphai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - g(ig)=galphai - ENDIF - endif - enddo - - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - gomegai=0.0D0 - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ig)=gomegai - ENDIF - endif - enddo - -C -C Add the components corresponding to local energy terms. -C - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - endif - enddo - enddo - -cd do i=1,ig -cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) -cd enddo - return - end -C------------------------------------------------------------------------- - subroutine cartgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' -c -c This subrouting calculates total Cartesian coordinate gradient. -c The subroutine chainbuild_cart and energy MUST be called beforehand. -c -#ifdef TIMING - time00=MPI_Wtime() -#endif - icg=1 - call sum_gradient -#ifdef TIMING -#endif -#ifdef DEBUG - write (iout,*) "After sum_gradient" - do i=1,nres-1 - write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) - write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) - enddo -#endif -c If performing constraint dynamics, add the gradients of the constraint energy - if(usampl.and.totT.gt.eq_time) then - do i=1,nct - do j=1,3 - gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i) - gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i) - enddo - enddo - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+dugamma(i) - enddo - do i=1,nres-2 - gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i) - enddo - endif -#ifdef TIMING - time01=MPI_Wtime() -#endif - call intcartderiv -#ifdef TIMING - time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 -#endif -cd call checkintcartgrad -cd write(iout,*) 'calling int_to_cart' -#ifdef DEBUG - write (iout,*) "gcart, gxcart, gloc before int_to_cart" -#endif - do i=1,nct - do j=1,3 - gcart(j,i)=gradc(j,i,icg) - gxcart(j,i)=gradx(j,i,icg) - enddo -#ifdef DEBUG - write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3), - & (gxcart(j,i),j=1,3),gloc(i,icg) -#endif - enddo -#ifdef TIMING - time01=MPI_Wtime() -#endif - call int_to_cart -#ifdef TIMING - time_inttocart=time_inttocart+MPI_Wtime()-time01 -#endif -#ifdef DEBUG - write (iout,*) "gcart and gxcart after int_to_cart" - do i=0,nres-1 - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), - & (gxcart(j,i),j=1,3) - enddo -#endif -#ifdef TIMING - time_cartgrad=time_cartgrad+MPI_Wtime()-time00 -#endif - return - end -C------------------------------------------------------------------------- - subroutine zerograd - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.SCCOR' -C -C Initialize Cartesian-coordinate gradient -C - do i=1,nres - do j=1,3 - gvdwx(j,i)=0.0D0 - gradx_scp(j,i)=0.0D0 - gvdwc(j,i)=0.0D0 - gvdwc_scp(j,i)=0.0D0 - gvdwc_scpp(j,i)=0.0d0 - gelc (j,i)=0.0D0 - gelc_long(j,i)=0.0D0 - gradb(j,i)=0.0d0 - gradbx(j,i)=0.0d0 - gvdwpp(j,i)=0.0d0 - gel_loc(j,i)=0.0d0 - gel_loc_long(j,i)=0.0d0 - ghpbc(j,i)=0.0D0 - ghpbx(j,i)=0.0D0 - gcorr3_turn(j,i)=0.0d0 - gcorr4_turn(j,i)=0.0d0 - gradcorr(j,i)=0.0d0 - gradcorr_long(j,i)=0.0d0 - gradcorr5_long(j,i)=0.0d0 - gradcorr6_long(j,i)=0.0d0 - gcorr6_turn_long(j,i)=0.0d0 - gradcorr5(j,i)=0.0d0 - gradcorr6(j,i)=0.0d0 - gcorr6_turn(j,i)=0.0d0 - gsccorc(j,i)=0.0d0 - gsccorx(j,i)=0.0d0 - gradc(j,i,icg)=0.0d0 - gradx(j,i,icg)=0.0d0 - gscloc(j,i)=0.0d0 - gsclocx(j,i)=0.0d0 - do intertyp=1,3 - gloc_sc(intertyp,i,icg)=0.0d0 - enddo - enddo - enddo -C -C Initialize the gradient of local energy terms. -C - do i=1,4*nres - gloc(i,icg)=0.0D0 - enddo - do i=1,nres - gel_loc_loc(i)=0.0d0 - gcorr_loc(i)=0.0d0 - g_corr5_loc(i)=0.0d0 - g_corr6_loc(i)=0.0d0 - gel_loc_turn3(i)=0.0d0 - gel_loc_turn4(i)=0.0d0 - gel_loc_turn6(i)=0.0d0 - gsccor_loc(i)=0.0d0 - enddo -c initialize gcart and gxcart - do i=0,nres - do j=1,3 - gcart(j,i)=0.0d0 - gxcart(j,i)=0.0d0 - enddo - enddo - return - end -c------------------------------------------------------------------------- - double precision function fdum() - fdum=0.0D0 - return - end diff --git a/source/unres/src_MD-M-newcorr/indexx.f b/source/unres/src_MD-M-newcorr/indexx.f deleted file mode 100644 index b903862..0000000 --- a/source/unres/src_MD-M-newcorr/indexx.f +++ /dev/null @@ -1,81 +0,0 @@ - SUBROUTINE indexx(n,arr,indx) - implicit real*8 (a-h,o-z) - INTEGER n,indx(n),M,NSTACK - REAL*8 arr(n) -c PARAMETER (M=7,NSTACK=50) - PARAMETER (M=7,NSTACK=500) - INTEGER i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) - REAL*8 a - do 11 j=1,n - indx(j)=j -11 continue - jstack=0 - l=1 - ir=n -1 if(ir-l.lt.M)then - do 13 j=l+1,ir - indxt=indx(j) - a=arr(indxt) - do 12 i=j-1,1,-1 - if(arr(indx(i)).le.a)goto 2 - indx(i+1)=indx(i) -12 continue - i=0 -2 indx(i+1)=indxt -13 continue - if(jstack.eq.0)return - ir=istack(jstack) - l=istack(jstack-1) - jstack=jstack-2 - else - k=(l+ir)/2 - itemp=indx(k) - indx(k)=indx(l+1) - indx(l+1)=itemp - if(arr(indx(l+1)).gt.arr(indx(ir)))then - itemp=indx(l+1) - indx(l+1)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l)).gt.arr(indx(ir)))then - itemp=indx(l) - indx(l)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l+1)).gt.arr(indx(l)))then - itemp=indx(l+1) - indx(l+1)=indx(l) - indx(l)=itemp - endif - i=l+1 - j=ir - indxt=indx(l) - a=arr(indxt) -3 continue - i=i+1 - if(arr(indx(i)).lt.a)goto 3 -4 continue - j=j-1 - if(arr(indx(j)).gt.a)goto 4 - if(j.lt.i)goto 5 - itemp=indx(i) - indx(i)=indx(j) - indx(j)=itemp - goto 3 -5 indx(l)=indx(j) - indx(j)=indxt - jstack=jstack+2 - if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' - if(ir-i+1.ge.j-l)then - istack(jstack)=ir - istack(jstack-1)=i - ir=j-1 - else - istack(jstack)=j-1 - istack(jstack-1)=l - l=i - endif - endif - goto 1 - END -C (C) Copr. 1986-92 Numerical Recipes Software *11915aZ%. diff --git a/source/unres/src_MD-M-newcorr/initialize_p.F b/source/unres/src_MD-M-newcorr/initialize_p.F deleted file mode 100644 index d2474fc..0000000 --- a/source/unres/src_MD-M-newcorr/initialize_p.F +++ /dev/null @@ -1,1424 +0,0 @@ - block data - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.MD' - data MovTypID - & /'pool','chain regrow','multi-bond','phi','theta','side chain', - & 'total'/ -c Conversion from poises to molecular unit and the gas constant - data cPoise /2.9361d0/, Rb /0.001986d0/ - end -c-------------------------------------------------------------------------- - subroutine initialize -C -C Define constants and zero out tables. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.MCM' - include 'COMMON.MINIM' - include 'COMMON.DERIV' - include 'COMMON.SPLITELE' -c Common blocks from the diagonalization routines - COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) - COMMON /MACHSW/ KDIAG,ICORFL,IXDR - logical mask_r -c real*8 text1 /'initial_i'/ - - mask_r=.false. -#ifndef ISNAN -c NaNQ initialization - i=-1 - rr=dacos(100.0d0) -#ifdef WINPGI - idumm=proc_proc(rr,i) -#else - call proc_proc(rr,i) -#endif -#endif - - kdiag=0 - icorfl=0 - iw=2 -C -C The following is just to define auxiliary variables used in angle conversion -C - pi=4.0D0*datan(1.0D0) - dwapi=2.0D0*pi - dwapi3=dwapi/3.0D0 - pipol=0.5D0*pi - deg2rad=pi/180.0D0 - rad2deg=1.0D0/deg2rad - angmin=10.0D0*deg2rad -C -C Define I/O units. -C - inp= 1 - iout= 2 - ipdbin= 3 - ipdb= 7 - icart = 30 - imol2= 4 - igeom= 8 - intin= 9 - ithep= 11 - ithep_pdb=51 - irotam=12 - irotam_pdb=52 - itorp= 13 - itordp= 23 - ielep= 14 - isidep=15 - iscpp=25 - icbase=16 - ifourier=20 - istat= 17 - irest1=55 - irest2=56 - iifrag=57 - ientin=18 - ientout=19 - ibond = 28 - isccor = 29 -crc for write_rmsbank1 - izs1=21 -cdr include secondary structure prediction bias - isecpred=27 -C -C CSA I/O units (separated from others especially for Jooyoung) -C - icsa_rbank=30 - icsa_seed=31 - icsa_history=32 - icsa_bank=33 - icsa_bank1=34 - icsa_alpha=35 - icsa_alpha1=36 - icsa_bankt=37 - icsa_int=39 - icsa_bank_reminimized=38 - icsa_native_int=41 - icsa_in=40 -crc for ifc error 118 - icsa_pdb=42 -C -C Set default weights of the energy terms. -C - wlong=1.0D0 - welec=1.0D0 - wtor =1.0D0 - wang =1.0D0 - wscloc=1.0D0 - wstrain=1.0D0 -C -C Zero out tables. -C -c print '(a,$)','Inside initialize' -c call memmon_print_usage() - do i=1,maxres2 - do j=1,3 - c(j,i)=0.0D0 - dc(j,i)=0.0D0 - enddo - enddo - do i=1,maxres - do j=1,3 - xloc(j,i)=0.0D0 - enddo - enddo - do i=1,ntyp - do j=1,ntyp - aa(i,j)=0.0D0 - bb(i,j)=0.0D0 - augm(i,j)=0.0D0 - sigma(i,j)=0.0D0 - r0(i,j)=0.0D0 - chi(i,j)=0.0D0 - enddo - do j=1,2 - bad(i,j)=0.0D0 - enddo - chip(i)=0.0D0 - alp(i)=0.0D0 - sigma0(i)=0.0D0 - sigii(i)=0.0D0 - rr0(i)=0.0D0 - a0thet(i)=0.0D0 - do j=1,2 - 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 -cc write (iout,*) "TU DOCHODZE",i,itortyp(i) - do iblock=1,2 - do j=-maxtor,maxtor - do k=1,maxterm - v1(k,j,i,iblock)=0.0D0 - v2(k,j,i,iblock)=0.0D0 - enddo - enddo - enddo - enddo - do iblock=1,2 - do i=-maxtor,maxtor - do j=-maxtor,maxtor - do k=-maxtor,maxtor - do l=1,maxtermd_1 - v1c(1,l,i,j,k,iblock)=0.0D0 - v1s(1,l,i,j,k,iblock)=0.0D0 - v1c(2,l,i,j,k,iblock)=0.0D0 - v1s(2,l,i,j,k,iblock)=0.0D0 - enddo !l - do l=1,maxtermd_2 - do m=1,maxtermd_2 - v2c(m,l,i,j,k,iblock)=0.0D0 - v2s(m,l,i,j,k,iblock)=0.0D0 - enddo !m - enddo !l - enddo !k - enddo !j - enddo !i - enddo !iblock - - do i=1,maxres - itype(i)=0 - itel(i)=0 - enddo -C Initialize the bridge arrays - ns=0 - nss=0 - nhpb=0 - do i=1,maxss - iss(i)=0 - enddo - do i=1,maxdim - dhpb(i)=0.0D0 - enddo - do i=1,maxres - ihpb(i)=0 - jhpb(i)=0 - enddo -C -C Initialize timing. -C - call set_timers -C -C Initialize variables used in minimization. -C -c maxfun=5000 -c maxit=2000 - maxfun=500 - maxit=200 - tolf=1.0D-2 - rtolf=5.0D-4 -C -C Initialize the variables responsible for the mode of gradient storage. -C - nfl=0 - icg=1 -C -C Initialize constants used to split the energy into long- and short-range -C components -C - r_cut=2.0d0 - rlamb=0.3d0 -#ifndef SPLITELE - nprint_ene=nprint_ene-1 -#endif - return - end -c------------------------------------------------------------------------- - block data nazwy - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - data restyp / - &'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 / - & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ", - & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ", - & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ", - & "ESTR ","EVDW2_14 ","UCONST ", " ","ESCCOR"/ - data wname / - & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", - & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD", - & "WSTRAIN","WVDWPP","WBOND","SCAL14"," "," ","WSCCOR"/ - data nprint_ene /20/ - data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16, - & 21,0/ - end -c--------------------------------------------------------------------------- - subroutine init_int_table - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer blocklengths(15),displs(15) -#endif - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.SBRIDGE' - include 'COMMON.TORCNSTR' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.CONTACTS' - common /przechowalnia/ iturn3_start_all(0:max_fg_procs), - & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs), - & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs), - &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1), - & ielend_all(maxres,0:max_fg_procs-1), - & ntask_cont_from_all(0:max_fg_procs-1), - & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1), - & ntask_cont_to_all(0:max_fg_procs-1), - & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1) - integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP - logical scheck,lprint,flag -#ifdef MPI - integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs), - & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs) -C... Determine the numbers of start and end SC-SC interaction -C... to deal with by current processor. - do i=0,nfgtasks-1 - itask_cont_from(i)=fg_rank - itask_cont_to(i)=fg_rank - enddo - lprint=.false. - if (lprint) - &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct - n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss - call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde) - if (lprint) - & write (iout,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',MyRank, - & ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds, - & ' my_sc_inde',my_sc_inde - ind_sctint=0 - iatsc_s=0 - iatsc_e=0 -#endif -c lprint=.false. - do i=1,maxres - nint_gr(i)=0 - nscp_gr(i)=0 - do j=1,maxint_gr - istart(i,1)=0 - iend(i,1)=0 - ielstart(i)=0 - ielend(i)=0 - iscpstart(i,1)=0 - iscpend(i,1)=0 - enddo - enddo - ind_scint=0 - ind_scint_old=0 -cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', -cd & (ihpb(i),jhpb(i),i=1,nss) - do i=nnt,nct-1 - scheck=.false. - if (dyn_ss) goto 10 - do ii=1,nss - if (ihpb(ii).eq.i+nres) then - scheck=.true. - jj=jhpb(ii)-nres - goto 10 - endif - enddo - 10 continue -cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj - if (scheck) then - if (jj.eq.i+1) then -#ifdef MPI -c write (iout,*) 'jj=i+1' - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12) -#else - nint_gr(i)=1 - istart(i,1)=i+2 - iend(i,1)=nct -#endif - else if (jj.eq.nct) then -#ifdef MPI -c write (iout,*) 'jj=nct' - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12) -#else - nint_gr(i)=1 - istart(i,1)=i+1 - iend(i,1)=nct-1 -#endif - else -#ifdef MPI - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12) - ii=nint_gr(i)+1 - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12) -#else - nint_gr(i)=2 - istart(i,1)=i+1 - iend(i,1)=jj-1 - istart(i,2)=jj+1 - iend(i,2)=nct -#endif - endif - else -#ifdef MPI - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12) -#else - nint_gr(i)=1 - istart(i,1)=i+1 - iend(i,1)=nct - ind_scint=ind_scint+nct-i -#endif - endif -#ifdef MPI - ind_scint_old=ind_scint -#endif - enddo - 12 continue -#ifndef MPI - iatsc_s=nnt - iatsc_e=nct-1 -#endif -#ifdef MPI - if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor, - & ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e -#endif - if (lprint) then - write (iout,'(a)') 'Interaction array:' - do i=iatsc_s,iatsc_e - write (iout,'(i3,2(2x,2i3))') - & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i)) - enddo - endif - ispp=4 -#ifdef MPI -C Now partition the electrostatic-interaction array - npept=nct-nnt - nele_int_tot=(npept-ispp)*(npept-ispp+1)/2 - call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde) - if (lprint) - & write (*,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',MyRank, - & ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds, - & ' my_ele_inde',my_ele_inde - iatel_s=0 - iatel_e=0 - ind_eleint=0 - ind_eleint_old=0 - do i=nnt,nct-3 - ijunk=0 - call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i, - & iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13) - enddo ! i - 13 continue - if (iatel_s.eq.0) iatel_s=1 - nele_int_tot_vdw=(npept-2)*(npept-2+1)/2 -c write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw - call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw) -c write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw, -c & " my_ele_inde_vdw",my_ele_inde_vdw - ind_eleint_vdw=0 - ind_eleint_vdw_old=0 - iatel_s_vdw=0 - iatel_e_vdw=0 - do i=nnt,nct-3 - ijunk=0 - call int_partition(ind_eleint_vdw,my_ele_inds_vdw, - & my_ele_inde_vdw,i, - & iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i), - & ielend_vdw(i),*15) -c write (iout,*) i," ielstart_vdw",ielstart_vdw(i), -c & " ielend_vdw",ielend_vdw(i) - enddo ! i - if (iatel_s_vdw.eq.0) iatel_s_vdw=1 - 15 continue -#else - iatel_s=nnt - iatel_e=nct-5 - do i=iatel_s,iatel_e - ielstart(i)=i+4 - ielend(i)=nct-1 - enddo - iatel_s_vdw=nnt - iatel_e_vdw=nct-3 - do i=iatel_s_vdw,iatel_e_vdw - ielstart_vdw(i)=i+2 - ielend_vdw(i)=nct-1 - enddo -#endif - if (lprint) then - write (*,'(a)') 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',MyRank - write (iout,*) 'Electrostatic interaction array:' - do i=iatel_s,iatel_e - write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i) - enddo - endif ! lprint -c iscp=3 - iscp=2 -C Partition the SC-p interaction array -#ifdef MPI - nscp_int_tot=(npept-iscp+1)*(npept-iscp+1) - call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde) - if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',myrank, - & ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds, - & ' my_scp_inde',my_scp_inde - iatscp_s=0 - iatscp_e=0 - ind_scpint=0 - ind_scpint_old=0 - do i=nnt,nct-1 - if (i.lt.nnt+iscp) then -cd write (iout,*) 'i.le.nnt+iscp' - call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, - & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1), - & iscpend(i,1),*14) - else if (i.gt.nct-iscp) then -cd write (iout,*) 'i.gt.nct-iscp' - call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, - & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), - & iscpend(i,1),*14) - else - call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, - & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), - & iscpend(i,1),*14) - ii=nscp_gr(i)+1 - call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, - & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii), - & iscpend(i,ii),*14) - endif - enddo ! i - 14 continue -#else - iatscp_s=nnt - iatscp_e=nct-1 - do i=nnt,nct-1 - if (i.lt.nnt+iscp) then - nscp_gr(i)=1 - iscpstart(i,1)=i+iscp - iscpend(i,1)=nct - elseif (i.gt.nct-iscp) then - nscp_gr(i)=1 - iscpstart(i,1)=nnt - iscpend(i,1)=i-iscp - else - nscp_gr(i)=2 - iscpstart(i,1)=nnt - iscpend(i,1)=i-iscp - iscpstart(i,2)=i+iscp - iscpend(i,2)=nct - endif - enddo ! i -#endif - if (lprint) then - write (iout,'(a)') 'SC-p interaction array:' - do i=iatscp_s,iatscp_e - write (iout,'(i3,2(2x,2i3))') - & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) - enddo - endif ! lprint -C Partition local interactions -#ifdef MPI - call int_bounds(nres-2,loc_start,loc_end) - loc_start=loc_start+1 - loc_end=loc_end+1 - call int_bounds(nres-2,ithet_start,ithet_end) - ithet_start=ithet_start+2 - ithet_end=ithet_end+2 - call int_bounds(nct-nnt-2,iturn3_start,iturn3_end) - iturn3_start=iturn3_start+nnt - iphi_start=iturn3_start+2 - iturn3_end=iturn3_end+nnt - iphi_end=iturn3_end+2 - iturn3_start=iturn3_start-1 - iturn3_end=iturn3_end-1 - call int_bounds(nres-3,itau_start,itau_end) - itau_start=itau_start+3 - itau_end=itau_end+3 - call int_bounds(nres-3,iphi1_start,iphi1_end) - iphi1_start=iphi1_start+3 - iphi1_end=iphi1_end+3 - call int_bounds(nct-nnt-3,iturn4_start,iturn4_end) - iturn4_start=iturn4_start+nnt - iphid_start=iturn4_start+2 - iturn4_end=iturn4_end+nnt - iphid_end=iturn4_end+2 - iturn4_start=iturn4_start-1 - iturn4_end=iturn4_end-1 - call int_bounds(nres-2,ibond_start,ibond_end) - ibond_start=ibond_start+1 - ibond_end=ibond_end+1 - call int_bounds(nct-nnt,ibondp_start,ibondp_end) - ibondp_start=ibondp_start+nnt - ibondp_end=ibondp_end+nnt - call int_bounds1(nres-1,ivec_start,ivec_end) -c print *,"Processor",myrank,fg_rank,fg_rank1, -c & " ivec_start",ivec_start," ivec_end",ivec_end - iset_start=loc_start+2 - iset_end=loc_end+2 - if (ndih_constr.eq.0) then - idihconstr_start=1 - idihconstr_end=0 - else - call int_bounds(ndih_constr,idihconstr_start,idihconstr_end) - endif -c nsumgrad=(nres-nnt)*(nres-nnt+1)/2 -c nlen=nres-nnt+1 - nsumgrad=(nres-nnt)*(nres-nnt+1)/2 - nlen=nres-nnt+1 - call int_bounds(nsumgrad,ngrad_start,ngrad_end) - igrad_start=((2*nlen+1) - & -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2 - jgrad_start(igrad_start)= - & ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2 - & +igrad_start - jgrad_end(igrad_start)=nres - igrad_end=((2*nlen+1) - & -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2 - if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1 - jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2 - & +igrad_end - do i=igrad_start+1,igrad_end-1 - jgrad_start(i)=i+1 - jgrad_end(i)=nres - enddo - if (lprint) then - write (*,*) 'Processor:',fg_rank,' CG group',kolor, - & ' absolute rank',myrank, - & ' loc_start',loc_start,' loc_end',loc_end, - & ' ithet_start',ithet_start,' ithet_end',ithet_end, - & ' iphi_start',iphi_start,' iphi_end',iphi_end, - & ' iphid_start',iphid_start,' iphid_end',iphid_end, - & ' ibond_start',ibond_start,' ibond_end',ibond_end, - & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end, - & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end, - & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end, - & ' ivec_start',ivec_start,' ivec_end',ivec_end, - & ' iset_start',iset_start,' iset_end',iset_end, - & ' idihconstr_start',idihconstr_start,' idihconstr_end', - & idihconstr_end - write (*,*) 'Processor:',fg_rank,myrank,' igrad_start', - & igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start, - & ' ngrad_end',ngrad_end - do i=igrad_start,igrad_end - write(*,*) 'Processor:',fg_rank,myrank,i, - & jgrad_start(i),jgrad_end(i) - enddo - endif - if (nfgtasks.gt.1) then - call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1, - & MPI_INTEGER,FG_COMM1,IERROR) - iaux=ivec_end-ivec_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1, - & MPI_INTEGER,FG_COMM1,IERROR) - call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=iset_end-iset_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=ibond_end-ibond_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=ithet_end-ithet_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=iphi_end-iphi_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=iphi1_end-iphi1_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - do i=0,maxprocs-1 - do j=1,maxres - ielstart_all(j,i)=0 - ielend_all(j,i)=0 - enddo - enddo - call MPI_Allgather(iturn3_start,1,MPI_INTEGER, - & iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iturn4_start,1,MPI_INTEGER, - & iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iturn3_end,1,MPI_INTEGER, - & iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iturn4_end,1,MPI_INTEGER, - & iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iatel_s,1,MPI_INTEGER, - & iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iatel_e,1,MPI_INTEGER, - & iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER, - & ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ielend(1),maxres,MPI_INTEGER, - & ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR) - if (lprint) then - write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks) - write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks) - write (iout,*) "iturn3_start_all", - & (iturn3_start_all(i),i=0,nfgtasks-1) - write (iout,*) "iturn3_end_all", - & (iturn3_end_all(i),i=0,nfgtasks-1) - write (iout,*) "iturn4_start_all", - & (iturn4_start_all(i),i=0,nfgtasks-1) - write (iout,*) "iturn4_end_all", - & (iturn4_end_all(i),i=0,nfgtasks-1) - write (iout,*) "The ielstart_all array" - do i=nnt,nct - write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1) - enddo - write (iout,*) "The ielend_all array" - do i=nnt,nct - write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1) - enddo - call flush(iout) - endif - ntask_cont_from=0 - ntask_cont_to=0 - itask_cont_from(0)=fg_rank - itask_cont_to(0)=fg_rank - flag=.false. - do ii=iturn3_start,iturn3_end - call add_int(ii,ii+2,iturn3_sent(1,ii), - & ntask_cont_to,itask_cont_to,flag) - enddo - do ii=iturn4_start,iturn4_end - call add_int(ii,ii+3,iturn4_sent(1,ii), - & ntask_cont_to,itask_cont_to,flag) - enddo - do ii=iturn3_start,iturn3_end - call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from) - enddo - do ii=iturn4_start,iturn4_end - call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from) - enddo - if (lprint) then - write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from, - & " ntask_cont_to",ntask_cont_to - write (iout,*) "itask_cont_from", - & (itask_cont_from(i),i=1,ntask_cont_from) - write (iout,*) "itask_cont_to", - & (itask_cont_to(i),i=1,ntask_cont_to) - call flush(iout) - endif -c write (iout,*) "Loop forward" -c call flush(iout) - do i=iatel_s,iatel_e -c write (iout,*) "from loop i=",i -c call flush(iout) - do j=ielstart(i),ielend(i) - call add_int_from(i,j,ntask_cont_from,itask_cont_from) - enddo - enddo -c write (iout,*) "Loop backward iatel_e-1",iatel_e-1, -c & " iatel_e",iatel_e -c call flush(iout) - nat_sent=0 - do i=iatel_s,iatel_e -c write (iout,*) "i",i," ielstart",ielstart(i), -c & " ielend",ielend(i) -c call flush(iout) - flag=.false. - do j=ielstart(i),ielend(i) - call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to, - & itask_cont_to,flag) - enddo - if (flag) then - nat_sent=nat_sent+1 - iat_sent(nat_sent)=i - endif - enddo - if (lprint) then - write (iout,*)"After longrange ntask_cont_from",ntask_cont_from, - & " ntask_cont_to",ntask_cont_to - write (iout,*) "itask_cont_from", - & (itask_cont_from(i),i=1,ntask_cont_from) - write (iout,*) "itask_cont_to", - & (itask_cont_to(i),i=1,ntask_cont_to) - call flush(iout) - write (iout,*) "iint_sent" - do i=1,nat_sent - ii=iat_sent(i) - write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4), - & j=ielstart(ii),ielend(ii)) - enddo - write (iout,*) "iturn3_sent iturn3_start",iturn3_start, - & " iturn3_end",iturn3_end - write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4), - & i=iturn3_start,iturn3_end) - write (iout,*) "iturn4_sent iturn4_start",iturn4_start, - & " iturn4_end",iturn4_end - write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4), - & i=iturn4_start,iturn4_end) - call flush(iout) - endif - call MPI_Gather(ntask_cont_from,1,MPI_INTEGER, - & ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR) -c write (iout,*) "Gather ntask_cont_from ended" -c call flush(iout) - call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER, - & itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king, - & FG_COMM,IERR) -c write (iout,*) "Gather itask_cont_from ended" -c call flush(iout) - call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all, - & 1,MPI_INTEGER,king,FG_COMM,IERR) -c write (iout,*) "Gather ntask_cont_to ended" -c call flush(iout) - call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER, - & itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR) -c write (iout,*) "Gather itask_cont_to ended" -c call flush(iout) - if (fg_rank.eq.king) then - write (iout,*)"Contact receive task map (proc, #tasks, tasks)" - do i=0,nfgtasks-1 - write (iout,'(20i4)') i,ntask_cont_from_all(i), - & (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i)) - enddo - write (iout,*) - call flush(iout) - write (iout,*) "Contact send task map (proc, #tasks, tasks)" - do i=0,nfgtasks-1 - write (iout,'(20i4)') i,ntask_cont_to_all(i), - & (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i)) - enddo - write (iout,*) - call flush(iout) -C Check if every send will have a matching receive - ncheck_to=0 - ncheck_from=0 - do i=0,nfgtasks-1 - ncheck_to=ncheck_to+ntask_cont_to_all(i) - ncheck_from=ncheck_from+ntask_cont_from_all(i) - enddo - write (iout,*) "Control sums",ncheck_from,ncheck_to - if (ncheck_from.ne.ncheck_to) then - write (iout,*) "Error: #receive differs from #send." - write (iout,*) "Terminating program...!" - call flush(iout) - flag=.false. - else - flag=.true. - do i=0,nfgtasks-1 - do j=1,ntask_cont_to_all(i) - ii=itask_cont_to_all(j,i) - do k=1,ntask_cont_from_all(ii) - if (itask_cont_from_all(k,ii).eq.i) then - if(lprint)write(iout,*)"Matching send/receive",i,ii - exit - endif - enddo - if (k.eq.ntask_cont_from_all(ii)+1) then - flag=.false. - write (iout,*) "Error: send by",j," to",ii, - & " would have no matching receive" - endif - enddo - enddo - endif - if (.not.flag) then - write (iout,*) "Unmatched sends; terminating program" - call flush(iout) - endif - endif - call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR) -c write (iout,*) "flag broadcast ended flag=",flag -c call flush(iout) - if (.not.flag) then - call MPI_Finalize(IERROR) - stop "Error in INIT_INT_TABLE: unmatched send/receive." - endif - call MPI_Comm_group(FG_COMM,fg_group,IERR) -c write (iout,*) "MPI_Comm_group ended" -c call flush(iout) - call MPI_Group_incl(fg_group,ntask_cont_from+1, - & itask_cont_from(0),CONT_FROM_GROUP,IERR) - call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0), - & CONT_TO_GROUP,IERR) - do i=1,nat_sent - ii=iat_sent(i) - iaux=4*(ielend(ii)-ielstart(ii)+1) - call MPI_Group_translate_ranks(fg_group,iaux, - & iint_sent(1,ielstart(ii),i),CONT_TO_GROUP, - & iint_sent_local(1,ielstart(ii),i),IERR ) -c write (iout,*) "Ranks translated i=",i -c call flush(iout) - enddo - iaux=4*(iturn3_end-iturn3_start+1) - call MPI_Group_translate_ranks(fg_group,iaux, - & iturn3_sent(1,iturn3_start),CONT_TO_GROUP, - & iturn3_sent_local(1,iturn3_start),IERR) - iaux=4*(iturn4_end-iturn4_start+1) - call MPI_Group_translate_ranks(fg_group,iaux, - & iturn4_sent(1,iturn4_start),CONT_TO_GROUP, - & iturn4_sent_local(1,iturn4_start),IERR) - if (lprint) then - write (iout,*) "iint_sent_local" - do i=1,nat_sent - ii=iat_sent(i) - write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4), - & j=ielstart(ii),ielend(ii)) - call flush(iout) - enddo - write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start, - & " iturn3_end",iturn3_end - write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4), - & i=iturn3_start,iturn3_end) - write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start, - & " iturn4_end",iturn4_end - write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4), - & i=iturn4_start,iturn4_end) - call flush(iout) - endif - call MPI_Group_free(fg_group,ierr) - call MPI_Group_free(cont_from_group,ierr) - call MPI_Group_free(cont_to_group,ierr) - call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR) - call MPI_Type_commit(MPI_UYZ,IERROR) - call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD, - & IERROR) - call MPI_Type_commit(MPI_UYZGRAD,IERROR) - call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR) - call MPI_Type_commit(MPI_MU,IERROR) - call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR) - call MPI_Type_commit(MPI_MAT1,IERROR) - call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR) - call MPI_Type_commit(MPI_MAT2,IERROR) - call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR) - call MPI_Type_commit(MPI_THET,IERROR) - call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR) - call MPI_Type_commit(MPI_GAM,IERROR) -#ifndef MATGATHER -c 9/22/08 Derived types to send matrices which appear in correlation terms - do i=0,nfgtasks-1 - if (ivec_count(i).eq.ivec_count(0)) then - lentyp(i)=0 - else - lentyp(i)=1 - endif - enddo - do ind_typ=lentyp(0),lentyp(nfgtasks-1) - if (ind_typ.eq.0) then - ichunk=ivec_count(0) - else - ichunk=ivec_count(1) - endif -c do i=1,4 -c blocklengths(i)=4 -c enddo -c displs(1)=0 -c do i=2,4 -c displs(i)=displs(i-1)+blocklengths(i-1)*maxres -c enddo -c do i=1,4 -c blocklengths(i)=blocklengths(i)*ichunk -c enddo -c write (iout,*) "blocklengths and displs" -c do i=1,4 -c write (iout,*) i,blocklengths(i),displs(i) -c enddo -c call flush(iout) -c call MPI_Type_indexed(4,blocklengths(1),displs(1), -c & MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR) -c call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR) -c write (iout,*) "MPI_ROTAT1",MPI_ROTAT1 -c do i=1,4 -c blocklengths(i)=2 -c enddo -c displs(1)=0 -c do i=2,4 -c displs(i)=displs(i-1)+blocklengths(i-1)*maxres -c enddo -c do i=1,4 -c blocklengths(i)=blocklengths(i)*ichunk -c enddo -c write (iout,*) "blocklengths and displs" -c do i=1,4 -c write (iout,*) i,blocklengths(i),displs(i) -c enddo -c call flush(iout) -c call MPI_Type_indexed(4,blocklengths(1),displs(1), -c & MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR) -c call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR) -c write (iout,*) "MPI_ROTAT2",MPI_ROTAT2 - do i=1,8 - blocklengths(i)=2 - enddo - displs(1)=0 - do i=2,8 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,15 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(8,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR) - call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR) - do i=1,8 - blocklengths(i)=4 - enddo - displs(1)=0 - do i=2,8 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,15 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(8,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR) - call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR) - do i=1,6 - blocklengths(i)=4 - enddo - displs(1)=0 - do i=2,6 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,6 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(6,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR) - call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR) - do i=1,2 - blocklengths(i)=8 - enddo - displs(1)=0 - do i=2,2 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,2 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(2,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR) - call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR) - do i=1,4 - blocklengths(i)=1 - enddo - displs(1)=0 - do i=2,4 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,4 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(4,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR) - call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR) - enddo -#endif - endif - iint_start=ivec_start+1 - iint_end=ivec_end+1 - do i=0,nfgtasks-1 - iint_count(i)=ivec_count(i) - iint_displ(i)=ivec_displ(i) - ivec_displ(i)=ivec_displ(i)-1 - iset_displ(i)=iset_displ(i)-1 - ithet_displ(i)=ithet_displ(i)-1 - iphi_displ(i)=iphi_displ(i)-1 - iphi1_displ(i)=iphi1_displ(i)-1 - ibond_displ(i)=ibond_displ(i)-1 - enddo - if (nfgtasks.gt.1 .and. fg_rank.eq.king - & .and. (me.eq.0 .or. .not. out1file)) then - write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT" - do i=0,nfgtasks-1 - write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i), - & iset_count(i) - enddo - write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end, - & " iphi1_start",iphi1_start," iphi1_end",iphi1_end - write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL" - do i=0,nfgtasks-1 - write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i), - & iphi1_displ(i) - enddo - write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ', - & nele_int_tot,' electrostatic and ',nscp_int_tot, - & ' SC-p interactions','were distributed among',nfgtasks, - & ' fine-grain processors.' - endif -#else - loc_start=2 - loc_end=nres-1 - ithet_start=3 - ithet_end=nres - iturn3_start=nnt - iturn3_end=nct-3 - iturn4_start=nnt - iturn4_end=nct-4 - iphi_start=nnt+3 - iphi_end=nct - iphi1_start=4 - iphi1_end=nres - idihconstr_start=1 - idihconstr_end=ndih_constr - iphid_start=iphi_start - iphid_end=iphi_end-1 - itau_start=4 - itau_end=nres - ibond_start=2 - ibond_end=nres-1 - ibondp_start=nnt - ibondp_end=nct-1 - ivec_start=1 - ivec_end=nres-1 - iset_start=3 - iset_end=nres+1 - iint_start=2 - iint_end=nres-1 -#endif - return - end -#ifdef MPI -c--------------------------------------------------------------------------- - subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag) - implicit none - include "DIMENSIONS" - include "COMMON.INTERACT" - include "COMMON.SETUP" - include "COMMON.IOUNITS" - integer ii,jj,itask(4),ntask_cont_to, - &itask_cont_to(0:max_fg_procs-1) - logical flag - integer iturn3_start_all,iturn3_end_all,iturn4_start_all, - & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all - common /przechowalnia/ iturn3_start_all(0:max_fg_procs), - & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs), - & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs), - &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1), - & ielend_all(maxres,0:max_fg_procs-1) - integer iproc,isent,k,l -c Determines whether to send interaction ii,jj to other processors; a given -c interaction can be sent to at most 2 processors. -c Sets flag=.true. if interaction ii,jj needs to be sent to at least -c one processor, otherwise flag is unchanged from the input value. - isent=0 - itask(1)=fg_rank - itask(2)=fg_rank - itask(3)=fg_rank - itask(4)=fg_rank -c write (iout,*) "ii",ii," jj",jj -c Loop over processors to check if anybody could need interaction ii,jj - do iproc=0,fg_rank-1 -c Check if the interaction matches any turn3 at iproc - do k=iturn3_start_all(iproc),iturn3_end_all(iproc) - l=k+2 - if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1 - & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1) - & then -c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l -c call flush(iout) - flag=.true. - if (iproc.ne.itask(1).and.iproc.ne.itask(2) - & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then - isent=isent+1 - itask(isent)=iproc - call add_task(iproc,ntask_cont_to,itask_cont_to) - endif - endif - enddo -C Check if the interaction matches any turn4 at iproc - do k=iturn4_start_all(iproc),iturn4_end_all(iproc) - l=k+3 - if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1 - & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1) - & then -c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l -c call flush(iout) - flag=.true. - if (iproc.ne.itask(1).and.iproc.ne.itask(2) - & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then - isent=isent+1 - itask(isent)=iproc - call add_task(iproc,ntask_cont_to,itask_cont_to) - endif - endif - enddo - if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and. - & iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then - if (ielstart_all(ii-1,iproc).le.jj-1.and. - & ielend_all(ii-1,iproc).ge.jj-1) then - flag=.true. - if (iproc.ne.itask(1).and.iproc.ne.itask(2) - & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then - isent=isent+1 - itask(isent)=iproc - call add_task(iproc,ntask_cont_to,itask_cont_to) - endif - endif - if (ielstart_all(ii-1,iproc).le.jj+1.and. - & ielend_all(ii-1,iproc).ge.jj+1) then - flag=.true. - if (iproc.ne.itask(1).and.iproc.ne.itask(2) - & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then - isent=isent+1 - itask(isent)=iproc - call add_task(iproc,ntask_cont_to,itask_cont_to) - endif - endif - endif - enddo - return - end -c--------------------------------------------------------------------------- - subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from) - implicit none - include "DIMENSIONS" - include "COMMON.INTERACT" - include "COMMON.SETUP" - include "COMMON.IOUNITS" - integer ii,jj,itask(2),ntask_cont_from, - & itask_cont_from(0:max_fg_procs-1) - logical flag - integer iturn3_start_all,iturn3_end_all,iturn4_start_all, - & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all - common /przechowalnia/ iturn3_start_all(0:max_fg_procs), - & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs), - & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs), - &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1), - & ielend_all(maxres,0:max_fg_procs-1) - integer iproc,k,l - do iproc=fg_rank+1,nfgtasks-1 - do k=iturn3_start_all(iproc),iturn3_end_all(iproc) - l=k+2 - if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1 - & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1) - & then -c write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - enddo - do k=iturn4_start_all(iproc),iturn4_end_all(iproc) - l=k+3 - if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1 - & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1) - & then -c write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - enddo - if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then - if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc)) - & then - if (jj+1.ge.ielstart_all(ii+1,iproc).and. - & jj+1.le.ielend_all(ii+1,iproc)) then - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - if (jj-1.ge.ielstart_all(ii+1,iproc).and. - & jj-1.le.ielend_all(ii+1,iproc)) then - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - endif - if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc)) - & then - if (jj-1.ge.ielstart_all(ii-1,iproc).and. - & jj-1.le.ielend_all(ii-1,iproc)) then - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - if (jj+1.ge.ielstart_all(ii-1,iproc).and. - & jj+1.le.ielend_all(ii-1,iproc)) then - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - endif - endif - enddo - return - end -c--------------------------------------------------------------------------- - subroutine add_task(iproc,ntask_cont,itask_cont) - implicit none - include "DIMENSIONS" - integer iproc,ntask_cont,itask_cont(0:max_fg_procs-1) - integer ii - do ii=1,ntask_cont - if (itask_cont(ii).eq.iproc) return - enddo - ntask_cont=ntask_cont+1 - itask_cont(ntask_cont)=iproc - return - end -c--------------------------------------------------------------------------- - subroutine int_bounds(total_ints,lower_bound,upper_bound) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - integer total_ints,lower_bound,upper_bound - integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs) - nint=total_ints/nfgtasks - do i=1,nfgtasks - int4proc(i-1)=nint - enddo - nexcess=total_ints-nint*nfgtasks - do i=1,nexcess - int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1 - enddo - lower_bound=0 - do i=0,fg_rank-1 - lower_bound=lower_bound+int4proc(i) - enddo - upper_bound=lower_bound+int4proc(fg_rank) - lower_bound=lower_bound+1 - return - end -c--------------------------------------------------------------------------- - subroutine int_bounds1(total_ints,lower_bound,upper_bound) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - integer total_ints,lower_bound,upper_bound - integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs) - nint=total_ints/nfgtasks1 - do i=1,nfgtasks1 - int4proc(i-1)=nint - enddo - nexcess=total_ints-nint*nfgtasks1 - do i=1,nexcess - int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1 - enddo - lower_bound=0 - do i=0,fg_rank1-1 - lower_bound=lower_bound+int4proc(i) - enddo - upper_bound=lower_bound+int4proc(fg_rank1) - lower_bound=lower_bound+1 - return - end -c--------------------------------------------------------------------------- - subroutine int_partition(int_index,lower_index,upper_index,atom, - & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - integer int_index,lower_index,upper_index,atom,at_start,at_end, - & first_atom,last_atom,int_gr,jat_start,jat_end - logical lprn - lprn=.false. - if (lprn) write (iout,*) 'int_index=',int_index - int_index_old=int_index - int_index=int_index+last_atom-first_atom+1 - if (lprn) - & write (iout,*) 'int_index=',int_index, - & ' int_index_old',int_index_old, - & ' lower_index=',lower_index, - & ' upper_index=',upper_index, - & ' atom=',atom,' first_atom=',first_atom, - & ' last_atom=',last_atom - if (int_index.ge.lower_index) then - int_gr=int_gr+1 - if (at_start.eq.0) then - at_start=atom - jat_start=first_atom-1+lower_index-int_index_old - else - jat_start=first_atom - endif - if (lprn) write (iout,*) 'jat_start',jat_start - if (int_index.ge.upper_index) then - at_end=atom - jat_end=first_atom-1+upper_index-int_index_old - return1 - else - jat_end=last_atom - endif - if (lprn) write (iout,*) 'jat_end',jat_end - endif - return - end -#endif -c------------------------------------------------------------------------------ - subroutine hpb_partition - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SBRIDGE' - include 'COMMON.IOUNITS' - include 'COMMON.SETUP' -#ifdef MPI - call int_bounds(nhpb,link_start,link_end) - write (iout,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',MyRank, - & ' nhpb',nhpb,' link_start=',link_start, - & ' link_end',link_end -#else - link_start=1 - link_end=nhpb -#endif - return - end diff --git a/source/unres/src_MD-M-newcorr/int_to_cart.f b/source/unres/src_MD-M-newcorr/int_to_cart.f deleted file mode 100644 index f413622..0000000 --- a/source/unres/src_MD-M-newcorr/int_to_cart.f +++ /dev/null @@ -1,273 +0,0 @@ - subroutine int_to_cart -c-------------------------------------------------------------- -c This subroutine converts the energy derivatives from internal -c coordinates to cartesian coordinates -c------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.SCCOR' -c calculating dE/ddc1 - if (nres.lt.3) go to 18 - do j=1,3 - gcart(j,1)=gcart(j,1)+gloc(1,icg)*dphi(j,1,4) - & +gloc(nres-2,icg)*dtheta(j,1,3) - if(itype(2).ne.10) then - gcart(j,1)=gcart(j,1)+gloc(ialph(2,1),icg)*dalpha(j,1,2)+ - & gloc(ialph(2,1)+nside,icg)*domega(j,1,2) - endif - enddo -c Calculating the remainder of dE/ddc2 - do j=1,3 - gcart(j,2)=gcart(j,2)+gloc(1,icg)*dphi(j,2,4)+ - & gloc(nres-2,icg)*dtheta(j,2,3)+gloc(nres-1,icg)*dtheta(j,1,4) - if(itype(2).ne.10) then - gcart(j,2)=gcart(j,2)+gloc(ialph(2,1),icg)*dalpha(j,2,2)+ - & gloc(ialph(2,1)+nside,icg)*domega(j,2,2) - endif - if(itype(3).ne.10) then - gcart(j,2)=gcart(j,2)+gloc(ialph(3,1),icg)*dalpha(j,1,3)+ - & gloc(ialph(3,1)+nside,icg)*domega(j,1,3) - endif - if(nres.gt.4) then - gcart(j,2)=gcart(j,2)+gloc(2,icg)*dphi(j,1,5) - endif - enddo -c If there are only five residues - if(nres.eq.5) then - do j=1,3 - gcart(j,3)=gcart(j,3)+gloc(1,icg)*dphi(j,3,4)+gloc(2,icg)* - & dphi(j,2,5)+gloc(nres-1,icg)*dtheta(j,2,4)+gloc(nres,icg)* - & dtheta(j,1,5) - if(itype(3).ne.10) then - gcart(j,3)=gcart(j,3)+gloc(ialph(3,1),icg)* - & dalpha(j,2,3)+gloc(ialph(3,1)+nside,icg)*domega(j,2,3) - endif - if(itype(4).ne.10) then - gcart(j,3)=gcart(j,3)+gloc(ialph(4,1),icg)* - & dalpha(j,1,4)+gloc(ialph(4,1)+nside,icg)*domega(j,1,4) - endif - enddo - endif -c If there are more than five residues - if(nres.gt.5) then - do i=3,nres-3 - do j=1,3 - gcart(j,i)=gcart(j,i)+gloc(i-2,icg)*dphi(j,3,i+1) - & +gloc(i-1,icg)*dphi(j,2,i+2)+ - & gloc(i,icg)*dphi(j,1,i+3)+gloc(nres+i-4,icg)*dtheta(j,2,i+1)+ - & gloc(nres+i-3,icg)*dtheta(j,1,i+2) - if(itype(i).ne.10) then - gcart(j,i)=gcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,2,i)+ - & gloc(ialph(i,1)+nside,icg)*domega(j,2,i) - endif - if(itype(i+1).ne.10) then - gcart(j,i)=gcart(j,i)+gloc(ialph(i+1,1),icg)*dalpha(j,1,i+1) - & +gloc(ialph(i+1,1)+nside,icg)*domega(j,1,i+1) - endif - enddo - enddo - endif -c Setting dE/ddnres-2 - if(nres.gt.5) then - do j=1,3 - gcart(j,nres-2)=gcart(j,nres-2)+gloc(nres-4,icg)* - & dphi(j,3,nres-1)+gloc(nres-3,icg)*dphi(j,2,nres) - & +gloc(2*nres-6,icg)* - & dtheta(j,2,nres-1)+gloc(2*nres-5,icg)*dtheta(j,1,nres) - if(itype(nres-2).ne.10) then - gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-2,1),icg)* - & dalpha(j,2,nres-2)+gloc(ialph(nres-2,1)+nside,icg)* - & domega(j,2,nres-2) - endif - if(itype(nres-1).ne.10) then - gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-1,1),icg)* - & dalpha(j,1,nres-1)+gloc(ialph(nres-1,1)+nside,icg)* - & domega(j,1,nres-1) - endif - enddo - endif -c Settind dE/ddnres-1 - do j=1,3 - gcart(j,nres-1)=gcart(j,nres-1)+gloc(nres-3,icg)*dphi(j,3,nres)+ - & gloc(2*nres-5,icg)*dtheta(j,2,nres) - if(itype(nres-1).ne.10) then - gcart(j,nres-1)=gcart(j,nres-1)+gloc(ialph(nres-1,1),icg)* - & dalpha(j,2,nres-1)+gloc(ialph(nres-1,1)+nside,icg)* - & domega(j,2,nres-1) - endif - enddo -c The side-chain vector derivatives - do i=2,nres-1 - if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - gxcart(j,i)=gxcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,3,i) - & +gloc(ialph(i,1)+nside,icg)*domega(j,3,i) - enddo - endif - enddo -c---------------------------------------------------------------------- -C INTERTYP=1 SC...Ca...Ca...Ca -C INTERTYP=2 Ca...Ca...Ca...SC -C INTERTYP=3 SC...Ca...Ca...SC -c calculating dE/ddc1 - 18 continue -c do i=1,nres -c gloc(i,icg)=0.0D0 -c write (iout,*) "poczotkoawy",i,gloc_sc(1,i,icg) -c enddo - if (nres.lt.2) return - if ((nres.lt.3).and.(itype(1).eq.10)) return - if ((itype(1).ne.10).and.(itype(1).ne.ntyp1)) then - do j=1,3 -cc Derviative was calculated for oposite vector of side chain therefore -c there is "-" sign before gloc_sc - gxcart(j,1)=gxcart(j,1)-gloc_sc(1,0,icg)* - & dtauangle(j,1,1,3) - gcart(j,1)=gcart(j,1)+gloc_sc(1,0,icg)* - & dtauangle(j,1,2,3) - if ((itype(2).ne.10).and.(itype(2).ne.ntyp1)) then - gxcart(j,1)= gxcart(j,1) - & -gloc_sc(3,0,icg)*dtauangle(j,3,1,3) - gcart(j,1)=gcart(j,1)+gloc_sc(3,0,icg)* - & dtauangle(j,3,2,3) - endif - enddo - endif - if ((nres.ge.3).and.(itype(3).ne.10).and.(itype(3).ne.ntyp1)) - & then - do j=1,3 - gcart(j,1)=gcart(j,1)+gloc_sc(2,1,icg)*dtauangle(j,2,1,4) - enddo - endif -c As potetnial DO NOT depend on omicron anlge their derivative is -c ommited -c & +gloc_sc(intertyp,nres-2,icg)*dtheta(j,1,3) - -c Calculating the remainder of dE/ddc2 - do j=1,3 - if((itype(2).ne.10).and.(itype(2).ne.ntyp1)) then - if (itype(1).ne.10) gxcart(j,2)=gxcart(j,2)+ - & gloc_sc(3,0,icg)*dtauangle(j,3,3,3) - if ((itype(3).ne.10).and.(nres.ge.3).and.(itype(3).ne.ntyp1)) - & then - gxcart(j,2)=gxcart(j,2)-gloc_sc(3,1,icg)*dtauangle(j,3,1,4) -cc the - above is due to different vector direction - gcart(j,2)=gcart(j,2)+gloc_sc(3,1,icg)*dtauangle(j,3,2,4) - endif - if (nres.gt.3) then - gxcart(j,2)=gxcart(j,2)-gloc_sc(1,1,icg)*dtauangle(j,1,1,4) -cc the - above is due to different vector direction - gcart(j,2)=gcart(j,2)+gloc_sc(1,1,icg)*dtauangle(j,1,2,4) -c write(iout,*) gloc_sc(1,1,icg),dtauangle(j,1,2,4),"gcart" -c write(iout,*) gloc_sc(1,1,icg),dtauangle(j,1,1,4),"gx" - endif - endif - if ((itype(1).ne.10).and.(itype(1).ne.ntyp1)) then - gcart(j,2)=gcart(j,2)+gloc_sc(1,0,icg)*dtauangle(j,1,3,3) -c write(iout,*) gloc_sc(1,0,icg),dtauangle(j,1,3,3) - endif - if ((itype(3).ne.10).and.(nres.ge.3)) then - gcart(j,2)=gcart(j,2)+gloc_sc(2,1,icg)*dtauangle(j,2,2,4) -c write(iout,*) gloc_sc(2,1,icg),dtauangle(j,2,2,4) - endif - if ((itype(4).ne.10).and.(nres.ge.4)) then - gcart(j,2)=gcart(j,2)+gloc_sc(2,2,icg)*dtauangle(j,2,1,5) -c write(iout,*) gloc_sc(2,2,icg),dtauangle(j,2,1,5) - endif - -c write(iout,*) gcart(j,2),itype(2),itype(1),itype(3), "gcart2" - enddo -c If there are more than five residues - if(nres.ge.5) then - do i=3,nres-2 - do j=1,3 -c write(iout,*) "before", gcart(j,i) - if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then - gxcart(j,i)=gxcart(j,i)+gloc_sc(2,i-2,icg) - & *dtauangle(j,2,3,i+1) - & -gloc_sc(1,i-1,icg)*dtauangle(j,1,1,i+2) - gcart(j,i)=gcart(j,i)+gloc_sc(1,i-1,icg) - & *dtauangle(j,1,2,i+2) -c write(iout,*) "new",j,i, -c & gcart(j,i),gloc_sc(1,i-1,icg),dtauangle(j,1,2,i+2) - if (itype(i-1).ne.10) then - gxcart(j,i)=gxcart(j,i)+gloc_sc(3,i-2,icg) - &*dtauangle(j,3,3,i+1) - endif - if (itype(i+1).ne.10) then - gxcart(j,i)=gxcart(j,i)-gloc_sc(3,i-1,icg) - &*dtauangle(j,3,1,i+2) - gcart(j,i)=gcart(j,i)+gloc_sc(3,i-1,icg) - &*dtauangle(j,3,2,i+2) - endif - endif - if (itype(i-1).ne.10) then - gcart(j,i)=gcart(j,i)+gloc_sc(1,i-2,icg)* - & dtauangle(j,1,3,i+1) - endif - if (itype(i+1).ne.10) then - gcart(j,i)=gcart(j,i)+gloc_sc(2,i-1,icg)* - & dtauangle(j,2,2,i+2) -c write(iout,*) "numer",i,gloc_sc(2,i-1,icg), -c & dtauangle(j,2,2,i+2) - endif - if (itype(i+2).ne.10) then - gcart(j,i)=gcart(j,i)+gloc_sc(2,i,icg)* - & dtauangle(j,2,1,i+3) - endif - enddo - enddo - endif -c Setting dE/ddnres-1 - if(nres.ge.4) then - do j=1,3 - if ((itype(nres-1).ne.10).and.(itype(nres-1).ne.ntyp1)) then - gxcart(j,nres-1)=gxcart(j,nres-1)+gloc_sc(2,nres-3,icg) - & *dtauangle(j,2,3,nres) -c write (iout,*) "gxcart(nres-1)", gloc_sc(2,nres-3,icg), -c & dtauangle(j,2,3,nres), gxcart(j,nres-1) - if (itype(nres-2).ne.10) then - gxcart(j,nres-1)=gxcart(j,nres-1)+gloc_sc(3,nres-3,icg) - & *dtauangle(j,3,3,nres) - endif - if ((itype(nres).ne.10).and.(itype(nres).ne.ntyp1)) then - gxcart(j,nres-1)=gxcart(j,nres-1)-gloc_sc(3,nres-2,icg) - & *dtauangle(j,3,1,nres+1) - gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(3,nres-2,icg) - & *dtauangle(j,3,2,nres+1) - endif - endif - if ((itype(nres-2).ne.10).and.(itype(nres-2).ne.ntyp1)) then - gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(1,nres-3,icg)* - & dtauangle(j,1,3,nres) - endif - if ((itype(nres).ne.10).and.(itype(nres).ne.ntyp1)) then - gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(2,nres-2,icg)* - & dtauangle(j,2,2,nres+1) -c write (iout,*) "gcart(nres-1)", gloc_sc(2,nres-2,icg), -c & dtauangle(j,2,2,nres+1), itype(nres-1),itype(nres) - endif - enddo - endif -c Settind dE/ddnres - if ((nres.ge.3).and.(itype(nres).ne.10).and. - & (itype(nres).ne.ntyp1))then - do j=1,3 - gxcart(j,nres)=gxcart(j,nres)+gloc_sc(3,nres-2,icg) - & *dtauangle(j,3,3,nres+1)+gloc_sc(2,nres-2,icg) - & *dtauangle(j,2,3,nres+1) - enddo - endif -c The side-chain vector derivatives - return - end - - diff --git a/source/unres/src_MD-M-newcorr/intcartderiv.F b/source/unres/src_MD-M-newcorr/intcartderiv.F deleted file mode 100644 index 369a4f0..0000000 --- a/source/unres/src_MD-M-newcorr/intcartderiv.F +++ /dev/null @@ -1,754 +0,0 @@ - subroutine intcartderiv - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.LOCAL' - include 'COMMON.SCCOR' - double precision dcostheta(3,2,maxres), - & dcosphi(3,3,maxres),dsinphi(3,3,maxres), - & dcosalpha(3,3,maxres),dcosomega(3,3,maxres), - & dsinomega(3,3,maxres),vo1(3),vo2(3),vo3(3), - & dummy(3),vp1(3),vp2(3),vp3(3),vpp1(3),n(3) - -#if defined(MPI) && defined(PARINTDER) - if (nfgtasks.gt.1 .and. me.eq.king) - & call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - pi4 = 0.5d0*pipol - pi34 = 3*pi4 - -c write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end - do i=1,nres - do j=1,3 - dtheta(j,1,i)=0.0d0 - dtheta(j,2,i)=0.0d0 - dphi(j,1,i)=0.0d0 - dphi(j,2,i)=0.0d0 - dphi(j,3,i)=0.0d0 - enddo - enddo -c Derivatives of theta's -#if defined(MPI) && defined(PARINTDER) -c We need dtheta(:,:,i-1) to compute dphi(:,:,i) - do i=max0(ithet_start-1,3),ithet_end -#else - do i=3,nres -#endif - cost=dcos(theta(i)) - sint=sqrt(1-cost*cost) - do j=1,3 - dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/ - & vbld(i-1) - if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint - dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/ - & vbld(i) - if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint - enddo - enddo -#if defined(MPI) && defined(PARINTDER) -c We need dtheta(:,:,i-1) to compute dphi(:,:,i) - do i=max0(ithet_start-1,3),ithet_end -#else - do i=3,nres -#endif - if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then - cost1=dcos(omicron(1,i)) - sint1=sqrt(1-cost1*cost1) - cost2=dcos(omicron(2,i)) - sint2=sqrt(1-cost2*cost2) - do j=1,3 -CC Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1) - dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ - & cost1*dc_norm(j,i-2))/ - & vbld(i-1) - domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i) - dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) - & +cost1*(dc_norm(j,i-1+nres)))/ - & vbld(i-1+nres) - domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i) -CC Calculate derivative over second omicron Sci-1,Cai-1 Cai -CC Looks messy but better than if in loop - dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) - & +cost2*dc_norm(j,i-1))/ - & vbld(i) - domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i) - dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) - & +cost2*(-dc_norm(j,i-1+nres)))/ - & vbld(i-1+nres) -c write(iout,*) "vbld", i,itype(i),vbld(i-1+nres) - domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i) - enddo - endif - enddo - -c Derivatives of phi: -c If phi is 0 or 180 degrees, then the formulas -c have to be derived by power series expansion of the -c conventional formulas around 0 and 180. -#ifdef PARINTDER - do i=iphi1_start,iphi1_end -#else - do i=4,nres -#endif -c if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle -c the conventional case - sint=dsin(theta(i)) - sint1=dsin(theta(i-1)) - sing=dsin(phi(i)) - cost=dcos(theta(i)) - cost1=dcos(theta(i-1)) - cosg=dcos(phi(i)) - scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -c Obtaining the gamma derivatives from sine derivative - if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. - & phi(i).gt.pi34.and.phi(i).le.pi.or. - & phi(i).gt.-pi.and.phi(i).le.-pi34) then - call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then - dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) - & -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2) - dphi(j,1,i)=cosg_inv*dsinphi(j,1,i) - dsinphi(j,2,i)= - & -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) - & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) - dphi(j,2,i)=cosg_inv*dsinphi(j,2,i) - dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) - & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) -c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dphi(j,3,i)=cosg_inv*dsinphi(j,3,i) - endif -c Bug fixed 3/24/05 (AL) - enddo -c Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then - dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* - & dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* - & dc_norm(j,i-3))/vbld(i-2) - dphi(j,1,i)=-1/sing*dcosphi(j,1,i) - dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* - & dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* - & dcostheta(j,1,i) - dphi(j,2,i)=-1/sing*dcosphi(j,2,i) - dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* - & dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* - & dc_norm(j,i-1))/vbld(i) - dphi(j,3,i)=-1/sing*dcosphi(j,3,i) - endif - enddo - endif - enddo -Calculate derivative of Tauangle -#ifdef PARINTDER - do i=itau_start,itau_end -#else - do i=3,nres -#endif - if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle -c if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or. -c & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle -cc dtauangle(j,intertyp,dervityp,residue number) -cc INTERTYP=1 SC...Ca...Ca..Ca -c the conventional case - sint=dsin(theta(i)) - sint1=dsin(omicron(2,i-1)) - sing=dsin(tauangle(1,i)) - cost=dcos(theta(i)) - cost1=dcos(omicron(2,i-1)) - cosg=dcos(tauangle(1,i)) - do j=1,3 - dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres) -cc write(iout,*) dc_norm2(j,i-2+nres),"dcnorm" - enddo - scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -cc write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4 -c Obtaining the gamma derivatives from sine derivative - if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. - & tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. - & tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then - call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) - call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2) - call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) - &-(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) - & *vbld_inv(i-2+nres) - dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i) - dsintau(j,1,2,i)= - & -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) - & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) -c write(iout,*) "dsintau", dsintau(j,1,2,i) - dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i) -c Bug fixed 3/24/05 (AL) - dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) - & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) -c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i) - enddo -c Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* - & dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* - & (dc_norm2(j,i-2+nres)))/vbld(i-2+nres) - dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i) - dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* - & dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* - & dcostheta(j,1,i) - dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i) - dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* - & dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* - & dc_norm(j,i-1))/vbld(i) - dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i) -c write (iout,*) "else",i - enddo - endif -c do k=1,3 -c write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3) -c enddo - enddo -CC Second case Ca...Ca...Ca...SC -#ifdef PARINTDER - do i=itau_start,itau_end -#else - do i=4,nres -#endif - if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. - & (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle -c the conventional case - sint=dsin(omicron(1,i)) - sint1=dsin(theta(i-1)) - sing=dsin(tauangle(2,i)) - cost=dcos(omicron(1,i)) - cost1=dcos(theta(i-1)) - cosg=dcos(tauangle(2,i)) -c do j=1,3 -c dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres) -c enddo - scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -c Obtaining the gamma derivatives from sine derivative - if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. - & tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. - & tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then - call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) - & +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2) -c write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1), -c &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)" - dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i) - dsintau(j,2,2,i)= - & -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) - & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) -c write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1), -c & sing*ctgt*domicron(j,1,2,i), -c & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) - dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i) -c Bug fixed 3/24/05 (AL) - dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) - & +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres) -c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i) - enddo -c Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* - & dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* - & dc_norm(j,i-3))/vbld(i-2) - dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i) - dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* - & dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* - & dcosomicron(j,1,1,i) - dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i) - dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* - & dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* - & dc_norm(j,i-1+nres))/vbld(i-1+nres) - dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i) -c write(iout,*) i,j,"else", dtauangle(j,2,3,i) - enddo - endif - enddo - -CCC third case SC...Ca...Ca...SC -#ifdef PARINTDER - - do i=itau_start,itau_end -#else - do i=3,nres -#endif -c the conventional case - if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. - &(itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle - sint=dsin(omicron(1,i)) - sint1=dsin(omicron(2,i-1)) - sing=dsin(tauangle(3,i)) - cost=dcos(omicron(1,i)) - cost1=dcos(omicron(2,i-1)) - cosg=dcos(tauangle(3,i)) - do j=1,3 - dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres) -c dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres) - enddo - scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -c Obtaining the gamma derivatives from sine derivative - if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. - & tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. - & tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then - call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1) - call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2) - call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) - & -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) - & *vbld_inv(i-2+nres) - dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i) - dsintau(j,3,2,i)= - & -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) - & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) - dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i) -c Bug fixed 3/24/05 (AL) - dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) - & +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) - & *vbld_inv(i-1+nres) -c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i) - enddo -c Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* - & dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* - & dc_norm2(j,i-2+nres))/vbld(i-2+nres) - dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i) - dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* - & dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* - & dcosomicron(j,1,1,i) - dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i) - dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* - & dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* - & dc_norm(j,i-1+nres))/vbld(i-1+nres) - dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i) -c write(iout,*) "else",i - enddo - endif - enddo - -#ifdef CRYST_SC -c Derivatives of side-chain angles alpha and omega -#if defined(MPI) && defined(PARINTDER) - do i=ibond_start,ibond_end -#else - do i=2,nres-1 -#endif - if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then - fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1)))) - fac6=fac5/vbld(i) - fac7=fac5*fac5 - fac8=fac5/vbld(i+1) - fac9=fac5/vbld(i+nres) - scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) - scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres)) - cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))*( - & scalar(dC_norm(1,i),dC_norm(1,i+nres)) - & -scalar(dC_norm(1,i-1),dC_norm(1,i+nres))) - sina=sqrt(1-cosa*cosa) - sino=dsin(omeg(i)) -c write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino - do j=1,3 - dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- - & dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1) - dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i) - dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- - & scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1) - dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i) - dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- - & dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ - & vbld(i+nres)) - dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i) - enddo -c obtaining the derivatives of omega from sines - if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. - & omeg(i).gt.pi34.and.omeg(i).le.pi.or. - & omeg(i).gt.-pi.and.omeg(i).le.-pi34) then - fac15=dcos(theta(i+1))/(dsin(theta(i+1))* - & dsin(theta(i+1))) - fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i))) - fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i))) - call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1) - call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2) - call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3) - coso_inv=1.0d0/dcos(omeg(i)) - do j=1,3 - dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) - & +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)-( - & sino*dc_norm(j,i-1))/vbld(i) - domega(j,1,i)=coso_inv*dsinomega(j,1,i) - dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) - & +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) - & -sino*dc_norm(j,i)/vbld(i+1) - domega(j,2,i)=coso_inv*dsinomega(j,2,i) - dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- - & fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ - & vbld(i+nres) - domega(j,3,i)=coso_inv*dsinomega(j,3,i) - enddo - else -c obtaining the derivatives of omega from cosines - fac10=sqrt(0.5d0*(1-dcos(theta(i+1)))) - fac11=sqrt(0.5d0*(1+dcos(theta(i+1)))) - fac12=fac10*sina - fac13=fac12*fac12 - fac14=sina*sina - do j=1,3 - dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* - & dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ - & (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* - & fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13 - domega(j,1,i)=-1/sino*dcosomega(j,1,i) - dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* - & dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* - & dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ - & (scala2-fac11*cosa)*(0.25d0*sina/fac10* - & dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i) - & ))/fac13 - domega(j,2,i)=-1/sino*dcosomega(j,2,i) - dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- - & scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ - & (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14 - domega(j,3,i)=-1/sino*dcosomega(j,3,i) - enddo - endif - else - do j=1,3 - do k=1,3 - dalpha(k,j,i)=0.0d0 - domega(k,j,i)=0.0d0 - enddo - enddo - endif - enddo -#endif -#if defined(MPI) && defined(PARINTDER) - if (nfgtasks.gt.1) then -#ifdef DEBUG -cd write (iout,*) "Gather dtheta" -cd call flush(iout) - write (iout,*) "dtheta before gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2) - enddo -#endif - call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank), - & MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET, - & king,FG_COMM,IERROR) -#ifdef DEBUG -cd write (iout,*) "Gather dphi" -cd call flush(iout) - write (iout,*) "dphi before gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3) - enddo -#endif - call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank), - & MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM, - & king,FG_COMM,IERROR) -cd write (iout,*) "Gather dalpha" -cd call flush(iout) -#ifdef CRYST_SC - call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank), - & MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM, - & king,FG_COMM,IERROR) -cd write (iout,*) "Gather domega" -cd call flush(iout) - call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank), - & MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM, - & king,FG_COMM,IERROR) -#endif - endif -#endif -#ifdef DEBUG - write (iout,*) "dtheta after gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2) - enddo - write (iout,*) "dphi after gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3) - enddo - write (iout,*) "dalpha after gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3) - enddo - write (iout,*) "domega after gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3) - enddo -#endif - return - end - - subroutine checkintcartgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.SETUP' - double precision dthetanum(3,2,maxres),dphinum(3,3,maxres) - & ,dalphanum(3,3,maxres), domeganum(3,3,maxres) - double precision theta_s(maxres),phi_s(maxres),alph_s(maxres), - & omeg_s(maxres),dc_norm_s(3) - double precision aincr /1.0d-5/ - - do i=1,nres - phi_s(i)=phi(i) - theta_s(i)=theta(i) - alph_s(i)=alph(i) - omeg_s(i)=omeg(i) - enddo -c Check theta gradient - write (iout,*) - & "Analytical (upper) and numerical (lower) gradient of theta" - write (iout,*) - do i=3,nres - do j=1,3 - dcji=dc(j,i-2) - dc(j,i-2)=dcji+aincr - call chainbuild_cart - call int_from_cart1(.false.) - dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr - dc(j,i-2)=dcji - dcji=dc(j,i-1) - dc(j,i-1)=dc(j,i-1)+aincr - call chainbuild_cart - dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr - dc(j,i-1)=dcji - enddo - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3), - & (dtheta(j,2,i),j=1,3) - write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3), - & (dthetanum(j,2,i),j=1,3) - write (iout,'(5x,3f10.5,5x,3f10.5)') - & (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3), - & (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3) - write (iout,*) - enddo -c Check gamma gradient - write (iout,*) - & "Analytical (upper) and numerical (lower) gradient of gamma" - do i=4,nres - do j=1,3 - dcji=dc(j,i-3) - dc(j,i-3)=dcji+aincr - call chainbuild_cart - dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr - dc(j,i-3)=dcji - dcji=dc(j,i-2) - dc(j,i-2)=dcji+aincr - call chainbuild_cart - dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr - dc(j,i-2)=dcji - dcji=dc(j,i-1) - dc(j,i-1)=dc(j,i-1)+aincr - call chainbuild_cart - dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr - dc(j,i-1)=dcji - enddo - write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3), - & (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3), - & (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') - & (dphinum(j,1,i)/dphi(j,1,i),j=1,3), - & (dphinum(j,2,i)/dphi(j,2,i),j=1,3), - & (dphinum(j,3,i)/dphi(j,3,i),j=1,3) - write (iout,*) - enddo -c Check alpha gradient - write (iout,*) - & "Analytical (upper) and numerical (lower) gradient of alpha" - do i=2,nres-1 - if(itype(i).ne.10) then - do j=1,3 - dcji=dc(j,i-1) - dc(j,i-1)=dcji+aincr - call chainbuild_cart - dalphanum(j,1,i)=(alph(i)-alph_s(i)) - & /aincr - dc(j,i-1)=dcji - dcji=dc(j,i) - dc(j,i)=dcji+aincr - call chainbuild_cart - dalphanum(j,2,i)=(alph(i)-alph_s(i)) - & /aincr - dc(j,i)=dcji - dcji=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+aincr - call chainbuild_cart - dalphanum(j,3,i)=(alph(i)-alph_s(i)) - & /aincr - dc(j,i+nres)=dcji - enddo - endif - write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3), - & (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3), - & (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') - & (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3), - & (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3), - & (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3) - write (iout,*) - enddo -c Check omega gradient - write (iout,*) - & "Analytical (upper) and numerical (lower) gradient of omega" - do i=2,nres-1 - if(itype(i).ne.10) then - do j=1,3 - dcji=dc(j,i-1) - dc(j,i-1)=dcji+aincr - call chainbuild_cart - domeganum(j,1,i)=(omeg(i)-omeg_s(i)) - & /aincr - dc(j,i-1)=dcji - dcji=dc(j,i) - dc(j,i)=dcji+aincr - call chainbuild_cart - domeganum(j,2,i)=(omeg(i)-omeg_s(i)) - & /aincr - dc(j,i)=dcji - dcji=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+aincr - call chainbuild_cart - domeganum(j,3,i)=(omeg(i)-omeg_s(i)) - & /aincr - dc(j,i+nres)=dcji - enddo - endif - write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3), - & (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3), - & (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') - & (domeganum(j,1,i)/domega(j,1,i),j=1,3), - & (domeganum(j,2,i)/domega(j,2,i),j=1,3), - & (domeganum(j,3,i)/domega(j,3,i),j=1,3) - write (iout,*) - enddo - return - end - - subroutine chainbuild_cart - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.TIME1' - include 'COMMON.IOUNITS' - -#ifdef MPI - if (nfgtasks.gt.1) then -c write (iout,*) "BCAST in chainbuild_cart" -c call flush(iout) -c Broadcast the order to build the chain and compute internal coordinates -c to the slaves. The slaves receive the order in ERGASTULUM. - time00=MPI_Wtime() -c write (iout,*) "CHAINBUILD_CART: DC before BCAST" -c do i=0,nres -c write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), -c & (dc(j,i+nres),j=1,3) -c enddo - if (fg_rank.eq.0) - & call MPI_Bcast(7,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_bcast7=time_bcast7+MPI_Wtime()-time00 - time01=MPI_Wtime() - call MPI_Bcast(dc(1,0),6*(nres+1),MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "CHAINBUILD_CART: DC after BCAST" -c do i=0,nres -c write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), -c & (dc(j,i+nres),j=1,3) -c enddo -c write (iout,*) "End BCAST in chainbuild_cart" -c call flush(iout) - time_bcast=time_bcast+MPI_Wtime()-time00 - time_bcastc=time_bcastc+MPI_Wtime()-time01 - endif -#endif - do j=1,3 - c(j,1)=dc(j,0) - enddo - do i=2,nres - do j=1,3 - c(j,i)=c(j,i-1)+dc(j,i-1) - enddo - enddo - do i=1,nres - do j=1,3 - c(j,i+nres)=c(j,i)+dc(j,i+nres) - enddo - enddo -c write (iout,*) "CHAINBUILD_CART" -c call cartprint - call int_from_cart1(.false.) - return - end diff --git a/source/unres/src_MD-M-newcorr/intcor.f b/source/unres/src_MD-M-newcorr/intcor.f deleted file mode 100644 index a3cd5d0..0000000 --- a/source/unres/src_MD-M-newcorr/intcor.f +++ /dev/null @@ -1,91 +0,0 @@ -C -C------------------------------------------------------------------------------ -C - double precision function alpha(i1,i2,i3) -c -c Calculates the planar angle between atoms (i1), (i2), and (i3). -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - x12=c(1,i1)-c(1,i2) - x23=c(1,i3)-c(1,i2) - y12=c(2,i1)-c(2,i2) - y23=c(2,i3)-c(2,i2) - z12=c(3,i1)-c(3,i2) - z23=c(3,i3)-c(3,i2) - vnorm=dsqrt(x12*x12+y12*y12+z12*z12) - wnorm=dsqrt(x23*x23+y23*y23+z23*z23) - scalar=(x12*x23+y12*y23+z12*z23)/(vnorm*wnorm) - alpha=arcos(scalar) - return - end -C -C------------------------------------------------------------------------------ -C - double precision function beta(i1,i2,i3,i4) -c -c Calculates the dihedral angle between atoms (i1), (i2), (i3) and (i4) -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - x12=c(1,i1)-c(1,i2) - x23=c(1,i3)-c(1,i2) - x34=c(1,i4)-c(1,i3) - y12=c(2,i1)-c(2,i2) - y23=c(2,i3)-c(2,i2) - y34=c(2,i4)-c(2,i3) - z12=c(3,i1)-c(3,i2) - z23=c(3,i3)-c(3,i2) - z34=c(3,i4)-c(3,i3) -cd print '(2i3,3f10.5)',i1,i2,x12,y12,z12 -cd print '(2i3,3f10.5)',i2,i3,x23,y23,z23 -cd print '(2i3,3f10.5)',i3,i4,x34,y34,z34 - wx=-y23*z34+y34*z23 - wy=x23*z34-z23*x34 - wz=-x23*y34+y23*x34 - wnorm=dsqrt(wx*wx+wy*wy+wz*wz) - vx=y12*z23-z12*y23 - vy=-x12*z23+z12*x23 - vz=x12*y23-y12*x23 - vnorm=dsqrt(vx*vx+vy*vy+vz*vz) - if (vnorm.gt.1.0D-13 .and. wnorm.gt.1.0D-13) then - scalar=(vx*wx+vy*wy+vz*wz)/(vnorm*wnorm) - if (dabs(scalar).gt.1.0D0) - &scalar=0.99999999999999D0*scalar/dabs(scalar) - angle=dacos(scalar) -cd print '(2i4,10f7.3)',i2,i3,vx,vy,vz,wx,wy,wz,vnorm,wnorm, -cd &scalar,angle - else - angle=pi - endif -c if (angle.le.0.0D0) angle=pi+angle - tx=vy*wz-vz*wy - ty=-vx*wz+vz*wx - tz=vx*wy-vy*wx - scalar=tx*x23+ty*y23+tz*z23 - if (scalar.lt.0.0D0) angle=-angle - beta=angle - return - end -C -C------------------------------------------------------------------------------ -C - function dist(i1,i2) -c -c Calculates the distance between atoms (i1) and (i2). -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - x12=c(1,i1)-c(1,i2) - y12=c(2,i1)-c(2,i2) - z12=c(3,i1)-c(3,i2) - dist=dsqrt(x12*x12+y12*y12+z12*z12) - return - end -C diff --git a/source/unres/src_MD-M-newcorr/intlocal.f b/source/unres/src_MD-M-newcorr/intlocal.f deleted file mode 100644 index 2dbcc88..0000000 --- a/source/unres/src_MD-M-newcorr/intlocal.f +++ /dev/null @@ -1,517 +0,0 @@ - subroutine integral(gamma1,gamma2,gamma3,gamma4,ity1,ity2,a1,a2, - & si1,si2,si3,si4,transp,q) - implicit none - integer ity1,ity2 - integer ilam1,ilam2,ilam3,ilam4,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4 - logical transp - double precision elocal,ele - double precision delta,delta2,sum,ene,sumene,boltz - double precision q,a1(2,2),a2(2,2),si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=20 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) gamma1,gamma2,ity1,ity2,a1,a2,si1,si2,si3,si4,transp - -cd do ilam1=-180,180,5 -cd do ilam2=-180,180,5 -cd lambda1=ilam1*conv+delta2 -cd lambda2=ilam2*conv+delta2 -cd write(2,'(2i5,2f10.5)') ilam1,ilam2,elocal(2,lambda1,lambda2), -cd & ele(lambda1,lambda2,a1,1.0d0,1.d00) -cd enddo -cd enddo -cd stop - - sum=0.0d0 - sumene=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 -cd write (2,*) ilam1,ilam2,ilam3,ilam4 -cd write (2,*) lambda1,lambda2,lambda3,lambda4 - ene= - & -elocal(ity1,lambda1,lambda2,.false.)* - & elocal(ity2,lambda3,lambda4,transp)* - & ele(si1*lambda1+gamma1,si3*lambda3+gamma3,a1)* - & ele(si2*lambda2+gamma2,si4*lambda4+gamma4,a2) -cd write (2,*) elocal(ity1,lambda1,gamma1-pi-lambda2), -cd & elocal(ity2,lambda3,gamma2-pi-lambda4), -cd & ele(lambda1,lambda2,a1,si1,si3), -cd & ele(lambda3,lambda4,a2,si2,si4) - sum=sum+ene - enddo - enddo - enddo - enddo - q=sum/(2*pi)**4*delta**4 - write (2,* )'sum',sum,' q',q - return - end -c--------------------------------------------------------------------------- - subroutine integral3(gamma1,gamma2,ity1,ity2,ity3,ity4, - & a1,koniec,q1,q2,q3,q4) - implicit none - integer ity1,ity2,ity3,ity4 - integer ilam1,ilam2,ilam3,ilam4,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,lambda1, - & lambda2,lambda3,lambda4 - logical koniec - double precision elocal,ele - double precision delta,delta2,sum1,sum2,sum3,sum4, - & ene1,ene2,ene3,ene4,boltz - double precision q1,q2,q3,q4,a1(2,2),a2(2,2) - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta - write(2,*) gamma1,gamma2,ity1,ity2,ity3,ity4,a1,koniec - -cd do ilam1=-180,180,5 -cd do ilam2=-180,180,5 -cd lambda1=ilam1*conv+delta2 -cd lambda2=ilam2*conv+delta2 -cd write(2,'(2i5,2f10.5)') ilam1,ilam2,elocal(2,lambda1,lambda2), -cd & ele(lambda1,lambda2,a1,1.0d0,1.d00) -cd enddo -cd enddo -cd stop - - sum1=0.0d0 - sum2=0.0d0 - sum3=0.0d0 - sum4=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 -cd write (2,*) ilam1,ilam2,ilam3,ilam4 -cd write (2,*) lambda1,lambda2,lambda3,lambda4 - if (.not.koniec) then - ene1= - & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)* - & elocal(ity3,lambda3,gamma2-pi-lambda4,.false.)* - & ele(lambda2,lambda4,a1) - else - ene1= - & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)* - & elocal(ity3,lambda3,lambda4,.false.)* - & ele(lambda2,-lambda4,a1) - endif - ene2= - & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)* - & elocal(ity4,lambda3,lambda4,.false.)* - & ele(lambda2,lambda3,a1) - if (.not.koniec) then - ene3= - & elocal(ity2,lambda1,lambda2,.false.)* - & elocal(ity3,lambda3,gamma2-pi-lambda4,.false.)* - & ele(lambda1,lambda4,a1) - else - ene3= - & elocal(ity2,lambda1,lambda2,.false.)* - & elocal(ity3,lambda3,lambda4,.false.)* - & ele(lambda1,-lambda4,a1) - endif - ene4= - & elocal(ity2,lambda1,lambda2,.false.)* - & elocal(ity4,lambda3,lambda4,.false.)* - & ele(lambda1,lambda3,a1) - sum1=sum1+ene1 - sum2=sum2+ene2 - sum3=sum3+ene3 - sum4=sum4+ene4 - enddo - enddo - enddo - enddo - q1=sum1/(2*pi)**4*delta**4 - q2=sum2/(2*pi)**4*delta**4 - q3=sum3/(2*pi)**4*delta**4 - q4=sum4/(2*pi)**4*delta**4 - write (2,* )'sum',sum1,sum2,sum3,sum4,' q',q1,q2,q3,q4 - return - end -c------------------------------------------------------------------------- - subroutine integral5(gamma1,gamma2,gamma3,gamma4,ity1,ity2,ity3, - & ity4,ity5,ity6,a1,a2,si1,si2,si3,si4,transp,ene1,ene2,ene3,ene4) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc5,eloc6,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,sum1,sum2,sum3,sum4, - & a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, -cd & ' gamma3=',gamma3,' gamma4=',gamma4 -cd write(2,*) ity1,ity2,ity3,ity4,ity5,ity6 -cd write(2,*) 'a1=',a1 -cd write(2,*) 'a2=',a2 -cd write(2,*) si1,si2,si3,si4,transp - - sum1=0.0d0 - sum2=0.0d0 - sum3=0.0d0 - sum4=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - do ilam5=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - lambda5=ilam5*conv+delta2 - if (transp) then - ele1=ele(lambda1,si4*lambda4,a1) - ele2=ele(lambda2,lambda3,a2) - else - ele1=ele(lambda1,lambda3,a1) - ele2=ele(lambda2,si4*lambda4,a2) - endif - eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.) - eloc5=elocal(ity5,lambda3,gamma4-pi-si4*lambda4,.false.) - pom=ele1*ele2*eloc2*eloc5 - if (si1.gt.0) then - eloc1=elocal(ity1,lambda5,gamma1-pi-lambda1,.false.) - sum1=sum1+pom*eloc1 - endif - eloc3=elocal(ity3,lambda2,lambda5,.false.) - sum2=sum2+pom*eloc3 - eloc4=elocal(ity4,lambda5,gamma3-pi-lambda3,.false.) - sum3=sum3+pom*eloc4 - if (si4.gt.0) then - eloc6=elocal(ity6,lambda4,lambda5,.false.) - sum4=sum4+pom*eloc6 - endif - enddo - enddo - enddo - enddo - enddo - pom=1.0d0/(2*pi)**5*delta**5 - ene1=sum1*pom - ene2=sum2*pom - ene3=sum3*pom - ene4=sum4*pom -c write (2,* )'sum',sum1,sum2,sum3,sum4,' q',ene1,ene2,ene3,ene4 - return - end -c------------------------------------------------------------------------- - subroutine integral_turn6(gamma1,gamma2,gamma3,gamma4,ity1,ity2, - & ity3,ity4,ity5,ity6,a1,a2,ene_turn6) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom,ene5 - double precision ene_turn6,sum5,a1(2,2),a2(2,2) - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta - write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, - & ' gamma3=',gamma3,' gamma4=',gamma4 - write(2,*) ity1,ity2,ity3,ity4,ity5,ity6 - write(2,*) 'a1=',a1 - write(2,*) 'a2=',a2 - - sum5=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - do ilam5=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - lambda5=ilam5*conv+delta2 - ele1=ele(lambda1,-lambda4,a1) - ele2=ele(lambda2,lambda3,a2) - eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.) - eloc5=elocal(ity5,lambda3,lambda4,.false.) - pom=ele1*ele2*eloc2*eloc5 - eloc3=elocal(ity3,lambda2,gamma3-pi-lambda5,.false.) - eloc4=elocal(ity4,lambda5,gamma4-pi-lambda3,.false.) - sum5=sum5+pom*eloc3*eloc4 - enddo - enddo - enddo - enddo - enddo - pom=-1.0d0/(2*pi)**5*delta**5 - ene_turn6=sum5*pom -c print *,'sum6',sum6,' ene6',ene6 - return - end -c------------------------------------------------------------------------- - subroutine integral6(gamma1,gamma2,gamma3,gamma4,ity1,ity2,ity3, - & ity4,ity5,ity6,a1,a2,si1,si2,si3,si4,transp,ene1,ene2,ene3,ene4, - & ene5,ene6) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3, - & sum4,sum5,sum6,a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, -cd & ' gamma3=',gamma3,' gamma4=',gamma4 -cd write(2,*) ity1,ity2,ity3,ity4,ity5,ity6 -cd write(2,*) 'a1=',a1 -cd write(2,*) 'a2=',a2 -cd write(2,*) si1,si2,si3,si4,transp - - sum1=0.0d0 - sum2=0.0d0 - sum3=0.0d0 - sum4=0.0d0 - sum5=0.0d0 - sum6=0.0d0 - eloc1=0.0d0 - eloc6=0.0d0 - eloc61=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - do ilam5=-180,179,iincr - do ilam6=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - lambda5=ilam5*conv+delta2 - lambda6=ilam6*conv+delta2 - if (transp) then - ele1=ele(lambda1,si4*lambda4,a1) - ele2=ele(lambda2,lambda3,a2) - else - ele1=ele(lambda1,lambda3,a1) - ele2=ele(lambda2,si4*lambda4,a2) - endif - eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.) - eloc5=elocal(ity5,lambda3,gamma4-pi-si4*lambda4,.false.) - pom=ele1*ele2*eloc2*eloc5 - if (si1.gt.0) then - eloc1=elocal(ity1,lambda5,gamma1-pi-lambda1,.false.) - endif - eloc3=elocal(ity3,lambda2,lambda6,.false.) - sum1=sum1+pom*eloc1*eloc3 - eloc4=elocal(ity4,lambda5,gamma3-pi-lambda3,.false.) - if (si4.gt.0) then - eloc6=elocal(ity6,lambda4,lambda6,.false.) - eloc61=elocal(ity6,lambda4,lambda5,.false.) - endif - sum2=sum2+pom*eloc4*eloc6 - eloc41=elocal(ity4,lambda6,gamma3-pi-lambda3,.false.) - sum3=sum3+pom*eloc1*eloc41 - sum4=sum4+pom*eloc1*eloc6 - sum5=sum5+pom*eloc3*eloc4 - sum6=sum6+pom*eloc3*eloc61 - enddo - enddo - enddo - enddo - enddo - enddo - pom=-1.0d0/(2*pi)**6*delta**6 - ene1=sum1*pom - ene2=sum2*pom - ene3=sum3*pom - ene4=sum4*pom - ene5=sum5*pom - ene6=sum6*pom -c print *,'sum6',sum6,' ene6',ene6 - return - end -c------------------------------------------------------------------------- - subroutine integral3a(gamma1,gamma2,ity1,ity2,a1,si1,ene1) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3, - & sum4,sum5,sum6,a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2 -cd write(2,*) ity1,ity2 -cd write(2,*) 'a1=',a1 -cd write(2,*) si1, - - sum1=0.0d0 - eloc1=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - ele1=ele(lambda1,si1*lambda3,a1) - eloc1=elocal(ity1,lambda1,gamma1-pi-lambda2,.false.) - if (si1.gt.0) then - eloc2=elocal(ity2,lambda2,gamma2-pi-lambda3,.false.) - else - eloc2=elocal(ity2,lambda2,lambda3,.false.) - endif - sum1=sum1+ele1*eloc1*eloc2 - enddo - enddo - enddo - pom=1.0d0/(2*pi)**3*delta**3 - ene1=sum1*pom - return - end -c------------------------------------------------------------------------- - subroutine integral4a(gamma1,gamma2,gamma3,ity1,ity2,ity3,a1,si1, - & ene1) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3, - & sum4,sum5,sum6,a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, -cd & ' gamma3=',gamma3 -cd write(2,*) ity1,ity2,ity3 -cd write(2,*) 'a1=',a1 -cd write(2,*) 'si1=',si1 - sum1=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - ele1=ele(lambda1,si1*lambda4,a1) - eloc1=elocal(ity1,lambda1,gamma1-pi-lambda2,.false.) - eloc2=elocal(ity2,lambda2,gamma2-pi-lambda3,.false.) - if (si1.gt.0) then - eloc3=elocal(ity3,lambda3,gamma3-pi-lambda4,.false.) - else - eloc3=elocal(ity3,lambda3,lambda4,.false.) - endif - sum1=sum1+ele1*eloc1*eloc2*eloc3 - enddo - enddo - enddo - enddo - pom=-1.0d0/(2*pi)**4*delta**4 - ene1=sum1*pom - return - end -c------------------------------------------------------------------------- - double precision function elocal(i,x,y,transp) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.TORSION' - integer i - double precision x,y,u(2),v(2),cu(2),dv(2),ev(2) - double precision scalar2 - logical transp - u(1)=dcos(x) - u(2)=dsin(x) - v(1)=dcos(y) - v(2)=dsin(y) - if (transp) then - call matvec2(cc(1,1,i),v,cu) - call matvec2(dd(1,1,i),u,dv) - call matvec2(ee(1,1,i),u,ev) - elocal=scalar2(b1(1,i),v)+scalar2(b2(1,i),u)+scalar2(cu,v)+ - & scalar2(dv,u)+scalar2(ev,v) - else - call matvec2(cc(1,1,i),u,cu) - call matvec2(dd(1,1,i),v,dv) - call matvec2(ee(1,1,i),v,ev) - elocal=scalar2(b1(1,i),u)+scalar2(b2(1,i),v)+scalar2(cu,u)+ - & scalar2(dv,v)+scalar2(ev,u) - endif - return - end -c------------------------------------------------------------------------- - double precision function ele(x,y,a) - implicit none - double precision x,y,a(2,2),si1,si2,u(2),v(2),av(2) - double precision scalar2 - u(1)=-cos(x) - u(2)= sin(x) - v(1)=-cos(y) - v(2)= sin(y) - call matvec2(a,v,av) - ele=scalar2(u,av) - return - end diff --git a/source/unres/src_MD-M-newcorr/kinetic_lesyng.f b/source/unres/src_MD-M-newcorr/kinetic_lesyng.f deleted file mode 100644 index db959b3..0000000 --- a/source/unres/src_MD-M-newcorr/kinetic_lesyng.f +++ /dev/null @@ -1,104 +0,0 @@ - subroutine kinetic(KE_total) -c---------------------------------------------------------------- -c This subroutine calculates the total kinetic energy of the chain -c----------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - double precision KE_total - - integer i,j,k - double precision KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3), - & mag1,mag2,v(3) - - KEt_p=0.0d0 - KEt_sc=0.0d0 -c write (iout,*) "ISC",(isc(itype(i)),i=1,nres) -c The translational part for peptide virtual bonds - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct-1 -c write (iout,*) "Kinetic trp:",i,(incr(j),j=1,3) - do j=1,3 - v(j)=incr(j)+0.5d0*d_t(j,i) - enddo - vtot(i)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) - KEt_p=KEt_p+(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - enddo -c write(iout,*) 'KEt_p', KEt_p -c The translational part for the side chain virtual bond -c Only now we can initialize incr with zeros. It must be equal -c to the velocities of the first Calpha. - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct - iti=iabs(itype(i)) - if (itype(i).eq.10) then - do j=1,3 - v(j)=incr(j) - enddo - else - do j=1,3 - v(j)=incr(j)+d_t(j,nres+i) - enddo - endif -c write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3) -c write (iout,*) "i",i," msc",msc(iti)," v",(v(j),j=1,3) - KEt_sc=KEt_sc+msc(iti)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) - vtot(i+nres)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - enddo -c goto 111 -c write(iout,*) 'KEt_sc', KEt_sc -c The part due to stretching and rotation of the peptide groups - KEr_p=0.0D0 - do i=nnt,nct-1 -c write (iout,*) "i",i -c write (iout,*) "i",i," mag1",mag1," mag2",mag2 - do j=1,3 - incr(j)=d_t(j,i) - enddo -c write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3) - KEr_p=KEr_p+(incr(1)*incr(1)+incr(2)*incr(2) - & +incr(3)*incr(3)) - enddo -c goto 111 -c write(iout,*) 'KEr_p', KEr_p -c The rotational part of the side chain virtual bond - KEr_sc=0.0D0 - do i=nnt,nct - iti=iabs(itype(i)) - if (itype(i).ne.10) then - do j=1,3 - incr(j)=d_t(j,nres+i) - enddo -c write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3) - KEr_sc=KEr_sc+Isc(iti)*(incr(1)*incr(1)+incr(2)*incr(2)+ - & incr(3)*incr(3)) - endif - enddo -c The total kinetic energy - 111 continue -c write(iout,*) 'KEr_sc', KEr_sc - KE_total=0.5d0*(mp*KEt_p+KEt_sc+0.25d0*Ip*KEr_p+KEr_sc) -c write (iout,*) "KE_total",KE_total - return - end - - - - diff --git a/source/unres/src_MD-M-newcorr/lagrangian_lesyng.F b/source/unres/src_MD-M-newcorr/lagrangian_lesyng.F deleted file mode 100644 index f8834ea..0000000 --- a/source/unres/src_MD-M-newcorr/lagrangian_lesyng.F +++ /dev/null @@ -1,703 +0,0 @@ - subroutine lagrangian -c------------------------------------------------------------------------- -c This subroutine contains the total lagrangain from which the accelerations -c are obtained. For numerical gradient checking, the derivetive of the -c lagrangian in the velocities and coordinates are calculated seperately -c------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'COMMON.MUCA' - include 'COMMON.TIME1' - - integer i,j,ind - double precision zapas(MAXRES6),muca_factor - logical lprn /.false./ - common /cipiszcze/ itime - -#ifdef TIMING - time00=MPI_Wtime() -#endif - do j=1,3 - zapas(j)=-gcart(j,0) - enddo - ind=3 - if (lprn) then - write (iout,*) "Potential forces backbone" - endif - do i=nnt,nct-1 - if (lprn) write (iout,'(i5,3e15.5,5x,3e15.5)') - & i,(-gcart(j,i),j=1,3) - do j=1,3 - ind=ind+1 - zapas(ind)=-gcart(j,i) - enddo - enddo - if (lprn) write (iout,*) "Potential forces sidechain" - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - if (lprn) write (iout,'(i5,3e15.5,5x,3e15.5)') - & i,(-gcart(j,i),j=1,3) - do j=1,3 - ind=ind+1 - zapas(ind)=-gxcart(j,i) - enddo - endif - enddo - - call ginv_mult(zapas,d_a_work) - - do j=1,3 - d_a(j,0)=d_a_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - d_a(j,i)=d_a_work(ind) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - ind=ind+1 - d_a(j,i+nres)=d_a_work(ind) - enddo - endif - enddo - - if(lmuca) then - imtime=imtime+1 - if(mucadyn.gt.0) call muca_update(potE) - factor=muca_factor(potE)*t_bath*Rb - -cd print *,'lmuca ',factor,potE - do j=1,3 - d_a(j,0)=d_a(j,0)*factor - enddo - do i=nnt,nct-1 - do j=1,3 - d_a(j,i)=d_a(j,i)*factor - enddo - enddo - do i=nnt,nct - do j=1,3 - d_a(j,i+nres)=d_a(j,i+nres)*factor - enddo - enddo - - endif - - if (lprn) then - write(iout,*) 'acceleration 3D' - write (iout,'(i3,3f10.5,3x,3f10.5)') 0,(d_a(j,0),j=1,3) - do i=nnt,nct-1 - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3) - enddo - do i=nnt,nct - write (iout,'(i3,3f10.5,3x,3f10.5)') - & i+nres,(d_a(j,i+nres),j=1,3) - enddo - endif -#ifdef TIMING - time_lagrangian=time_lagrangian+MPI_Wtime()-time00 -#endif - return - end -c------------------------------------------------------------------ - subroutine setup_MD_matrices - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer ierror -#endif - include 'COMMON.SETUP' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - integer i,j - logical lprn /.false./ - logical osob - double precision dtdi,massvec(maxres2),Gcopy(maxres2,maxres2), - & Ghalf(mmaxres2),sqreig(maxres2) - double precision work(8*maxres6) - integer iwork(maxres6) - common /przechowalnia/ Gcopy,Ghalf -c -c Set up the matrix of the (dC,dX)-->(C,X) transformation (A), the -c inertia matrix (Gmat) and the inverse of the inertia matrix (Ginv) -c -c Determine the number of degrees of freedom (dimen) and the number of -c sites (dimen1) - dimen=(nct-nnt+1)+nside - dimen1=(nct-nnt)+(nct-nnt+1) - dimen3=dimen*3 -#ifdef MPI - if (nfgtasks.gt.1) then - time00=MPI_Wtime() - call MPI_Bcast(5,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 - call int_bounds(dimen,igmult_start,igmult_end) - igmult_start=igmult_start-1 - call MPI_Allgather(3*igmult_start,1,MPI_INTEGER, - & ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - my_ng_count=igmult_end-igmult_start - call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - write (iout,*) 'Processor:',fg_rank,' CG group',kolor, - & ' absolute rank',myrank,' igmult_start',igmult_start, - & ' igmult_end',igmult_end,' count',my_ng_count - write (iout,*) "ng_start",(ng_start(i),i=0,nfgtasks-1) - write (iout,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1) - call flush(iout) - else -#endif - igmult_start=1 - igmult_end=dimen - my_ng_count=dimen -#ifdef MPI - endif -#endif -c write (iout,*) "dimen",dimen," dimen1",dimen1," dimen3",dimen3 -c Zeroing out A and fricmat - do i=1,dimen - do j=1,dimen - A(i,j)=0.0D0 - enddo - enddo -c Diagonal elements of the dC part of A and the respective friction coefficients - ind=1 - ind1=0 - do i=nnt,nct-1 - ind=ind+1 - ind1=ind1+1 - coeff=0.25d0*IP - massvec(ind1)=mp - Gmat(ind,ind)=coeff - A(ind1,ind)=0.5d0 - enddo - -c Off-diagonal elements of the dC part of A - k=3 - do i=1,nct-nnt - do j=1,i - A(i,j)=1.0d0 - enddo - enddo -c Diagonal elements of the dX part of A and the respective friction coefficients - m=nct-nnt - m1=nct-nnt+1 - ind=0 - ind1=0 - msc(ntyp1)=1.0d0 - do i=nnt,nct - ind=ind+1 - ii = ind+m - iti=itype(i) - massvec(ii)=msc(iabs(iti)) - if (iti.ne.10 .and. iti.ne.ntyp1) then - ind1=ind1+1 - ii1= ind1+m1 - A(ii,ii1)=1.0d0 - Gmat(ii1,ii1)=ISC(iabs(iti)) - endif - enddo -c Off-diagonal elements of the dX part of A - ind=0 - k=nct-nnt - do i=nnt,nct - iti=itype(i) - ind=ind+1 - do j=nnt,i - ii = ind - jj = j-nnt+1 - A(k+ii,jj)=1.0d0 - enddo - enddo - if (lprn) then - write (iout,*) - write (iout,*) "Vector massvec" - do i=1,dimen1 - write (iout,*) i,massvec(i) - enddo - write (iout,'(//a)') "A" - call matout(dimen,dimen1,maxres2,maxres2,A) - endif - -c Calculate the G matrix (store in Gmat) - do k=1,dimen - do i=1,dimen - dtdi=0.0d0 - do j=1,dimen1 - dtdi=dtdi+A(j,k)*A(j,i)*massvec(j) - enddo - Gmat(k,i)=Gmat(k,i)+dtdi - enddo - enddo - - if (lprn) then - write (iout,'(//a)') "Gmat" - call matout(dimen,dimen,maxres2,maxres2,Gmat) - endif - do i=1,dimen - do j=1,dimen - Ginv(i,j)=0.0d0 - Gcopy(i,j)=Gmat(i,j) - enddo - Ginv(i,i)=1.0d0 - enddo -c Invert the G matrix - call MATINVERT(dimen,maxres2,Gcopy,Ginv,osob) - if (lprn) then - write (iout,'(//a)') "Ginv" - call matout(dimen,dimen,maxres2,maxres2,Ginv) - endif -#ifdef MPI - if (nfgtasks.gt.1) then - myginv_ng_count=maxres2*my_ng_count - call MPI_Allgather(maxres2*igmult_start,1,MPI_INTEGER, - & nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER, - & nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR) - write (iout,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1) - write (iout,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1) - call flush(iout) -c call MPI_Scatterv(ginv(1,1),nginv_counts(0), -c & nginv_start(0),MPI_DOUBLE_PRECISION,ginv, -c & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -c call MPI_Barrier(FG_COMM,IERR) - time00=MPI_Wtime() - call MPI_Scatterv(ginv(1,1),nginv_counts(0), - & nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1), - & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -#ifdef TIMING - time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00 -#endif - do i=1,dimen - do j=1,2*my_ng_count - ginv(j,i)=gcopy(i,j) - enddo - enddo -c write (iout,*) "Master's chunk of ginv" -c call MATOUT2(my_ng_count,dimen,maxres2,maxres2,ginv) - endif -#endif - if (osob) then - write (iout,*) "The G matrix is singular." - stop - endif -c Compute G**(-1/2) and G**(1/2) - ind=0 - do i=1,dimen - do j=1,i - ind=ind+1 - Ghalf(ind)=Gmat(i,j) - enddo - enddo - call gldiag(maxres2,dimen,dimen,Ghalf,work,Geigen,Gvec, - & ierr,iwork) - if (lprn) then - write (iout,'(//a)') - & "Eigenvectors and eigenvalues of the G matrix" - call eigout(dimen,dimen,maxres2,maxres2,Gvec,Geigen) - endif - do i=1,dimen - sqreig(i)=dsqrt(Geigen(i)) - enddo - do i=1,dimen - do j=1,dimen - Gsqrp(i,j)=0.0d0 - Gsqrm(i,j)=0.0d0 - Gcopy(i,j)=0.0d0 - do k=1,dimen - Gsqrp(i,j)=Gsqrp(i,j)+Gvec(i,k)*Gvec(j,k)*sqreig(k) - Gsqrm(i,j)=Gsqrm(i,j)+Gvec(i,k)*Gvec(j,k)/sqreig(k) - Gcopy(i,j)=Gcopy(i,j)+Gvec(i,k)*Gvec(j,k)*Geigen(k) - enddo - enddo - enddo - if (lprn) then - write (iout,*) "Comparison of original and restored G" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,5f10.5)') i,j,Gmat(i,j),Gcopy(i,j), - & Gmat(i,j)-Gcopy(i,j),Gsqrp(i,j),Gsqrm(i,j) - enddo - enddo - endif - return - end -c------------------------------------------------------------------------------- - SUBROUTINE EIGOUT(NC,NR,LM2,LM3,A,B) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - double precision A(LM2,LM3),B(LM2) - KA=1 - KC=6 - 1 KB=MIN0(KC,NC) - WRITE(IOUT,600) (I,I=KA,KB) - WRITE(IOUT,601) (B(I),I=KA,KB) - WRITE(IOUT,602) - 2 N=0 - DO 3 I=1,NR - WRITE(IOUT,603) I,(A(I,J),J=KA,KB) - N=N+1 - IF(N.LT.10) GO TO 3 - WRITE(IOUT,602) - N=0 - 3 CONTINUE - 4 IF (KB.EQ.NC) RETURN - KA=KC+1 - KC=KC+6 - GO TO 1 - 600 FORMAT (// 9H ROOT NO.,I4,9I11) - 601 FORMAT (/5X,10(1PE11.4)) - 602 FORMAT (2H ) - 603 FORMAT (I5,10F11.5) - 604 FORMAT (1H1) - END -c------------------------------------------------------------------------------- - SUBROUTINE MATOUT(NC,NR,LM2,LM3,A) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - double precision A(LM2,LM3) - KA=1 - KC=6 - 1 KB=MIN0(KC,NC) - WRITE(IOUT,600) (I,I=KA,KB) - WRITE(IOUT,602) - 2 N=0 - DO 3 I=1,NR - WRITE(IOUT,603) I,(A(I,J),J=KA,KB) - N=N+1 - IF(N.LT.10) GO TO 3 - WRITE(IOUT,602) - N=0 - 3 CONTINUE - 4 IF (KB.EQ.NC) RETURN - KA=KC+1 - KC=KC+6 - GO TO 1 - 600 FORMAT (//5x,9I11) - 602 FORMAT (2H ) - 603 FORMAT (I5,10F11.3) - 604 FORMAT (1H1) - END -c------------------------------------------------------------------------------- - SUBROUTINE MATOUT1(NC,NR,LM2,LM3,A) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - double precision A(LM2,LM3) - KA=1 - KC=21 - 1 KB=MIN0(KC,NC) - WRITE(IOUT,600) (I,I=KA,KB) - WRITE(IOUT,602) - 2 N=0 - DO 3 I=1,NR - WRITE(IOUT,603) I,(A(I,J),J=KA,KB) - N=N+1 - IF(N.LT.3) GO TO 3 - WRITE(IOUT,602) - N=0 - 3 CONTINUE - 4 IF (KB.EQ.NC) RETURN - KA=KC+1 - KC=KC+21 - GO TO 1 - 600 FORMAT (//5x,7(3I5,2x)) - 602 FORMAT (2H ) - 603 FORMAT (I5,7(3F5.1,2x)) - 604 FORMAT (1H1) - END -c------------------------------------------------------------------------------- - SUBROUTINE MATOUT2(NC,NR,LM2,LM3,A) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - double precision A(LM2,LM3) - KA=1 - KC=12 - 1 KB=MIN0(KC,NC) - WRITE(IOUT,600) (I,I=KA,KB) - WRITE(IOUT,602) - 2 N=0 - DO 3 I=1,NR - WRITE(IOUT,603) I,(A(I,J),J=KA,KB) - N=N+1 - IF(N.LT.3) GO TO 3 - WRITE(IOUT,602) - N=0 - 3 CONTINUE - 4 IF (KB.EQ.NC) RETURN - KA=KC+1 - KC=KC+12 - GO TO 1 - 600 FORMAT (//5x,4(3I9,2x)) - 602 FORMAT (2H ) - 603 FORMAT (I5,4(3F9.3,2x)) - 604 FORMAT (1H1) - END -c--------------------------------------------------------------------------- - SUBROUTINE ginv_mult(z,d_a_tmp) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer ierr -#endif - include 'COMMON.SETUP' - include 'COMMON.TIME1' - include 'COMMON.MD' - double precision z(dimen3),d_a_tmp(dimen3),temp(maxres6),time00 - &time01 -#ifdef MPI - if (nfgtasks.gt.1) then - if (fg_rank.eq.0) then -c The matching BROADCAST for fg processors is called in ERGASTULUM - time00=MPI_Wtime() - call MPI_Bcast(4,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -c print *,"Processor",myrank," BROADCAST iorder in GINV_MULT" - endif -c write (2,*) "time00",time00 -c write (2,*) "Before Scatterv" -c call flush(2) -c write (2,*) "Whole z (for FG master)" -c do i=1,dimen -c write (2,*) i,z(i) -c enddo -c call MPI_Barrier(FG_COMM,IERROR) - time00=MPI_Wtime() - call MPI_Scatterv(z,ng_counts(0),ng_start(0), - & MPI_DOUBLE_PRECISION, - & z,3*my_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -c write (2,*) "My chunk of z" -c do i=1,3*my_ng_count -c write (2,*) i,z(i) -c enddo -c write (2,*) "After SCATTERV" -c call flush(2) -c write (2,*) "MPI_Wtime",MPI_Wtime() - time_scatter=time_scatter+MPI_Wtime()-time00 -#ifdef TIMING - time_scatter_ginvmult=time_scatter_ginvmult+MPI_Wtime()-time00 -#endif -c write (2,*) "time_scatter",time_scatter -c write (2,*) "dimen",dimen," dimen3",dimen3," my_ng_count", -c & my_ng_count -c call flush(2) - time01=MPI_Wtime() - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - temp(ind)=0.0d0 - do j=1,my_ng_count -c write (2,*) "k,i,j,ind",k,i,j,ind,(j-1)*3+k+1, -c & Ginv(i,j),z((j-1)*3+k+1), -c & Ginv(i,j)*z((j-1)*3+k+1) -c temp(ind)=temp(ind)+Ginv(i,j)*z((j-1)*3+k+1) - temp(ind)=temp(ind)+Ginv(j,i)*z((j-1)*3+k+1) - enddo - enddo - enddo - time_ginvmult=time_ginvmult+MPI_Wtime()-time01 -c write (2,*) "Before REDUCE" -c call flush(2) -c write (2,*) "z before reduce" -c do i=1,dimen -c write (2,*) i,temp(i) -c enddo - time00=MPI_Wtime() - call MPI_Reduce(temp(1),d_a_tmp(1),dimen3,MPI_DOUBLE_PRECISION, - & MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -c write (2,*) "After REDUCE" -c call flush(2) - else -#endif -#ifdef TIMING - time01=MPI_Wtime() -#endif - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - d_a_tmp(ind)=0.0d0 - do j=1,dimen -c write (2,*) "k,i,j,ind",k,i,j,ind,(j-1)*3+k+1 -c call flush(2) -c & Ginv(i,j),z((j-1)*3+k+1), -c & Ginv(i,j)*z((j-1)*3+k+1) - d_a_tmp(ind)=d_a_tmp(ind) - & +Ginv(j,i)*z((j-1)*3+k+1) -c d_a_tmp(ind)=d_a_tmp(ind) -c & +Ginv(i,j)*z((j-1)*3+k+1) - enddo - enddo - enddo -#ifdef TIMING - time_ginvmult=time_ginvmult+MPI_Wtime()-time01 -#endif -#ifdef MPI - endif -#endif - return - end -c--------------------------------------------------------------------------- -#ifdef GINV_MULT - SUBROUTINE ginv_mult_test(z,d_a_tmp) - include 'DIMENSIONS' - integer dimen -c include 'COMMON.MD' - double precision z(dimen),d_a_tmp(dimen) - double precision ztmp(dimen/3),dtmp(dimen/3) - -c do i=1,dimen -c d_a_tmp(i)=0.0d0 -c do j=1,dimen -c d_a_tmp(i)=d_a_tmp(i)+Ginv(i,j)*z(j) -c enddo -c enddo -c -c return - -!ibm* unroll(3) - do k=0,2 - do j=1,dimen/3 - ztmp(j)=z((j-1)*3+k+1) - enddo - - call alignx(16,ztmp(1)) - call alignx(16,dtmp(1)) - call alignx(16,Ginv(1,1)) - - do i=1,dimen/3 - dtmp(i)=0.0d0 - do j=1,dimen/3 - dtmp(i)=dtmp(i)+Ginv(i,j)*ztmp(j) - enddo - enddo - do i=1,dimen/3 - ind=(i-1)*3+k+1 - d_a_tmp(ind)=dtmp(i) - enddo - enddo - return - end -#endif -c--------------------------------------------------------------------------- - SUBROUTINE fricmat_mult(z,d_a_tmp) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer IERROR -#endif - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.SETUP' - include 'COMMON.TIME1' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - double precision z(dimen3),d_a_tmp(dimen3),temp(maxres6),time00 - &time01 -#ifdef MPI - if (nfgtasks.gt.1) then - if (fg_rank.eq.0) then -c The matching BROADCAST for fg processors is called in ERGASTULUM - time00=MPI_Wtime() - call MPI_Bcast(9,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -c print *,"Processor",myrank," BROADCAST iorder in FRICMAT_MULT" - endif -c call MPI_Barrier(FG_COMM,IERROR) - time00=MPI_Wtime() - call MPI_Scatterv(z,ng_counts(0),ng_start(0), - & MPI_DOUBLE_PRECISION, - & z,3*my_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -c write (2,*) "My chunk of z" -c do i=1,3*my_ng_count -c write (2,*) i,z(i) -c enddo - time_scatter=time_scatter+MPI_Wtime()-time00 -#ifdef TIMING - time_scatter_fmatmult=time_scatter_fmatmult+MPI_Wtime()-time00 -#endif - time01=MPI_Wtime() - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - temp(ind)=0.0d0 - do j=1,my_ng_count - temp(ind)=temp(ind)-fricmat(j,i)*z((j-1)*3+k+1) - enddo - enddo - enddo - time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01 -c write (2,*) "Before REDUCE" -c write (2,*) "d_a_tmp before reduce" -c do i=1,dimen3 -c write (2,*) i,temp(i) -c enddo -c call flush(2) - time00=MPI_Wtime() - call MPI_Reduce(temp(1),d_a_tmp(1),dimen3,MPI_DOUBLE_PRECISION, - & MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -c write (2,*) "After REDUCE" -c call flush(2) - else -#endif -#ifdef TIMING - time01=MPI_Wtime() -#endif - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - d_a_tmp(ind)=0.0d0 - do j=1,dimen - d_a_tmp(ind)=d_a_tmp(ind) - & -fricmat(j,i)*z((j-1)*3+k+1) - enddo - enddo - enddo -#ifdef TIMING - time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01 -#endif -#ifdef MPI - endif -#endif -c write (iout,*) "Vector d_a" -c do i=1,dimen3 -c write (2,*) i,d_a_tmp(i) -c enddo - return - end diff --git a/source/unres/src_MD-M-newcorr/local_move.f b/source/unres/src_MD-M-newcorr/local_move.f deleted file mode 100644 index 763d3cc..0000000 --- a/source/unres/src_MD-M-newcorr/local_move.f +++ /dev/null @@ -1,972 +0,0 @@ -c------------------------------------------------------------- - - subroutine local_move_init(debug) -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' ! Needed by COMMON.LOCAL - include 'COMMON.GEO' ! For pi, deg2rad - include 'COMMON.LOCAL' ! For vbl - include 'COMMON.LOCMOVE' - -c INPUT arguments - logical debug - - -c Determine wheter to do some debugging output - locmove_output=debug - -c Set the init_called flag to 1 - init_called=1 - -c The following are never changed - min_theta=60.D0*deg2rad ! (0,PI) - max_theta=175.D0*deg2rad ! (0,PI) - dmin2=vbl*vbl*2.*(1.-cos(min_theta)) - dmax2=vbl*vbl*2.*(1.-cos(max_theta)) - flag=1.0D300 - small=1.0D-5 - small2=0.5*small*small - -c Not really necessary... - a_n=0 - b_n=0 - res_n=0 - - return - end - -c------------------------------------------------------------- - - subroutine local_move(n_start, n_end, PHImin, PHImax) -c Perform a local move between residues m and n (inclusive) -c PHImin and PHImax [0,PI] determine the size of the move -c Works on whatever structure is in the variables theta and phi, -c sidechain variables are left untouched -c The final structure is NOT minimized, but both the cartesian -c variables c and the angles are up-to-date at the end (no further -c chainbuild is required) -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.MINIM' - include 'COMMON.SBRIDGE' - include 'COMMON.LOCMOVE' - -c External functions - integer move_res - external move_res - double precision ran_number - external ran_number - -c INPUT arguments - integer n_start, n_end ! First and last residues to move - double precision PHImin, PHImax ! min/max angles [0,PI] - -c Local variables - integer i,j - double precision min,max - integer iretcode - - -c Check if local_move_init was called. This assumes that it -c would not be 1 if not explicitely initialized - if (init_called.ne.1) then - write(6,*)' *** local_move_init not called!!!' - stop - endif - -c Quick check for crazy range - if (n_start.gt.n_end .or. n_start.lt.1 .or. n_end.gt.nres) then - write(6,'(a,i3,a,i3)') - + ' *** Cannot make local move between n_start = ', - + n_start,' and n_end = ',n_end - return - endif - -c Take care of end residues first... - if (n_start.eq.1) then -c Move residue 1 (completely random) - theta(3)=ran_number(min_theta,max_theta) - phi(4)=ran_number(-PI,PI) - i=2 - else - i=n_start - endif - if (n_end.eq.nres) then -c Move residue nres (completely random) - theta(nres)=ran_number(min_theta,max_theta) - phi(nres)=ran_number(-PI,PI) - j=nres-1 - else - j=n_end - endif - -c ...then go through all other residues one by one -c Start from the two extremes and converge - call chainbuild - do while (i.le.j) - min=PHImin - max=PHImax -c$$$c Move the first two residues by less than the others -c$$$ if (i-n_start.lt.3) then -c$$$ if (i-n_start.eq.0) then -c$$$ min=0.4*PHImin -c$$$ max=0.4*PHImax -c$$$ else if (i-n_start.eq.1) then -c$$$ min=0.8*PHImin -c$$$ max=0.8*PHImax -c$$$ else if (i-n_start.eq.2) then -c$$$ min=PHImin -c$$$ max=PHImax -c$$$ endif -c$$$ endif - -c The actual move, on residue i - iretcode=move_res(min,max,i) ! Discard iretcode - i=i+1 - - if (i.le.j) then - min=PHImin - max=PHImax -c$$$c Move the last two residues by less than the others -c$$$ if (n_end-j.lt.3) then -c$$$ if (n_end-j.eq.0) then -c$$$ min=0.4*PHImin -c$$$ max=0.4*PHImax -c$$$ else if (n_end-j.eq.1) then -c$$$ min=0.8*PHImin -c$$$ max=0.8*PHImax -c$$$ else if (n_end-j.eq.2) then -c$$$ min=PHImin -c$$$ max=PHImax -c$$$ endif -c$$$ endif - -c The actual move, on residue j - iretcode=move_res(min,max,j) ! Discard iretcode - j=j-1 - endif - enddo - - call int_from_cart(.false.,.false.) - - return - end - -c------------------------------------------------------------- - - subroutine output_tabs -c Prints out the contents of a_..., b_..., res_... - implicit none - -c Includes - include 'COMMON.GEO' - include 'COMMON.LOCMOVE' - -c Local variables - integer i,j - - - write(6,*)'a_...' - write(6,'(8f7.1)')(a_ang(i)*rad2deg,i=0,a_n-1) - write(6,'(8(2x,3l1,2x))')((a_tab(i,j),i=0,2),j=0,a_n-1) - - write(6,*)'b_...' - write(6,'(4f7.1)')(b_ang(i)*rad2deg,i=0,b_n-1) - write(6,'(4(2x,3l1,2x))')((b_tab(i,j),i=0,2),j=0,b_n-1) - - write(6,*)'res_...' - write(6,'(12f7.1)')(res_ang(i)*rad2deg,i=0,res_n-1) - write(6,'(12(2x,3l1,2x))')((res_tab(0,i,j),i=0,2),j=0,res_n-1) - write(6,'(12(2x,3l1,2x))')((res_tab(1,i,j),i=0,2),j=0,res_n-1) - write(6,'(12(2x,3l1,2x))')((res_tab(2,i,j),i=0,2),j=0,res_n-1) - - return - end - -c------------------------------------------------------------- - - subroutine angles2tab(PHImin,PHImax,n,ang,tab) -c Only uses angles if [0,PI] (but PHImin cannot be 0., -c and PHImax cannot be PI) - implicit none - -c Includes - include 'COMMON.GEO' - -c INPUT arguments - double precision PHImin,PHImax - -c OUTPUT arguments - integer n - double precision ang(0:3) - logical tab(0:2,0:3) - - - if (PHImin .eq. PHImax) then -c Special case with two 010's - n = 2; - ang(0) = -PHImin; - ang(1) = PHImin; - tab(0,0) = .false. - tab(2,0) = .false. - tab(0,1) = .false. - tab(2,1) = .false. - tab(1,0) = .true. - tab(1,1) = .true. - else if (PHImin .eq. PI) then -c Special case with one 010 - n = 1 - ang(0) = PI - tab(0,0) = .false. - tab(2,0) = .false. - tab(1,0) = .true. - else if (PHImax .eq. 0.) then -c Special case with one 010 - n = 1 - ang(0) = 0. - tab(0,0) = .false. - tab(2,0) = .false. - tab(1,0) = .true. - else -c Standard cases - n = 0 - if (PHImin .gt. 0.) then -c Start of range (011) - ang(n) = PHImin - tab(0,n) = .false. - tab(1,n) = .true. - tab(2,n) = .true. -c End of range (110) - ang(n+1) = -PHImin - tab(0,n+1) = .true. - tab(1,n+1) = .true. - tab(2,n+1) = .false. - n = n+2 - endif - if (PHImax .lt. PI) then -c Start of range (011) - ang(n) = -PHImax - tab(0,n) = .false. - tab(1,n) = .true. - tab(2,n) = .true. -c End of range (110) - ang(n+1) = PHImax - tab(0,n+1) = .true. - tab(1,n+1) = .true. - tab(2,n+1) = .false. - n = n+2 - endif - endif - - return - end - -c------------------------------------------------------------- - - subroutine minmax_angles(x,y,z,r,n,ang,tab) -c When solutions do not exist, assume all angles -c are acceptable - i.e., initial geometry must be correct - implicit none - -c Includes - include 'COMMON.GEO' - include 'COMMON.LOCMOVE' - -c Input arguments - double precision x,y,z,r - -c Output arguments - integer n - double precision ang(0:3) - logical tab(0:2,0:3) - -c Local variables - double precision num, denom, phi - double precision Kmin, Kmax - integer i - - - num = x*x + y*y + z*z - denom = x*x + y*y - n = 0 - if (denom .gt. 0.) then - phi = atan2(y,x) - denom = 2.*r*sqrt(denom) - num = num+r*r - Kmin = (num - dmin2)/denom - Kmax = (num - dmax2)/denom - -c Allowed values of K (else all angles are acceptable) -c -1 <= Kmin < 1 -c -1 < Kmax <= 1 - if (Kmin .gt. 1. .or. abs(Kmin-1.) .lt. small2) then - Kmin = -flag - else if (Kmin .lt. -1. .or. abs(Kmin+1.) .lt. small2) then - Kmin = PI - else - Kmin = acos(Kmin) - endif - - if (Kmax .lt. -1. .or. abs(Kmax+1.) .lt. small2) then - Kmax = flag - else if (Kmax .gt. 1. .or. abs(Kmax-1.) .lt. small2) then - Kmax = 0. - else - Kmax = acos(Kmax) - endif - - if (Kmax .lt. Kmin) Kmax = Kmin - - call angles2tab(Kmin, Kmax, n, ang, tab) - -c Add phi and check that angles are within range (-PI,PI] - do i=0,n-1 - ang(i) = ang(i)+phi - if (ang(i) .le. -PI) then - ang(i) = ang(i)+2.*PI - else if (ang(i) .gt. PI) then - ang(i) = ang(i)-2.*PI - endif - enddo - endif - - return - end - -c------------------------------------------------------------- - - subroutine construct_tab -c Take a_... and b_... values and produces the results res_... -c x_ang are assumed to be all different (diff > small) -c x_tab(1,i) must be 1 for all i (i.e., all x_ang are acceptable) - implicit none - -c Includes - include 'COMMON.LOCMOVE' - -c Local variables - integer n_max,i,j,index - logical done - double precision phi - - - n_max = a_n + b_n - if (n_max .eq. 0) then - res_n = 0 - return - endif - - do i=0,n_max-1 - do j=0,1 - res_tab(j,0,i) = .true. - res_tab(j,2,i) = .true. - res_tab(j,1,i) = .false. - enddo - enddo - - index = 0 - phi = -flag - done = .false. - do while (.not.done) - res_ang(index) = flag - -c Check a first... - do i=0,a_n-1 - if ((a_ang(i)-phi).gt.small .and. - + a_ang(i) .lt. res_ang(index)) then -c Found a lower angle - res_ang(index) = a_ang(i) -c Copy the values from a_tab into res_tab(0,,) - res_tab(0,0,index) = a_tab(0,i) - res_tab(0,1,index) = a_tab(1,i) - res_tab(0,2,index) = a_tab(2,i) -c Set default values for res_tab(1,,) - res_tab(1,0,index) = .true. - res_tab(1,1,index) = .false. - res_tab(1,2,index) = .true. - else if (abs(a_ang(i)-res_ang(index)).lt.small) then -c Found an equal angle (can only be equal to a b_ang) - res_tab(0,0,index) = a_tab(0,i) - res_tab(0,1,index) = a_tab(1,i) - res_tab(0,2,index) = a_tab(2,i) - endif - enddo -c ...then check b - do i=0,b_n-1 - if ((b_ang(i)-phi).gt.small .and. - + b_ang(i) .lt. res_ang(index)) then -c Found a lower angle - res_ang(index) = b_ang(i) -c Copy the values from b_tab into res_tab(1,,) - res_tab(1,0,index) = b_tab(0,i) - res_tab(1,1,index) = b_tab(1,i) - res_tab(1,2,index) = b_tab(2,i) -c Set default values for res_tab(0,,) - res_tab(0,0,index) = .true. - res_tab(0,1,index) = .false. - res_tab(0,2,index) = .true. - else if (abs(b_ang(i)-res_ang(index)).lt.small) then -c Found an equal angle (can only be equal to an a_ang) - res_tab(1,0,index) = b_tab(0,i) - res_tab(1,1,index) = b_tab(1,i) - res_tab(1,2,index) = b_tab(2,i) - endif - enddo - - if (res_ang(index) .eq. flag) then - res_n = index - done = .true. - else if (index .eq. n_max-1) then - res_n = n_max - done = .true. - else - phi = res_ang(index) ! Store previous angle - index = index+1 - endif - enddo - -c Fill the gaps -c First a... - index = 0 - if (a_n .gt. 0) then - do while (.not.res_tab(0,1,index)) - index=index+1 - enddo - done = res_tab(0,2,index) - do i=index+1,res_n-1 - if (res_tab(0,1,i)) then - done = res_tab(0,2,i) - else - res_tab(0,0,i) = done - res_tab(0,1,i) = done - res_tab(0,2,i) = done - endif - enddo - done = res_tab(0,0,index) - do i=index-1,0,-1 - if (res_tab(0,1,i)) then - done = res_tab(0,0,i) - else - res_tab(0,0,i) = done - res_tab(0,1,i) = done - res_tab(0,2,i) = done - endif - enddo - else - do i=0,res_n-1 - res_tab(0,0,i) = .true. - res_tab(0,1,i) = .true. - res_tab(0,2,i) = .true. - enddo - endif -c ...then b - index = 0 - if (b_n .gt. 0) then - do while (.not.res_tab(1,1,index)) - index=index+1 - enddo - done = res_tab(1,2,index) - do i=index+1,res_n-1 - if (res_tab(1,1,i)) then - done = res_tab(1,2,i) - else - res_tab(1,0,i) = done - res_tab(1,1,i) = done - res_tab(1,2,i) = done - endif - enddo - done = res_tab(1,0,index) - do i=index-1,0,-1 - if (res_tab(1,1,i)) then - done = res_tab(1,0,i) - else - res_tab(1,0,i) = done - res_tab(1,1,i) = done - res_tab(1,2,i) = done - endif - enddo - else - do i=0,res_n-1 - res_tab(1,0,i) = .true. - res_tab(1,1,i) = .true. - res_tab(1,2,i) = .true. - enddo - endif - -c Finally fill the last row with AND operation - do i=0,res_n-1 - do j=0,2 - res_tab(2,j,i) = (res_tab(0,j,i) .and. res_tab(1,j,i)) - enddo - enddo - - return - end - -c------------------------------------------------------------- - - subroutine construct_ranges(phi_n,phi_start,phi_end) -c Given the data in res_..., construct a table of -c min/max allowed angles - implicit none - -c Includes - include 'COMMON.GEO' - include 'COMMON.LOCMOVE' - -c Output arguments - integer phi_n - double precision phi_start(0:11),phi_end(0:11) - -c Local variables - logical done - integer index - - - if (res_n .eq. 0) then -c Any move is allowed - phi_n = 1 - phi_start(0) = -PI - phi_end(0) = PI - else - phi_n = 0 - index = 0 - done = .false. - do while (.not.done) -c Find start of range (01x) - done = .false. - do while (.not.done) - if (res_tab(2,0,index).or.(.not.res_tab(2,1,index))) then - index=index+1 - else - done = .true. - phi_start(phi_n) = res_ang(index) - endif - if (index .eq. res_n) done = .true. - enddo -c If a start was found (index < res_n), find the end of range (x10) -c It may not be found without wrapping around - if (index .lt. res_n) then - done = .false. - do while (.not.done) - if ((.not.res_tab(2,1,index)).or.res_tab(2,2,index)) then - index=index+1 - else - done = .true. - endif - if (index .eq. res_n) done = .true. - enddo - if (index .lt. res_n) then -c Found the end of the range - phi_end(phi_n) = res_ang(index) - phi_n=phi_n+1 - index=index+1 - if (index .eq. res_n) then - done = .true. - else - done = .false. - endif - else -c Need to wrap around - done = .true. - phi_end(phi_n) = flag - endif - endif - enddo -c Take care of the last one if need to wrap around - if (phi_end(phi_n) .eq. flag) then - index = 0 - do while ((.not.res_tab(2,1,index)).or.res_tab(2,2,index)) - index=index+1 - enddo - phi_end(phi_n) = res_ang(index) + 2.*PI - phi_n=phi_n+1 - endif - endif - - return - end - -c------------------------------------------------------------- - - subroutine fix_no_moves(phi) - implicit none - -c Includes - include 'COMMON.GEO' - include 'COMMON.LOCMOVE' - -c Output arguments - double precision phi - -c Local variables - integer index - double precision diff,temp - - -c Look for first 01x in gammas (there MUST be at least one) - diff = flag - index = 0 - do while (res_tab(1,0,index) .or. (.not.res_tab(1,1,index))) - index=index+1 - enddo - if (res_ang(index) .le. 0.D0) then ! Make sure it's from PHImax -c Try to increase PHImax - if (index .gt. 0) then - phi = res_ang(index-1) - diff = abs(res_ang(index) - res_ang(index-1)) - endif -c Look for last (corresponding) x10 - index = res_n - 1 - do while ((.not.res_tab(1,1,index)) .or. res_tab(1,2,index)) - index=index-1 - enddo - if (index .lt. res_n-1) then - temp = abs(res_ang(index) - res_ang(index+1)) - if (temp .lt. diff) then - phi = res_ang(index+1) - diff = temp - endif - endif - endif - -c If increasing PHImax didn't work, decreasing PHImin -c will (with one exception) -c Look for first x10 (there MUST be at least one) - index = 0 - do while ((.not.res_tab(1,1,index)) .or. res_tab(1,2,index)) - index=index+1 - enddo - if (res_ang(index) .lt. 0.D0) then ! Make sure it's from PHImin -c Try to decrease PHImin - if (index .lt. res_n-1) then - temp = abs(res_ang(index) - res_ang(index+1)) - if (res_ang(index+1) .le. 0.D0 .and. temp .lt. diff) then - phi = res_ang(index+1) - diff = temp - endif - endif -c Look for last (corresponding) 01x - index = res_n - 1 - do while (res_tab(1,0,index) .or. (.not.res_tab(1,1,index))) - index=index-1 - enddo - if (index .gt. 0) then - temp = abs(res_ang(index) - res_ang(index-1)) - if (res_ang(index-1) .ge. 0.D0 .and. temp .lt. diff) then - phi = res_ang(index-1) - diff = temp - endif - endif - endif - -c If it still didn't work, it must be PHImax == 0. or PHImin == PI - if (diff .eq. flag) then - index = 0 - if (res_tab(index,1,0) .or. (.not.res_tab(index,1,1)) .or. - + res_tab(index,1,2)) index = res_n - 1 -c This MUST work at this point - if (index .eq. 0) then - phi = res_ang(1) - else - phi = res_ang(index - 1) - endif - endif - - return - end - -c------------------------------------------------------------- - - integer function move_res(PHImin,PHImax,i_move) -c Moves residue i_move (in array c), leaving everything else fixed -c Starting geometry is not checked, it should be correct! -c R(,i_move) is the only residue that will move, but must have -c 1 < i_move < nres (i.e., cannot move ends) -c Whether any output is done is controlled by locmove_output -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.LOCMOVE' - -c External functions - double precision ran_number - external ran_number - -c Input arguments - double precision PHImin,PHImax - integer i_move - -c RETURN VALUES: -c 0: move successfull -c 1: Dmin or Dmax had to be modified -c 2: move failed - check your input geometry - - -c Local variables - double precision X(0:2),Y(0:2),Z(0:2),Orig(0:2) - double precision P(0:2) - logical no_moves,done - integer index,i,j - double precision phi,temp,radius - double precision phi_start(0:11), phi_end(0:11) - integer phi_n - -c Set up the coordinate system - do i=0,2 - Orig(i)=0.5*(c(i+1,i_move-1)+c(i+1,i_move+1)) ! Position of origin - enddo - - do i=0,2 - Z(i)=c(i+1,i_move+1)-c(i+1,i_move-1) - enddo - temp=sqrt(Z(0)*Z(0)+Z(1)*Z(1)+Z(2)*Z(2)) - do i=0,2 - Z(i)=Z(i)/temp - enddo - - do i=0,2 - X(i)=c(i+1,i_move)-Orig(i) - enddo -c radius is the radius of the circle on which c(,i_move) can move - radius=sqrt(X(0)*X(0)+X(1)*X(1)+X(2)*X(2)) - do i=0,2 - X(i)=X(i)/radius - enddo - - Y(0)=Z(1)*X(2)-X(1)*Z(2) - Y(1)=X(0)*Z(2)-Z(0)*X(2) - Y(2)=Z(0)*X(1)-X(0)*Z(1) - -c Calculate min, max angles coming from dmin, dmax to c(,i_move-2) - if (i_move.gt.2) then - do i=0,2 - P(i)=c(i+1,i_move-2)-Orig(i) - enddo - call minmax_angles(P(0)*X(0)+P(1)*X(1)+P(2)*X(2), - + P(0)*Y(0)+P(1)*Y(1)+P(2)*Y(2), - + P(0)*Z(0)+P(1)*Z(1)+P(2)*Z(2), - + radius,a_n,a_ang,a_tab) - else - a_n=0 - endif - -c Calculate min, max angles coming from dmin, dmax to c(,i_move+2) - if (i_move.lt.nres-2) then - do i=0,2 - P(i)=c(i+1,i_move+2)-Orig(i) - enddo - call minmax_angles(P(0)*X(0)+P(1)*X(1)+P(2)*X(2), - + P(0)*Y(0)+P(1)*Y(1)+P(2)*Y(2), - + P(0)*Z(0)+P(1)*Z(1)+P(2)*Z(2), - + radius,b_n,b_ang,b_tab) - else - b_n=0 - endif - -c Construct the resulting table for alpha and beta - call construct_tab() - - if (locmove_output) then - print *,'ALPHAS & BETAS TABLE' - call output_tabs() - endif - -c Check that there is at least one possible move - no_moves = .true. - if (res_n .eq. 0) then - no_moves = .false. - else - index = 0 - do while ((index .lt. res_n) .and. no_moves) - if (res_tab(2,1,index)) no_moves = .false. - index=index+1 - enddo - endif - if (no_moves) then - if (locmove_output) print *,' *** Cannot move anywhere' - move_res=2 - return - endif - -c Transfer res_... into a_... - a_n = 0 - do i=0,res_n-1 - if ( (res_tab(2,0,i).neqv.res_tab(2,1,i)) .or. - + (res_tab(2,0,i).neqv.res_tab(2,2,i)) ) then - a_ang(a_n) = res_ang(i) - do j=0,2 - a_tab(j,a_n) = res_tab(2,j,i) - enddo - a_n=a_n+1 - endif - enddo - -c Check that the PHI's are within [0,PI] - if (PHImin .lt. 0. .or. abs(PHImin) .lt. small) PHImin = -flag - if (PHImin .gt. PI .or. abs(PHImin-PI) .lt. small) PHImin = PI - if (PHImax .gt. PI .or. abs(PHImax-PI) .lt. small) PHImax = flag - if (PHImax .lt. 0. .or. abs(PHImax) .lt. small) PHImax = 0. - if (PHImax .lt. PHImin) PHImax = PHImin -c Calculate min and max angles coming from PHImin and PHImax, -c and put them in b_... - call angles2tab(PHImin, PHImax, b_n, b_ang, b_tab) -c Construct the final table - call construct_tab() - - if (locmove_output) then - print *,'FINAL TABLE' - call output_tabs() - endif - -c Check that there is at least one possible move - no_moves = .true. - if (res_n .eq. 0) then - no_moves = .false. - else - index = 0 - do while ((index .lt. res_n) .and. no_moves) - if (res_tab(2,1,index)) no_moves = .false. - index=index+1 - enddo - endif - - if (no_moves) then -c Take care of the case where no solution exists... - call fix_no_moves(phi) - if (locmove_output) then - print *,' *** Had to modify PHImin or PHImax' - print *,'phi: ',phi*rad2deg - endif - move_res=1 - else -c ...or calculate the solution -c Construct phi_start/phi_end arrays - call construct_ranges(phi_n, phi_start, phi_end) -c Choose random angle phi in allowed range(s) - temp = 0. - do i=0,phi_n-1 - temp = temp + phi_end(i) - phi_start(i) - enddo - phi = ran_number(phi_start(0),phi_start(0)+temp) - index = 0 - done = .false. - do while (.not.done) - if (phi .lt. phi_end(index)) then - done = .true. - else - index=index+1 - endif - if (index .eq. phi_n) then - done = .true. - else if (.not.done) then - phi = phi + phi_start(index) - phi_end(index-1) - endif - enddo - if (index.eq.phi_n) phi=phi_end(phi_n-1) ! Fix numerical errors - if (phi .gt. PI) phi = phi-2.*PI - - if (locmove_output) then - print *,'ALLOWED RANGE(S)' - do i=0,phi_n-1 - print *,phi_start(i)*rad2deg,phi_end(i)*rad2deg - enddo - print *,'phi: ',phi*rad2deg - endif - move_res=0 - endif - -c Re-use radius as temp variable - temp=radius*cos(phi) - radius=radius*sin(phi) - do i=0,2 - c(i+1,i_move)=Orig(i)+temp*X(i)+radius*Y(i) - enddo - - return - end - -c------------------------------------------------------------- - - subroutine loc_test -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.LOCMOVE' - -c External functions - integer move_res - external move_res - -c Local variables - integer i,j - integer phi_n - double precision phi_start(0:11),phi_end(0:11) - double precision phi - double precision R(0:2,0:5) - - locmove_output=.true. - -c call angles2tab(30.*deg2rad,70.*deg2rad,a_n,a_ang,a_tab) -c call angles2tab(80.*deg2rad,130.*deg2rad,b_n,b_ang,b_tab) -c call minmax_angles(0.D0,3.8D0,0.D0,3.8D0,b_n,b_ang,b_tab) -c call construct_tab -c call output_tabs - -c call construct_ranges(phi_n,phi_start,phi_end) -c do i=0,phi_n-1 -c print *,phi_start(i)*rad2deg,phi_end(i)*rad2deg -c enddo - -c call fix_no_moves(phi) -c print *,'NO MOVES FOUND, BEST PHI IS',phi*rad2deg - - R(0,0)=0.D0 - R(1,0)=0.D0 - R(2,0)=0.D0 - R(0,1)=0.D0 - R(1,1)=-cos(28.D0*deg2rad) - R(2,1)=-0.5D0-sin(28.D0*deg2rad) - R(0,2)=0.D0 - R(1,2)=0.D0 - R(2,2)=-0.5D0 - R(0,3)=cos(30.D0*deg2rad) - R(1,3)=0.D0 - R(2,3)=0.D0 - R(0,4)=0.D0 - R(1,4)=0.D0 - R(2,4)=0.5D0 - R(0,5)=0.D0 - R(1,5)=cos(26.D0*deg2rad) - R(2,5)=0.5D0+sin(26.D0*deg2rad) - do i=1,5 - do j=0,2 - R(j,i)=vbl*R(j,i) - enddo - enddo -c i=move_res(R(0,1),0.D0*deg2rad,180.D0*deg2rad) - imov=2 - i=move_res(0.D0*deg2rad,180.D0*deg2rad,imov) - print *,'RETURNED ',i - print *,(R(i,3)/vbl,i=0,2) - - return - end - -c------------------------------------------------------------- diff --git a/source/unres/src_MD-M-newcorr/make-tau.log b/source/unres/src_MD-M-newcorr/make-tau.log deleted file mode 100644 index c108a58..0000000 --- a/source/unres/src_MD-M-newcorr/make-tau.log +++ /dev/null @@ -1,1960 +0,0 @@ -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 unres.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse unres.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor unres.pdb unres.F -o unres.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 unres.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o unres.o -Looking for file: unres.o - - -Debug: cleaning inst file -Executing> /bin/rm -f unres.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f unres.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o arcos.o arcos.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse arcos.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor arcos.pdb arcos.f -o arcos.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c arcos.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o arcos.o -Looking for file: arcos.o - - -Debug: cleaning inst file -Executing> /bin/rm -f arcos.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f arcos.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o cartprint.o cartprint.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse cartprint.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor cartprint.pdb cartprint.f -o cartprint.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c cartprint.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o cartprint.o -Looking for file: cartprint.o - - -Debug: cleaning inst file -Executing> /bin/rm -f cartprint.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f cartprint.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 chainbuild.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse chainbuild.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor chainbuild.pdb chainbuild.F -o chainbuild.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 chainbuild.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o chainbuild.o -Looking for file: chainbuild.o - - -Debug: cleaning inst file -Executing> /bin/rm -f chainbuild.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f chainbuild.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o convert.o convert.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse convert.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor convert.pdb convert.f -o convert.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c convert.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o convert.o -Looking for file: convert.o - - -Debug: cleaning inst file -Executing> /bin/rm -f convert.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f convert.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 initialize_p.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse initialize_p.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor initialize_p.pdb initialize_p.F -o initialize_p.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 initialize_p.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o initialize_p.o -Looking for file: initialize_p.o - - -Debug: cleaning inst file -Executing> /bin/rm -f initialize_p.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f initialize_p.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 matmult.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse matmult.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor matmult.pdb matmult.f -o matmult.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 matmult.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o matmult.o -Looking for file: matmult.o - - -Debug: cleaning inst file -Executing> /bin/rm -f matmult.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f matmult.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 readrtns_CSA.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse readrtns_CSA.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor readrtns_CSA.pdb readrtns_CSA.F -o readrtns_CSA.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 readrtns_CSA.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o readrtns_CSA.o -Looking for file: readrtns_CSA.o - - -Debug: cleaning inst file -Executing> /bin/rm -f readrtns_CSA.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f readrtns_CSA.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 parmread.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse parmread.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor parmread.pdb parmread.F -o parmread.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 parmread.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o parmread.o -Looking for file: parmread.o - - -Debug: cleaning inst file -Executing> /bin/rm -f parmread.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f parmread.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 gen_rand_conf.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse gen_rand_conf.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor gen_rand_conf.pdb gen_rand_conf.F -o gen_rand_conf.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 gen_rand_conf.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o gen_rand_conf.o -Looking for file: gen_rand_conf.o - - -Debug: cleaning inst file -Executing> /bin/rm -f gen_rand_conf.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f gen_rand_conf.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o printmat.o printmat.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse printmat.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor printmat.pdb printmat.f -o printmat.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c printmat.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o printmat.o -Looking for file: printmat.o - - -Debug: cleaning inst file -Executing> /bin/rm -f printmat.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f printmat.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o map.o map.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse map.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor map.pdb map.f -o map.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c map.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o map.o -Looking for file: map.o - - -Debug: cleaning inst file -Executing> /bin/rm -f map.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f map.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o pinorm.o pinorm.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse pinorm.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor pinorm.pdb pinorm.f -o pinorm.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c pinorm.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o pinorm.o -Looking for file: pinorm.o - - -Debug: cleaning inst file -Executing> /bin/rm -f pinorm.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f pinorm.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o randgens.o randgens.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse randgens.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor randgens.pdb randgens.f -o randgens.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c randgens.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o randgens.o -Looking for file: randgens.o - - -Debug: cleaning inst file -Executing> /bin/rm -f randgens.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f randgens.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o rescode.o rescode.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse rescode.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor rescode.pdb rescode.f -o rescode.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c rescode.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o rescode.o -Looking for file: rescode.o - - -Debug: cleaning inst file -Executing> /bin/rm -f rescode.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f rescode.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 intcor.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse intcor.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor intcor.pdb intcor.f -o intcor.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 intcor.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o intcor.o -Looking for file: intcor.o - - -Debug: cleaning inst file -Executing> /bin/rm -f intcor.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f intcor.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 timing.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse timing.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor timing.pdb timing.F -o timing.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 timing.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o timing.o -Looking for file: timing.o - - -Debug: cleaning inst file -Executing> /bin/rm -f timing.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f timing.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o misc.o misc.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse misc.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor misc.pdb misc.f -o misc.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c misc.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o misc.o -Looking for file: misc.o - - -Debug: cleaning inst file -Executing> /bin/rm -f misc.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f misc.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o intlocal.o intlocal.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse intlocal.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor intlocal.pdb intlocal.f -o intlocal.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c intlocal.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o intlocal.o -Looking for file: intlocal.o - - -Debug: cleaning inst file -Executing> /bin/rm -f intlocal.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f intlocal.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 cartder.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse cartder.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor cartder.pdb cartder.F -o cartder.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 cartder.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o cartder.o -Looking for file: cartder.o - - -Debug: cleaning inst file -Executing> /bin/rm -f cartder.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f cartder.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 checkder_p.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse checkder_p.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor checkder_p.pdb checkder_p.F -o checkder_p.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 checkder_p.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o checkder_p.o -Looking for file: checkder_p.o - - -Debug: cleaning inst file -Executing> /bin/rm -f checkder_p.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f checkder_p.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 econstr_local.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse econstr_local.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor econstr_local.pdb econstr_local.F -o econstr_local.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 econstr_local.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o econstr_local.o -Looking for file: econstr_local.o - - -Debug: cleaning inst file -Executing> /bin/rm -f econstr_local.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f econstr_local.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 energy_p_new.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse energy_p_new.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor energy_p_new.pdb energy_p_new.F -o energy_p_new.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 energy_p_new.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o energy_p_new.o -Looking for file: energy_p_new.o - - -Debug: cleaning inst file -Executing> /bin/rm -f energy_p_new.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f energy_p_new.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 energy_p_new-sep.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse energy_p_new-sep.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor energy_p_new-sep.pdb energy_p_new-sep.F -o energy_p_new-sep.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 energy_p_new-sep.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o energy_p_new-sep.o -Looking for file: energy_p_new-sep.o - - -Debug: cleaning inst file -Executing> /bin/rm -f energy_p_new-sep.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f energy_p_new-sep.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 gradient_p.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse gradient_p.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor gradient_p.pdb gradient_p.F -o gradient_p.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 gradient_p.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o gradient_p.o -Looking for file: gradient_p.o - - -Debug: cleaning inst file -Executing> /bin/rm -f gradient_p.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f gradient_p.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 minimize_p.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse minimize_p.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor minimize_p.pdb minimize_p.F -o minimize_p.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 minimize_p.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o minimize_p.o -Looking for file: minimize_p.o - - -Debug: cleaning inst file -Executing> /bin/rm -f minimize_p.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f minimize_p.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 sumsld.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse sumsld.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor sumsld.pdb sumsld.f -o sumsld.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 sumsld.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o sumsld.o -Looking for file: sumsld.o - - -Debug: cleaning inst file -Executing> /bin/rm -f sumsld.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f sumsld.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 cored.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse cored.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor cored.pdb cored.f -o cored.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 cored.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o cored.o -Looking for file: cored.o - - -Debug: cleaning inst file -Executing> /bin/rm -f cored.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f cored.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 rmdd.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse rmdd.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor rmdd.pdb rmdd.f -o rmdd.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 rmdd.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o rmdd.o -Looking for file: rmdd.o - - -Debug: cleaning inst file -Executing> /bin/rm -f rmdd.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f rmdd.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 geomout.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse geomout.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor geomout.pdb geomout.F -o geomout.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 geomout.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o geomout.o -Looking for file: geomout.o - - -Debug: cleaning inst file -Executing> /bin/rm -f geomout.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f geomout.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 readpdb.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse readpdb.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor readpdb.pdb readpdb.f -o readpdb.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 readpdb.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o readpdb.o -Looking for file: readpdb.o - - -Debug: cleaning inst file -Executing> /bin/rm -f readpdb.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f readpdb.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 regularize.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse regularize.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor regularize.pdb regularize.F -o regularize.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 regularize.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o regularize.o -Looking for file: regularize.o - - -Debug: cleaning inst file -Executing> /bin/rm -f regularize.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f regularize.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 thread.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse thread.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor thread.pdb thread.F -o thread.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 thread.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o thread.o -Looking for file: thread.o - - -Debug: cleaning inst file -Executing> /bin/rm -f thread.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f thread.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o fitsq.o fitsq.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse fitsq.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor fitsq.pdb fitsq.f -o fitsq.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c fitsq.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o fitsq.o -Looking for file: fitsq.o - - -Debug: cleaning inst file -Executing> /bin/rm -f fitsq.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f fitsq.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 mcm.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse mcm.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor mcm.pdb mcm.F -o mcm.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 mcm.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o mcm.o -Looking for file: mcm.o - - -Debug: cleaning inst file -Executing> /bin/rm -f mcm.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f mcm.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 mc.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse mc.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor mc.pdb mc.F -o mc.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 mc.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o mc.o -Looking for file: mc.o - - -Debug: cleaning inst file -Executing> /bin/rm -f mc.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f mc.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o bond_move.o bond_move.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse bond_move.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor bond_move.pdb bond_move.f -o bond_move.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c bond_move.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o bond_move.o -Looking for file: bond_move.o - - -Debug: cleaning inst file -Executing> /bin/rm -f bond_move.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f bond_move.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o refsys.o refsys.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse refsys.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor refsys.pdb refsys.f -o refsys.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c refsys.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o refsys.o -Looking for file: refsys.o - - -Debug: cleaning inst file -Executing> /bin/rm -f refsys.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f refsys.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o check_sc_distr.o check_sc_distr.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse check_sc_distr.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor check_sc_distr.pdb check_sc_distr.f -o check_sc_distr.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c check_sc_distr.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o check_sc_distr.o -Looking for file: check_sc_distr.o - - -Debug: cleaning inst file -Executing> /bin/rm -f check_sc_distr.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f check_sc_distr.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o check_bond.o check_bond.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse check_bond.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor check_bond.pdb check_bond.f -o check_bond.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c check_bond.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o check_bond.o -Looking for file: check_bond.o - - -Debug: cleaning inst file -Executing> /bin/rm -f check_bond.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f check_bond.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o contact.o contact.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse contact.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor contact.pdb contact.f -o contact.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c contact.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o contact.o -Looking for file: contact.o - - -Debug: cleaning inst file -Executing> /bin/rm -f contact.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f contact.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o djacob.o djacob.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse djacob.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor djacob.pdb djacob.f -o djacob.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c djacob.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o djacob.o -Looking for file: djacob.o - - -Debug: cleaning inst file -Executing> /bin/rm -f djacob.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f djacob.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 eigen.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse eigen.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor eigen.pdb eigen.f -o eigen.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 eigen.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o eigen.o -Looking for file: eigen.o - - -Debug: cleaning inst file -Executing> /bin/rm -f eigen.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f eigen.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 blas.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse blas.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor blas.pdb blas.f -o blas.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 blas.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o blas.o -Looking for file: blas.o - - -Debug: cleaning inst file -Executing> /bin/rm -f blas.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f blas.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 add.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse add.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor add.pdb add.f -o add.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 add.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o add.o -Looking for file: add.o - - -Debug: cleaning inst file -Executing> /bin/rm -f add.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f add.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 entmcm.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse entmcm.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor entmcm.pdb entmcm.F -o entmcm.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 entmcm.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o entmcm.o -Looking for file: entmcm.o - - -Debug: cleaning inst file -Executing> /bin/rm -f entmcm.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f entmcm.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 minim_mcmf.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse minim_mcmf.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor minim_mcmf.pdb minim_mcmf.F -o minim_mcmf.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 minim_mcmf.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o minim_mcmf.o -Looking for file: minim_mcmf.o - - -Debug: cleaning inst file -Executing> /bin/rm -f minim_mcmf.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f minim_mcmf.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 together.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse together.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor together.pdb together.F -o together.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 together.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o together.o -Looking for file: together.o - - -Debug: cleaning inst file -Executing> /bin/rm -f together.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f together.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 csa.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse csa.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor csa.pdb csa.f -o csa.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 csa.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o csa.o -Looking for file: csa.o - - -Debug: cleaning inst file -Executing> /bin/rm -f csa.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f csa.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 minim_jlee.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse minim_jlee.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor minim_jlee.pdb minim_jlee.F -o minim_jlee.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 minim_jlee.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o minim_jlee.o -Looking for file: minim_jlee.o - - -Debug: cleaning inst file -Executing> /bin/rm -f minim_jlee.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f minim_jlee.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 shift.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse shift.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor shift.pdb shift.F -o shift.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 shift.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o shift.o -Looking for file: shift.o - - -Debug: cleaning inst file -Executing> /bin/rm -f shift.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f shift.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 diff12.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse diff12.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor diff12.pdb diff12.f -o diff12.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 diff12.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o diff12.o -Looking for file: diff12.o - - -Debug: cleaning inst file -Executing> /bin/rm -f diff12.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f diff12.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 bank.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse bank.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor bank.pdb bank.F -o bank.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 bank.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o bank.o -Looking for file: bank.o - - -Debug: cleaning inst file -Executing> /bin/rm -f bank.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f bank.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 newconf.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse newconf.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor newconf.pdb newconf.f -o newconf.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 newconf.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o newconf.o -Looking for file: newconf.o - - -Debug: cleaning inst file -Executing> /bin/rm -f newconf.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f newconf.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 ran.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse ran.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor ran.pdb ran.f -o ran.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 ran.inst.f -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o ran.o -Looking for file: ran.o - - -Debug: cleaning inst file -Executing> /bin/rm -f ran.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f ran.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o indexx.o indexx.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse indexx.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor indexx.pdb indexx.f -o indexx.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c indexx.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o indexx.o -Looking for file: indexx.o - - -Debug: cleaning inst file -Executing> /bin/rm -f indexx.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f indexx.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 MP.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse MP.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor MP.pdb MP.F -o MP.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 MP.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o MP.o -Looking for file: MP.o - - -Debug: cleaning inst file -Executing> /bin/rm -f MP.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f MP.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 compare_s1.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse compare_s1.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor compare_s1.pdb compare_s1.F -o compare_s1.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 compare_s1.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o compare_s1.o -Looking for file: compare_s1.o - - -Debug: cleaning inst file -Executing> /bin/rm -f compare_s1.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f compare_s1.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include prng.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse prng.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor prng.pdb prng.f -o prng.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 prng.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o prng.o -Looking for file: prng.o - - -Debug: cleaning inst file -Executing> /bin/rm -f prng.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f prng.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 test.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse test.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor test.pdb test.F -o test.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 test.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o test.o -Looking for file: test.o - - -Debug: cleaning inst file -Executing> /bin/rm -f test.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f test.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o banach.o banach.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse banach.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor banach.pdb banach.f -o banach.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c banach.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o banach.o -Looking for file: banach.o - - -Debug: cleaning inst file -Executing> /bin/rm -f banach.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f banach.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o distfit.o distfit.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse distfit.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor distfit.pdb distfit.f -o distfit.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c distfit.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o distfit.o -Looking for file: distfit.o - - -Debug: cleaning inst file -Executing> /bin/rm -f distfit.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f distfit.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 rmsd.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse rmsd.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor rmsd.pdb rmsd.F -o rmsd.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 rmsd.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o rmsd.o -Looking for file: rmsd.o - - -Debug: cleaning inst file -Executing> /bin/rm -f rmsd.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f rmsd.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o elecont.o elecont.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse elecont.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor elecont.pdb elecont.f -o elecont.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c elecont.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o elecont.o -Looking for file: elecont.o - - -Debug: cleaning inst file -Executing> /bin/rm -f elecont.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f elecont.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 dihed_cons.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse dihed_cons.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor dihed_cons.pdb dihed_cons.F -o dihed_cons.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 dihed_cons.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o dihed_cons.o -Looking for file: dihed_cons.o - - -Debug: cleaning inst file -Executing> /bin/rm -f dihed_cons.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f dihed_cons.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 sc_move.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse sc_move.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor sc_move.pdb sc_move.F -o sc_move.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 sc_move.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o sc_move.o -Looking for file: sc_move.o - - -Debug: cleaning inst file -Executing> /bin/rm -f sc_move.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f sc_move.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o local_move.o local_move.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse local_move.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor local_move.pdb local_move.f -o local_move.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c local_move.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o local_move.o -Looking for file: local_move.o - - -Debug: cleaning inst file -Executing> /bin/rm -f local_move.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f local_move.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o intcartderiv.o intcartderiv.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse intcartderiv.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor intcartderiv.pdb intcartderiv.f -o intcartderiv.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c intcartderiv.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o intcartderiv.o -Looking for file: intcartderiv.o - - -Debug: cleaning inst file -Executing> /bin/rm -f intcartderiv.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f intcartderiv.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 lagrangian_lesyng.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse lagrangian_lesyng.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor lagrangian_lesyng.pdb lagrangian_lesyng.F -o lagrangian_lesyng.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 lagrangian_lesyng.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o lagrangian_lesyng.o -Looking for file: lagrangian_lesyng.o - - -Debug: cleaning inst file -Executing> /bin/rm -f lagrangian_lesyng.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f lagrangian_lesyng.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 stochfric.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse stochfric.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor stochfric.pdb stochfric.F -o stochfric.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 stochfric.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o stochfric.o -Looking for file: stochfric.o - - -Debug: cleaning inst file -Executing> /bin/rm -f stochfric.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f stochfric.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o kinetic_lesyng.o kinetic_lesyng.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse kinetic_lesyng.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor kinetic_lesyng.pdb kinetic_lesyng.f -o kinetic_lesyng.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c kinetic_lesyng.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o kinetic_lesyng.o -Looking for file: kinetic_lesyng.o - - -Debug: cleaning inst file -Executing> /bin/rm -f kinetic_lesyng.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f kinetic_lesyng.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 MD_A-MTS.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse MD_A-MTS.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor MD_A-MTS.pdb MD_A-MTS.F -o MD_A-MTS.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 MD_A-MTS.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o MD_A-MTS.o -Looking for file: MD_A-MTS.o - - -Debug: cleaning inst file -Executing> /bin/rm -f MD_A-MTS.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f MD_A-MTS.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o moments.o moments.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse moments.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor moments.pdb moments.f -o moments.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c moments.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o moments.o -Looking for file: moments.o - - -Debug: cleaning inst file -Executing> /bin/rm -f moments.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f moments.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o int_to_cart.o int_to_cart.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse int_to_cart.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor int_to_cart.pdb int_to_cart.f -o int_to_cart.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c int_to_cart.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o int_to_cart.o -Looking for file: int_to_cart.o - - -Debug: cleaning inst file -Executing> /bin/rm -f int_to_cart.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f int_to_cart.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o surfatom.o surfatom.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse surfatom.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor surfatom.pdb surfatom.f -o surfatom.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c surfatom.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o surfatom.o -Looking for file: surfatom.o - - -Debug: cleaning inst file -Executing> /bin/rm -f surfatom.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f surfatom.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o sort.o sort.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse sort.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor sort.pdb sort.f -o sort.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c sort.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o sort.o -Looking for file: sort.o - - -Debug: cleaning inst file -Executing> /bin/rm -f sort.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f sort.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o muca_md.o muca_md.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse muca_md.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor muca_md.pdb muca_md.f -o muca_md.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c muca_md.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o muca_md.o -Looking for file: muca_md.o - - -Debug: cleaning inst file -Executing> /bin/rm -f muca_md.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f muca_md.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 MREMD.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse MREMD.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor MREMD.pdb MREMD.F -o MREMD.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 MREMD.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o MREMD.o -Looking for file: MREMD.o - - -Debug: cleaning inst file -Executing> /bin/rm -f MREMD.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f MREMD.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 rattle.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse rattle.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor rattle.pdb rattle.F -o rattle.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 rattle.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o rattle.o -Looking for file: rattle.o - - -Debug: cleaning inst file -Executing> /bin/rm -f rattle.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f rattle.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o gauss.o gauss.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse gauss.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor gauss.pdb gauss.f -o gauss.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c gauss.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o gauss.o -Looking for file: gauss.o - - -Debug: cleaning inst file -Executing> /bin/rm -f gauss.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f gauss.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 energy_split-sep.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse energy_split-sep.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor energy_split-sep.pdb energy_split-sep.F -o energy_split-sep.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 energy_split-sep.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o energy_split-sep.o -Looking for file: energy_split-sep.o - - -Debug: cleaning inst file -Executing> /bin/rm -f energy_split-sep.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f energy_split-sep.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 q_measure.F - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse q_measure.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor q_measure.pdb q_measure.F -o q_measure.inst.F - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 q_measure.inst.F -I/include -DAIX -DISNAN -DUNRES -DMP -DMPI -DPGI -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o q_measure.o -Looking for file: q_measure.o - - -Debug: cleaning inst file -Executing> /bin/rm -f q_measure.inst.F - - -Debug: cleaning PDB file -Executing> /bin/rm -f q_measure.pdb - -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include -c -o gnmr1.o gnmr1.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse gnmr1.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor gnmr1.pdb gnmr1.f -o gnmr1.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 -c gnmr1.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o gnmr1.o -Looking for file: gnmr1.o - - -Debug: cleaning inst file -Executing> /bin/rm -f gnmr1.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f gnmr1.pdb - -cc -o compinfo compinfo.c -/opt/xt-pe/1.5.60/bin/snos64/cc: INFO: catamount target is being used -compinfo.c: -PGC-W-0156-Type not specified, 'int' assumed (compinfo.c: 8) -PGC/x86-64 Linux 7.2-2: compilation completed with warnings -compinfo.o(.text+0x12b): In function `main': -: warning: warning: system is not implemented and will always fail -./compinfo | true -tau_f90.sh -c -fast -pc 64 -tp p6 -I/include cinfo.f - - -Debug: Parsing with PDT Parser -Executing> /usr/local/packages/TAU-2.17/tau-2.17/../pdtoolkit-3.12/xt3/bin/f95parse cinfo.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include - - -Debug: Instrumenting with TAU -Executing> /usr/local/packages/TAU-2.17/tau-2.17/xt3/bin/tau_instrumentor cinfo.pdb cinfo.f -o cinfo.inst.f - - -Debug: Compiling with Instrumented Code -Executing> qk-pgf90 -I. -c -fast -pc 64 -tp p6 cinfo.inst.f -I/include -I/usr/local/packages/TAU-2.17/tau-2.17/include -I/opt/xt-mpt/default/mpich2-64/P2/include -o cinfo.o -Looking for file: cinfo.o - - -Debug: cleaning inst file -Executing> /bin/rm -f cinfo.inst.f - - -Debug: cleaning PDB file -Executing> /bin/rm -f cinfo.pdb - -tau_f90.sh -fast -pc 64 -tp p6 unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o cartder.o checkder_p.o econstr_local.o energy_p_new.o energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o eigen.o blas.o add.o entmcm.o minim_mcmf.o together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o indexx.o MP.o compare_s1.o prng.o test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o sc_move.o local_move.o intcartderiv.o lagrangian_lesyng.o stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o q_measure.o gnmr1.o cinfo.o xdrf/libxdrf.a -o ../bin/unres_MD_Tc_procor-newparm-gnivpar-tau.exe - - -Debug: Linking with TAU Options -Executing> qk-pgf90 -fast -pc 64 -tp p6 unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o cartder.o checkder_p.o econstr_local.o energy_p_new.o energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o eigen.o blas.o add.o entmcm.o minim_mcmf.o together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o indexx.o MP.o compare_s1.o prng.o test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o sc_move.o local_move.o intcartderiv.o lagrangian_lesyng.o stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o q_measure.o gnmr1.o cinfo.o xdrf/libxdrf.a -o ../bin/unres_MD_Tc_procor-newparm-gnivpar-tau.exe -L/opt/xt-mpt/default/mpich2-64/P2/lib -L/usr/local/packages/TAU-2.17/tau-2.17/xt3/lib -lTauMpi-mpi-pdt-pgi -lrt -lmpichcxx -lmpich -lrt -L/usr/local/packages/TAU-2.17/tau-2.17/xt3/lib -ltau-mpi-pdt-pgi -lstd -lC -/usr/bin/ld: skipping incompatible /usr/local/packages/TAU-2.17/tau-2.17/xt3/lib/libTauMpi-mpi-pdt-pgi.a when searching for -lTauMpi-mpi-pdt-pgi -/usr/bin/ld: skipping incompatible /usr/local/packages/TAU-2.17/tau-2.17/xt3/lib/libTauMpi-mpi-pdt-pgi.a when searching for -lTauMpi-mpi-pdt-pgi -/usr/bin/ld: cannot find -lTauMpi-mpi-pdt-pgi -Error: Tried Looking for file: ../bin/unres_MD_Tc_procor-newparm-gnivpar-tau.exe -Error: Command(Executable) is -- qk-pgf90 -Error: Full Command attempted is -- qk-pgf90 -fast -pc 64 -tp p6 unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o cartder.o checkder_p.o econstr_local.o energy_p_new.o energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o eigen.o blas.o add.o entmcm.o minim_mcmf.o together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o indexx.o MP.o compare_s1.o prng.o test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o sc_move.o local_move.o intcartderiv.o lagrangian_lesyng.o stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o q_measure.o gnmr1.o cinfo.o xdrf/libxdrf.a -o ../bin/unres_MD_Tc_procor-newparm-gnivpar-tau.exe -L/opt/xt-mpt/default/mpich2-64/P2/lib -L/usr/local/packages/TAU-2.17/tau-2.17/xt3/lib -lTauMpi-mpi-pdt-pgi -lrt -lmpichcxx -lmpich -lrt -L/usr/local/packages/TAU-2.17/tau-2.17/xt3/lib -ltau-mpi-pdt-pgi -lstd -lC -Error: Reverting to a Regular Make - - - -Debug: Compiling with Non-Instrumented Regular Code -Executing> qk-pgf90 -fast -pc 64 -tp p6 unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o cartder.o checkder_p.o econstr_local.o energy_p_new.o energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o eigen.o blas.o add.o entmcm.o minim_mcmf.o together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o indexx.o MP.o compare_s1.o prng.o test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o sc_move.o local_move.o intcartderiv.o lagrangian_lesyng.o stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o q_measure.o gnmr1.o cinfo.o xdrf/libxdrf.a -o ../bin/unres_MD_Tc_procor-newparm-gnivpar-tau.exe -/usr/bin/ld: skipping incompatible /opt/xt-catamount/1.5.60/lib/cnos64/liblustre.a when searching for -llustre -/usr/bin/ld: cannot find -llustre - diff --git a/source/unres/src_MD-M-newcorr/map.f b/source/unres/src_MD-M-newcorr/map.f deleted file mode 100644 index 6ea2632..0000000 --- a/source/unres/src_MD-M-newcorr/map.f +++ /dev/null @@ -1,89 +0,0 @@ - subroutine map - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MAP' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.CONTROL' - include 'COMMON.TORCNSTR' - double precision energia(0:n_ene) - character*5 angid(4) /'PHI','THETA','ALPHA','OMEGA'/ - double precision ang_list(10) - double precision g(maxvar),x(maxvar) - integer nn(10) - write (iout,'(a,i3,a)')'Energy map constructed in the following ', - & nmap,' groups of variables:' - do i=1,nmap - write (iout,'(2a,i3,a,i3)') angid(kang(i)),' of residues ', - & res1(i),' to ',res2(i) - enddo - nmax=nstep(1) - do i=2,nmap - if (nmax.lt.nstep(i)) nmax=nstep(i) - enddo - ntot=nmax**nmap - iii=0 - write (istat,'(1h#,a14,29a15)') (" ",k=1,nmap), - & (ename(print_order(k)),k=1,nprint_ene),"ETOT","GNORM" - do i=0,ntot-1 - ii=i - do j=1,nmap - nn(j)=mod(ii,nmax)+1 - ii=ii/nmax - enddo - do j=1,nmap - if (nn(j).gt.nstep(j)) goto 10 - enddo - iii=iii+1 -Cd write (iout,*) i,iii,(nn(j),j=1,nmap) - do j=1,nmap - ang_list(j)=ang_from(j) - & +(nn(j)-1)*(ang_to(j)-ang_from(j))/nstep(j) - do k=res1(j),res2(j) - goto (1,2,3,4), kang(j) - 1 phi(k)=deg2rad*ang_list(j) - if (minim) phi0(k-res1(j)+1)=deg2rad*ang_list(j) - goto 5 - 2 theta(k)=deg2rad*ang_list(j) - goto 5 - 3 alph(k)=deg2rad*ang_list(j) - goto 5 - 4 omeg(k)=deg2rad*ang_list(j) - 5 continue - enddo ! k - enddo ! j - call chainbuild - if (minim) then - call geom_to_var(nvar,x) - call minimize(etot,x,iretcode,nfun) - print *,'SUMSL return code is',iretcode,' eval ',nfun -c call intout - else - call zerograd - call geom_to_var(nvar,x) - endif - call etotal(energia(0)) - etot = energia(0) - nf=1 - nfl=3 - call gradient(nvar,x,nf,g,uiparm,urparm,fdum) - gnorm=0.0d0 - do k=1,nvar - gnorm=gnorm+g(k)**2 - enddo - etot=energia(0) - - gnorm=dsqrt(gnorm) -c write (iout,'(6(1pe15.5))') (ang_list(k),k=1,nmap),etot,gnorm - write (istat,'(30e15.5)') (ang_list(k),k=1,nmap), - & (energia(print_order(ii)),ii=1,nprint_ene),etot,gnorm -c write (iout,*) 'POINT',I,' ANGLES:',(ang_list(k),k=1,nmap) -c call intout -c call enerprint(energia) - 10 continue - enddo ! i - return - end diff --git a/source/unres/src_MD-M-newcorr/matmult.f b/source/unres/src_MD-M-newcorr/matmult.f deleted file mode 100644 index e9257cf..0000000 --- a/source/unres/src_MD-M-newcorr/matmult.f +++ /dev/null @@ -1,18 +0,0 @@ - SUBROUTINE MATMULT(A1,A2,A3) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(3,3),A2(3,3),A3(3,3) - DIMENSION AI3(3,3) - DO 1 I=1,3 - DO 2 J=1,3 - A3IJ=0.0 - DO 3 K=1,3 - 3 A3IJ=A3IJ+A1(I,K)*A2(K,J) - AI3(I,J)=A3IJ - 2 CONTINUE - 1 CONTINUE - DO 4 I=1,3 - DO 4 J=1,3 - 4 A3(I,J)=AI3(I,J) - RETURN - END diff --git a/source/unres/src_MD-M-newcorr/mc.F b/source/unres/src_MD-M-newcorr/mc.F deleted file mode 100644 index ec5b87b..0000000 --- a/source/unres/src_MD-M-newcorr/mc.F +++ /dev/null @@ -1,819 +0,0 @@ - subroutine monte_carlo -C Does Boltzmann and entropic sampling without energy minimization - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPL - include 'COMMON.INFO' -#endif - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.THREAD' - include 'COMMON.NAMES' - logical accepted,not_done,over,ovrtim,error,lprint - integer MoveType,nbond,nbins - integer conf_comp - double precision RandOrPert - double precision varia(maxvar),elowest,elowest1, - & ehighest,ehighest1,eold - double precision przes(3),obr(3,3) - double precision varold(maxvar) - logical non_conv - integer moves1(-1:MaxMoveType+1,0:MaxProcs-1), - & moves_acc1(-1:MaxMoveType+1,0:MaxProcs-1) -#ifdef MPL - double precision etot_temp,etot_all(0:MaxProcs) - external d_vadd,d_vmin,d_vmax - double precision entropy1(-max_ene:max_ene), - & nhist1(-max_ene:max_ene) - integer nbond_move1(maxres*(MaxProcs+1)), - & nbond_acc1(maxres*(MaxProcs+1)),itemp(2) -#endif - double precision var_lowest(maxvar) - double precision energia(0:n_ene),energia_ave(0:n_ene) -C - write(iout,'(a,i8,2x,a,f10.5)') - & 'pool_read_freq=',pool_read_freq,' pool_fraction=',pool_fraction - open (istat,file=statname) - WhatsUp=0 - indminn=-max_ene - indmaxx=max_ene - facee=1.0D0/(maxacc*delte) -C Number of bins in energy histogram - nbins=e_up/delte-1 - write (iout,*) 'NBINS=',nbins - conste=dlog(facee) -C Read entropy from previous simulations. - if (ent_read) then - read (ientin,*) indminn,indmaxx,emin,emax - print *,'indminn=',indminn,' indmaxx=',indmaxx,' emin=',emin, - & ' emax=',emax - do i=-max_ene,max_ene - entropy(i)=0.0D0 - enddo - read (ientin,*) (ijunk,ejunk,entropy(i),i=indminn,indmaxx) - indmin=indminn - indmax=indmaxx - write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx, - & ' emin=',emin,' emax=',emax - write (iout,'(/a)') 'Initial entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - endif ! ent_read -C Read the pool of conformations - call read_pool - elowest=1.0D+10 - ehighest=-1.0D+10 -C---------------------------------------------------------------------------- -C Entropy-sampling simulations with continually updated entropy; -C set NSWEEP=1 for Boltzmann sampling. -C Loop thru simulations -C---------------------------------------------------------------------------- - DO ISWEEP=1,NSWEEP -C -C Initialize the IFINISH array. -C -#ifdef MPL - do i=1,nctasks - ifinish(i)=0 - enddo -#endif -c--------------------------------------------------------------------------- -C Initialize counters. -c--------------------------------------------------------------------------- -C Total number of generated confs. - ngen=0 -C Total number of moves. In general this won't be equal to the number of -C attempted moves, because we may want to reject some "bad" confs just by -C overlap check. - nmove=0 -C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... -C motions. - do i=1,nres - nbond_move(i)=0 - nbond_acc(i)=0 - enddo -C Initialize total and accepted number of moves of various kind. - do i=-1,MaxMoveType - moves(i)=0 - moves_acc(i)=0 - enddo -C Total number of energy evaluations. - neneval=0 - nfun=0 -C---------------------------------------------------------------------------- -C Take a conformation from the pool -C---------------------------------------------------------------------------- - rewind(istat) - write (iout,*) 'emin=',emin,' emax=',emax - if (npool.gt.0) then - ii=iran_num(1,npool) - do i=1,nvar - varia(i)=xpool(i,ii) - enddo - write (iout,*) 'Took conformation',ii,' from the pool energy=', - & epool(ii) - call var_to_geom(nvar,varia) -C Print internal coordinates of the initial conformation - call intout - else if (isweep.gt.1) then - if (eold.lt.emax) then - do i=1,nvar - varia(i)=varold(i) - enddo - else - do i=1,nvar - varia(i)=var_lowest(i) - enddo - endif - call var_to_geom(nvar,varia) - endif -C---------------------------------------------------------------------------- -C Compute and print initial energies. -C---------------------------------------------------------------------------- - nsave=0 - Kwita=0 - WhatsUp=0 - write (iout,'(/80(1h*)/a,i2/80(1h*)/)') 'MCE iteration #',isweep - write (iout,'(/80(1h*)/a)') 'Initial energies:' - call chainbuild - call geom_to_var(nvar,varia) - call etotal(energia(0)) - etot = energia(0) - call enerprint(energia(0)) - if (refstr) then - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,1),nsup,przes, - & obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order',co - write (istat,'(i10,16(1pe14.5))') 0, - & (energia(print_order(i)),i=1,nprint_ene), - & etot,rms,frac,co - else - write (istat,'(i10,14(1pe14.5))') 0, - & (energia(print_order(i)),i=1,nprint_ene),etot - endif -c close(istat) - neneval=neneval+1 - if (.not. ent_read) then -C Initialize the entropy array -#ifdef MPL -C Collect total energies from other processors. - etot_temp=etot - etot_all(0)=etot - call mp_gather(etot_temp,etot_all,8,MasterID,cgGroupID) - if (MyID.eq.MasterID) then -C Get the lowest and the highest energy. - print *,'MASTER: etot_temp: ',(etot_all(i),i=0,nprocs-1), - & ' emin=',emin,' emax=',emax - emin=1.0D10 - emax=-1.0D10 - do i=0,nprocs - if (emin.gt.etot_all(i)) emin=etot_all(i) - if (emax.lt.etot_all(i)) emax=etot_all(i) - enddo - emax=emin+e_up - endif ! MyID.eq.MasterID - etot_all(1)=emin - etot_all(2)=emax - print *,'Processor',MyID,' calls MP_BCAST to send/recv etot_all' - call mp_bcast(etot_all(1),16,MasterID,cgGroupID) - print *,'Processor',MyID,' MP_BCAST to send/recv etot_all ended' - if (MyID.ne.MasterID) then - print *,'Processor:',MyID,etot_all(1),etot_all(2), - & etot_all(1),etot_all(2) - emin=etot_all(1) - emax=etot_all(2) - endif ! MyID.ne.MasterID - write (iout,*) 'After MP_GATHER etot_temp=', - & etot_temp,' emin=',emin -#else - emin=etot - emax=emin+e_up - indminn=0 - indmin=0 -#endif - IF (MULTICAN) THEN -C Multicanonical sampling - start from Boltzmann distribution - do i=-max_ene,max_ene - entropy(i)=(emin+i*delte)*betbol - enddo - ELSE -C Entropic sampling - start from uniform distribution of the density of states - do i=-max_ene,max_ene - entropy(i)=0.0D0 - enddo - ENDIF ! MULTICAN - write (iout,'(/a)') 'Initial entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - if (isweep.eq.1) then - emax=emin+e_up - indminn=0 - indmin=0 - indmaxx=indminn+nbins - indmax=indmaxx - endif ! isweep.eq.1 - endif ! .not. ent_read -#ifdef MPL - call recv_stop_sig(Kwita) - if (whatsup.eq.1) then - call send_stop_sig(-2) - not_done=.false. - else if (whatsup.le.-2) then - not_done=.false. - else if (whatsup.eq.2) then - not_done=.false. - else - not_done=.true. - endif -#else - not_done=.true. -#endif - write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Enter Monte Carlo procedure.' - close(igeom) - call briefout(0,etot) - do i=1,nvar - varold(i)=varia(i) - enddo - eold=etot - call entropia(eold,sold,indeold) -C NACC is the counter for the accepted conformations of a given processor - nacc=0 -C NACC_TOT counts the total number of accepted conformations - nacc_tot=0 -C Main loop. -c---------------------------------------------------------------------------- -C Zero out average energies - do i=0,n_ene - energia_ave(i)=0.0d0 - enddo -C Initialize energy histogram - do i=-max_ene,max_ene - nhist(i)=0.0D0 - enddo ! i -C Zero out iteration counter. - it=0 - do j=1,nvar - varold(j)=varia(j) - enddo -C Begin MC iteration loop. - do while (not_done) - it=it+1 -C Initialize local counter. - ntrial=0 ! # of generated non-overlapping confs. - noverlap=0 ! # of overlapping confs. - accepted=.false. - do while (.not. accepted .and. WhatsUp.eq.0 .and. Kwita.eq.0) - ntrial=ntrial+1 -C Retrieve the angles of previously accepted conformation - do j=1,nvar - varia(j)=varold(j) - enddo - call var_to_geom(nvar,varia) -C Rebuild the chain. - call chainbuild - MoveType=0 - nbond=0 - lprint=.true. -C Decide whether to take a conformation from the pool or generate/perturb one -C randomly - from_pool=ran_number(0.0D0,1.0D0) - if (npool.gt.0 .and. from_pool.lt.pool_fraction) then -C Throw a dice to choose the conformation from the pool - ii=iran_num(1,npool) - do i=1,nvar - varia(i)=xpool(i,ii) - enddo - call var_to_geom(nvar,varia) - call chainbuild -cd call intout -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a,i3,a,f10.5)') - & 'Try conformation',ii,' from the pool energy=',epool(ii) - MoveType=-1 - moves(-1)=moves(-1)+1 - else -C Decide whether to generate a random conformation or perturb the old one - RandOrPert=ran_number(0.0D0,1.0D0) - if (RandOrPert.gt.RanFract) then - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a)') 'Perturbation-generated conformation.' - call perturb(error,lprint,MoveType,nbond,0.1D0) - if (error) goto 20 - if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then - write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=', - & MoveType,' returned from PERTURB.' - goto 20 - endif - call chainbuild - else - MoveType=0 - moves(0)=moves(0)+1 - nstart_grow=iran_num(3,nres) - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(2a,i3)') 'Random-generated conformation', - & ' - chain regrown from residue',nstart_grow - call gen_rand_conf(nstart_grow,*30) - endif - call geom_to_var(nvar,varia) - endif ! pool -Cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - ngen=ngen+1 - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a,i5,a,i10,a,i10)') - & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (*,'(a,i5,a,i10,a,i10)') - & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen - call etotal(energia(0)) - etot = energia(0) - neneval=neneval+1 -cd call enerprint(energia(0)) -cd write(iout,*)'it=',it,' etot=',etot - if (etot-elowest.gt.overlap_cut) then - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a,i5,a,1pe14.5)') 'Iteration',it, - & ' Overlap detected in the current conf.; energy is',etot - accepted=.false. - noverlap=noverlap+1 - if (noverlap.gt.maxoverlap) then - write (iout,'(a)') 'Too many overlapping confs.' - goto 20 - endif - else -C-------------------------------------------------------------------------- -C... Acceptance test -C-------------------------------------------------------------------------- - accepted=.false. - if (WhatsUp.eq.0) - & call accept_mc(it,etot,eold,scur,sold,varia,varold,accepted) - if (accepted) then - nacc=nacc+1 - nacc_tot=nacc_tot+1 - if (elowest.gt.etot) then - elowest=etot - do i=1,nvar - var_lowest(i)=varia(i) - enddo - endif - if (ehighest.lt.etot) ehighest=etot - moves_acc(MoveType)=moves_acc(MoveType)+1 - if (MoveType.eq.1) then - nbond_acc(nbond)=nbond_acc(nbond)+1 - endif -C Compare with reference structure. - if (refstr) then - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,1), - & nsup,przes,obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - endif ! refstr -C -C Periodically save average energies and confs. -C - do i=0,n_ene - energia_ave(i)=energia_ave(i)+energia(i) - enddo - moves(MaxMoveType+1)=nmove - moves_acc(MaxMoveType+1)=nacc - IF ((it/save_frequency)*save_frequency.eq.it) THEN - do i=0,n_ene - energia_ave(i)=energia_ave(i)/save_frequency - enddo - etot_ave=energia_ave(0) -C#ifdef AIX -C open (istat,file=statname,position='append') -C#else -C open (istat,file=statname,access='append') -Cendif - if (print_mc.gt.0) - & write (iout,'(80(1h*)/20x,a,i20)') - & 'Iteration #',it - if (refstr .and. print_mc.gt.0) then - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order:',co - endif - if (print_stat) then - if (refstr) then - write (istat,'(i10,10(1pe14.5))') it, - & (energia_ave(print_order(i)),i=1,nprint_ene), - & etot_ave,rms_ave,frac_ave - else - write (istat,'(i10,10(1pe14.5))') it, - & (energia_ave(print_order(i)),i=1,nprint_ene), - & etot_ave - endif - endif -c close(istat) - if (print_mc.gt.0) - & call statprint(nacc,nfun,iretcode,etot,elowest) -C Print internal coordinates. - if (print_int) call briefout(nacc,etot) - do i=0,n_ene - energia_ave(i)=0.0d0 - enddo - ENDIF ! ( (it/save_frequency)*save_frequency.eq.it) -C Update histogram - inde=icialosc((etot-emin)/delte) - nhist(inde)=nhist(inde)+1.0D0 -#ifdef MPL - if ( (it/message_frequency)*message_frequency.eq.it - & .and. (MyID.ne.MasterID) ) then - call recv_stop_sig(Kwita) - call send_MCM_info(message_frequency) - endif -#endif -C Store the accepted conf. and its energy. - eold=etot - sold=scur - do i=1,nvar - varold(i)=varia(i) - enddo -#ifdef MPL - if (Kwita.eq.0) call recv_stop_sig(kwita) -#endif - endif ! accepted - endif ! overlap -#ifdef MPL - if (MyID.eq.MasterID .and. - & (it/message_frequency)*message_frequency.eq.it) then - call receive_MC_info - if (nacc_tot.ge.maxacc) accepted=.true. - endif -#endif -C if ((ntrial.gt.maxtrial_iter -C & .or. (it/pool_read_freq)*pool_read_freq.eq.it) -C & .and. npool.gt.0) then -C Take a conformation from the pool -C ii=iran_num(1,npool) -C do i=1,nvar -C varold(i)=xpool(i,ii) -C enddo -C if (ntrial.gt.maxtrial_iter) -C & write (iout,*) 'Iteration',it,' max. # of trials exceeded.' -C write (iout,*) -C & 'Take conformation',ii,' from the pool energy=',epool(ii) -C if (print_mc.gt.2) -C & write (iout,'(10f8.3)') (rad2deg*varold(i),i=1,nvar) -C ntrial=0 -C eold=epool(ii) -C call entropia(eold,sold,indeold) -C accepted=.true. -C endif ! (ntrial.gt.maxtrial_iter .and. npool.gt.0) - 30 continue - enddo ! accepted -#ifdef MPL - if (MyID.eq.MasterID .and. - & (it/message_frequency)*message_frequency.eq.it) then - call receive_MC_info - endif - if (Kwita.eq.0) call recv_stop_sig(kwita) -#endif - if (ovrtim()) WhatsUp=-1 -cd write (iout,*) 'WhatsUp=',WhatsUp,' Kwita=',Kwita - not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) - & .and. (Kwita.eq.0) -cd write (iout,*) 'not_done=',not_done -#ifdef MPL - if (Kwita.lt.0) then - print *,'Processor',MyID, - & ' has received STOP signal =',Kwita,' in EntSamp.' -cd print *,'not_done=',not_done - if (Kwita.lt.-1) WhatsUp=Kwita - if (MyID.ne.MasterID) call send_MCM_info(-1) - else if (nacc_tot.ge.maxacc) then - print *,'Processor',MyID,' calls send_stop_sig,', - & ' because a sufficient # of confs. have been collected.' -cd print *,'not_done=',not_done - call send_stop_sig(-1) - if (MyID.ne.MasterID) call send_MCM_info(-1) - else if (WhatsUp.eq.-1) then - print *,'Processor',MyID, - & ' calls send_stop_sig because of timeout.' -cd print *,'not_done=',not_done - call send_stop_sig(-2) - if (MyID.ne.MasterID) call send_MCM_info(-1) - endif -#endif - enddo ! not_done - -C----------------------------------------------------------------- -C... Construct energy histogram & update entropy -C----------------------------------------------------------------- - go to 21 - 20 WhatsUp=-3 -#ifdef MPL - write (iout,*) 'Processor',MyID, - & ' is broadcasting ERROR-STOP signal.' - write (*,*) 'Processor',MyID, - & ' is broadcasting ERROR-STOP signal.' - call send_stop_sig(-3) - if (MyID.ne.MasterID) call send_MCM_info(-1) -#endif - 21 continue - write (iout,'(/a)') 'Energy histogram' - do i=-100,100 - write (iout,'(i5,2f20.5)') i,emin+i*delte,nhist(i) - enddo -#ifdef MPL -C Wait until every processor has sent complete MC info. - if (MyID.eq.MasterID) then - not_done=.true. - do while (not_done) -C write (*,*) 'The IFINISH array:' -C write (*,*) (ifinish(i),i=1,nctasks) - not_done=.false. - do i=2,nctasks - not_done=not_done.or.(ifinish(i).ge.0) - enddo - if (not_done) call receive_MC_info - enddo - endif -C Make collective histogram from the work of all processors. - msglen=(2*max_ene+1)*8 - print *, - & 'Processor',MyID,' calls MP_REDUCE to send/receive histograms', - & ' msglen=',msglen - call mp_reduce(nhist,nhist1,msglen,MasterID,d_vadd, - & cgGroupID) - print *,'Processor',MyID,' MP_REDUCE accomplished for histogr.' - do i=-max_ene,max_ene - nhist(i)=nhist1(i) - enddo -C Collect min. and max. energy - print *, - &'Processor',MyID,' calls MP_REDUCE to send/receive energy borders' - call mp_reduce(elowest,elowest1,8,MasterID,d_vmin,cgGroupID) - call mp_reduce(ehighest,ehighest1,8,MasterID,d_vmax,cgGroupID) - print *,'Processor',MyID,' MP_REDUCE accomplished for energies.' - IF (MyID.eq.MasterID) THEN - elowest=elowest1 - ehighest=ehighest1 -#endif - write (iout,'(a,i10)') '# of accepted confs:',nacc_tot - write (iout,'(a,f10.5,a,f10.5)') 'Lowest energy:',elowest, - & ' Highest energy',ehighest - indmin=icialosc((elowest-emin)/delte) - imdmax=icialosc((ehighest-emin)/delte) - if (indmin.lt.indminn) then - emax=emin+indmin*delte+e_up - indmaxx=indmin+nbins - indminn=indmin - endif - if (.not.ent_read) ent_read=.true. - write(iout,*)'indminn=',indminn,' indmaxx=',indmaxx -C Update entropy (density of states) - do i=indmin,indmax - if (nhist(i).gt.0) then - entropy(i)=entropy(i)+dlog(nhist(i)+0.0D0) - endif - enddo - write (iout,'(/80(1h*)/a,i2/80(1h*)/)') - & 'End of macroiteration',isweep - write (iout,'(a,f10.5,a,f10.5)') 'Elowest=',elowest, - & ' Ehighest=',ehighest - write (iout,'(/a)') 'Energy histogram' - do i=indminn,indmaxx - write (iout,'(i5,2f20.5)') i,emin+i*delte,nhist(i) - enddo - write (iout,'(/a)') 'Entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f20.5)') i,emin+i*delte,entropy(i) - enddo -C----------------------------------------------------------------- -C... End of energy histogram construction -C----------------------------------------------------------------- -#ifdef MPL - ELSE - if (.not. ent_read) ent_read=.true. - ENDIF ! MyID .eq. MaterID - if (MyID.eq.MasterID) then - itemp(1)=indminn - itemp(2)=indmaxx - endif - print *,'before mp_bcast processor',MyID,' indminn=',indminn, - & ' indmaxx=',indmaxx,' itemp=',itemp(1),itemp(2) - call mp_bcast(itemp(1),8,MasterID,cgGroupID) - call mp_bcast(emax,8,MasterID,cgGroupID) - print *,'after mp_bcast processor',MyID,' indminn=',indminn, - & ' indmaxx=',indmaxx,' itemp=',itemp(1),itemp(2) - if (MyID .ne. MasterID) then - indminn=itemp(1) - indmaxx=itemp(2) - endif - msglen=(indmaxx-indminn+1)*8 - print *,'processor',MyID,' calling mp_bcast msglen=',msglen, - & ' indminn=',indminn,' indmaxx=',indmaxx,' isweep=',isweep - call mp_bcast(entropy(indminn),msglen,MasterID,cgGroupID) - IF(MyID.eq.MasterID .and. .not. ovrtim() .and. WhatsUp.ge.0)THEN - open (ientout,file=entname,status='unknown') - write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax - do i=indminn,indmaxx - write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) - enddo - close(ientout) - ELSE - write (iout,*) 'Received from master:' - write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx, - & ' emin=',emin,' emax=',emax - write (iout,'(/a)') 'Entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - ENDIF ! MyID.eq.MasterID - print *,'Processor',MyID,' calls MP_GATHER' - call mp_gather(nbond_move,nbond_move1,4*Nbm,MasterID, - & cgGroupID) - call mp_gather(nbond_acc,nbond_acc1,4*Nbm,MasterID, - & cgGroupID) - print *,'Processor',MyID,' MP_GATHER call accomplished' - if (MyID.eq.MasterID) then - - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc_tot,nfun,iretcode,etot,elowest) - write (iout,'(a)') - & 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(8i10)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(8i10)') (nbond_acc(i),i=1,Nbm) - - write (iout,'(a)') - & 'Statistics of multi-bond moves of respective processors:' - do iproc=1,Nprocs-1 - do i=1,Nbm - ind=iproc*nbm+i - nbond_move(i)=nbond_move(i)+nbond_move1(ind) - nbond_acc(i)=nbond_acc(i)+nbond_acc1(ind) - enddo - enddo - do iproc=0,NProcs-1 - write (iout,*) 'Processor',iproc,' nbond_move:', - & (nbond_move1(iproc*nbm+i),i=1,Nbm), - & ' nbond_acc:',(nbond_acc1(iproc*nbm+i),i=1,Nbm) - enddo - endif - call mp_gather(moves,moves1,4*(MaxMoveType+3),MasterID, - & cgGroupID) - call mp_gather(moves_acc,moves_acc1,4*(MaxMoveType+3), - & MasterID,cgGroupID) - if (MyID.eq.MasterID) then - do iproc=1,Nprocs-1 - do i=-1,MaxMoveType+1 - moves(i)=moves(i)+moves1(i,iproc) - moves_acc(i)=moves_acc(i)+moves_acc1(i,iproc) - enddo - enddo - nmove=0 - do i=0,MaxMoveType+1 - nmove=nmove+moves(i) - enddo - do iproc=0,NProcs-1 - write (iout,*) 'Processor',iproc,' moves', - & (moves1(i,iproc),i=0,MaxMoveType+1), - & ' moves_acc:',(moves_acc1(i,iproc),i=0,MaxMoveType+1) - enddo - endif -#else - open (ientout,file=entname,status='unknown') - write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax - do i=indminn,indmaxx - write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) - enddo - close(ientout) -#endif - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc_tot,nfun,iretcode,etot,elowest) - write (iout,'(a)') - & 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(8i10)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(8i10)') (nbond_acc(i),i=1,Nbm) - if (ovrtim() .or. WhatsUp.lt.0) return - -C--------------------------------------------------------------------------- - ENDDO ! ISWEEP -C--------------------------------------------------------------------------- - - runtime=tcpu() - - if (isweep.eq.nsweep .and. it.ge.maxacc) - &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' - return - end -c------------------------------------------------------------------------------ - subroutine accept_mc(it,ecur,eold,scur,sold,x,xold,accepted) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' -#ifdef MPL - include 'COMMON.INFO' -#endif - include 'COMMON.GEO' - double precision ecur,eold,xx,ran_number,bol - double precision x(maxvar),xold(maxvar) - logical accepted -C Check if the conformation is similar. -cd write (iout,*) 'Enter ACCEPTING' -cd write (iout,*) 'Old PHI angles:' -cd write (iout,*) (rad2deg*xold(i),i=1,nphi) -cd write (iout,*) 'Current angles' -cd write (iout,*) (rad2deg*x(i),i=1,nphi) -cd ddif=dif_ang(nphi,x,xold) -cd write (iout,*) 'Angle norm:',ddif -cd write (iout,*) 'ecur=',ecur,' emax=',emax - if (ecur.gt.emax) then - accepted=.false. - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a)') 'Conformation rejected as too high in energy' - return - endif -C Else evaluate the entropy of the conf and compare it with that of the previous -C one. - call entropia(ecur,scur,indecur) -cd print *,'Processor',MyID,' ecur=',ecur,' indecur=',indecur, -cd & ' scur=',scur,' eold=',eold,' sold=',sold -cd print *,'deix=',deix,' dent=',dent,' delte=',delte - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) then - write(iout,*)'it=',it,'ecur=',ecur,' indecur=',indecur, - & ' scur=',scur - write(iout,*)'eold=',eold,' sold=',sold - endif - if (scur.le.sold) then - accepted=.true. - else -C Else carry out acceptance test - xx=ran_number(0.0D0,1.0D0) - xxh=scur-sold - if (xxh.gt.50.0D0) then - bol=0.0D0 - else - bol=exp(-xxh) - endif - if (bol.gt.xx) then - accepted=.true. - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a)') 'Conformation accepted.' - else - accepted=.false. - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a)') 'Conformation rejected.' - endif - endif - return - end -c-------------------------------------------------------------------------- - integer function icialosc(x) - double precision x - if (x.lt.0.0D0) then - icialosc=dint(x)-1 - else - icialosc=dint(x) - endif - return - end -c-------------------------------------------------------------------------- - subroutine entropia(ecur,scur,indecur) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.IOUNITS' - double precision ecur,scur - integer indecur - indecur=icialosc((ecur-emin)/delte) - if (iabs(indecur).gt.max_ene) then - if ((it/print_freq)*it.eq.it) write (iout,'(a,2i5)') - & 'Accepting: Index out of range:',indecur - scur=1000.0D0 - else if (indecur.ge.indmaxx) then - scur=entropy(indecur) - if (print_mc.gt.0 .and. (it/print_freq)*it.eq.it) - & write (iout,*)'Energy boundary reached', - & indmaxx,indecur,entropy(indecur) - else - deix=ecur-(emin+indecur*delte) - dent=entropy(indecur+1)-entropy(indecur) - scur=entropy(indecur)+(dent/delte)*deix - endif - return - end diff --git a/source/unres/src_MD-M-newcorr/mcm.F b/source/unres/src_MD-M-newcorr/mcm.F deleted file mode 100644 index 7f839f4..0000000 --- a/source/unres/src_MD-M-newcorr/mcm.F +++ /dev/null @@ -1,1481 +0,0 @@ - subroutine mcm_setup - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.MCM' - include 'COMMON.CONTROL' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.VAR' -C -C Set up variables used in MC/MCM. -C - write (iout,'(80(1h*)/20x,a/80(1h*))') 'MCM control parameters:' - write (iout,'(5(a,i7))') 'Maxacc:',maxacc,' MaxTrial:',MaxTrial, - & ' MaxRepm:',MaxRepm,' MaxGen:',MaxGen,' MaxOverlap:',MaxOverlap - write (iout,'(4(a,f8.1)/2(a,i3))') - & 'Tmin:',Tmin,' Tmax:',Tmax,' TstepH:',TstepH, - & ' TstepC:',TstepC,'NstepH:',NstepH,' NstepC:',NstepC - if (nwindow.gt.0) then - write (iout,'(a)') 'Perturbation windows:' - do i=1,nwindow - i1=winstart(i) - i2=winend(i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(a,i3,a,i3,a,i3)') restyp(it1),i1,restyp(it2),i2, - & ' length',winlen(i) - enddo - endif -C Rbolt=8.3143D-3*2.388459D-01 kcal/(mol*K) - RBol=1.9858D-3 -C Number of "end bonds". - koniecl=0 -c koniecl=nphi - print *,'koniecl=',koniecl - write (iout,'(a)') 'Probabilities of move types:' - write (*,'(a)') 'Probabilities of move types:' - do i=1,MaxMoveType - write (iout,'(a,f10.5)') MovTypID(i), - & sumpro_type(i)-sumpro_type(i-1) - write (*,'(a,f10.5)') MovTypID(i), - & sumpro_type(i)-sumpro_type(i-1) - enddo - write (iout,*) -C Maximum length of N-bond segment to be moved -c nbm=nres-1-(2*koniecl-1) - if (nwindow.gt.0) then - maxwinlen=winlen(1) - do i=2,nwindow - if (winlen(i).gt.maxwinlen) maxwinlen=winlen(i) - enddo - nbm=min0(maxwinlen,6) - write (iout,'(a,i3,a,i3)') 'Nbm=',Nbm,' Maxwinlen=',Maxwinlen - else - nbm=min0(6,nres-2) - endif - sumpro_bond(0)=0.0D0 - sumpro_bond(1)=0.0D0 - do i=2,nbm - sumpro_bond(i)=sumpro_bond(i-1)+1.0D0/dfloat(i) - enddo - write (iout,'(a)') 'The SumPro_Bond array:' - write (iout,'(8f10.5)') (sumpro_bond(i),i=1,nbm) - write (*,'(a)') 'The SumPro_Bond array:' - write (*,'(8f10.5)') (sumpro_bond(i),i=1,nbm) -C Maximum number of side chains moved simultaneously -c print *,'nnt=',nnt,' nct=',nct - ngly=0 - do i=nnt,nct - if (itype(i).eq.10) ngly=ngly+1 - enddo - mmm=nct-nnt-ngly+1 - if (mmm.gt.0) then - MaxSideMove=min0((nct-nnt+1)/2,mmm) - endif -c print *,'MaxSideMove=',MaxSideMove -C Max. number of generated confs (not used at present). - maxgen=10000 -C Set initial temperature - Tcur=Tmin - betbol=1.0D0/(Rbol*Tcur) - write (iout,'(a,f8.1,a,f10.5)') 'Initial temperature:',Tcur, - & ' BetBol:',betbol - write (iout,*) 'RanFract=',ranfract - return - end -c------------------------------------------------------------------------------ -#ifndef MPI - subroutine do_mcm(i_orig) -C Monte-Carlo-with-Minimization calculations - serial code. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.MCM' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.CACHE' -crc include 'COMMON.DEFORM' -crc include 'COMMON.DEFORM1' - include 'COMMON.NAMES' - logical accepted,over,ovrtim,error,lprint,not_done,my_conf, - & enelower,non_conv - integer MoveType,nbond,conf_comp - integer ifeed(max_cache) - double precision varia(maxvar),varold(maxvar),elowest,eold, - & przes(3),obr(3,3) - double precision energia(0:n_ene) - -C--------------------------------------------------------------------------- -C Initialize counters. -C--------------------------------------------------------------------------- -C Total number of generated confs. - ngen=0 -C Total number of moves. In general this won't be equal to the number of -C attempted moves, because we may want to reject some "bad" confs just by -C overlap check. - nmove=0 -C Total number of temperature jumps. - ntherm=0 -C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... -C motions. - ncache=0 - do i=1,nres - nbond_move(i)=0 - enddo -C Initialize total and accepted number of moves of various kind. - do i=0,MaxMoveType - moves(i)=0 - moves_acc(i)=0 - enddo -C Total number of energy evaluations. - neneval=0 - nfun=0 - nsave=0 - - write (iout,*) 'RanFract=',RanFract - - WhatsUp=0 - Kwita=0 - -c---------------------------------------------------------------------------- -C Compute and print initial energies. -c---------------------------------------------------------------------------- - call intout - write (iout,'(/80(1h*)/a)') 'Initial energies:' - call chainbuild - nf=0 - - call etotal(energia(0)) - etot = energia(0) -C Minimize the energy of the first conformation. - if (minim) then - call geom_to_var(nvar,varia) -! write (iout,*) 'The VARIA array' -! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) - call minimize(etot,varia,iretcode,nfun) - call var_to_geom(nvar,varia) - call chainbuild - write (iout,*) 'etot from MINIMIZE:',etot -! write (iout,*) 'Tha VARIA array' -! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) - - call etotal(energia(0)) - etot=energia(0) - call enerprint(energia(0)) - endif - if (refstr) then - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes, - & obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order:',co - if (print_stat) - & write (istat,'(i5,17(1pe14.5))') 0, - & (energia(print_order(i)),i=1,nprint_ene), - & etot,rms,frac,co - else - if (print_stat) write (istat,'(i5,16(1pe14.5))') 0, - & (energia(print_order(i)),i=1,nprint_ene),etot - endif - if (print_stat) close(istat) - neneval=neneval+nfun+1 - write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Enter Monte Carlo procedure.' - if (print_int) then - close(igeom) - call briefout(0,etot) - endif - eold=etot - do i=1,nvar - varold(i)=varia(i) - enddo - elowest=etot - call zapis(varia,etot) - nacc=0 ! total # of accepted confs of the current processor. - nacc_tot=0 ! total # of accepted confs of all processors. - - not_done = (iretcode.ne.11) - -C---------------------------------------------------------------------------- -C Main loop. -c---------------------------------------------------------------------------- - it=0 - nout=0 - do while (not_done) - it=it+1 - write (iout,'(80(1h*)/20x,a,i7)') - & 'Beginning iteration #',it -C Initialize local counter. - ntrial=0 ! # of generated non-overlapping confs. - accepted=.false. - do while (.not. accepted) - -C Retrieve the angles of previously accepted conformation - noverlap=0 ! # of overlapping confs. - do j=1,nvar - varia(j)=varold(j) - enddo - call var_to_geom(nvar,varia) -C Rebuild the chain. - call chainbuild -C Heat up the system, if necessary. - call heat(over) -C If temperature cannot be further increased, stop. - if (over) goto 20 - MoveType=0 - nbond=0 - lprint=.true. -cd write (iout,'(a)') 'Old variables:' -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) -C Decide whether to generate a random conformation or perturb the old one - RandOrPert=ran_number(0.0D0,1.0D0) - if (RandOrPert.gt.RanFract) then - if (print_mc.gt.0) - & write (iout,'(a)') 'Perturbation-generated conformation.' - call perturb(error,lprint,MoveType,nbond,1.0D0) - if (error) goto 20 - if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then - write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=', - & MoveType,' returned from PERTURB.' - goto 20 - endif - call chainbuild - else - MoveType=0 - moves(0)=moves(0)+1 - nstart_grow=iran_num(3,nres) - if (print_mc.gt.0) - & write (iout,'(2a,i3)') 'Random-generated conformation', - & ' - chain regrown from residue',nstart_grow - call gen_rand_conf(nstart_grow,*30) - endif - call geom_to_var(nvar,varia) -cd write (iout,'(a)') 'New variables:' -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - ngen=ngen+1 - - call etotal(energia(0)) - etot=energia(0) -c call enerprint(energia(0)) -c write (iout,'(2(a,1pe14.5))') 'Etot=',Etot,' Elowest=',Elowest - if (etot-elowest.gt.overlap_cut) then - if(iprint.gt.1.or.etot.lt.1d20) - & write (iout,'(a,1pe14.5)') - & 'Overlap detected in the current conf.; energy is',etot - neneval=neneval+1 - accepted=.false. - noverlap=noverlap+1 - if (noverlap.gt.maxoverlap) then - write (iout,'(a)') 'Too many overlapping confs.' - goto 20 - endif - else - if (minim) then - call minimize(etot,varia,iretcode,nfun) -cd write (iout,*) 'etot from MINIMIZE:',etot -cd write (iout,'(a)') 'Variables after minimization:' -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - - call etotal(energia(0)) - etot = energia(0) - neneval=neneval+nfun+2 - endif -c call enerprint(energia(0)) - write (iout,'(a,i6,a,1pe16.6)') 'Conformation:',ngen, - & ' energy:',etot -C-------------------------------------------------------------------------- -C... Do Metropolis test -C-------------------------------------------------------------------------- - accepted=.false. - my_conf=.false. - - if (WhatsUp.eq.0 .and. Kwita.eq.0) then - call metropolis(nvar,varia,varold,etot,eold,accepted, - & my_conf,EneLower,it) - endif - write (iout,*) 'My_Conf=',My_Conf,' EneLower=',EneLower - if (accepted) then - - nacc=nacc+1 - nacc_tot=nacc_tot+1 - if (elowest.gt.etot) elowest=etot - moves_acc(MoveType)=moves_acc(MoveType)+1 - if (MoveType.eq.1) then - nbond_acc(nbond)=nbond_acc(nbond)+1 - endif -C Check against conformation repetitions. - irepet=conf_comp(varia,etot) - if (print_stat) then -#if defined(AIX) || defined(PGI) - open (istat,file=statname,position='append') -#else - open (istat,file=statname,access='append') -#endif - endif - call statprint(nacc,nfun,iretcode,etot,elowest) - if (refstr) then - call var_to_geom(nvar,varia) - call chainbuild - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup), - & nsup,przes,obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order',co - endif ! refstr - if (My_Conf) then - nout=nout+1 - write (iout,*) 'Writing new conformation',nout - if (refstr) then - write (istat,'(i5,16(1pe14.5))') nout, - & (energia(print_order(i)),i=1,nprint_ene), - & etot,rms,frac - else - if (print_stat) - & write (istat,'(i5,17(1pe14.5))') nout, - & (energia(print_order(i)),i=1,nprint_ene),etot - endif ! refstr - if (print_stat) close(istat) -C Print internal coordinates. - if (print_int) call briefout(nout,etot) -C Accumulate the newly accepted conf in the coord1 array, if it is different -C from all confs that are already there. - call compare_s1(n_thr,max_thread2,etot,varia,ii, - & enetb1,coord1,rms_deform,.true.,iprint) - write (iout,*) 'After compare_ss: n_thr=',n_thr - if (ii.eq.1 .or. ii.eq.3) then - write (iout,'(8f10.4)') - & (rad2deg*coord1(i,n_thr),i=1,nvar) - endif - else - write (iout,*) 'Conformation from cache, not written.' - endif ! My_Conf - - if (nrepm.gt.maxrepm) then - write (iout,'(a)') 'Too many conformation repetitions.' - goto 20 - endif -C Store the accepted conf. and its energy. - eold=etot - do i=1,nvar - varold(i)=varia(i) - enddo - if (irepet.eq.0) call zapis(varia,etot) -C Lower the temperature, if necessary. - call cool - - else - - ntrial=ntrial+1 - endif ! accepted - endif ! overlap - - 30 continue - enddo ! accepted -C Check for time limit. - if (ovrtim()) WhatsUp=-1 - not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) - & .and. (Kwita.eq.0) - - enddo ! not_done - goto 21 - 20 WhatsUp=-3 - - 21 continue - runtime=tcpu() - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc,nfun,iretcode,etot,elowest) - write (iout,'(a)') - & 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) - if (it.ge.maxacc) - &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' - - return - end -#endif -#ifdef MPI -c------------------------------------------------------------------------------ - subroutine do_mcm(i_orig) -C Monte-Carlo-with-Minimization calculations - parallel code. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.MCM' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.INFO' - include 'COMMON.CACHE' -crc include 'COMMON.DEFORM' -crc include 'COMMON.DEFORM1' -crc include 'COMMON.DEFORM2' - include 'COMMON.MINIM' - include 'COMMON.NAMES' - logical accepted,over,ovrtim,error,lprint,not_done,similar, - & enelower,non_conv,flag,finish - integer MoveType,nbond,conf_comp - double precision varia(maxvar),varold(maxvar),elowest,eold, - & x1(maxvar), varold1(maxvar), przes(3),obr(3,3) - integer iparentx(max_threadss2) - integer iparentx1(max_threadss2) - integer imtasks(150),imtasks_n - double precision energia(0:n_ene) - - print *,'Master entered DO_MCM' - nodenum = nprocs - - finish=.false. - imtasks_n=0 - do i=1,nodenum-1 - imtasks(i)=0 - enddo -C--------------------------------------------------------------------------- -C Initialize counters. -C--------------------------------------------------------------------------- -C Total number of generated confs. - ngen=0 -C Total number of moves. In general this won`t be equal to the number of -C attempted moves, because we may want to reject some "bad" confs just by -C overlap check. - nmove=0 -C Total number of temperature jumps. - ntherm=0 -C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... -C motions. - ncache=0 - do i=1,nres - nbond_move(i)=0 - enddo -C Initialize total and accepted number of moves of various kind. - do i=0,MaxMoveType - moves(i)=0 - moves_acc(i)=0 - enddo -C Total number of energy evaluations. - neneval=0 - nfun=0 - nsave=0 -c write (iout,*) 'RanFract=',RanFract - WhatsUp=0 - Kwita=0 -c---------------------------------------------------------------------------- -C Compute and print initial energies. -c---------------------------------------------------------------------------- - call intout - write (iout,'(/80(1h*)/a)') 'Initial energies:' - call chainbuild - nf=0 - call etotal(energia(0)) - etot = energia(0) - call enerprint(energia(0)) -C Request energy computation from slave processors. - call geom_to_var(nvar,varia) -! write (iout,*) 'The VARIA array' -! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) - call minimize(etot,varia,iretcode,nfun) - call var_to_geom(nvar,varia) - call chainbuild - write (iout,*) 'etot from MINIMIZE:',etot -! write (iout,*) 'Tha VARIA array' -! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) - neneval=0 - eneglobal=1.0d99 - if (print_mc .gt. 0) write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Enter Monte Carlo procedure.' - if (print_mc .gt. 0) write (iout,'(i5,1pe14.5)' ) i_orig,etot - eold=etot - do i=1,nvar - varold(i)=varia(i) - enddo - elowest=etot - call zapis(varia,etot) -c diagnostics - call var_to_geom(nvar,varia) - call chainbuild - call etotal(energia(0)) - if (print_mc.gt.0) write (iout,*) 'Initial energy:',etot -c end diagnostics - nacc=0 ! total # of accepted confs of the current processor. - nacc_tot=0 ! total # of accepted confs of all processors. - not_done=.true. -C---------------------------------------------------------------------------- -C Main loop. -c---------------------------------------------------------------------------- - it=0 - nout=0 - LOOP1:do while (not_done) - it=it+1 - if (print_mc.gt.0) write (iout,'(80(1h*)/20x,a,i7)') - & 'Beginning iteration #',it -C Initialize local counter. - ntrial=0 ! # of generated non-overlapping confs. - noverlap=0 ! # of overlapping confs. - accepted=.false. - LOOP2:do while (.not. accepted) - - LOOP3:do while (imtasks_n.lt.nodenum-1.and..not.finish) - do i=1,nodenum-1 - if(imtasks(i).eq.0) then - is=i - exit - endif - enddo -C Retrieve the angles of previously accepted conformation - do j=1,nvar - varia(j)=varold(j) - enddo - call var_to_geom(nvar,varia) -C Rebuild the chain. - call chainbuild -C Heat up the system, if necessary. - call heat(over) -C If temperature cannot be further increased, stop. - if (over) then - finish=.true. - endif - MoveType=0 - nbond=0 -c write (iout,'(a)') 'Old variables:' -c write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) -C Decide whether to generate a random conformation or perturb the old one - RandOrPert=ran_number(0.0D0,1.0D0) - if (RandOrPert.gt.RanFract) then - if (print_mc.gt.0) - & write (iout,'(a)') 'Perturbation-generated conformation.' - call perturb(error,lprint,MoveType,nbond,1.0D0) -c print *,'after perturb',error,finish - if (error) finish = .true. - if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then - write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=', - & MoveType,' returned from PERTURB.' - finish=.true. - write (*,'(/a,i7,a/)') 'Error - unknown MoveType=', - & MoveType,' returned from PERTURB.' - endif - call chainbuild - else - MoveType=0 - moves(0)=moves(0)+1 - nstart_grow=iran_num(3,nres) - if (print_mc.gt.0) - & write (iout,'(2a,i3)') 'Random-generated conformation', - & ' - chain regrown from residue',nstart_grow - call gen_rand_conf(nstart_grow,*30) - endif - call geom_to_var(nvar,varia) - ngen=ngen+1 -c print *,'finish=',finish - if (etot-elowest.gt.overlap_cut) then - if (print_mc.gt.1) write (iout,'(a,1pe14.5)') - & 'Overlap detected in the current conf.; energy is',etot - if(iprint.gt.1.or.etot.lt.1d19) print *, - & 'Overlap detected in the current conf.; energy is',etot - neneval=neneval+1 - accepted=.false. - noverlap=noverlap+1 - if (noverlap.gt.maxoverlap) then - write (iout,*) 'Too many overlapping confs.', - & ' etot, elowest, overlap_cut', etot, elowest, overlap_cut - finish=.true. - endif - else if (.not. finish) then -C Distribute tasks to processors -c print *,'Master sending order' - call MPI_SEND(12, 1, MPI_INTEGER, is, tag, - & CG_COMM, ierr) -c write (iout,*) '12: tag=',tag -c print *,'Master sent order to processor',is - call MPI_SEND(it, 1, MPI_INTEGER, is, tag, - & CG_COMM, ierr) -c write (iout,*) 'it: tag=',tag - call MPI_SEND(eold, 1, MPI_DOUBLE_PRECISION, is, tag, - & CG_COMM, ierr) -c write (iout,*) 'eold: tag=',tag - call MPI_SEND(varia(1), nvar, MPI_DOUBLE_PRECISION, - & is, tag, - & CG_COMM, ierr) -c write (iout,*) 'varia: tag=',tag - call MPI_SEND(varold(1), nvar, MPI_DOUBLE_PRECISION, - & is, tag, - & CG_COMM, ierr) -c write (iout,*) 'varold: tag=',tag -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - imtasks(is)=1 - imtasks_n=imtasks_n+1 -C End distribution - endif ! overlap - enddo LOOP3 - - flag = .false. - LOOP_RECV:do while(.not.flag) - do is=1, nodenum-1 - call MPI_IPROBE(is,tag,CG_COMM,flag,status,ierr) - if(flag) then - call MPI_RECV(iitt, 1, MPI_INTEGER, is, tag, - & CG_COMM, status, ierr) - call MPI_RECV(eold1, 1, MPI_DOUBLE_PRECISION, is, tag, - & CG_COMM, status, ierr) - call MPI_RECV(etot, 1, MPI_DOUBLE_PRECISION, is, tag, - & CG_COMM, status, ierr) - call MPI_RECV(varia(1), nvar, MPI_DOUBLE_PRECISION,is,tag, - & CG_COMM, status, ierr) - call MPI_RECV(varold1(1), nvar, MPI_DOUBLE_PRECISION, is, - & tag, CG_COMM, status, ierr) - call MPI_RECV(ii_grnum_d, 1, MPI_INTEGER, is, tag, - & CG_COMM, status, ierr) - call MPI_RECV(ii_ennum_d, 1, MPI_INTEGER, is, tag, - & CG_COMM, status, ierr) - call MPI_RECV(ii_hesnum_d, 1, MPI_INTEGER, is, tag, - & CG_COMM, status, ierr) - i_grnum_d=i_grnum_d+ii_grnum_d - i_ennum_d=i_ennum_d+ii_ennum_d - neneval = neneval+ii_ennum_d - i_hesnum_d=i_hesnum_d+ii_hesnum_d - i_minimiz=i_minimiz+1 - imtasks(is)=0 - imtasks_n=imtasks_n-1 - exit - endif - enddo - enddo LOOP_RECV - - if(print_mc.gt.0) write (iout,'(a,i6,a,i6,a,i6,a,1pe16.6)') - & 'From Worker #',is,' iitt',iitt, - & ' Conformation:',ngen,' energy:',etot -C-------------------------------------------------------------------------- -C... Do Metropolis test -C-------------------------------------------------------------------------- - call metropolis(nvar,varia,varold1,etot,eold1,accepted, - & similar,EneLower) - if(iitt.ne.it.and..not.similar) then - call metropolis(nvar,varia,varold,etot,eold,accepted, - & similar,EneLower) - accepted=enelower - endif - if(etot.lt.eneglobal)eneglobal=etot -c if(mod(it,100).eq.0) - write(iout,*)'CHUJOJEB ',neneval,eneglobal - if (accepted) then -C Write the accepted conformation. - nout=nout+1 - if (refstr) then - call var_to_geom(nvar,varia) - call chainbuild - kkk=1 - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup,kkk), - & nsup,przes,obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order:',co - endif ! refstr - if (print_mc.gt.0) - & write (iout,*) 'Writing new conformation',nout - if (print_stat) then - call var_to_geom(nvar,varia) -#if defined(AIX) || defined(PGI) - open (istat,file=statname,position='append') -#else - open (istat,file=statname,access='append') -#endif - if (refstr) then - write (istat,'(i5,16(1pe14.5))') nout, - & (energia(print_order(i)),i=1,nprint_ene), - & etot,rms,frac - else - write (istat,'(i5,16(1pe14.5))') nout, - & (energia(print_order(i)),i=1,nprint_ene),etot - endif ! refstr - close(istat) - endif ! print_stat -C Print internal coordinates. - if (print_int) call briefout(nout,etot) - nacc=nacc+1 - nacc_tot=nacc_tot+1 - if (elowest.gt.etot) elowest=etot - moves_acc(MoveType)=moves_acc(MoveType)+1 - if (MoveType.eq.1) then - nbond_acc(nbond)=nbond_acc(nbond)+1 - endif -C Check against conformation repetitions. - irepet=conf_comp(varia,etot) - if (nrepm.gt.maxrepm) then - if (print_mc.gt.0) - & write (iout,'(a)') 'Too many conformation repetitions.' - finish=.true. - endif -C Store the accepted conf. and its energy. - eold=etot - do i=1,nvar - varold(i)=varia(i) - enddo - if (irepet.eq.0) call zapis(varia,etot) -C Lower the temperature, if necessary. - call cool - else - ntrial=ntrial+1 - endif ! accepted - 30 continue - if(finish.and.imtasks_n.eq.0)exit LOOP2 - enddo LOOP2 ! accepted -C Check for time limit. - not_done = (it.lt.max_mcm_it) .and. (nacc_tot.lt.maxacc) - if(.not.not_done .or. finish) then - if(imtasks_n.gt.0) then - not_done=.true. - else - not_done=.false. - endif - finish=.true. - endif - enddo LOOP1 ! not_done - runtime=tcpu() - if (print_mc.gt.0) then - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc,nfun,iretcode,etot,elowest) - write (iout,'(a)') - & 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) - if (it.ge.maxacc) - &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' - endif -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - do is=1,nodenum-1 - call MPI_SEND(999, 1, MPI_INTEGER, is, tag, - & CG_COMM, ierr) - enddo - return - end -c------------------------------------------------------------------------------ - subroutine execute_slave(nodeinfo,iprint) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.TIME1' - include 'COMMON.IOUNITS' -crc include 'COMMON.DEFORM' -crc include 'COMMON.DEFORM1' -crc include 'COMMON.DEFORM2' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.INFO' - include 'COMMON.MINIM' - character*10 nodeinfo - double precision x(maxvar),x1(maxvar) - nodeinfo='chujwdupe' -c print *,'Processor:',MyID,' Entering execute_slave' - tag=0 -c call MPI_SEND(nodeinfo, 10, MPI_CHARACTER, 0, tag, -c & CG_COMM, ierr) - -1001 call MPI_RECV(i_switch, 1, MPI_INTEGER, 0, tag, - & CG_COMM, status, ierr) -c write(iout,*)'12: tag=',tag - if(iprint.ge.2)print *, MyID,' recv order ',i_switch - if (i_switch.eq.12) then - i_grnum_d=0 - i_ennum_d=0 - i_hesnum_d=0 - call MPI_RECV(iitt, 1, MPI_INTEGER, 0, tag, - & CG_COMM, status, ierr) -c write(iout,*)'12: tag=',tag - call MPI_RECV(ener, 1, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, status, ierr) -c write(iout,*)'ener: tag=',tag - call MPI_RECV(x(1), nvar, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, status, ierr) -c write(iout,*)'x: tag=',tag - call MPI_RECV(x1(1), nvar, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, status, ierr) -c write(iout,*)'x1: tag=',tag -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif -c print *,'calling minimize' - call minimize(energyx,x,iretcode,nfun) - if(iprint.gt.0) - & write(iout,100)'minimized energy = ',energyx, - & ' # funeval:',nfun,' iret ',iretcode - write(*,100)'minimized energy = ',energyx, - & ' # funeval:',nfun,' iret ',iretcode - 100 format(a20,f10.5,a12,i5,a6,i2) - if(iretcode.eq.10) then - do iminrep=2,3 - if(iprint.gt.1) - & write(iout,*)' ... not converged - trying again ',iminrep - call minimize(energyx,x,iretcode,nfun) - if(iprint.gt.1) - & write(iout,*)'minimized energy = ',energyx, - & ' # funeval:',nfun,' iret ',iretcode - if(iretcode.ne.10)go to 812 - enddo - if(iretcode.eq.10) then - if(iprint.gt.1) - & write(iout,*)' ... not converged again - giving up' - go to 812 - endif - endif -812 continue -c print *,'Sending results' - call MPI_SEND(iitt, 1, MPI_INTEGER, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(ener, 1, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(energyx, 1, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(x(1), nvar, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(x1(1), nvar, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(i_grnum_d, 1, MPI_INTEGER, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(nfun, 1, MPI_INTEGER, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(i_hesnum_d, 1, MPI_INTEGER, 0, tag, - & CG_COMM, ierr) -c print *,'End sending' - go to 1001 - endif - - return - end -#endif -c------------------------------------------------------------------------------ - subroutine statprint(it,nfun,iretcode,etot,elowest) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'COMMON.MCM' - if (minim) then - write (iout, - & '(80(1h*)/a,i5,a,1pe14.5,a,1pe14.5/a,i3,a,i10,a,i5,a,i5)') - & 'Finished iteration #',it,' energy is',etot, - & ' lowest energy:',elowest, - & 'SUMSL return code:',iretcode, - & ' # of energy evaluations:',neneval, - & '# of temperature jumps:',ntherm, - & ' # of minima repetitions:',nrepm - else - write (iout,'(80(1h*)/a,i8,a,1pe14.5,a,1pe14.5)') - & 'Finished iteration #',it,' energy is',etot, - & ' lowest energy:',elowest - endif - write (iout,'(/4a)') - & 'Kind of move ',' total',' accepted', - & ' fraction' - write (iout,'(58(1h-))') - do i=-1,MaxMoveType - if (moves(i).eq.0) then - fr_mov_i=0.0d0 - else - fr_mov_i=dfloat(moves_acc(i))/dfloat(moves(i)) - endif - write(iout,'(a,2i15,f10.5)')MovTypID(i),moves(i),moves_acc(i), - & fr_mov_i - enddo - write (iout,'(a,2i15,f10.5)') 'total ',nmove,nacc_tot, - & dfloat(nacc_tot)/dfloat(nmove) - write (iout,'(58(1h-))') - write (iout,'(a,1pe12.4)') 'Elapsed time:',tcpu() - return - end -c------------------------------------------------------------------------------ - subroutine heat(over) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - logical over -C Check if there`s a need to increase temperature. - if (ntrial.gt.maxtrial) then - if (NstepH.gt.0) then - if (dabs(Tcur-TMax).lt.1.0D-7) then - if (print_mc.gt.0) - & write (iout,'(/80(1h*)/a,f8.3,a/80(1h*))') - & 'Upper limit of temperature reached. Terminating.' - over=.true. - Tcur=Tmin - else - Tcur=Tcur*TstepH - if (Tcur.gt.Tmax) Tcur=Tmax - betbol=1.0D0/(Rbol*Tcur) - if (print_mc.gt.0) - & write (iout,'(/80(1h*)/a,f8.3,a,f10.5/80(1h*))') - & 'System heated up to ',Tcur,' K; BetBol:',betbol - ntherm=ntherm+1 - ntrial=0 - over=.false. - endif - else - if (print_mc.gt.0) - & write (iout,'(a)') - & 'Maximum number of trials in a single MCM iteration exceeded.' - over=.true. - Tcur=Tmin - endif - else - over=.false. - endif - return - end -c------------------------------------------------------------------------------ - subroutine cool - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - if (nstepC.gt.0 .and. dabs(Tcur-Tmin).gt.1.0D-7) then - Tcur=Tcur/TstepC - if (Tcur.lt.Tmin) Tcur=Tmin - betbol=1.0D0/(Rbol*Tcur) - if (print_mc.gt.0) - & write (iout,'(/80(1h*)/a,f8.3,a,f10.5/80(1h*))') - & 'System cooled down up to ',Tcur,' K; BetBol:',betbol - endif - return - end -C--------------------------------------------------------------------------- - subroutine zapis(varia,etot) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MP - include 'mpif.h' - include 'COMMON.INFO' -#endif - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - integer itemp(maxsave) - double precision varia(maxvar) - logical lprint - lprint=.false. - if (lprint) then - write (iout,'(a,i5,a,i5)') 'Enter ZAPIS NSave=',Nsave, - & ' MaxSave=',MaxSave - write (iout,'(a)') 'Current energy and conformation:' - write (iout,'(1pe14.5)') etot - write (iout,'(10f8.3)') (rad2deg*varia(i),i=1,nvar) - endif -C Shift the contents of the esave and varsave arrays if filled up. - call add2cache(maxvar,maxsave,nsave,nvar,MyID,itemp, - & etot,varia,esave,varsave) - if (lprint) then - write (iout,'(a)') 'Energies and the VarSave array.' - do i=1,nsave - write (iout,'(i5,1pe14.5)') i,esave(i) - write (iout,'(10f8.3)') (rad2deg*varsave(j,i),j=1,nvar) - enddo - endif - return - end -C--------------------------------------------------------------------------- - subroutine perturb(error,lprint,MoveType,nbond,max_phi) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (MMaxSideMove=100) - include 'COMMON.MCM' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' -crc include 'COMMON.DEFORM1' - logical error,lprint,fail - integer MoveType,nbond,end_select,ind_side(MMaxSideMove) - double precision max_phi - double precision psi,gen_psi - external iran_num - integer iran_num - integer ifour - data ifour /4/ - error=.false. - lprint=.false. -C Perturb the conformation according to a randomly selected move. - call SelectMove(MoveType) -c write (iout,*) 'MoveType=',MoveType - itrial=0 - goto (100,200,300,400,500) MoveType -C------------------------------------------------------------------------------ -C Backbone N-bond move. -C Select the number of bonds (length of the segment to perturb). - 100 continue - if (itrial.gt.1000) then - write (iout,'(a)') 'Too many attempts at multiple-bond move.' - error=.true. - return - endif - bond_prob=ran_number(0.0D0,sumpro_bond(nbm)) -c print *,'sumpro_bond(nbm)=',sumpro_bond(nbm), -c & ' Bond_prob=',Bond_Prob - do i=1,nbm-1 -c print *,i,Bond_Prob,sumpro_bond(i),sumpro_bond(i+1) - if (bond_prob.ge.sumpro_bond(i) .and. - & bond_prob.le.sumpro_bond(i+1)) then - nbond=i+1 - goto 10 - endif - enddo - write (iout,'(2a)') 'In PERTURB: Error - number of bonds', - & ' to move out of range.' - error=.true. - return - 10 continue - if (nwindow.gt.0) then -C Select the first residue to perturb - iwindow=iran_num(1,nwindow) - print *,'iwindow=',iwindow - iiwin=1 - do while (winlen(iwindow).lt.nbond) - iwindow=iran_num(1,nwindow) - iiwin=iiwin+1 - if (iiwin.gt.1000) then - write (iout,'(a)') 'Cannot select moveable residues.' - error=.true. - return - endif - enddo - nstart=iran_num(winstart(iwindow),winend(iwindow)) - else - nstart = iran_num(koniecl+2,nres-nbond-koniecl) -cd print *,'nres=',nres,' nbond=',nbond,' koniecl=',koniecl, -cd & ' nstart=',nstart - endif - psi = gen_psi() - if (psi.eq.0.0) then - error=.true. - return - endif - if (print_mc.gt.1) write (iout,'(a,i4,a,i4,a,f8.3)') - & 'PERTURB: nbond=',nbond,' nstart=',nstart,' psi=',psi*rad2deg -cd print *,'nstart=',nstart - call bond_move(nbond,nstart,psi,.false.,error) - if (error) then - write (iout,'(2a)') - & 'Could not define reference system in bond_move, ', - & 'choosing ahother segment.' - itrial=itrial+1 - goto 100 - endif - nbond_move(nbond)=nbond_move(nbond)+1 - moves(1)=moves(1)+1 - nmove=nmove+1 - return -C------------------------------------------------------------------------------ -C Backbone endmove. Perturb a SINGLE angle of a residue close to the end of -C the chain. - 200 continue - lprint=.true. -c end_select=iran_num(1,2*koniecl) -c if (end_select.gt.koniecl) then -c end_select=nphi-(end_select-koniecl) -c else -c end_select=koniecl+3 -c endif -c if (nwindow.gt.0) then -c iwin=iran_num(1,nwindow) -c i1=max0(4,winstart(iwin)) -c i2=min0(winend(imin)+2,nres) -c end_select=iran_num(i1,i2) -c else -c iselect = iran_num(1,nmov_var) -c jj = 0 -c do i=1,nphi -c if (isearch_tab(i).eq.1) jj = jj+1 -c if (jj.eq.iselect) then -c end_select=i+3 -c exit -c endif -c enddo -c endif - end_select = iran_num(4,nres) - psi=max_phi*gen_psi() - if (psi.eq.0.0D0) then - error=.true. - return - endif - phi(end_select)=pinorm(phi(end_select)+psi) - if (print_mc.gt.1) write (iout,'(a,i4,a,f8.3,a,f8.3)') - & 'End angle',end_select,' moved by ',psi*rad2deg,' new angle:', - & phi(end_select)*rad2deg -c if (end_select.gt.3) -c & theta(end_select-1)=gen_theta(itype(end_select-2), -c & phi(end_select-1),phi(end_select)) -c if (end_select.lt.nres) -c & theta(end_select)=gen_theta(itype(end_select-1), -c & phi(end_select),phi(end_select+1)) -cd print *,'nres=',nres,' end_select=',end_select -cd print *,'theta',end_select-1,theta(end_select-1) -cd print *,'theta',end_select,theta(end_select) - moves(2)=moves(2)+1 - nmove=nmove+1 - lprint=.false. - return -C------------------------------------------------------------------------------ -C Side chain move. -C Select the number of SCs to perturb. - 300 isctry=0 - 301 nside_move=iran_num(1,MaxSideMove) -c print *,'nside_move=',nside_move,' MaxSideMove',MaxSideMove -C Select the indices. - do i=1,nside_move - icount=0 - 111 inds=iran_num(nnt,nct) - icount=icount+1 - if (icount.gt.1000) then - write (iout,'(a)')'Error - cannot select side chains to move.' - error=.true. - return - endif - if (itype(inds).eq.10) goto 111 - do j=1,i-1 - if (inds.eq.ind_side(j)) goto 111 - enddo - do j=1,i-1 - if (inds.lt.ind_side(j)) then - indx=j - goto 112 - endif - enddo - indx=i - 112 do j=i,indx+1,-1 - ind_side(j)=ind_side(j-1) - enddo - 113 ind_side(indx)=inds - enddo -C Carry out perturbation. - do i=1,nside_move - ii=ind_side(i) - iti=itype(ii) - call gen_side(iti,theta(ii+1),alph(ii),omeg(ii),fail) - if (fail) then - isctry=isctry+1 - if (isctry.gt.1000) then - write (iout,'(a)') 'Too many errors in SC generation.' - error=.true. - return - endif - goto 301 - endif - if (print_mc.gt.1) write (iout,'(2a,i4,a,2f8.3)') - & 'Side chain ',restyp(iti),ii,' moved to ', - & alph(ii)*rad2deg,omeg(ii)*rad2deg - enddo - moves(3)=moves(3)+1 - nmove=nmove+1 - return -C------------------------------------------------------------------------------ -C THETA move - 400 end_select=iran_num(3,nres) - theta_new=gen_theta(itype(end_select),phi(end_select), - & phi(end_select+1)) - if (print_mc.gt.1) write (iout,'(a,i3,a,f8.3,a,f8.3)') - & 'Theta ',end_select,' moved from',theta(end_select)*rad2deg, - & ' to ',theta_new*rad2deg - theta(end_select)=theta_new - moves(4)=moves(4)+1 - nmove=nmove+1 - return -C------------------------------------------------------------------------------ -C Error returned from SelectMove. - 500 error=.true. - return - end -C------------------------------------------------------------------------------ - subroutine SelectMove(MoveType) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - what_move=ran_number(0.0D0,sumpro_type(MaxMoveType)) - do i=1,MaxMoveType - if (what_move.ge.sumpro_type(i-1).and. - & what_move.lt.sumpro_type(i)) then - MoveType=i - return - endif - enddo - write (iout,'(a)') - & 'Fatal error in SelectMoveType: cannot select move.' - MoveType=MaxMoveType+1 - return - end -c---------------------------------------------------------------------------- - double precision function gen_psi() - implicit none - integer i - double precision x,ran_number - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - x=0.0D0 - do i=1,100 - x=ran_number(-pi,pi) - if (dabs(x).gt.angmin) then - gen_psi=x - return - endif - enddo - write (iout,'(a)')'From Gen_Psi: Cannot generate angle increment.' - gen_psi=0.0D0 - return - end -c---------------------------------------------------------------------------- - subroutine metropolis(n,xcur,xold,ecur,eold,accepted,similar, - & enelower) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' -crc include 'COMMON.DEFORM' - double precision ecur,eold,xx,ran_number,bol - double precision xcur(n),xold(n) - double precision ecut1 ,ecut2 ,tola - logical accepted,similar,not_done,enelower - logical lprn - data ecut1 /-1.0D-5/,ecut2 /5.0D-3/,tola/5.0D0/ -! ecut1=-5*enedif -! ecut2=50*enedif -! tola=5.0d0 -C Set lprn=.true. for debugging. - lprn=.false. - if (lprn) - &write(iout,*)'enedif',enedif,' ecut1',ecut1,' ecut2',ecut2 - similar=.false. - enelower=.false. - accepted=.false. -C Check if the conformation is similar. - difene=ecur-eold - reldife=difene/dmax1(dabs(eold),dabs(ecur),1.0D0) - if (lprn) then - write (iout,*) 'Metropolis' - write(iout,*)'ecur,eold,difene,reldife',ecur,eold,difene,reldife - endif -C If energy went down remarkably, we accept the new conformation -C unconditionally. -cjp if (reldife.lt.ecut1) then - if (difene.lt.ecut1) then - accepted=.true. - EneLower=.true. - if (lprn) write (iout,'(a)') - & 'Conformation accepted, because energy has lowered remarkably.' -! elseif (reldife.lt.ecut2 .and. dif_ang(nphi,xcur,xold).lt.tola) -cjp elseif (reldife.lt.ecut2) - elseif (difene.lt.ecut2) - & then -C Reject the conf. if energy has changed insignificantly and there is not -C much change in conformation. - if (lprn) - & write (iout,'(2a)') 'Conformation rejected, because it is', - & ' similar to the preceding one.' - accepted=.false. - similar=.true. - else -C Else carry out Metropolis test. - EneLower=.false. - xx=ran_number(0.0D0,1.0D0) - xxh=betbol*difene - if (lprn) - & write (iout,*) 'betbol=',betbol,' difene=',difene,' xxh=',xxh - if (xxh.gt.50.0D0) then - bol=0.0D0 - else - bol=exp(-xxh) - endif - if (lprn) write (iout,*) 'bol=',bol,' xx=',xx - if (bol.gt.xx) then - accepted=.true. - if (lprn) write (iout,'(a)') - & 'Conformation accepted, because it passed Metropolis test.' - else - accepted=.false. - if (lprn) write (iout,'(a)') - & 'Conformation rejected, because it did not pass Metropolis test.' - endif - endif -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - return - end -c------------------------------------------------------------------------------ - integer function conf_comp(x,ene) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - double precision etol , angtol - double precision x(maxvar) - double precision dif_ang,difa - data etol /0.1D0/, angtol /20.0D0/ - do ii=nsave,1,-1 -c write (iout,*) 'ii=',ii,'ene=',ene,esave(ii),dabs(ene-esave(ii)) - if (dabs(ene-esave(ii)).lt.etol) then - difa=dif_ang(nphi,x,varsave(1,ii)) -c do i=1,nphi -c write(iout,'(i3,3f8.3)')i,rad2deg*x(i), -c & rad2deg*varsave(i,ii) -c enddo -c write(iout,*) 'ii=',ii,' difa=',difa,' angtol=',angtol - if (difa.le.angtol) then - if (print_mc.gt.0) then - write (iout,'(a,i5,2(a,1pe15.4))') - & 'Current conformation matches #',ii, - & ' in the store array ene=',ene,' esave=',esave(ii) -c write (*,'(a,i5,a)') 'Current conformation matches #',ii, -c & ' in the store array.' - endif ! print_mc.gt.0 - if (print_mc.gt.1) then - do i=1,nphi - write(iout,'(i3,3f8.3)')i,rad2deg*x(i), - & rad2deg*varsave(i,ii) - enddo - endif ! print_mc.gt.1 - nrepm=nrepm+1 - conf_comp=ii - return - endif - endif - enddo - conf_comp=0 - return - end -C---------------------------------------------------------------------------- - double precision function dif_ang(n,x,y) - implicit none - integer i,n - double precision x(n),y(n) - double precision w,wa,dif,difa - double precision pinorm - include 'COMMON.GEO' - wa=0.0D0 - difa=0.0D0 - do i=1,n - dif=dabs(pinorm(y(i)-x(i))) - if (dabs(dif-dwapi).lt.dif) dif=dabs(dif-dwapi) - w=1.0D0-(2.0D0*(i-1)/(n-1)-1.0D0)**2+1.0D0/n - wa=wa+w - difa=difa+dif*dif*w - enddo - dif_ang=rad2deg*dsqrt(difa/wa) - return - end -c-------------------------------------------------------------------------- - subroutine add2cache(n1,n2,ncache,nvar,SourceID,CachSrc, - & ecur,xcur,ecache,xcache) - implicit none - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - integer n1,n2,ncache,nvar,SourceID,CachSrc(n2) - integer i,ii,j - double precision ecur,xcur(nvar),ecache(n2),xcache(n1,n2) -cd write (iout,*) 'Enter ADD2CACHE ncache=',ncache ,' ecur',ecur -cd write (iout,'(10f8.3)') (rad2deg*xcur(i),i=1,nvar) -cd write (iout,*) 'Old CACHE array:' -cd do i=1,ncache -cd write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) -cd write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) -cd enddo - - i=ncache - do while (i.gt.0 .and. ecur.lt.ecache(i)) - i=i-1 - enddo - i=i+1 -cd write (iout,*) 'i=',i,' ncache=',ncache - if (ncache.eq.n2) then - write (iout,*) 'Cache dimension exceeded',ncache,n2 - write (iout,*) 'Highest-energy conformation will be removed.' - ncache=ncache-1 - endif - do ii=ncache,i,-1 - ecache(ii+1)=ecache(ii) - CachSrc(ii+1)=CachSrc(ii) - do j=1,nvar - xcache(j,ii+1)=xcache(j,ii) - enddo - enddo - ecache(i)=ecur - CachSrc(i)=SourceID - do j=1,nvar - xcache(j,i)=xcur(j) - enddo - ncache=ncache+1 -cd write (iout,*) 'New CACHE array:' -cd do i=1,ncache -cd write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) -cd write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) -cd enddo - return - end -c-------------------------------------------------------------------------- - subroutine rm_from_cache(i,n1,n2,ncache,nvar,CachSrc,ecache, - & xcache) - implicit none - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - integer n1,n2,ncache,nvar,CachSrc(n2) - integer i,ii,j - double precision ecache(n2),xcache(n1,n2) - -cd write (iout,*) 'Enter RM_FROM_CACHE' -cd write (iout,*) 'Old CACHE array:' -cd do ii=1,ncache -cd write (iout,*)'i=',ii,' ecache=',ecache(ii),' CachSrc',CachSrc(ii) -cd write (iout,'(10f8.3)') (rad2deg*xcache(j,ii),j=1,nvar) -cd enddo - - do ii=i+1,ncache - ecache(ii-1)=ecache(ii) - CachSrc(ii-1)=CachSrc(ii) - do j=1,nvar - xcache(j,ii-1)=xcache(j,ii) - enddo - enddo - ncache=ncache-1 -cd write (iout,*) 'New CACHE array:' -cd do i=1,ncache -cd write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) -cd write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) -cd enddo - return - end diff --git a/source/unres/src_MD-M-newcorr/minim_jlee.F b/source/unres/src_MD-M-newcorr/minim_jlee.F deleted file mode 100644 index d83b15b..0000000 --- a/source/unres/src_MD-M-newcorr/minim_jlee.F +++ /dev/null @@ -1,435 +0,0 @@ - subroutine minim_jlee -c controls minimization and sorting routines - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.MINIM' - include 'COMMON.CONTROL' - include 'mpif.h' - external func,gradient,fdum - real ran1,ran2,ran3 - include 'COMMON.SETUP' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' - include 'COMMON.CHAIN' - dimension muster(mpi_status_size) - dimension var(maxvar),erg(mxch*(mxch+1)/2+1) - dimension var2(maxvar) - integer iffr(maxres),ihpbt(maxdim),jhpbt(maxdim) - double precision d(maxvar),v(1:lv+1),garbage(maxvar) - double precision energia(0:n_ene),time0s,time1s - dimension indx(9),info(12) - dimension iv(liv) - dimension idum(1),rdum(1) - dimension icont(2,maxcont) - logical check_var,fail - integer iloop(2) - common /przechowalnia/ v - data rad /1.745329252d-2/ -c receive # of start -! print *,'Processor',me,' calling MINIM_JLEE maxfun',maxfun, -! & ' maxmin',maxmin,' tolf',tolf,' rtolf',rtolf - nhpb0=nhpb - 10 continue - time0s=MPI_WTIME() -c print *, 'MINIM_JLEE: ',me,' is waiting' - call mpi_recv(info,12,mpi_integer,king,idint,CG_COMM, - * muster,ierr) - time1s=MPI_WTIME() - write (iout,'(a12,f10.4,a4)')'Waiting for ',time1s-time0s,' sec' - call flush(iout) - n=info(1) -c print *, 'MINIM_JLEE: ',me,' received: ',n - -crc if (ierr.ne.0) go to 100 -c if # = 0, return - if (n.eq.0) then - write (iout,*) 'Finishing minim_jlee - signal',n,' from master' - call flush(iout) - return - endif - - nfun=0 - IF (n.lt.0) THEN - call mpi_recv(var,nvar,mpi_double_precision, - * king,idreal,CG_COMM,muster,ierr) - call mpi_recv(iffr,nres,mpi_integer, - * king,idint,CG_COMM,muster,ierr) - call mpi_recv(var2,nvar,mpi_double_precision, - * king,idreal,CG_COMM,muster,ierr) - ELSE -c receive initial values of variables - call mpi_recv(var,nvar,mpi_double_precision, - * king,idreal,CG_COMM,muster,ierr) -crc if (ierr.ne.0) go to 100 - ENDIF - - if(vdisulf.and.info(2).ne.-1) then - if(info(4).ne.0)then - call mpi_recv(ihpbt,info(4),mpi_integer, - * king,idint,CG_COMM,muster,ierr) - call mpi_recv(jhpbt,info(4),mpi_integer, - * king,idint,CG_COMM,muster,ierr) - endif - endif - - IF (n.lt.0) THEN - n=-n - nhpb=nhpb0 - link_start=1 - link_end=nhpb - call init_int_table - call contact_cp(var,var2,iffr,nfun,n) - ENDIF - - if(vdisulf.and.info(2).ne.-1) then - nss=0 - if(info(4).ne.0)then -cd write(iout,*) 'SS=',info(4),'N=',info(1),'IT=',info(2) - call var_to_geom(nvar,var) - call chainbuild - do i=1,info(4) - if (dist(ihpbt(i),jhpbt(i)).lt.7.0) then - nss=nss+1 - ihpb(nss)=ihpbt(i) - jhpb(nss)=jhpbt(i) -cd write(iout,*) 'SS mv=',info(3), -cd & ihpb(nss)-nres,jhpb(nss)-nres, -cd & dist(ihpb(nss),jhpb(nss)) - dhpb(nss)=dbr - forcon(nss)=fbr - else -cd write(iout,*) 'rm SS mv=',info(3), -cd & ihpbt(i)-nres,jhpbt(i)-nres,dist(ihpbt(i),jhpbt(i)) - endif - enddo - endif - nhpb=nss - link_start=1 - link_end=nhpb - call init_int_table - endif - - if (info(3).eq.14) then - write(iout,*) 'calling local_move',info(7),info(8) - call local_move_init(.false.) - call var_to_geom(nvar,var) - call local_move(info(7),info(8),20d0,50d0) - call geom_to_var(nvar,var) - endif - - - if (info(3).eq.16) then - write(iout,*) 'calling beta_slide',info(7),info(8), - & info(10), info(11), info(12) - call var_to_geom(nvar,var) - call beta_slide(info(7),info(8),info(10),info(11),info(12) - & ,nfun,n) - call geom_to_var(nvar,var) - endif - - - if (info(3).eq.17) then - write(iout,*) 'calling beta_zip',info(7),info(8) - call var_to_geom(nvar,var) - call beta_zip(info(7),info(8),nfun,n) - call geom_to_var(nvar,var) - endif - - -crc overlap test - - if (overlapsc) then - - call var_to_geom(nvar,var) - call chainbuild - call etotal(energia(0)) - nfun=nfun+1 - if (energia(1).eq.1.0d20) then - info(3)=-info(3) - write (iout,'(a,1pe14.5)')'#OVERLAP evdw=1d20',energia(1) - call overlap_sc(fail) - if(.not.fail) then - call geom_to_var(nvar,var) - call etotal(energia(0)) - nfun=nfun+1 - write (iout,'(a,1pe14.5)')'#OVERLAP evdw after',energia(1) - else - v(10)=1.0d20 - iv(1)=-1 - goto 201 - endif - endif - endif - - if (searchsc) then - call var_to_geom(nvar,var) - call sc_move(2,nres-1,1,10d0,nft_sc,etot) - call geom_to_var(nvar,var) -cd write(iout,*) 'sc_move',nft_sc,etot - endif - - if (check_var(var,info)) then - v(10)=1.0d21 - iv(1)=6 - goto 201 - endif - - -crc - -! write (iout,*) 'MINIM_JLEE: Processor',me,' nvar',nvar -! write (iout,'(8f10.4)') (var(i),i=1,nvar) -! write (*,*) 'MINIM_JLEE: Processor',me,' received nvar',nvar -! write (*,'(8f10.4)') (var(i),i=1,nvar) - - do i=1,nvar - garbage(i)=var(i) - enddo - - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit -cd iv(21)=iout - iv(21)=0 -* 1 means to print out result - iv(22)=0 -cd iv(22)=1 -* 1 means to print out summary stats - iv(23)=0 -* 1 means to print initial x and d - iv(24)=0 - -c if(me.eq.3.and.n.eq.255) then -c print *,' CHUJ: stoi' -c iv(21)=6 -c iv(22)=1 -c iv(23)=1 -c iv(24)=1 -c endif - -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -c v(25)=4.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo -c minimize energy -! write (iout,*) 'Processor',me,' nvar',nvar -! write (iout,*) 'Variables BEFORE minimization:' -! write (iout,'(8f10.4)') (rad2deg*var(i),i=1,nvar) - -c print *, 'MINIM_JLEE: ',me,' before SUMSL ' - - call func(nvar,var,nf,eee,idum,rdum,fdum) - nfun=nfun+1 - if(eee.ge.1.0d20) then -c print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' -c print *,' energy before SUMSL =',eee -c print *,' aborting local minimization' - iv(1)=-1 - v(10)=eee - go to 201 - endif - -ct time0s=MPI_WTIME() - call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum) -ct write(iout,*) 'sumsl time=',MPI_WTIME()-time0s,iv(7),v(10) -c print *, 'MINIM_JLEE: ',me,' after SUMSL ' - -c find which conformation was returned from sumsl - nfun=nfun+iv(7) -! print *,'Processor',me,' iv(17)',iv(17),' iv(18)',iv(18),' nf',nf, -! & ' retcode',iv(1),' energy',v(10),' tolf',v(31),' rtolf',v(32) -c if (iv(1).ne.4 .or. nf.le.1) then -c write (*,*) 'Processor',me,' something bad in SUMSL',iv(1),nf -c write (*,*) 'Initial Variables' -c write (*,'(8f10.4)') (rad2deg*garbage(i),i=1,nvar) -c write (*,*) 'Variables' -c write (*,'(8f10.4)') (rad2deg*var(i),i=1,nvar) -c write (*,*) 'Vector d' -c write (*,'(8f10.4)') (d(i),i=1,nvar) -c write (iout,*) 'Processor',me,' something bad in SUMSL', -c & iv(1),nf -c write (iout,*) 'Initial Variables' -c write (iout,'(8f10.4)') (rad2deg*garbage(i),i=1,nvar) -c write (iout,*) 'Variables' -c write (iout,'(8f10.4)') (rad2deg*var(i),i=1,nvar) -c write (iout,*) 'Vector d' -c write (iout,'(8f10.4)') (d(i),i=1,nvar) -c endif -c if (nf.lt.iv(6)-1) then -c recalculate intra- and interchain energies -c call func(nvar,var,nf,v(10),iv,v,fdum) -c else if (nf.eq.iv(6)-1) then -c regenerate conformation -c call var_to_geom(nvar,var) -c call chainbuild -c endif -c change origin and axes to standard ECEPP format -c call var_to_geom(nvar,var) -! write (iout,*) 'MINIM_JLEE after minim: Processor',me,' nvar',nvar -! write (iout,'(8f10.4)') (var(i),i=1,nvar) -! write (iout,*) 'Energy:',v(10) -c send back output -c print *, 'MINIM_JLEE: ',me,' minimized: ',n - 201 continue - indx(1)=n -c return code: 6-gradient 9-number of ftn evaluation, etc - indx(2)=iv(1) -c total # of ftn evaluations (for iwf=0, it includes all minimizations). - indx(3)=nfun - indx(4)=info(2) - indx(5)=info(3) - indx(6)=nss - indx(7)=info(5) - indx(8)=info(6) - indx(9)=info(9) - call mpi_send(indx,9,mpi_integer,king,idint,CG_COMM, - * ierr) -c send back energies -c al & cc -c calculate contact order -#ifdef CO_BIAS - call contact(.false.,ncont,icont,co) - erg(1)=v(10)-1.0d2*co -#else - erg(1)=v(10) -#endif - j=1 - call mpi_send(erg,j,mpi_double_precision,king,idreal, - * CG_COMM,ierr) -#ifdef CO_BIAS - call mpi_send(co,j,mpi_double_precision,king,idreal, - * CG_COMM,ierr) -#endif -c send back values of variables - call mpi_send(var,nvar,mpi_double_precision, - * king,idreal,CG_COMM,ierr) -! print * , 'MINIM_JLEE: Processor',me,' send erg and var ' - - if(vdisulf.and.info(2).ne.-1.and.nss.ne.0) then -cd call intout -cd call chainbuild -cd call etotal(energia(0)) -cd etot=energia(0) -cd call enerprint(energia(0)) - call mpi_send(ihpb,nss,mpi_integer, - * king,idint,CG_COMM,ierr) - call mpi_send(jhpb,nss,mpi_integer, - * king,idint,CG_COMM,ierr) - endif - - go to 10 - 100 print *, ' error in receiving message from emperor', me - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 200 print *, ' error in sending message to emperor' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 300 print *, ' error in communicating with emperor' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 956 format (' initial energy could not be calculated',41x) - 957 format (80x) - 965 format (' convergence code ',i2,' # of function calls ', - * i4,' # of gradient calls ',i4,10x) - 975 format (' energy ',1p,e12.4,' scaled gradient ',e11.3,32x) - end - - logical function check_var(var,info) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.SETUP' - dimension var(maxvar) - dimension info(3) -C AL ------- - check_var=.false. - do i=nphi+ntheta+1,nphi+ntheta+nside -! Check the side chain "valence" angles alpha - if (var(i).lt.1.0d-7) then - write (iout,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' - write (iout,*) 'Processor',me,'received bad variables!!!!' - write (iout,*) 'Variables' - write (iout,'(8f10.4)') (rad2deg*var(j),j=1,nvar) - write (iout,*) 'Continuing calculations at this point', - & ' could destroy the results obtained so far... ABORTING!!!!!!' - write (iout,'(a19,i5,f10.4,a4,2i4,a3,i3)') - & 'valence angle alpha',i-nphi-ntheta,var(i), - & 'n it',info(1),info(2),'mv ',info(3) - write (*,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' - write (*,*) 'Processor',me,'received bad variables!!!!' - write (*,*) 'Variables' - write (*,'(8f10.4)') (rad2deg*var(j),j=1,nvar) - write (*,*) 'Continuing calculations at this point', - & ' could destroy the results obtained so far... ABORTING!!!!!!' - write (*,'(a19,i5,f10.4,a4,2i4,a3,i3)') - & 'valence angle alpha',i-nphi-ntheta,var(i), - & 'n it',info(1),info(2),'mv ',info(3) - check_var=.true. - return - endif - enddo -! Check the backbone "valence" angles theta - do i=nphi+1,nphi+ntheta - if (var(i).lt.1.0d-7) then - write (iout,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' - write (iout,*) 'Processor',me,'received bad variables!!!!' - write (iout,*) 'Variables' - write (iout,'(8f10.4)') (rad2deg*var(j),j=1,nvar) - write (iout,*) 'Continuing calculations at this point', - & ' could destroy the results obtained so far... ABORTING!!!!!!' - write (iout,'(a19,i5,f10.4,a4,2i4,a3,i3)') - & 'valence angle theta',i-nphi,var(i), - & 'n it',info(1),info(2),'mv ',info(3) - write (*,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' - write (*,*) 'Processor',me,'received bad variables!!!!' - write (*,*) 'Variables' - write (*,'(8f10.4)') (rad2deg*var(j),j=1,nvar) - write (*,*) 'Continuing calculations at this point', - & ' could destroy the results obtained so far... ABORTING!!!!!!' - write (*,'(a19,i5,f10.4,a4,2i4,a3,i3)') - & 'valence angle theta',i-nphi,var(i), - & 'n it',info(1),info(2),'mv ',info(3) - check_var=.true. - return - endif - enddo - return - end diff --git a/source/unres/src_MD-M-newcorr/minim_mcmf.F b/source/unres/src_MD-M-newcorr/minim_mcmf.F deleted file mode 100644 index 836d258..0000000 --- a/source/unres/src_MD-M-newcorr/minim_mcmf.F +++ /dev/null @@ -1,119 +0,0 @@ - subroutine minim_mcmf - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.MINIM' - include 'mpif.h' - external func,gradient,fdum - real ran1,ran2,ran3 - include 'COMMON.SETUP' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - dimension muster(mpi_status_size) - dimension var(maxvar),erg(mxch*(mxch+1)/2+1) - double precision d(maxvar),v(1:lv+1),garbage(maxvar) - dimension indx(6) - dimension iv(liv) - dimension idum(1),rdum(1) - double precision przes(3),obrot(3,3) - logical non_conv - data rad /1.745329252d-2/ - common /przechowalnia/ v - - ichuj=0 - 10 continue - ichuj = ichuj + 1 - call mpi_recv(indx,6,mpi_integer,king,idint,CG_COMM, - * muster,ierr) - if (indx(1).eq.0) return -c print *, 'worker ',me,' received order ',n,ichuj - call mpi_recv(var,nvar,mpi_double_precision, - * king,idreal,CG_COMM,muster,ierr) - call mpi_recv(ene0,1,mpi_double_precision, - * king,idreal,CG_COMM,muster,ierr) -c print *, 'worker ',me,' var read ' - - - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit -c iv(21)=iout - iv(21)=0 -* 1 means to print out result - iv(22)=0 -* 1 means to print out summary stats - iv(23)=0 -* 1 means to print initial x and d - iv(24)=0 -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo -c minimize energy - - call func(nvar,var,nf,eee,idum,rdum,fdum) - if(eee.gt.1.0d18) then -c print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' -c print *,' energy before SUMSL =',eee -c print *,' aborting local minimization' - iv(1)=-1 - v(10)=eee - nf=1 - go to 201 - endif - - call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum) -c find which conformation was returned from sumsl - nf=iv(7)+1 - 201 continue -c total # of ftn evaluations (for iwf=0, it includes all minimizations). - indx(4)=nf - indx(5)=iv(1) - eee=v(10) - - call mpi_send(indx,6,mpi_integer,king,idint,CG_COMM, - * ierr) -c print '(a5,i3,15f10.5)', 'ENEX0',indx(1),v(10) - call mpi_send(var,nvar,mpi_double_precision, - * king,idreal,CG_COMM,ierr) - call mpi_send(eee,1,mpi_double_precision,king,idreal, - * CG_COMM,ierr) - call mpi_send(ene0,1,mpi_double_precision,king,idreal, - * CG_COMM,ierr) - go to 10 - - return - end diff --git a/source/unres/src_MD-M-newcorr/minimize_p.F b/source/unres/src_MD-M-newcorr/minimize_p.F deleted file mode 100644 index 06c7a73..0000000 --- a/source/unres/src_MD-M-newcorr/minimize_p.F +++ /dev/null @@ -1,641 +0,0 @@ - subroutine minimize(etot,x,iretcode,nfun) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) -********************************************************************* -* OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * -* the calling subprogram. * -* when d(i)=1.0, then v(35) is the length of the initial step, * -* calculated in the usual pythagorean way. * -* absolute convergence occurs when the function is within v(31) of * -* zero. unless you know the minimum value in advance, abs convg * -* is probably not useful. * -* relative convergence is when the model predicts that the function * -* will decrease by less than v(32)*abs(fun). * -********************************************************************* - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.MINIM' - common /srutu/ icall - dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) - double precision energia(0:n_ene) - external func,gradient,fdum - external func_restr,grad_restr - logical not_done,change,reduce - common /przechowalnia/ v - - icall = 1 - - NOT_DONE=.TRUE. - -c DO WHILE (NOT_DONE) - - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit - iv(21)=0 - if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout -* 1 means to print out result - iv(22)=print_min_res -* 1 means to print out summary stats - iv(23)=print_min_stat -* 1 means to print initial x and d - iv(24)=print_min_ini -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -c v(25)=4.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo -cd print *,'Calling SUMSL' -c call var_to_geom(nvar,x) -c call chainbuild -c call etotal(energia(0)) -c etot = energia(0) - IF (mask_r) THEN - call x2xx(x,xx,nvar_restr) - call sumsl(nvar_restr,d,xx,func_restr,grad_restr, - & iv,liv,lv,v,idum,rdum,fdum) - call xx2x(x,xx) - ELSE - call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) - ENDIF - etot=v(10) - iretcode=iv(1) -cd print *,'Exit SUMSL; return code:',iretcode,' energy:',etot -cd write (iout,'(/a,i4/)') 'SUMSL return code:',iv(1) -c call intout -c change=reduce(x) - call var_to_geom(nvar,x) -c if (change) then -c write (iout,'(a)') 'Reduction worked, minimizing again...' -c else -c not_done=.false. -c endif - call chainbuild -c call etotal(energia(0)) -c etot=energia(0) -c call enerprint(energia(0)) - nfun=iv(6) - -c write (*,*) 'Processor',MyID,' leaves MINIMIZE.' - -c ENDDO ! NOT_DONE - - return - end -#ifdef MPI -c---------------------------------------------------------------------------- - subroutine ergastulum - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SETUP' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.TIME1' - double precision z(maxres6),d_a_tmp(maxres6) - double precision edum(0:n_ene),time_order(0:10) - double precision Gcopy(maxres2,maxres2) - common /przechowalnia/ Gcopy - integer icall /0/ -C Workers wait for variables and NF, and NFL from the boss - iorder=0 - do while (iorder.ge.0) -c write (*,*) 'Processor',fg_rank,' CG group',kolor, -c & ' receives order from Master' - time00=MPI_Wtime() - call MPI_Bcast(iorder,1,MPI_INTEGER,king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 - if (icall.gt.4 .and. iorder.ge.0) - & time_order(iorder)=time_order(iorder)+MPI_Wtime()-time00 - icall=icall+1 -c write (*,*) -c & 'Processor',fg_rank,' completed receive MPI_BCAST order',iorder - if (iorder.eq.0) then - call zerograd - call etotal(edum) -c write (2,*) "After etotal" -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - else if (iorder.eq.2) then - call zerograd - call etotal_short(edum) -c write (2,*) "After etotal_short" -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - else if (iorder.eq.3) then - call zerograd - call etotal_long(edum) -c write (2,*) "After etotal_long" -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - else if (iorder.eq.1) then - call sum_gradient -c write (2,*) "After sum_gradient" -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - else if (iorder.eq.4) then - call ginv_mult(z,d_a_tmp) - else if (iorder.eq.5) then -c Setup MD things for a slave - dimen=(nct-nnt+1)+nside - dimen1=(nct-nnt)+(nct-nnt+1) - dimen3=dimen*3 -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - call int_bounds(dimen,igmult_start,igmult_end) - igmult_start=igmult_start-1 - call MPI_Allgather(3*igmult_start,1,MPI_INTEGER, - & ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - my_ng_count=igmult_end-igmult_start - call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1, - & MPI_INTEGER,FG_COMM,IERROR) -c write (2,*) "ng_start",(ng_start(i),i=0,nfgtasks-1) -c write (2,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1) - myginv_ng_count=maxres2*my_ng_count -c write (2,*) "igmult_start",igmult_start," igmult_end", -c & igmult_end," my_ng_count",my_ng_count -c call flush(2) - call MPI_Allgather(maxres2*igmult_start,1,MPI_INTEGER, - & nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER, - & nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR) -c write (2,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1) -c write (2,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1) -c call flush(2) -c call MPI_Barrier(FG_COMM,IERROR) - time00=MPI_Wtime() - call MPI_Scatterv(ginv(1,1),nginv_counts(0), - & nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1), - & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -#ifdef TIMING - time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00 -#endif - do i=1,dimen - do j=1,2*my_ng_count - ginv(j,i)=gcopy(i,j) - enddo - enddo -c write (2,*) "dimen",dimen," dimen3",dimen3 -c write (2,*) "End MD setup" -c call flush(2) -c write (iout,*) "My chunk of ginv_block" -c call MATOUT2(my_ng_count,dimen3,maxres2,maxers2,ginv_block) - else if (iorder.eq.6) then - call int_from_cart1(.false.) - else if (iorder.eq.7) then - call chainbuild_cart - else if (iorder.eq.8) then - call intcartderiv - else if (iorder.eq.9) then - call fricmat_mult(z,d_a_tmp) - else if (iorder.eq.10) then - call setup_fricmat - endif - enddo - write (*,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',myrank,' leves ERGASTULUM.' - write(*,*)'Processor',fg_rank,' wait times for respective orders', - & (' order[',i,']',time_order(i),i=0,10) - return - end -#endif -************************************************************************ - subroutine func(n,x,nf,f,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - common /chuju/ jjj - double precision energia(0:n_ene) - integer jjj - double precision ufparm - external ufparm - integer uiparm(1) - real*8 urparm(1) - dimension x(maxvar) -c if (jjj.gt.0) then -c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -c endif - nfl=nf - icg=mod(nf,2)+1 -cd print *,'func',nf,nfl,icg - call var_to_geom(n,x) - call zerograd - call chainbuild -cd write (iout,*) 'ETOTAL called from FUNC' - call etotal(energia(0)) - call sum_gradient - f=energia(0) -c if (jjj.gt.0) then -c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -c write (iout,*) 'f=',etot -c jjj=0 -c endif - return - end -************************************************************************ - subroutine func_restr(n,x,nf,f,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - common /chuju/ jjj - double precision energia(0:n_ene) - integer jjj - double precision ufparm - external ufparm - integer uiparm(1) - real*8 urparm(1) - dimension x(maxvar) -c if (jjj.gt.0) then -c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -c endif - nfl=nf - icg=mod(nf,2)+1 - call var_to_geom_restr(n,x) - call zerograd - call chainbuild -cd write (iout,*) 'ETOTAL called from FUNC' - call etotal(energia(0)) - call sum_gradient - f=energia(0) -c if (jjj.gt.0) then -c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -c write (iout,*) 'f=',etot -c jjj=0 -c endif - return - end -c------------------------------------------------------- - subroutine x2xx(x,xx,n) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - double precision xx(maxvar),x(maxvar) - - do i=1,nvar - varall(i)=x(i) - enddo - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - xx(ig)=x(igall) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - xx(ig)=x(igall) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - xx(ig)=x(igall) - endif - endif - enddo - enddo - - n=ig - - return - end - - subroutine xx2x(x,xx) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - double precision xx(maxvar),x(maxvar) - - do i=1,nvar - x(i)=varall(i) - enddo - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - x(igall)=xx(ig) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - x(igall)=xx(ig) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - x(igall)=xx(ig) - endif - endif - enddo - enddo - - return - end - -c---------------------------------------------------------- - subroutine minim_dc(etot,iretcode,nfun) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.MINIM' - include 'COMMON.CHAIN' - dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) - common /przechowalnia/ v - - double precision energia(0:n_ene) - external func_dc,grad_dc,fdum - logical not_done,change,reduce - double precision g(maxvar),f1 - - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit - iv(21)=0 - if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout -* 1 means to print out result - iv(22)=print_min_res -* 1 means to print out summary stats - iv(23)=print_min_stat -* 1 means to print initial x and d - iv(24)=print_min_ini -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -c v(25)=4.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,6*nres - d(i)=1.0D-1 - enddo - - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - x(k)=dc(j,i) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - x(k)=dc(j,i+nres) - enddo - endif - enddo - - call sumsl(k,d,x,func_dc,grad_dc,iv,liv,lv,v,idum,rdum,fdum) - - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - dc(j,i)=x(k) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - dc(j,i+nres)=x(k) - enddo - endif - enddo - call chainbuild_cart - -cd call zerograd -cd nf=0 -cd call func_dc(k,x,nf,f,idum,rdum,fdum) -cd call grad_dc(k,x,nf,g,idum,rdum,fdum) -cd -cd do i=1,k -cd x(i)=x(i)+1.0D-5 -cd call func_dc(k,x,nf,f1,idum,rdum,fdum) -cd x(i)=x(i)-1.0D-5 -cd print '(i5,2f15.5)',i,g(i),(f1-f)/1.0D-5 -cd enddo - - etot=v(10) - iretcode=iv(1) - nfun=iv(6) - return - end - - subroutine func_dc(n,x,nf,f,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - double precision energia(0:n_ene) - double precision ufparm - external ufparm - integer uiparm(1) - real*8 urparm(1) - dimension x(maxvar) - nfl=nf -cbad icg=mod(nf,2)+1 - icg=1 - - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - dc(j,i)=x(k) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - dc(j,i+nres)=x(k) - enddo - endif - enddo - call chainbuild_cart - - call zerograd - call etotal(energia(0)) - f=energia(0) - -cd print *,'func_dc ',nf,nfl,f - - return - end - - subroutine grad_dc(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - external ufparm - integer uiparm(1),k - double precision urparm(1) - dimension x(maxvar),g(maxvar) -c -c -c -cbad icg=mod(nf,2)+1 - icg=1 -cd print *,'grad_dc ',nf,nfl,nf-nfl+1,icg - if (nf-nfl+1) 20,30,40 - 20 call func_dc(n,x,nf,f,uiparm,urparm,ufparm) -cd print *,20 - if (nf.eq.0) return - goto 40 - 30 continue -cd print *,30 - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - dc(j,i)=x(k) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - dc(j,i+nres)=x(k) - enddo - endif - enddo - call chainbuild_cart - -C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartgrad -cd print *,40 - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - g(k)=gcart(j,i) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - g(k)=gxcart(j,i) - enddo - endif - enddo - - return - end diff --git a/source/unres/src_MD-M-newcorr/misc.f b/source/unres/src_MD-M-newcorr/misc.f deleted file mode 100644 index e189839..0000000 --- a/source/unres/src_MD-M-newcorr/misc.f +++ /dev/null @@ -1,203 +0,0 @@ -C $Date: 1994/10/12 17:24:21 $ -C $Revision: 2.5 $ -C -C -C - logical function find_arg(ipos,line,errflag) - parameter (maxlen=80) - character*80 line - character*1 empty /' '/,equal /'='/ - logical errflag -* This function returns .TRUE., if an argument follows keyword keywd; if so -* IPOS will point to the first non-blank character of the argument. Returns -* .FALSE., if no argument follows the keyword; in this case IPOS points -* to the first non-blank character of the next keyword. - do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) - ipos=ipos+1 - enddo - errflag=.false. - if (line(ipos:ipos).eq.equal) then - find_arg=.true. - ipos=ipos+1 - do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) - ipos=ipos+1 - enddo - if (ipos.gt.maxlen) errflag=.true. - else - find_arg=.false. - endif - return - end - logical function find_group(iunit,jout,key1) - character*(*) key1 - character*80 karta,ucase - integer ilen - external ilen - logical lcom - rewind (iunit) - karta=' ' - ll=ilen(key1) - do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta)) - read (iunit,'(a)',end=10) karta - enddo - write (jout,'(2a)') '> ',karta(1:78) - find_group=.true. - return - 10 find_group=.false. - return - end - logical function iblnk(charc) - character*1 charc - integer n - n = ichar(charc) - iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq. ' ') - return - end - integer function ilen(string) - character*(*) string - logical iblnk - - ilen = len(string) -1 if ( ilen .gt. 0 ) then - if ( iblnk( string(ilen:ilen) ) ) then - ilen = ilen - 1 - goto 1 - endif - endif - return - end - integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset) - character*16 keywd,keywdset(1:nkey,0:nkey) - character*16 ucase - do i=1,narg - if (ucase(keywd).eq.keywdset(i,ikey)) then -* Match found - in_keywd_set=i - return - endif - enddo -* No match to the allowed set of keywords if this point is reached. - in_keywd_set=0 - return - end - character*(*) function lcase(string) - integer i, k, idiff - character*(*) string - character*1 c - character*40 chtmp -c - i = len(lcase) - k = len(string) - if (i .lt. k) then - k = i - if (string(k+1:) .ne. ' ') then - chtmp = string - endif - endif - idiff = ichar('a') - ichar('A') - lcase = string - do 99 i = 1, k - c = string(i:i) - if (lge(c,'A') .and. lle(c,'Z')) then - lcase(i:i) = char(ichar(c) + idiff) - endif - 99 continue - return - end - logical function lcom(ipos,karta) - character*80 karta - character koment(2) /'!','#'/ - lcom=.false. - do i=1,2 - if (karta(ipos:ipos).eq.koment(i)) lcom=.true. - enddo - return - end - logical function lower_case(ch) - character*(*) ch - lower_case=(ch.ge.'a' .and. ch.le.'z') - return - end - subroutine mykey(line,keywd,ipos,blankline,errflag) -* This subroutine seeks a non-empty substring keywd in the string LINE. -* The substring begins with the first character different from blank and -* "=" encountered right to the pointer IPOS (inclusively) and terminates -* at the character left to the first blank or "=". When the subroutine is -* exited, the pointer IPOS is moved to the position of the terminator in LINE. -* The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains -* only separators or the maximum length of the data line (80) has been reached. -* The logical variable ERRFLAG is set at .TRUE. if the string -* consists only from a "=". - parameter (maxlen=80) - character*1 empty /' '/,equal /'='/,comma /','/ - character*(*) keywd - character*80 line - logical blankline,errflag,lcom - errflag=.false. - do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen)) - ipos=ipos+1 - enddo - if (ipos.gt.maxlen .or. lcom(ipos,line) ) then -* At this point the rest of the input line turned out to contain only blanks -* or to be commented out. - blankline=.true. - return - endif - blankline=.false. - istart=ipos -* Checks whether the current char is a separator. - do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal - & .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen) - ipos=ipos+1 - enddo - iend=ipos-1 -* Error flag set to .true., if the length of the keyword was found less than 1. - if (iend.lt.istart) then - errflag=.true. - return - endif - keywd=line(istart:iend) - return - end - subroutine numstr(inum,numm) - character*10 huj /'0123456789'/ - character*(*) numm - inumm=inum - inum1=inumm/10 - inum2=inumm-10*inum1 - inumm=inum1 - numm(3:3)=huj(inum2+1:inum2+1) - inum1=inumm/10 - inum2=inumm-10*inum1 - inumm=inum1 - numm(2:2)=huj(inum2+1:inum2+1) - inum1=inumm/10 - inum2=inumm-10*inum1 - inumm=inum1 - numm(1:1)=huj(inum2+1:inum2+1) - return - end - character*(*) function ucase(string) - integer i, k, idiff - character*(*) string - character*1 c - character*40 chtmp -c - i = len(ucase) - k = len(string) - if (i .lt. k) then - k = i - if (string(k+1:) .ne. ' ') then - chtmp = string - endif - endif - idiff = ichar('a') - ichar('A') - ucase = string - do 99 i = 1, k - c = string(i:i) - if (lge(c,'a') .and. lle(c,'z')) then - ucase(i:i) = char(ichar(c) - idiff) - endif - 99 continue - return - end diff --git a/source/unres/src_MD-M-newcorr/module.log b/source/unres/src_MD-M-newcorr/module.log deleted file mode 100644 index 684781c..0000000 --- a/source/unres/src_MD-M-newcorr/module.log +++ /dev/null @@ -1,11 +0,0 @@ -Currently Loaded Modulefiles: - 1) modules/3.1.6 11) xt-libc/1.5.60 - 2) pgi/7.2.2 12) xt-os/1.5.60 - 3) totalview-support/1.0.5 13) xt-catamount/1.5.60 - 4) xt-totalview/8.4.1b 14) xt-boot/1.5.60 - 5) xt-libsci/10.0.0 15) xt-crms/1.5.60 - 6) xt-mpt/1.5.60 16) xt-lustre-ss/1.5.60 - 7) xt-pe/1.5.60 17) Base-opts/1.5.60 - 8) PrgEnv-pgi/1.5.60 18) psc_path/1.0 - 9) xt-pbs/5.3.5-6xt_psc 19) dmover/1.0 - 10) xt-service/1.5.60 20) tau/tau-2.17 diff --git a/source/unres/src_MD-M-newcorr/moments.f b/source/unres/src_MD-M-newcorr/moments.f deleted file mode 100644 index 983ce36..0000000 --- a/source/unres/src_MD-M-newcorr/moments.f +++ /dev/null @@ -1,328 +0,0 @@ - subroutine inertia_tensor -c Calculating the intertia tensor for the entire protein in order to -c remove the perpendicular components of velocity matrix which cause -c the molecule to rotate. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - - double precision Im(3,3),Imcp(3,3),cm(3),pr(3),M_SC, - & eigvec(3,3),Id(3,3),eigval(3),L(3),vp(3),vrot(3), - & vpp(3,0:MAXRES),vs_p(3),pr1(3,3), - & pr2(3,3),pp(3),incr(3),v(3),mag,mag2 - common /gucio/ cm - integer iti,inres - do i=1,3 - do j=1,3 - Im(i,j)=0.0d0 - pr1(i,j)=0.0d0 - pr2(i,j)=0.0d0 - enddo - L(i)=0.0d0 - cm(i)=0.0d0 - vrot(i)=0.0d0 - enddo -c calculating the center of the mass of the protein - do i=nnt,nct-1 - do j=1,3 - cm(j)=cm(j)+c(j,i)+0.5d0*dc(j,i) - enddo - enddo - do j=1,3 - cm(j)=mp*cm(j) - enddo - M_SC=0.0d0 - do i=nnt,nct - iti=iabs(itype(i)) - M_SC=M_SC+msc(iabs(iti)) - inres=i+nres - do j=1,3 - cm(j)=cm(j)+msc(iabs(iti))*c(j,inres) - enddo - enddo - do j=1,3 - cm(j)=cm(j)/(M_SC+(nct-nnt)*mp) - enddo - - do i=nnt,nct-1 - do j=1,3 - pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) - enddo - Im(1,1)=Im(1,1)+mp*(pr(2)*pr(2)+pr(3)*pr(3)) - Im(1,2)=Im(1,2)-mp*pr(1)*pr(2) - Im(1,3)=Im(1,3)-mp*pr(1)*pr(3) - Im(2,3)=Im(2,3)-mp*pr(2)*pr(3) - Im(2,2)=Im(2,2)+mp*(pr(3)*pr(3)+pr(1)*pr(1)) - Im(3,3)=Im(3,3)+mp*(pr(1)*pr(1)+pr(2)*pr(2)) - enddo - - do i=nnt,nct - iti=iabs(itype(i)) - inres=i+nres - do j=1,3 - pr(j)=c(j,inres)-cm(j) - enddo - Im(1,1)=Im(1,1)+msc(iabs(iti))*(pr(2)*pr(2)+pr(3)*pr(3)) - Im(1,2)=Im(1,2)-msc(iabs(iti))*pr(1)*pr(2) - Im(1,3)=Im(1,3)-msc(iabs(iti))*pr(1)*pr(3) - Im(2,3)=Im(2,3)-msc(iabs(iti))*pr(2)*pr(3) - Im(2,2)=Im(2,2)+msc(iabs(iti))*(pr(3)*pr(3)+pr(1)*pr(1)) - Im(3,3)=Im(3,3)+msc(iabs(iti))*(pr(1)*pr(1)+pr(2)*pr(2)) - enddo - - do i=nnt,nct-1 - Im(1,1)=Im(1,1)+Ip*(1-dc_norm(1,i)*dc_norm(1,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(1,2)=Im(1,2)+Ip*(-dc_norm(1,i)*dc_norm(2,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(1,3)=Im(1,3)+Ip*(-dc_norm(1,i)*dc_norm(3,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(2,3)=Im(2,3)+Ip*(-dc_norm(2,i)*dc_norm(3,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(2,2)=Im(2,2)+Ip*(1-dc_norm(2,i)*dc_norm(2,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(3,3)=Im(3,3)+Ip*(1-dc_norm(3,i)*dc_norm(3,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - enddo - - - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - iti=iabs(itype(i)) - inres=i+nres - Im(1,1)=Im(1,1)+Isc(iti)*(1-dc_norm(1,inres)* - & dc_norm(1,inres))*vbld(inres)*vbld(inres) - Im(1,2)=Im(1,2)-Isc(iti)*(dc_norm(1,inres)* - & dc_norm(2,inres))*vbld(inres)*vbld(inres) - Im(1,3)=Im(1,3)-Isc(iti)*(dc_norm(1,inres)* - & dc_norm(3,inres))*vbld(inres)*vbld(inres) - Im(2,3)=Im(2,3)-Isc(iti)*(dc_norm(2,inres)* - & dc_norm(3,inres))*vbld(inres)*vbld(inres) - Im(2,2)=Im(2,2)+Isc(iti)*(1-dc_norm(2,inres)* - & dc_norm(2,inres))*vbld(inres)*vbld(inres) - Im(3,3)=Im(3,3)+Isc(iti)*(1-dc_norm(3,inres)* - & dc_norm(3,inres))*vbld(inres)*vbld(inres) - endif - enddo - - call angmom(cm,L) -c write(iout,*) "The angular momentum before adjustment:" -c write(iout,*) (L(j),j=1,3) - - Im(2,1)=Im(1,2) - Im(3,1)=Im(1,3) - Im(3,2)=Im(2,3) - -c Copying the Im matrix for the djacob subroutine - do i=1,3 - do j=1,3 - Imcp(i,j)=Im(i,j) - Id(i,j)=0.0d0 - enddo - enddo - -c Finding the eigenvectors and eignvalues of the inertia tensor - call djacob(3,3,10000,1.0d-10,Imcp,eigvec,eigval) -c write (iout,*) "Eigenvalues & Eigenvectors" -c write (iout,'(5x,3f10.5)') (eigval(i),i=1,3) -c write (iout,*) -c do i=1,3 -c write (iout,'(i5,3f10.5)') i,(eigvec(i,j),j=1,3) -c enddo -c Constructing the diagonalized matrix - do i=1,3 - if (dabs(eigval(i)).gt.1.0d-15) then - Id(i,i)=1.0d0/eigval(i) - else - Id(i,i)=0.0d0 - endif - enddo - do i=1,3 - do j=1,3 - Imcp(i,j)=eigvec(j,i) - enddo - enddo - do i=1,3 - do j=1,3 - do k=1,3 - pr1(i,j)=pr1(i,j)+Id(i,k)*Imcp(k,j) - enddo - enddo - enddo - do i=1,3 - do j=1,3 - do k=1,3 - pr2(i,j)=pr2(i,j)+eigvec(i,k)*pr1(k,j) - enddo - enddo - enddo -c Calculating the total rotational velocity of the molecule - do i=1,3 - do j=1,3 - vrot(i)=vrot(i)+pr2(i,j)*L(j) - enddo - enddo -c Resetting the velocities - do i=nnt,nct-1 - call vecpr(vrot(1),dc(1,i),vp) - do j=1,3 - d_t(j,i)=d_t(j,i)-vp(j) - enddo - enddo - do i=nnt,nct - if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - call vecpr(vrot(1),dc(1,inres),vp) - do j=1,3 - d_t(j,inres)=d_t(j,inres)-vp(j) - enddo - endif - enddo - call angmom(cm,L) -c write(iout,*) "The angular momentum after adjustment:" -c write(iout,*) (L(j),j=1,3) - return - end -c---------------------------------------------------------------------------- - subroutine angmom(cm,L) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - - double precision L(3),cm(3),pr(3),vp(3),vrot(3),incr(3),v(3), - & pp(3) - integer iti,inres -c Calculate the angular momentum - do j=1,3 - L(j)=0.0d0 - enddo - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct-1 - do j=1,3 - pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) - enddo - do j=1,3 - v(j)=incr(j)+0.5d0*d_t(j,i) - enddo - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - call vecpr(pr(1),v(1),vp) - do j=1,3 - L(j)=L(j)+mp*vp(j) - enddo - do j=1,3 - pr(j)=0.5d0*dc(j,i) - pp(j)=0.5d0*d_t(j,i) - enddo - call vecpr(pr(1),pp(1),vp) - do j=1,3 - L(j)=L(j)+Ip*vp(j) - enddo - enddo - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct - iti=iabs(itype(i)) - inres=i+nres - do j=1,3 - pr(j)=c(j,inres)-cm(j) - enddo - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - v(j)=incr(j)+d_t(j,inres) - enddo - else - do j=1,3 - v(j)=incr(j) - enddo - endif - call vecpr(pr(1),v(1),vp) -c write (iout,*) "i",i," iti",iti," pr",(pr(j),j=1,3), -c & " v",(v(j),j=1,3)," vp",(vp(j),j=1,3) - do j=1,3 - L(j)=L(j)+msc(iabs(iti))*vp(j) - enddo -c write (iout,*) "L",(l(j),j=1,3) - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - v(j)=incr(j)+d_t(j,inres) - enddo - call vecpr(dc(1,inres),d_t(1,inres),vp) - do j=1,3 - L(j)=L(j)+Isc(iti)*vp(j) - enddo - endif - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - enddo - return - end -c------------------------------------------------------------------------------ - subroutine vcm_vel(vcm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - double precision vcm(3),vv(3),summas,amas - do j=1,3 - vcm(j)=0.0d0 - vv(j)=d_t(j,0) - enddo - summas=0.0d0 - do i=nnt,nct - if (i.lt.nct) then - summas=summas+mp - do j=1,3 - vcm(j)=vcm(j)+mp*(vv(j)+0.5d0*d_t(j,i)) - enddo - endif - amas=msc(iabs(itype(i))) - summas=summas+amas - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - vcm(j)=vcm(j)+amas*(vv(j)+d_t(j,i+nres)) - enddo - else - do j=1,3 - vcm(j)=vcm(j)+amas*vv(j) - enddo - endif - do j=1,3 - vv(j)=vv(j)+d_t(j,i) - enddo - enddo -c write (iout,*) "vcm",(vcm(j),j=1,3)," summas",summas - do j=1,3 - vcm(j)=vcm(j)/summas - enddo - return - end diff --git a/source/unres/src_MD-M-newcorr/muca_md.f b/source/unres/src_MD-M-newcorr/muca_md.f deleted file mode 100644 index c10a6a7..0000000 --- a/source/unres/src_MD-M-newcorr/muca_md.f +++ /dev/null @@ -1,334 +0,0 @@ - subroutine muca_delta(remd_t_bath,remd_ene,i,iex,delta) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.MD' - double precision remd_t_bath(maxprocs) - double precision remd_ene(maxprocs) - double precision muca_ene - double precision betai,betaiex,delta - - betai=1.0/(Rb*remd_t_bath(i)) - betaiex=1.0/(Rb*remd_t_bath(iex)) - - delta=betai*(muca_ene(remd_ene(iex),i,remd_t_bath)- - & muca_ene(remd_ene(i),i,remd_t_bath)) - & -betaiex*(muca_ene(remd_ene(iex),iex,remd_t_bath)- - & muca_ene(remd_ene(i),iex,remd_t_bath)) - - return - end - - double precision function muca_ene(energy,i,remd_t_bath) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.MD' - double precision y,yp,energy - double precision remd_t_bath(maxprocs) - integer i - - if (energy.lt.elowi(i)) then - call splint(emuca,nemuca,nemuca2,nmuca,elowi(i),y,yp) - muca_ene=remd_t_bath(i)*Rb*(yp*(energy-elowi(i))+y) - elseif (energy.gt.ehighi(i)) then - call splint(emuca,nemuca,nemuca2,nmuca,ehighi(i),y,yp) - muca_ene=remd_t_bath(i)*Rb*(yp*(energy-ehighi(i))+y) - else - call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) - muca_ene=remd_t_bath(i)*Rb*y - endif - return - end - - subroutine read_muca - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.CONTROL' - include 'COMMON.MD' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision yp1,ypn,yp,x,muca_factor,y,muca_ene - imtime=0 - do i=1,4*maxres - hist(i)=0 - enddo - if (modecalc.eq.14.and..not.remd_tlist) then - print *,"MUCAREMD works only with TLIST" - stop - endif - open(89,file='muca.input') - read(89,*) - read(89,*) - if (modecalc.eq.14) then - read(89,*) (elowi(i),ehighi(i),i=1,nrep) - if (remd_mlist) then - k=0 - do i=1,nrep - do j=1,remd_m(i) - i2rep(k)=i - k=k+1 - enddo - enddo - elow=elowi(i2rep(me)) - ehigh=ehighi(i2rep(me)) - elowi(me+1)=elow - ehighi(me+1)=ehigh - else - elow=elowi(me+1) - ehigh=ehighi(me+1) - endif - else - read(89,*) elow,ehigh - elowi(1)=elow - ehighi(1)=ehigh - endif - i=0 - do while(.true.) - i=i+1 - read(89,*,end=100) emuca(i),nemuca(i) -cd nemuca(i)=nemuca(i)*remd_t(me+1)*Rb - enddo - 100 continue - nmuca=i-1 - hbin=emuca(nmuca)-emuca(nmuca-1) - write (iout,*) 'hbin',hbin - write (iout,*) me,'elow,ehigh',elow,ehigh - yp1=0 - ypn=0 - call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) - factor_min=0.0d0 - factor_min=muca_factor(ehigh) - call print_muca - return - end - - - subroutine print_muca - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.CONTROL' - include 'COMMON.MD' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision yp1,ypn,yp,x,muca_factor,y,muca_ene - double precision dummy(maxprocs) - - if (remd_mlist) then - k=0 - do i=1,nrep - do j=1,remd_m(i) - i2rep(k)=i - k=k+1 - enddo - enddo - endif - - do i=1,nmuca -c print *,'nemuca ',emuca(i),nemuca(i) - do j=0,4 - x=emuca(i)+hbin/5*j - if (modecalc.eq.14) then - if (remd_mlist) then - yp=muca_factor(x)*remd_t(i2rep(me))*Rb - dummy(me+1)=remd_t(i2rep(me)) - y=muca_ene(x,me+1,dummy) - else - yp=muca_factor(x)*remd_t(me+1)*Rb - y=muca_ene(x,me+1,remd_t) - endif - write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime, - & 'muca factor ',x,yp,' muca ene',y - else - yp=muca_factor(x)*t_bath*Rb - dummy(1)=t_bath - y=muca_ene(x,1,dummy) - write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime, - & 'muca factor ',x,yp,' muca ene',y - endif - enddo - enddo - if(mucadyn.gt.0) then - do i=1,nmuca - write(iout,'(a13,i8,2f12.5)') 'nemuca after ', - & imtime,emuca(i),nemuca(i) - enddo - endif - return - end - - subroutine muca_update(energy) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.CONTROL' - include 'COMMON.MD' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energy - double precision yp1,ypn - integer k - logical lnotend - - k=int((energy-emuca(1))/hbin)+1 - - IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN - if(energy.ge.ehigh) - & write (iout,*) 'MUCA reject',energy,emuca(k) - if(energy.ge.ehigh.and.(energy-ehigh).lt.hbin) then - write (iout,*) 'MUCA ehigh',energy,emuca(k) - do i=k,nmuca - hist(i)=hist(i)+1 - enddo - endif - if(k.gt.0.and.energy.lt.ehigh) hist(k)=hist(k)+1 - ELSE - if(k.gt.0.and.k.lt.4*maxres) hist(k)=hist(k)+1 - ENDIF - if(mod(imtime,mucadyn).eq.0) then - - do i=1,nmuca - IF(muca_smooth.eq.2.or.muca_smooth.eq.3) THEN - nemuca(i)=nemuca(i)+dlog(hist(i)+1) - ELSE - if (hist(i).gt.0) hist(i)=dlog(hist(i)) - nemuca(i)=nemuca(i)+hist(i) - ENDIF - hist(i)=0 - write(iout,'(a24,i8,2f12.5)')'nemuca before smoothing ', - & imtime,emuca(i),nemuca(i) - enddo - - - lnotend=.true. - ismooth=0 - ist=2 - ien=nmuca-1 - IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN -c lnotend=.false. -c do i=1,nmuca-1 -c do j=i+1,nmuca -c if(nemuca(j).lt.nemuca(i)) lnotend=.true. -c enddo -c enddo - do while(lnotend) - ismooth=ismooth+1 - write (iout,*) 'MUCA update smoothing',ist,ien - do i=ist,ien - nemuca(i)=(nemuca(i-1)+nemuca(i)+nemuca(i+1))/3 - enddo - lnotend=.false. - ist=0 - ien=0 - do i=1,nmuca-1 - do j=i+1,nmuca - if(nemuca(j).lt.nemuca(i)) then - lnotend=.true. - if(ist.eq.0) ist=i-1 - if(ien.lt.j+1) ien=j+1 - endif - enddo - enddo - enddo - ENDIF - - write (iout,*) 'MUCA update ',imtime,' smooth= ',ismooth - yp1=0 - ypn=0 - call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) - call print_muca - - endif - return - end - - double precision function muca_factor(energy) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - double precision y,yp,energy - - if (energy.lt.elow) then - call splint(emuca,nemuca,nemuca2,nmuca,elow,y,yp) - elseif (energy.gt.ehigh) then - call splint(emuca,nemuca,nemuca2,nmuca,ehigh,y,yp) - else - call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) - endif - - if(yp.ge.factor_min) then - muca_factor=yp - else - muca_factor=factor_min - endif -cd print *,'energy, muca_factor',energy,muca_factor - return - end - - - SUBROUTINE spline(x,y,n,yp1,ypn,y2) - INTEGER n,NMAX - REAL*8 yp1,ypn,x(n),y(n),y2(n) - PARAMETER (NMAX=500) - INTEGER i,k - REAL*8 p,qn,sig,un,u(NMAX) - if (yp1.gt..99e30) then - y2(1)=0. - u(1)=0. - else - y2(1)=-0.5 - u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) - endif - do i=2,n-1 - sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) - p=sig*y2(i-1)+2. - y2(i)=(sig-1.)/p - u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) - * /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p - enddo - if (ypn.gt..99e30) then - qn=0. - un=0. - else - qn=0.5 - un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) - endif - y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) - do k=n-1,1,-1 - y2(k)=y2(k)*y2(k+1)+u(k) - enddo - return - END - - - SUBROUTINE splint(xa,ya,y2a,n,x,y,yp) - INTEGER n - REAL*8 x,y,xa(n),y2a(n),ya(n),yp - INTEGER k,khi,klo - REAL*8 a,b,h - klo=1 - khi=n - 1 if (khi-klo.gt.1) then - k=(khi+klo)/2 - if (xa(k).gt.x) then - khi=k - else - klo=k - endif - goto 1 - endif - h=xa(khi)-xa(klo) - if (h.eq.0.) pause 'bad xa input in splint' - a=(xa(khi)-x)/h - b=(x-xa(klo))/h - y=a*ya(klo)+b*ya(khi)+ - * ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6. - yp=-ya(klo)/h+ya(khi)/h-3*(a**2)*y2a(klo)*h/6. - + +(3*(b**2)-1)*y2a(khi)*h/6. - return - END diff --git a/source/unres/src_MD-M-newcorr/newconf.f b/source/unres/src_MD-M-newcorr/newconf.f deleted file mode 100644 index 5f93b95..0000000 --- a/source/unres/src_MD-M-newcorr/newconf.f +++ /dev/null @@ -1,2454 +0,0 @@ -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine make_var(n,idum,iter_csa) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.HAIRPIN' - include 'COMMON.VAR' - include 'COMMON.DISTFIT' - include 'COMMON.GEO' - include 'COMMON.CONTROL' - logical nicht_getan,nicht_getan1,fail,lfound - integer nharp,iharp(4,maxres/3),nconf_harp - integer iisucc(mxio) - logical ifused(mxio) - integer nhx_seed(max_seed),ihx_seed(4,maxres/3,max_seed) - integer nhx_use(max_seed),ihx_use(0:4,maxres/3,max_seed) - integer nlx_seed(max_seed),ilx_seed(2,maxres/3,max_seed), - & nlx_use(max_seed),ilx_use(maxres/3,max_seed) - real ran1,ran2 - - write (iout,*) 'make_var : nseed=',nseed,'ntry=',n - index=0 - -c----------------------------------------- - if (n7.gt.0.or.n8.gt.0.or.n9.gt.0.or.n14.gt.0.or.n15.gt.0 - & .or.n16.gt.0.or.n17.gt.0.or.n18.gt.0) - & call select_frag(n7frag,n8frag,n14frag, - & n15frag,nbefrag,iter_csa) - -c--------------------------------------------------- -c N18 - random perturbation of one phi(=gamma) angle in a loop -c - IF (n18.gt.0) THEN - nlx_tot=0 - do iters=1,nseed - i1=is(iters) - nlx_seed(iters)=0 - do i2=1,n14frag - if (lvar_frag(i2,1).eq.i1) then - nlx_seed(iters)=nlx_seed(iters)+5 - ilx_seed(1,nlx_seed(iters),iters)=lvar_frag(i2,2) - ilx_seed(2,nlx_seed(iters),iters)=lvar_frag(i2,3) - ilx_use(nlx_seed(iters),iters)=5 - endif - enddo - nlx_use(iters)=nlx_seed(iters) - nlx_tot=nlx_tot+nlx_seed(iters) - enddo - - if (nlx_tot .ge. n18*nseed) then - ntot_gen=n18*nseed - else - ntot_gen=(nlx_tot/nseed)*nseed - endif - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nlx_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nlx_seed(iters)) - if (ilx_use(iih,iters).gt.0) then - nicht_getan=.false. - ilx_use(iih,iters)=ilx_use(iih,iters)-1 - nlx_use(iters)=nlx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=18 - parent(1,index)=iseed - parent(2,index)=0 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - jr=iran_num(ilx_seed(1,iih,iters),ilx_seed(2,iih,iters)) - d=ran_number(-pi,pi) - dihang_in(2,jr-2,1,index)=pinorm(dihang_in(2,jr-2,1,index)+d) - - - if (ngen.eq.ntot_gen) goto 145 - endif - enddo - enddo - 145 continue - - ENDIF - - -c----------------------------------------- -c N17 : zip a beta in a seed by forcing one additional p-p contact -c - IF (n17.gt.0) THEN - nhx_tot=0 - do iters=1,nseed - i1=is(iters) - nhx_seed(iters)=0 - nhx_use(iters)=0 - do i2=1,nbefrag - if (avar_frag(i2,1).eq.i1) then - nhx_seed(iters)=nhx_seed(iters)+1 - ihx_use(2,nhx_seed(iters),iters)=1 - if (avar_frag(i2,5)-avar_frag(i2,3).le.3.and. - & avar_frag(i2,2).gt.1.and.avar_frag(i2,4).lt.nres) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)+1 - ihx_use(0,nhx_seed(iters),iters)=1 - ihx_use(1,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - else - if (avar_frag(i2,4).gt.avar_frag(i2,5)) then - if (avar_frag(i2,2).gt.1.and. - & avar_frag(i2,4).lt.nres) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)+1 - ihx_use(0,nhx_seed(iters),iters)=1 - ihx_use(1,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - endif - if (avar_frag(i2,3).lt.nres.and. - & avar_frag(i2,5).gt.1) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,3)+1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,5)-1 - ihx_use(0,nhx_seed(iters),iters)= - & ihx_use(0,nhx_seed(iters),iters)+1 - ihx_use(2,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - endif - else - if (avar_frag(i2,2).gt.1.and. - & avar_frag(i2,4).gt.1) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)-1 - ihx_use(0,nhx_seed(iters),iters)=1 - ihx_use(1,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - endif - if (avar_frag(i2,3).lt.nres.and. - & avar_frag(i2,5).lt.nres) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,3)+1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,5)+1 - ihx_use(0,nhx_seed(iters),iters)= - & ihx_use(0,nhx_seed(iters),iters)+1 - ihx_use(2,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - endif - endif - endif - endif - enddo - - nhx_tot=nhx_tot+nhx_use(iters) -cd write (iout,*) "debug N17",iters,nhx_seed(iters), -cd & nhx_use(iters),nhx_tot - enddo - - if (nhx_tot .ge. n17*nseed) then - ntot_gen=n17*nseed - else if (nhx_tot .ge. nseed) then - ntot_gen=(nhx_tot/nseed)*nseed - else - ntot_gen=nhx_tot - endif -cd write (iout,*) "debug N17==",ntot_gen,nhx_tot,nseed - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nhx_use(iters).gt.0) then -cd write (iout,*) "debug N17",nhx_use(iters),ngen,ntot_gen -cd write (iout,*) "debugN17^", -cd & (ihx_use(0,k,iters),k=1,nhx_use(iters)) - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nhx_seed(iters)) -cd write (iout,*) "debugN17^",iih - if (ihx_use(0,iih,iters).gt.0) then - iim=iran_num(1,2) -cd write (iout,*) "debugN17=",iih,nhx_seed(iters) -cd write (iout,*) "debugN17-",iim,'##', -cd & (ihx_use(k,iih,iters),k=0,2) -cd call flush(iout) - do while (ihx_use(iim,iih,iters).eq.1) - iim=iran_num(1,2) -cd write (iout,*) "debugN17-",iim,'##', -cd & (ihx_use(k,iih,iters),k=0,2) -cd call flush(iout) - enddo - nicht_getan=.false. - ihx_use(iim,iih,iters)=1 - ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 - nhx_use(iters)=nhx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=17 - parent(1,index)=iseed - parent(2,index)=0 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - if (iim.eq.1) then - idata(1,index)=ihx_seed(1,iih,iters) - idata(2,index)=ihx_seed(2,iih,iters) - else - idata(1,index)=ihx_seed(3,iih,iters) - idata(2,index)=ihx_seed(4,iih,iters) - endif - - if (ngen.eq.ntot_gen) goto 115 - endif - enddo - enddo - 115 continue - write (iout,*) "N17",n17," ngen/nseed",ngen/nseed, - & ngen,nseed - - - ENDIF -c----------------------------------------- -c N16 : slide non local beta in a seed by +/- 1 or +/- 2 -c - IF (n16.gt.0) THEN - nhx_tot=0 - do iters=1,nseed - i1=is(iters) - nhx_seed(iters)=0 - do i2=1,n7frag - if (bvar_frag(i2,1).eq.i1) then - nhx_seed(iters)=nhx_seed(iters)+1 - ihx_seed(1,nhx_seed(iters),iters)=bvar_frag(i2,3) - ihx_seed(2,nhx_seed(iters),iters)=bvar_frag(i2,4) - ihx_seed(3,nhx_seed(iters),iters)=bvar_frag(i2,5) - ihx_seed(4,nhx_seed(iters),iters)=bvar_frag(i2,6) - ihx_use(0,nhx_seed(iters),iters)=4 - do i3=1,4 - ihx_use(i3,nhx_seed(iters),iters)=0 - enddo - endif - enddo - nhx_use(iters)=4*nhx_seed(iters) - nhx_tot=nhx_tot+nhx_seed(iters) -cd write (iout,*) "debug N16",iters,nhx_seed(iters) - enddo - - if (4*nhx_tot .ge. n16*nseed) then - ntot_gen=n16*nseed - else if (4*nhx_tot .ge. nseed) then - ntot_gen=(4*nhx_tot/nseed)*nseed - else - ntot_gen=4*nhx_tot - endif - write (iout,*) "debug N16",ntot_gen,4*nhx_tot,nseed - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nhx_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nhx_seed(iters)) - if (ihx_use(0,iih,iters).gt.0) then - iim=iran_num(1,4) - do while (ihx_use(iim,iih,iters).eq.1) -cd write (iout,*) iim, -cd & ihx_use(0,iih,iters),ihx_use(iim,iih,iters) - iim=iran_num(1,4) - enddo - nicht_getan=.false. - ihx_use(iim,iih,iters)=1 - ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 - nhx_use(iters)=nhx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=16 - parent(1,index)=iseed - parent(2,index)=0 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do i=1,4 - idata(i,index)=ihx_seed(i,iih,iters) - enddo - idata(5,index)=iim - - if (ngen.eq.ntot_gen) goto 116 - endif - enddo - enddo - 116 continue - write (iout,*) "N16",n16," ngen/nseed",ngen/nseed, - & ngen,nseed - ENDIF -c----------------------------------------- -c N15 : copy two 2nd structure elements from 1 or 2 conf. in bank to a seed -c - IF (n15.gt.0) THEN - - do iters=1,nseed - iseed=is(iters) - do i=1,mxio - ifused(i)=.false. - enddo - - do idummy=1,n15 - iter=0 - 84 continue - - iran=0 - iif=iran_num(1,n15frag) - do while( (ifused(iif) .or. svar_frag(iif,1).eq.iseed) .and. - & iran.le.mxio ) - iif=iran_num(1,n15frag) - iran=iran+1 - enddo - if(iran.ge.mxio) goto 811 - - iran=0 - iig=iran_num(1,n15frag) - do while( (ifused(iig) .or. svar_frag(iig,1).eq.iseed .or. - & .not.(svar_frag(iif,3).lt.svar_frag(iig,2).or. - & svar_frag(iig,3).lt.svar_frag(iif,2)) ) .and. - & iran.le.mxio ) - iig=iran_num(1,n15frag) - iran=iran+1 - enddo - if(iran.ge.mxio) goto 811 - - index=index+1 - movenx(index)=15 - parent(1,index)=iseed - parent(2,index)=svar_frag(iif,1) - parent(3,index)=svar_frag(iig,1) - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - ifused(iif)=.true. - ifused(iig)=.true. - call newconf_copy(idum,dihang_in(1,1,1,index), - & svar_frag(iif,1),svar_frag(iif,2),svar_frag(iif,3)) - - do j=svar_frag(iig,2),svar_frag(iig,3) - do i=1,4 - dihang_in(i,j,1,index)=bvar(i,j,1,svar_frag(iig,1)) - enddo - enddo - - - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) then - index=index-1 - ifused(iif)=.false. - goto 84 - endif - endif - - 811 continue - enddo - enddo - ENDIF - -c----------------------------------------- -c N14 local_move (Maurizio) for loops in a seed -c - IF (n14.gt.0) THEN - nlx_tot=0 - do iters=1,nseed - i1=is(iters) - nlx_seed(iters)=0 - do i2=1,n14frag - if (lvar_frag(i2,1).eq.i1) then - nlx_seed(iters)=nlx_seed(iters)+3 - ilx_seed(1,nlx_seed(iters),iters)=lvar_frag(i2,2) - ilx_seed(2,nlx_seed(iters),iters)=lvar_frag(i2,3) - ilx_use(nlx_seed(iters),iters)=3 - endif - enddo - nlx_use(iters)=nlx_seed(iters) - nlx_tot=nlx_tot+nlx_seed(iters) -cd write (iout,*) "debug N14",iters,nlx_seed(iters) - enddo - - if (nlx_tot .ge. n14*nseed) then - ntot_gen=n14*nseed - else - ntot_gen=(nlx_tot/nseed)*nseed - endif -cd write (iout,*) "debug N14",ntot_gen,n14frag,nseed - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nlx_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nlx_seed(iters)) - if (ilx_use(iih,iters).gt.0) then - nicht_getan=.false. - ilx_use(iih,iters)=ilx_use(iih,iters)-1 - nlx_use(iters)=nlx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=14 - parent(1,index)=iseed - parent(2,index)=0 - - idata(1,index)=ilx_seed(1,iih,iters) - idata(2,index)=ilx_seed(2,iih,iters) - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - if (ngen.eq.ntot_gen) goto 131 - endif - enddo - enddo - 131 continue -cd write (iout,*) "N14",n14," ngen/nseed",ngen/nseed, -cd & ngen,nseed - - ENDIF -c----------------------------------------- -c N9 : shift a helix in a seed -c - IF (n9.gt.0) THEN - nhx_tot=0 - do iters=1,nseed - i1=is(iters) - nhx_seed(iters)=0 - do i2=1,n8frag - if (hvar_frag(i2,1).eq.i1) then - nhx_seed(iters)=nhx_seed(iters)+1 - ihx_seed(1,nhx_seed(iters),iters)=hvar_frag(i2,2) - ihx_seed(2,nhx_seed(iters),iters)=hvar_frag(i2,3) - ihx_use(0,nhx_seed(iters),iters)=4 - do i3=1,4 - ihx_use(i3,nhx_seed(iters),iters)=0 - enddo - endif - enddo - nhx_use(iters)=4*nhx_seed(iters) - nhx_tot=nhx_tot+nhx_seed(iters) -cd write (iout,*) "debug N9",iters,nhx_seed(iters) - enddo - - if (4*nhx_tot .ge. n9*nseed) then - ntot_gen=n9*nseed - else - ntot_gen=(4*nhx_tot/nseed)*nseed - endif -cd write (iout,*) "debug N9",ntot_gen,n8frag,nseed - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nhx_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nhx_seed(iters)) - if (ihx_use(0,iih,iters).gt.0) then - iim=iran_num(1,4) - do while (ihx_use(iim,iih,iters).eq.1) -cd write (iout,*) iim, -cd & ihx_use(0,iih,iters),ihx_use(iim,iih,iters) - iim=iran_num(1,4) - enddo - nicht_getan=.false. - ihx_use(iim,iih,iters)=1 - ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 - nhx_use(iters)=nhx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=9 - parent(1,index)=iseed - parent(2,index)=0 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - jstart=max(nnt,ihx_seed(1,iih,iters)+1) - jend=min(nct,ihx_seed(2,iih,iters)) -cd write (iout,*) "debug N9",iters,iih,jstart,jend - if (iim.eq.1) then - ishift=-2 - else if (iim.eq.2) then - ishift=-1 - else if (iim.eq.3) then - ishift=1 - else if (iim.eq.4) then - ishift=2 - else - write (iout,*) 'CHUJ NASTAPIL: iim=',iim - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do j=jstart,jend - if (itype(j).eq.10) then - iang=2 - else - iang=4 - endif - do i=1,iang - if (j+ishift.ge.nnt.and.j+ishift.le.nct) - & dihang_in(i,j+ishift,1,index)=bvar(i,j,1,iseed) - enddo - enddo - if (ishift.gt.0) then - do j=0,ishift-1 - if (itype(jend+j).eq.10) then - iang=2 - else - iang=4 - endif - do i=1,iang - if (jend+j.ge.nnt.and.jend+j.le.nct) - & dihang_in(i,jstart+j,1,index)=bvar(i,jend+j,1,iseed) - enddo - enddo - else - do j=0,-ishift-1 - if (itype(jstart+j).eq.10) then - iang=2 - else - iang=4 - endif - do i=1,iang - if (jend+j.ge.nnt.and.jend+j.le.nct) - & dihang_in(i,jend+j,1,index)=bvar(i,jstart+j,1,iseed) - enddo - enddo - endif - if (ngen.eq.ntot_gen) goto 133 - endif - enddo - enddo - 133 continue -cd write (iout,*) "N9",n9," ngen/nseed",ngen/nseed, -cd & ngen,nseed - - ENDIF -c----------------------------------------- -c N8 : copy a helix from bank to seed -c - if (n8.gt.0) then - if (n8frag.lt.n8) then - write (iout,*) "N8: only ",n8frag,'helices' - n8c=n8frag - else - n8c=n8 - endif - - do iters=1,nseed - iseed=is(iters) - do i=1,mxio - ifused(i)=.false. - enddo - - - do idummy=1,n8c - iter=0 - 94 continue - iran=0 - iif=iran_num(1,n8frag) - do while( (ifused(iif) .or. hvar_frag(iif,1).eq.iseed) .and. - & iran.le.mxio ) - iif=iran_num(1,n8frag) - iran=iran+1 - enddo - - if(iran.ge.mxio) goto 911 - - index=index+1 - movenx(index)=8 - parent(1,index)=iseed - parent(2,index)=hvar_frag(iif,1) - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - ifused(iif)=.true. - if (hvar_frag(iif,3)-hvar_frag(iif,2).le.6) then - call newconf_copy(idum,dihang_in(1,1,1,index), - & hvar_frag(iif,1),hvar_frag(iif,2),hvar_frag(iif,3)) - else - ih_start=iran_num(hvar_frag(iif,2),hvar_frag(iif,3)-6) - ih_end=iran_num(ih_start,hvar_frag(iif,3)) - call newconf_copy(idum,dihang_in(1,1,1,index), - & hvar_frag(iif,1),ih_start,ih_end) - endif - iter=iter+1 - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) then - index=index-1 - ifused(iif)=.false. - goto 94 - endif - endif - - - 911 continue - - enddo - enddo - - endif - -c----------------------------------------- -c N7 : copy nonlocal beta fragment from bank to seed -c - if (n7.gt.0) then - if (n7frag.lt.n7) then - write (iout,*) "N7: only ",n7frag,'nonlocal fragments' - n7c=n7frag - else - n7c=n7 - endif - - do i=1,maxres - do j=1,mxio2 - iff_in(i,j)=0 - enddo - enddo - index2=0 - do i=1,mxio - isend2(i)=0 - enddo - - do iters=1,nseed - iseed=is(iters) - do i=1,mxio - ifused(i)=.false. - enddo - - do idummy=1,n7c - iran=0 - iif=iran_num(1,n7frag) - do while( (ifused(iif) .or. bvar_frag(iif,1).eq.iseed) .and. - & iran.le.mxio ) - iif=iran_num(1,n7frag) - iran=iran+1 - enddo - -cd write (*,'(3i5,l,4i5)'),iters,idummy,iif,ifused(iif), -cd & bvar_frag(iif,1),iseed,iran,index2 - - if(iran.ge.mxio) goto 999 - if(index2.ge.mxio2) goto 999 - - index=index+1 - movenx(index)=7 - parent(1,index)=iseed - parent(2,index)=bvar_frag(iif,1) - index2=index2+1 - isend2(index)=index2 - ifused(iif)=.true. - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in2(i,j,k,index2)=bvar(i,j,k,bvar_frag(iif,1)) - enddo - enddo - enddo - - if (bvar_frag(iif,2).eq.4) then - do i=bvar_frag(iif,3),bvar_frag(iif,4) - iff_in(i,index2)=1 - enddo - if (bvar_frag(iif,5).lt.bvar_frag(iif,6)) then -cd print *,'###',bvar_frag(iif,3),bvar_frag(iif,4), -cd & bvar_frag(iif,5),bvar_frag(iif,6) - do i=bvar_frag(iif,5),bvar_frag(iif,6) - iff_in(i,index2)=1 - enddo - else -cd print *,'###',bvar_frag(iif,3),bvar_frag(iif,4), -cd & bvar_frag(iif,6),bvar_frag(iif,5) - do i=bvar_frag(iif,6),bvar_frag(iif,5) - iff_in(i,index2)=1 - enddo - endif - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - - 999 continue - - enddo - enddo - - endif -c----------------------------------------------- -c N6 : copy random continues fragment from bank to seed -c - do iters=1,nseed - iseed=is(iters) - do idummy=1,n6 - isize=(is2-is1+1)*ran1(idum)+is1 - index=index+1 - movenx(index)=6 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - iter=0 - 104 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 104 - iter=iter+1 - call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) - parent(1,index)=iseed - parent(2,index)=i1 - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 104 - endif - enddo - enddo -c----------------------------------------- - if (n3.gt.0.or.n4.gt.0) call gen_hairpin - nconf_harp=0 - do iters=1,nseed - if (nharp_seed(iters).gt.0) nconf_harp=nconf_harp+1 - enddo -c----------------------------------------- -c N3 : copy hairpin from bank to seed -c - do iters=1,nseed - iseed=is(iters) - nsucc=0 - nacc=0 - do idummy=1,n3 - index=index+1 - iter=0 - 124 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 124 - do k=1,nsucc - if (i1.eq.iisucc(k).and.nsucc.lt.nconf_harp-1) goto 124 - enddo - nsucc=nsucc+1 - iisucc(nsucc)=i1 - iter=iter+1 - call newconf_residue_hairpin(idum,dihang_in(1,1,1,index), - & i1,fail) - if (fail) then - if (icycle.le.0 .and. nsucc.eq.nconf .or. - & icycle.gt.0 .and. nsucc.eq.nbank) then - index=index-1 - goto 125 - else - goto 124 - endif - endif - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 124 - endif - movenx(index)=3 - parent(1,index)=iseed - parent(2,index)=i1 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - nacc=nacc+1 - enddo -c if not enough hairpins, supplement with windows - 125 continue -cdd if (n3.ne.0) write (iout,*) "N3",n3," nsucc",nsucc," nacc",nacc - do idummy=nacc+1,n3 - isize=(is2-is1+1)*ran1(idum)+is1 - index=index+1 - movenx(index)=6 - parent(1,index)=iseed - parent(2,index)=i1 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - iter=0 - 114 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 114 - iter=iter+1 - call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 114 - endif - enddo - enddo -c----------------------------------------- -c N4 : shift a turn in hairpin in seed -c - IF (N4.GT.0) THEN - if (4*nharp_tot .ge. n4*nseed) then - ntot_gen=n4*nseed - else - ntot_gen=(4*nharp_tot/nseed)*nseed - endif - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) -c write (iout,*) 'iters',iters,' iseed',iseed,' nharp_seed', -c & nharp_seed(iters),' nharp_use',nharp_use(iters), -c & ' ntot_gen',ntot_gen -c write (iout,*) 'iharp_use(0)', -c & (iharp_use(0,k,iters),k=1,nharp_seed(iters)) - if (nharp_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nharp_seed(iters)) -c write (iout,*) 'iih',iih,' iharp_use', -c & (iharp_use(k,iih,iters),k=1,4) - if (iharp_use(0,iih,iters).gt.0) then - nicht_getan1=.true. - do while (nicht_getan1) - iim=iran_num(1,4) - nicht_getan1=iharp_use(iim,iih,iters).eq.1 - enddo - nicht_getan=.false. - iharp_use(iim,iih,iters)=1 - iharp_use(0,iih,iters)=iharp_use(0,iih,iters)-1 - nharp_use(iters)=nharp_use(iters)-1 -cdd write (iout,'(a16,i3,a5,i2,a10,2i4)') -cdd & 'N4 selected hairpin',iih,' move',iim,' iharp_seed', -cdd & iharp_seed(1,iih,iters),iharp_seed(2,iih,iters) - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=4 - parent(1,index)=iseed - parent(2,index)=0 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - jstart=iharp_seed(1,iih,iters)+1 - jend=iharp_seed(2,iih,iters) - if (iim.eq.1) then - ishift=-2 - else if (iim.eq.2) then - ishift=-1 - else if (iim.eq.3) then - ishift=1 - else if (iim.eq.4) then - ishift=2 - else - write (iout,*) 'CHUJ NASTAPIL: iim=',iim - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif -c write (iout,*) 'jstart',jstart,' jend',jend,' ishift',ishift -c write (iout,*) 'Before turn shift' -c do j=2,nres-1 -c theta(j+1)=dihang_in(1,j,1,index) -c phi(j+2)=dihang_in(2,j,1,index) -c alph(j)=dihang_in(3,j,1,index) -c omeg(j)=dihang_in(4,j,1,index) -c enddo -c call intout - do j=jstart,jend - if (itype(j).eq.10) then - iang=2 - else - iang=4 - endif - do i=1,iang - if (j+ishift.ge.nnt.and.j+ishift.le.nct) - & dihang_in(i,j+ishift,1,index)=bvar(i,j,1,iseed) - enddo - enddo -c write (iout,*) 'After turn shift' -c do j=2,nres-1 -c theta(j+1)=dihang_in(1,j,1,index) -c phi(j+2)=dihang_in(2,j,1,index) -c alph(j)=dihang_in(3,j,1,index) -c omeg(j)=dihang_in(4,j,1,index) -c enddo -c call intout - if (ngen.eq.ntot_gen) goto 135 - endif - enddo - enddo -c if not enough hairpins, supplement with windows -c write (iout,*) 'end of enddo' - 135 continue -cdd write (iout,*) "N4",n4," ngen/nseed",ngen/nseed, -cdd & ngen,nseed - do iters=1,nseed - iseed=is(iters) - do idummy=ngen/nseed+1,n4 - isize=(is2-is1+1)*ran1(idum)+is1 - index=index+1 - movenx(index)=6 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - - iter=0 - 134 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 134 - iter=iter+1 - call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) - parent(1,index)=iseed - parent(2,index)=i1 - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 134 - endif - enddo - enddo - ENDIF -c----------------------------------------- -c N5 : copy one residue from bank to seed (normally switched off - use N1) -c - do iters=1,nseed - iseed=is(iters) - isize=1 - do i=1,n5 - index=index+1 - movenx(index)=5 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - - iter=0 - 105 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 105 - iter=iter+1 - call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) - parent(1,index)=iseed - parent(2,index)=i1 - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 105 - endif - enddo - enddo -c----------------------------------------- -c N2 : copy backbone of one residue from bank or first bank to seed -c (normally switched off - use N1) -c - do iters=1,nseed - iseed=is(iters) - do i=n2,1,-1 - if(icycle.le.0.and.iuse.gt.nconf-irr) then - iseed=ran1(idum)*nconf+1 - iseed=nbank-nconf+iseed - endif - index=index+1 - movenx(index)=2 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - iter=0 - 102 i1= ran1(idum)*nbank+1 - if(i1.eq.iseed) goto 102 - iter=iter+1 - if(icycle.le.0.and.iuse.gt.nconf-irr) then - nran=mod(i-1,nran0)+3 - call newconf1arr(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=-iseed - parent(2,index)=-i1 - else if(icycle.le.0.and.iters.le.iuse) then - nran=mod(i-1,nran0)+1 - call newconf1abr(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=-i1 - else - nran=mod(i-1,nran1)+1 - if(ran1(idum).lt.0.5) then - call newconf1abr(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=-i1 - else - call newconf1abb(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=i1 - endif - endif - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 102 - endif - enddo - enddo -c----------------------------------------- -c N1 : copy backbone or sidechain of one residue from bank or -c first bank to seed -c - do iters=1,nseed - iseed=is(iters) - do i=n1,1,-1 - if(icycle.le.0.and.iuse.gt.nconf-irr) then - iseed=ran1(idum)*nconf+1 - iseed=nbank-nconf+iseed - endif - index=index+1 - movenx(index)=1 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - iter=0 - 101 i1= ran1(idum)*nbank+1 - - if(i1.eq.iseed) goto 101 - iter=iter+1 - if(icycle.le.0.and.iuse.gt.nconf-irr) then - nran=mod(i-1,nran0)+3 - call newconf1rr(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=-iseed - parent(2,index)=-i1 - else if(icycle.le.0.and.iters.le.iuse) then - nran=mod(i-1,nran0)+1 - call newconf1br(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=-i1 - else - nran=mod(i-1,nran1)+1 - if(ran1(idum).lt.0.5) then - call newconf1br(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=-i1 - else - call newconf1bb(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=i1 - endif - endif - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 101 - endif - enddo - enddo -c----------------------------------------- -c N0 just all seeds -c - IF (n0.gt.0) THEN - do iters=1,nseed - iseed=is(iters) - index=index+1 - movenx(index)=0 - parent(1,index)=iseed - parent(2,index)=0 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - enddo - ENDIF -c----------------------------------------- - if (vdisulf) then - do iters=1,nseed - iseed=is(iters) - - do k=1,numch - do j=2,nres-1 - theta(j+1)=bvar(1,j,k,iseed) - phi(j+2)=bvar(2,j,k,iseed) - alph(j)=bvar(3,j,k,iseed) - omeg(j)=bvar(4,j,k,iseed) - enddo - enddo - call chainbuild - -cd write(iout,*) 'makevar DYNSS',iseed,'#',bvar_ns(iseed), -cd & (bvar_s(k,iseed),k=1,bvar_ns(iseed)), -cd & bvar_nss(iseed), -cd & (bvar_ss(1,k,iseed)-nres,'-', -cd & bvar_ss(2,k,iseed)-nres,k=1,bvar_nss(iseed)) - - do i1=1,bvar_ns(iseed) -c -c N10 fussion of free halfcysteines in seed -c first select CYS with distance < 7A -c - do j1=i1+1,bvar_ns(iseed) - if (dist(bvar_s(i1,iseed)+nres,bvar_s(j1,iseed)+nres) - & .lt.7.0.and. - & iabs(bvar_s(i1,iseed)-bvar_s(j1,iseed)).gt.3) then - - index=index+1 - movenx(index)=10 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - ij=bvar_nss(iseed)+1 - nss_in(index)=ij - iss_in(ij,index)=bvar_s(i1,iseed)+nres - jss_in(ij,index)=bvar_s(j1,iseed)+nres - -cd write(iout,*) 'makevar NSS0',index, -cd & dist(bvar_s(i1,iseed)+nres,bvar_s(j1,iseed)+nres), -cd & nss_in(index),iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - enddo -c -c N11 type I transdisulfidation -c - do j1=1,bvar_nss(iseed) - if (dist(bvar_s(i1,iseed)+nres,bvar_ss(1,j1,iseed)) - & .lt.7.0.and. - & iabs(bvar_s(i1,iseed)-(bvar_ss(1,j1,iseed)-nres)) - & .gt.3) then - - index=index+1 - movenx(index)=11 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - if (ij.ne.j1) then - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed) - iss_in(j1,index)=bvar_s(i1,iseed)+nres - jss_in(j1,index)=bvar_ss(1,j1,iseed) - if (iss_in(j1,index).gt.jss_in(j1,index)) then - iss_in(j1,index)=bvar_ss(1,j1,iseed) - jss_in(j1,index)=bvar_s(i1,iseed)+nres - endif - -cd write(iout,*) 'makevar NSS1 #1',index, -cd & bvar_s(i1,iseed),bvar_ss(1,j1,iseed)-nres, -cd & dist(bvar_s(i1,iseed)+nres,bvar_ss(1,j1,iseed)), -cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -cd & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - endif - if (dist(bvar_s(i1,iseed)+nres,bvar_ss(2,j1,iseed)) - & .lt.7.0.and. - & iabs(bvar_s(i1,iseed)-(bvar_ss(2,j1,iseed)-nres)) - & .gt.3) then - - index=index+1 - movenx(index)=11 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - if (ij.ne.j1) then - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed) - iss_in(j1,index)=bvar_s(i1,iseed)+nres - jss_in(j1,index)=bvar_ss(2,j1,iseed) - if (iss_in(j1,index).gt.jss_in(j1,index)) then - iss_in(j1,index)=bvar_ss(2,j1,iseed) - jss_in(j1,index)=bvar_s(i1,iseed)+nres - endif - - -cd write(iout,*) 'makevar NSS1 #2',index, -cd & bvar_s(i1,iseed),bvar_ss(2,j1,iseed)-nres, -cd & dist(bvar_s(i1,iseed)+nres,bvar_ss(2,j1,iseed)), -cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -cd & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - enddo - enddo - -c -c N12 type II transdisulfidation -c - do i1=1,bvar_nss(iseed) - do j1=i1+1,bvar_nss(iseed) - if (dist(bvar_ss(1,i1,iseed),bvar_ss(1,j1,iseed)) - & .lt.7.0.and. - & dist(bvar_ss(2,i1,iseed),bvar_ss(2,j1,iseed)) - & .lt.7.0.and. - & iabs(bvar_ss(1,i1,iseed)-bvar_ss(1,j1,iseed)) - & .gt.3.and. - & iabs(bvar_ss(2,i1,iseed)-bvar_ss(2,j1,iseed)) - & .gt.3) then - index=index+1 - movenx(index)=12 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - if (ij.ne.i1 .and. ij.ne.j1) then - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed) - iss_in(i1,index)=bvar_ss(1,i1,iseed) - jss_in(i1,index)=bvar_ss(1,j1,iseed) - if (iss_in(i1,index).gt.jss_in(i1,index)) then - iss_in(i1,index)=bvar_ss(1,j1,iseed) - jss_in(i1,index)=bvar_ss(1,i1,iseed) - endif - iss_in(j1,index)=bvar_ss(2,i1,iseed) - jss_in(j1,index)=bvar_ss(2,j1,iseed) - if (iss_in(j1,index).gt.jss_in(j1,index)) then - iss_in(j1,index)=bvar_ss(2,j1,iseed) - jss_in(j1,index)=bvar_ss(2,i1,iseed) - endif - - -cd write(iout,*) 'makevar NSS2 #1',index, -cd & bvar_ss(1,i1,iseed)-nres,bvar_ss(1,j1,iseed)-nres, -cd & dist(bvar_ss(1,i1,iseed),bvar_ss(1,j1,iseed)), -cd & bvar_ss(2,i1,iseed)-nres,bvar_ss(2,j1,iseed)-nres, -cd & dist(bvar_ss(2,i1,iseed),bvar_ss(2,j1,iseed)), -cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -cd & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - - if (dist(bvar_ss(1,i1,iseed),bvar_ss(2,j1,iseed)) - & .lt.7.0.and. - & dist(bvar_ss(2,i1,iseed),bvar_ss(1,j1,iseed)) - & .lt.7.0.and. - & iabs(bvar_ss(1,i1,iseed)-bvar_ss(2,j1,iseed)) - & .gt.3.and. - & iabs(bvar_ss(2,i1,iseed)-bvar_ss(1,j1,iseed)) - & .gt.3) then - index=index+1 - movenx(index)=12 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - if (ij.ne.i1 .and. ij.ne.j1) then - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed) - iss_in(i1,index)=bvar_ss(1,i1,iseed) - jss_in(i1,index)=bvar_ss(2,j1,iseed) - if (iss_in(i1,index).gt.jss_in(i1,index)) then - iss_in(i1,index)=bvar_ss(2,j1,iseed) - jss_in(i1,index)=bvar_ss(1,i1,iseed) - endif - iss_in(j1,index)=bvar_ss(2,i1,iseed) - jss_in(j1,index)=bvar_ss(1,j1,iseed) - if (iss_in(j1,index).gt.jss_in(j1,index)) then - iss_in(j1,index)=bvar_ss(1,j1,iseed) - jss_in(j1,index)=bvar_ss(2,i1,iseed) - endif - - -cd write(iout,*) 'makevar NSS2 #2',index, -cd & bvar_ss(1,i1,iseed)-nres,bvar_ss(2,j1,iseed)-nres, -cd & dist(bvar_ss(1,i1,iseed),bvar_ss(2,j1,iseed)), -cd & bvar_ss(2,i1,iseed)-nres,bvar_ss(1,j1,iseed)-nres, -cd & dist(bvar_ss(2,i1,iseed),bvar_ss(1,j1,iseed)), -cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -cd & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - - - enddo - enddo -c -c N13 removal of disulfide bond -c - if (bvar_nss(iseed).gt.0) then - i1=bvar_nss(iseed)*ran1(idum)+1 - - index=index+1 - movenx(index)=13 - parent(1,index)=iseed - parent(2,index)=0 - ij=0 - do j1=1,bvar_nss(iseed) - if (j1.ne.i1) then - ij=ij+1 - iss_in(ij,index)=bvar_ss(1,j1,iseed) - jss_in(ij,index)=bvar_ss(2,j1,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed)-1 - -cd write(iout,*) 'NSS3',index,i1, -cd & bvar_ss(1,i1,iseed)-nres,'=',bvar_ss(2,i1,iseed)-nres,'#', -cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -cd & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - - enddo - endif -c----------------------------------------- - - - - if(index.ne.n) write(iout,*)'make_var : ntry=',index - - n=index -cd do ii=1,n -cd write (istat,*) "======== ii=",ii," the dihang array" -cd do i=1,nres -cd write (istat,'(i5,4f15.5)') i,(dihang_in(k,i,1,ii)*rad2deg,k=1,4) -cd enddo -cd enddo - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine check_old(icheck,n) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - data ctdif /10./ - data ctdiff /60./ - - i1=n - do i2=1,n-1 - diff=0.d0 - do m=1,numch - do j=2,nres-1 - do i=1,4 - dif=rad2deg*dabs(dihang_in(i,j,m,i1)-dihang_in(i,j,m,i2)) - if(dif.gt.180.0) dif=360.0-dif - if(dif.gt.ctdif) goto 100 - diff=diff+dif - if(diff.gt.ctdiff) goto 100 - enddo - enddo - enddo - icheck=1 - return - 100 continue - enddo - - icheck=0 - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf1rr(idum,vvar,nran,i1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=rvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=ntotgr - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=rvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf1br(idum,vvar,nran,i1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=ntotgr - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(i2ndstr.gt.0) then - rtmp=ran1(idum) - if(rtmp.le.rdih_bias) then - i=0 - do j=1,ndih_nconstr - if(igroup(2,1,iran).eq.idih_nconstr(j))i=j - enddo - if(i.eq.0) then - juhc=0 -4321 juhc=juhc+1 - iran= ran1(idum)*number+1 - i=0 - do j=1,ndih_nconstr - if(igroup(2,1,iran).eq.idih_nconstr(j))i=j - enddo - if(i.eq.0.or.juhc.lt.1000)goto 4321 - if(juhc.eq.1000) then - print *, 'move 6 : failed to find unconstrained group' - write(iout,*) 'move 6 : failed to find unconstrained group' - endif - endif - endif - endif - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=rvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf1bb(idum,vvar,nran,i1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=ntotgr - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=bvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf1arr(idum,vvar,nran,i1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=rvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=nres-2 - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=rvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf1abr(idum,vvar,nran,i1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=nres-2 - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(i2ndstr.gt.0) then - rtmp=ran1(idum) - if(rtmp.le.rdih_bias) then - iran=ran1(idum)*ndih_nconstr+1 - iran=idih_nconstr(iran) - endif - endif - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=rvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf1abb(idum,vvar,nran,i1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=nres-2 - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(i2ndstr.gt.0) then - rtmp=ran1(idum) - if(rtmp.le.rdih_bias) then - iran=ran1(idum)*ndih_nconstr+1 - iran=idih_nconstr(iran) - endif - endif - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=bvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf_residue(idum,vvar,i1,isize) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - if (iseed.gt.mxio .or. iseed.lt.1) then - write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - - k=1 - number=nres+isize-2 - iter=1 - 10 iran= ran1(idum)*number+1 - if(i2ndstr.gt.0) then - rtmp=ran1(idum) - if(rtmp.le.rdih_bias) then - iran=ran1(idum)*ndih_nconstr+1 - iran=idih_nconstr(iran) - endif - endif - istart=iran-isize+1 - iend=iran - if(istart.lt.2) istart=2 - if(iend.gt.nres-1) iend=nres-1 - - if(iter.eq.1) goto 11 - do ind=1,iter-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do j=istart,iend - do i=1,4 - dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - enddo - iold(iter)=iran - iter=iter+1 - if(iter.gt.number) goto 20 - goto 10 - - 20 continue - do j=istart,iend - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,i1) - enddo - enddo - - return - end - -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf_copy(idum,vvar,i1,istart,iend) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - if (iseed.gt.mxio .or. iseed.lt.1) then - write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - - do j=istart,iend - do i=1,4 - vvar(i,j,1)=bvar(i,j,1,i1) - enddo - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf_residue_hairpin(idum,vvar,i1,fail) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.VAR' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - integer nharp,iharp(4,maxres/3),icipa(maxres/3) - logical fail,not_done - ctdif=10. - - fail=.false. - if (iseed.gt.mxio .or. iseed.lt.1) then - write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - do k=1,numch - do j=2,nres-1 - theta(j+1)=bvar(1,j,k,i1) - phi(j+2)=bvar(2,j,k,i1) - alph(j)=bvar(3,j,k,i1) - omeg(j)=bvar(4,j,k,i1) - enddo - enddo -c call intout - call chainbuild - call hairpin(.false.,nharp,iharp) - - if (nharp.eq.0) then - fail=.true. - return - endif - - n_used=0 - - DO III=1,NHARP - - not_done = .true. - icount=0 - do while (not_done) - icount=icount+1 - iih=iran_num(1,nharp) - do k=1,n_used - if (iih.eq.icipa(k)) then - iih=0 - goto 22 - endif - enddo - not_done=.false. - n_used=n_used+1 - icipa(n_used)=iih - 22 continue - not_done = not_done .and. icount.le.nharp - enddo - - if (iih.eq.0) then - write (iout,*) "CHUJ NASTAPIL W NEWCONF_RESIDUE_HAIRPIN!!!!" - fail=.true. - return - endif - - istart=iharp(1,iih)+1 - iend=iharp(2,iih) - -cdd write (iout,*) "newconf_residue_hairpin: iih",iih, -cdd & " istart",istart," iend",iend - - do k=1,numch - do j=istart,iend - do i=1,4 - dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - enddo - enddo - goto 10 - 20 continue - do k=1,numch - do j=istart,iend - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,i1) - enddo - enddo - enddo -c do j=1,numch -c do l=2,nres-1 -c write (iout,'(4f8.3)') (rad2deg*vvar(i,l,j),i=1,4) -c enddo -c enddo - return - 10 continue - ENDDO - - fail=.true. - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine gen_hairpin - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.HAIRPIN' - -c write (iout,*) 'Entering GEN_HAIRPIN' - do iters=1,nseed - i1=is(iters) - do k=1,numch - do j=2,nres-1 - theta(j+1)=bvar(1,j,k,i1) - phi(j+2)=bvar(2,j,k,i1) - alph(j)=bvar(3,j,k,i1) - omeg(j)=bvar(4,j,k,i1) - enddo - enddo - call chainbuild - call hairpin(.false.,nharp_seed(iters),iharp_seed(1,1,iters)) - enddo - - nharp_tot=0 - do iters=1,nseed - nharp_tot=nharp_tot+nharp_seed(iters) - nharp_use(iters)=4*nharp_seed(iters) - do j=1,nharp_seed(iters) - iharp_use(0,j,iters)=4 - do k=1,4 - iharp_use(k,j,iters)=0 - enddo - enddo - enddo - - write (iout,*) 'GEN_HAIRPIN: nharp_tot',nharp_tot -cdd do i=1,nseed -cdd write (iout,*) 'seed',i -cdd write (iout,*) 'nharp_seed',nharp_seed(i), -cdd & ' nharp_use',nharp_use(i) -cd write (iout,*) 'iharp_seed, iharp_use' -cd do j=1,nharp_seed(i) -cd write (iout,'(7i3)') iharp_seed(1,j,i),iharp_seed(2,j,i), -cd & (iharp_use(k,j,i),k=0,4) -cd enddo -cdd enddo - return - end - -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine select_frag(nn,nh,nl,ns,nb,i_csa) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.HAIRPIN' - include 'COMMON.DISTFIT' - character*50 linia - integer isec(maxres) - - - nn=0 - nh=0 - nl=0 - ns=0 - nb=0 -cd write (iout,*) 'Entering select_frag' - do i1=1,nbank - do i=1,nres - isec(i)=0 - enddo - do k=1,numch - do j=2,nres-1 - theta(j+1)=bvar(1,j,k,i1) - phi(j+2)=bvar(2,j,k,i1) - alph(j)=bvar(3,j,k,i1) - omeg(j)=bvar(4,j,k,i1) - enddo - enddo - call chainbuild -cd write (iout,*) ' -- ',i1,' -- ' - call secondary2(.false.) -c -c bvar_frag nn==pair of nonlocal strands in beta sheet (loop>4) -c strands > 4 residues; used by N7 and N16 -c - do j=1,nbfrag -c -Ctest 09/12/02 bfrag(2,j)-bfrag(1,j).gt.3 -c - do i=bfrag(1,j),bfrag(2,j) - isec(i)=1 - enddo - do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j)) - isec(i)=1 - enddo - - if ( (bfrag(3,j).lt.bfrag(4,j) .or. - & bfrag(4,j)-bfrag(2,j).gt.4) .and. - & bfrag(2,j)-bfrag(1,j).gt.4 ) then - nn=nn+1 - - - if (bfrag(3,j).lt.bfrag(4,j)) then - write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') - & "select",bfrag(1,j)-1,"-",bfrag(2,j)-1 - & ,",",bfrag(3,j)-1,"-",bfrag(4,j)-1 - else - write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') - & "select",bfrag(1,j)-1,"-",bfrag(2,j)-1 - & ,",",bfrag(4,j)-1,"-",bfrag(3,j)-1 - - endif -cd call write_pdb(i_csa*1000+nn+nh,linia,0d0) - - bvar_frag(nn,1)=i1 - bvar_frag(nn,2)=4 - do i=1,4 - bvar_frag(nn,i+2)=bfrag(i,j) - enddo - endif - enddo - -c -c hvar_frag nh==helices; used by N8 and N9 -c - do j=1,nhfrag - - do i=hfrag(1,j),hfrag(2,j) - isec(i)=2 - enddo - - if ( hfrag(2,j)-hfrag(1,j).gt.4 ) then - nh=nh+1 - -cd write(linia,'(a6,i3,a1,i3)') -cd & "select",hfrag(1,j)-1,"-",hfrag(2,j)-1 -cd call write_pdb(i_csa*1000+nn+nh,linia,0d0) - - hvar_frag(nh,1)=i1 - hvar_frag(nh,2)=hfrag(1,j) - hvar_frag(nh,3)=hfrag(2,j) - endif - enddo - - -cv write(iout,'(i4,1pe12.4,1x,1000i1)') -cv & i1,bene(i1),(isec(i),i=1,nres) -cv write(linia,'(i4,1x,1000i1)') -cv & i1,(isec(i),i=1,nres) -cv call write_pdb(i_csa*1000+i1,linia,bene(i1)) -c -c lvar_frag nl==loops; used by N14 -c - i=1 - nl1=nl - do while (i.lt.nres) - if (isec(i).eq.0) then - nl=nl+1 - lvar_frag(nl,1)=i1 - lvar_frag(nl,2)=i - i=i+1 - do while (isec(i).eq.0.and.i.le.nres) - i=i+1 - enddo - lvar_frag(nl,3)=i-1 - if (lvar_frag(nl,3)-lvar_frag(nl,2).lt.1) nl=nl-1 - endif - i=i+1 - enddo -cd write(iout,'(4i5)') (i,(lvar_frag(i,ii),ii=1,3),i=nl1+1,nl) - -c -c svar_frag ns==an secondary structure element; used by N15 -c - i=1 - ns1=ns - do while (i.lt.nres) - if (isec(i).gt.0) then - ns=ns+1 - svar_frag(ns,1)=i1 - svar_frag(ns,2)=i - i=i+1 - do while (isec(i).gt.0.and.isec(i-1).eq.isec(i) - & .and.i.le.nres) - i=i+1 - enddo - svar_frag(ns,3)=i-1 - if (svar_frag(ns,3)-svar_frag(ns,2).lt.1) ns=ns-1 - endif - if (isec(i).eq.0) i=i+1 - enddo -cd write(iout,'(4i5)') (i,(svar_frag(i,ii),ii=1,3),i=ns1+1,ns) - -c -c avar_frag nb==any pair of beta strands; used by N17 -c - do j=1,nbfrag - nb=nb+1 - avar_frag(nb,1)=i1 - do i=1,4 - avar_frag(nb,i+1)=bfrag(i,j) - enddo - enddo - - enddo - - return - end diff --git a/source/unres/src_MD-M-newcorr/objects.sizes b/source/unres/src_MD-M-newcorr/objects.sizes deleted file mode 100644 index 862d1e3..0000000 --- a/source/unres/src_MD-M-newcorr/objects.sizes +++ /dev/null @@ -1,168 +0,0 @@ - text data bss dec hex filename - 342 80 0 422 1a6 add.o - text data bss dec hex filename - 104 44 0 148 94 arcos.o - text data bss dec hex filename - 2316 352 0 2668 a6c banach.o - text data bss dec hex filename - 42120 5468 772 48360 bce8 bank.o - text data bss dec hex filename - 9994 764 8 10766 2a0e blas.o - text data bss dec hex filename - 5016 680 272 5968 1750 bond_move.o - text data bss dec hex filename - 4144 196 259392 263732 40634 cartder.o - text data bss dec hex filename - 1040 224 0 1264 4f0 cartprint.o - text data bss dec hex filename - 2572 404 40 3016 bc8 chainbuild.o - text data bss dec hex filename - 368 132 184 684 2ac check_bond.o - text data bss dec hex filename - 16364 2264 390656 409284 63ec4 checkder_p.o - text data bss dec hex filename - 696 236 32 964 3c4 check_sc_distr.o - text data bss dec hex filename - 2640 832 0 3472 d90 cinfo.o - text data bss dec hex filename - 6036 980 43352 50368 c4c0 compare_s1.o - text data bss dec hex filename - 5032 672 86456 92160 16800 contact.o - text data bss dec hex filename - 3576 484 43216 47276 b8ac convert.o - text data bss dec hex filename - 28680 5840 1240 35760 8bb0 cored.o - text data bss dec hex filename - 7372 1448 264 9084 237c csa.o - text data bss dec hex filename - 632 52 0 684 2ac diff12.o - text data bss dec hex filename - 5276 768 248 6292 1894 dihed_cons.o - text data bss dec hex filename - 5840 884 21744 28468 6f34 distfit.o - text data bss dec hex filename - 4276 256 1256 5788 169c djacob.o - text data bss dec hex filename - 2200 240 0 2440 988 econstr_local.o - text data bss dec hex filename - 35258 3508 320 39086 98ae eigen.o - text data bss dec hex filename - 17660 1744 191000 210404 335e4 elecont.o - text data bss dec hex filename - 150482 10704 429408 590594 90302 energy_p_new.o - text data bss dec hex filename - 44420 4204 1136 49760 c260 energy_p_new-sep.o - text data bss dec hex filename - 3276 304 600 4180 1054 energy_split-sep.o - text data bss dec hex filename - 27800 2828 86956 117584 1cb50 entmcm.o - text data bss dec hex filename - 9964 764 568 11296 2c20 fitsq.o - text data bss dec hex filename - 2604 136 0 2740 ab4 gauss.o - text data bss dec hex filename - 15888 3224 6056 25168 6250 gen_rand_conf.o - text data bss dec hex filename - 21996 2892 26120 51008 c740 geomout.o - text data bss dec hex filename - 272 156 0 428 1ac gnmr1.o - text data bss dec hex filename - 5564 464 24 6052 17a4 gradient_p.o - text data bss dec hex filename - 1202 116 2000 3318 cf6 indexx.o - text data bss dec hex filename - 9528 16928 8308 34764 87cc initialize_p.o - text data bss dec hex filename - 12732 1176 633768 647676 9e1fc intcartderiv.o - text data bss dec hex filename - 1300 192 72 1564 61c intcor.o - text data bss dec hex filename - 11628 1740 384 13752 35b8 intlocal.o - text data bss dec hex filename - 4732 180 0 4912 1330 int_to_cart.o - text data bss dec hex filename - 2116 132 48 2296 8f8 kinetic_lesyng.o - text data bss dec hex filename - 21386 2700 39369688 39393774 25919ee lagrangian_lesyng.o - text data bss dec hex filename - 12394 1692 624 14710 3976 local_move.o - text data bss dec hex filename - 3802 412 86768 90982 16366 map.o - text data bss dec hex filename - 648 60 72 780 30c matmult.o - text data bss dec hex filename - 32904 4732 218020 255656 3e6a8 mcm.o - text data bss dec hex filename - 25172 2412 130332 157916 268dc mc.o - text data bss dec hex filename - 51422 5916 865520 922858 e14ea MD_A-MTS.o - text data bss dec hex filename - 8328 764 260456 269548 41cec minimize_p.o - text data bss dec hex filename - 11376 1464 3406284 3419124 342bf4 minim_jlee.o - text data bss dec hex filename - 1384 164 86728 88276 158d4 minim_mcmf.o - text data bss dec hex filename - 5170 878 216 6264 1878 misc.o - text data bss dec hex filename - 6752 368 712 7832 1e98 moments.o - text data bss dec hex filename - 19346 3576 8716 31638 7b96 MP.o - text data bss dec hex filename - 42300 4512 14380584 14427396 dc2504 MREMD.o - text data bss dec hex filename - 8912 1368 20568 30848 7880 muca_md.o - text data bss dec hex filename - 50648 2904 24272 77824 13000 newconf.o - text data bss dec hex filename - 42598 4892 208 47698 ba52 parmread.o - text data bss dec hex filename - 124 40 0 164 a4 pinorm.o - text data bss dec hex filename - 1256 332 0 1588 634 printmat.o - text data bss dec hex filename - 1184 16588 0 17772 456c prng.o - text data bss dec hex filename - 11748 896 194728 207372 32a0c q_measure.o - text data bss dec hex filename - 2190 448 8840 11478 2cd6 randgens.o - text data bss dec hex filename - 3104 228 524 3856 f10 ran.o - text data bss dec hex filename - 23134 1992 129688 154814 25cbe rattle.o - text data bss dec hex filename - 10440 1176 896 12512 30e0 readpdb.o - text data bss dec hex filename - 114098 11732 14564 140394 2246a readrtns_CSA.o - text data bss dec hex filename - 1816 244 0 2060 80c refsys.o - text data bss dec hex filename - 3852 492 3272720 3277064 320108 regularize.o - text data bss dec hex filename - 896 140 0 1036 40c rescode.o - text data bss dec hex filename - 444 188 0 632 278 rmdd.o - text data bss dec hex filename - 4944 776 173320 179040 2bb60 rmsd.o - text data bss dec hex filename - 9152 1292 173700 184144 2cf50 sc_move.o - text data bss dec hex filename - 5960 1888 0 7848 1ea8 shift.o - text data bss dec hex filename - 5894 920 768 7582 1d9e sort.o - text data bss dec hex filename - 17784 1960 288280 308024 4b338 stochfric.o - text data bss dec hex filename - 10248 928 120 11296 2c20 sumsld.o - text data bss dec hex filename - 4894 524 67240 72658 11bd2 surfatom.o - text data bss dec hex filename - 55640 6124 8813080 8874844 876b5c test.o - text data bss dec hex filename - 16436 1876 1048 19360 4ba0 thread.o - text data bss dec hex filename - 1820 404 28 2252 8cc timing.o - text data bss dec hex filename - 31980 4560 220320 256860 3eb5c together.o - text data bss dec hex filename - 15850 3704 44640 64194 fac2 unres.o diff --git a/source/unres/src_MD-M-newcorr/parmread.F b/source/unres/src_MD-M-newcorr/parmread.F deleted file mode 100644 index e48d010..0000000 --- a/source/unres/src_MD-M-newcorr/parmread.F +++ /dev/null @@ -1,1375 +0,0 @@ - subroutine parmread -C -C Read the parameters of the probability distributions of the virtual-bond -C valence angles and the side chains and energy parameters. -C -C Important! Energy-term weights ARE NOT read here; they are read from the -C main input file instead, because NO defaults have yet been set for these -C parameters. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" - integer IERROR -#endif - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.SCCOR' - include 'COMMON.SCROT' - include 'COMMON.FFIELD' - include 'COMMON.NAMES' - include 'COMMON.SBRIDGE' - include 'COMMON.MD' - include 'COMMON.SETUP' - character*1 t1,t2,t3 - character*1 onelett(4) /"G","A","P","D"/ - character*1 toronelet(-2:2) /"p","a","G","A","P"/ - logical lprint,LaTeX - dimension blower(3,3,maxlob) - dimension b(13) - character*3 lancuch,ucase -C -C For printing parameters after they are read set the following in the UNRES -C C-shell script: -C -C setenv PRINT_PARM YES -C -C To print parameters in LaTeX format rather than as ASCII tables: -C -C setenv LATEX YES -C - call getenv_loc("PRINT_PARM",lancuch) - lprint = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") - call getenv_loc("LATEX",lancuch) - LaTeX = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") -C - dwa16=2.0d0**(1.0d0/6.0d0) - itypro=20 -C Assign virtual-bond length - vbl=3.8D0 - vblinv=1.0D0/vbl - vblinv2=vblinv*vblinv -c -c Read the virtual-bond parameters, masses, and moments of inertia -c and Stokes' radii of the peptide group and side chains -c -#ifdef CRYST_BOND - read (ibond,*) vbldp0,akp,mp,ip,pstok - do i=1,ntyp - nbondterm(i)=1 - read (ibond,*) vbldsc0(1,i),aksc(1,i),msc(i),isc(i),restok(i) - dsc(i) = vbldsc0(1,i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - enddo -#else - read (ibond,*) junk,vbldp0,akp,rjunk,mp,ip,pstok - do i=1,ntyp - read (ibond,*) nbondterm(i),(vbldsc0(j,i),aksc(j,i),abond0(j,i), - & j=1,nbondterm(i)),msc(i),isc(i),restok(i) - dsc(i) = vbldsc0(1,i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - enddo -#endif - if (lprint) then - write(iout,'(/a/)')"Dynamic constants of the interaction sites:" - write (iout,'(a10,a3,6a10)') 'Type','N','VBL','K','A0','mass', - & 'inertia','Pstok' - write(iout,'(a10,i3,6f10.5)') "p",1,vbldp0,akp,0.0d0,mp,ip,pstok - do i=1,ntyp - write (iout,'(a10,i3,6f10.5)') restyp(i),nbondterm(i), - & vbldsc0(1,i),aksc(1,i),abond0(1,i),msc(i),isc(i),restok(i) - do j=2,nbondterm(i) - write (iout,'(13x,3f10.5)') - & vbldsc0(j,i),aksc(j,i),abond0(j,i) - enddo - enddo - endif -#ifdef CRYST_THETA -C -C Read the parameters of the probability distribution/energy expression -C of the virtual-bond valence angles theta -C - do i=1,ntyp - read (ithep,*,err=111,end=111) a0thet(i),(athet(j,i,1,1),j=1,2), - & (bthet(j,i,1,1),j=1,2) - read (ithep,*,err=111,end=111) (polthet(j,i),j=0,3) - read (ithep,*,err=111,end=111) (gthet(j,i),j=1,3) - read (ithep,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) - sigc0(i)=sigc0(i)**2 - enddo - do i=1,ntyp - athet(1,i,1,-1)=athet(1,i,1,1) - athet(2,i,1,-1)=athet(2,i,1,1) - bthet(1,i,1,-1)=-bthet(1,i,1,1) - bthet(2,i,1,-1)=-bthet(2,i,1,1) - athet(1,i,-1,1)=-athet(1,i,1,1) - athet(2,i,-1,1)=-athet(2,i,1,1) - bthet(1,i,-1,1)=bthet(1,i,1,1) - bthet(2,i,-1,1)=bthet(2,i,1,1) - enddo - do i=-ntyp,-1 - a0thet(i)=a0thet(-i) - athet(1,i,-1,-1)=athet(1,-i,1,1) - athet(2,i,-1,-1)=-athet(2,-i,1,1) - bthet(1,i,-1,-1)=bthet(1,-i,1,1) - bthet(2,i,-1,-1)=-bthet(2,-i,1,1) - athet(1,i,-1,1)=athet(1,-i,1,1) - athet(2,i,-1,1)=-athet(2,-i,1,1) - bthet(1,i,-1,1)=-bthet(1,-i,1,1) - bthet(2,i,-1,1)=bthet(2,-i,1,1) - athet(1,i,1,-1)=-athet(1,-i,1,1) - athet(2,i,1,-1)=athet(2,-i,1,1) - bthet(1,i,1,-1)=bthet(1,-i,1,1) - bthet(2,i,1,-1)=-bthet(2,-i,1,1) - theta0(i)=theta0(-i) - sig0(i)=sig0(-i) - sigc0(i)=sigc0(-i) - do j=0,3 - polthet(j,i)=polthet(j,-i) - enddo - do j=1,3 - gthet(j,i)=gthet(j,-i) - enddo - enddo - - close (ithep) - if (lprint) then - if (.not.LaTeX) then - write (iout,'(a)') - & 'Parameters of the virtual-bond valence angles:' - write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:', - & ' ATHETA0 ',' A1 ',' A2 ', - & ' B1 ',' B2 ' - do i=1,ntyp - write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, - & a0thet(i),(athet(j,i,1,1),j=1,2),(bthet(j,i,1,1),j=1,2) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the expression for sigma(theta_c):', - & ' ALPH0 ',' ALPH1 ',' ALPH2 ', - & ' ALPH3 ',' SIGMA0C ' - do i=1,ntyp - write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, - & (polthet(j,i),j=0,3),sigc0(i) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the second gaussian:', - & ' THETA0 ',' SIGMA0 ',' G1 ', - & ' G2 ',' G3 ' - do i=1,ntyp - write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i), - & sig0(i),(gthet(j,i),j=1,3) - enddo - else - write (iout,'(a)') - & 'Parameters of the virtual-bond valence angles:' - write (iout,'(/a/9x,5a/79(1h-))') - & 'Coefficients of expansion', - & ' theta0 ',' a1*10^2 ',' a2*10^2 ', - & ' b1*10^1 ',' b2*10^1 ' - do i=1,ntyp - write(iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i), - & a0thet(i),(100*athet(j,i,1,1),j=1,2), - & (10*bthet(j,i,1,1),j=1,2) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the expression for sigma(theta_c):', - & ' alpha0 ',' alph1 ',' alph2 ', - & ' alhp3 ',' sigma0c ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(1pe12.3,1h&))') restyp(i), - & (polthet(j,i),j=0,3),sigc0(i) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the second gaussian:', - & ' theta0 ',' sigma0*10^2 ',' G1*10^-1', - & ' G2 ',' G3*10^1 ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),theta0(i), - & 100*sig0(i),gthet(1,i)*0.1D0,gthet(2,i),gthet(3,i)*10.0D0 - enddo - endif - endif -#else -C -C Read the parameters of Utheta determined from ab initio surfaces -C Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -C - read (ithep,*,err=111,end=111) nthetyp,ntheterm,ntheterm2, - & ntheterm3,nsingle,ndouble - nntheterm=max0(ntheterm,ntheterm2,ntheterm3) - read (ithep,*,err=111,end=111) (ithetyp(i),i=1,ntyp1) - do i=-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 VAR:iblock means terminally blocking group 1=non-proline 2=proline - do iblock=1,2 -c VAR:ntethtyp is type of theta potentials type currently 0=glycine -c VAR:1=non-glicyne non-proline 2=proline -c VAR:negative values for D-aminoacid - do i=0,nthetyp - do j=-nthetyp,nthetyp - do k=-nthetyp,nthetyp - read (ithep,'(6a)',end=111,err=111) res1 - read (ithep,*,end=111,err=111) aa0thet(i,j,k,iblock) -c VAR: aa0thet is variable describing the average value of Foureir -c VAR: expansion series -c VAR: aathet is foureir expansion in theta/2 angle for full formula -c VAR: look at the fitting equation in Kozlowska et al., J. Phys.: -Condens. Matter 19 (2007) 285203 and Sieradzan et al., unpublished - read (ithep,*,end=111,err=111) - &(aathet(l,i,j,k,iblock),l=1,ntheterm) - read (ithep,*,end=111,err=111) - & ((bbthet(lll,ll,i,j,k,iblock),lll=1,nsingle), - & (ccthet(lll,ll,i,j,k,iblock),lll=1,nsingle), - & (ddthet(lll,ll,i,j,k,iblock),lll=1,nsingle), - & (eethet(lll,ll,i,j,k,iblock),lll=1,nsingle), - & ll=1,ntheterm2) - read (ithep,*,end=111,err=111) - & (((ffthet(llll,lll,ll,i,j,k,iblock), - & ffthet(lll,llll,ll,i,j,k,iblock), - & ggthet(llll,lll,ll,i,j,k,iblock), - & ggthet(lll,llll,ll,i,j,k,iblock), - & llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) - enddo - enddo - enddo -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 IF YOU WANT VALENCE POTENTIALS FOR DUMMY ATOM UNCOMENT BELOW (NOT -C RECOMENTDED AFTER VERSION 3.3) -c do i=1,nthetyp -c do j=1,nthetyp -c do l=1,ntheterm -c aathet(l,i,j,nthetyp+1,iblock)=aathet(l,i,j,1,iblock) -c aathet(l,nthetyp+1,i,j,iblock)=aathet(l,1,i,j,iblock) -c enddo -c aa0thet(i,j,nthetyp+1,iblock)=aa0thet(i,j,1,iblock) -c aa0thet(nthetyp+1,i,j,iblock)=aa0thet(1,i,j,iblock) -c enddo -c do l=1,ntheterm -c aathet(l,nthetyp+1,i,nthetyp+1,iblock)=aathet(l,1,i,1,iblock) -c enddo -c aa0thet(nthetyp+1,i,nthetyp+1,iblock)=aa0thet(1,i,1,iblock) -c enddo -c enddo -C AND COMMENT THE LOOPS BELOW - do i=1,nthetyp - do j=1,nthetyp - do l=1,ntheterm - aathet(l,i,j,nthetyp+1,iblock)=0.0d0 - aathet(l,nthetyp+1,i,j,iblock)=0.0d0 - enddo - aa0thet(i,j,nthetyp+1,iblock)=0.0d0 - aa0thet(nthetyp+1,i,j,iblock)=0.0d0 - enddo - do l=1,ntheterm - aathet(l,nthetyp+1,i,nthetyp+1,iblock)=0.0d0 - enddo - aa0thet(nthetyp+1,i,nthetyp+1,iblock)=0.0d0 - enddo - enddo -C TILL HERE -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 i=1,nthetyp+1 - do j=1,nthetyp+1 - do k=1,nthetyp+1 - write (iout,'(//4a)') - & 'Type ',onelett(i),onelett(j),onelett(k) - write (iout,'(//a,10x,a)') " l","a[l]" - write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k,iblock) - write (iout,'(i2,1pe15.5)') - & (l,aathet(l,i,j,k,iblock),l=1,ntheterm) - do l=1,ntheterm2 - write (iout,'(//2h m,4(9x,a,3h[m,,i1,1h]))') - & "b",l,"c",l,"d",l,"e",l - do m=1,nsingle - write (iout,'(i2,4(1pe15.5))') m, - & bbthet(m,l,i,j,k,iblock),ccthet(m,l,i,j,k,iblock), - & ddthet(m,l,i,j,k,iblock),eethet(m,l,i,j,k,iblock) - enddo - enddo - do l=1,ntheterm3 - write (iout,'(//3hm,n,4(6x,a,5h[m,n,,i1,1h]))') - & "f+",l,"f-",l,"g+",l,"g-",l - do m=2,ndouble - do n=1,m-1 - write (iout,'(i1,1x,i1,4(1pe15.5))') n,m, - & ffthet(n,m,l,i,j,k,iblock), - & ffthet(m,n,l,i,j,k,iblock), - & ggthet(n,m,l,i,j,k,iblock), - & ggthet(m,n,l,i,j,k,iblock) - enddo - enddo - enddo - enddo - enddo - enddo - call flush(iout) - endif - write (2,*) "Start reading THETA_PDB",ithep_pdb - do i=1,ntyp -c write (2,*) 'i=',i - read (ithep_pdb,*,err=111,end=111) - & a0thet(i),(athet(j,i,1,1),j=1,2), - & (bthet(j,i,1,1),j=1,2) - read (ithep_pdb,*,err=111,end=111) (polthet(j,i),j=0,3) - read (ithep_pdb,*,err=111,end=111) (gthet(j,i),j=1,3) - read (ithep_pdb,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) - sigc0(i)=sigc0(i)**2 - enddo - do i=1,ntyp - athet(1,i,1,-1)=athet(1,i,1,1) - athet(2,i,1,-1)=athet(2,i,1,1) - bthet(1,i,1,-1)=-bthet(1,i,1,1) - bthet(2,i,1,-1)=-bthet(2,i,1,1) - athet(1,i,-1,1)=-athet(1,i,1,1) - athet(2,i,-1,1)=-athet(2,i,1,1) - bthet(1,i,-1,1)=bthet(1,i,1,1) - bthet(2,i,-1,1)=bthet(2,i,1,1) - enddo - do i=-ntyp,-1 - a0thet(i)=a0thet(-i) - athet(1,i,-1,-1)=athet(1,-i,1,1) - athet(2,i,-1,-1)=-athet(2,-i,1,1) - bthet(1,i,-1,-1)=bthet(1,-i,1,1) - bthet(2,i,-1,-1)=-bthet(2,-i,1,1) - athet(1,i,-1,1)=athet(1,-i,1,1) - athet(2,i,-1,1)=-athet(2,-i,1,1) - bthet(1,i,-1,1)=-bthet(1,-i,1,1) - bthet(2,i,-1,1)=bthet(2,-i,1,1) - athet(1,i,1,-1)=-athet(1,-i,1,1) - athet(2,i,1,-1)=athet(2,-i,1,1) - bthet(1,i,1,-1)=bthet(1,-i,1,1) - bthet(2,i,1,-1)=-bthet(2,-i,1,1) - theta0(i)=theta0(-i) - sig0(i)=sig0(-i) - sigc0(i)=sigc0(-i) - do j=0,3 - polthet(j,i)=polthet(j,-i) - enddo - do j=1,3 - gthet(j,i)=gthet(j,-i) - enddo - enddo - write (2,*) "End reading THETA_PDB" - close (ithep_pdb) -#endif - close(ithep) -#ifdef CRYST_SC -C -C Read the parameters of the probability distribution/energy expression -C of the side chains. -C - do i=1,ntyp - read (irotam,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - if (i.ne.10) then - do j=1,nlob(i) - do k=1,3 - do l=1,3 - blower(l,k,j)=0.0D0 - enddo - enddo - enddo - bsc(1,i)=0.0D0 - read(irotam,*,end=112,err=112)(censc(k,1,i),k=1,3), - & ((blower(k,l,1),l=1,k),k=1,3) - 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 - if (LaTeX) then - write (iout,'(/3a,i2,a,f8.3)') 'Residue type: ',restyp(i), - & ' # of gaussian lobes:',nlobi,' dsc:',dsc(i) - write (iout,'(1h&,a,3(2h&&,f8.3,2h&&))') - & 'log h',(bsc(j,i),j=1,nlobi) - write (iout,'(1h&,a,3(1h&,f8.3,1h&,f8.3,1h&,f8.3,1h&))') - & 'x',((censc(k,j,i),k=1,3),j=1,nlobi) - do k=1,3 - write (iout,'(2h& ,5(2x,1h&,3(f7.3,1h&)))') - & ((gaussc(k,l,j,i),l=1,3),j=1,nlobi) - enddo - else - write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi) - write (iout,'(a,f10.4,4(16x,f10.4))') - & 'Center ',(bsc(j,i),j=1,nlobi) - write (iout,'(5(2x,3f8.4))') ((censc(k,j,i),k=1,3), - & j=1,nlobi) - write (iout,'(a)') - endif - endif - enddo - endif -#else -C -C Read scrot parameters for potentials determined from all-atom AM1 calculations -C added by Urszula Kozlowska 07/11/2007 -C - do i=1,ntyp - read (irotam,*,end=112,err=112) - if (i.eq.10) then - read (irotam,*,end=112,err=112) - else - do j=1,65 - read(irotam,*,end=112,err=112) sc_parmin(j,i) - enddo - endif - enddo -C -C Read the parameters of the probability distribution/energy expression -C of the side chains. -C - write (2,*) "Start reading ROTAM_PDB" - do i=1,ntyp - read (irotam_pdb,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - if (i.ne.10) then - do j=1,nlob(i) - do k=1,3 - do l=1,3 - blower(l,k,j)=0.0D0 - enddo - enddo - enddo - bsc(1,i)=0.0D0 - read(irotam_pdb,*,end=112,err=112)(censc(k,1,i),k=1,3), - & ((blower(k,l,1),l=1,k),k=1,3) - do j=2,nlob(i) - read (irotam_pdb,*,end=112,err=112) bsc(j,i) - read (irotam_pdb,*,end=112,err=112) (censc(k,j,i),k=1,3), - & ((blower(k,l,j),l=1,k),k=1,3) - enddo - do j=1,nlob(i) - do k=1,3 - do l=1,k - akl=0.0D0 - do m=1,3 - akl=akl+blower(k,m,j)*blower(l,m,j) - enddo - gaussc(k,l,j,i)=akl - gaussc(l,k,j,i)=akl - enddo - enddo - enddo - endif - enddo - close (irotam_pdb) - write (2,*) "End reading ROTAM_PDB" -#endif - close(irotam) - -#ifdef CRYST_TOR -C -C Read torsional parameters in old format -C - read (itorp,*,end=113,err=113) ntortyp,nterm_old - if (lprint)write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old - read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) - do i=1,ntortyp - do j=1,ntortyp - read (itorp,'(a)') - do k=1,nterm_old - read (itorp,*,end=113,err=113) kk,v1(k,j,i),v2(k,j,i) - enddo - enddo - enddo - close (itorp) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,ntortyp - do j=1,ntortyp - write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) - write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) - enddo - enddo - endif -#else -C -C Read torsional parameters -C - read (itorp,*,end=113,err=113) ntortyp - read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) - do iblock=1,2 - do i=-ntyp,-1 - itortyp(i)=-itortyp(-i) - enddo - write (iout,*) 'ntortyp',ntortyp - do i=0,ntortyp-1 - do j=-ntortyp+1,ntortyp-1 - read (itorp,*,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 -c write(iout,*) i,j,k,iblock,nterm(i,j,iblock) -c write(iout,*) v1(k,-i,-j,iblock),v1(k,i,j,iblock), -c &v2(k,-i,-j,iblock),v2(k,i,j,iblock) - enddo - do k=1,nlor(i,j,iblock) - read (itorp,*,end=113,err=113) kk,vlor1(k,i,j), - & vlor2(k,i,j),vlor3(k,i,j) - v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) - enddo - v0(i,j,iblock)=v0ij - v0(-i,-j,iblock)=v0ij - enddo - enddo - enddo - close (itorp) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do 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 -#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 -#ifdef SCCORPDB - 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) - v0ijsccor=0.0d0 - v0ijsccor1=0.0d0 - v0ijsccor2=0.0d0 - v0ijsccor3=0.0d0 - si=-1.0d0 - nterm_sccor(-i,j)=nterm_sccor(i,j) - nterm_sccor(-i,-j)=nterm_sccor(i,j) - nterm_sccor(i,-j)=nterm_sccor(i,j) - do k=1,nterm_sccor(i,j) - read (isccor,*,end=119,err=119) kk,v1sccor(k,l,i,j) - & ,v2sccor(k,l,i,j) - if (j.eq.iscprol) then - if (i.eq.isccortyp(10)) then - v1sccor(k,l,i,-j)=v1sccor(k,l,i,j) - v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) - else - v1sccor(k,l,i,-j)=v1sccor(k,l,i,j)*0.5d0 - & +v2sccor(k,l,i,j)*dsqrt(0.75d0) - v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)*0.5d0 - & +v1sccor(k,l,i,j)*dsqrt(0.75d0) - v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j) - v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j) - v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j) - v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j) - endif - else - if (i.eq.isccortyp(10)) then - v1sccor(k,l,i,-j)=v1sccor(k,l,i,j) - v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) - else - if (j.eq.isccortyp(10)) then - v1sccor(k,l,-i,j)=v1sccor(k,l,i,j) - v2sccor(k,l,-i,j)=-v2sccor(k,l,i,j) - else - v1sccor(k,l,i,-j)=-v1sccor(k,l,i,j) - v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j) - v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j) - v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j) - v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j) - v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j) - endif - endif - endif - v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) - v0ijsccor1=v0ijsccor+si*v1sccor(k,l,-i,j) - v0ijsccor2=v0ijsccor+si*v1sccor(k,l,i,-j) - v0ijsccor3=v0ijsccor+si*v1sccor(k,l,-i,-j) - si=-si - enddo - do k=1,nlor_sccor(i,j) - read (isccor,*,end=119,err=119) kk,vlor1sccor(k,i,j), - & vlor2sccor(k,i,j),vlor3sccor(k,i,j) - v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ - &(1+vlor3sccor(k,i,j)**2) - enddo - v0sccor(l,i,j)=v0ijsccor - v0sccor(l,-i,j)=v0ijsccor1 - v0sccor(l,i,-j)=v0ijsccor2 - v0sccor(l,-i,-j)=v0ijsccor3 - enddo - enddo - enddo - close (isccor) -#else - read (isccor,*,end=119,err=119) (isccortyp(i),i=1,ntyp) -c write (iout,*) 'ntortyp',ntortyp - maxinter=3 -cc maxinter is maximum interaction sites - do l=1,maxinter - do i=1,nsccortyp - do j=1,nsccortyp - read (isccor,*,end=119,err=119) - & nterm_sccor(i,j),nlor_sccor(i,j) - v0ijsccor=0.0d0 - si=-1.0d0 - - do k=1,nterm_sccor(i,j) - read (isccor,*,end=119,err=119) kk,v1sccor(k,l,i,j) - & ,v2sccor(k,l,i,j) - v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) - si=-si - enddo - do k=1,nlor_sccor(i,j) - read (isccor,*,end=119,err=119) kk,vlor1sccor(k,i,j), - & vlor2sccor(k,i,j),vlor3sccor(k,i,j) - v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ - &(1+vlor3sccor(k,i,j)**2) - enddo - v0sccor(i,j,iblock)=v0ijsccor - enddo - enddo - enddo - close (isccor) - -#endif - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,nsccortyp - do j=1,nsccortyp - write (iout,*) 'ityp',i,' jtyp',j - write (iout,*) 'Fourier constants' - do k=1,nterm_sccor(i,j) - write (iout,'(2(1pe15.5))') v1sccor(k,l,i,j),v2sccor(k,l,i,j) - enddo - write (iout,*) 'Lorenz constants' - do k=1,nlor_sccor(i,j) - write (iout,'(3(1pe15.5))') - & vlor1sccor(k,i,j),vlor2sccor(k,i,j),vlor3sccor(k,i,j) - enddo - enddo - enddo - endif - -C -C 9/18/99 (AL) Read coefficients of the Fourier expansion of the local -C interaction energy of the Gly, Ala, and Pro prototypes. -C - if (lprint) then - write (iout,*) - write (iout,*) "Coefficients of the cumulants" - endif - read (ifourier,*) nloctyp - - do i=0,nloctyp-1 - read (ifourier,*,end=115,err=115) - read (ifourier,*,end=115,err=115) (b(ii),ii=1,13) -#ifdef NEWCORR - write (iout,*) "TUTUTU" - read (ifourier,*,end=115,err=115) (bnew1(ii,1,i),ii=1,3) - read (ifourier,*,end=115,err=115) (bnew2(ii,1,i),ii=1,3) - read (ifourier,*,end=115,err=115) (bnew1(ii,2,i),ii=1,1) - read (ifourier,*,end=115,err=115) (bnew2(ii,2,i),ii=1,1) - read (ifourier,*,end=115,err=115) (eenew(ii,i),ii=1,1) - -#endif - if (lprint) then - write (iout,*) 'Type',i - write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii),ii=1,13) - 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) - -c b2(1,i)=0.0d0 -c b2(2,i)=0.0d0 - CC(1,1,i)= b(7) - CC(2,2,i)=-b(7) - CC(2,1,i)= b(9) - CC(1,2,i)= b(9) - CC(1,1,-i)= b(7) - CC(2,2,-i)=-b(7) - CC(2,1,-i)=-b(9) - CC(1,2,-i)=-b(9) -c CC(1,1,i)=0.0d0 -c CC(2,2,i)=0.0d0 -c CC(2,1,i)=0.0d0 -c CC(1,2,i)=0.0d0 - Ctilde(1,1,i)=b(7) - Ctilde(1,2,i)=b(9) - Ctilde(2,1,i)=-b(9) - Ctilde(2,2,i)=b(7) - Ctilde(1,1,-i)=b(7) - Ctilde(1,2,-i)=-b(9) - Ctilde(2,1,-i)=b(9) - Ctilde(2,2,-i)=b(7) - -c Ctilde(1,1,i)=0.0d0 -c Ctilde(1,2,i)=0.0d0 -c Ctilde(2,1,i)=0.0d0 -c Ctilde(2,2,i)=0.0d0 - DD(1,1,i)= b(6) - DD(2,2,i)=-b(6) - DD(2,1,i)= b(8) - DD(1,2,i)= b(8) - DD(1,1,-i)= b(6) - DD(2,2,-i)=-b(6) - DD(2,1,-i)=-b(8) - DD(1,2,-i)=-b(8) -c DD(1,1,i)=0.0d0 -c DD(2,2,i)=0.0d0 -c DD(2,1,i)=0.0d0 -c DD(1,2,i)=0.0d0 - Dtilde(1,1,i)=b(6) - Dtilde(1,2,i)=b(8) - Dtilde(2,1,i)=-b(8) - Dtilde(2,2,i)=b(6) - Dtilde(1,1,-i)=b(6) - Dtilde(1,2,-i)=-b(8) - Dtilde(2,1,-i)=b(8) - Dtilde(2,2,-i)=b(6) - -c Dtilde(1,1,i)=0.0d0 -c Dtilde(1,2,i)=0.0d0 -c Dtilde(2,1,i)=0.0d0 -c Dtilde(2,2,i)=0.0d0 - EEold(1,1,i)= b(10)+b(11) - EEold(2,2,i)=-b(10)+b(11) - EEold(2,1,i)= b(12)-b(13) - EEold(1,2,i)= b(12)+b(13) - EEold(1,1,-i)= b(10)+b(11) - EEold(2,2,-i)=-b(10)+b(11) - EEold(2,1,-i)=-b(12)+b(13) - EEold(1,2,-i)=-b(12)-b(13) - write(iout,*) "TU DOCHODZE" -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 -c lprint=.true. - if (lprint) then - do i=1,nloctyp - write (iout,*) 'Type',i - write (iout,*) 'B1' - write(iout,*) B1(1,i),B1(2,i) - write (iout,*) 'B2' - write(iout,*) B2(1,i),B2(2,i) - write (iout,*) 'CC' - do j=1,2 - write (iout,'(2f10.5)') CC(j,1,i),CC(j,2,i) - enddo - write(iout,*) 'DD' - do j=1,2 - write (iout,'(2f10.5)') DD(j,1,i),DD(j,2,i) - enddo - write(iout,*) 'EE' - do j=1,2 - write (iout,'(2f10.5)') EEold(j,1,i),EEold(j,2,i) - enddo - enddo - endif -c lprint=.false. - -C -C Read electrostatic-interaction parameters -C - if (lprint) then - write (iout,*) - write (iout,'(/a)') 'Electrostatic interaction constants:' - write (iout,'(1x,a,1x,a,10x,a,11x,a,11x,a,11x,a)') - & 'IT','JT','APP','BPP','AEL6','AEL3' - endif - read (ielep,*,end=116,err=116) ((epp(i,j),j=1,2),i=1,2) - read (ielep,*,end=116,err=116) ((rpp(i,j),j=1,2),i=1,2) - read (ielep,*,end=116,err=116) ((elpp6(i,j),j=1,2),i=1,2) - read (ielep,*,end=116,err=116) ((elpp3(i,j),j=1,2),i=1,2) - close (ielep) - do i=1,2 - do j=1,2 - rri=rpp(i,j)**6 - app (i,j)=epp(i,j)*rri*rri - bpp (i,j)=-2.0D0*epp(i,j)*rri - ael6(i,j)=elpp6(i,j)*4.2D0**6 - ael3(i,j)=elpp3(i,j)*4.2D0**3 -c lprint=.true. - if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j), - & ael6(i,j),ael3(i,j) -c 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.' -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop - endif - expon2=expon/2 - if(me.eq.king) - & write(iout,'(/3a,2i3)') 'Potential is ',potname(ipot), - & ', exponents are ',expon,2*expon - goto (10,20,30,30,40) ipot -C----------------------- LJ potential --------------------------------- - 10 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJ potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,a)') 'residue','sigma' - write (iout,'(a3,6x,f10.5)') (restyp(i),sigma0(i),i=1,ntyp) - endif - goto 50 -C----------------------- LJK potential -------------------------------- - 20 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJK potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,2a)') 'residue',' sigma ',' r0 ' - write (iout,'(a3,6x,2f10.5)') (restyp(i),sigma0(i),rr0(i), - & i=1,ntyp) - endif - goto 50 -C---------------------- GB or BP potential ----------------------------- - 30 do i=1,ntyp - read (isidep,*,end=116,err=116)(eps(i,j),j=i,ntyp) - enddo - read (isidep,*,end=116,err=116)(sigma0(i),i=1,ntyp) - read (isidep,*,end=116,err=116)(sigii(i),i=1,ntyp) - read (isidep,*,end=116,err=116)(chip(i),i=1,ntyp) - read (isidep,*,end=116,err=116)(alp(i),i=1,ntyp) -C For the GB potential convert sigma'**2 into chi' - if (ipot.eq.4) then - do i=1,ntyp - chip(i)=(chip(i)-1.0D0)/(chip(i)+1.0D0) - enddo - endif - if (lprint) then - write (iout,'(/a/)') 'Parameters of the BP potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,4a)') 'residue',' sigma ','s||/s_|_^2', - & ' chip ',' alph ' - write (iout,'(a3,6x,4f10.5)') (restyp(i),sigma0(i),sigii(i), - & chip(i),alp(i),i=1,ntyp) - endif - goto 50 -C--------------------- GBV potential ----------------------------------- - 40 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp),(sigii(i),i=1,ntyp), - & (chip(i),i=1,ntyp),(alp(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the GBV potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,5a)') 'residue',' sigma ',' r0 ', - & 's||/s_|_^2',' chip ',' alph ' - write (iout,'(a3,6x,5f10.5)') (restyp(i),sigma0(i),rr0(i), - & sigii(i),chip(i),alp(i),i=1,ntyp) - endif - 50 continue - close (isidep) -C----------------------------------------------------------------------- -C Calculate the "working" parameters of SC interactions. - do i=2,ntyp - do j=1,i-1 - eps(i,j)=eps(j,i) - enddo - enddo - do i=1,ntyp - do j=i,ntyp - sigma(i,j)=dsqrt(sigma0(i)**2+sigma0(j)**2) - sigma(j,i)=sigma(i,j) - rs0(i,j)=dwa16*sigma(i,j) - rs0(j,i)=rs0(i,j) - enddo - enddo - if (lprint) write (iout,'(/a/10x,7a/72(1h-))') - & 'Working parameters of the SC interactions:', - & ' a ',' b ',' augm ',' sigma ',' r0 ', - & ' chi1 ',' chi2 ' - do i=1,ntyp - do j=i,ntyp - epsij=eps(i,j) - if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then - rrij=sigma(i,j) - else - rrij=rr0(i)+rr0(j) - endif - r0(i,j)=rrij - r0(j,i)=rrij - rrij=rrij**expon - epsij=eps(i,j) - sigeps=dsign(1.0D0,epsij) - epsij=dabs(epsij) - aa(i,j)=epsij*rrij*rrij - bb(i,j)=-sigeps*epsij*rrij - aa(j,i)=aa(i,j) - bb(j,i)=bb(i,j) - if (ipot.gt.2) then - sigt1sq=sigma0(i)**2 - sigt2sq=sigma0(j)**2 - sigii1=sigii(i) - sigii2=sigii(j) - ratsig1=sigt2sq/sigt1sq - ratsig2=1.0D0/ratsig1 - chi(i,j)=(sigii1-1.0D0)/(sigii1+ratsig1) - if (j.gt.i) chi(j,i)=(sigii2-1.0D0)/(sigii2+ratsig2) - rsum_max=dsqrt(sigii1*sigt1sq+sigii2*sigt2sq) - else - rsum_max=sigma(i,j) - endif -c if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then - sigmaii(i,j)=rsum_max - sigmaii(j,i)=rsum_max -c else -c sigmaii(i,j)=r0(i,j) -c sigmaii(j,i)=r0(i,j) -c endif -cd write (iout,*) i,j,r0(i,j),sigma(i,j),rsum_max - if ((ipot.eq.2 .or. ipot.eq.5) .and. r0(i,j).gt.rsum_max) then - r_augm=sigma(i,j)*(rrij-sigma(i,j))/rrij - augm(i,j)=epsij*r_augm**(2*expon) -c augm(i,j)=0.5D0**(2*expon)*aa(i,j) - augm(j,i)=augm(i,j) - else - augm(i,j)=0.0D0 - augm(j,i)=0.0D0 - endif - if (lprint) then - write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') - & restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j), - & sigma(i,j),r0(i,j),chi(i,j),chi(j,i) - endif - enddo - enddo -#ifdef OLDSCP -C -C Define the SC-p interaction constants (hard-coded; old style) -C - do i=1,ntyp -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 -c lprint=.true. - if (lprint) then - write (iout,*) "Parameters of SC-p interactions:" - do i=1,ntyp - write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1), - & eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) - enddo - endif -c lprint=.false. -#endif -C -C Define the constants of the disulfide bridge -C - ebr=-12.00D0 -c -c Old arbitrary potential - commented out. -c -c dbr= 4.20D0 -c fbr= 3.30D0 -c -c Constants of the disulfide-bond potential determined based on the RHF/6-31G** -c energy surface of diethyl disulfide. -c A. Liwo and U. Kozlowska, 11/24/03 -c - D0CM = 3.78d0 - AKCM = 15.1d0 - AKTH = 11.0d0 - AKCT = 12.0d0 - V1SS =-1.08d0 - V2SS = 7.61d0 - V3SS = 13.7d0 -c akcm=0.0d0 -c akth=0.0d0 -c akct=0.0d0 -c v1ss=0.0d0 -c v2ss=0.0d0 -c v3ss=0.0d0 - - if(me.eq.king) then - write (iout,'(/a)') "Disulfide bridge parameters:" - write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr - write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm - write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct - write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss, - & ' v3ss:',v3ss - endif - return - 111 write (iout,*) "Error reading bending energy parameters." - goto 999 - 112 write (iout,*) "Error reading rotamer energy parameters." - goto 999 - 113 write (iout,*) "Error reading torsional energy parameters." - goto 999 - 114 write (iout,*) "Error reading double torsional energy parameters." - goto 999 - 115 write (iout,*) - & "Error reading cumulant (multibody energy) parameters." - goto 999 - 116 write (iout,*) "Error reading electrostatic energy parameters." - goto 999 - 117 write (iout,*) "Error reading side chain interaction parameters." - goto 999 - 118 write (iout,*) "Error reading SCp interaction parameters." - goto 999 - 119 write (iout,*) "Error reading SCCOR parameters" - 999 continue -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop - return - end - - - subroutine getenv_loc(var, val) - character(*) var, val - -#ifdef WINIFL - character(2000) line - external ilen - - open (196,file='env',status='old',readonly,shared) - iread=0 -c write(*,*)'looking for ',var -10 read(196,*,err=11,end=11)line - iread=index(line,var) -c write(*,*)iread,' ',var,' ',line - if (iread.eq.0) go to 10 -c write(*,*)'---> ',line -11 continue - if(iread.eq.0) then -c write(*,*)'CHUJ' - val='' - else - iread=iread+ilen(var)+1 - read (line(iread:),*,err=12,end=12) val -c write(*,*)'OK: ',var,' = ',val - endif - close(196) - return -12 val='' - close(196) -#elif (defined CRAY) - integer lennam,lenval,ierror -c -c getenv using a POSIX call, useful on the T3D -c Sept 1996, comment out error check on advice of H. Pritchard -c - lennam = len(var) - if(lennam.le.0) stop '--error calling getenv--' - call pxfgetenv(var,lennam,val,lenval,ierror) -c-HP- if(ierror.ne.0) stop '--error returned by pxfgetenv--' -#else - call getenv(var,val) -#endif - - return - end diff --git a/source/unres/src_MD-M-newcorr/pdtf5579.pdb b/source/unres/src_MD-M-newcorr/pdtf5579.pdb deleted file mode 100644 index c606aed..0000000 --- a/source/unres/src_MD-M-newcorr/pdtf5579.pdb +++ /dev/null @@ -1,1195 +0,0 @@ - -lang fortran - -so#1 readrtns_CSA.pp.F - - -so#2 DIMENSIONS - - -so#3 mpif.h - - -so#4 COMMON.SETUP - - -so#5 COMMON.CONTROL - - -so#6 COMMON.SBRIDGE - - -so#7 COMMON.IOUNITS - - -so#8 DIMENSIONS - - -so#9 mpif.h - - -so#10 COMMON.IOUNITS - - -so#11 COMMON.TIME1 - - -so#12 COMMON.THREAD - - -so#13 COMMON.SBRIDGE - - -so#14 COMMON.CONTROL - - -so#15 COMMON.MCM - - -so#16 COMMON.MAP - - -so#17 COMMON.HEADER - - -so#18 COMMON.CSA - - -so#19 COMMON.CHAIN - - -so#20 COMMON.MUCA - - -so#21 COMMON.MD - - -so#22 COMMON.FFIELD - - -so#23 COMMON.SETUP - - -so#24 DIMENSIONS - - -so#25 COMMON.IOUNITS - - -so#26 COMMON.TIME1 - - -so#27 COMMON.MD - - -so#28 COMMON.LANGEVIN.lang0 - - -so#29 COMMON.INTERACT - - -so#30 COMMON.NAMES - - -so#31 COMMON.GEO - - -so#32 COMMON.REMD - - -so#33 COMMON.CONTROL - - -so#34 COMMON.SETUP - - -so#35 DIMENSIONS - - -so#36 COMMON.IOUNITS - - -so#37 COMMON.TIME1 - - -so#38 COMMON.MD - - -so#39 COMMON.LANGEVIN.lang0 - - -so#40 COMMON.INTERACT - - -so#41 COMMON.NAMES - - -so#42 COMMON.GEO - - -so#43 COMMON.SETUP - - -so#44 COMMON.CONTROL - - -so#45 COMMON.SPLITELE - - -so#46 DIMENSIONS - - -so#47 mpif.h - - -so#48 COMMON.IOUNITS - - -so#49 COMMON.GEO - - -so#50 COMMON.VAR - - -so#51 COMMON.INTERACT - - -so#52 COMMON.LOCAL - - -so#53 COMMON.NAMES - - -so#54 COMMON.CHAIN - - -so#55 COMMON.FFIELD - - -so#56 COMMON.SBRIDGE - - -so#57 COMMON.HEADER - - -so#58 COMMON.CONTROL - - -so#59 COMMON.DBASE - - -so#60 COMMON.THREAD - - -so#61 COMMON.CONTACTS - - -so#62 COMMON.TORCNSTR - - -so#63 COMMON.TIME1 - - -so#64 COMMON.BOUNDS - - -so#65 COMMON.MD - - -so#66 COMMON.SETUP - - -so#67 DIMENSIONS - - -so#68 mpif.h - - -so#69 COMMON.IOUNITS - - -so#70 COMMON.GEO - - -so#71 COMMON.VAR - - -so#72 COMMON.INTERACT - - -so#73 COMMON.LOCAL - - -so#74 COMMON.NAMES - - -so#75 COMMON.CHAIN - - -so#76 COMMON.FFIELD - - -so#77 COMMON.SBRIDGE - - -so#78 COMMON.HEADER - - -so#79 COMMON.CONTROL - - -so#80 COMMON.DBASE - - -so#81 COMMON.THREAD - - -so#82 COMMON.TIME1 - - -so#83 COMMON.SETUP - - -so#84 DIMENSIONS - - -so#85 COMMON.GEO - - -so#86 COMMON.VAR - - -so#87 COMMON.CHAIN - - -so#88 COMMON.IOUNITS - - -so#89 COMMON.CONTROL - - -so#90 COMMON.LOCAL - - -so#91 COMMON.INTERACT - - -so#92 DIMENSIONS - - -so#93 COMMON.IOUNITS - - -so#94 COMMON.GEO - - -so#95 COMMON.VAR - - -so#96 COMMON.INTERACT - - -so#97 COMMON.LOCAL - - -so#98 COMMON.NAMES - - -so#99 COMMON.CHAIN - - -so#100 COMMON.FFIELD - - -so#101 COMMON.SBRIDGE - - -so#102 COMMON.HEADER - - -so#103 COMMON.CONTROL - - -so#104 COMMON.DBASE - - -so#105 COMMON.THREAD - - -so#106 COMMON.TIME1 - - -so#107 DIMENSIONS - - -so#108 COMMON.IOUNITS - - -so#109 COMMON.GEO - - -so#110 COMMON.VAR - - -so#111 COMMON.INTERACT - - -so#112 COMMON.LOCAL - - -so#113 COMMON.NAMES - - -so#114 COMMON.CHAIN - - -so#115 COMMON.FFIELD - - -so#116 COMMON.SBRIDGE - - -so#117 COMMON.HEADER - - -so#118 COMMON.CONTROL - - -so#119 COMMON.DBASE - - -so#120 COMMON.THREAD - - -so#121 COMMON.TIME1 - - -so#122 DIMENSIONS - - -so#123 COMMON.IOUNITS - - -so#124 COMMON.GEO - - -so#125 COMMON.VAR - - -so#126 COMMON.INTERACT - - -so#127 COMMON.LOCAL - - -so#128 COMMON.NAMES - - -so#129 COMMON.CHAIN - - -so#130 COMMON.FFIELD - - -so#131 COMMON.SBRIDGE - - -so#132 COMMON.HEADER - - -so#133 COMMON.CONTROL - - -so#134 COMMON.DBASE - - -so#135 COMMON.THREAD - - -so#136 COMMON.TIME1 - - -so#137 DIMENSIONS - - -so#138 COMMON.MAP - - -so#139 COMMON.IOUNITS - - -so#140 DIMENSIONS - - -so#141 COMMON.IOUNITS - - -so#142 COMMON.GEO - - -so#143 COMMON.CSA - - -so#144 COMMON.BANK - - -so#145 COMMON.CONTROL - - -so#146 DIMENSIONS - - -so#147 COMMON.MCM - - -so#148 COMMON.MCE - - -so#149 COMMON.IOUNITS - - -so#150 DIMENSIONS - - -so#151 COMMON.MINIM - - -so#152 COMMON.IOUNITS - - -so#153 DIMENSIONS - - -so#154 COMMON.GEO - - -so#155 COMMON.VAR - - -so#156 COMMON.CHAIN - - -so#157 COMMON.IOUNITS - - -so#158 COMMON.CONTROL - - -so#159 DIMENSIONS - - -so#160 mpif.h - - -so#161 COMMON.SETUP - - -so#162 COMMON.IOUNITS - - -so#163 COMMON.MD - - -so#164 COMMON.CONTROL - - -so#165 DIMENSIONS - - -so#166 COMMON.IOUNITS - - -so#167 DIMENSIONS - - -so#168 COMMON.CHAIN - - -so#169 COMMON.IOUNITS - - -so#170 COMMON.MD - - -so#171 DIMENSIONS - - -so#172 mpif.h - - -so#173 COMMON.SETUP - - -so#174 COMMON.CHAIN - - -so#175 COMMON.IOUNITS - - -so#176 COMMON.MD - - -so#177 COMMON.CONTROL - - -so#178 DIMENSIONS - - -so#179 mpif.h - - -so#180 COMMON.SETUP - - -so#181 COMMON.CONTROL - - -so#182 COMMON.CHAIN - - -so#183 COMMON.IOUNITS - - -so#184 COMMON.SBRIDGE - - -so#185 DIMENSIONS - - -so#186 COMMON.IOUNITS - - -so#187 DIMENSIONS - - -so#188 COMMON.IOUNITS - - -so#189 DIMENSIONS - - -so#190 mpif.h - - -so#191 COMMON.IOUNITS - - -so#192 COMMON.TIME1 - - -so#193 COMMON.THREAD - - -so#194 COMMON.SBRIDGE - - -so#195 COMMON.CONTROL - - -so#196 COMMON.MCM - - -so#197 COMMON.MAP - - -so#198 COMMON.HEADER - - -so#199 COMMON.CSA - - -so#200 COMMON.CHAIN - - -so#201 COMMON.MUCA - - -so#202 COMMON.MD - - -so#203 COMMON.FFIELD - - -so#204 COMMON.SETUP - - -ro#1 READRTNS -rloc so#1 1 18 -rlink f90 -rkind fext -rstart so#1 13 7 -rstmt st#0 fsingle_if so#1 17 7 so#1 17 32 st#1 NA -rstmt st#1 fsingle_if so#1 19 7 so#1 19 56 st#2 NA -rstmt st#2 fsingle_if so#1 21 7 so#1 21 41 st#3 NA -rstmt st#3 fif so#1 23 7 so#1 26 11 st#4 NA -rstmt st#4 fsingle_if so#1 28 7 so#1 28 31 st#5 NA -rstmt st#6 fio so#1 32 8 so#1 32 48 st#7 NA -rstmt st#7 fsingle_if so#1 33 8 so#1 33 40 NA NA -rstmt st#5 fif so#1 31 7 so#1 34 12 st#8 st#6 -rstmt st#10 fio so#1 44 7 so#1 45 48 NA NA -rstmt st#9 fsingle_if so#1 43 7 so#1 45 48 st#11 st#10 -rstmt st#12 fio so#1 47 9 so#1 47 66 NA NA -rstmt st#11 fdo so#1 46 7 so#1 48 11 NA st#12 -rstmt st#8 fif so#1 41 7 so#1 50 11 st#13 st#9 -rstmt st#13 freturn so#1 53 7 so#1 53 12 st#14 NA -rstmt st#14 freturn so#1 54 7 so#1 54 9 NA NA -rbody st#0 - -ro#2 READ_CONTROL -rloc so#1 56 18 -rlink f90 -rkind fext -rstart so#1 86 7 -rstmt st#0 fassign so#1 86 7 so#1 86 17 st#1 NA -rstmt st#1 fassign so#1 87 7 so#1 87 20 st#2 NA -rstmt st#2 fassign so#1 88 7 so#1 88 16 st#3 NA -rstmt st#3 fio so#1 89 7 so#1 89 28 st#4 NA -rstmt st#4 fassign so#1 96 7 so#1 96 51 st#5 NA -rstmt st#5 fassign so#1 97 7 so#1 97 57 st#6 NA -rstmt st#6 fassign so#1 100 7 so#1 100 55 st#7 NA -rstmt st#8 fio so#1 108 8 so#1 108 50 st#9 NA -rstmt st#9 fio so#1 109 8 so#1 109 52 st#10 NA -rstmt st#10 fio so#1 110 8 so#1 110 58 st#11 NA -rstmt st#11 fio so#1 111 8 so#1 111 49 st#12 NA -rstmt st#12 fio so#1 112 8 so#1 112 52 st#13 NA -rstmt st#13 fio so#1 113 8 so#1 113 58 NA NA -rstmt st#7 fif so#1 107 7 so#1 114 11 st#14 st#8 -rstmt st#14 fassign so#1 118 7 so#1 118 26 st#15 NA -rstmt st#15 fassign so#1 119 7 so#1 119 28 st#16 NA -rstmt st#16 fassign so#1 120 7 so#1 120 18 st#17 NA -rstmt st#17 fassign so#1 121 7 so#1 121 16 st#18 NA -rstmt st#18 fassign so#1 123 7 so#1 123 48 st#19 NA -rstmt st#19 fassign so#1 124 7 so#1 124 45 st#20 NA -rstmt st#20 fassign so#1 125 7 so#1 125 51 st#21 NA -rstmt st#21 fassign so#1 126 7 so#1 126 30 st#22 NA -rstmt st#22 fassign so#1 127 7 so#1 127 53 st#23 NA -rstmt st#23 fassign so#1 128 7 so#1 128 28 st#24 NA -rstmt st#24 fassign so#1 129 7 so#1 129 49 st#25 NA -rstmt st#25 fassign so#1 130 7 so#1 130 55 st#26 NA -rstmt st#26 fassign so#1 131 7 so#1 131 47 st#27 NA -rstmt st#27 fassign so#1 132 7 so#1 132 49 st#28 NA -rstmt st#28 fassign so#1 133 7 so#1 133 47 st#29 NA -rstmt st#29 fassign so#1 134 7 so#1 134 59 st#30 NA -rstmt st#30 fassign so#1 135 7 so#1 135 42 st#31 NA -rstmt st#31 fassign so#1 136 7 so#1 136 49 st#32 NA -rstmt st#33 fio so#1 143 8 so#1 143 49 NA NA -rstmt st#32 fsingle_if so#1 142 7 so#1 143 49 st#34 st#33 -rstmt st#35 fassign so#1 146 9 so#1 146 18 st#36 NA -rstmt st#36 fassign so#1 147 9 so#1 147 21 NA NA -rstmt st#34 fif so#1 144 7 so#1 148 11 st#37 st#35 -rstmt st#38 fassign so#1 150 9 so#1 150 18 st#39 NA -rstmt st#40 fassign so#1 152 11 so#1 152 22 NA NA -rstmt st#42 fassign so#1 154 11 so#1 154 22 NA NA -rstmt st#43 fassign so#1 156 11 so#1 156 22 NA NA -rstmt st#41 fif so#1 153 9 so#1 157 13 NA st#42 st#43 -rstmt st#39 fif so#1 151 9 so#1 157 13 NA st#40 st#41 -rstmt st#45 fassign so#1 159 9 so#1 159 18 st#46 NA -rstmt st#48 fio so#1 165 11 so#1 165 72 NA NA -rstmt st#47 fsingle_if so#1 164 11 so#1 165 72 st#49 st#48 -rstmt st#49 fstop so#1 166 11 NULL 0 0 NA NA -rstmt st#46 fif so#1 161 9 so#1 167 13 NA NA st#47 -rstmt st#51 fassign so#1 169 9 so#1 169 18 NA NA -rstmt st#53 fassign so#1 171 9 so#1 171 18 NA NA -rstmt st#55 fassign so#1 173 9 so#1 173 18 NA NA -rstmt st#57 fassign so#1 175 9 so#1 175 18 NA NA -rstmt st#59 fassign so#1 178 9 so#1 178 18 NA NA -rstmt st#61 fassign so#1 187 9 so#1 187 19 NA NA -rstmt st#63 fassign so#1 189 9 so#1 189 19 NA NA -rstmt st#65 fassign so#1 191 9 so#1 191 19 NA NA -rstmt st#67 fassign so#1 193 9 so#1 193 19 NA NA -rstmt st#69 fassign so#1 195 9 so#1 195 19 NA NA -rstmt st#68 fif so#1 194 7 so#1 196 11 NA st#69 -rstmt st#66 fif so#1 192 7 so#1 196 11 NA st#67 st#68 -rstmt st#64 fif so#1 190 7 so#1 196 11 NA st#65 st#66 -rstmt st#62 fif so#1 188 7 so#1 196 11 NA st#63 st#64 -rstmt st#60 fif so#1 186 7 so#1 196 11 NA st#61 st#62 -rstmt st#58 fif so#1 177 7 so#1 196 11 NA st#59 st#60 -rstmt st#56 fif so#1 174 7 so#1 196 11 NA st#57 st#58 -rstmt st#54 fif so#1 172 7 so#1 196 11 NA st#55 st#56 -rstmt st#52 fif so#1 170 7 so#1 196 11 NA st#53 st#54 -rstmt st#50 fif so#1 168 7 so#1 196 11 NA st#51 st#52 -rstmt st#44 fif so#1 158 7 so#1 196 11 NA st#45 st#50 -rstmt st#37 fif so#1 149 7 so#1 196 11 st#70 st#38 st#44 -rstmt st#70 fassign so#1 198 7 so#1 198 42 st#71 NA -rstmt st#72 fio so#1 203 8 so#1 203 40 st#73 NA -rstmt st#73 fio so#1 204 8 so#1 204 47 NA NA -rstmt st#71 fif so#1 201 7 so#1 205 11 st#74 st#72 -rstmt st#74 fassign so#1 207 7 so#1 207 44 st#75 NA -rstmt st#75 fassign so#1 208 7 so#1 208 37 st#76 NA -rstmt st#76 fassign so#1 209 7 so#1 209 39 st#77 NA -rstmt st#77 fassign so#1 210 7 so#1 210 45 st#78 NA -rstmt st#78 fassign so#1 211 7 so#1 211 47 st#79 NA -rstmt st#79 fassign so#1 212 7 so#1 212 47 st#80 NA -rstmt st#80 fassign so#1 213 7 so#1 213 55 st#81 NA -rstmt st#82 fio so#1 216 8 so#1 217 48 NA NA -rstmt st#81 fsingle_if so#1 215 7 so#1 217 48 st#83 st#82 -rstmt st#83 freturn so#1 218 7 so#1 218 12 st#84 NA -rstmt st#84 freturn so#1 219 7 so#1 219 9 NA NA -rbody st#0 - -ro#3 READ_REMDPAR -rloc so#1 221 18 -rlink f90 -rkind fext -rstart so#1 246 7 -rstmt st#1 fio so#1 247 8 so#1 247 34 NA NA -rstmt st#0 fsingle_if so#1 246 7 so#1 247 34 st#2 st#1 -rstmt st#2 fassign so#1 254 7 so#1 254 48 st#3 NA -rstmt st#3 fassign so#1 256 7 so#1 256 56 st#4 NA -rstmt st#4 fassign so#1 257 7 so#1 257 53 st#5 NA -rstmt st#6 fassign so#1 260 18 so#1 260 50 NA NA -rstmt st#5 fsingle_if so#1 259 7 so#1 260 50 st#7 st#6 -rstmt st#8 fio so#1 268 8 so#1 268 35 st#9 NA -rstmt st#9 fio so#1 269 8 so#1 269 37 st#10 NA -rstmt st#10 fio so#1 270 8 so#1 270 41 st#11 NA -rstmt st#11 fio so#1 271 8 so#1 271 42 st#12 NA -rstmt st#12 fio so#1 272 8 so#1 272 54 NA NA -rstmt st#7 fif so#1 261 7 so#1 273 11 st#13 st#8 -rstmt st#13 fassign so#1 274 7 so#1 274 24 st#14 NA -rstmt st#15 fassign so#1 276 10 so#1 276 26 st#16 NA -rstmt st#16 fio so#1 278 10 so#1 278 51 st#17 NA -rstmt st#18 fio so#1 280 11 so#1 280 53 NA NA -rstmt st#17 fsingle_if so#1 279 10 so#1 280 53 NA st#18 -rstmt st#14 fif so#1 275 7 so#1 281 11 st#19 st#15 -rstmt st#19 fassign so#1 282 7 so#1 282 24 st#20 NA -rstmt st#21 fassign so#1 284 10 so#1 284 26 st#22 NA -rstmt st#22 fio so#1 286 10 so#1 286 52 st#23 NA -rstmt st#24 fio so#1 288 11 so#1 288 52 st#25 NA -rstmt st#25 fassign so#1 289 11 so#1 289 25 st#26 NA -rstmt st#27 fassign so#1 291 12 so#1 291 48 NA NA -rstmt st#26 fdo so#1 290 11 so#1 292 15 st#28 st#27 -rstmt st#28 fio so#1 293 11 so#1 293 66 NA NA -rstmt st#23 fif so#1 287 10 so#1 294 14 NA st#24 -rstmt st#20 fif so#1 283 7 so#1 295 11 st#29 st#21 -rstmt st#30 fio so#1 297 8 so#1 297 69 NA NA -rstmt st#29 fsingle_if so#1 296 7 so#1 297 69 st#31 st#30 -rstmt st#31 freturn so#1 298 7 so#1 298 12 st#32 NA -rstmt st#32 freturn so#1 299 7 so#1 299 9 NA NA -rbody st#0 - -ro#4 READ_MDPAR -rloc so#1 301 18 -rlink f90 -rkind fext -rstart so#1 324 7 -rstmt st#0 fassign so#1 333 7 so#1 333 47 st#1 NA -rstmt st#1 fassign so#1 335 7 so#1 335 30 st#2 NA -rstmt st#2 fassign so#1 337 7 so#1 337 30 st#3 NA -rstmt st#3 fassign so#1 340 7 so#1 340 43 st#4 NA -rstmt st#4 fassign so#1 341 7 so#1 341 41 st#5 NA -rstmt st#5 fassign so#1 342 7 so#1 342 47 st#6 NA -rstmt st#6 fassign so#1 343 7 so#1 343 45 st#7 NA -rstmt st#8 fassign so#1 348 36 so#1 348 64 NA NA -rstmt st#7 fsingle_if so#1 348 7 so#1 348 64 st#9 st#8 -rstmt st#9 fassign so#1 350 7 so#1 350 68 st#10 NA -rstmt st#10 fassign so#1 351 7 so#1 351 62 st#11 NA -rstmt st#12 fassign so#1 352 33 so#1 352 58 NA NA -rstmt st#11 fsingle_if so#1 352 7 so#1 352 58 st#13 st#12 -rstmt st#13 fassign so#1 353 7 so#1 353 45 st#14 NA -rstmt st#14 fassign so#1 354 7 so#1 354 59 st#15 NA -rstmt st#15 fassign so#1 355 7 so#1 355 47 st#16 NA -rstmt st#16 fassign so#1 357 7 so#1 357 12 st#17 NA -rstmt st#17 fif so#1 358 7 so#1 360 11 st#18 NA -rstmt st#19 fio so#1 363 8 so#1 363 21 st#20 NA -rstmt st#20 fio so#1 364 8 so#1 364 72 st#21 NA -rstmt st#21 fio so#1 365 8 so#1 365 21 st#22 NA -rstmt st#22 fio so#1 366 8 so#1 366 42 st#23 NA -rstmt st#23 fio so#1 367 8 so#1 367 62 st#24 NA -rstmt st#24 fio so#1 368 8 so#1 369 46 st#25 NA -rstmt st#25 fio so#1 370 8 so#1 370 60 st#26 NA -rstmt st#26 fio so#1 371 8 so#1 371 21 st#27 NA -rstmt st#27 fio so#1 372 8 so#1 372 66 st#28 NA -rstmt st#28 fio so#1 373 8 so#1 375 24 st#29 NA -rstmt st#29 fio so#1 376 8 so#1 376 53 st#30 NA -rstmt st#31 fio so#1 378 9 so#1 380 64 st#32 NA -rstmt st#32 fio so#1 381 9 so#1 382 30 NA NA -rstmt st#30 fif so#1 377 8 so#1 383 12 st#33 st#31 -rstmt st#33 fio so#1 384 8 so#1 386 39 st#34 NA -rstmt st#34 fio so#1 387 8 so#1 389 43 st#35 NA -rstmt st#35 fio so#1 390 8 so#1 391 63 st#36 NA -rstmt st#36 fio so#1 392 8 so#1 392 68 st#37 NA -rstmt st#37 fio so#1 393 8 so#1 393 70 st#38 NA -rstmt st#39 fio so#1 394 20 so#1 395 62 NA NA -rstmt st#38 fsingle_if so#1 394 8 so#1 395 62 NA st#39 -rstmt st#18 fif so#1 362 7 so#1 396 11 st#40 st#19 -rstmt st#40 fassign so#1 397 7 so#1 397 24 st#41 NA -rstmt st#42 fassign so#1 402 9 so#1 402 51 st#43 NA -rstmt st#44 fio so#1 405 10 so#1 405 62 st#45 NA -rstmt st#46 fio so#1 407 11 so#1 408 62 NA NA -rstmt st#48 fio so#1 410 11 so#1 410 68 NA NA -rstmt st#50 fio so#1 412 11 so#1 412 72 NA NA -rstmt st#52 fio so#1 414 11 so#1 414 51 NA NA -rstmt st#53 fio so#1 416 11 so#1 417 69 st#54 NA -rstmt st#54 fstop so#1 418 11 NULL 0 0 NA NA -rstmt st#51 fif so#1 413 10 so#1 419 14 NA st#52 st#53 -rstmt st#49 fif so#1 411 10 so#1 419 14 NA st#50 st#51 -rstmt st#47 fif so#1 409 10 so#1 419 14 NA st#48 st#49 -rstmt st#45 fif so#1 406 10 so#1 419 14 st#55 st#46 st#47 -rstmt st#55 fio so#1 420 10 so#1 420 57 st#56 NA -rstmt st#56 fio so#1 421 10 so#1 421 70 st#57 NA -rstmt st#57 fio so#1 422 10 so#1 422 70 st#58 NA -rstmt st#58 fio so#1 423 10 so#1 424 59 st#59 NA -rstmt st#60 fio so#1 425 24 so#1 427 56 NA NA -rstmt st#59 fsingle_if so#1 425 10 so#1 427 56 NA st#60 -rstmt st#43 fif so#1 404 9 so#1 428 13 st#61 st#44 -rstmt st#61 fassign so#1 430 9 so#1 430 30 st#62 NA -rstmt st#63 fio so#1 432 10 so#1 433 13 NA NA -rstmt st#62 fsingle_if so#1 431 9 so#1 433 13 st#64 st#63 -rstmt st#64 fassign so#1 434 9 so#1 434 39 st#65 NA -rstmt st#65 fassign so#1 435 9 so#1 435 39 st#66 NA -rstmt st#67 fassign so#1 437 11 so#1 437 51 st#68 NA -rstmt st#68 fassign so#1 438 11 so#1 438 45 NA NA -rstmt st#66 fdo so#1 436 9 so#1 439 14 st#69 st#67 -rstmt st#70 fio so#1 441 10 so#1 443 52 st#71 NA -rstmt st#71 fio so#1 444 10 so#1 444 72 st#72 NA -rstmt st#73 fio so#1 446 11 so#1 447 45 NA NA -rstmt st#72 fdo so#1 445 10 so#1 448 14 NA st#73 -rstmt st#69 fif so#1 440 9 so#1 449 13 NA st#70 -rstmt st#76 fio so#1 452 10 so#1 452 56 st#77 NA -rstmt st#77 fio so#1 453 10 so#1 453 57 st#78 NA -rstmt st#78 fio so#1 454 10 so#1 454 71 st#79 NA -rstmt st#80 fio so#1 456 10 so#1 457 36 NA NA -rstmt st#79 fsingle_if so#1 455 10 so#1 457 36 st#81 st#80 -rstmt st#82 fio so#1 459 11 so#1 461 17 NA NA -rstmt st#81 fsingle_if so#1 458 10 so#1 461 17 NA st#82 -rstmt st#75 fif so#1 451 9 so#1 462 13 NA st#76 -rstmt st#84 fio so#1 465 10 so#1 465 63 NA NA -rstmt st#83 fsingle_if so#1 464 9 so#1 465 63 NA st#84 -rstmt st#74 fif so#1 450 7 so#1 466 11 NA st#75 st#83 -rstmt st#41 fif so#1 398 7 so#1 466 11 st#85 st#42 st#74 -rstmt st#87 fio so#1 468 18 so#1 468 72 NA NA -rstmt st#86 fsingle_if so#1 468 8 so#1 468 72 st#88 st#87 -rstmt st#89 fio so#1 470 11 so#1 470 54 st#90 NA -rstmt st#90 fio so#1 471 11 so#1 471 65 st#91 NA -rstmt st#91 fio so#1 472 11 so#1 472 60 st#92 NA -rstmt st#92 fio so#1 473 11 so#1 473 65 st#93 NA -rstmt st#94 fio so#1 475 12 so#1 475 52 st#95 NA -rstmt st#96 fio so#1 477 15 so#1 478 62 NA NA -rstmt st#95 fdo so#1 476 12 so#1 479 16 st#97 st#96 -rstmt st#97 fio so#1 480 12 so#1 480 68 st#98 NA -rstmt st#98 fio so#1 481 12 so#1 481 60 st#99 NA -rstmt st#100 fio so#1 483 13 so#1 484 64 NA NA -rstmt st#99 fdo so#1 482 12 so#1 485 16 st#101 st#100 -rstmt st#101 fio so#1 486 12 so#1 487 33 st#102 NA -rstmt st#102 fio so#1 488 12 so#1 488 45 st#103 NA -rstmt st#104 fio so#1 490 13 so#1 492 56 NA NA -rstmt st#103 fdo so#1 489 12 so#1 493 16 NA st#104 -rstmt st#93 fdo so#1 474 11 so#1 494 15 st#105 st#94 -rstmt st#105 fassign so#1 495 9 so#1 495 30 NA NA -rstmt st#88 fif so#1 469 8 so#1 496 12 NA st#89 -rstmt st#85 fif so#1 467 7 so#1 497 11 st#106 st#86 -rstmt st#107 fio so#1 499 8 so#1 499 67 NA NA -rstmt st#106 fsingle_if so#1 498 7 so#1 499 67 st#108 st#107 -rstmt st#108 freturn so#1 500 7 so#1 500 12 st#109 NA -rstmt st#109 freturn so#1 501 7 so#1 501 9 NA NA -rbody st#0 - -ro#5 MOLREAD -rloc so#1 503 18 -rlink f90 -rkind fext -rstart so#1 546 7 -rstmt st#1 fassign so#1 571 42 so#1 571 47 NA NA -rstmt st#0 fsingle_if so#1 571 7 so#1 571 47 st#2 st#1 -rstmt st#3 fassign so#1 574 28 so#1 574 39 NA NA -rstmt st#2 fsingle_if so#1 574 7 so#1 574 39 st#4 st#3 -rstmt st#4 fassign so#1 575 7 so#1 575 20 st#5 NA -rstmt st#5 fassign so#1 576 7 so#1 576 21 st#6 NA -rstmt st#6 fassign so#1 577 7 so#1 577 22 st#7 NA -rstmt st#7 fassign so#1 578 7 so#1 578 22 st#8 NA -rstmt st#8 fassign so#1 579 7 so#1 579 23 st#9 NA -rstmt st#9 fassign so#1 580 7 so#1 580 23 st#10 NA -rstmt st#10 fassign so#1 581 7 so#1 581 24 st#11 NA -rstmt st#11 fassign so#1 582 7 so#1 582 23 st#12 NA -rstmt st#12 fassign so#1 583 7 so#1 583 23 st#13 NA -rstmt st#13 fassign so#1 584 7 so#1 584 24 st#14 NA -rstmt st#14 fassign so#1 585 7 so#1 585 22 st#15 NA -rstmt st#15 fassign so#1 586 7 so#1 586 24 st#16 NA -rstmt st#16 fassign so#1 587 7 so#1 587 22 st#17 NA -rstmt st#17 fassign so#1 588 7 so#1 588 24 st#18 NA -rstmt st#18 fassign so#1 589 7 so#1 589 25 st#19 NA -rstmt st#19 fassign so#1 590 7 so#1 590 24 st#20 NA -rstmt st#20 fassign so#1 591 7 so#1 591 23 st#21 NA -rstmt st#21 fassign so#1 592 7 so#1 592 24 st#22 NA -rstmt st#22 fassign so#1 593 7 so#1 593 24 st#23 NA -rstmt st#24 fio so#1 595 8 so#1 597 21 NA NA -rstmt st#23 fsingle_if so#1 594 7 so#1 597 21 st#25 st#24 -rstmt st#25 flabel so#1 598 1 NULL 0 0 st#26 NA -rstmt st#28 fio so#1 619 9 so#1 620 50 st#29 NA -rstmt st#29 fio so#1 621 9 so#1 623 64 NA NA -rstmt st#31 fio so#1 625 9 so#1 626 50 NA NA -rstmt st#30 fif so#1 624 8 so#1 627 12 NA st#31 -rstmt st#27 fif so#1 618 8 so#1 627 12 st#32 st#28 st#30 -rstmt st#32 fio so#1 628 8 so#1 629 57 st#33 NA -rstmt st#33 fio so#1 630 8 so#1 631 62 NA NA -rstmt st#26 fif so#1 617 7 so#1 632 11 st#34 st#27 -rstmt st#34 fassign so#1 633 7 so#1 633 35 st#35 NA -rstmt st#36 fassign so#1 635 9 so#1 635 33 st#37 NA -rstmt st#37 fassign so#1 636 9 so#1 636 33 st#38 NA -rstmt st#38 fassign so#1 637 9 so#1 637 33 st#39 NA -rstmt st#39 fassign so#1 638 9 so#1 638 33 NA NA -rstmt st#35 fdo so#1 634 7 so#1 639 11 st#40 st#36 -rstmt st#41 fio so#1 642 8 so#1 644 21 NA NA -rstmt st#40 fsingle_if so#1 641 7 so#1 644 21 st#42 st#41 -rstmt st#42 flabel so#1 645 1 NULL 0 0 st#43 NA -rstmt st#44 fio so#1 665 8 so#1 666 13 NA NA -rstmt st#43 fsingle_if so#1 664 7 so#1 666 13 st#45 st#44 -rstmt st#46 fio so#1 676 8 so#1 676 60 st#47 NA -rstmt st#47 fio so#1 677 8 so#1 678 19 st#48 NA -rstmt st#48 fio so#1 679 8 so#1 679 59 st#49 NA -rstmt st#49 fio so#1 680 8 so#1 680 31 st#50 NA -rstmt st#50 fio so#1 681 8 so#1 681 49 NA NA -rstmt st#45 fif so#1 675 7 so#1 682 11 st#51 st#46 -rstmt st#52 fio so#1 684 9 so#1 684 31 st#53 NA -rstmt st#54 fio so#1 686 10 so#1 686 71 NA NA -rstmt st#53 fsingle_if so#1 685 9 so#1 686 71 st#55 st#54 -rstmt st#55 fio so#1 687 9 so#1 687 53 st#56 NA -rstmt st#57 flabel so#1 689 1 NULL 0 0 st#58 NA -rstmt st#58 fio so#1 689 3 so#1 689 52 st#59 NA -rstmt st#59 fstop so#1 690 9 NULL 0 0 st#60 NA -rstmt st#56 fgoto so#1 688 9 so#1 688 16 st#57 NA st#60 -rstmt st#60 flabel so#1 691 1 NULL 0 0 st#61 NA -rstmt st#62 fio so#1 696 10 so#1 696 72 NA NA -rstmt st#61 fsingle_if so#1 695 9 so#1 696 72 st#63 st#62 -rstmt st#64 fassign so#1 698 11 so#1 698 31 NA NA -rstmt st#63 fdo so#1 697 9 so#1 699 13 st#65 st#64 -rstmt st#65 fio so#1 700 9 so#1 700 22 st#66 NA -rstmt st#66 fassign so#1 701 9 so#1 701 22 st#67 NA -rstmt st#67 fassign so#1 702 9 so#1 702 29 st#68 NA -rstmt st#70 fio so#1 707 11 so#1 707 42 NA NA -rstmt st#69 fsingle_if so#1 706 10 so#1 707 42 st#71 st#70 -rstmt st#71 fassign so#1 708 10 so#1 708 19 st#72 NA -rstmt st#73 fassign so#1 710 11 so#1 710 22 st#74 NA -rstmt st#75 fassign so#1 712 13 so#1 712 17 st#76 NA -rstmt st#76 fassign so#1 713 13 so#1 713 23 st#77 NA -rstmt st#78 fassign so#1 716 15 so#1 716 23 NA NA -rstmt st#77 fdo so#1 714 13 so#1 717 17 st#79 st#78 -rstmt st#80 fio so#1 718 22 so#1 719 45 NA NA -rstmt st#79 fsingle_if so#1 718 13 so#1 719 45 NA st#80 -rstmt st#74 fif so#1 711 11 so#1 720 15 NA st#75 -rstmt st#72 fdo so#1 709 10 so#1 721 14 NA st#73 -rstmt st#68 fif so#1 705 9 so#1 722 15 NA st#69 -rstmt st#51 fif so#1 683 7 so#1 723 11 st#81 st#52 -rstmt st#82 fio so#1 726 9 so#1 726 25 st#83 NA -rstmt st#84 fio so#1 729 11 so#1 729 57 NA NA -rstmt st#85 fio so#1 731 11 so#1 731 57 NA NA -rstmt st#83 fif so#1 728 9 so#1 732 13 st#86 st#84 st#85 -rstmt st#87 fassign so#1 735 11 so#1 735 48 NA NA -rstmt st#86 fdo so#1 734 9 so#1 736 13 st#88 st#87 -rstmt st#89 fassign so#1 739 11 so#1 739 21 st#90 NA -rstmt st#90 fassign so#1 740 11 so#1 740 28 NA NA -rstmt st#88 fdo so#1 738 9 so#1 741 13 st#91 st#89 -rstmt st#92 fassign so#1 743 11 so#1 743 36 st#93 NA -rstmt st#93 fassign so#1 744 11 so#1 744 44 NA NA -rstmt st#91 fdo so#1 742 9 so#1 747 13 NA st#92 -rstmt st#81 fif so#1 724 7 so#1 748 12 st#94 st#82 -rstmt st#96 fassign so#1 757 11 so#1 757 19 NA NA -rstmt st#98 fassign so#1 763 4 so#1 763 12 NA NA -rstmt st#99 fassign so#1 765 4 so#1 765 12 NA NA -rstmt st#97 fif so#1 759 9 so#1 766 15 NA st#98 st#99 -rstmt st#95 fif so#1 753 9 so#1 766 15 NA st#96 st#97 -rstmt st#94 fdo so#1 751 7 so#1 767 11 st#100 st#95 -rstmt st#101 fio so#1 769 8 so#1 769 28 st#102 NA -rstmt st#103 fio so#1 771 10 so#1 771 42 NA NA -rstmt st#102 fdo so#1 770 8 so#1 772 12 st#104 st#103 -rstmt st#104 fio so#1 773 8 so#1 773 34 NA NA -rstmt st#100 fif so#1 768 7 so#1 774 11 st#105 st#101 -rstmt st#106 fassign so#1 778 9 so#1 778 25 st#107 NA -rstmt st#107 fassign so#1 779 9 so#1 779 24 NA NA -rstmt st#105 fdo so#1 777 7 so#1 780 11 st#108 st#106 -rstmt st#108 fio so#1 781 7 so#1 781 30 st#109 NA -rstmt st#110 fio so#1 783 9 so#1 783 26 st#111 NA -rstmt st#111 fio so#1 784 9 so#1 784 71 st#112 NA -rstmt st#113 fio so#1 786 10 so#1 787 62 st#114 NA -rstmt st#115 fio so#1 789 11 so#1 789 68 NA NA -rstmt st#114 fdo so#1 788 10 so#1 790 14 NA st#115 -rstmt st#112 fif so#1 785 9 so#1 791 13 st#116 st#113 -rstmt st#117 fassign so#1 793 11 so#1 793 33 st#118 NA -rstmt st#118 fassign so#1 794 11 so#1 794 37 NA NA -rstmt st#116 fdo so#1 792 9 so#1 795 13 st#119 st#117 -rstmt st#120 fio so#1 797 10 so#1 797 37 NA NA -rstmt st#119 fsingle_if so#1 796 9 so#1 797 37 st#121 st#120 -rstmt st#122 fassign so#1 799 11 so#1 799 29 st#123 NA -rstmt st#123 fassign so#1 800 11 so#1 800 44 st#124 NA -rstmt st#124 fassign so#1 801 11 so#1 801 44 NA NA -rstmt st#121 fdo so#1 798 9 so#1 802 14 NA st#122 -rstmt st#109 fif so#1 782 7 so#1 803 11 st#125 st#110 -rstmt st#125 fassign so#1 804 7 so#1 804 11 st#126 NA -rstmt st#127 fio so#1 808 8 so#1 808 61 st#128 NA -rstmt st#129 fio so#1 810 10 so#1 811 71 NA NA -rstmt st#128 fdo so#1 809 8 so#1 812 12 NA st#129 -rstmt st#126 fif so#1 806 7 so#1 814 11 st#130 st#127 -rstmt st#130 fassign so#1 816 7 so#1 816 14 st#131 NA -rstmt st#132 fassign so#1 818 27 so#1 818 31 NA NA -rstmt st#131 fsingle_if so#1 818 7 so#1 818 31 st#133 st#132 -rstmt st#134 fassign so#1 819 30 so#1 819 38 NA NA -rstmt st#133 fsingle_if so#1 819 7 so#1 819 38 st#135 st#134 -rstmt st#137 fio so#1 822 10 so#1 822 43 NA NA -rstmt st#136 fsingle_if so#1 821 9 so#1 822 43 st#138 st#137 -rstmt st#138 fassign so#1 823 9 so#1 823 22 st#139 NA -rstmt st#142 fassign so#1 827 15 so#1 827 30 st#143 NA -rstmt st#141 fif so#1 826 13 so#1 829 17 NA st#142 -rstmt st#140 fdo so#1 825 11 so#1 830 15 st#144 st#141 -rstmt st#144 fio so#1 831 11 so#1 832 68 st#145 NA -rstmt st#145 fstop so#1 833 11 NULL 0 0 NA NA -rstmt st#148 fassign so#1 838 15 so#1 838 37 st#149 NA -rstmt st#149 fassign so#1 839 15 so#1 839 28 st#150 NA -rstmt st#147 fif so#1 836 13 so#1 841 17 NA st#148 -rstmt st#146 fdo so#1 835 11 so#1 842 16 st#151 st#147 -rstmt st#151 fio so#1 843 11 so#1 844 68 NA NA -rstmt st#139 fif so#1 824 9 so#1 845 13 st#152 st#140 st#146 -rstmt st#150 fgoto so#1 840 15 so#1 840 22 NA NA st#152 -rstmt st#143 fgoto so#1 828 15 so#1 828 22 NA NA st#152 -rstmt st#152 flabel so#1 846 1 NULL 0 0 st#153 NA -rstmt st#154 fassign so#1 847 24 so#1 847 35 NA NA -rstmt st#153 fsingle_if so#1 847 9 so#1 847 35 st#155 st#154 -rstmt st#156 fassign so#1 848 30 so#1 848 43 NA NA -rstmt st#155 fsingle_if so#1 848 9 so#1 848 43 st#157 st#156 -rstmt st#158 fassign so#1 849 30 so#1 849 43 NA NA -rstmt st#157 fsingle_if so#1 849 9 so#1 849 43 st#159 st#158 -rstmt st#160 fio so#1 851 10 so#1 852 48 NA NA -rstmt st#159 fsingle_if so#1 850 9 so#1 852 48 NA st#160 -rstmt st#135 fif so#1 820 7 so#1 853 11 st#161 st#136 -rstmt st#162 fassign so#1 855 26 so#1 855 37 NA NA -rstmt st#161 fsingle_if so#1 855 7 so#1 855 37 st#163 st#162 -rstmt st#164 fassign so#1 857 9 so#1 857 25 NA NA -rstmt st#166 fassign so#1 859 9 so#1 859 18 NA NA -rstmt st#165 fif so#1 858 7 so#1 860 11 NA st#166 -rstmt st#163 fif so#1 856 7 so#1 860 11 st#167 st#164 st#165 -rstmt st#168 fio so#1 862 8 so#1 862 60 st#169 NA -rstmt st#169 fio so#1 863 8 so#1 863 36 NA NA -rstmt st#167 fif so#1 861 7 so#1 864 11 st#170 st#168 -rstmt st#173 flabel so#1 871 1 NULL 0 0 st#174 NA -rstmt st#174 fio so#1 871 4 so#1 871 65 st#175 NA -rstmt st#175 fstop so#1 874 11 NULL 0 0 st#176 NA -rstmt st#172 fgoto so#1 870 11 so#1 870 17 st#173 NA st#176 -rstmt st#176 flabel so#1 876 1 NULL 0 0 st#177 NA -rstmt st#177 fassign so#1 879 11 so#1 879 24 st#178 NA -rstmt st#178 fassign so#1 880 11 so#1 880 24 st#179 NA -rstmt st#179 fassign so#1 881 11 so#1 881 24 st#180 NA -rstmt st#182 fassign so#1 884 15 so#1 884 30 NA NA -rstmt st#181 fdo so#1 883 13 so#1 885 17 NA st#182 -rstmt st#180 fdo so#1 882 11 so#1 886 15 NA st#181 -rstmt st#171 fif so#1 868 9 so#1 888 13 st#183 st#172 -rstmt st#183 fsingle_if so#1 891 9 so#1 891 46 st#184 NA -rstmt st#185 fio so#1 893 10 so#1 893 43 NA NA -rstmt st#184 fsingle_if so#1 892 9 so#1 893 43 st#186 st#185 -rstmt st#188 fio so#1 896 10 so#1 896 63 NA NA -rstmt st#187 fsingle_if so#1 895 9 so#1 896 63 st#189 st#188 -rstmt st#191 fassign so#1 899 13 so#1 899 63 NA NA -rstmt st#190 fdo so#1 898 11 so#1 900 15 st#192 st#191 -rstmt st#193 fio so#1 902 12 so#1 904 59 NA NA -rstmt st#192 fsingle_if so#1 901 11 so#1 904 59 NA st#193 -rstmt st#189 fdo so#1 897 9 so#1 905 13 NA st#190 -rstmt st#186 fif so#1 894 9 so#1 906 13 NA st#187 -rstmt st#170 fif so#1 867 7 so#1 907 11 st#194 st#171 -rstmt st#197 fio so#1 915 12 so#1 915 65 NA NA -rstmt st#196 fsingle_if so#1 914 11 so#1 915 65 st#198 st#197 -rstmt st#199 fio so#1 917 13 so#1 919 44 st#200 NA -rstmt st#202 fassign so#1 923 17 so#1 923 39 st#203 NA -rstmt st#203 fassign so#1 924 17 so#1 924 55 NA NA -rstmt st#201 fdo so#1 922 15 so#1 925 19 NA st#202 -rstmt st#200 fdo so#1 921 13 so#1 926 17 st#204 st#201 -rstmt st#207 fassign so#1 930 19 so#1 930 50 st#208 NA -rstmt st#208 fassign so#1 931 19 so#1 931 70 NA NA -rstmt st#206 fdo so#1 929 17 so#1 932 21 NA st#207 -rstmt st#205 fif so#1 928 15 so#1 933 19 NA st#206 -rstmt st#204 fdo so#1 927 13 so#1 934 17 st#209 st#205 -rstmt st#209 freturn so#1 935 13 so#1 935 18 NA NA -rstmt st#198 fif so#1 916 11 so#1 938 15 st#210 st#199 -rstmt st#211 flabel so#1 940 1 NULL 0 0 st#212 NA -rstmt st#212 fio so#1 940 4 so#1 940 56 st#213 NA -rstmt st#213 fstop so#1 944 11 NULL 0 0 st#214 NA -rstmt st#210 fgoto so#1 939 11 so#1 939 17 st#211 NA st#214 -rstmt st#214 flabel so#1 945 1 NULL 0 0 NA NA -rstmt st#217 fio so#1 948 11 so#1 948 63 NA NA -rstmt st#216 fsingle_if so#1 947 10 so#1 948 63 st#218 st#217 -rstmt st#219 fassign so#1 950 11 so#1 950 31 NA NA -rstmt st#218 fdo so#1 949 10 so#1 951 14 st#220 st#219 -rstmt st#221 fassign so#1 953 11 so#1 953 30 NA NA -rstmt st#220 fdo so#1 952 10 so#1 954 14 st#222 st#221 -rstmt st#223 fassign so#1 956 11 so#1 956 31 NA NA -rstmt st#222 fdo so#1 955 10 so#1 957 14 st#224 st#223 -rstmt st#225 fassign so#1 959 11 so#1 959 32 NA NA -rstmt st#224 fdo so#1 958 10 so#1 960 14 NA st#225 -rstmt st#227 fio so#1 963 12 so#1 963 66 NA NA -rstmt st#226 fsingle_if so#1 962 11 so#1 963 66 st#228 st#227 -rstmt st#230 fassign so#1 971 15 so#1 971 20 st#231 NA -rstmt st#232 flabel so#1 974 1 NULL 0 0 st#233 NA -rstmt st#233 fio so#1 974 4 so#1 975 34 st#234 NA -rstmt st#234 fio so#1 976 15 so#1 978 33 NA NA -rstmt st#229 fdo so#1 970 13 so#1 986 17 st#235 st#230 -rstmt st#235 fio so#1 987 13 so#1 988 57 st#236 NA -rstmt st#236 fio so#1 989 13 so#1 990 57 st#237 NA -rstmt st#231 fgoto so#1 973 15 so#1 973 21 st#232 NA st#237 -rstmt st#237 flabel so#1 994 1 NULL 0 0 NA NA -rstmt st#228 fif so#1 967 11 so#1 995 15 NA st#229 -rstmt st#215 fif so#1 946 9 so#1 996 13 NA st#216 st#226 -rstmt st#195 fif so#1 913 9 so#1 996 13 NA st#196 st#215 -rstmt st#239 fio so#1 998 9 so#1 998 34 st#240 NA -rstmt st#240 fio so#1 999 9 so#1 999 56 st#241 NA -rstmt st#242 fio so#1 1001 9 so#1 1001 48 NA NA -rstmt st#241 fsingle_if so#1 1000 9 so#1 1001 48 st#243 st#242 -rstmt st#243 fio so#1 1002 9 so#1 1002 65 st#244 NA -rstmt st#245 flabel so#1 1004 1 NULL 0 0 st#246 NA -rstmt st#246 fio so#1 1004 3 so#1 1004 65 st#247 NA -rstmt st#247 fstop so#1 1008 9 NULL 0 0 st#248 NA -rstmt st#244 fgoto so#1 1003 9 so#1 1003 16 st#245 NA st#248 -rstmt st#248 flabel so#1 1009 1 NULL 0 0 NA NA -rstmt st#238 fif so#1 997 7 so#1 1011 12 NA st#239 -rstmt st#194 fif so#1 908 7 so#1 1011 12 st#249 st#195 st#238 -rstmt st#249 fif so#1 1013 7 so#1 1015 11 st#250 NA -rstmt st#250 fsingle_if so#1 1017 7 so#1 1018 18 st#251 NA -rstmt st#252 fio so#1 1020 9 so#1 1021 64 st#253 NA -rstmt st#253 fio so#1 1022 9 so#1 1022 45 st#254 NA -rstmt st#254 fio so#1 1023 9 so#1 1023 53 st#255 NA -rstmt st#256 fassign so#1 1025 4 so#1 1025 18 st#257 NA -rstmt st#257 fassign so#1 1026 4 so#1 1026 18 st#258 NA -rstmt st#258 fassign so#1 1027 4 so#1 1027 16 st#259 NA -rstmt st#259 fassign so#1 1028 4 so#1 1028 16 st#260 NA -rstmt st#261 fio so#1 1030 11 so#1 1032 23 NA NA -rstmt st#260 fsingle_if so#1 1029 4 so#1 1032 23 NA st#261 -rstmt st#255 fdo so#1 1024 2 so#1 1033 6 st#262 st#256 -rstmt st#262 fio so#1 1034 2 so#1 1034 19 NA NA -rstmt st#251 fif so#1 1019 7 so#1 1035 11 st#263 st#252 -rstmt st#263 fsingle_if so#1 1036 7 so#1 1036 41 st#264 NA -rstmt st#265 fio so#1 1047 9 so#1 1048 58 NA NA -rstmt st#264 fsingle_if so#1 1046 7 so#1 1048 58 st#266 st#265 -rstmt st#266 freturn so#1 1050 7 so#1 1050 12 st#267 NA -rstmt st#267 freturn so#1 1051 7 so#1 1051 9 NA NA -rbody st#0 - -ro#6 SEQ_COMP -rloc so#1 1053 24 -rlink f90 -rkind fint -rstart so#1 1057 7 -rstmt st#2 fassign so#1 1059 11 so#1 1059 26 st#3 NA -rstmt st#3 freturn so#1 1060 11 so#1 1060 16 NA NA -rstmt st#1 fif so#1 1058 9 so#1 1061 13 NA st#2 -rstmt st#0 fdo so#1 1057 7 so#1 1062 11 st#4 st#1 -rstmt st#4 fassign so#1 1063 7 so#1 1063 21 st#5 NA -rstmt st#5 freturn so#1 1064 7 so#1 1064 12 st#6 NA -rstmt st#6 freturn so#1 1065 7 so#1 1065 9 NA NA -rbody st#0 - -ro#7 READ_BRIDGE -rloc so#1 1067 18 -rlink f90 -rkind fext -rstart so#1 1090 7 -rstmt st#0 fio so#1 1090 7 so#1 1090 37 st#1 NA -rstmt st#1 fio so#1 1091 7 so#1 1091 22 st#2 NA -rstmt st#3 fio so#1 1093 9 so#1 1093 55 NA NA -rstmt st#2 fsingle_if so#1 1092 7 so#1 1093 55 st#4 st#3 -rstmt st#7 fio so#1 1097 37 so#1 1099 43 NA NA -rstmt st#6 fsingle_if so#1 1097 4 so#1 1099 43 st#8 st#7 -rstmt st#8 fio so#1 1100 4 so#1 1102 43 st#9 NA -rstmt st#9 fstop so#1 1105 10 NULL 0 0 NA NA -rstmt st#5 fif so#1 1096 2 so#1 1107 13 NA st#6 -rstmt st#4 fdo so#1 1095 7 so#1 1108 11 st#10 st#5 -rstmt st#11 fio so#1 1111 7 so#1 1111 48 st#12 NA -rstmt st#12 fio so#1 1112 7 so#1 1112 72 st#13 NA -rstmt st#14 fassign so#1 1114 9 so#1 1114 16 st#15 NA -rstmt st#18 fio so#1 1121 8 so#1 1122 56 st#19 NA -rstmt st#19 fio so#1 1123 8 so#1 1124 56 s \ No newline at end of file diff --git a/source/unres/src_MD-M-newcorr/permut.F b/source/unres/src_MD-M-newcorr/permut.F deleted file mode 100644 index 724f36c..0000000 --- a/source/unres/src_MD-M-newcorr/permut.F +++ /dev/null @@ -1,66 +0,0 @@ - subroutine permut(isym) - 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' -c include 'COMMON.DISTFIT' -c include 'COMMON.SETUP' - integer n,a - logical nextp - external nextp - dimension a(isym) -c parameter(n=symetr) - n=isym - if (n.eq.1) then - tabperm(1,1)=1 - return - endif - kkk=0 - do i=1,n - a(i)=i - enddo - 10 print *,(a(i),i=1,n) - kkk=kkk+1 - do i=1,n - tabperm(kkk,i)=a(i) -c write (iout,*) "tututu", kkk - 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/unres/src_MD-M-newcorr/pinorm.f b/source/unres/src_MD-M-newcorr/pinorm.f deleted file mode 100644 index 91392bf..0000000 --- a/source/unres/src_MD-M-newcorr/pinorm.f +++ /dev/null @@ -1,17 +0,0 @@ - double precision function pinorm(x) - implicit real*8 (a-h,o-z) -c -c this function takes an angle (in radians) and puts it in the range of -c -pi to +pi. -c - integer n - include 'COMMON.GEO' - n = x / dwapi - pinorm = x - n * dwapi - if ( pinorm .gt. pi ) then - pinorm = pinorm - dwapi - else if ( pinorm .lt. - pi ) then - pinorm = pinorm + dwapi - end if - return - end diff --git a/source/unres/src_MD-M-newcorr/printmat.f b/source/unres/src_MD-M-newcorr/printmat.f deleted file mode 100644 index be2b38f..0000000 --- a/source/unres/src_MD-M-newcorr/printmat.f +++ /dev/null @@ -1,16 +0,0 @@ - subroutine printmat(ldim,m,n,iout,key,a) - character*3 key(n) - double precision a(ldim,n) - do 1 i=1,n,8 - nlim=min0(i+7,n) - write (iout,1000) (key(k),k=i,nlim) - write (iout,1020) - 1000 format (/5x,8(6x,a3)) - 1020 format (/80(1h-)/) - do 2 j=1,n - write (iout,1010) key(j),(a(j,k),k=i,nlim) - 2 continue - 1 continue - 1010 format (a3,2x,8(f9.4)) - return - end diff --git a/source/unres/src_MD-M-newcorr/prng.f b/source/unres/src_MD-M-newcorr/prng.f deleted file mode 100644 index 73f6766..0000000 --- a/source/unres/src_MD-M-newcorr/prng.f +++ /dev/null @@ -1,525 +0,0 @@ - real*8 function prng_next(me) - implicit none - integer me -c -c Calling sequence: -c = prng_next ( ) -c = vprng ( , , ) -c -c This code is based on a sequential algorithm provided by Mal Kalos. -c This version uses a single 64-bit word to store the initial seeds -c and additive constants. -c A 64-bit floating point number is returned. -c -c The array "iparam" is full-word aligned, being padded by zeros to -c let each generator be on a subpage boundary. -c That is, rows 1 and 2 in a given column of the array are for real, -c rows 3-16 are bogus. -c -c July 12, 1993: double the number of sequences. We should have been -c using two packets per seed, rather than four -c October 31, 1993: merge the two arrays of seeds and constants, -c and switch to 64-bit arithmetic. -c June 1994: port to RS6K. Internal state is kept as 2 64-bit integers -c The ishft function is defined only on 32-bit integers, so we will -c shift numbers by dividing by 2**11 and then adding on 2**53-1. -c -c November 1994: ishift now works on 64-bit numbers (though it gives a -c warning). Thus we go back to using it. John Zollweg also added the -c vprng() routine to return vectors of real*8 random numbers. -c - real*8 recip53 - parameter ( recip53 = 2.0D0**(-53) ) - integer*8 two - parameter ( two = 2**11) - integer*8 m,ishift -c parameter ( m = 34522712143931 ) ! 11**13 -c parameter ( ishift = 9007199254740991 ) ! 2**53-1 - - integer nmax - integer*8 iparam - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - integer*8 next - -crc g77 doesn't support integer*8 constants - m = dint(34522712143931.0d0) - ishift = dint(9007199254740991.0d0) - -c RS6K porting note: ishift now takes 64-bit integers , with a warning - if ( 0.le.me .and. me.le.nmax ) then - next = iparam(1,me)*m + iparam(2,me) - iparam(1,me) = next - prng_next = recip53 * ishft( next, -11 ) - else - prng_next=-1.0D0 - endif - - end -c -c vprng(me, rn, num) Get a vector of random numbers -c - subroutine vprng(me,rn,num) - real*8 recip53, rn(1) - parameter ( recip53 = 2.0D0**(-53) ) - integer*8 m,iparam -c parameter ( m = 34522712143931 ) ! 11**13 - integer nmax, num, me - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - integer*8 next - -crc g77 doesn't support integer*8 constants - m = dint(34522712143931.0d0) - - if ( 0.le.me .and. me.le.nmax ) then - do 1 i=1,num - next = iparam(1,me)*m + iparam(2,me) - iparam(1,me) = next - rn(i) = recip53 * ishft( next, -11 ) - 1 continue - else - rn(1)=-1.0D0 - endif - return - end - -c -c prng_chkpnt Get the current state of a generator -c -c Calling sequence: -c logical prng_chkpnt, status -c status = prng_chkpnt (me, iseed) where -c -c me is the particular generator whose state is being gotten -c seed is an 4-element integer array where the "l"-values will be saved -c - logical function prng_chkpnt (me, iseed) - implicit none - integer me - integer*8 iseed - - integer nmax - integer*8 iparam - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - if (me .lt. 0 .or. me .gt. nmax) then - prng_chkpnt=.false. - else - prng_chkpnt=.true. - iseed=iparam(1,me) - endif - end -c -c prng_restart Restart generator from a saved state -c -c Calling sequence: -c logical prng_restart, status -c status = prng_restart (me, iseed) where -c -c me is the particular generator being restarted -c iseed is a 8-byte integer containing the "l"-values -c - logical function prng_restart (me, iseed) - implicit none - integer me - integer*8 iseed - - integer nmax - integer*8 iparam - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - if (me .lt. 0 .or. me .gt. nmax) then - prng_restart=.false. - return - else - prng_restart=.true. - iparam(1,me)=iseed - endif - end - - block data prngblk - parameter(nmax=1021) - integer*8 iparam - common/ksrprng/iparam(2,0:nmax) - data (iparam(1,i),iparam(2,i),i= 0, 29) / - + 11848219, 11848219, 11848237, 11848237, 11848241, 11848241, - + 11848247, 11848247, 11848253, 11848253, 11848271, 11848271, - + 11848297, 11848297, 11848313, 11848313, 11848339, 11848339, - + 11848351, 11848351, 11848357, 11848357, 11848363, 11848363, - + 11848367, 11848367, 11848373, 11848373, 11848379, 11848379, - + 11848393, 11848393, 11848433, 11848433, 11848451, 11848451, - + 11848469, 11848469, 11848477, 11848477, 11848489, 11848489, - + 11848493, 11848493, 11848513, 11848513, 11848523, 11848523, - + 11848531, 11848531, 11848537, 11848537, 11848553, 11848553, - + 11848589, 11848589, 11848591, 11848591, 11848601, 11848601 / - data (iparam(1,i),iparam(2,i),i= 30, 59) / - + 11848619, 11848619, 11848637, 11848637, 11848663, 11848663, - + 11848673, 11848673, 11848679, 11848679, 11848691, 11848691, - + 11848699, 11848699, 11848709, 11848709, 11848717, 11848717, - + 11848721, 11848721, 11848729, 11848729, 11848741, 11848741, - + 11848751, 11848751, 11848757, 11848757, 11848787, 11848787, - + 11848801, 11848801, 11848829, 11848829, 11848853, 11848853, - + 11848861, 11848861, 11848867, 11848867, 11848873, 11848873, - + 11848891, 11848891, 11848909, 11848909, 11848919, 11848919, - + 11848931, 11848931, 11848937, 11848937, 11848961, 11848961, - + 11848981, 11848981, 11849021, 11849021, 11849039, 11849039 / - data (iparam(1,i),iparam(2,i),i= 60, 89) / - + 11849053, 11849053, 11849059, 11849059, 11849069, 11849069, - + 11849077, 11849077, 11849087, 11849087, 11849093, 11849093, - + 11849107, 11849107, 11849111, 11849111, 11849129, 11849129, - + 11849137, 11849137, 11849177, 11849177, 11849183, 11849183, - + 11849203, 11849203, 11849231, 11849231, 11849237, 11849237, - + 11849239, 11849239, 11849249, 11849249, 11849251, 11849251, - + 11849269, 11849269, 11849273, 11849273, 11849291, 11849291, - + 11849297, 11849297, 11849309, 11849309, 11849339, 11849339, - + 11849359, 11849359, 11849363, 11849363, 11849399, 11849399, - + 11849401, 11849401, 11849413, 11849413, 11849417, 11849417 / - data (iparam(1,i),iparam(2,i),i= 90, 119) / - + 11849437, 11849437, 11849443, 11849443, 11849473, 11849473, - + 11849491, 11849491, 11849503, 11849503, 11849507, 11849507, - + 11849557, 11849557, 11849567, 11849567, 11849569, 11849569, - + 11849573, 11849573, 11849587, 11849587, 11849599, 11849599, - + 11849633, 11849633, 11849641, 11849641, 11849653, 11849653, - + 11849659, 11849659, 11849671, 11849671, 11849683, 11849683, - + 11849689, 11849689, 11849693, 11849693, 11849699, 11849699, - + 11849701, 11849701, 11849707, 11849707, 11849713, 11849713, - + 11849723, 11849723, 11849741, 11849741, 11849743, 11849743, - + 11849759, 11849759, 11849767, 11849767, 11849771, 11849771 / - data (iparam(1,i),iparam(2,i),i= 120, 149) / - + 11849791, 11849791, 11849801, 11849801, 11849809, 11849809, - + 11849813, 11849813, 11849869, 11849869, 11849881, 11849881, - + 11849891, 11849891, 11849909, 11849909, 11849923, 11849923, - + 11849933, 11849933, 11849947, 11849947, 11849987, 11849987, - + 11850001, 11850001, 11850011, 11850011, 11850019, 11850019, - + 11850023, 11850023, 11850031, 11850031, 11850049, 11850049, - + 11850061, 11850061, 11850073, 11850073, 11850077, 11850077, - + 11850103, 11850103, 11850109, 11850109, 11850121, 11850121, - + 11850127, 11850127, 11850133, 11850133, 11850149, 11850149, - + 11850161, 11850161, 11850169, 11850169, 11850191, 11850191 / - data (iparam(1,i),iparam(2,i),i= 150, 179) / - + 11850233, 11850233, 11850247, 11850247, 11850259, 11850259, - + 11850269, 11850269, 11850283, 11850283, 11850301, 11850301, - + 11850341, 11850341, 11850347, 11850347, 11850367, 11850367, - + 11850373, 11850373, 11850379, 11850379, 11850389, 11850389, - + 11850407, 11850407, 11850427, 11850427, 11850437, 11850437, - + 11850469, 11850469, 11850481, 11850481, 11850511, 11850511, - + 11850529, 11850529, 11850541, 11850541, 11850557, 11850557, - + 11850607, 11850607, 11850611, 11850611, 11850667, 11850667, - + 11850677, 11850677, 11850679, 11850679, 11850701, 11850701, - + 11850731, 11850731, 11850739, 11850739, 11850749, 11850749 / - data (iparam(1,i),iparam(2,i),i= 180, 209) / - + 11850791, 11850791, 11850803, 11850803, 11850829, 11850829, - + 11850833, 11850833, 11850859, 11850859, 11850877, 11850877, - + 11850899, 11850899, 11850907, 11850907, 11850913, 11850913, - + 11850919, 11850919, 11850931, 11850931, 11850941, 11850941, - + 11850947, 11850947, 11850953, 11850953, 11850961, 11850961, - + 11850983, 11850983, 11850991, 11850991, 11850997, 11850997, - + 11851031, 11851031, 11851033, 11851033, 11851051, 11851051, - + 11851061, 11851061, 11851067, 11851067, 11851093, 11851093, - + 11851109, 11851109, 11851123, 11851123, 11851127, 11851127, - + 11851139, 11851139, 11851157, 11851157, 11851163, 11851163 / - data (iparam(1,i),iparam(2,i),i= 210, 239) / - + 11851181, 11851181, 11851201, 11851201, 11851219, 11851219, - + 11851291, 11851291, 11851303, 11851303, 11851309, 11851309, - + 11851313, 11851313, 11851319, 11851319, 11851349, 11851349, - + 11851351, 11851351, 11851361, 11851361, 11851373, 11851373, - + 11851403, 11851403, 11851409, 11851409, 11851423, 11851423, - + 11851447, 11851447, 11851451, 11851451, 11851481, 11851481, - + 11851493, 11851493, 11851519, 11851519, 11851523, 11851523, - + 11851529, 11851529, 11851547, 11851547, 11851549, 11851549, - + 11851559, 11851559, 11851577, 11851577, 11851589, 11851589, - + 11851591, 11851591, 11851597, 11851597, 11851603, 11851603 / - data (iparam(1,i),iparam(2,i),i= 240, 269) / - + 11851607, 11851607, 11851613, 11851613, 11851621, 11851621, - + 11851627, 11851627, 11851639, 11851639, 11851673, 11851673, - + 11851681, 11851681, 11851727, 11851727, 11851753, 11851753, - + 11851759, 11851759, 11851787, 11851787, 11851793, 11851793, - + 11851799, 11851799, 11851813, 11851813, 11851841, 11851841, - + 11851859, 11851859, 11851867, 11851867, 11851891, 11851891, - + 11851909, 11851909, 11851919, 11851919, 11851927, 11851927, - + 11851933, 11851933, 11851949, 11851949, 11851967, 11851967, - + 11851997, 11851997, 11852017, 11852017, 11852051, 11852051, - + 11852053, 11852053, 11852059, 11852059, 11852083, 11852083 / - data (iparam(1,i),iparam(2,i),i= 270, 299) / - + 11852089, 11852089, 11852129, 11852129, 11852147, 11852147, - + 11852149, 11852149, 11852161, 11852161, 11852171, 11852171, - + 11852177, 11852177, 11852209, 11852209, 11852221, 11852221, - + 11852237, 11852237, 11852251, 11852251, 11852263, 11852263, - + 11852273, 11852273, 11852279, 11852279, 11852287, 11852287, - + 11852293, 11852293, 11852297, 11852297, 11852303, 11852303, - + 11852311, 11852311, 11852327, 11852327, 11852339, 11852339, - + 11852341, 11852341, 11852359, 11852359, 11852369, 11852369, - + 11852437, 11852437, 11852453, 11852453, 11852459, 11852459, - + 11852473, 11852473, 11852513, 11852513, 11852531, 11852531 / - data (iparam(1,i),iparam(2,i),i= 300, 329) / - + 11852537, 11852537, 11852539, 11852539, 11852557, 11852557, - + 11852573, 11852573, 11852579, 11852579, 11852591, 11852591, - + 11852609, 11852609, 11852611, 11852611, 11852623, 11852623, - + 11852641, 11852641, 11852647, 11852647, 11852657, 11852657, - + 11852663, 11852663, 11852717, 11852717, 11852719, 11852719, - + 11852741, 11852741, 11852759, 11852759, 11852767, 11852767, - + 11852773, 11852773, 11852803, 11852803, 11852807, 11852807, - + 11852809, 11852809, 11852831, 11852831, 11852833, 11852833, - + 11852837, 11852837, 11852857, 11852857, 11852873, 11852873, - + 11852879, 11852879, 11852891, 11852891, 11852917, 11852917 / - data (iparam(1,i),iparam(2,i),i= 330, 359) / - + 11852921, 11852921, 11852957, 11852957, 11852959, 11852959, - + 11852969, 11852969, 11852983, 11852983, 11852989, 11852989, - + 11853001, 11853001, 11853013, 11853013, 11853019, 11853019, - + 11853031, 11853031, 11853089, 11853089, 11853133, 11853133, - + 11853157, 11853157, 11853161, 11853161, 11853181, 11853181, - + 11853203, 11853203, 11853217, 11853217, 11853221, 11853221, - + 11853227, 11853227, 11853241, 11853241, 11853307, 11853307, - + 11853319, 11853319, 11853323, 11853323, 11853329, 11853329, - + 11853367, 11853367, 11853383, 11853383, 11853419, 11853419, - + 11853421, 11853421, 11853427, 11853427, 11853449, 11853449 / - data (iparam(1,i),iparam(2,i),i= 360, 389) / - + 11853451, 11853451, 11853463, 11853463, 11853529, 11853529, - + 11853557, 11853557, 11853571, 11853571, 11853601, 11853601, - + 11853613, 11853613, 11853617, 11853617, 11853629, 11853629, - + 11853649, 11853649, 11853659, 11853659, 11853679, 11853679, - + 11853689, 11853689, 11853719, 11853719, 11853731, 11853731, - + 11853757, 11853757, 11853761, 11853761, 11853773, 11853773, - + 11853791, 11853791, 11853817, 11853817, 11853839, 11853839, - + 11853847, 11853847, 11853857, 11853857, 11853869, 11853869, - + 11853883, 11853883, 11853887, 11853887, 11853889, 11853889, - + 11853893, 11853893, 11853899, 11853899, 11853911, 11853911 / - data (iparam(1,i),iparam(2,i),i= 390, 419) / - + 11853931, 11853931, 11853943, 11853943, 11853979, 11853979, - + 11853991, 11853991, 11854001, 11854001, 11854009, 11854009, - + 11854019, 11854019, 11854057, 11854057, 11854061, 11854061, - + 11854147, 11854147, 11854159, 11854159, 11854163, 11854163, - + 11854169, 11854169, 11854211, 11854211, 11854247, 11854247, - + 11854261, 11854261, 11854267, 11854267, 11854279, 11854279, - + 11854303, 11854303, 11854327, 11854327, 11854331, 11854331, - + 11854333, 11854333, 11854363, 11854363, 11854379, 11854379, - + 11854399, 11854399, 11854411, 11854411, 11854429, 11854429, - + 11854433, 11854433, 11854439, 11854439, 11854441, 11854441 / - data (iparam(1,i),iparam(2,i),i= 420, 449) / - + 11854463, 11854463, 11854477, 11854477, 11854489, 11854489, - + 11854517, 11854517, 11854519, 11854519, 11854523, 11854523, - + 11854529, 11854529, 11854567, 11854567, 11854571, 11854571, - + 11854573, 11854573, 11854603, 11854603, 11854607, 11854607, - + 11854681, 11854681, 11854691, 11854691, 11854709, 11854709, - + 11854723, 11854723, 11854757, 11854757, 11854783, 11854783, - + 11854793, 11854793, 11854813, 11854813, 11854847, 11854847, - + 11854853, 11854853, 11854873, 11854873, 11854877, 11854877, - + 11854883, 11854883, 11854891, 11854891, 11854897, 11854897, - + 11854901, 11854901, 11854919, 11854919, 11854937, 11854937 / - data (iparam(1,i),iparam(2,i),i= 450, 479) / - + 11854961, 11854961, 11854963, 11854963, 11854979, 11854979, - + 11855003, 11855003, 11855017, 11855017, 11855023, 11855023, - + 11855029, 11855029, 11855033, 11855033, 11855111, 11855111, - + 11855141, 11855141, 11855147, 11855147, 11855149, 11855149, - + 11855159, 11855159, 11855177, 11855177, 11855203, 11855203, - + 11855213, 11855213, 11855219, 11855219, 11855231, 11855231, - + 11855267, 11855267, 11855269, 11855269, 11855303, 11855303, - + 11855309, 11855309, 11855321, 11855321, 11855329, 11855329, - + 11855339, 11855339, 11855351, 11855351, 11855353, 11855353, - + 11855357, 11855357, 11855359, 11855359, 11855381, 11855381 / - data (iparam(1,i),iparam(2,i),i= 480, 509) / - + 11855383, 11855383, 11855387, 11855387, 11855399, 11855399, - + 11855407, 11855407, 11855413, 11855413, 11855489, 11855489, - + 11855491, 11855491, 11855507, 11855507, 11855521, 11855521, - + 11855531, 11855531, 11855549, 11855549, 11855551, 11855551, - + 11855567, 11855567, 11855581, 11855581, 11855587, 11855587, - + 11855593, 11855593, 11855633, 11855633, 11855653, 11855653, - + 11855663, 11855663, 11855687, 11855687, 11855689, 11855689, - + 11855699, 11855699, 11855713, 11855713, 11855731, 11855731, - + 11855737, 11855737, 11855743, 11855743, 11855747, 11855747, - + 11855759, 11855759, 11855773, 11855773, 11855801, 11855801 / - data (iparam(1,i),iparam(2,i),i= 510, 539) / - + 11855807, 11855807, 11855813, 11855813, 11855827, 11855827, - + 11855839, 11855839, 11855869, 11855869, 11855881, 11855881, - + 11855903, 11855903, 11855911, 11855911, 11855933, 11855933, - + 11855959, 11855959, 11855989, 11855989, 11855993, 11855993, - + 11855999, 11855999, 11856001, 11856001, 11856023, 11856023, - + 11856049, 11856049, 11856071, 11856071, 11856101, 11856101, - + 11856107, 11856107, 11856113, 11856113, 11856139, 11856139, - + 11856151, 11856151, 11856161, 11856161, 11856179, 11856179, - + 11856193, 11856193, 11856199, 11856199, 11856223, 11856223, - + 11856239, 11856239, 11856263, 11856263, 11856269, 11856269 / - data (iparam(1,i),iparam(2,i),i= 540, 569) / - + 11856281, 11856281, 11856287, 11856287, 11856307, 11856307, - + 11856311, 11856311, 11856329, 11856329, 11856343, 11856343, - + 11856359, 11856359, 11856371, 11856371, 11856373, 11856373, - + 11856409, 11856409, 11856419, 11856419, 11856461, 11856461, - + 11856469, 11856469, 11856473, 11856473, 11856479, 11856479, - + 11856511, 11856511, 11856517, 11856517, 11856541, 11856541, - + 11856547, 11856547, 11856553, 11856553, 11856583, 11856583, - + 11856629, 11856629, 11856641, 11856641, 11856653, 11856653, - + 11856659, 11856659, 11856673, 11856673, 11856697, 11856697, - + 11856709, 11856709, 11856727, 11856727, 11856731, 11856731 / - data (iparam(1,i),iparam(2,i),i= 570, 599) / - + 11856763, 11856763, 11856809, 11856809, 11856811, 11856811, - + 11856821, 11856821, 11856841, 11856841, 11856857, 11856857, - + 11856877, 11856877, 11856883, 11856883, 11856899, 11856899, - + 11856919, 11856919, 11856947, 11856947, 11856953, 11856953, - + 11856979, 11856979, 11857003, 11857003, 11857033, 11857033, - + 11857037, 11857037, 11857039, 11857039, 11857049, 11857049, - + 11857061, 11857061, 11857067, 11857067, 11857073, 11857073, - + 11857081, 11857081, 11857091, 11857091, 11857093, 11857093, - + 11857099, 11857099, 11857123, 11857123, 11857127, 11857127, - + 11857147, 11857147, 11857151, 11857151, 11857193, 11857193 / - data (iparam(1,i),iparam(2,i),i= 600, 629) / - + 11857217, 11857217, 11857229, 11857229, 11857243, 11857243, - + 11857249, 11857249, 11857267, 11857267, 11857277, 11857277, - + 11857291, 11857291, 11857303, 11857303, 11857309, 11857309, - + 11857327, 11857327, 11857331, 11857331, 11857333, 11857333, - + 11857361, 11857361, 11857367, 11857367, 11857369, 11857369, - + 11857393, 11857393, 11857399, 11857399, 11857409, 11857409, - + 11857421, 11857421, 11857423, 11857423, 11857451, 11857451, - + 11857453, 11857453, 11857457, 11857457, 11857477, 11857477, - + 11857481, 11857481, 11857493, 11857493, 11857499, 11857499, - + 11857519, 11857519, 11857523, 11857523, 11857529, 11857529 / - data (iparam(1,i),iparam(2,i),i= 630, 659) / - + 11857543, 11857543, 11857561, 11857561, 11857589, 11857589, - + 11857591, 11857591, 11857613, 11857613, 11857621, 11857621, - + 11857661, 11857661, 11857667, 11857667, 11857693, 11857693, - + 11857697, 11857697, 11857709, 11857709, 11857711, 11857711, - + 11857751, 11857751, 11857753, 11857753, 11857759, 11857759, - + 11857763, 11857763, 11857777, 11857777, 11857787, 11857787, - + 11857793, 11857793, 11857801, 11857801, 11857817, 11857817, - + 11857819, 11857819, 11857831, 11857831, 11857837, 11857837, - + 11857873, 11857873, 11857877, 11857877, 11857883, 11857883, - + 11857889, 11857889, 11857907, 11857907, 11857913, 11857913 / - data (iparam(1,i),iparam(2,i),i= 660, 689) / - + 11857931, 11857931, 11857969, 11857969, 11857991, 11857991, - + 11857999, 11857999, 11858009, 11858009, 11858017, 11858017, - + 11858023, 11858023, 11858029, 11858029, 11858039, 11858039, - + 11858051, 11858051, 11858057, 11858057, 11858059, 11858059, - + 11858101, 11858101, 11858111, 11858111, 11858131, 11858131, - + 11858149, 11858149, 11858159, 11858159, 11858177, 11858177, - + 11858191, 11858191, 11858201, 11858201, 11858227, 11858227, - + 11858243, 11858243, 11858267, 11858267, 11858269, 11858269, - + 11858279, 11858279, 11858281, 11858281, 11858291, 11858291, - + 11858311, 11858311, 11858323, 11858323, 11858359, 11858359 / - data (iparam(1,i),iparam(2,i),i= 690, 719) / - + 11858377, 11858377, 11858381, 11858381, 11858387, 11858387, - + 11858423, 11858423, 11858443, 11858443, 11858447, 11858447, - + 11858479, 11858479, 11858533, 11858533, 11858543, 11858543, - + 11858551, 11858551, 11858557, 11858557, 11858569, 11858569, - + 11858573, 11858573, 11858579, 11858579, 11858597, 11858597, - + 11858599, 11858599, 11858629, 11858629, 11858657, 11858657, - + 11858659, 11858659, 11858683, 11858683, 11858701, 11858701, - + 11858719, 11858719, 11858723, 11858723, 11858729, 11858729, - + 11858747, 11858747, 11858779, 11858779, 11858783, 11858783, - + 11858801, 11858801, 11858807, 11858807, 11858813, 11858813 / - data (iparam(1,i),iparam(2,i),i= 720, 749) / - + 11858839, 11858839, 11858851, 11858851, 11858893, 11858893, - + 11858897, 11858897, 11858921, 11858921, 11858947, 11858947, - + 11858953, 11858953, 11858969, 11858969, 11858971, 11858971, - + 11858989, 11858989, 11859017, 11859017, 11859031, 11859031, - + 11859049, 11859049, 11859061, 11859061, 11859073, 11859073, - + 11859077, 11859077, 11859079, 11859079, 11859083, 11859083, - + 11859101, 11859101, 11859109, 11859109, 11859137, 11859137, - + 11859139, 11859139, 11859151, 11859151, 11859157, 11859157, - + 11859163, 11859163, 11859167, 11859167, 11859179, 11859179, - + 11859187, 11859187, 11859229, 11859229, 11859233, 11859233 / - data (iparam(1,i),iparam(2,i),i= 750, 779) / - + 11859241, 11859241, 11859247, 11859247, 11859269, 11859269, - + 11859293, 11859293, 11859307, 11859307, 11859311, 11859311, - + 11859349, 11859349, 11859359, 11859359, 11859371, 11859371, - + 11859377, 11859377, 11859383, 11859383, 11859427, 11859427, - + 11859433, 11859433, 11859451, 11859451, 11859457, 11859457, - + 11859461, 11859461, 11859473, 11859473, 11859481, 11859481, - + 11859487, 11859487, 11859493, 11859493, 11859503, 11859503, - + 11859509, 11859509, 11859539, 11859539, 11859541, 11859541, - + 11859563, 11859563, 11859569, 11859569, 11859571, 11859571, - + 11859583, 11859583, 11859599, 11859599, 11859611, 11859611 / - data (iparam(1,i),iparam(2,i),i= 780, 809) / - + 11859643, 11859643, 11859707, 11859707, 11859713, 11859713, - + 11859719, 11859719, 11859739, 11859739, 11859751, 11859751, - + 11859791, 11859791, 11859817, 11859817, 11859821, 11859821, - + 11859833, 11859833, 11859847, 11859847, 11859853, 11859853, - + 11859877, 11859877, 11859889, 11859889, 11859893, 11859893, - + 11859901, 11859901, 11859907, 11859907, 11859917, 11859917, - + 11859923, 11859923, 11859929, 11859929, 11859961, 11859961, - + 11859979, 11859979, 11859989, 11859989, 11859997, 11859997, - + 11860021, 11860021, 11860031, 11860031, 11860039, 11860039, - + 11860049, 11860049, 11860081, 11860081, 11860087, 11860087 / - data (iparam(1,i),iparam(2,i),i= 810, 839) / - + 11860097, 11860097, 11860103, 11860103, 11860109, 11860109, - + 11860117, 11860117, 11860133, 11860133, 11860151, 11860151, - + 11860171, 11860171, 11860207, 11860207, 11860223, 11860223, - + 11860231, 11860231, 11860243, 11860243, 11860267, 11860267, - + 11860301, 11860301, 11860307, 11860307, 11860327, 11860327, - + 11860379, 11860379, 11860397, 11860397, 11860411, 11860411, - + 11860469, 11860469, 11860477, 11860477, 11860483, 11860483, - + 11860487, 11860487, 11860489, 11860489, 11860493, 11860493, - + 11860517, 11860517, 11860547, 11860547, 11860567, 11860567, - + 11860573, 11860573, 11860613, 11860613, 11860619, 11860619 / - data (iparam(1,i),iparam(2,i),i= 840, 869) / - + 11860627, 11860627, 11860637, 11860637, 11860643, 11860643, - + 11860649, 11860649, 11860661, 11860661, 11860669, 11860669, - + 11860687, 11860687, 11860691, 11860691, 11860697, 11860697, - + 11860699, 11860699, 11860703, 11860703, 11860727, 11860727, - + 11860741, 11860741, 11860753, 11860753, 11860777, 11860777, - + 11860787, 11860787, 11860789, 11860789, 11860811, 11860811, - + 11860837, 11860837, 11860859, 11860859, 11860867, 11860867, - + 11860889, 11860889, 11860897, 11860897, 11860963, 11860963, - + 11860969, 11860969, 11860973, 11860973, 11860993, 11860993, - + 11861011, 11861011, 11861033, 11861033, 11861071, 11861071 / - data (iparam(1,i),iparam(2,i),i= 870, 899) / - + 11861081, 11861081, 11861089, 11861089, 11861093, 11861093, - + 11861099, 11861099, 11861107, 11861107, 11861131, 11861131, - + 11861141, 11861141, 11861159, 11861159, 11861167, 11861167, - + 11861191, 11861191, 11861197, 11861197, 11861207, 11861207, - + 11861219, 11861219, 11861221, 11861221, 11861231, 11861231, - + 11861237, 11861237, 11861273, 11861273, 11861293, 11861293, - + 11861299, 11861299, 11861303, 11861303, 11861327, 11861327, - + 11861351, 11861351, 11861357, 11861357, 11861363, 11861363, - + 11861371, 11861371, 11861401, 11861401, 11861407, 11861407, - + 11861411, 11861411, 11861413, 11861413, 11861429, 11861429 / - data (iparam(1,i),iparam(2,i),i= 900, 929) / - + 11861441, 11861441, 11861467, 11861467, 11861527, 11861527, - + 11861539, 11861539, 11861543, 11861543, 11861557, 11861557, - + 11861569, 11861569, 11861573, 11861573, 11861579, 11861579, - + 11861581, 11861581, 11861599, 11861599, 11861611, 11861611, - + 11861617, 11861617, 11861627, 11861627, 11861639, 11861639, - + 11861651, 11861651, 11861659, 11861659, 11861671, 11861671, - + 11861683, 11861683, 11861687, 11861687, 11861693, 11861693, - + 11861701, 11861701, 11861711, 11861711, 11861713, 11861713, - + 11861749, 11861749, 11861791, 11861791, 11861803, 11861803, - + 11861819, 11861819, 11861827, 11861827, 11861849, 11861849 / - data (iparam(1,i),iparam(2,i),i= 930, 959) / - + 11861873, 11861873, 11861879, 11861879, 11861887, 11861887, - + 11861911, 11861911, 11861917, 11861917, 11861921, 11861921, - + 11861923, 11861923, 11861953, 11861953, 11861959, 11861959, - + 11861987, 11861987, 11862007, 11862007, 11862013, 11862013, - + 11862029, 11862029, 11862031, 11862031, 11862049, 11862049, - + 11862077, 11862077, 11862083, 11862083, 11862157, 11862157, - + 11862167, 11862167, 11862199, 11862199, 11862203, 11862203, - + 11862217, 11862217, 11862223, 11862223, 11862229, 11862229, - + 11862233, 11862233, 11862239, 11862239, 11862241, 11862241, - + 11862259, 11862259, 11862269, 11862269, 11862271, 11862271 / - data (iparam(1,i),iparam(2,i),i= 960, 989) / - + 11862293, 11862293, 11862307, 11862307, 11862313, 11862313, - + 11862317, 11862317, 11862343, 11862343, 11862353, 11862353, - + 11862373, 11862373, 11862391, 11862391, 11862439, 11862439, - + 11862469, 11862469, 11862493, 11862493, 11862527, 11862527, - + 11862547, 11862547, 11862563, 11862563, 11862569, 11862569, - + 11862577, 11862577, 11862581, 11862581, 11862611, 11862611, - + 11862623, 11862623, 11862661, 11862661, 11862673, 11862673, - + 11862679, 11862679, 11862701, 11862701, 11862703, 11862703, - + 11862713, 11862713, 11862761, 11862761, 11862791, 11862791, - + 11862803, 11862803, 11862839, 11862839, 11862841, 11862841 / - data (iparam(1,i),iparam(2,i),i= 990,1019) / - + 11862857, 11862857, 11862869, 11862869, 11862881, 11862881, - + 11862911, 11862911, 11862919, 11862919, 11862959, 11862959, - + 11862979, 11862979, 11862989, 11862989, 11862997, 11862997, - + 11863021, 11863021, 11863031, 11863031, 11863037, 11863037, - + 11863039, 11863039, 11863057, 11863057, 11863067, 11863067, - + 11863073, 11863073, 11863099, 11863099, 11863109, 11863109, - + 11863121, 11863121, 11863123, 11863123, 11863133, 11863133, - + 11863151, 11863151, 11863153, 11863153, 11863171, 11863171, - + 11863183, 11863183, 11863207, 11863207, 11863213, 11863213, - + 11863237, 11863237, 11863249, 11863249, 11863253, 11863253 / - data (iparam(1,i),iparam(2,i),i=1020,1021) / - + 11863259, 11863259, 11863279, 11863279 / - end diff --git a/source/unres/src_MD-M-newcorr/prng_32.F b/source/unres/src_MD-M-newcorr/prng_32.F deleted file mode 100644 index 21cac76..0000000 --- a/source/unres/src_MD-M-newcorr/prng_32.F +++ /dev/null @@ -1,1070 +0,0 @@ -#if defined(AIX) || defined(AMD64) - real*8 function prng_next(me) - implicit none - integer me -c -c Calling sequence: -c = prng_next ( ) -c = vprng ( , , ) -c -c This code is based on a sequential algorithm provided by Mal Kalos. -c This version uses a single 64-bit word to store the initial seeds -c and additive constants. -c A 64-bit floating point number is returned. -c -c The array "iparam" is full-word aligned, being padded by zeros to -c let each generator be on a subpage boundary. -c That is, rows 1 and 2 in a given column of the array are for real, -c rows 3-16 are bogus. -c -c July 12, 1993: double the number of sequences. We should have been -c using two packets per seed, rather than four -c October 31, 1993: merge the two arrays of seeds and constants, -c and switch to 64-bit arithmetic. -c June 1994: port to RS6K. Internal state is kept as 2 64-bit integers -c The ishft function is defined only on 32-bit integers, so we will -c shift numbers by dividing by 2**11 and then adding on 2**53-1. -c -c November 1994: ishift now works on 64-bit numbers (though it gives a -c warning). Thus we go back to using it. John Zollweg also added the -c vprng() routine to return vectors of real*8 random numbers. -c - real*8 recip53 - parameter ( recip53 = 2.0D0**(-53) ) - integer*8 two - parameter ( two = 2**11) - integer*8 m,ishift -c parameter ( m = 34522712143931 ) ! 11**13 -c parameter ( ishift = 9007199254740991 ) ! 2**53-1 - - integer nmax - integer*8 iparam - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - integer*8 next - -crc g77 doesn't support integer*8 constants - m = dint(34522712143931.0d0) - ishift = dint(9007199254740991.0d0) - if(me.gt.nmax) me=mod(me,nmax) - -c RS6K porting note: ishift now takes 64-bit integers , with a warning - if ( 0.le.me .and. me.le.nmax ) then - next = iparam(1,me)*m + iparam(2,me) - iparam(1,me) = next - prng_next = recip53 * ishft( next, -11 ) - else - prng_next=-1.0D0 - endif - - end -c -c vprng(me, rn, num) Get a vector of random numbers -c - subroutine vprng(me,rn,num) - real*8 recip53, rn(1) - parameter ( recip53 = 2.0D0**(-53) ) - integer*8 m,iparam -c parameter ( m = 34522712143931 ) ! 11**13 - integer nmax, num, me - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - integer*8 next - -crc g77 doesn't support integer*8 constants - m = dint(34522712143931.0d0) - - if ( 0.le.me .and. me.le.nmax ) then - do 1 i=1,num - next = iparam(1,me)*m + iparam(2,me) - iparam(1,me) = next - rn(i) = recip53 * ishft( next, -11 ) - 1 continue - else - rn(1)=-1.0D0 - endif - return - end - -c -c prng_chkpnt Get the current state of a generator -c -c Calling sequence: -c logical prng_chkpnt, status -c status = prng_chkpnt (me, iseed) where -c -c me is the particular generator whose state is being gotten -c seed is an 4-element integer array where the "l"-values will be saved -c - logical function prng_chkpnt (me, iseed) - implicit none - integer me - integer*8 iseed - - integer nmax - integer*8 iparam - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - if (me .lt. 0 .or. me .gt. nmax) then - prng_chkpnt=.false. - else - prng_chkpnt=.true. - iseed=iparam(1,me) - endif - end -c -c prng_restart Restart generator from a saved state -c -c Calling sequence: -c logical prng_restart, status -c status = prng_restart (me, iseed) where -c -c me is the particular generator being restarted -c iseed is a 8-byte integer containing the "l"-values -c - logical function prng_restart (me, iseed) - implicit none - integer me - integer*8 iseed - - integer nmax - integer*8 iparam - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - if(me.gt.nmax) me=mod(me,nmax) - if (me .lt. 0 .or. me .gt. nmax) then - prng_restart=.false. - return - else - prng_restart=.true. - iparam(1,me)=iseed - endif - end - - block data prngblk - parameter(nmax=1021) - integer*8 iparam - common/ksrprng/iparam(2,0:nmax) - data (iparam(1,i),iparam(2,i),i= 0, 29) / - + 11848219, 11848219, 11848237, 11848237, 11848241, 11848241, - + 11848247, 11848247, 11848253, 11848253, 11848271, 11848271, - + 11848297, 11848297, 11848313, 11848313, 11848339, 11848339, - + 11848351, 11848351, 11848357, 11848357, 11848363, 11848363, - + 11848367, 11848367, 11848373, 11848373, 11848379, 11848379, - + 11848393, 11848393, 11848433, 11848433, 11848451, 11848451, - + 11848469, 11848469, 11848477, 11848477, 11848489, 11848489, - + 11848493, 11848493, 11848513, 11848513, 11848523, 11848523, - + 11848531, 11848531, 11848537, 11848537, 11848553, 11848553, - + 11848589, 11848589, 11848591, 11848591, 11848601, 11848601 / - data (iparam(1,i),iparam(2,i),i= 30, 59) / - + 11848619, 11848619, 11848637, 11848637, 11848663, 11848663, - + 11848673, 11848673, 11848679, 11848679, 11848691, 11848691, - + 11848699, 11848699, 11848709, 11848709, 11848717, 11848717, - + 11848721, 11848721, 11848729, 11848729, 11848741, 11848741, - + 11848751, 11848751, 11848757, 11848757, 11848787, 11848787, - + 11848801, 11848801, 11848829, 11848829, 11848853, 11848853, - + 11848861, 11848861, 11848867, 11848867, 11848873, 11848873, - + 11848891, 11848891, 11848909, 11848909, 11848919, 11848919, - + 11848931, 11848931, 11848937, 11848937, 11848961, 11848961, - + 11848981, 11848981, 11849021, 11849021, 11849039, 11849039 / - data (iparam(1,i),iparam(2,i),i= 60, 89) / - + 11849053, 11849053, 11849059, 11849059, 11849069, 11849069, - + 11849077, 11849077, 11849087, 11849087, 11849093, 11849093, - + 11849107, 11849107, 11849111, 11849111, 11849129, 11849129, - + 11849137, 11849137, 11849177, 11849177, 11849183, 11849183, - + 11849203, 11849203, 11849231, 11849231, 11849237, 11849237, - + 11849239, 11849239, 11849249, 11849249, 11849251, 11849251, - + 11849269, 11849269, 11849273, 11849273, 11849291, 11849291, - + 11849297, 11849297, 11849309, 11849309, 11849339, 11849339, - + 11849359, 11849359, 11849363, 11849363, 11849399, 11849399, - + 11849401, 11849401, 11849413, 11849413, 11849417, 11849417 / - data (iparam(1,i),iparam(2,i),i= 90, 119) / - + 11849437, 11849437, 11849443, 11849443, 11849473, 11849473, - + 11849491, 11849491, 11849503, 11849503, 11849507, 11849507, - + 11849557, 11849557, 11849567, 11849567, 11849569, 11849569, - + 11849573, 11849573, 11849587, 11849587, 11849599, 11849599, - + 11849633, 11849633, 11849641, 11849641, 11849653, 11849653, - + 11849659, 11849659, 11849671, 11849671, 11849683, 11849683, - + 11849689, 11849689, 11849693, 11849693, 11849699, 11849699, - + 11849701, 11849701, 11849707, 11849707, 11849713, 11849713, - + 11849723, 11849723, 11849741, 11849741, 11849743, 11849743, - + 11849759, 11849759, 11849767, 11849767, 11849771, 11849771 / - data (iparam(1,i),iparam(2,i),i= 120, 149) / - + 11849791, 11849791, 11849801, 11849801, 11849809, 11849809, - + 11849813, 11849813, 11849869, 11849869, 11849881, 11849881, - + 11849891, 11849891, 11849909, 11849909, 11849923, 11849923, - + 11849933, 11849933, 11849947, 11849947, 11849987, 11849987, - + 11850001, 11850001, 11850011, 11850011, 11850019, 11850019, - + 11850023, 11850023, 11850031, 11850031, 11850049, 11850049, - + 11850061, 11850061, 11850073, 11850073, 11850077, 11850077, - + 11850103, 11850103, 11850109, 11850109, 11850121, 11850121, - + 11850127, 11850127, 11850133, 11850133, 11850149, 11850149, - + 11850161, 11850161, 11850169, 11850169, 11850191, 11850191 / - data (iparam(1,i),iparam(2,i),i= 150, 179) / - + 11850233, 11850233, 11850247, 11850247, 11850259, 11850259, - + 11850269, 11850269, 11850283, 11850283, 11850301, 11850301, - + 11850341, 11850341, 11850347, 11850347, 11850367, 11850367, - + 11850373, 11850373, 11850379, 11850379, 11850389, 11850389, - + 11850407, 11850407, 11850427, 11850427, 11850437, 11850437, - + 11850469, 11850469, 11850481, 11850481, 11850511, 11850511, - + 11850529, 11850529, 11850541, 11850541, 11850557, 11850557, - + 11850607, 11850607, 11850611, 11850611, 11850667, 11850667, - + 11850677, 11850677, 11850679, 11850679, 11850701, 11850701, - + 11850731, 11850731, 11850739, 11850739, 11850749, 11850749 / - data (iparam(1,i),iparam(2,i),i= 180, 209) / - + 11850791, 11850791, 11850803, 11850803, 11850829, 11850829, - + 11850833, 11850833, 11850859, 11850859, 11850877, 11850877, - + 11850899, 11850899, 11850907, 11850907, 11850913, 11850913, - + 11850919, 11850919, 11850931, 11850931, 11850941, 11850941, - + 11850947, 11850947, 11850953, 11850953, 11850961, 11850961, - + 11850983, 11850983, 11850991, 11850991, 11850997, 11850997, - + 11851031, 11851031, 11851033, 11851033, 11851051, 11851051, - + 11851061, 11851061, 11851067, 11851067, 11851093, 11851093, - + 11851109, 11851109, 11851123, 11851123, 11851127, 11851127, - + 11851139, 11851139, 11851157, 11851157, 11851163, 11851163 / - data (iparam(1,i),iparam(2,i),i= 210, 239) / - + 11851181, 11851181, 11851201, 11851201, 11851219, 11851219, - + 11851291, 11851291, 11851303, 11851303, 11851309, 11851309, - + 11851313, 11851313, 11851319, 11851319, 11851349, 11851349, - + 11851351, 11851351, 11851361, 11851361, 11851373, 11851373, - + 11851403, 11851403, 11851409, 11851409, 11851423, 11851423, - + 11851447, 11851447, 11851451, 11851451, 11851481, 11851481, - + 11851493, 11851493, 11851519, 11851519, 11851523, 11851523, - + 11851529, 11851529, 11851547, 11851547, 11851549, 11851549, - + 11851559, 11851559, 11851577, 11851577, 11851589, 11851589, - + 11851591, 11851591, 11851597, 11851597, 11851603, 11851603 / - data (iparam(1,i),iparam(2,i),i= 240, 269) / - + 11851607, 11851607, 11851613, 11851613, 11851621, 11851621, - + 11851627, 11851627, 11851639, 11851639, 11851673, 11851673, - + 11851681, 11851681, 11851727, 11851727, 11851753, 11851753, - + 11851759, 11851759, 11851787, 11851787, 11851793, 11851793, - + 11851799, 11851799, 11851813, 11851813, 11851841, 11851841, - + 11851859, 11851859, 11851867, 11851867, 11851891, 11851891, - + 11851909, 11851909, 11851919, 11851919, 11851927, 11851927, - + 11851933, 11851933, 11851949, 11851949, 11851967, 11851967, - + 11851997, 11851997, 11852017, 11852017, 11852051, 11852051, - + 11852053, 11852053, 11852059, 11852059, 11852083, 11852083 / - data (iparam(1,i),iparam(2,i),i= 270, 299) / - + 11852089, 11852089, 11852129, 11852129, 11852147, 11852147, - + 11852149, 11852149, 11852161, 11852161, 11852171, 11852171, - + 11852177, 11852177, 11852209, 11852209, 11852221, 11852221, - + 11852237, 11852237, 11852251, 11852251, 11852263, 11852263, - + 11852273, 11852273, 11852279, 11852279, 11852287, 11852287, - + 11852293, 11852293, 11852297, 11852297, 11852303, 11852303, - + 11852311, 11852311, 11852327, 11852327, 11852339, 11852339, - + 11852341, 11852341, 11852359, 11852359, 11852369, 11852369, - + 11852437, 11852437, 11852453, 11852453, 11852459, 11852459, - + 11852473, 11852473, 11852513, 11852513, 11852531, 11852531 / - data (iparam(1,i),iparam(2,i),i= 300, 329) / - + 11852537, 11852537, 11852539, 11852539, 11852557, 11852557, - + 11852573, 11852573, 11852579, 11852579, 11852591, 11852591, - + 11852609, 11852609, 11852611, 11852611, 11852623, 11852623, - + 11852641, 11852641, 11852647, 11852647, 11852657, 11852657, - + 11852663, 11852663, 11852717, 11852717, 11852719, 11852719, - + 11852741, 11852741, 11852759, 11852759, 11852767, 11852767, - + 11852773, 11852773, 11852803, 11852803, 11852807, 11852807, - + 11852809, 11852809, 11852831, 11852831, 11852833, 11852833, - + 11852837, 11852837, 11852857, 11852857, 11852873, 11852873, - + 11852879, 11852879, 11852891, 11852891, 11852917, 11852917 / - data (iparam(1,i),iparam(2,i),i= 330, 359) / - + 11852921, 11852921, 11852957, 11852957, 11852959, 11852959, - + 11852969, 11852969, 11852983, 11852983, 11852989, 11852989, - + 11853001, 11853001, 11853013, 11853013, 11853019, 11853019, - + 11853031, 11853031, 11853089, 11853089, 11853133, 11853133, - + 11853157, 11853157, 11853161, 11853161, 11853181, 11853181, - + 11853203, 11853203, 11853217, 11853217, 11853221, 11853221, - + 11853227, 11853227, 11853241, 11853241, 11853307, 11853307, - + 11853319, 11853319, 11853323, 11853323, 11853329, 11853329, - + 11853367, 11853367, 11853383, 11853383, 11853419, 11853419, - + 11853421, 11853421, 11853427, 11853427, 11853449, 11853449 / - data (iparam(1,i),iparam(2,i),i= 360, 389) / - + 11853451, 11853451, 11853463, 11853463, 11853529, 11853529, - + 11853557, 11853557, 11853571, 11853571, 11853601, 11853601, - + 11853613, 11853613, 11853617, 11853617, 11853629, 11853629, - + 11853649, 11853649, 11853659, 11853659, 11853679, 11853679, - + 11853689, 11853689, 11853719, 11853719, 11853731, 11853731, - + 11853757, 11853757, 11853761, 11853761, 11853773, 11853773, - + 11853791, 11853791, 11853817, 11853817, 11853839, 11853839, - + 11853847, 11853847, 11853857, 11853857, 11853869, 11853869, - + 11853883, 11853883, 11853887, 11853887, 11853889, 11853889, - + 11853893, 11853893, 11853899, 11853899, 11853911, 11853911 / - data (iparam(1,i),iparam(2,i),i= 390, 419) / - + 11853931, 11853931, 11853943, 11853943, 11853979, 11853979, - + 11853991, 11853991, 11854001, 11854001, 11854009, 11854009, - + 11854019, 11854019, 11854057, 11854057, 11854061, 11854061, - + 11854147, 11854147, 11854159, 11854159, 11854163, 11854163, - + 11854169, 11854169, 11854211, 11854211, 11854247, 11854247, - + 11854261, 11854261, 11854267, 11854267, 11854279, 11854279, - + 11854303, 11854303, 11854327, 11854327, 11854331, 11854331, - + 11854333, 11854333, 11854363, 11854363, 11854379, 11854379, - + 11854399, 11854399, 11854411, 11854411, 11854429, 11854429, - + 11854433, 11854433, 11854439, 11854439, 11854441, 11854441 / - data (iparam(1,i),iparam(2,i),i= 420, 449) / - + 11854463, 11854463, 11854477, 11854477, 11854489, 11854489, - + 11854517, 11854517, 11854519, 11854519, 11854523, 11854523, - + 11854529, 11854529, 11854567, 11854567, 11854571, 11854571, - + 11854573, 11854573, 11854603, 11854603, 11854607, 11854607, - + 11854681, 11854681, 11854691, 11854691, 11854709, 11854709, - + 11854723, 11854723, 11854757, 11854757, 11854783, 11854783, - + 11854793, 11854793, 11854813, 11854813, 11854847, 11854847, - + 11854853, 11854853, 11854873, 11854873, 11854877, 11854877, - + 11854883, 11854883, 11854891, 11854891, 11854897, 11854897, - + 11854901, 11854901, 11854919, 11854919, 11854937, 11854937 / - data (iparam(1,i),iparam(2,i),i= 450, 479) / - + 11854961, 11854961, 11854963, 11854963, 11854979, 11854979, - + 11855003, 11855003, 11855017, 11855017, 11855023, 11855023, - + 11855029, 11855029, 11855033, 11855033, 11855111, 11855111, - + 11855141, 11855141, 11855147, 11855147, 11855149, 11855149, - + 11855159, 11855159, 11855177, 11855177, 11855203, 11855203, - + 11855213, 11855213, 11855219, 11855219, 11855231, 11855231, - + 11855267, 11855267, 11855269, 11855269, 11855303, 11855303, - + 11855309, 11855309, 11855321, 11855321, 11855329, 11855329, - + 11855339, 11855339, 11855351, 11855351, 11855353, 11855353, - + 11855357, 11855357, 11855359, 11855359, 11855381, 11855381 / - data (iparam(1,i),iparam(2,i),i= 480, 509) / - + 11855383, 11855383, 11855387, 11855387, 11855399, 11855399, - + 11855407, 11855407, 11855413, 11855413, 11855489, 11855489, - + 11855491, 11855491, 11855507, 11855507, 11855521, 11855521, - + 11855531, 11855531, 11855549, 11855549, 11855551, 11855551, - + 11855567, 11855567, 11855581, 11855581, 11855587, 11855587, - + 11855593, 11855593, 11855633, 11855633, 11855653, 11855653, - + 11855663, 11855663, 11855687, 11855687, 11855689, 11855689, - + 11855699, 11855699, 11855713, 11855713, 11855731, 11855731, - + 11855737, 11855737, 11855743, 11855743, 11855747, 11855747, - + 11855759, 11855759, 11855773, 11855773, 11855801, 11855801 / - data (iparam(1,i),iparam(2,i),i= 510, 539) / - + 11855807, 11855807, 11855813, 11855813, 11855827, 11855827, - + 11855839, 11855839, 11855869, 11855869, 11855881, 11855881, - + 11855903, 11855903, 11855911, 11855911, 11855933, 11855933, - + 11855959, 11855959, 11855989, 11855989, 11855993, 11855993, - + 11855999, 11855999, 11856001, 11856001, 11856023, 11856023, - + 11856049, 11856049, 11856071, 11856071, 11856101, 11856101, - + 11856107, 11856107, 11856113, 11856113, 11856139, 11856139, - + 11856151, 11856151, 11856161, 11856161, 11856179, 11856179, - + 11856193, 11856193, 11856199, 11856199, 11856223, 11856223, - + 11856239, 11856239, 11856263, 11856263, 11856269, 11856269 / - data (iparam(1,i),iparam(2,i),i= 540, 569) / - + 11856281, 11856281, 11856287, 11856287, 11856307, 11856307, - + 11856311, 11856311, 11856329, 11856329, 11856343, 11856343, - + 11856359, 11856359, 11856371, 11856371, 11856373, 11856373, - + 11856409, 11856409, 11856419, 11856419, 11856461, 11856461, - + 11856469, 11856469, 11856473, 11856473, 11856479, 11856479, - + 11856511, 11856511, 11856517, 11856517, 11856541, 11856541, - + 11856547, 11856547, 11856553, 11856553, 11856583, 11856583, - + 11856629, 11856629, 11856641, 11856641, 11856653, 11856653, - + 11856659, 11856659, 11856673, 11856673, 11856697, 11856697, - + 11856709, 11856709, 11856727, 11856727, 11856731, 11856731 / - data (iparam(1,i),iparam(2,i),i= 570, 599) / - + 11856763, 11856763, 11856809, 11856809, 11856811, 11856811, - + 11856821, 11856821, 11856841, 11856841, 11856857, 11856857, - + 11856877, 11856877, 11856883, 11856883, 11856899, 11856899, - + 11856919, 11856919, 11856947, 11856947, 11856953, 11856953, - + 11856979, 11856979, 11857003, 11857003, 11857033, 11857033, - + 11857037, 11857037, 11857039, 11857039, 11857049, 11857049, - + 11857061, 11857061, 11857067, 11857067, 11857073, 11857073, - + 11857081, 11857081, 11857091, 11857091, 11857093, 11857093, - + 11857099, 11857099, 11857123, 11857123, 11857127, 11857127, - + 11857147, 11857147, 11857151, 11857151, 11857193, 11857193 / - data (iparam(1,i),iparam(2,i),i= 600, 629) / - + 11857217, 11857217, 11857229, 11857229, 11857243, 11857243, - + 11857249, 11857249, 11857267, 11857267, 11857277, 11857277, - + 11857291, 11857291, 11857303, 11857303, 11857309, 11857309, - + 11857327, 11857327, 11857331, 11857331, 11857333, 11857333, - + 11857361, 11857361, 11857367, 11857367, 11857369, 11857369, - + 11857393, 11857393, 11857399, 11857399, 11857409, 11857409, - + 11857421, 11857421, 11857423, 11857423, 11857451, 11857451, - + 11857453, 11857453, 11857457, 11857457, 11857477, 11857477, - + 11857481, 11857481, 11857493, 11857493, 11857499, 11857499, - + 11857519, 11857519, 11857523, 11857523, 11857529, 11857529 / - data (iparam(1,i),iparam(2,i),i= 630, 659) / - + 11857543, 11857543, 11857561, 11857561, 11857589, 11857589, - + 11857591, 11857591, 11857613, 11857613, 11857621, 11857621, - + 11857661, 11857661, 11857667, 11857667, 11857693, 11857693, - + 11857697, 11857697, 11857709, 11857709, 11857711, 11857711, - + 11857751, 11857751, 11857753, 11857753, 11857759, 11857759, - + 11857763, 11857763, 11857777, 11857777, 11857787, 11857787, - + 11857793, 11857793, 11857801, 11857801, 11857817, 11857817, - + 11857819, 11857819, 11857831, 11857831, 11857837, 11857837, - + 11857873, 11857873, 11857877, 11857877, 11857883, 11857883, - + 11857889, 11857889, 11857907, 11857907, 11857913, 11857913 / - data (iparam(1,i),iparam(2,i),i= 660, 689) / - + 11857931, 11857931, 11857969, 11857969, 11857991, 11857991, - + 11857999, 11857999, 11858009, 11858009, 11858017, 11858017, - + 11858023, 11858023, 11858029, 11858029, 11858039, 11858039, - + 11858051, 11858051, 11858057, 11858057, 11858059, 11858059, - + 11858101, 11858101, 11858111, 11858111, 11858131, 11858131, - + 11858149, 11858149, 11858159, 11858159, 11858177, 11858177, - + 11858191, 11858191, 11858201, 11858201, 11858227, 11858227, - + 11858243, 11858243, 11858267, 11858267, 11858269, 11858269, - + 11858279, 11858279, 11858281, 11858281, 11858291, 11858291, - + 11858311, 11858311, 11858323, 11858323, 11858359, 11858359 / - data (iparam(1,i),iparam(2,i),i= 690, 719) / - + 11858377, 11858377, 11858381, 11858381, 11858387, 11858387, - + 11858423, 11858423, 11858443, 11858443, 11858447, 11858447, - + 11858479, 11858479, 11858533, 11858533, 11858543, 11858543, - + 11858551, 11858551, 11858557, 11858557, 11858569, 11858569, - + 11858573, 11858573, 11858579, 11858579, 11858597, 11858597, - + 11858599, 11858599, 11858629, 11858629, 11858657, 11858657, - + 11858659, 11858659, 11858683, 11858683, 11858701, 11858701, - + 11858719, 11858719, 11858723, 11858723, 11858729, 11858729, - + 11858747, 11858747, 11858779, 11858779, 11858783, 11858783, - + 11858801, 11858801, 11858807, 11858807, 11858813, 11858813 / - data (iparam(1,i),iparam(2,i),i= 720, 749) / - + 11858839, 11858839, 11858851, 11858851, 11858893, 11858893, - + 11858897, 11858897, 11858921, 11858921, 11858947, 11858947, - + 11858953, 11858953, 11858969, 11858969, 11858971, 11858971, - + 11858989, 11858989, 11859017, 11859017, 11859031, 11859031, - + 11859049, 11859049, 11859061, 11859061, 11859073, 11859073, - + 11859077, 11859077, 11859079, 11859079, 11859083, 11859083, - + 11859101, 11859101, 11859109, 11859109, 11859137, 11859137, - + 11859139, 11859139, 11859151, 11859151, 11859157, 11859157, - + 11859163, 11859163, 11859167, 11859167, 11859179, 11859179, - + 11859187, 11859187, 11859229, 11859229, 11859233, 11859233 / - data (iparam(1,i),iparam(2,i),i= 750, 779) / - + 11859241, 11859241, 11859247, 11859247, 11859269, 11859269, - + 11859293, 11859293, 11859307, 11859307, 11859311, 11859311, - + 11859349, 11859349, 11859359, 11859359, 11859371, 11859371, - + 11859377, 11859377, 11859383, 11859383, 11859427, 11859427, - + 11859433, 11859433, 11859451, 11859451, 11859457, 11859457, - + 11859461, 11859461, 11859473, 11859473, 11859481, 11859481, - + 11859487, 11859487, 11859493, 11859493, 11859503, 11859503, - + 11859509, 11859509, 11859539, 11859539, 11859541, 11859541, - + 11859563, 11859563, 11859569, 11859569, 11859571, 11859571, - + 11859583, 11859583, 11859599, 11859599, 11859611, 11859611 / - data (iparam(1,i),iparam(2,i),i= 780, 809) / - + 11859643, 11859643, 11859707, 11859707, 11859713, 11859713, - + 11859719, 11859719, 11859739, 11859739, 11859751, 11859751, - + 11859791, 11859791, 11859817, 11859817, 11859821, 11859821, - + 11859833, 11859833, 11859847, 11859847, 11859853, 11859853, - + 11859877, 11859877, 11859889, 11859889, 11859893, 11859893, - + 11859901, 11859901, 11859907, 11859907, 11859917, 11859917, - + 11859923, 11859923, 11859929, 11859929, 11859961, 11859961, - + 11859979, 11859979, 11859989, 11859989, 11859997, 11859997, - + 11860021, 11860021, 11860031, 11860031, 11860039, 11860039, - + 11860049, 11860049, 11860081, 11860081, 11860087, 11860087 / - data (iparam(1,i),iparam(2,i),i= 810, 839) / - + 11860097, 11860097, 11860103, 11860103, 11860109, 11860109, - + 11860117, 11860117, 11860133, 11860133, 11860151, 11860151, - + 11860171, 11860171, 11860207, 11860207, 11860223, 11860223, - + 11860231, 11860231, 11860243, 11860243, 11860267, 11860267, - + 11860301, 11860301, 11860307, 11860307, 11860327, 11860327, - + 11860379, 11860379, 11860397, 11860397, 11860411, 11860411, - + 11860469, 11860469, 11860477, 11860477, 11860483, 11860483, - + 11860487, 11860487, 11860489, 11860489, 11860493, 11860493, - + 11860517, 11860517, 11860547, 11860547, 11860567, 11860567, - + 11860573, 11860573, 11860613, 11860613, 11860619, 11860619 / - data (iparam(1,i),iparam(2,i),i= 840, 869) / - + 11860627, 11860627, 11860637, 11860637, 11860643, 11860643, - + 11860649, 11860649, 11860661, 11860661, 11860669, 11860669, - + 11860687, 11860687, 11860691, 11860691, 11860697, 11860697, - + 11860699, 11860699, 11860703, 11860703, 11860727, 11860727, - + 11860741, 11860741, 11860753, 11860753, 11860777, 11860777, - + 11860787, 11860787, 11860789, 11860789, 11860811, 11860811, - + 11860837, 11860837, 11860859, 11860859, 11860867, 11860867, - + 11860889, 11860889, 11860897, 11860897, 11860963, 11860963, - + 11860969, 11860969, 11860973, 11860973, 11860993, 11860993, - + 11861011, 11861011, 11861033, 11861033, 11861071, 11861071 / - data (iparam(1,i),iparam(2,i),i= 870, 899) / - + 11861081, 11861081, 11861089, 11861089, 11861093, 11861093, - + 11861099, 11861099, 11861107, 11861107, 11861131, 11861131, - + 11861141, 11861141, 11861159, 11861159, 11861167, 11861167, - + 11861191, 11861191, 11861197, 11861197, 11861207, 11861207, - + 11861219, 11861219, 11861221, 11861221, 11861231, 11861231, - + 11861237, 11861237, 11861273, 11861273, 11861293, 11861293, - + 11861299, 11861299, 11861303, 11861303, 11861327, 11861327, - + 11861351, 11861351, 11861357, 11861357, 11861363, 11861363, - + 11861371, 11861371, 11861401, 11861401, 11861407, 11861407, - + 11861411, 11861411, 11861413, 11861413, 11861429, 11861429 / - data (iparam(1,i),iparam(2,i),i= 900, 929) / - + 11861441, 11861441, 11861467, 11861467, 11861527, 11861527, - + 11861539, 11861539, 11861543, 11861543, 11861557, 11861557, - + 11861569, 11861569, 11861573, 11861573, 11861579, 11861579, - + 11861581, 11861581, 11861599, 11861599, 11861611, 11861611, - + 11861617, 11861617, 11861627, 11861627, 11861639, 11861639, - + 11861651, 11861651, 11861659, 11861659, 11861671, 11861671, - + 11861683, 11861683, 11861687, 11861687, 11861693, 11861693, - + 11861701, 11861701, 11861711, 11861711, 11861713, 11861713, - + 11861749, 11861749, 11861791, 11861791, 11861803, 11861803, - + 11861819, 11861819, 11861827, 11861827, 11861849, 11861849 / - data (iparam(1,i),iparam(2,i),i= 930, 959) / - + 11861873, 11861873, 11861879, 11861879, 11861887, 11861887, - + 11861911, 11861911, 11861917, 11861917, 11861921, 11861921, - + 11861923, 11861923, 11861953, 11861953, 11861959, 11861959, - + 11861987, 11861987, 11862007, 11862007, 11862013, 11862013, - + 11862029, 11862029, 11862031, 11862031, 11862049, 11862049, - + 11862077, 11862077, 11862083, 11862083, 11862157, 11862157, - + 11862167, 11862167, 11862199, 11862199, 11862203, 11862203, - + 11862217, 11862217, 11862223, 11862223, 11862229, 11862229, - + 11862233, 11862233, 11862239, 11862239, 11862241, 11862241, - + 11862259, 11862259, 11862269, 11862269, 11862271, 11862271 / - data (iparam(1,i),iparam(2,i),i= 960, 989) / - + 11862293, 11862293, 11862307, 11862307, 11862313, 11862313, - + 11862317, 11862317, 11862343, 11862343, 11862353, 11862353, - + 11862373, 11862373, 11862391, 11862391, 11862439, 11862439, - + 11862469, 11862469, 11862493, 11862493, 11862527, 11862527, - + 11862547, 11862547, 11862563, 11862563, 11862569, 11862569, - + 11862577, 11862577, 11862581, 11862581, 11862611, 11862611, - + 11862623, 11862623, 11862661, 11862661, 11862673, 11862673, - + 11862679, 11862679, 11862701, 11862701, 11862703, 11862703, - + 11862713, 11862713, 11862761, 11862761, 11862791, 11862791, - + 11862803, 11862803, 11862839, 11862839, 11862841, 11862841 / - data (iparam(1,i),iparam(2,i),i= 990,1019) / - + 11862857, 11862857, 11862869, 11862869, 11862881, 11862881, - + 11862911, 11862911, 11862919, 11862919, 11862959, 11862959, - + 11862979, 11862979, 11862989, 11862989, 11862997, 11862997, - + 11863021, 11863021, 11863031, 11863031, 11863037, 11863037, - + 11863039, 11863039, 11863057, 11863057, 11863067, 11863067, - + 11863073, 11863073, 11863099, 11863099, 11863109, 11863109, - + 11863121, 11863121, 11863123, 11863123, 11863133, 11863133, - + 11863151, 11863151, 11863153, 11863153, 11863171, 11863171, - + 11863183, 11863183, 11863207, 11863207, 11863213, 11863213, - + 11863237, 11863237, 11863249, 11863249, 11863253, 11863253 / - data (iparam(1,i),iparam(2,i),i=1020,1021) / - + 11863259, 11863259, 11863279, 11863279 / - end -#else - real function prng_next(me) -crc logical prng_restart, prng_chkpnt -c -c Calling sequence: -c = prng_next ( ) -c -c This code is based on a sequential algorithm provided by Mal Kalos. -c This version uses 4 16-bit packets, and uses a block data common -c area for the initial seeds and constants. A 64-bit floating point -c number is returned. -c -c The arrays "l" and "n" are full-word aligned, being padded by zeros -c That is, rows 1-4 in a given column are for real, rows 5-16 are bogus -c -c July 12, 1993: double the number of sequences. We should have been -c using two packets per seed, rather than four -c - real tpm12 - integer iseed(4) - parameter(tpm12 = 1.d0/65536.d0) - parameter(nmax=1021) -c external prngblk - common/ksrprng/l(16,0:nmax),n(16,0:nmax) -c*ksr*subpage /ksrprng/ - data m1,m2,m3,m4 / 0, 8037, 61950, 30779/ - if (me .lt. 0 .or. me .gt. nmax) then - prng_next=-1.0 - return - endif - l1=l(1,me) - l2=l(2,me) - l3=l(3,me) - l4=l(4,me) - i1=l1*m4+l2*m3+l3*m2+l4*m1 + n(1,me) - i2=l2*m4+l3*m3+l4*m2 + n(2,me) - i3=l3*m4+l4*m3 + n(3,me) - i4=l4*m4 + n(4,me) - l4=and(i4,65535) - i3=i3+ishft(i4,-16) - l3=and(i3,65535) - i2=i2+ishft(i3,-16) - l2=and(i2,65535) - l1=and(i1+ishft(i2,-16),65535) - prng_next=tpm12*(l1+tpm12*(l2+tpm12*(l3+tpm12*l4))) - l(1,me)=l1 - l(2,me)=l2 - l(3,me)=l3 - l(4,me)=l4 - return - end -c -c prng_chkpnt Get the current state of a generator -c -c Calling sequence: -c logical prng_chkpnt, status -c status = prng_chkpnt (me, iseed) where -c -c me is the particular generator whose state is being gotten -c seed is an 4-element integer array where the "l"-values will be saved -c -crc entry prng_chkpnt (me, iseed) - logical function prng_chkpnt (me, iseed) - integer iseed(4) - parameter(nmax=1021) - common/ksrprng/l(16,0:nmax),n(16,0:nmax) - if (me .lt. 0 .or. me .gt. nmax) then - prng_chkpnt=.false. - else - prng_chkpnt=.true. - iseed(1)=l(1,me) - iseed(2)=l(2,me) - iseed(3)=l(3,me) - iseed(4)=l(4,me) - endif - return - end -c -c prng_restart Restart generator from a saved state -c -c Calling sequence: -c logical prng_restart, status -c status = prng_restart (me, iseed) where -c -c me is the particular generator being restarted -c seed is an 4-element integer array containing the "l"-values -c -crc entry prng_restart (me, iseed) - logical function prng_restart (me, iseed) - integer iseed(4) - parameter(nmax=1021) - common/ksrprng/l(16,0:nmax),n(16,0:nmax) - if (me .lt. 0 .or. me .gt. nmax) then - prng_restart=.false. - return - else - prng_restart=.true. - l(1,me)=iseed(1) - l(2,me)=iseed(2) - l(3,me)=iseed(3) - l(4,me)=iseed(4) - endif - return - end - - block data prngblk -c -c Sequence of prime numbers represented as pairs of 16-bit integers -c modulo 2**16, obtained from Mal Kalos August 28, 1992. Only 98 -c continuation cards are allowed by ksr Fortran, so several DATA -c statements are used to initialize 1022 generators. -c -c @cornell university, 1992 -c - parameter(nmax=1021,nmax1=2*nmax+2) - common/ksrprng/l(16,0:nmax),n(16,0:nmax) -c*ksr*subpage /ksrprng/ - -c High order quads in arrays "l" and "n" are initialized to zero : rows 1-2 -c Rows 5-16 remain uninitialized. They are just pads, never used. - DATA ((l(i,j),i=1,2),j=0,nmax)/nmax1*0.0/ - DATA ((n(i,j),i=1,2),j=0,nmax)/nmax1*0.0/ - -c The rest of array "l" and "n" are initialized to a 20-bit seed - DATA ((l(i,j),i=3,4),j=0,489)/ - .180, 51739,180, 51757,180, 51761,180, 51767,180,51773, - .180, 51791,180, 51817,180, 51833,180, 51859,180, 51871, - .180, 51877,180, 51883,180, 51887,180, 51893,180, 51899, - .180, 51913,180, 51953,180, 51971,180, 51989,180, 51997, - .180, 52009,180, 52013,180, 52033,180, 52043,180, 52051, - .180, 52057,180, 52073,180, 52109,180, 52111,180, 52121, - .180, 52139,180, 52157,180, 52183,180, 52193,180, 52199, - .180, 52211,180, 52219,180, 52229,180, 52237,180, 52241, - .180, 52249,180, 52261,180, 52271,180, 52277,180, 52307, - .180, 52321,180, 52349,180, 52373,180, 52381,180, 52387, - .180, 52393,180, 52411,180, 52429,180, 52439,180, 52451, - .180, 52457,180, 52481,180, 52501,180, 52541,180, 52559, - .180, 52573,180, 52579,180, 52589,180, 52597,180, 52607, - .180, 52613,180, 52627,180, 52631,180, 52649,180, 52657, - .180, 52697,180, 52703,180, 52723,180, 52751,180, 52757, - .180, 52759,180, 52769,180, 52771,180, 52789,180, 52793, - .180, 52811,180, 52817,180, 52829,180, 52859,180, 52879, - .180, 52883,180, 52919,180, 52921,180, 52933,180, 52937, - .180, 52957,180, 52963,180, 52993,180, 53011,180, 53023, - .180, 53027,180, 53077,180, 53087,180, 53089,180, 53093, - .180, 53107,180, 53119,180, 53153,180, 53161,180, 53173, - .180, 53179,180, 53191,180, 53203,180, 53209,180, 53213, - .180, 53219,180, 53221,180, 53227,180, 53233,180, 53243, - .180, 53261,180, 53263,180, 53279,180, 53287,180, 53291, - .180, 53311,180, 53321,180, 53329,180, 53333,180, 53389, - .180, 53401,180, 53411,180, 53429,180, 53443,180, 53453, - .180, 53467,180, 53507,180, 53521,180, 53531,180, 53539, - .180, 53543,180, 53551,180, 53569,180, 53581,180, 53593, - .180, 53597,180, 53623,180, 53629,180, 53641,180, 53647, - .180, 53653,180, 53669,180, 53681,180, 53689,180, 53711, - .180, 53753,180, 53767,180, 53779,180, 53789,180, 53803, - .180, 53821,180, 53861,180, 53867,180, 53887,180, 53893, - .180, 53899,180, 53909,180, 53927,180, 53947,180, 53957, - .180, 53989,180, 54001,180, 54031,180, 54049,180, 54061, - .180, 54077,180, 54127,180, 54131,180, 54187,180, 54197, - .180, 54199,180, 54221,180, 54251,180, 54259,180, 54269, - .180, 54311,180, 54323,180, 54349,180, 54353,180, 54379, - .180, 54397,180, 54419,180, 54427,180, 54433,180, 54439, - .180, 54451,180, 54461,180, 54467,180, 54473,180, 54481, - .180, 54503,180, 54511,180, 54517,180, 54551,180, 54553, - .180, 54571,180, 54581,180, 54587,180, 54613,180, 54629, - .180, 54643,180, 54647,180, 54659,180, 54677,180, 54683, - .180, 54701,180, 54721,180, 54739,180, 54811,180, 54823, - .180, 54829,180, 54833,180, 54839,180, 54869,180, 54871, - .180, 54881,180, 54893,180, 54923,180, 54929,180, 54943, - .180, 54967,180, 54971,180, 55001,180, 55013,180, 55039, - .180, 55043,180, 55049,180, 55067,180, 55069,180, 55079, - .180, 55097,180, 55109,180, 55111,180, 55117,180, 55123, - .180, 55127,180, 55133,180, 55141,180, 55147,180, 55159, - .180, 55193,180, 55201,180, 55247,180, 55273,180, 55279, - .180, 55307,180, 55313,180, 55319,180, 55333,180, 55361, - .180, 55379,180, 55387,180, 55411,180, 55429,180, 55439, - .180, 55447,180, 55453,180, 55469,180, 55487,180, 55517, - .180, 55537,180, 55571,180, 55573,180, 55579,180, 55603, - .180, 55609,180, 55649,180, 55667,180, 55669,180, 55681, - .180, 55691,180, 55697,180, 55729,180, 55741,180, 55757, - .180, 55771,180, 55783,180, 55793,180, 55799,180, 55807, - .180, 55813,180, 55817,180, 55823,180, 55831,180, 55847, - .180, 55859,180, 55861,180, 55879,180, 55889,180, 55957, - .180, 55973,180, 55979,180, 55993,180, 56033,180, 56051, - .180, 56057,180, 56059,180, 56077,180, 56093,180, 56099, - .180, 56111,180, 56129,180, 56131,180, 56143,180, 56161, - .180, 56167,180, 56177,180, 56183,180, 56237,180, 56239, - .180, 56261,180, 56279,180, 56287,180, 56293,180, 56323, - .180, 56327,180, 56329,180, 56351,180, 56353,180, 56357, - .180, 56377,180, 56393,180, 56399,180, 56411,180, 56437, - .180, 56441,180, 56477,180, 56479,180, 56489,180, 56503, - .180, 56509,180, 56521,180, 56533,180, 56539,180, 56551, - .180, 56609,180, 56653,180, 56677,180, 56681,180, 56701, - .180, 56723,180, 56737,180, 56741,180, 56747,180, 56761, - .180, 56827,180, 56839,180, 56843,180, 56849,180, 56887, - .180, 56903,180, 56939,180, 56941,180, 56947,180, 56969, - .180, 56971,180, 56983,180, 57049,180, 57077,180, 57091, - .180, 57121,180, 57133,180, 57137,180, 57149,180, 57169, - .180, 57179,180, 57199,180, 57209,180, 57239,180, 57251, - .180, 57277,180, 57281,180, 57293,180, 57311,180, 57337, - .180, 57359,180, 57367,180, 57377,180, 57389,180, 57403, - .180, 57407,180, 57409,180, 57413,180, 57419,180, 57431, - .180, 57451,180, 57463,180, 57499,180, 57511,180, 57521, - .180, 57529,180, 57539,180, 57577,180, 57581,180, 57667, - .180, 57679,180, 57683,180, 57689,180, 57731,180, 57767, - .180, 57781,180, 57787,180, 57799,180, 57823,180, 57847, - .180, 57851,180, 57853,180, 57883,180, 57899,180, 57919, - .180, 57931,180, 57949,180, 57953,180, 57959,180, 57961, - .180, 57983,180, 57997,180, 58009,180, 58037,180, 58039, - .180, 58043,180, 58049,180, 58087,180, 58091,180, 58093, - .180, 58123,180, 58127,180, 58201,180, 58211,180, 58229, - .180, 58243,180, 58277,180, 58303,180, 58313,180, 58333, - .180, 58367,180, 58373,180, 58393,180, 58397,180, 58403, - .180, 58411,180, 58417,180, 58421,180, 58439,180, 58457, - .180, 58481,180, 58483,180, 58499,180, 58523,180, 58537, - .180, 58543,180, 58549,180, 58553,180, 58631,180, 58661, - .180, 58667,180, 58669,180, 58679,180, 58697,180, 58723, - .180, 58733,180, 58739,180, 58751,180, 58787,180, 58789, - .180, 58823,180, 58829,180, 58841,180, 58849,180, 58859, - .180, 58871,180, 58873,180, 58877,180, 58879,180, 58901, - .180, 58903,180, 58907,180, 58919,180, 58927,180, 58933, - .180, 59009,180, 59011,180, 59027,180, 59041,180, 59051/ - DATA ((l(i,j),i=3,4),j=490,979)/ - .180, 59069,180, 59071,180, 59087,180, 59101,180, 59107, - .180, 59113,180, 59153,180, 59173,180, 59183,180, 59207, - .180, 59209,180, 59219,180, 59233,180, 59251,180, 59257, - .180, 59263,180, 59267,180, 59279,180, 59293,180, 59321, - .180, 59327,180, 59333,180, 59347,180, 59359,180, 59389, - .180, 59401,180, 59423,180, 59431,180, 59453,180, 59479, - .180, 59509,180, 59513,180, 59519,180, 59521,180, 59543, - .180, 59569,180, 59591,180, 59621,180, 59627,180, 59633, - .180, 59659,180, 59671,180, 59681,180, 59699,180, 59713, - .180, 59719,180, 59743,180, 59759,180, 59783,180, 59789, - .180, 59801,180, 59807,180, 59827,180, 59831,180, 59849, - .180, 59863,180, 59879,180, 59891,180, 59893,180, 59929, - .180, 59939,180, 59981,180, 59989,180, 59993,180, 59999, - .180, 60031,180, 60037,180, 60061,180, 60067,180, 60073, - .180, 60103,180, 60149,180, 60161,180, 60173,180, 60179, - .180, 60193,180, 60217,180, 60229,180, 60247,180, 60251, - .180, 60283,180, 60329,180, 60331,180, 60341,180, 60361, - .180, 60377,180, 60397,180, 60403,180, 60419,180, 60439, - .180, 60467,180, 60473,180, 60499,180, 60523,180, 60553, - .180, 60557,180, 60559,180, 60569,180, 60581,180, 60587, - .180, 60593,180, 60601,180, 60611,180, 60613,180, 60619, - .180, 60643,180, 60647,180, 60667,180, 60671,180, 60713, - .180, 60737,180, 60749,180, 60763,180, 60769,180, 60787, - .180, 60797,180, 60811,180, 60823,180, 60829,180, 60847, - .180, 60851,180, 60853,180, 60881,180, 60887,180, 60889, - .180, 60913,180, 60919,180, 60929,180, 60941,180, 60943, - .180, 60971,180, 60973,180, 60977,180, 60997,180, 61001, - .180, 61013,180, 61019,180, 61039,180, 61043,180, 61049, - .180, 61063,180, 61081,180, 61109,180, 61111,180, 61133, - .180, 61141,180, 61181,180, 61187,180, 61213,180, 61217, - .180, 61229,180, 61231,180, 61271,180, 61273,180, 61279, - .180, 61283,180, 61297,180, 61307,180, 61313,180, 61321, - .180, 61337,180, 61339,180, 61351,180, 61357,180, 61393, - .180, 61397,180, 61403,180, 61409,180, 61427,180, 61433, - .180, 61451,180, 61489,180, 61511,180, 61519,180, 61529, - .180, 61537,180, 61543,180, 61549,180, 61559,180, 61571, - .180, 61577,180, 61579,180, 61621,180, 61631,180, 61651, - .180, 61669,180, 61679,180, 61697,180, 61711,180, 61721, - .180, 61747,180, 61763,180, 61787,180, 61789,180, 61799, - .180, 61801,180, 61811,180, 61831,180, 61843,180, 61879, - .180, 61897,180, 61901,180, 61907,180, 61943,180, 61963, - .180, 61967,180, 61999,180, 62053,180, 62063,180, 62071, - .180, 62077,180, 62089,180, 62093,180, 62099,180, 62117, - .180, 62119,180, 62149,180, 62177,180, 62179,180, 62203, - .180, 62221,180, 62239,180, 62243,180, 62249,180, 62267, - .180, 62299,180, 62303,180, 62321,180, 62327,180, 62333, - .180, 62359,180, 62371,180, 62413,180, 62417,180, 62441, - .180, 62467,180, 62473,180, 62489,180, 62491,180, 62509, - .180, 62537,180, 62551,180, 62569,180, 62581,180, 62593, - .180, 62597,180, 62599,180, 62603,180, 62621,180, 62629, - .180, 62657,180, 62659,180, 62671,180, 62677,180, 62683, - .180, 62687,180, 62699,180, 62707,180, 62749,180, 62753, - .180, 62761,180, 62767,180, 62789,180, 62813,180, 62827, - .180, 62831,180, 62869,180, 62879,180, 62891,180, 62897, - .180, 62903,180, 62947,180, 62953,180, 62971,180, 62977, - .180, 62981,180, 62993,180, 63001,180, 63007,180, 63013, - .180, 63023,180, 63029,180, 63059,180, 63061,180, 63083, - .180, 63089,180, 63091,180, 63103,180, 63119,180, 63131, - .180, 63163,180, 63227,180, 63233,180, 63239,180, 63259, - .180, 63271,180, 63311,180, 63337,180, 63341,180, 63353, - .180, 63367,180, 63373,180, 63397,180, 63409,180, 63413, - .180, 63421,180, 63427,180, 63437,180, 63443,180, 63449, - .180, 63481,180, 63499,180, 63509,180, 63517,180, 63541, - .180, 63551,180, 63559,180, 63569,180, 63601,180, 63607, - .180, 63617,180, 63623,180, 63629,180, 63637,180, 63653, - .180, 63671,180, 63691,180, 63727,180, 63743,180, 63751, - .180, 63763,180, 63787,180, 63821,180, 63827,180, 63847, - .180, 63899,180, 63917,180, 63931,180, 63989,180, 63997, - .180, 64003,180, 64007,180, 64009,180, 64013,180, 64037, - .180, 64067,180, 64087,180, 64093,180, 64133,180, 64139, - .180, 64147,180, 64157,180, 64163,180, 64169,180, 64181, - .180, 64189,180, 64207,180, 64211,180, 64217,180, 64219, - .180, 64223,180, 64247,180, 64261,180, 64273,180, 64297, - .180, 64307,180, 64309,180, 64331,180, 64357,180, 64379, - .180, 64387,180, 64409,180, 64417,180, 64483,180, 64489, - .180, 64493,180, 64513,180, 64531,180, 64553,180, 64591, - .180, 64601,180, 64609,180, 64613,180, 64619,180, 64627, - .180, 64651,180, 64661,180, 64679,180, 64687,180, 64711, - .180, 64717,180, 64727,180, 64739,180, 64741,180, 64751, - .180, 64757,180, 64793,180, 64813,180, 64819,180, 64823, - .180, 64847,180, 64871,180, 64877,180, 64883,180, 64891, - .180, 64921,180, 64927,180, 64931,180, 64933,180, 64949, - .180, 64961,180, 64987,180, 65047,180, 65059,180, 65063, - .180, 65077,180, 65089,180, 65093,180, 65099,180, 65101, - .180, 65119,180, 65131,180, 65137,180, 65147,180, 65159, - .180, 65171,180, 65179,180, 65191,180, 65203,180, 65207, - .180, 65213,180, 65221,180, 65231,180, 65233,180, 65269, - .180, 65311,180, 65323,180, 65339,180, 65347,180, 65369, - .180, 65393,180, 65399,180, 65407,180, 65431,180, 65437, - .180, 65441,180, 65443,180, 65473,180, 65479,180, 65507, - .180, 65527,180, 65533,181, 13,181, 15,181, 33, - .181, 61,181, 67,181, 141,181, 151,181, 183, - .181, 187,181, 201,181, 207,181, 213,181, 217, - .181, 223,181, 225,181, 243,181, 253,181, 255, - .181, 277,181, 291,181, 297,181, 301,181, 327, - .181, 337,181, 357,181, 375,181, 423,181, 453, - .181, 477,181, 511,181, 531,181, 547,181, 553, - .181, 561,181, 565,181, 595,181, 607,181, 645/ - DATA ((l(i,j),i=3,4),j=980,nmax)/ - .181, 657,181, 663,181, 685,181, 687,181, 697, - .181, 745,181, 775,181, 787,181, 823,181, 825, - .181, 841,181, 853,181, 865,181, 895,181, 903, - .181, 943,181, 963,181, 973,181, 981,181, 1005, - .181,1015,181,1021,181,1023,181,1041,181,1051, - .181, 1057,181, 1083,181, 1093,181, 1105,181, 1107, - .181, 1117,181, 1135,181, 1137,181, 1155,181, 1167, - .181, 1191,181, 1197,181, 1221,181, 1233,181, 1237, - .181, 1243,181, 1263/ - DATA ((n(i,j),i=3,4),j=0,489)/ - .180, 51739,180, 51757,180, 51761,180, 51767,180, 51773, - .180, 51791,180, 51817,180, 51833,180, 51859,180, 51871, - .180, 51877,180, 51883,180, 51887,180, 51893,180, 51899, - .180, 51913,180, 51953,180, 51971,180, 51989,180, 51997, - .180, 52009,180, 52013,180, 52033,180, 52043,180, 52051, - .180, 52057,180, 52073,180, 52109,180, 52111,180, 52121, - .180, 52139,180, 52157,180, 52183,180, 52193,180, 52199, - .180, 52211,180, 52219,180, 52229,180, 52237,180, 52241, - .180, 52249,180, 52261,180, 52271,180, 52277,180, 52307, - .180, 52321,180, 52349,180, 52373,180, 52381,180, 52387, - .180, 52393,180, 52411,180, 52429,180, 52439,180, 52451, - .180, 52457,180, 52481,180, 52501,180, 52541,180, 52559, - .180, 52573,180, 52579,180, 52589,180, 52597,180, 52607, - .180, 52613,180, 52627,180, 52631,180, 52649,180, 52657, - .180, 52697,180, 52703,180, 52723,180, 52751,180, 52757, - .180, 52759,180, 52769,180, 52771,180, 52789,180, 52793, - .180, 52811,180, 52817,180, 52829,180, 52859,180, 52879, - .180, 52883,180, 52919,180, 52921,180, 52933,180, 52937, - .180, 52957,180, 52963,180, 52993,180, 53011,180, 53023, - .180, 53027,180, 53077,180, 53087,180, 53089,180, 53093, - .180, 53107,180, 53119,180, 53153,180, 53161,180, 53173, - .180, 53179,180, 53191,180, 53203,180, 53209,180, 53213, - .180, 53219,180, 53221,180, 53227,180, 53233,180, 53243, - .180, 53261,180, 53263,180, 53279,180, 53287,180, 53291, - .180, 53311,180, 53321,180, 53329,180, 53333,180, 53389, - .180, 53401,180, 53411,180, 53429,180, 53443,180, 53453, - .180, 53467,180, 53507,180, 53521,180, 53531,180, 53539, - .180, 53543,180, 53551,180, 53569,180, 53581,180, 53593, - .180, 53597,180, 53623,180, 53629,180, 53641,180, 53647, - .180, 53653,180, 53669,180, 53681,180, 53689,180, 53711, - .180, 53753,180, 53767,180, 53779,180, 53789,180, 53803, - .180, 53821,180, 53861,180, 53867,180, 53887,180, 53893, - .180, 53899,180, 53909,180, 53927,180, 53947,180, 53957, - .180, 53989,180, 54001,180, 54031,180, 54049,180, 54061, - .180, 54077,180, 54127,180, 54131,180, 54187,180, 54197, - .180, 54199,180, 54221,180, 54251,180, 54259,180, 54269, - .180, 54311,180, 54323,180, 54349,180, 54353,180, 54379, - .180, 54397,180, 54419,180, 54427,180, 54433,180, 54439, - .180, 54451,180, 54461,180, 54467,180, 54473,180, 54481, - .180, 54503,180, 54511,180, 54517,180, 54551,180, 54553, - .180, 54571,180, 54581,180, 54587,180, 54613,180, 54629, - .180, 54643,180, 54647,180, 54659,180, 54677,180, 54683, - .180, 54701,180, 54721,180, 54739,180, 54811,180, 54823, - .180, 54829,180, 54833,180, 54839,180, 54869,180, 54871, - .180, 54881,180, 54893,180, 54923,180, 54929,180, 54943, - .180, 54967,180, 54971,180, 55001,180, 55013,180, 55039, - .180, 55043,180, 55049,180, 55067,180, 55069,180, 55079, - .180, 55097,180, 55109,180, 55111,180, 55117,180, 55123, - .180, 55127,180, 55133,180, 55141,180, 55147,180, 55159, - .180, 55193,180, 55201,180, 55247,180, 55273,180, 55279, - .180, 55307,180, 55313,180, 55319,180, 55333,180, 55361, - .180, 55379,180, 55387,180, 55411,180, 55429,180, 55439, - .180, 55447,180, 55453,180, 55469,180, 55487,180, 55517, - .180, 55537,180, 55571,180, 55573,180, 55579,180, 55603, - .180, 55609,180, 55649,180, 55667,180, 55669,180, 55681, - .180, 55691,180, 55697,180, 55729,180, 55741,180, 55757, - .180, 55771,180, 55783,180, 55793,180, 55799,180, 55807, - .180, 55813,180, 55817,180, 55823,180, 55831,180, 55847, - .180, 55859,180, 55861,180, 55879,180, 55889,180, 55957, - .180, 55973,180, 55979,180, 55993,180, 56033,180, 56051, - .180, 56057,180, 56059,180, 56077,180, 56093,180, 56099, - .180, 56111,180, 56129,180, 56131,180, 56143,180, 56161, - .180, 56167,180, 56177,180, 56183,180, 56237,180, 56239, - .180, 56261,180, 56279,180, 56287,180, 56293,180, 56323, - .180, 56327,180, 56329,180, 56351,180, 56353,180, 56357, - .180, 56377,180, 56393,180, 56399,180, 56411,180, 56437, - .180, 56441,180, 56477,180, 56479,180, 56489,180, 56503, - .180, 56509,180, 56521,180, 56533,180, 56539,180, 56551, - .180, 56609,180, 56653,180, 56677,180, 56681,180, 56701, - .180, 56723,180, 56737,180, 56741,180, 56747,180, 56761, - .180, 56827,180, 56839,180, 56843,180, 56849,180, 56887, - .180, 56903,180, 56939,180, 56941,180, 56947,180, 56969, - .180, 56971,180, 56983,180, 57049,180, 57077,180, 57091, - .180, 57121,180, 57133,180, 57137,180, 57149,180, 57169, - .180, 57179,180, 57199,180, 57209,180, 57239,180, 57251, - .180, 57277,180, 57281,180, 57293,180, 57311,180, 57337, - .180, 57359,180, 57367,180, 57377,180, 57389,180, 57403, - .180, 57407,180, 57409,180, 57413,180, 57419,180, 57431, - .180, 57451,180, 57463,180, 57499,180, 57511,180, 57521, - .180, 57529,180, 57539,180, 57577,180, 57581,180, 57667, - .180, 57679,180, 57683,180, 57689,180, 57731,180, 57767, - .180, 57781,180, 57787,180, 57799,180, 57823,180, 57847, - .180, 57851,180, 57853,180, 57883,180, 57899,180, 57919, - .180, 57931,180, 57949,180, 57953,180, 57959,180, 57961, - .180, 57983,180, 57997,180, 58009,180, 58037,180, 58039, - .180, 58043,180, 58049,180, 58087,180, 58091,180, 58093, - .180, 58123,180, 58127,180, 58201,180, 58211,180, 58229, - .180, 58243,180, 58277,180, 58303,180, 58313,180, 58333, - .180, 58367,180, 58373,180, 58393,180, 58397,180, 58403, - .180, 58411,180, 58417,180, 58421,180, 58439,180, 58457, - .180, 58481,180, 58483,180, 58499,180, 58523,180, 58537, - .180, 58543,180, 58549,180, 58553,180, 58631,180, 58661, - .180, 58667,180, 58669,180, 58679,180, 58697,180, 58723, - .180, 58733,180, 58739,180, 58751,180, 58787,180, 58789, - .180, 58823,180, 58829,180, 58841,180, 58849,180, 58859, - .180, 58871,180, 58873,180, 58877,180, 58879,180, 58901, - .180, 58903,180, 58907,180, 58919,180, 58927,180, 58933, - .180, 59009,180, 59011,180, 59027,180, 59041,180, 59051/ - DATA ((n(i,j),i=3,4),j=490,979)/ - .180, 59069,180, 59071,180, 59087,180, 59101,180, 59107, - .180, 59113,180, 59153,180, 59173,180, 59183,180, 59207, - .180, 59209,180, 59219,180, 59233,180, 59251,180, 59257, - .180, 59263,180, 59267,180, 59279,180, 59293,180, 59321, - .180, 59327,180, 59333,180, 59347,180, 59359,180, 59389, - .180, 59401,180, 59423,180, 59431,180, 59453,180, 59479, - .180, 59509,180, 59513,180, 59519,180, 59521,180, 59543, - .180, 59569,180, 59591,180, 59621,180, 59627,180, 59633, - .180, 59659,180, 59671,180, 59681,180, 59699,180, 59713, - .180, 59719,180, 59743,180, 59759,180, 59783,180, 59789, - .180, 59801,180, 59807,180, 59827,180, 59831,180, 59849, - .180, 59863,180, 59879,180, 59891,180, 59893,180, 59929, - .180, 59939,180, 59981,180, 59989,180, 59993,180, 59999, - .180, 60031,180, 60037,180, 60061,180, 60067,180, 60073, - .180, 60103,180, 60149,180, 60161,180, 60173,180, 60179, - .180, 60193,180, 60217,180, 60229,180, 60247,180, 60251, - .180, 60283,180, 60329,180, 60331,180, 60341,180, 60361, - .180, 60377,180, 60397,180, 60403,180, 60419,180, 60439, - .180, 60467,180, 60473,180, 60499,180, 60523,180, 60553, - .180, 60557,180, 60559,180, 60569,180, 60581,180, 60587, - .180, 60593,180, 60601,180, 60611,180, 60613,180, 60619, - .180, 60643,180, 60647,180, 60667,180, 60671,180, 60713, - .180, 60737,180, 60749,180, 60763,180, 60769,180, 60787, - .180, 60797,180, 60811,180, 60823,180, 60829,180, 60847, - .180, 60851,180, 60853,180, 60881,180, 60887,180, 60889, - .180, 60913,180, 60919,180, 60929,180, 60941,180, 60943, - .180, 60971,180, 60973,180, 60977,180, 60997,180, 61001, - .180, 61013,180, 61019,180, 61039,180, 61043,180, 61049, - .180, 61063,180, 61081,180, 61109,180, 61111,180, 61133, - .180, 61141,180, 61181,180, 61187,180, 61213,180, 61217, - .180, 61229,180, 61231,180, 61271,180, 61273,180, 61279, - .180, 61283,180, 61297,180, 61307,180, 61313,180, 61321, - .180, 61337,180, 61339,180, 61351,180, 61357,180, 61393, - .180, 61397,180, 61403,180, 61409,180, 61427,180, 61433, - .180, 61451,180, 61489,180, 61511,180, 61519,180, 61529, - .180, 61537,180, 61543,180, 61549,180, 61559,180, 61571, - .180, 61577,180, 61579,180, 61621,180, 61631,180, 61651, - .180, 61669,180, 61679,180, 61697,180, 61711,180, 61721, - .180, 61747,180, 61763,180, 61787,180, 61789,180, 61799, - .180, 61801,180, 61811,180, 61831,180, 61843,180, 61879, - .180, 61897,180, 61901,180, 61907,180, 61943,180, 61963, - .180, 61967,180, 61999,180, 62053,180, 62063,180, 62071, - .180, 62077,180, 62089,180, 62093,180, 62099,180, 62117, - .180, 62119,180, 62149,180, 62177,180, 62179,180, 62203, - .180, 62221,180, 62239,180, 62243,180, 62249,180, 62267, - .180, 62299,180, 62303,180, 62321,180, 62327,180, 62333, - .180, 62359,180, 62371,180, 62413,180, 62417,180, 62441, - .180, 62467,180, 62473,180, 62489,180, 62491,180, 62509, - .180, 62537,180, 62551,180, 62569,180, 62581,180, 62593, - .180, 62597,180, 62599,180, 62603,180, 62621,180, 62629, - .180, 62657,180, 62659,180, 62671,180, 62677,180, 62683, - .180, 62687,180, 62699,180, 62707,180, 62749,180, 62753, - .180, 62761,180, 62767,180, 62789,180, 62813,180, 62827, - .180, 62831,180, 62869,180, 62879,180, 62891,180, 62897, - .180, 62903,180, 62947,180, 62953,180, 62971,180, 62977, - .180, 62981,180, 62993,180, 63001,180, 63007,180, 63013, - .180, 63023,180, 63029,180, 63059,180, 63061,180, 63083, - .180, 63089,180, 63091,180, 63103,180, 63119,180, 63131, - .180, 63163,180, 63227,180, 63233,180, 63239,180, 63259, - .180, 63271,180, 63311,180, 63337,180, 63341,180, 63353, - .180, 63367,180, 63373,180, 63397,180, 63409,180, 63413, - .180, 63421,180, 63427,180, 63437,180, 63443,180, 63449, - .180, 63481,180, 63499,180, 63509,180, 63517,180, 63541, - .180, 63551,180, 63559,180, 63569,180, 63601,180, 63607, - .180, 63617,180, 63623,180, 63629,180, 63637,180, 63653, - .180, 63671,180, 63691,180, 63727,180, 63743,180, 63751, - .180, 63763,180, 63787,180, 63821,180, 63827,180, 63847, - .180, 63899,180, 63917,180, 63931,180, 63989,180, 63997, - .180, 64003,180, 64007,180, 64009,180, 64013,180, 64037, - .180, 64067,180, 64087,180, 64093,180, 64133,180, 64139, - .180, 64147,180, 64157,180, 64163,180, 64169,180, 64181, - .180, 64189,180, 64207,180, 64211,180, 64217,180, 64219, - .180, 64223,180, 64247,180, 64261,180, 64273,180, 64297, - .180, 64307,180, 64309,180, 64331,180, 64357,180, 64379, - .180, 64387,180, 64409,180, 64417,180, 64483,180, 64489, - .180, 64493,180, 64513,180, 64531,180, 64553,180, 64591, - .180, 64601,180, 64609,180, 64613,180, 64619,180, 64627, - .180, 64651,180, 64661,180, 64679,180, 64687,180, 64711, - .180, 64717,180, 64727,180, 64739,180, 64741,180, 64751, - .180, 64757,180, 64793,180, 64813,180, 64819,180, 64823, - .180, 64847,180, 64871,180, 64877,180, 64883,180, 64891, - .180, 64921,180, 64927,180, 64931,180, 64933,180, 64949, - .180, 64961,180, 64987,180, 65047,180, 65059,180, 65063, - .180, 65077,180, 65089,180, 65093,180, 65099,180, 65101, - .180, 65119,180, 65131,180, 65137,180, 65147,180, 65159, - .180, 65171,180, 65179,180, 65191,180, 65203,180, 65207, - .180, 65213,180, 65221,180, 65231,180, 65233,180, 65269, - .180, 65311,180, 65323,180, 65339,180, 65347,180, 65369, - .180, 65393,180, 65399,180, 65407,180, 65431,180, 65437, - .180, 65441,180, 65443,180, 65473,180, 65479,180, 65507, - .180, 65527,180, 65533,181, 13,181, 15,181, 33, - .181, 61,181, 67,181, 141,181, 151,181, 183, - .181, 187,181, 201,181, 207,181, 213,181, 217, - .181, 223,181, 225,181, 243,181, 253,181, 255, - .181, 277,181, 291,181, 297,181, 301,181, 327, - .181, 337,181, 357,181, 375,181, 423,181, 453, - .181, 477,181, 511,181, 531,181, 547,181, 553, - .181, 561,181, 565,181, 595,181, 607,181, 645/ - DATA ((n(i,j),i=3,4),j=980,nmax)/ - .181, 657,181, 663,181, 685,181, 687,181, 697, - .181, 745,181, 775,181, 787,181, 823,181, 825, - .181, 841,181, 853,181, 865,181, 895,181, 903, - .181, 943,181, 963,181, 973,181, 981,181, 1005, - .181, 1015,181, 1021,181, 1023,181, 1041,181, 1051, - .181, 1057,181, 1083,181, 1093,181, 1105,181, 1107, - .181, 1117,181, 1135,181, 1137,181, 1155,181, 1167, - .181, 1191,181, 1197,181, 1221,181, 1233,181, 1237, - .181, 1243,181, 1263/ - end -#endif diff --git a/source/unres/src_MD-M-newcorr/proc_proc.c b/source/unres/src_MD-M-newcorr/proc_proc.c deleted file mode 100644 index f023520..0000000 --- a/source/unres/src_MD-M-newcorr/proc_proc.c +++ /dev/null @@ -1,140 +0,0 @@ -#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/unres/src_MD-M-newcorr/q_measure.F b/source/unres/src_MD-M-newcorr/q_measure.F deleted file mode 100644 index 8f12dc1..0000000 --- a/source/unres/src_MD-M-newcorr/q_measure.F +++ /dev/null @@ -1,491 +0,0 @@ - double precision function qwolynes(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - integer i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4, - & secseg - integer nsep /3/ - double precision dist,qm - double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM - logical lprn /.false./ - logical flag - double precision sigm,x - sigm(x)=0.25d0*x - do kkk=1,nperm - qq = 0.0d0 - nl=0 - if(flag) then - do il=seg1+nsep,seg2 - do jl=seg1,il-nsep - nl=nl+1 - d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ - & (cref(2,jl,kkk)-cref(2,il,kkk))**2+ - & (cref(3,jl,kkk)-cref(3,il,kkk))**2) - dij=dist(il,jl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ - & (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ - & (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) - dijCM=dist(il+nres,jl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - enddo - enddo - qq = qq/nl - else - do il=seg1,seg2 - if((seg3-il).lt.3) then - secseg=il+3 - else - secseg=seg3 - endif - do jl=secseg,seg4 - nl=nl+1 - d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ - & (cref(2,jl,kkk)-cref(2,il,kkk))**2+ - & (cref(3,jl,kkk)-cref(3,il,kkk))**2) - dij=dist(il,jl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ - & (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ - & (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) - dijCM=dist(il+nres,jl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - enddo - enddo - qq = qq/nl - endif - if (qqmax.le.qq) qqmax=qq - enddo - qwolynes=1.0d0-qqmax - return - end -c------------------------------------------------------------------- - subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.MD' - integer i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4, - & secseg - integer nsep /3/ - double precision dist - double precision dij,d0ij,dijCM,d0ijCM - logical lprn /.false./ - logical flag - double precision sigm,x,sim,dd0,fac,ddqij - sigm(x)=0.25d0*x - do kkk=1,nperm - do i=0,nres - do j=1,3 - dqwol(j,i)=0.0d0 - dxqwol(j,i)=0.0d0 - enddo - enddo - nl=0 - if(flag) then - do il=seg1+nsep,seg2 - do jl=seg1,il-nsep - nl=nl+1 - d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ - & (cref(2,jl,kkk)-cref(2,il,kkk))**2+ - & (cref(3,jl,kkk)-cref(3,il,kkk))**2) - dij=dist(il,jl) - sim = 1.0d0/sigm(d0ij) - sim = sim*sim - dd0 = dij-d0ij - fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim) - do k=1,3 - ddqij = (c(k,il)-c(k,jl))*fac - dqwol(k,il)=dqwol(k,il)+ddqij - dqwol(k,jl)=dqwol(k,jl)-ddqij - enddo - - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ - & (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ - & (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) - dijCM=dist(il+nres,jl+nres) - sim = 1.0d0/sigm(d0ijCM) - sim = sim*sim - dd0=dijCM-d0ijCM - fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim) - do k=1,3 - ddqij = (c(k,il+nres)-c(k,jl+nres))*fac - dxqwol(k,il)=dxqwol(k,il)+ddqij - dxqwol(k,jl)=dxqwol(k,jl)-ddqij - enddo - endif - enddo - enddo - else - do il=seg1,seg2 - if((seg3-il).lt.3) then - secseg=il+3 - else - secseg=seg3 - endif - do jl=secseg,seg4 - nl=nl+1 - d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ - & (cref(2,jl,kkk)-cref(2,il,kkk))**2+ - & (cref(3,jl,kkk)-cref(3,il,kkk))**2) - dij=dist(il,jl) - sim = 1.0d0/sigm(d0ij) - sim = sim*sim - dd0 = dij-d0ij - fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim) - do k=1,3 - ddqij = (c(k,il)-c(k,jl))*fac - dqwol(k,il)=dqwol(k,il)+ddqij - dqwol(k,jl)=dqwol(k,jl)-ddqij - enddo - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ - & (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ - & (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) - dijCM=dist(il+nres,jl+nres) - sim = 1.0d0/sigm(d0ijCM) - sim=sim*sim - dd0 = dijCM-d0ijCM - fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim) - do k=1,3 - ddqij = (c(k,il+nres)-c(k,jl+nres))*fac - dxqwol(k,il)=dxqwol(k,il)+ddqij - dxqwol(k,jl)=dxqwol(k,jl)-ddqij - enddo - endif - enddo - enddo - endif - enddo - do i=0,nres - do j=1,3 - dqwol(j,i)=dqwol(j,i)/nl - dxqwol(j,i)=dxqwol(j,i)/nl - enddo - enddo - return - end -c------------------------------------------------------------------- - subroutine qwol_num(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - integer seg1,seg2,seg3,seg4 - logical flag - double precision qwolan(3,0:maxres),cdummy(3,0:maxres2), - & qwolxan(3,0:maxres),q1,q2 - double precision delta /1.0d-10/ - do i=0,nres - do j=1,3 - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - cdummy(j,i)=c(j,i) - c(j,i)=c(j,i)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolan(j,i)=(q2-q1)/delta - c(j,i)=cdummy(j,i) - enddo - enddo - do i=0,nres - do j=1,3 - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - cdummy(j,i+nres)=c(j,i+nres) - c(j,i+nres)=c(j,i+nres)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolxan(j,i)=(q2-q1)/delta - c(j,i+nres)=cdummy(j,i+nres) - enddo - enddo -c write(iout,*) "Numerical Q carteisan gradients backbone: " -c do i=0,nct -c write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3) -c enddo -c write(iout,*) "Numerical Q carteisan gradients side-chain: " -c do i=0,nct -c write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3) -c enddo - return - end -c------------------------------------------------------------------------ - subroutine EconstrQ -c MD with umbrella_sampling using Wolyne's distance measure as a constraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision uzap1,uzap2,hm1,hm2,hmnum - double precision ucdelan,dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES), - & duconst(3,0:MAXRES),duxconst(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ - do i=0,nres - do j=1,3 - duconst(j,i)=0.0d0 - dudconst(j,i)=0.0d0 - duxconst(j,i)=0.0d0 - dudxconst(j,i)=0.0d0 - enddo - enddo - Uconst=0.0d0 - do i=1,nfrag - qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true. - & ,idummy,idummy) - Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset)) -c Calculating the derivatives of Constraint energy with respect to Q - Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i), - & qinfrag(i,iset)) -c hm1=harmonic(qfrag(i,iset),qinfrag(i,iset)) -c hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset)) -c hmnum=(hm2-hm1)/delta -c write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset), -c & qinfrag(i,iset)) -c write(iout,*) "harmonicnum frag", hmnum -c Calculating the derivatives of Q with respect to cartesian coordinates - call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true. - & ,idummy,idummy) -c write(iout,*) "dqwol " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3) -c enddo -c write(iout,*) "dxqwol " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) -c enddo -c Calculating numerical gradients of dU/dQi and dQi/dxi -c call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true. -c & ,idummy,idummy) -c The gradients of Uconst in Cs - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii) - enddo - enddo - enddo - do i=1,npair - kstart=ifrag(1,ipair(1,i,iset),iset) - kend=ifrag(2,ipair(1,i,iset),iset) - lstart=ifrag(1,ipair(2,i,iset),iset) - lend=ifrag(2,ipair(2,i,iset),iset) - qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend) - Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset)) -c Calculating dU/dQ - Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset)) -c hm1=harmonic(qpair(i),qinpair(i,iset)) -c hm2=harmonic(qpair(i)+delta,qinpair(i,iset)) -c hmnum=(hm2-hm1)/delta -c write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i), -c & qinpair(i,iset)) -c write(iout,*) "harmonicnum pair ", hmnum -c Calculating dQ/dXi - call qwolynes_prim(kstart,kend,.false. - & ,lstart,lend) -c write(iout,*) "dqwol " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3) -c enddo -c write(iout,*) "dxqwol " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) -c enddo -c Calculating numerical gradients -c call qwol_num(kstart,kend,.false. -c & ,lstart,lend) -c The gradients of Uconst in Cs - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii) - enddo - enddo - enddo -c write(iout,*) "Uconst inside subroutine ", Uconst -c Transforming the gradients from Cs to dCs for the backbone - do i=0,nres - do j=i+1,nres - do k=1,3 - dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j) - enddo - enddo - enddo -c Transforming the gradients from Cs to dCs for the side chains - do i=1,nres - do j=1,3 - dudxconst(j,i)=duxconst(j,i) - enddo - enddo -c write(iout,*) "dU/ddc backbone " -c do ii=0,nres -c write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/ddX side chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) -c enddo -c Calculating numerical gradients of dUconst/ddc and dUconst/ddx -c call dEconstrQ_num - return - end -c----------------------------------------------------------------------- - subroutine dEconstrQ_num -c Calculating numerical dUconst/ddc and dUconst/ddx - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision uzap1,uzap2 - double precision dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ -c For the backbone - do i=0,nres-1 - do j=1,3 - dUcartan(j,i)=0.0d0 - cdummy(j,i)=dc(j,i) - dc(j,i)=dc(j,i)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true. - & ,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii), - & qinpair(ii,iset)) - enddo - dc(j,i)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true. - & ,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii), - & qinpair(ii,iset)) - enddo - ducartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo -c Calculating numerical gradients for dU/ddx - do i=0,nres-1 - duxcartan(j,i)=0.0d0 - do j=1,3 - cdummy(j,i)=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true. - & ,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii), - & qinpair(ii,iset)) - enddo - dc(j,i+nres)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset), - & ifrag(2,ii,iset),.true.,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii), - & qinpair(ii,iset)) - enddo - duxcartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo - write(iout,*) "Numerical dUconst/ddc backbone " - do ii=0,nres - write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) - enddo -c write(iout,*) "Numerical dUconst/ddx side-chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) -c enddo - return - end -c--------------------------------------------------------------------------- diff --git a/source/unres/src_MD-M-newcorr/q_measure1.F b/source/unres/src_MD-M-newcorr/q_measure1.F deleted file mode 100644 index 9c1546d..0000000 --- a/source/unres/src_MD-M-newcorr/q_measure1.F +++ /dev/null @@ -1,470 +0,0 @@ - double precision function qwolynes(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.MD' - integer i,j,jl,k,l,il,kl,nl,np,seg1,seg2,seg3,seg4,secseg - integer nsep /3/ - double precision dist,qm - double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM - logical lprn /.false./ - logical flag - qq = 0.0d0 - nl=0 - do i=0,nres - do j=1,3 - dqwol(j,i)=0.0d0 - dxqwol(j,i)=0.0d0 - enddo - enddo - if (lprn) then - write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4, - & " flag",flag - call flush(iout) - endif - if (flag) then - do il=seg1+nsep,seg2 - do jl=seg1,il-nsep - nl=nl+1 - if (itype(il).ne.10) then - ilnres=il+nres - else - ilnres=il - endif - if (itype(jl).ne.10) then - jlnres=jl+nres - else - jlnres=jl - endif - qqijCM = qcontrib(il,jl,ilnres,jlnres) - qq = qq+qqijCM - if (lprn) then - write (iout,*) "qqijCM",qqijCM - call flush(iout) - endif - enddo - enddo - if (lprn) then - write (iout,*) "nl",nl," qq",qq - call flush(iout) - endif - else - do il=seg1,seg2 - if((seg3-il).lt.3) then - secseg=il+3 - else - secseg=seg3 - endif - do jl=secseg,seg4 - nl=nl+1 - if (itype(il).ne.10) then - ilnres=il+nres - else - ilnres=il - endif - if (itype(jl).ne.10) then - jlnres=jl+nres - else - jlnres=jl - endif - qqijCM = qcontrib(il,jl,ilnres,jlnres) - qq = qq+qqijCM - if (lprn) then - write (iout,*) "qqijCM",qqijCM - call flush(iout) - endif - enddo - enddo - endif - qq = qq/nl - qwolynes=1.0d0-qq - do i=0,nres - do j=1,3 - dqwol(j,i)=dqwol(j,i)/nl - dxqwol(j,i)=dxqwol(j,i)/nl - enddo - enddo - return - end -c------------------------------------------------------------------- - subroutine qwol_num(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.MD' - integer seg1,seg2,seg3,seg4 - logical flag - double precision qwolan(3,0:maxres),cdummy(3,0:maxres2), - & qwolxan(3,0:maxres),q1,q2 - double precision delta /1.0d-7/ - write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4 - write(iout,*) "dQ/dc backbone " - do i=0,nres - write(iout,'(i5,3e15.5)') i, (dqwol(j,i),j=1,3) - enddo - write(iout,*) "dQ/dX side chain " - do i=1,nres - write(iout,'(i5,3e15.5)') i,(dxqwol(j,i),j=1,3) - enddo - do i=1,nres - do j=1,3 - cdummy(j,i)=c(j,i) - c(j,i)=c(j,i)-delta - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - c(j,i)=cdummy(j,i)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolan(j,i)=0.5d0*(q2-q1)/delta - c(j,i)=cdummy(j,i) -c write (iout,*) "i",i," j",j," q1",q1," a2",q2 - enddo - enddo - do i=1,nres - do j=1,3 - cdummy(j,i+nres)=c(j,i+nres) - c(j,i+nres)=c(j,i+nres)-delta - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - c(j,i+nres)=cdummy(j,i+nres)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolxan(j,i)=0.5d0*(q2-q1)/delta - c(j,i+nres)=cdummy(j,i+nres) - enddo - enddo - write(iout,*) "Numerical Q cartesian gradients backbone: " - do i=0,nres - write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3) - enddo - write(iout,*) "Numerical Q cartesian gradients side-chain: " - do i=0,nres - write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3) - enddo - return - end -c------------------------------------------------------------------------ - subroutine EconstrQ -c MD with umbrella_sampling using Wolyne's distance measure as a constraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision uzap1,uzap2,hm1,hm2,hmnum - double precision ucdelan,dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES), - & duconst(3,0:MAXRES),duxconst(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ - do i=0,nres - do j=1,3 - duconst(j,i)=0.0d0 - dudconst(j,i)=0.0d0 - duxconst(j,i)=0.0d0 - dudxconst(j,i)=0.0d0 - enddo - enddo - Uconst=0.0d0 - do i=1,nfrag - qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true. - & ,idummy,idummy) - Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset)) -c Calculating the derivatives of Constraint energy with respect to Q - Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),qinfrag(i,iset)) -c Calculating the derivatives of Q with respect to cartesian coordinates - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii) - enddo - enddo -c write (iout,*) "Calling qwol_num" -c call qwol_num(ifrag(1,i),ifrag(2,i),.true.,idummy,idummy) - enddo - do i=1,npair - kstart=ifrag(1,ipair(1,i,iset),iset) - kend=ifrag(2,ipair(1,i,iset),iset) - lstart=ifrag(1,ipair(2,i,iset),iset) - lend=ifrag(2,ipair(2,i,iset),iset) - qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend) - Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset)) -c Calculating dU/dQ - Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset)) -c Calculating dQ/dXi - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii) - enddo - enddo - enddo -c write(iout,*) "Uconst inside subroutine ", Uconst -c Transforming the gradients from Cs to dCs for the backbone - do i=0,nres - do j=i+1,nres - do k=1,3 - dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j) - enddo - enddo - enddo -c Transforming the gradients from Cs to dCs for the side chains - do i=1,nres - do j=1,3 - dudxconst(j,i)=duxconst(j,i) - enddo - enddo -c write(iout,*) "dU/dc backbone " -c do ii=0,nres -c write(iout,'(i5,3e15.5)') ii, (duconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/dX side chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/ddc backbone " -c do ii=0,nres -c write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/ddX side chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dudxconst(j,ii),j=1,3) -c enddo -c Calculating numerical gradients of dUconst/ddc and dUconst/ddx -c call dEconstrQ_num - return - end -c----------------------------------------------------------------------- - subroutine dEconstrQ_num -c Calculating numerical dUconst/ddc and dUconst/ddx - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision uzap1,uzap2 - double precision dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ -c For the backbone - do i=0,nres-1 - do j=1,3 - dUcartan(j,i)=0.0d0 - cdummy(j,i)=dc(j,i) - dc(j,i)=dc(j,i)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - dc(j,i)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - ducartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo -c Calculating numerical gradients for dU/ddx - do i=0,nres-1 - do j=1,3 - duxcartan(j,i)=0.0d0 - enddo - do j=1,3 - cdummy(j,i)=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - dc(j,i+nres)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - duxcartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo - write(iout,*) "Numerical dUconst/ddc backbone " - do ii=0,nres - write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) - enddo - write(iout,*) "Numerical dUconst/ddx side-chain " - do ii=1,nres - write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) - enddo - return - end -c--------------------------------------------------------------------------- - double precision function qcontrib(il,jl,il1,jl1) - implicit none - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.MD' - integer i,j,k,il,jl,il1,jl1,nd - double precision dist - external dist - double precision dij1,dij2,dij3,dij4,d0ij1,d0ij2,d0ij3,d0ij4,fac, - & fac1,ddave,ssij,ddqij - logical lprn /.false./ - d0ij1=dsqrt((cref(1,jl)-cref(1,il))**2+ - & (cref(2,jl)-cref(2,il))**2+ - & (cref(3,jl)-cref(3,il))**2) - dij1=dist(il,jl) - ddave=(dij1-d0ij1)**2 - nd=1 - if (jl1.ne.jl) then - d0ij2=dsqrt((cref(1,jl1)-cref(1,il))**2+ - & (cref(2,jl1)-cref(2,il))**2+ - & (cref(3,jl1)-cref(3,il))**2) - dij2=dist(il,jl1) - ddave=ddave+(dij2-d0ij2)**2 - nd=nd+1 - endif - if (il1.ne.il) then - d0ij3=dsqrt((cref(1,jl)-cref(1,il1))**2+ - & (cref(2,jl)-cref(2,il1))**2+ - & (cref(3,jl)-cref(3,il1))**2) - dij3=dist(il1,jl) - ddave=ddave+(dij3-d0ij3)**2 - nd=nd+1 - endif - if (il1.ne.il .and. jl1.ne.jl) then - d0ij4=dsqrt((cref(1,jl1)-cref(1,il1))**2+ - & (cref(2,jl1)-cref(2,il1))**2+ - & (cref(3,jl1)-cref(3,il1))**2) - dij4=dist(il1,jl1) - ddave=ddave+(dij4-d0ij4)**2 - nd=nd+1 - endif - ddave=ddave/nd - if (lprn) then - write (iout,*) "il",il," jl",jl, - & " itype",itype(il),itype(jl)," nd",nd - write (iout,*)"d0ij",d0ij1,d0ij2,d0ij3,d0ij4, - & " dij",dij1,dij2,dij3,dij4," ddave",ddave - call flush(iout) - endif -c ssij = (0.25d0*d0ij1)**2 - if (il.ne.il1 .and. jl.ne.jl1) then - ssij = 16.0d0/(d0ij1*d0ij4) - else - ssij = 16.0d0/(d0ij1*d0ij1) - endif - qcontrib = dexp(-0.5d0*ddave*ssij) -c Compute gradient - fac1 = qcontrib*ssij/nd - fac = fac1*(dij1-d0ij1)/dij1 - do k=1,3 - ddqij = (c(k,il)-c(k,jl))*fac - dqwol(k,il)=dqwol(k,il)+ddqij - dqwol(k,jl)=dqwol(k,jl)-ddqij - enddo - if (jl1.ne.jl) then - fac = fac1*(dij2-d0ij2)/dij2 - do k=1,3 - ddqij = (c(k,il)-c(k,jl1))*fac - dqwol(k,il)=dqwol(k,il)+ddqij - dxqwol(k,jl)=dxqwol(k,jl)-ddqij - enddo - endif - if (il1.ne.il) then - fac = fac1*(dij3-d0ij3)/dij3 - do k=1,3 - ddqij = (c(k,il1)-c(k,jl))*fac - dxqwol(k,il)=dxqwol(k,il)+ddqij - dqwol(k,jl)=dqwol(k,jl)-ddqij - enddo - endif - if (il1.ne.il .and. jl1.ne.jl) then - fac = fac1*(dij4-d0ij4)/dij4 - do k=1,3 - ddqij = (c(k,il1)-c(k,jl1))*fac - dxqwol(k,il)=dxqwol(k,il)+ddqij - dxqwol(k,jl)=dxqwol(k,jl)-ddqij - enddo - endif - return - end diff --git a/source/unres/src_MD-M-newcorr/q_measure3.F b/source/unres/src_MD-M-newcorr/q_measure3.F deleted file mode 100644 index f0a030e..0000000 --- a/source/unres/src_MD-M-newcorr/q_measure3.F +++ /dev/null @@ -1,529 +0,0 @@ - double precision function qwolynes(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.MD' - integer i,j,jl,k,l,il,kl,nl,np,seg1,seg2,seg3,seg4,secseg - integer nsep /3/ - double precision dist,qm - double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM - logical lprn /.false./ - logical flag - qq = 0.0d0 - nl=0 - do i=0,nres - do j=1,3 - dqwol(j,i)=0.0d0 - dxqwol(j,i)=0.0d0 - enddo - enddo - if (lprn) then - write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4, - & " flag",flag - call flush(iout) - endif - if (flag) then - do il=seg1+nsep,seg2 - do jl=seg1,il-nsep - nl=nl+1 - if (itype(il).ne.10) then - ilnres=il+nres - else - ilnres=il - endif - if (itype(jl).ne.10) then - jlnres=jl+nres - else - jlnres=jl - endif - qqijCM = qcontrib(il,jl,ilnres,jlnres) - qq = qq+qqijCM - if (lprn) then - write (iout,*) "qqijCM",qqijCM - call flush(iout) - endif - enddo - enddo - if (lprn) then - write (iout,*) "nl",nl," qq",qq - call flush(iout) - endif - else - do il=seg1,seg2 - if((seg3-il).lt.3) then - secseg=il+3 - else - secseg=seg3 - endif - do jl=secseg,seg4 - nl=nl+1 - if (itype(il).ne.10) then - ilnres=il+nres - else - ilnres=il - endif - if (itype(jl).ne.10) then - jlnres=jl+nres - else - jlnres=jl - endif - qqijCM = qcontrib(il,jl,ilnres,jlnres) - qq = qq+qqijCM - if (lprn) then - write (iout,*) "qqijCM",qqijCM - call flush(iout) - endif - enddo - enddo - endif - qq = qq/nl - qwolynes=1.0d0-qq - do i=0,nres - do j=1,3 - dqwol(j,i)=dqwol(j,i)/nl - dxqwol(j,i)=dxqwol(j,i)/nl - enddo - enddo - return - end -c------------------------------------------------------------------- - subroutine qwol_num(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.MD' - integer seg1,seg2,seg3,seg4 - logical flag - double precision qwolan(3,0:maxres),cdummy(3,0:maxres2), - & qwolxan(3,0:maxres),q1,q2 - double precision delta /1.0d-7/ - write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4 - write(iout,*) "dQ/dc backbone " - do i=0,nres - write(iout,'(i5,3e15.5)') i, (dqwol(j,i),j=1,3) - enddo - write(iout,*) "dQ/dX side chain " - do i=1,nres - write(iout,'(i5,3e15.5)') i,(dxqwol(j,i),j=1,3) - enddo - do i=1,nres - do j=1,3 - cdummy(j,i)=c(j,i) - c(j,i)=c(j,i)-delta - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - c(j,i)=cdummy(j,i)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolan(j,i)=0.5d0*(q2-q1)/delta - c(j,i)=cdummy(j,i) -c write (iout,*) "i",i," j",j," q1",q1," a2",q2 - enddo - enddo - do i=1,nres - do j=1,3 - cdummy(j,i+nres)=c(j,i+nres) - c(j,i+nres)=c(j,i+nres)-delta - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - c(j,i+nres)=cdummy(j,i+nres)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolxan(j,i)=0.5d0*(q2-q1)/delta - c(j,i+nres)=cdummy(j,i+nres) - enddo - enddo - write(iout,*) "Numerical Q cartesian gradients backbone: " - do i=0,nres - write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3) - enddo - write(iout,*) "Numerical Q cartesian gradients side-chain: " - do i=0,nres - write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3) - enddo - return - end -c------------------------------------------------------------------------ - subroutine EconstrQ -c MD with umbrella_sampling using Wolyne's distance measure as a constraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision uzap1,uzap2,hm1,hm2,hmnum - double precision ucdelan,dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES), - & duconst(3,0:MAXRES),duxconst(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ - do i=0,nres - do j=1,3 - duconst(j,i)=0.0d0 - dudconst(j,i)=0.0d0 - duxconst(j,i)=0.0d0 - dudxconst(j,i)=0.0d0 - enddo - enddo - Uconst=0.0d0 - do i=1,nfrag - qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true. - & ,idummy,idummy) - Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset)) -c Calculating the derivatives of Constraint energy with respect to Q - Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),qinfrag(i,iset)) -c Calculating the derivatives of Q with respect to cartesian coordinates - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii) - enddo - enddo -c write (iout,*) "Calling qwol_num" -c call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.,idummy,idummy) - enddo -c stop - do i=1,npair - kstart=ifrag(1,ipair(1,i,iset),iset) - kend=ifrag(2,ipair(1,i,iset),iset) - lstart=ifrag(1,ipair(2,i,iset),iset) - lend=ifrag(2,ipair(2,i,iset),iset) - qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend) - Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset)) -c Calculating dU/dQ - Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset)) -c Calculating dQ/dXi - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii) - enddo - enddo - enddo -c write(iout,*) "Uconst inside subroutine ", Uconst -c Transforming the gradients from Cs to dCs for the backbone - do i=0,nres - do j=i+1,nres - do k=1,3 - dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j) - enddo - enddo - enddo -c Transforming the gradients from Cs to dCs for the side chains - do i=1,nres - do j=1,3 - dudxconst(j,i)=duxconst(j,i) - enddo - enddo -c write(iout,*) "dU/dc backbone " -c do ii=0,nres -c write(iout,'(i5,3e15.5)') ii, (duconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/dX side chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/ddc backbone " -c do ii=0,nres -c write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/ddX side chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dudxconst(j,ii),j=1,3) -c enddo -c Calculating numerical gradients of dUconst/ddc and dUconst/ddx -c call dEconstrQ_num - return - end -c----------------------------------------------------------------------- - subroutine dEconstrQ_num -c Calculating numerical dUconst/ddc and dUconst/ddx - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision uzap1,uzap2 - double precision dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ -c For the backbone - do i=0,nres-1 - do j=1,3 - dUcartan(j,i)=0.0d0 - cdummy(j,i)=dc(j,i) - dc(j,i)=dc(j,i)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - dc(j,i)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - ducartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo -c Calculating numerical gradients for dU/ddx - do i=0,nres-1 - do j=1,3 - duxcartan(j,i)=0.0d0 - enddo - do j=1,3 - cdummy(j,i)=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - dc(j,i+nres)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - duxcartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo - write(iout,*) "Numerical dUconst/ddc backbone " - do ii=0,nres - write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) - enddo - write(iout,*) "Numerical dUconst/ddx side-chain " - do ii=1,nres - write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) - enddo - return - end -c--------------------------------------------------------------------------- - double precision function qcontrib(il,jl,il1,jl1) - implicit none - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.LOCAL' - integer i,j,k,il,jl,il1,jl1,nd,itl,jtl - double precision dist - external dist - double precision dij,dij1,d0ij,d0ij1,om1,om2,om12,om10,om20,om120 - & ,fac,fac1,ddave,ssij,ddqij,d0ii1,d0jj1,rij,eom1,eom2,eom12 - double precision u(3),v(3),er(3),er0(3),dcosom1(3),dcosom2(3), - & aux1,aux2 - double precision scalar - external scalar - logical lprn /.false./ - if (lprn) write (iout,*) "il",il," jl",jl," il1",il1," jl1",jl1 - d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ - & (cref(2,jl)-cref(2,il))**2+ - & (cref(3,jl)-cref(3,il))**2) - dij=dist(il,jl) - dij1=dist(il1,jl1) - do i=1,3 - er(i)=(c(i,jl1)-c(i,il1))/dij1 - enddo - do i=1,3 - er0(i)=cref(i,jl1)-cref(i,il1) - enddo - d0ij1=dsqrt(scalar(er0,er0)) - do i=1,3 - er0(i)=er0(i)/d0ij1 - enddo - if (il.ne.il1 .or. jl.ne.jl1) then - ddave=0.5d0*((dij-d0ij)**2+(dij1-d0ij1)**2) - nd=2 - else - ddave=(dij-d0ij)**2 - nd=1 - endif - if (il.ne.il1) then - do i=1,3 - u(i)=cref(i,il1)-cref(i,il) - enddo - d0ii1=dsqrt(scalar(u,u)) - do i=1,3 - u(i)=u(i)/d0ii1 - enddo - if (lprn) then - write (iout,*) "u",(u(i),i=1,3) - write (iout,*) "er0",(er0(i),i=1,3) - om10=scalar(er0,u) - om1=scalar(er,dc_norm(1,il1)) - write (iout,*) "om10",om10," om1",om1 - endif - else - om1=0.0d0 - om10=0.0d0 - endif - if (jl.ne.jl1) then - do i=1,3 - v(i)=cref(i,jl1)-cref(i,jl) - enddo - d0jj1=dsqrt(scalar(v,v)) - do i=1,3 - v(i)=v(i)/d0jj1 - enddo - if (lprn) then - write (iout,*) "v",(v(i),i=1,3) - write (iout,*) "er0",(er0(i),i=1,3) - om20=scalar(er,v) - om2=scalar(er,dc_norm(1,jl1)) - write (iout,*) "om20",om20," om2",om2 - endif - else - om2=0.0d0 - om20=0.0d0 - endif - if (il.ne.il1 .and. jl.ne.jl1) then - om120=scalar(u,v) - om12=scalar(dc_norm(1,il1),dc_norm(1,jl1)) - else - om12=0.0d0 - om120=0.0d0 - endif - if (lprn) then - write (iout,*) "il",il," jl",jl,itype(il),itype(jl) - write (iout,*)"d0ij",d0ij," om10",om10," om20",om20, - & " om120",om120, - & " dij",dij," om1",om1," om2",om2," om12",om12 - call flush(iout) - endif - ssij = 16.0d0/(d0ij*d0ij) - qcontrib = dexp(-0.5d0*(ddave*ssij+((om1-om10)**2 - & +(om2-om20)**2+(om12-om120)**2))) - if (lprn) write (iout,*) "ssij",ssij," qcontrib",qcontrib -c qcontrib = dexp(-0.5d0*(ddave*ssij)+(om1-om10)**2+(om2-om20)**2) -c qcontrib = dexp(-0.5d0*(ddave*ssij)) -c Compute gradient - radial component - fac1 = qcontrib*ssij/nd - fac = fac1*(dij-d0ij)/dij - do k=1,3 - ddqij = (c(k,il)-c(k,jl))*fac - dqwol(k,il)=dqwol(k,il)+ddqij - dqwol(k,jl)=dqwol(k,jl)-ddqij - enddo - if (il1.ne.il .or. jl1.ne.jl) then - fac = fac1*(dij1-d0ij1)/dij1 - do k=1,3 - ddqij = (c(k,il1)-c(k,jl1))*fac - if (il1.ne.il) then - dxqwol(k,il)=dxqwol(k,il)+ddqij - else - dqwol(k,il)=dqwol(k,il)+ddqij - endif - if (jl1.ne.jl) then - dxqwol(k,jl)=dxqwol(k,jl)-ddqij - else - dqwol(k,jl)=dqwol(k,jl)-ddqij - endif - enddo - endif -c return -c Orientational contributions - rij=1.0d0/dij1 - eom1=qcontrib*(om1-om10) - eom2=qcontrib*(om2-om20) - eom12=qcontrib*(om12-om120) - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,il1)-om1*er(k)) - dcosom2(k)=rij*(dc_norm(k,jl1)-om2*er(k)) - enddo - do k=1,3 - ddqij=eom1*dcosom1(k)+eom2*dcosom2(k) - aux1=(eom12*(dc_norm(k,jl1)-om12*dc_norm(k,il1)) - & +eom1*(er(k)-om1*dc_norm(k,il1)))*vbld_inv(il1) - aux2=(eom12*(dc_norm(k,il1)-om12*dc_norm(k,jl1)) - & +eom2*(er(k)-om2*dc_norm(k,jl1)))*vbld_inv(jl1) - dqwol(k,il)=dqwol(k,il)-ddqij-aux1 - dqwol(k,jl)=dqwol(k,jl)+ddqij-aux2 - dxqwol(k,il)=dxqwol(k,il)-ddqij+aux1 -c & +(eom12*(dc_norm(k,jl1)-om12*dc_norm(k,il1)) -c & +eom1*(er(k)-om1*dc_norm(k,il1)))*vbld_inv(il1) - dxqwol(k,jl)=dxqwol(k,jl)+ddqij+aux2 -c & +(eom12*(dc_norm(k,il1)-om12*dc_norm(k,jl1)) -c & +eom2*(er(k)-om2*dc_norm(k,jl1)))*vbld_inv(jl1) - enddo - return - end diff --git a/source/unres/src_MD-M-newcorr/ran.f b/source/unres/src_MD-M-newcorr/ran.f deleted file mode 100644 index dd23252..0000000 --- a/source/unres/src_MD-M-newcorr/ran.f +++ /dev/null @@ -1,128 +0,0 @@ -ccccccccccccccccccccccccccccccccccccccccccccccccc - FUNCTION ran0(idum) - INTEGER idum,IA,IM,IQ,IR,MASK - REAL ran0,AM - PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, - *MASK=123459876) - INTEGER k - idum=ieor(idum,MASK) - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if (idum.lt.0) idum=idum+IM - ran0=AM*idum - idum=ieor(idum,MASK) - return - END -C (C) Copr. 1986-92 Numerical Recipes Software *11915 -ccccccccccccccccccccccccccccccccccccccccccccccccc - FUNCTION ran1(idum) - INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV - REAL ran1,AM,EPS,RNMX - PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, - *NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS) - INTEGER j,k,iv(NTAB),iy - SAVE iv,iy - DATA iv /NTAB*0/, iy /0/ - if (idum.le.0.or.iy.eq.0) then - idum=max(-idum,1) - do 11 j=NTAB+8,1,-1 - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if (idum.lt.0) idum=idum+IM - if (j.le.NTAB) iv(j)=idum -11 continue - iy=iv(1) - endif - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if (idum.lt.0) idum=idum+IM - j=1+iy/NDIV - iy=iv(j) - iv(j)=idum - ran1=min(AM*iy,RNMX) - return - END -C (C) Copr. 1986-92 Numerical Recipes Software *11915 -ccccccccccccccccccccccccccccccccccccccccccccccccc - FUNCTION ran2(idum) - INTEGER idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV - REAL ran2,AM,EPS,RNMX - PARAMETER (IM1=2147483563,IM2=2147483399,AM=1./IM1,IMM1=IM1-1, - *IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791, - *NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2e-7,RNMX=1.-EPS) - INTEGER idum2,j,k,iv(NTAB),iy - SAVE iv,iy,idum2 - DATA idum2/123456789/, iv/NTAB*0/, iy/0/ - if (idum.le.0) then - idum=max(-idum,1) - idum2=idum - do 11 j=NTAB+8,1,-1 - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if (idum.lt.0) idum=idum+IM1 - if (j.le.NTAB) iv(j)=idum -11 continue - iy=iv(1) - endif - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if (idum.lt.0) idum=idum+IM1 - k=idum2/IQ2 - idum2=IA2*(idum2-k*IQ2)-k*IR2 - if (idum2.lt.0) idum2=idum2+IM2 - j=1+iy/NDIV - iy=iv(j)-idum2 - iv(j)=idum - if(iy.lt.1)iy=iy+IMM1 - ran2=min(AM*iy,RNMX) - return - END -C (C) Copr. 1986-92 Numerical Recipes Software *11915 -ccccccccccccccccccccccccccccccccccccccccccccccccc - FUNCTION ran3(idum) - INTEGER idum - INTEGER MBIG,MSEED,MZ -C REAL MBIG,MSEED,MZ - REAL ran3,FAC - PARAMETER (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1./MBIG) -C PARAMETER (MBIG=4000000.,MSEED=1618033.,MZ=0.,FAC=1./MBIG) - INTEGER i,iff,ii,inext,inextp,k - INTEGER mj,mk,ma(55) -C REAL mj,mk,ma(55) - SAVE iff,inext,inextp,ma - DATA iff /0/ - if(idum.lt.0.or.iff.eq.0)then - iff=1 - mj=MSEED-iabs(idum) - mj=mod(mj,MBIG) - ma(55)=mj - mk=1 - do 11 i=1,54 - ii=mod(21*i,55) - ma(ii)=mk - mk=mj-mk - if(mk.lt.MZ)mk=mk+MBIG - mj=ma(ii) -11 continue - do 13 k=1,4 - do 12 i=1,55 - ma(i)=ma(i)-ma(1+mod(i+30,55)) - if(ma(i).lt.MZ)ma(i)=ma(i)+MBIG -12 continue -13 continue - inext=0 - inextp=31 - idum=1 - endif - inext=inext+1 - if(inext.eq.56)inext=1 - inextp=inextp+1 - if(inextp.eq.56)inextp=1 - mj=ma(inext)-ma(inextp) - if(mj.lt.MZ)mj=mj+MBIG - ma(inext)=mj - ran3=mj*FAC - return - END -C (C) Copr. 1986-92 Numerical Recipes Software *11915 -ccccccccccccccccccccccccccccccccccccccccccccccccc diff --git a/source/unres/src_MD-M-newcorr/randgens.f b/source/unres/src_MD-M-newcorr/randgens.f deleted file mode 100644 index 0daeb35..0000000 --- a/source/unres/src_MD-M-newcorr/randgens.f +++ /dev/null @@ -1,99 +0,0 @@ -C $Date: 1994/10/04 16:19:52 $ -C $Revision: 2.1 $ -C -C -C See help for RANDOMV on the PSFSHARE disk to understand these -C subroutines. This is the VS Fortran version of this code. -C -C - SUBROUTINE VRND(VEC,N) - INTEGER A(250) - COMMON /VRANDD/ A, I, I147 - INTEGER LOOP,I,I147,VEC(N) - DO 23000 LOOP=1,N - I=I+1 - IF(.NOT.(I.GE.251))GOTO 23002 - I=1 -23002 CONTINUE - I147=I147+1 - IF(.NOT.(I147.GE.251))GOTO 23004 - I147=1 -23004 CONTINUE - A(I)=IEOR(A(I147),A(I)) - VEC(LOOP)=A(I) -23000 CONTINUE - RETURN - END -C -C - DOUBLE PRECISION FUNCTION RNDV(IDUM) - DOUBLE PRECISION RM1,RM2,R(99) - INTEGER IA1,IC1,M1, IA2,IC2,M2, IA3,IC3,M3, IDUM - SAVE - DATA IA1,IC1,M1/1279,351762,1664557/ - DATA IA2,IC2,M2/2011,221592,1048583/ - DATA IA3,IC3,M3/15551,6150,29101/ - IF(.NOT.(IDUM.LT.0))GOTO 23006 - IX1 = MOD(-IDUM,M1) - IX1 = MOD(IA1*IX1+IC1,M1) - IX2 = MOD(IX1,M2) - IX1 = MOD(IA1*IX1+IC1,M1) - IX3 = MOD(IX1,M3) - RM1 = 1./DBLE(M1) - RM2 = 1./DBLE(M2) - DO 23008 J = 1,99 - IX1 = MOD(IA1*IX1+IC1,M1) - IX2 = MOD(IA2*IX2+IC2,M2) - R(J) = (DBLE(IX1)+DBLE(IX2)*RM2)*RM1 -23008 CONTINUE -23006 CONTINUE - IX1 = MOD(IA1*IX1+IC1,M1) - IX2 = MOD(IA2*IX2+IC2,M2) - IX3 = MOD(IA3*IX3+IC3,M3) - J = 1+(99*IX3)/M3 - RNDV = R(J) - R(J) = (DBLE(IX1)+DBLE(IX2)*RM2)*RM1 - IDUM = IX1 - RETURN - END -C -C - SUBROUTINE VRNDST(SEED) - INTEGER A(250),LOOP,IDUM,SEED - DOUBLE PRECISION RNDV - COMMON /VRANDD/ A, I, I147 - I=0 - I147=103 - IDUM=SEED - DO 23010 LOOP=1,250 - A(LOOP)=INT(RNDV(IDUM)*2147483647) -23010 CONTINUE - RETURN - END -C -C - SUBROUTINE VRNDIN(IODEV) - INTEGER IODEV, A(250) - COMMON/VRANDD/ A, I, I147 - READ(IODEV) A, I, I147 - RETURN - END -C -C - SUBROUTINE VRNDOU(IODEV) -C This corresponds to VRNDOUT in the APFTN64 version - INTEGER IODEV, A(250) - COMMON/VRANDD/ A, I, I147 - WRITE(IODEV) A, I, I147 - RETURN - END - FUNCTION RNUNF(N) - INTEGER IRAN1(2000) - DATA FCTOR /2147483647.0D0/ -C We get only one random number, here! DR 9/1/92 - CALL VRND(IRAN1,1) - RNUNF= DBLE( IRAN1(1) ) / FCTOR -C****************************** -C write(6,*) 'rnunf in rnunf = ',rnunf - RETURN - END diff --git a/source/unres/src_MD-M-newcorr/random_multi_chain/cont.unr b/source/unres/src_MD-M-newcorr/random_multi_chain/cont.unr deleted file mode 100644 index 7a854fb..0000000 --- a/source/unres/src_MD-M-newcorr/random_multi_chain/cont.unr +++ /dev/null @@ -1,2 +0,0 @@ -42 1 1 - end of reading diff --git a/source/unres/src_MD-M-newcorr/random_multi_chain/ext_mono.pdb b/source/unres/src_MD-M-newcorr/random_multi_chain/ext_mono.pdb deleted file mode 100644 index 62bf112..0000000 --- a/source/unres/src_MD-M-newcorr/random_multi_chain/ext_mono.pdb +++ /dev/null @@ -1,42 +0,0 @@ -ATOM 1 CA TYR 1 8.382 -13.657 -9.928 -ATOM 2 CB TYR 1 168.670-166.145 -5.869 -ATOM 3 CA ARG 2 9.042 -10.963 -7.273 -ATOM 4 CB ARG 2 169.196-168.255 -8.982 -ATOM 5 CA ILE 3 5.955 -9.381 -5.594 -ATOM 6 CB ILE 3 7.355 -17.267 -9.348 -ATOM 7 CA PRO 4 4.450 -6.011 -6.010 -ATOM 8 CB PRO 4 8.293 -15.262 -11.754 -ATOM 9 CA SER 5 7.190 -5.250 -8.539 -ATOM 10 CB SER 5 10.641 -9.174 -5.373 -ATOM 11 CA TYR 6 7.354 -5.535 -12.348 -ATOM 12 CB TYR 6 4.796 -10.792 -5.197 -ATOM 13 CA ASP 7 10.752 -3.958 -12.637 -ATOM 14 CB ASP 7 3.513 -6.163 -6.874 -ATOM 15 CA PHE 8 12.824 -6.283 -10.393 -ATOM 16 CB PHE 8 8.181 -5.602 -8.100 -ATOM 17 CA GLY 9 16.230 -6.896 -8.867 -ATOM 18 CA ASP 10 15.528 -10.562 -8.120 -ATOM 19 CB ASP 10 11.867 -3.361 -13.818 -ATOM 20 CA GLU 11 18.121 -13.316 -7.560 -ATOM 21 CB GLU 11 13.216 -7.681 -12.195 -ATOM 22 CA LEU 12 15.809 -16.273 -7.470 -ATOM 23 CB LEU 12 16.230 -6.896 -8.867 -ATOM 24 CA ALA 13 17.442 -19.233 -9.312 -ATOM 25 CB ALA 13 14.699 -11.588 -9.257 -ATOM 26 CA LYS 14 17.116 -22.328 -7.158 -ATOM 27 CB LYS 14 20.265 -13.685 -6.890 -ATOM 28 CA LEU 15 19.000 -23.404 -4.147 -ATOM 29 CB LEU 15 14.049 -15.539 -7.808 -ATOM 30 CA LEU 16 22.743 -23.767 -4.878 -ATOM 31 CB LEU 16 18.156 -19.310 -9.668 -ATOM 32 CA ARG 17 23.976 -24.680 -1.328 -ATOM 33 CB ARG 17 17.640 -24.337 -8.709 -ATOM 34 CA GLN 18 24.627 -28.315 -2.216 -ATOM 35 CB GLN 18 17.753 -23.570 -2.744 -ATOM 36 CA ALA 19 28.360 -28.817 -1.583 -ATOM 37 CB ALA 19 23.194 -24.346 -6.642 -ATOM 38 CA MET 20 30.487 -30.892 -3.948 -ATOM 39 CB MET 20 24.660 -21.877 -0.677 -ATOM 40 CA GLY 21 30.705 -34.625 -4.528 -ATOM 41 CA D 22 34.458 -36.431 -1.272 -ATOM 42 CB D 22 28.138 -29.185 -1.013 diff --git a/source/unres/src_MD-M-newcorr/random_multi_chain/ext_sing.pdb b/source/unres/src_MD-M-newcorr/random_multi_chain/ext_sing.pdb deleted file mode 100644 index 7849a15..0000000 --- a/source/unres/src_MD-M-newcorr/random_multi_chain/ext_sing.pdb +++ /dev/null @@ -1,42 +0,0 @@ -ATOM 1 CA GLY 1 10.016 -0.162 -2.895 -ATOM 2 CA TYR 2 9.800 1.995 0.246 -ATOM 3 CB TYR 2 7.805 2.090 1.786 -ATOM 4 CA ARG 3 13.606 2.684 0.612 -ATOM 5 CB ARG 3 13.698 0.199 -1.130 -ATOM 6 CA ILE 4 15.292 6.106 0.367 -ATOM 7 CB ILE 4 15.459 7.277 1.758 -ATOM 8 CA PRO 5 17.298 8.071 -2.143 -ATOM 9 CB PRO 5 16.462 8.590 -3.113 -ATOM 10 CA SER 6 17.687 5.028 -4.340 -ATOM 11 CB SER 6 18.654 5.685 -4.411 -ATOM 12 CA TYR 7 15.262 2.522 -5.839 -ATOM 13 CB TYR 7 14.011 4.112 -4.475 -ATOM 14 CA ASP 8 16.605 -0.805 -6.925 -ATOM 15 CB ASP 8 18.130 -1.491 -6.849 -ATOM 16 CA PHE 9 14.458 -3.153 -8.962 -ATOM 17 CB PHE 9 12.508 -4.263 -9.379 -ATOM 18 CA GLY 10 16.407 -6.185 -9.924 -ATOM 19 CA ASP 11 15.230 -9.704 -10.533 -ATOM 20 CB ASP 11 14.156 -9.782 -11.867 -ATOM 21 CA GLU 12 16.670 -12.474 -8.174 -ATOM 22 CB GLU 12 16.970 -13.667 -6.237 -ATOM 23 CA LEU 13 17.758 -15.930 -9.223 -ATOM 24 CB LEU 13 17.453 -17.596 -10.066 -ATOM 25 CA ALA 14 20.810 -17.626 -7.681 -ATOM 26 CB ALA 14 21.136 -17.240 -7.073 -ATOM 27 CA LYS 15 22.101 -20.451 -5.570 -ATOM 28 CB LYS 15 24.290 -21.707 -6.036 -ATOM 29 CA LEU 16 24.426 -19.349 -2.750 -ATOM 30 CB LEU 16 24.431 -17.386 -3.007 -ATOM 31 CA LEU 17 26.368 -22.081 -0.978 -ATOM 32 CB LEU 17 26.300 -23.176 0.602 -ATOM 33 CA ARG 18 29.334 -23.295 -2.984 -ATOM 34 CB ARG 18 31.106 -20.948 -3.700 -ATOM 35 CA GLN 19 31.643 -25.851 -1.247 -ATOM 36 CB GLN 19 32.614 -26.996 0.441 -ATOM 37 CA ALA 20 34.350 -26.824 -3.781 -ATOM 38 CB ALA 20 34.912 -26.587 -3.411 -ATOM 39 CA MET 21 35.154 -29.805 -6.038 -ATOM 40 CB MET 21 31.463 -29.620 -5.509 -ATOM 41 CA GLY 22 38.268 -30.200 -8.056 -ATOM 42 CA GLY 23 39.823 -28.216 -10.858 diff --git a/source/unres/src_MD-M-newcorr/random_multi_chain/fort.4 b/source/unres/src_MD-M-newcorr/random_multi_chain/fort.4 deleted file mode 100644 index 882d9d2..0000000 --- a/source/unres/src_MD-M-newcorr/random_multi_chain/fort.4 +++ /dev/null @@ -1,43 +0,0 @@ - ATOM 1CA GLYA 1 10.016 -0.162 -2.895 1. 10. - ATOM 2CA TYRA 2 9.8 1.995 0.246 1. 10. - ATOM 3CB TYRA 2 7.805 2.09 1.786 1. 10. - ATOM 4CA ARGA 3 13.606 2.684 0.612 1. 10. - ATOM 5CB ARGA 3 13.698 0.199 -1.13 1. 10. - ATOM 6CA ILEA 4 15.292 6.106 0.367 1. 10. - ATOM 7CB ILEA 4 15.459 7.277 1.758 1. 10. - ATOM 8CA PROA 5 17.298 8.071 -2.143 1. 10. - ATOM 9CB PROA 5 16.462 8.59 -3.113 1. 10. - ATOM 10CA SERA 6 17.687 5.028 -4.34 1. 10. - ATOM 11CB SERA 6 18.654 5.685 -4.411 1. 10. - ATOM 12CA TYRA 7 15.262 2.522 -5.839 1. 10. - ATOM 13CB TYRA 7 14.011 4.112 -4.475 1. 10. - ATOM 14CA ASPA 8 16.605 -0.805 -6.925 1. 10. - ATOM 15CB ASPA 8 18.13 -1.491 -6.849 1. 10. - ATOM 16CA PHEA 9 14.458 -3.153 -8.962 1. 10. - ATOM 17CB PHEA 9 12.508 -4.263 -9.379 1. 10. - ATOM 18CA GLYA 10 16.407 -6.185 -9.924 1. 10. - ATOM 19CA ASPA 11 15.23 -9.704 -10.533 1. 10. - ATOM 20CB ASPA 11 14.156 -9.782 -11.867 1. 10. - ATOM 21CA GLUA 12 16.67 -12.474 -8.174 1. 10. - ATOM 22CB GLUA 12 16.97 -13.667 -6.237 1. 10. - ATOM 23CA LEUA 13 17.758 -15.93 -9.223 1. 10. - ATOM 24CB LEUA 13 17.453 -17.596 -10.066 1. 10. - ATOM 25CA ALAA 14 20.81 -17.626 -7.681 1. 10. - ATOM 26CB ALAA 14 21.136 -17.24 -7.073 1. 10. - ATOM 27CA LYSA 15 22.101 -20.451 -5.57 1. 10. - ATOM 28CB LYSA 15 24.29 -21.707 -6.036 1. 10. - ATOM 29CA LEUA 16 24.426 -19.349 -2.75 1. 10. - ATOM 30CB LEUA 16 24.431 -17.386 -3.007 1. 10. - ATOM 31CA LEUA 17 26.368 -22.081 -0.978 1. 10. - ATOM 32CB LEUA 17 26.3 -23.176 0.602 1. 10. - ATOM 33CA ARGA 18 29.334 -23.295 -2.984 1. 10. - ATOM 34CB ARGA 18 31.106 -20.948 -3.7 1. 10. - ATOM 35CA GLNA 19 31.643 -25.851 -1.247 1. 10. - ATOM 36CB GLNA 19 32.614 -26.996 0.441 1. 10. - ATOM 37CA ALAA 20 34.35 -26.824 -3.781 1. 10. - ATOM 38CB ALAA 20 34.912 -26.587 -3.411 1. 10. - ATOM 39CA META 21 35.154 -29.805 -6.038 1. 10. - ATOM 40CB META 21 31.463 -29.62 -5.509 1. 10. - ATOM 41CA GLYA 22 38.268 -30.2 -8.056 1. 10. - ATOM 42CA GLYA 23 39.823 -28.216 -10.858 1. 10. - TER diff --git a/source/unres/src_MD-M-newcorr/random_multi_chain/output.pdb b/source/unres/src_MD-M-newcorr/random_multi_chain/output.pdb deleted file mode 100644 index b195fc6..0000000 --- a/source/unres/src_MD-M-newcorr/random_multi_chain/output.pdb +++ /dev/null @@ -1,43 +0,0 @@ -ATOM 1 CA GLY A 1 10.016 -0.162 -2.895 1.00 10.00 -ATOM 2 CA TYR A 2 9.800 1.995 0.246 1.00 10.00 -ATOM 3 CB TYR A 2 7.805 2.090 1.786 1.00 10.00 -ATOM 4 CA ARG A 3 13.606 2.684 0.612 1.00 10.00 -ATOM 5 CB ARG A 3 13.698 0.199 -1.130 1.00 10.00 -ATOM 6 CA ILE A 4 15.292 6.106 0.367 1.00 10.00 -ATOM 7 CB ILE A 4 15.459 7.277 1.758 1.00 10.00 -ATOM 8 CA PRO A 5 17.298 8.071 -2.143 1.00 10.00 -ATOM 9 CB PRO A 5 16.462 8.590 -3.113 1.00 10.00 -ATOM 10 CA SER A 6 17.687 5.028 -4.340 1.00 10.00 -ATOM 11 CB SER A 6 18.654 5.685 -4.411 1.00 10.00 -ATOM 12 CA TYR A 7 15.262 2.522 -5.839 1.00 10.00 -ATOM 13 CB TYR A 7 14.011 4.112 -4.475 1.00 10.00 -ATOM 14 CA ASP A 8 16.605 -0.805 -6.925 1.00 10.00 -ATOM 15 CB ASP A 8 18.130 -1.491 -6.849 1.00 10.00 -ATOM 16 CA PHE A 9 14.458 -3.153 -8.962 1.00 10.00 -ATOM 17 CB PHE A 9 12.508 -4.263 -9.379 1.00 10.00 -ATOM 18 CA GLY A 10 16.407 -6.185 -9.924 1.00 10.00 -ATOM 19 CA ASP A 11 15.230 -9.704 -10.533 1.00 10.00 -ATOM 20 CB ASP A 11 14.156 -9.782 -11.867 1.00 10.00 -ATOM 21 CA GLU A 12 16.670 -12.474 -8.174 1.00 10.00 -ATOM 22 CB GLU A 12 16.970 -13.667 -6.237 1.00 10.00 -ATOM 23 CA LEU A 13 17.758 -15.930 -9.223 1.00 10.00 -ATOM 24 CB LEU A 13 17.453 -17.596 -10.066 1.00 10.00 -ATOM 25 CA ALA A 14 20.810 -17.626 -7.681 1.00 10.00 -ATOM 26 CB ALA A 14 21.136 -17.240 -7.073 1.00 10.00 -ATOM 27 CA LYS A 15 22.101 -20.451 -5.570 1.00 10.00 -ATOM 28 CB LYS A 15 24.290 -21.707 -6.036 1.00 10.00 -ATOM 29 CA LEU A 16 24.426 -19.349 -2.750 1.00 10.00 -ATOM 30 CB LEU A 16 24.431 -17.386 -3.007 1.00 10.00 -ATOM 31 CA LEU A 17 26.368 -22.081 -0.978 1.00 10.00 -ATOM 32 CB LEU A 17 26.300 -23.176 0.602 1.00 10.00 -ATOM 33 CA ARG A 18 29.334 -23.295 -2.984 1.00 10.00 -ATOM 34 CB ARG A 18 31.106 -20.948 -3.700 1.00 10.00 -ATOM 35 CA GLN A 19 31.643 -25.851 -1.247 1.00 10.00 -ATOM 36 CB GLN A 19 32.614 -26.996 0.441 1.00 10.00 -ATOM 37 CA ALA A 20 34.350 -26.824 -3.781 1.00 10.00 -ATOM 38 CB ALA A 20 34.912 -26.587 -3.411 1.00 10.00 -ATOM 39 CA MET A 21 35.154 -29.805 -6.038 1.00 10.00 -ATOM 40 CB MET A 21 31.463 -29.620 -5.509 1.00 10.00 -ATOM 41 CA GLY A 22 38.268 -30.200 -8.056 1.00 10.00 -ATOM 42 CA GLY A 23 39.823 -28.216 -10.858 1.00 10.00 -TER diff --git a/source/unres/src_MD-M-newcorr/random_multi_chain/random.f b/source/unres/src_MD-M-newcorr/random_multi_chain/random.f deleted file mode 100644 index aee6dbd..0000000 --- a/source/unres/src_MD-M-newcorr/random_multi_chain/random.f +++ /dev/null @@ -1,61 +0,0 @@ - implicit none - double precision vec(3,1000,20),xtemp,ytemp,ztemp -cc vector is in the sequence: position, number of atom, number of chain - character*80 inname,outname,incontrol - character*8 junk - character*3 atype(1000),restyp(1000),atyptemp,resttemp,chain - integer natoms,i,ncopies,atnum,renum(1000),irestemp,actatom - integer unres,k,j,nrep - double precision occupan(1000),tempfact(1000),occutemp,temptemp - call getarg(1,inname) - call getarg(2,outname) - call getarg(3,incontrol) - k=18 - call RNUNF(k) - write (*,*) k - open (6,file=incontrol, status='old') - read (6,*) natoms,ncopies,unres - open (1,file=inname, status='old') - if (unres.eq.0) then - do i=1,natoms - read (1,*) junk,atnum,atyptemp,resttemp,chain,irestemp,xtemp, - &ytemp, ztemp,occutemp,temptemp - vec(1,i,1)=xtemp - vec(2,i,1)=ytemp - vec(3,i,1)=ztemp - atype(i)=atyptemp - restyp(i)=resttemp - renum(i)=irestemp - occupan(i)=occutemp - tempfact(i)=temptemp - enddo - endif - if (unres.ne.0) then - do i=1,natoms - read (1,*) junk,atnum,atyptemp,resttemp,irestemp,xtemp,ytemp, - &ztemp - vec(1,i,1)=xtemp - vec(2,i,1)=ytemp - vec(3,i,1)=ztemp - atype(i)=atyptemp - restyp(i)=resttemp - occupan(i)=1.0 - tempfact(i)=10.0 - renum(i)=irestemp - enddo - endif - write (*,*) "end of reading" - open (4,file=outname) - junk="ATOM " - do k=1,ncopies - if (k.eq.1) chain=" A" - do i=1,natoms - actatom=natoms*(k-1)+i - write (4,'(a8,i3,a4,a4,a2,i3,f12.3,2f8.3,2f6.2)') junk, actatom - &, atype(i),restyp(i),chain, - &renum(i), (vec(j,i,k),j=1,3),occupan(i),tempfact(i) - enddo - write (4,'(a3)') "TER" - enddo - end - diff --git a/source/unres/src_MD-M-newcorr/random_multi_chain/toggle b/source/unres/src_MD-M-newcorr/random_multi_chain/toggle deleted file mode 100755 index 9e0844f25dc348b7390e1206df9a80512cb630ff..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 15794 zcmdU04RlmRmae4J5HXOT`~(4cLQwEPn}h(-6{jNvUfl2_KXZgtx|^gEqWPPogTWOi z*k;C_HX47J!*KjzcU=#w>zegvL>5R8mFRJ1v&_zdqvJ%yv3o&{_{X|x_Pe*LIck6!l-l|*mZdJX0@6``W%a^97r3szV#Z`j1u5-N%$+HkUFJ@L@#UfL9 z#Z+;D7y-nM!^;w)GN);eDq7P_rRM_8pnSRl(!DaH=oHBbO|^$aslK7)Rar?Zr%6^* zAq)n{j(k-tsGqn5?PX_#==6=0xKbqd$ZnP);aSQ~(;g}qNmJcEDvpjRs(n+^z2J!V z5*c!XIn@`)uX;aJNp`hUrJ#1Imou7HN?2%0x|FVk9k)-i-+9)4URGPPX+hCtwUu*g zYwBBC=e8Cvn7g3J)7;=GWdCze5;bwzigjG3?vL|S4P!wK9CV#7z(Hw}B;rEQF*qjT zpysGcBgP|7X#$SXIH(O&jy0)nwL+Y?wozZHQIJqfkZ%-MSvYh$9~tuXTm@uD0Q zV=|6&a8O@RJI|KLPu*s#9+i~}r?OMw(}5c}?5O~NVF$sN;z(6ajRRipfUjYEwCJ7U zMQ$jqM>bXYpF7}w2Ye(hSgLZWm45FiFLFbv9@$j-Ee`mt4tTo*J{kVxh))K4^Zd{l zN_Qcfs^0q@@Jm!Voj;_O45eMjrYh&J9Pq~-@No`){-cBbUI+YT2mEyhd<)|kIkxK} zFdtMGR?q~HFPeSLp@v3~o13eGAWh9JLE-aN*EQ5b5@-tfe8P9l7T@Y%bxm_9*tEDd z(A*qs7C{(5GYErP7*y5N*D!`cDjR&YH4UQ57i_HwammoA@=&HMAQVgY{f4ideRAp|6^)edIS+42u?6phb1mo(0^tiV9ydaRtP2 zI~Slylvhov3)IvDsb~%O0wMO&7px3~0>CykQ;(qC!WXQs6wAuXu3qdb^b~sLqc^RI zW+Gfzo{=c86Jb(frG(JmNq~ADYPp~WQ&YN_BTYo?B0rh%TBPTE;&Z0^i3pktl`8YO z7ToHAVZmvx)M=Ilx6ZNo7M$wPsn~++wS;6|3r_R0PNoIdb1}(QS#ayTeVqlTxmPE@ z1*f$|r_C0e=6IbNEx7JmlC@fJ>)O+1!L8%_P76+RzD}JMT(4^++iAgR{nKf;1*bJg zr#%*2ub(9Avf#9)=(N{@)7q<3j|Eq^5G?Ao;IuC5WQI>=#(tG1M63{D65ED0o8gx- z4-d|NccLK%XP&@0dzu$H;y067ynhgB=5L6Hp@{b}f0TF%wRjKnuMtln7Vl#IMdB%R zEtg;?BR{ubgXwBk9;HxW-E6&K9kNIZp7eBfIEGdB@WAr$Xtegp9oI`KZ{ zR})Vm6YpXE8sh2pBi_aQ)x=Zi#CJ1)1@ROz@lNIoiJw4x8}pYEPoWcU1P{uo;KQ=W zzic!k@0#Hg1FP1S9qH+t>=ovbL;XyS>;{Q-!{D>dPP(>c)SWiL5N3N%D1ESxFKwqa zwJmxh*AQZz8F@dHb21M$J(*_2{cG3^9)cn+rbsM-*E{hy~wPf(UR}Xh~QU&JrQ>(CwnjI~j`&L1*J0CZ< zY!dqr9-AG{(Up^;qJ-$E6b*n#QE@`_Jg_6}jmHKDso%|x1C*5ouE3S-7Bl?1{BNlI z9VCB&V(=hU-91#&Ly$|uHC$agRfm3Xqxs!NqL_<;cKZ|TGS=NO=L3gQm&sc5oaC2C zdC1ADkqNJU@iqBh+6kAAj)zNa2_No572_}3PX0vNU*AccGYk1NGqf0dMbo#Yov zdA^hU+yCUtcdJuJz0LA8Tp)V5#GwU(`0xQbqr}NP&}h9J z?9G0PmlPL|$VhuDz;1t{5vM<=Mm$H2VE-+v`mrxqL6bgFOP+{#SoZ3h2fz47n?5;+ZP?i`77{0Og}m5i2FHkq}n;?ewxL5lEk~TIO@I! zS+k-y>i!95`l9Y_l-U{0Xn*i8tHr#G9Yi7-9YoCN@-xxWQ&^It?(bXGB1`W5x)V2L zr?5!ffN}EbVZO*E-Jn}{sVebO=1jf0&_b1($O!1tI9sl zy#c?qPG@gCbUJ&idxT%go>sD}EV9$SO9VQ-0zG-eJr#w>?mrdYb_(6U9dOiL1v~iu z z?dSa1jF)p;tLdsf0G)Ufdb%^}K5;I4&;rQieiIBlI1UmSzX?#(-6!SiS$;&yUt;-E zmhYGHMJ#_t%DY&8Da-S4zNx1IrS1Yc*b{M2U_1wBjM%7j%8VdN-CqZEYkrR$wdP%> z>)nrS9BR#doL8+eqwCH@-OocUl1`zHg8FfhO8aFHt-(*XTr;w5;E4No!AsEPbS>UM zt{OSZ&^STSpBN!0!rM-W)?yCU<7UUUm>hjo7;mSub9yNVZotfiu0{9G>4{`KMDeXc z_+&SJ9OnLo3gYmo98}MNj8W*m0*-e3p)5iMsYdFx;2QgnXApKIF@g{1%e4 zFZmxQeA#}gaT=}wbxp^Cu6|5pn-c{t!i_U7eh0yyW^Zr@&oR)~8++0B=%)|OE+-N{pIHe9V!P-xAE$15mL7YCdg(FvSTGoSr7C9Ds^F#RA{$XfJ!JG6Ps66sjdE|>Fk&jCT$Gv5S52u-zpKSVf zGkSd<9yQeF<&;M&^K#3PGs>f(yjkVZTl4Y}SjDdgje3tSaX70#D&=F)J`{w!ouZqoK-Z z3I-}`>Z?oEu3TGj?GzKV#SP6Ohn0;oFAnx9zBBOSK_#9f|mt{_$-p- z*8^KVQOZkY_a@|dkll*ozDZKvhCC%*ercF`O#1OC=y?}-i4}M8c}S1^cnQbDXOW+P z{8BvUqI46VlkKVB=s6gr*?bma$r${V@qmR5stmU zBZORgm-|N}d}F-fk@uwE?ZTbbbz|tRo$RT93|yxRK>xoagbgR{ubtPp3L}nb!ZiOY zrJ(uW+W3=-&r(#sZyK$5{XQ~7@!oVV=k&PB86kQ7P9n!8c@@5*SXE48ic+p5iFeG3 zUzyka zgo&GZQ^`s9eccG#lMXyqHg`yi3tylCmMekPhVMW>bvz&6VuGo`~EjzAxtDK%&Q|h<9 zN0(^ov(-M8hK>o6{VC;J?Z2!1RPyigPmfKjf2qoG!mReO6#ZtEkHPJfH4Q>|-bS~W zTQy0%i9xtC;1VP8mbCjyybHx(d-4aYy>i*&#a9@!@RiDJqsUX_nQs*47vvWd6cie> zRtGB$GZ2#aT&(iKqC5}E3!t38AipTTXh@myxdp|u|2XCUQEgB2*1Aw&lkhZ$nk3z< zb2asN{oW`%^$nq*r{wCgxuHO{@N5n=Zx)`)t@SXJG}I(K)%7i&Ey1Sdnuhu$#s^tb zur@#jD%V&W5*~gx@4>5ZTKohDO$91!KruLZxNKPt-mAl?p{_1iAF^Kj|3;qPmD0G-^Sns+fp<@ z_gf*(yYTB*k9Vukg)gr4I8MeV3OzoP@m!(DT{1q&%5q-DdzN_XTyK($#!&{o!%YIg zP~4}b=!Z)gAKnkej1TXJQpP8Wf$4tahEf@_Y4|m+{nz7T9q@GeLR>uu(-t==+-t*~ z{FnC!V@0N||L@>>&lC3FnfEfDBm8)VYE5#T8{V!bphSLl+I}w`0-mZr<$R6VW2Rpg zzediFec;mQ3;Y=pH^5VR2M6KC3_o&0c=;^EC!mD;XZRU0_zYjtB;Gc|&xn`L_-&@} zo*8~d3_hbeh4;_!Gh*-=&(ahw)O@b-QiU4|_bUB$3isRes}$a5!&`x;>Yp&{qkr%! ziISdgBMQ&7;rA%qP*rgl7(rjP^6nDbI9=?3f1k@4KCk+K z8}P?IPu>WeK0dUkA26OJ=<7^MU^#79xP9HZ)1jPu9Ppn4H&mHc^0yB73tUdtu;=QB z9Ln!?z<=X_zr*A{`}>xtL-`LVef#^D z2OaeP26(FdF;6+@{~Y*Otf#xxI2`~_>7axD%fP98`@WgiSU+pnd!{~za*io|`+KXm z9rQnNz&`?>s=c2(=zr~ipM!u&6^A(v_(aCDhP{uP!gz}N)rvrEt!0OesAvi`hg$GP zw*nhb7O!2o+E-q-W-V>J@hwT>u34NAHDd1$9;Y?d21CJ0>~!(@uob4dwqaAC*2fR! ze1Vo$As^jUw$#;a)kT-CSTaVt>m{dfer#M+* zzUT5}V1cI~Uy$3?!TM%6-c(lr$D8U3;cXMPLDmGwt(ppQ2BP@@3Q=oKMIow!RxyBi zD72)(2$$Vui;XPj3`&ycVm3niT-o)jzv|VjDBcGwI>!&{8huwg;_=dKl zks6{`Z%ec815;bnwov#~`t(*cz6@mL)4SG|mz1r*$l@Jtmd$HwXBq96JNq6sxhajE F`!BbIVdnq< diff --git a/source/unres/src_MD-M-newcorr/rattle.F b/source/unres/src_MD-M-newcorr/rattle.F deleted file mode 100644 index 5a8ed0c..0000000 --- a/source/unres/src_MD-M-newcorr/rattle.F +++ /dev/null @@ -1,724 +0,0 @@ - subroutine rattle1 -c RATTLE algorithm for velocity Verlet - step 1, UNRES -c AL 9/24/04 - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef RATTLE - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision gginv(maxres2,maxres2), - & gdc(3,MAXRES2,MAXRES2),dC_uncor(3,MAXRES2), - & Cmat(MAXRES2,MAXRES2),x(MAXRES2),xcorr(3,MAXRES2) - common /przechowalnia/ GGinv,gdc,Cmat,nbond - integer max_rattle /5/ - logical lprn /.false./, lprn1 /.false./,not_done - double precision tol_rattle /1.0d-5/ - if (lprn) write (iout,*) "RATTLE1" - nbond=nct-nnt - do i=nnt,nct - if (itype(i).ne.10) nbond=nbond+1 - enddo -c Make a folded form of the Ginv-matrix - ind=0 - ii=0 - do i=nnt,nct-1 - ii=ii+1 - do j=1,3 - ind=ind+1 - ind1=0 - jj=0 - do k=nnt,nct-1 - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) - enddo - endif - enddo - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ii=ii+1 - do j=1,3 - ind=ind+1 - ind1=0 - jj=0 - do k=nnt,nct-1 - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) - enddo - endif - enddo - enddo - endif - enddo - if (lprn1) then - write (iout,*) "Matrix GGinv" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv) - endif - not_done=.true. - iter=0 - do while (not_done) - iter=iter+1 - if (iter.gt.max_rattle) then - write (iout,*) "Error - too many iterations in RATTLE." - stop - endif -c Calculate the matrix C = GG**(-1) dC_old o dC - ind1=0 - do i=nnt,nct-1 - ind1=ind1+1 - do j=1,3 - dC_uncor(j,ind1)=dC(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind1=ind1+1 - do j=1,3 - dC_uncor(j,ind1)=dC(j,i+nres) - enddo - endif - enddo - do i=1,nbond - ind=0 - do k=nnt,nct-1 - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres) - enddo - endif - enddo - enddo -c Calculate deviations from standard virtual-bond lengths - ind=0 - do i=nnt,nct-1 - ind=ind+1 - x(ind)=vbld(i+1)**2-vbl**2 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 - endif - enddo - if (lprn) then - write (iout,*) "Coordinates and violations" - do i=1,nbond - write(iout,'(i5,3f10.5,5x,e15.5)') - & i,(dC_uncor(j,i),j=1,3),x(i) - enddo - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i+nres,ind,(d_t_new(j,i+nres),j=1,3), - & scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) - endif - enddo -c write (iout,*) "gdc" -c do i=1,nbond -c write (iout,*) "i",i -c do j=1,nbond -c write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) -c enddo -c enddo - endif - xmax=dabs(x(1)) - do i=2,nbond - if (dabs(x(i)).gt.xmax) then - xmax=dabs(x(i)) - endif - enddo - if (xmax.lt.tol_rattle) then - not_done=.false. - goto 100 - endif -c Calculate the matrix of the system of equations - do i=1,nbond - do j=1,nbond - Cmat(i,j)=0.0d0 - do k=1,3 - Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Cmat" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) - endif - call gauss(Cmat,X,MAXRES2,nbond,1,*10) -c Add constraint term to positions - ind=0 - do i=nnt,nct-1 - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - xx=0.5d0*xx - dC(j,i)=dC(j,i)-xx - d_t_new(j,i)=d_t_new(j,i)-xx/d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - xx=0.5d0*xx - dC(j,i+nres)=dC(j,i+nres)-xx - d_t_new(j,i+nres)=d_t_new(j,i+nres)-xx/d_time - enddo - endif - enddo -c Rebuild the chain using the new coordinates - call chainbuild_cart - if (lprn) then - write (iout,*) "New coordinates, Lagrange multipliers,", - & " and differences between actual and standard bond lengths" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - xx=vbld(i+1)**2-vbl**2 - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i),j=1,3),x(ind),xx - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - xx=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i+nres),j=1,3),x(ind),xx - endif - enddo - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i+nres,ind,(d_t_new(j,i+nres),j=1,3), - & scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) - endif - enddo - endif - enddo - 100 continue - return - 10 write (iout,*) "Error - singularity in solving the system", - & " of equations for Lagrange multipliers." - stop -#else - write (iout,*) - & "RATTLE inactive; use -DRATTLE switch at compile time." - stop -#endif - end -c------------------------------------------------------------------------------ - subroutine rattle2 -c RATTLE algorithm for velocity Verlet - step 2, UNRES -c AL 9/24/04 - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef RATTLE - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision gginv(maxres2,maxres2), - & gdc(3,MAXRES2,MAXRES2),dC_uncor(3,MAXRES2), - & Cmat(MAXRES2,MAXRES2),x(MAXRES2) - common /przechowalnia/ GGinv,gdc,Cmat,nbond - integer max_rattle /5/ - logical lprn /.false./, lprn1 /.false./,not_done - double precision tol_rattle /1.0d-5/ - if (lprn) write (iout,*) "RATTLE2" - if (lprn) write (iout,*) "Velocity correction" -c Calculate the matrix G dC - do i=1,nbond - ind=0 - do k=nnt,nct-1 - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC(j,k) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC(j,k+nres) - enddo - endif - enddo - enddo -c if (lprn) then -c write (iout,*) "gdc" -c do i=1,nbond -c write (iout,*) "i",i -c do j=1,nbond -c write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) -c enddo -c enddo -c endif -c Calculate the matrix of the system of equations - ind=0 - do i=nnt,nct-1 - ind=ind+1 - do j=1,nbond - Cmat(ind,j)=0.0d0 - do k=1,3 - Cmat(ind,j)=Cmat(ind,j)+dC(k,i)*gdc(k,ind,j) - enddo - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - do j=1,nbond - Cmat(ind,j)=0.0d0 - do k=1,3 - Cmat(ind,j)=Cmat(ind,j)+dC(k,i+nres)*gdc(k,ind,j) - enddo - enddo - endif - enddo -c Calculate the scalar product dC o d_t_new - ind=0 - do i=nnt,nct-1 - ind=ind+1 - x(ind)=scalar(d_t(1,i),dC(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - x(ind)=scalar(d_t(1,i+nres),dC(1,i+nres)) - endif - enddo - if (lprn) then - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i,ind,(d_t(j,i),j=1,3),x(ind) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind) - endif - enddo - endif - xmax=dabs(x(1)) - do i=2,nbond - if (dabs(x(i)).gt.xmax) then - xmax=dabs(x(i)) - endif - enddo - if (xmax.lt.tol_rattle) then - not_done=.false. - goto 100 - endif - if (lprn1) then - write (iout,*) "Matrix Cmat" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) - endif - call gauss(Cmat,X,MAXRES2,nbond,1,*10) -c Add constraint term to velocities - ind=0 - do i=nnt,nct-1 - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - d_t(j,i)=d_t(j,i)-xx - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - d_t(j,i+nres)=d_t(j,i+nres)-xx - enddo - endif - enddo - if (lprn) then - write (iout,*) - & "New velocities, Lagrange multipliers violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - if (lprn) write (iout,'(2i5,3f10.5,5x,2e15.5)') - & i,ind,(d_t(j,i),j=1,3),x(ind),scalar(d_t(1,i),dC(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,2e15.5)') - & i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind), - & scalar(d_t(1,i+nres),dC(1,i+nres)) - endif - enddo - endif - 100 continue - return - 10 write (iout,*) "Error - singularity in solving the system", - & " of equations for Lagrange multipliers." - stop -#else - write (iout,*) - & "RATTLE inactive; use -DRATTLE option at compile time." - stop -#endif - end -c------------------------------------------------------------------------------ - subroutine rattle_brown -c RATTLE/LINCS algorithm for Brownian dynamics, UNRES -c AL 9/24/04 - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef RATTLE - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision gginv(maxres2,maxres2), - & gdc(3,MAXRES2,MAXRES2),dC_uncor(3,MAXRES2), - & Cmat(MAXRES2,MAXRES2),x(MAXRES2) - common /przechowalnia/ GGinv,gdc,Cmat,nbond - integer max_rattle /5/ - logical lprn /.true./, lprn1 /.true./,not_done - double precision tol_rattle /1.0d-5/ - if (lprn) write (iout,*) "RATTLE_BROWN" - nbond=nct-nnt - do i=nnt,nct - if (itype(i).ne.10) nbond=nbond+1 - enddo -c Make a folded form of the Ginv-matrix - ind=0 - ii=0 - do i=nnt,nct-1 - ii=ii+1 - do j=1,3 - ind=ind+1 - ind1=0 - jj=0 - do k=nnt,nct-1 - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) - enddo - endif - enddo - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ii=ii+1 - do j=1,3 - ind=ind+1 - ind1=0 - jj=0 - do k=nnt,nct-1 - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1)GGinv(ii,jj)=fricmat(ind,ind1) - enddo - endif - enddo - enddo - endif - enddo - if (lprn1) then - write (iout,*) "Matrix GGinv" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv) - endif - not_done=.true. - iter=0 - do while (not_done) - iter=iter+1 - if (iter.gt.max_rattle) then - write (iout,*) "Error - too many iterations in RATTLE." - stop - endif -c Calculate the matrix C = GG**(-1) dC_old o dC - ind1=0 - do i=nnt,nct-1 - ind1=ind1+1 - do j=1,3 - dC_uncor(j,ind1)=dC(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind1=ind1+1 - do j=1,3 - dC_uncor(j,ind1)=dC(j,i+nres) - enddo - endif - enddo - do i=1,nbond - ind=0 - do k=nnt,nct-1 - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres) - enddo - endif - enddo - enddo -c Calculate deviations from standard virtual-bond lengths - ind=0 - do i=nnt,nct-1 - ind=ind+1 - x(ind)=vbld(i+1)**2-vbl**2 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 - endif - enddo - if (lprn) then - write (iout,*) "Coordinates and violations" - do i=1,nbond - write(iout,'(i5,3f10.5,5x,e15.5)') - & i,(dC_uncor(j,i),j=1,3),x(i) - enddo - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i,ind,(d_t(j,i),j=1,3),scalar(d_t(1,i),dC_old(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i+nres,ind,(d_t(j,i+nres),j=1,3), - & scalar(d_t(1,i+nres),dC_old(1,i+nres)) - endif - enddo - write (iout,*) "gdc" - do i=1,nbond - write (iout,*) "i",i - do j=1,nbond - write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) - enddo - enddo - endif - xmax=dabs(x(1)) - do i=2,nbond - if (dabs(x(i)).gt.xmax) then - xmax=dabs(x(i)) - endif - enddo - if (xmax.lt.tol_rattle) then - not_done=.false. - goto 100 - endif -c Calculate the matrix of the system of equations - do i=1,nbond - do j=1,nbond - Cmat(i,j)=0.0d0 - do k=1,3 - Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Cmat" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) - endif - call gauss(Cmat,X,MAXRES2,nbond,1,*10) -c Add constraint term to positions - ind=0 - do i=nnt,nct-1 - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - xx=-0.5d0*xx - d_t(j,i)=d_t(j,i)+xx/d_time - dC(j,i)=dC(j,i)+xx - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - xx=-0.5d0*xx - d_t(j,i+nres)=d_t(j,i+nres)+xx/d_time - dC(j,i+nres)=dC(j,i+nres)+xx - enddo - endif - enddo -c Rebuild the chain using the new coordinates - call chainbuild_cart - if (lprn) then - write (iout,*) "New coordinates, Lagrange multipliers,", - & " and differences between actual and standard bond lengths" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - xx=vbld(i+1)**2-vbl**2 - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i),j=1,3),x(ind),xx - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - xx=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i+nres),j=1,3),x(ind),xx - endif - enddo - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i+nres,ind,(d_t_new(j,i+nres),j=1,3), - & scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) - endif - enddo - endif - enddo - 100 continue - return - 10 write (iout,*) "Error - singularity in solving the system", - & " of equations for Lagrange multipliers." - stop -#else - write (iout,*) - & "RATTLE inactive; use -DRATTLE option at compile time" - stop -#endif - end diff --git a/source/unres/src_MD-M-newcorr/readpdb.F b/source/unres/src_MD-M-newcorr/readpdb.F deleted file mode 100644 index f2daadd..0000000 --- a/source/unres/src_MD-M-newcorr/readpdb.F +++ /dev/null @@ -1,557 +0,0 @@ - subroutine readpdb -C Read the PDB file and convert the peptide geometry into virtual-chain -C geometry. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.NAMES' - include 'COMMON.CONTROL' - include 'COMMON.DISTFIT' - include 'COMMON.SETUP' - character*3 seq,atom,res - character*80 card - dimension sccor(3,20) - double precision e1(3),e2(3),e3(3) - integer rescode - logical fail - 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)=ntyp1 - 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)=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 - itype(ires)=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.ntyp1) 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)=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)-3.8d0*e2(j) - enddo - else - do j=1,3 - dcj=c(j,nres-2)-c(j,nres-3) - c(j,nres)=c(j,nres-1)+dcj - c(j,2*nres)=c(j,nres) - enddo - endif - endif - do i=2,nres-1 - do j=1,3 - c(j,i+nres)=dc(j,i) - enddo - enddo - do j=1,3 - c(j,nres+1)=c(j,1) - c(j,2*nres)=c(j,nres) - enddo - if (itype(1).eq.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)-3.8d0*e2(j) - enddo - else - do j=1,3 - dcj=c(j,4)-c(j,3) - c(j,1)=c(j,2)-dcj - c(j,nres+1)=c(j,1) - enddo - endif - endif -C Calculate internal coordinates. - if(me.eq.king.or..not.out1file)then - 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,nres - lll=lll+1 -cc write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) - if (i.gt.1) then - if ((itype(i-1).eq.ntyp1).and.(i.gt.2)) then - chain_length=lll-1 - kkk=kkk+1 -c write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) - lll=1 - endif - endif - do j=1,3 - cref(j,i,cou)=c(j,i) - cref(j,i+nres,cou)=c(j,i+nres) - if (i.le.nres) then - chain_rep(j,lll,kkk)=c(j,i) - chain_rep(j,lll+nres,kkk)=c(j,i+nres) - endif - enddo - enddo - write (iout,*) chain_length - if (chain_length.eq.0) chain_length=nres - do j=1,3 - chain_rep(j,chain_length,symetr)=chain_rep(j,chain_length,1) - chain_rep(j,chain_length+nres,symetr) - &=chain_rep(j,chain_length+nres,1) - enddo -c diagnostic -c write (iout,*) "spraw lancuchy",chain_length,symetr -c do i=1,4 -c do kkk=1,chain_length -c write (iout,*) itype(kkk),(chain_rep(j,kkk,i), j=1,3) -c enddo -c enddo -c enddiagnostic -C makes copy of chains - write (iout,*) "symetr", symetr - - if (symetr.gt.1) then - call permut(symetr) - nperm=1 - do i=1,symetr - nperm=nperm*i - enddo - do i=1,nperm - write(iout,*) (tabperm(i,kkk),kkk=1,4) - enddo - do i=1,nperm - cou=0 - do kkk=1,symetr - icha=tabperm(i,kkk) -c write (iout,*) i,icha - do lll=1,chain_length - cou=cou+1 - if (cou.le.nres) then - do j=1,3 - kupa=mod(lll,chain_length) - iprzes=(kkk-1)*chain_length+lll - if (kupa.eq.0) kupa=chain_length -c write (iout,*) "kupa", kupa - cref(j,iprzes,i)=chain_rep(j,kupa,icha) - cref(j,iprzes+nres,i)=chain_rep(j,kupa+nres,icha) - enddo - endif - enddo - enddo - enddo - endif -C-koniec robienia kopii -c diag - do kkk=1,nperm - write (iout,*) "nowa struktura", nperm - do i=1,nres - write (iout,110) restyp(itype(i)),i,cref(1,i,kkk), - &cref(2,i,kkk), - &cref(3,i,kkk),cref(1,nres+i,kkk), - &cref(2,nres+i,kkk),cref(3,nres+i,kkk) - enddo - 100 format (//' alpha-carbon coordinates ', - & ' centroid coordinates'/ - 1 ' ', 6X,'X',11X,'Y',11X,'Z', - & 10X,'X',11X,'Y',11X,'Z') - 110 format (a,'(',i3,')',6f12.5) - - enddo -cc 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.ntyp1 .and. itype(i+1).ne.ntyp1 .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.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 - 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(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 - diff --git a/source/unres/src_MD-M-newcorr/readpdb.f b/source/unres/src_MD-M-newcorr/readpdb.f deleted file mode 100644 index 084d907c05b686ae11c3af387078936502ce1799..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 43512 zcmc(o3w%|@wf{FHN|4}AELya*M(?o=l_GEeX+vucB)ShA9xAq>riOTu0BwLY1O$tU zCZTMT6R{Utdy6ft+Isu2*jlRAYIuW+0`-Bfimfli2cjaP<@|qZX04NzNzU!P{ol|3 zKcAk=-rrfXW@gQr$DX~V*OVvD@7t$Oj>n;o_Z6>?+^BfT&%16)&1I=~qBo!mI#;A4 z*Lx@JV3Q-KmwcaqU`{V3f6DN_t{QKt;hAb@(yul=H*+r+D-1tQZZq+nh994~my18+ zqL0_bCFkqR^H@-7&=(CR`F!RgA7egRS`F2PCE#|8o zP9uccyT;*znBV5`&oM7zE_N$19Dg`W=XeV9S$w~b^UY#jih5CyoQ=%O9NuiW^q%Lv zXR~>04Hv6>o=E(Txzw*8%Wq~b{VM!P=F(5XUt?ax`Gp^4UhMFERE6w0!r`A`KF;AI zn3p|g5WKh5x5Z?hx+ z1(uibEA=m7`9~c2sVraN=&xk?=`1hxY+xQZyoLEJhu_TnAnPyS_}9$$IlPm3g`?+j z=Hngvzsg+ZbLq#U%oC3MKs1EL`wWK{F|TxZlzENA&u3om@R`h;9A3|SnZvJPKFHzU zV?M;;w=<78{2u1R9R4u#(GEYpzqP|0$IhoQhmlN>{yOypnt!0o2}2D>CMS$B9Dkf} zp5gfp^}I=j5A4Cu04ekirHdqGvb`AU@Ku-D8F#qDWxX2X@cNCmfu#;Fodtk!0e-sN z<>y<^n(FZTXIMQnezd&Im(>nmc@_Y|T>P}WtZxnACwbgixGp^te-PU7lfE#3|J;&= zKb(a>orNFC!hJNaw{iz(;h)dK7iZzOWZ@^m1ih7eau$AJ7QQwMPoO)=&SKwHJaJr$ zSog~#XTmTD*E_t_P|v%8_3Zkb1r0pm{uM*T=#N^y4(+7y8o1VfkojB8rOm}w+&jX0 z4vw~97t0UFkkfi*@emyA@P_8r_t*w}&EaK_TKUTy?(w*&V=ncV z5x&roUtVqXEOmGu);|i@IlLb$yx!sRz_^;Zl*?xFe(cI~zue()*)QDX@U^Bkp7%#b zzm)T5N50?_>r9Sq4(~k4DtgS(gYBpZPdV~3U;WjQkFfl!;8F)hCi*Z7ABcIiH~HAt zVqcA25}R?!#lf|2EWz9vdw@JEdN`z+($jzGk=|=FIM~(_*=HTfyO(gx{3W~{*{6d9 zsr!vcw3Dc~Yj9uRbW3v)(i15w`x>sj<|App%98}H*!Jve2YYNt%kwc|jt)KT-r8_fc)=W(01grt-Jg`}PQJ;L%oY zb?|`4?F>@wCZlO*B58E%;*3ITB-u-m`ckN)c)C*z?T30VgmRcd*dT1V?j{o}T9a7| zX184M;EeL};9@dR$p?Px*(jkm8=5BQHg%a09hFNdvyhb*X4}vP+!?cnzmCwxV@hhJ zm~jbidv719&_*<>+1$#A;+9J1&7>2RSdN$~p*jb2B`5{zD3Tz_RfwsAro13&t+nCB z+_q~;vh7Ct8=7nOxzM2QmJc?(SP*RZTV62Wpj$V=w!^}A%A=jpPSeKLPQT-fkJD-0i_#6Td&y{- zPTosu5E5Z~WEbMtJ#^Q6qhQUW(O{zImu)LYJ6a3DDDIEAJo;>TbWiMF7Aq>6 z=9T;9yOE=)XeyepIzk(svT%EuU%t1iT8VH?bn)0#r)IM{u7kpms>mc7f8lunBGXf2LNU*9WUy z#!l$y)M|q>PUJzxdZ6_;k;A~uLlOnbLt>dcD*?qg4U<#(*N}Br0g`@J{o?| z{A$0mKY&|eVy24Y_pEJ#-|<`I2%104^V>J$$}j$lU;J=9d}j(aDyi{XsNh3>!7nJT z^G`8xyty+Ej4~4AxZ;sIzXFXa_#<!EN99+At6EcaCt;q4zvbFg8kYBvJ z&OdoK*<^BRd>rFFCsDHFs*?fQw~@l2dE4N4dIR9H1Bciw#+DhAoJ}TaJCaUM33ng3 z&+a?JmdH9dSZk*mB4us2*&%Wr)MgnPvL>{c#Ra>EjEBJ?;FCwFN(fy;h6W2QM8^4~ zh_djuNGHk{_mnXJzb9;E!?Q?JbVn>z7J-AslW(BbcObd>NMFDG6{Nv{14#z4*^LCL z@?*{8Q-n_TTkp0h-=kYd{0GNB6l5oR4G*`MTnb zuIrimk#`?tk0JgLzk|3&dL`?p^g<~MGL@`b809GxX5yfE4Iw+~0(mD#?C zHNS%0*7bO~8l;xZ!;*mJDTxeqm-oS$Y&Vn3Qa$IO*2>yTsVyQ$V-TYzSWn(6$%4&|b zc3wR!NSSp8GxA#FWo2kbYS5Nlu%>Y}<6vzz)vgsM2XoVHoVgrCI7@4?qVkJ=9PdRy3^R;d5n>CxLkQ zL=e7<)tPeWHCa6>L*F=Pk-^wCcBAM%n`RA`Z`=Tdl`3&Hb_pBF1a=NLtYa>SqH{&J`3Gq~l@?-u%#g+q- z8bcZ#ZG2 zKAzqjZ~i#v>W70it1*E|mDEXPx|bVo-ZD6r-bNb^@`WJ1r7S!Wl-REJJIasIM&91B zx6%wsU0eoC{cD^68@rA#qJ=UK!aB2{4#{5l@PU5lU%I6#*!b>94c#X@%i1EX)U9X*McDVzK6rPxf1AEew)x@=OEpeE?K#AeB_- zpJRRXiW6{YX6?mGyB3=ww1R^2PU`D>fKLOaCXk3-Y&u!E%VEh~N!C;feOiP{Ngmo% z(LFm_#v5$=?vB(WExiSq=z{IgW-TX`r}Y(9gLQJZP%Uv`4_%s%^zl1xXXe(_^<{-7PmWcQZX;mF0z*JFP1-;nweQtjG>RC`gD zvk!2{PErFX7nK|9{F&Qna+{8pX*Z^O?2`7^`IXN==I_x?+`WM-QxkNLiR=7N+Iv*p z7IdiGpSc%B*&Q#|rb?{ZGmlZ*>@y_?iGOp5eB8nSG4I?KykW0JGF8BH91iyt&ZK!RdO&hKIl;!-*Yzd+` za=6W;*x|Ou6eUXoG6gCVb_P`J^Hdl;!X}Vbma{3niJXK4F+UPx&2}Jg?YS|O-}G^i z-WcveHZw>{p71-~gWp7-jp1=3jotnpzk>(&$y8cb6YYMCY?0o+YE_UjOC^%cxb}-* zz-7c#5EpmZtd;1Hna|<=Kka?t4=MJGw+87=*fwoI>SomIT1$8O#oIt10(}wmr|J(a^l3zhI02 z>v2di{yL#8_YWpz0{ZuTy7G(h95r)0Ie90X98Xm-vzx8N6UT+mpy@6b#HOm;&D4@C;tHR6U zIa|>bo8Hw6wp;uHqm0f?A!COX)r^dehYtLqnaCcWp)cSqGyj4g8YwfbKl5#fRnT-g zhU$e>YCd;A6l|m9J@n@}`m^)U`B<22*WmU^x*cS1F^}z~TidHa^CmnyZcUWD@3-HC zfo+HNVRHtGwH!m|R+zP{%^1JUG?pJmu=vxih6Xrh2fg= zC~r+S^*7HDdB|?|qlhUaQmacTj{ON!lNbJ#jy-2#5YV~k922jJ&*% z!+!fhn$1e~UR8{f+vlmoplz6qL%t9B9w*P3srN=vds<6q=7*Ep;ng*s%+R)L2~y2+ z;TQiEm%LIG{FDm8q=11WtHu_)WXN*yh+QiR2AO(5EVNn7d~6mP462Rb*D}ZaS7_g( z6hH14W3{1Wh?f?>eGyt1eKY!OW_iKek~khik4;JqdYLrf>7fP{Y}sVh$)j;Wy8wRX zEm$pppKS})yl%4;O5Q@rQz)`_dEtz9d665lyqFt2OVIERO7{Ehji@d?kK@t!bBJql zI&t-B)Om7hP)(4thu-Iysnj^VamluUR1JEtxF7L`7yAau9XJj9gx`KOxul&S!-rB6 z1~%{W`S$ExL2}PMIgn>i7xU+Dsq-5;F>0GWi&=j`ek-ZP#UQyDA{X{aq|QIOz0SWz zdl8csFS_5hc!WHN}QO=$AQ%j99ZFm`qiBM zx4%i|>^cN<4z%{SB0WeY=!ERWoM>n3vq5MkkM5D*@c|W_{7d+xd)mAwXg-RGd^D`> z7h@w^(6WIl+2f4)Cq!Xd6Z07}J!2E&xMCBwMVRAyoIPV2?0)Xt?Tq^V{sSheSNF(0A;(!k&5=u28v_t)vcxuCQ@IyMPV`s|C>G z8s4Z4*&huQwA&;54Xngb~4-#6Cyy}L>%Pf~dOX440mi1$0}P&D%uVyLZqF|tqe0EbVC#2rfrp<0JLFIc$jA5R7Ww+8#F`)9c?0@_igGaY~+d<|r2DgLkt$B>Wt?k-4 zUV&k|6EAtoZ(ohanDB)u;p?%(eet^F989h;bAV;OWob^sMLz{*HwA6R)!L4;7D&f1 z`ogEeow4w}fc$pL)TBM}Zhf<9VC;jf$mjX3&yl(Cu>@tBmRcRB*gmwBg~#aohf;bw z9njTuoDD?oH3H_ZKBz2BTIP$UKzHh|J=rj4p{e zj>McE5)F=oeIqPS9|!!70W_aBZ(gD{8;LMtZ0^SUS6~*#mkwrLaO3@d!5(B)Wed#K5c^h4IJ&XSj&Wsy8^=+2F>M*2pf-~1Bn)85iJ(cqKxQ>ETZE?bVNq9G>d2;qNN$p=~+Z8M09#abXFG8 zIU;HukebzyMRbXXT0h(WHtzpx%eO?9L#B7@$#V~qC{P{}GkMsVW9diCiyE^}9|I@HOlxKx zxGeowRrsH0-qX+x`I3$C@{I23J)NC6DE23Kn0;*% zeUsjX?!s-xy>cLCtYqKk@LL<&8#u3Z%GyTXM53tkTGOU3-?I1l7s1x{j0n4XxtRHS zw6p8|k3CXCvRv4gIml=am5?GA75i}_Yu*gW>zse-Weyr*&#$mG{g*jG(rgKW z>O&^OX=Mk63N2W_>H?FXoLYA@e9< z{JzbWqTb`&tg^W8an>L$^B#u;(X+&iK6W6fI3@=B0!UWdLirLdFBU$(|1h%AiraLk z=YY0*8O#fG0!!l`o1DdD0Xm7@huDmGN~AVWJ83HD8rfan$Wdmgmxy6xkD$WC=jn8q zF1rnKd~6cfFDdA4`#4F?l!EL8Su4DVoq48tpf}TDDbht=mSbciY>eJ(rl9vsgiWSN z@=-HtHNAIP!bXjn> zJH2?x<9^5M*rn~i14(xGmBJM-SbwG&#J&Q!0+hW7Z}kH{$X6e;OojmZl4j6s-js0} zatS%<7k^@h$?8z{D-_CUTEK22T}Tokhu;$nQ9b z+7LEHUZbzI4+dd<KxG5gK zJtf3e)o!Y-c|Ab2 zH5WvFNJU^zK`%h%B?Fo;s1xT^^w!kAQ9zbYnk<`ol=gc%wOSPq59}XDPg$wO7;9z) ziKXJ`AHRbJ;(hpe(R8?d!)vEcNHyi9cOPp#e8q87k{b>z#UJiyKJQB9o`)_U zK{DTL3A(;Iw6B2Tsqy$4UA{Q9Um9ZI*tOKQGLA!`<|F<6_D4{T3@X@@Ub>h`+%Gm! z5E`SDg&R{7`Ze$CXJ0CiS#U@Sd*d73%QoPP0=!S~huT%wADU}g{6D?Ndjq_%+PLhG z@seFvo#oVtzkdkxpCH3v&VS%cW|1-niWU$I(^x*h-Ge z9np{Fa%?ObD6dWH--l*m&y#o@|Kk8QmEb@MX$(-9!WoVp4)c%?@gt>(tc@cS8Q7? zmKGg7W050^b=kS6T()%1&-VYP_4%iAww$hZxc5DKb1dpjr+bt#9X~oW(Jbemuru(w zjAZhZ936X6$;3~@k95<0fUDl*dt)R^dMGcAd8yZbSGSZ)d0qWLnLus50HsiQQbvH* zbY17F>#jOscc0;6KWeYknbN6TI;Wt+0MYlqBzqi{C3x+^L7Btq( zonMXG7A33elZ)zcSyNQkxL{sUvT^CcCde#oYFw0TTGUuO+#5sE?7rE>H86`8B{4;;vsgZrO&B3~Bt_kF(1 z<2>v7HTPR_eEV^!+>V?Z%wVSa)9JE=Rpj6ZCgZF0n^6=! zkV=q$ci>;BzqR_ooZPEW>*h%Ar_l_u{Ewmj|Jw2gbDASvmd~Z>jdW8VG)M3!fnSa3 z5nLdw<2L2egwl~q|2&g-Lyn17^v(Scchu2Dsh3R*&zOY!6@5E$Z^$8ky<6$qB{piT zt*&XPxqSHf-f*~gQ}yMDm(DYBQ|*!_Z|?lX^|kY>yv5axRo?vSd9@3xyvEu(I~1zC zg|$tK8mheHoa(s{noFapI@yG)1&ij-ZGvpFs;;qmHsbkBjrEk(6j$X9zkK0BZ+PQ^ znraO9;pQ(Uh$>32T3Gw-s=9eiUIsvKRsGzIJk@mM@X_AIGcHQRXH1VxoLn_(jFGPU z;)trb^J{9Cbk9r5wD2gCoNRy|&Bvj73zG|KYO7586^(P7YP(gY8>w0{Z*F(BUe&0% z^&{%)7gRSjR42bx+cbRC=w8?u4|Qy+t*@%9Uf5JMuXbLtVQDX7=Xy1Bk*+H^GCE@T zh~cBi&M@nOc~!~k#-^&sgv8_sY&EaCsfx-qBC5IPj_9sqq!H***XRhZnkL99?{ZAR zRlU^ci@mUMUZx9-+T?s8Y)iccv=VzhfgMYe>QDq(SLvH^~# zS~GIY7kldJX@O|BJY&gj4k9x+XjD%WHK>QNMvcw5a%5ucqB2O0>>?LWoH*^G?uZu3 z?&PBKi@SrKjTosLF`BB<(=!)Yy<6#H$fhGR-EZ$yM~xu^ zch5og?M`~MX-tncjp@;*F+Ex^re_O!)Ytexx6;SQV=zcqrjM5E#v0L*;jwBm( z7wA4!jIz^>>eO*x>{j9^JC|sIaoq*TpxufXcW!q9vTt{RvE2p8+}#DnbQd7&cNgfk zG>jZY&fHDlT&E7!w5k>7I(6t_$#b1L^swZ)z0Ca4b9-@tu|3)7kv&SE8SP=mk%#ove)_%0D{la9jmbN6=eqc*qHn(A&76i56wgtkqXyYte|U#pMfX zmSW@7)L7e;oP#vpR3#Ty*UhabCAi|vQ$uwlGYFv_^GFr#rmm=-Jr~VckesuiW*!fLRc zqwC@G7c|ulzhLSmU%;bJ@>|%V)n2}6Hg;k2YrWyMb7)sL4_A$~_0_}8M$ukoQa*(Z zCk5JbF2}DFKMH5q$nb0E`cw-(=Wu*TYQiw)^e{@>+E4QRD2_@0)%eK+*+k|fe>`7P z6z6N=w6mA+Exs6lnDk4yjxR_*T}yqwr#Q(Azt!P*S89U!QV(gQhvXTjw>a{A>pkXh zoY(@qB+WZ}46D2yvF%T^fyCJ z?C@>HwfuFC{sN=j^W?!<>T?EjI*F!0ob=?fpFF1Y>vEq|T=&cK4wrs;+2PVJM;uOd zpwOQTi6H$b{SsB2>M3@h{}z@4Ma%J%eko@zb{>p03KdFT>!JUOn1a~hJ+A0)mAtmY zdd0P#ZOo_8bND#suR6Sx`5Vlsf2lqa4l9nc=}gGMX$A$d zPYZrx=g%`2KPe_5gt5%UAIuvP@G>P&^Qz3l^oa-skuRl!5WdZvZd>t_au+K-RDY3Q zt~k|6!VO9fb(QG(f#RfRJeT`phku#*?;ZXX<^$P?Vo#~h>55a^Bn)Rx*>!zxRPuEB z8P4z^bFq*34}C#HLF_-m-g2`={e6LZ%- zk10LW)s?KD{=r%b)UFUe(er^LUqeC&$MGaf`pM4Hk0&vA^^_=i8ZTo1Qs&a$dZbaP z&Z4I=i=HbTevs`?|DY@d>33OwL#3bUFLqevaB1%k94_^IPw6K;v+$#E%;8Hc_C8Au zMG(6M_STCkPWF-Yv4T0-ll(kbVKdyVnF^qTIByt z_))lBaT;H%4aHZU%qhxeM$uoHQ+-zAC-wPA=^_2p1_~!|W_Mf^Do(PpPK{BV_8_AF z%Zk&>S>XY5DxUmg2K&j^6qmXn*{gE+2!aT+9nQnwTi|e6r8Hy1Fc`d^7(2Q(%yVAcLb(i&Mu=#G%ju*Wi&1Wv_Q46=XNpV__ ze$9N1(z6mw?0+kBng8Xv{*Ouztw-&wXRFc^Dn0LH(et6=OCc}k3CA4$vThD!L%HkS zXPHZT*KmEl$lUdxSy}YVbM)NCdKPDq|B<6##^X9i&mFAi!7O@ScI4Nw{99S%%lSc! z>_DcH{#wl3?XML|zD>!m&%$>*dZzO@-KXTqC8gYV71#CoNOA3-`6nSW0`(U+(cGV; zIAtw1)bmC&r*`qBNtw(yWC!iHvz4AtunvmmD|zjo9g1uF(7%&Of%Ff;Pulw%=2V|0 z_<7%_Kc2T<@hdDcf8SAhXsn2yT&`S359gW2oXSlp`O6*oi+E^ZwKs z2xK?XFX1GI=W#-UIob0R{G^^U6em3|?ZY30N{7F(&tR|4(J%IFa=6R`-*ve7`fW-- zZ4IP8zfqj(^B$M`JH^|S{Jn~ky!88{%*j5wzxFCletYC5{6YAe(nFV0pZAr#_McPu z#RrXFd8b5r&SFk>)_xvUT-S3NbE>DQ&m_`<{cjfiS13JtT&z%B>%YO#zofzH|Fa{X zZ?U(<;j&NI>2R^nOG-bLEBm5@ij&>M505BL@}nNvT~rHtz+bDFRCRVc1J?<cT;y+5{07Jizgcmzzs&zXRh;T0^1oD^$`$^5#pzP`2E|E_%!fM^ zCq2SDT9nYZce~-d`xb9Oczep$IQ1{d#`xLybY8_AbRwo{xqz zCx4c2MR4hjR(uEn4pW#@tykhF{rgQN|7j6M{B0$#_sL6{Q+>4EI+UKzC_T4i(Q~__ zN9=r`(sR1fvm=Y1-HsmVmsgaYBBkg3EP5ug5v5&{WwOI%zkRX8WgWTH;j4Imo^-g> z>01t8EBkqekKhV@$KmT(zS-g4i#9`>!G z?{GO+{FB4ivHTMb7yCc&aIyc(4wv@6>2PUpe;y3v|1?j^JW%LxnXgWDxQv(2F_-y= zrzvlg!;829UvjwYf6jM!!1lbv;nSJdDt-lY=du2IiZ27JVELsEmvy$);j+%&=x|w2 zA9uL4_qiSg24?A4!b1Vz*$CDJF@@& z+c^%G^=Q1qWj%^JT-KwjnbZ7yCEI|aX2q#K5>_%N|GXYQ@wX1e^>;zPak%KY-{IoV zI~^|m^D=X?C+QdYw;axof!+rWk4V8h>5HDx%m+GL^q=N%(f>Jzi~i9L7yXkQF8V8& zlRc?jvgupwaQQB-)!})(9^dZh7k;P12ebSi9bU}5)8XTo?{v86f5zdW|5b;J{`VX% z`cL3RRQg5qPg7j4<6m>Qtjkpnmvy#Yaq?#wFHH`Y@v_X}GG02EQ-9HTk@rMD%EE6~ zoXRc3kHT*pp0L>agTse0|Fgrz54Sjc2+QwsxQx@i%*oDrT<>$ZjJwwyJ>usF9X^B0 zJ>u~3%)KIe;jU|W%%wiEKRMZvm-c>I@iU-O+7(fp+BF0}3TGFY$efE3m-k;7>WQyAv(RTg`r9exM%GKY6EPdI!p^9qL_ zWIoH`@;$~%#mP^kT|djhf2Fu?Z>Qo~&(m4>iw+n2?{~P^|NSid#4~LJ-F`X6;iCUy z<}x1Td3=Gx#m}#BxQvTy94_PNCgxNhz5lsIak7u>)9!G1k!_CmCx;g^-{f%FH$Lfb z**Cu7aM?G0=HIMBs^?Ys$$3z92Mi%}JhfBL^v+yev*Y<2toa!m- z+KmpEb?wIvmv!w$#c7PnJp2mtzF_*i@h!#ALz?va2U&Pp@lqw9#}hK?*Ln&R*Yc-k z;b&&yLz%n%J4$iWUOsP}>2Nu3T;y;$Z@kXoa^Cn0#dW`|bGY=&y$%{xZMSDo*tgJ@XZ(a)n=^xVA&9;-n`RKMESK9_O5+2P_p&p2HC;egVw?Ri9Ts*l+Dl+WS@fy!NipPVObIhvH@w)N+QmE^U*l`yCNjj=367ci%OoT&IE zN}fLzF{zbG|4IvjqtoXB8^n9%J$TK%( z8~k~jne0z~C39SaIobabD`NgenY(_KP2zb{<&P~sZjDAO3zHi zf0RYf-Ad2bmHbAf=TgNV%cAE=#r1yRZN)30N9zBXv#nCHn_hQ@Gbg*XDf!E?@b54m zzh>^VvC%M|}QbE*&RH{|=Yq~i3vBjLwNPdlLKze~v* zJ)Gf~l20l5!Y^0>DOcXte1SQ&OZ&;3Ed1L_57kr7Tb3yKDpl@vj=Ze}d`Zb`fB1JL zul?|kic>x1T&UCGaxV0w!{t2c1&7Od)Io9?FUp+yh2+JaF^9|f*kp&x82Gl*UkyD{pDPt7{qo(~HHx<>`4x(jygWzz zkU7;;_sgw{lOM`=Yj-I<+W#L=^4fo1V@~7xllVz^Q|ZzE|B>Rlo}WC&=A?R>`b@I- z%9-=}?5$FloOs(`d5NU{XbChQWwf{Ov&r@tN#eAFk`oy?ENXssXp?ILMdNhPIl9J#wh+h zr15m*ec9E|--}+X^w*MN4woxETK_i{*ZLbB{Y&_HZ>7>-C(053Ko<2ss&# zcPl-!m7Yym^gN`v_Rl>^zaB4dEB$kn{=-U-uIDkuwH=NhX)|Z~k^O%NbLz*rO8?o+ z-F}QJuJxBV`ej^PsPunR>7S+a==y(Gac!S9itF)p2XlA+S*PTeqg?Uz&5G-B_bhX= z!?#pD4=DY5JbtL;3n5?6dCnYVFUW3s+P=@(g&ELZZ{4z-H6K~Bc+ca)xaq=3Wq zN?z;vq2k|ztc<($%rpML<8Cu^s^@%Bj`(4vN9+HK;@?yHpJy)mW!$~Xob)eH`uj%h zjq7hCn3Ep8E?lBG`H8%znB{Oe=b!Cxd5>_r!$nWgXj>mDSL-jy!Y|Fj+q3YS94__z zvBRaFzskZNbhy-iyTe8QyUfYXdVGCpOjmnp9hdX}35wqcF7w_D#c96E`@YRzsW{26 zwb-jsob*?$unF~wYyC}%Q@_jp>T1QQ+yX9lh2py04#i1Nfi2eix#CnGc^=Q`Kc$Kb?iYrFesqKdLzCmvhuUV{wB(`oE2z=+9G} z>Y2-S!@vAxf{at?$MK45`>USyL!x)s|K+DCs7gv&pO zyq5C`-^J&2^#8NnO`hi?^M9bH^c>`IJHiH=>0kf*31sDxyD2HN=gu6*+RWbW{0`m?!yHISFq0H2Y9~ zxBP-hfC&32QH3IPO_z7#M= nres, n_start < n_end) -c NOTE: this move should never increase the energy -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.HEADER' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - -c External functions - integer iran_num - external iran_num - -c Input arguments - integer n_start,n_end,n_maxtry - double precision e_drop - -c Output arguments - integer n_fun - double precision etot - -c Local variables - double precision energy(0:n_ene) - double precision cur_alph(2:nres-1),cur_omeg(2:nres-1) - double precision orig_e,cur_e - integer n,n_steps,n_first,n_cur,n_tot,i - double precision orig_w(n_ene) - double precision wtime - - -c Set non side-chain weights to zero (minimization is faster) -c NOTE: e(2) does not actually depend on the side-chain, only CA - orig_w(2)=wscp - orig_w(3)=welec - orig_w(4)=wcorr - orig_w(5)=wcorr5 - orig_w(6)=wcorr6 - orig_w(7)=wel_loc - orig_w(8)=wturn3 - orig_w(9)=wturn4 - orig_w(10)=wturn6 - orig_w(11)=wang - orig_w(13)=wtor - orig_w(14)=wtor_d - orig_w(15)=wvdwpp - - wscp=0.D0 - welec=0.D0 - wcorr=0.D0 - wcorr5=0.D0 - wcorr6=0.D0 - wel_loc=0.D0 - wturn3=0.D0 - wturn4=0.D0 - wturn6=0.D0 - wang=0.D0 - wtor=0.D0 - wtor_d=0.D0 - wvdwpp=0.D0 - -c Make sure n_start, n_end are within proper range - if (n_start.lt.2) n_start=2 - if (n_end.gt.nres-1) n_end=nres-1 -crc if (n_start.lt.n_end) then - if (n_start.gt.n_end) then - n_start=2 - n_end=nres-1 - endif - -c Save the initial values of energy and coordinates -cd call chainbuild -cd call etotal(energy) -cd write (iout,*) 'start sc ene',energy(0) -cd call enerprint(energy(0)) -crc etot=energy(0) - n_fun=0 -crc orig_e=etot -crc cur_e=orig_e -crc do i=2,nres-1 -crc cur_alph(i)=alph(i) -crc cur_omeg(i)=omeg(i) -crc enddo - -ct wtime=MPI_WTIME() -c Try (one by one) all specified residues, starting from a -c random position in sequence -c Stop early if the energy has decreased by at least e_drop - n_tot=n_end-n_start+1 - n_first=iran_num(0,n_tot-1) - n_steps=0 - n=0 -crc do while (n.lt.n_tot .and. orig_e-etot.lt.e_drop) - do while (n.lt.n_tot) - n_cur=n_start+mod(n_first+n,n_tot) - call single_sc_move(n_cur,n_maxtry,e_drop, - + n_steps,n_fun,etot) -c If a lower energy was found, update the current structure... -crc if (etot.lt.cur_e) then -crc cur_e=etot -crc do i=2,nres-1 -crc cur_alph(i)=alph(i) -crc cur_omeg(i)=omeg(i) -crc enddo -crc else -c ...else revert to the previous one -crc etot=cur_e -crc do i=2,nres-1 -crc alph(i)=cur_alph(i) -crc omeg(i)=cur_omeg(i) -crc enddo -crc endif - n=n+1 -cd -cd call chainbuild -cd call etotal(energy) -cd print *,'running',n,energy(0) - enddo - -cd call chainbuild -cd call etotal(energy) -cd write (iout,*) 'end sc ene',energy(0) - -c Put the original weights back to calculate the full energy - wscp=orig_w(2) - welec=orig_w(3) - wcorr=orig_w(4) - wcorr5=orig_w(5) - wcorr6=orig_w(6) - wel_loc=orig_w(7) - wturn3=orig_w(8) - wturn4=orig_w(9) - wturn6=orig_w(10) - wang=orig_w(11) - wtor=orig_w(13) - wtor_d=orig_w(14) - wvdwpp=orig_w(15) - -crc n_fun=n_fun+1 -ct write (iout,*) 'sc_local time= ',MPI_WTIME()-wtime - return - end - -c------------------------------------------------------------- - - subroutine single_sc_move(res_pick,n_maxtry,e_drop, - + n_steps,n_fun,e_sc) -c Perturb one side-chain (res_pick) and minimize the -c neighbouring region, keeping all CA's and non-neighbouring -c side-chains fixed -c Try until e_drop energy improvement is achieved, or n_maxtry -c attempts have been made -c At the start, e_sc should contain the side-chain-only energy(0) -c nsteps and nfun for this move are ADDED to n_steps and n_fun -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.CHAIN' - include 'COMMON.MINIM' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - -c External functions - double precision dist - external dist - -c Input arguments - integer res_pick,n_maxtry - double precision e_drop - -c Input/Output arguments - integer n_steps,n_fun - double precision e_sc - -c Local variables - logical fail - integer i,j - integer nres_moved - integer iretcode,loc_nfun,orig_maxfun,n_try - double precision sc_dist,sc_dist_cutoff - double precision energy(0:n_ene),orig_e,cur_e - double precision evdw,escloc - double precision cur_alph(2:nres-1),cur_omeg(2:nres-1) - double precision var(maxvar) - - double precision orig_theta(1:nres),orig_phi(1:nres), - + orig_alph(1:nres),orig_omeg(1:nres) - - -c Define what is meant by "neighbouring side-chain" - sc_dist_cutoff=5.0D0 - -c Don't do glycine or ends - i=itype(res_pick) - if (i.eq.10 .or. i.eq.ntyp1) return - -c Freeze everything (later will relax only selected side-chains) - mask_r=.true. - do i=1,nres - mask_phi(i)=0 - mask_theta(i)=0 - mask_side(i)=0 - enddo - -c Find the neighbours of the side-chain to move -c and save initial variables -crc orig_e=e_sc -crc cur_e=orig_e - nres_moved=0 - do i=2,nres-1 -c Don't do glycine (itype(j)==10) - if (itype(i).ne.10) then - sc_dist=dist(nres+i,nres+res_pick) - else - sc_dist=sc_dist_cutoff - endif - if (sc_dist.lt.sc_dist_cutoff) then - nres_moved=nres_moved+1 - mask_side(i)=1 - cur_alph(i)=alph(i) - cur_omeg(i)=omeg(i) - endif - enddo - - call chainbuild - call egb1(evdw) - call esc(escloc) - e_sc=wsc*evdw+wscloc*escloc -cd call etotal(energy) -cd print *,'new ',(energy(k),k=0,n_ene) - orig_e=e_sc - cur_e=orig_e - - n_try=0 - do while (n_try.lt.n_maxtry .and. orig_e-cur_e.lt.e_drop) -c Move the selected residue (don't worry if it fails) - call gen_side(iabs(itype(res_pick)),theta(res_pick+1), - + alph(res_pick),omeg(res_pick),fail) - -c Minimize the side-chains starting from the new arrangement - call geom_to_var(nvar,var) - orig_maxfun=maxfun - maxfun=7 - -crc do i=1,nres -crc orig_theta(i)=theta(i) -crc orig_phi(i)=phi(i) -crc orig_alph(i)=alph(i) -crc orig_omeg(i)=omeg(i) -crc enddo - - call minimize_sc1(e_sc,var,iretcode,loc_nfun) - -cv write(*,'(2i3,2f12.5,2i3)') -cv & res_pick,nres_moved,orig_e,e_sc-cur_e, -cv & iretcode,loc_nfun - -c$$$ if (iretcode.eq.8) then -c$$$ write(iout,*)'Coordinates just after code 8' -c$$$ call chainbuild -c$$$ call all_varout -c$$$ call flush(iout) -c$$$ do i=1,nres -c$$$ theta(i)=orig_theta(i) -c$$$ phi(i)=orig_phi(i) -c$$$ alph(i)=orig_alph(i) -c$$$ omeg(i)=orig_omeg(i) -c$$$ enddo -c$$$ write(iout,*)'Coordinates just before code 8' -c$$$ call chainbuild -c$$$ call all_varout -c$$$ call flush(iout) -c$$$ endif - - n_fun=n_fun+loc_nfun - maxfun=orig_maxfun - call var_to_geom(nvar,var) - -c If a lower energy was found, update the current structure... - if (e_sc.lt.cur_e) then -cv call chainbuild -cv call etotal(energy) -cd call egb1(evdw) -cd call esc(escloc) -cd e_sc1=wsc*evdw+wscloc*escloc -cd print *,' new',e_sc1,energy(0) -cv print *,'new ',energy(0) -cd call enerprint(energy(0)) - cur_e=e_sc - do i=2,nres-1 - if (mask_side(i).eq.1) then - cur_alph(i)=alph(i) - cur_omeg(i)=omeg(i) - endif - enddo - else -c ...else revert to the previous one - e_sc=cur_e - do i=2,nres-1 - if (mask_side(i).eq.1) then - alph(i)=cur_alph(i) - omeg(i)=cur_omeg(i) - endif - enddo - endif - n_try=n_try+1 - - enddo - n_steps=n_steps+n_try - -c Reset the minimization mask_r to false - mask_r=.false. - - return - end - -c------------------------------------------------------------- - - subroutine sc_minimize(etot,iretcode,nfun) -c Minimizes side-chains only, leaving backbone frozen -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - -c Output arguments - double precision etot - integer iretcode,nfun - -c Local variables - integer i - double precision orig_w(n_ene),energy(0:n_ene) - double precision var(maxvar) - - -c Set non side-chain weights to zero (minimization is faster) -c NOTE: e(2) does not actually depend on the side-chain, only CA - orig_w(2)=wscp - orig_w(3)=welec - orig_w(4)=wcorr - orig_w(5)=wcorr5 - orig_w(6)=wcorr6 - orig_w(7)=wel_loc - orig_w(8)=wturn3 - orig_w(9)=wturn4 - orig_w(10)=wturn6 - orig_w(11)=wang - orig_w(13)=wtor - orig_w(14)=wtor_d - - wscp=0.D0 - welec=0.D0 - wcorr=0.D0 - wcorr5=0.D0 - wcorr6=0.D0 - wel_loc=0.D0 - wturn3=0.D0 - wturn4=0.D0 - wturn6=0.D0 - wang=0.D0 - wtor=0.D0 - wtor_d=0.D0 - -c Prepare to freeze backbone - do i=1,nres - mask_phi(i)=0 - mask_theta(i)=0 - mask_side(i)=1 - enddo - -c Minimize the side-chains - mask_r=.true. - call geom_to_var(nvar,var) - call minimize(etot,var,iretcode,nfun) - call var_to_geom(nvar,var) - mask_r=.false. - -c Put the original weights back and calculate the full energy - wscp=orig_w(2) - welec=orig_w(3) - wcorr=orig_w(4) - wcorr5=orig_w(5) - wcorr6=orig_w(6) - wel_loc=orig_w(7) - wturn3=orig_w(8) - wturn4=orig_w(9) - wturn6=orig_w(10) - wang=orig_w(11) - wtor=orig_w(13) - wtor_d=orig_w(14) - - call chainbuild - call etotal(energy) - etot=energy(0) - - return - end - -c------------------------------------------------------------- - subroutine minimize_sc1(etot,x,iretcode,nfun) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.MINIM' - common /srutu/ icall - dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) - double precision energia(0:n_ene) - external func,gradient,fdum - external func_restr1,grad_restr1 - logical not_done,change,reduce - common /przechowalnia/ v - - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit -c iv(21)=iout - iv(21)=0 -* 1 means to print out result - iv(22)=0 -* 1 means to print out summary stats - iv(23)=0 -* 1 means to print initial x and d - iv(24)=0 -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -c v(25)=4.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo - IF (mask_r) THEN - call x2xx(x,xx,nvar_restr) - call sumsl(nvar_restr,d,xx,func_restr1,grad_restr1, - & iv,liv,lv,v,idum,rdum,fdum) - call xx2x(x,xx) - ELSE - call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) - ENDIF - etot=v(10) - iretcode=iv(1) - nfun=iv(6) - - return - end -************************************************************************ - subroutine func_restr1(n,x,nf,f,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - include 'COMMON.INTERACT' - include 'COMMON.TIME1' - common /chuju/ jjj - double precision energia(0:n_ene),evdw,escloc - integer jjj - double precision ufparm,e1,e2 - external ufparm - integer uiparm(1) - real*8 urparm(1) - dimension x(maxvar) - nfl=nf - icg=mod(nf,2)+1 - -#ifdef OSF -c Intercept NaNs in the coordinates, before calling etotal - x_sum=0.D0 - do i=1,n - x_sum=x_sum+x(i) - enddo - FOUND_NAN=.false. - if (x_sum.ne.x_sum) then - write(iout,*)" *** func_restr1 : Found NaN in coordinates" - f=1.0D+73 - FOUND_NAN=.true. - return - endif -#endif - - call var_to_geom_restr(n,x) - call zerograd - call chainbuild -cd write (iout,*) 'ETOTAL called from FUNC' - call egb1(evdw) - call esc(escloc) - f=wsc*evdw+wscloc*escloc -cd call etotal(energia(0)) -cd f=wsc*energia(1)+wscloc*energia(12) -cd print *,f,evdw,escloc,energia(0) -C -C Sum up the components of the Cartesian gradient. -C - do i=1,nct - do j=1,3 - gradx(j,i,icg)=wsc*gvdwx(j,i) - enddo - enddo - - return - end -c------------------------------------------------------- - subroutine grad_restr1(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - external ufparm - integer uiparm(1) - double precision urparm(1) - dimension x(maxvar),g(maxvar) - - icg=mod(nf,2)+1 - if (nf-nfl+1) 20,30,40 - 20 call func_restr1(n,x,nf,f,uiparm,urparm,ufparm) -c write (iout,*) 'grad 20' - if (nf.eq.0) return - goto 40 - 30 call var_to_geom_restr(n,x) - call chainbuild -C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartder -C -C Convert the Cartesian gradient into internal-coordinate gradient. -C - - ig=0 - ind=nres-2 - do i=2,nres-2 - IF (mask_phi(i+2).eq.1) THEN - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) - enddo - enddo - ig=ig+1 - g(ig)=gphii - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - - ind=0 - do i=1,nres-2 - IF (mask_theta(i+2).eq.1) THEN - ig=ig+1 - gthetai=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) - enddo - enddo - g(ig)=gthetai - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - galphai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - g(ig)=galphai - ENDIF - endif - enddo - - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - gomegai=0.0D0 - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ig)=gomegai - ENDIF - endif - enddo - -C -C Add the components corresponding to local energy terms. -C - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - endif - enddo - enddo - -cd do i=1,ig -cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) -cd enddo - return - end -C----------------------------------------------------------------------------- - subroutine egb1(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - include 'COMMON.CONTROL' - logical lprn - evdw=0.0D0 -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.true. - ind=0 - do i=iatsc_s,iatsc_e - - - itypi=iabs(itype(i)) - itypi1=iabs(itype(i+1)) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) - dsci_inv=dsc_inv(itypi) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN - ind=ind+1 - itypj=iabs(itype(j)) - dscj_inv=dsc_inv(itypj) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) -C For diagnostics only!!! -c chi1=0.0D0 -c chi2=0.0D0 -c chi12=0.0D0 -c chip1=0.0D0 -c chip2=0.0D0 -c chip12=0.0D0 -c alf1=0.0D0 -c alf2=0.0D0 -c alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 -cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & epsi,sigm,chi1,chi2,chip1,chip2, -cd & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, -cd & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, -cd & evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij - -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad - ENDIF - enddo ! j - enddo ! iint - enddo ! i - end -C----------------------------------------------------------------------------- diff --git a/source/unres/src_MD-M-newcorr/select.tau b/source/unres/src_MD-M-newcorr/select.tau deleted file mode 100644 index a91c73b..0000000 --- a/source/unres/src_MD-M-newcorr/select.tau +++ /dev/null @@ -1,81 +0,0 @@ -BEGIN_FILE_INCLUDE_LIST -add.* -arcos.* -banach.* -bank.* -blas.* -bond_move.* -cartder.* -cartprint.* -chainbuild.* -check_bond.* -checkder_p.* -check_sc_distr.* -cinfo.* -compare_s1.* -contact.* -convert.* -cored.* -csa.* -diff12.* -dihed_cons.* -distfit.* -djacob.* -econstr_local.* -eigen.* -elecont.* -energy_p_new.* -energy_p_new-sep.* -energy_split-sep.* -entmcm.* -fitsq.* -gauss.* -geomout.* -gnmr1.* -gradient_p.* -indexx.* -initialize_p.* -intcartderiv.* -intcor.* -intlocal.* -int_to_cart.* -kinetic_lesyng.* -lagrangian_lesyng.* -local_move.* -map.* -matmult.* -mcm.* -mc.* -MD_A-MTS.* -minimize_p.* -minim_jlee.* -minim_mcmf.* -misc.* -moments.* -MP.* -MREMD.* -muca_md.* -newconf.* -parmread.* -pinorm.* -printmat.* -q_measure.* -rattle.* -readpdb.* -refsys.* -regularize.* -rescode.* -rmdd.* -rmsd.* -sc_move.* -shift.* -sort.* -stochfric.* -sumsld.* -surfatom.* -test.* -thread.* -timing.* -together.* -unres.* -END_FILE_INCLUDE_LIST diff --git a/source/unres/src_MD-M-newcorr/shift.F b/source/unres/src_MD-M-newcorr/shift.F deleted file mode 100644 index 6eb9b3f..0000000 --- a/source/unres/src_MD-M-newcorr/shift.F +++ /dev/null @@ -1,105 +0,0 @@ -c--------------------------------- - subroutine csa_read - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.IOUNITS' - - open(icsa_in,file=csa_in,status="old",err=100) - read(icsa_in,*) nconf - read(icsa_in,*) jstart,jend - read(icsa_in,*) nstmax - read(icsa_in,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 - read(icsa_in,*) nran0,nran1,irr - read(icsa_in,*) nseed - read(icsa_in,*) ntotal,cut1,cut2 - read(icsa_in,*) estop - read(icsa_in,*) icmax,irestart - read(icsa_in,*) ntbankm,dele,difcut - read(icsa_in,*) iref,rmscut,pnccut - read(icsa_in,*) ndiff - close(icsa_in) - - return - - 100 continue - return - end -c--------------------------------- - subroutine initial_write - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.IOUNITS' - - open(icsa_seed,file=csa_seed,status="unknown") - write(icsa_seed,*) "seed" - close(31) -#if defined(AIX) || defined(PGI) - open(icsa_history,file=csa_history,status="unknown", - & position="append") -#else - open(icsa_history,file=csa_history,status="unknown", - & access="append") -#endif - write(icsa_history,*) nconf - write(icsa_history,*) jstart,jend - write(icsa_history,*) nstmax - write(icsa_history,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 - write(icsa_history,*) nran0,nran1,irr - write(icsa_history,*) nseed - write(icsa_history,*) ntotal,cut1,cut2 - write(icsa_history,*) estop - write(icsa_history,*) icmax,irestart - write(icsa_history,*) ntbankm,dele,difcut - write(icsa_history,*) iref,rmscut,pnccut - write(icsa_history,*) ndiff - - write(icsa_history,*) - close(icsa_history) - - open(icsa_bank1,file=csa_bank1,status="unknown") - write(icsa_bank1,*) 0 - close(icsa_bank1) - - return - end -c--------------------------------- - subroutine restart_write - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - -#if defined(AIX) || defined(PGI) - open(icsa_history,file=csa_history,position="append") -#else - open(icsa_history,file=csa_history,access="append") -#endif - write(icsa_history,*) - write(icsa_history,*) "This is restart" - write(icsa_history,*) - write(icsa_history,*) nconf - write(icsa_history,*) jstart,jend - write(icsa_history,*) nstmax - write(icsa_history,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 - write(icsa_history,*) nran0,nran1,irr - write(icsa_history,*) nseed - write(icsa_history,*) ntotal,cut1,cut2 - write(icsa_history,*) estop - write(icsa_history,*) icmax,irestart - write(icsa_history,*) ntbankm,dele,difcut - write(icsa_history,*) iref,rmscut,pnccut - write(icsa_history,*) ndiff - write(icsa_history,*) - write(icsa_history,*) "irestart is: ", irestart - - write(icsa_history,*) - close(icsa_history) - - return - end -c--------------------------------- diff --git a/source/unres/src_MD-M-newcorr/sizes.i b/source/unres/src_MD-M-newcorr/sizes.i deleted file mode 100644 index 45c44ff..0000000 --- a/source/unres/src_MD-M-newcorr/sizes.i +++ /dev/null @@ -1,83 +0,0 @@ -c -c -c ################################################### -c ## COPYRIGHT (C) 1992 by Jay William Ponder ## -c ## All Rights Reserved ## -c ################################################### -c -c ############################################################# -c ## ## -c ## sizes.i -- parameter values to set array dimensions ## -c ## ## -c ############################################################# -c -c -c "sizes.i" sets values for critical array dimensions used -c throughout the software; these parameters will fix the size -c of the largest systems that can be handled; values too large -c for the computer's memory and/or swap space to accomodate -c will result in poor performance or outright failure -c -c parameter: maximum allowed number of: -c -c maxatm atoms in the molecular system -c maxval atoms directly bonded to an atom -c maxgrp user-defined groups of atoms -c maxtyp force field atom type definitions -c maxclass force field atom class definitions -c maxkey lines in the keyword file -c maxrot bonds for torsional rotation -c maxvar optimization variables (vector storage) -c maxopt optimization variables (matrix storage) -c maxhess off-diagonal Hessian elements -c maxlight sites for method of lights neighbors -c maxvib vibrational frequencies -c maxgeo distance geometry points -c maxcell unit cells in replicated crystal -c maxring 3-, 4-, or 5-membered rings -c maxfix geometric restraints -c maxbio biopolymer atom definitions -c maxres residues in the macromolecule -c maxamino amino acid residue types -c maxnuc nucleic acid residue types -c maxbnd covalent bonds in molecular system -c maxang bond angles in molecular system -c maxtors torsional angles in molecular system -c maxpi atoms in conjugated pisystem -c maxpib covalent bonds involving pisystem -c maxpit torsional angles involving pisystem -c -c - integer maxatm,maxval,maxgrp - integer maxtyp,maxclass,maxkey - integer maxrot,maxopt - integer maxhess,maxlight,maxvib - integer maxgeo,maxcell,maxring - integer maxfix,maxbio - integer maxamino,maxnuc,maxbnd - integer maxang,maxtors,maxpi - integer maxpib,maxpit - parameter (maxatm=maxres2) - parameter (maxval=8) - parameter (maxgrp=1000) - parameter (maxtyp=3000) - parameter (maxclass=500) - parameter (maxkey=10000) - parameter (maxrot=1000) - parameter (maxopt=1000) - parameter (maxhess=1000000) - parameter (maxlight=8*maxatm) - parameter (maxvib=1000) - parameter (maxgeo=1000) - parameter (maxcell=10000) - parameter (maxring=10000) - parameter (maxfix=10000) - parameter (maxbio=10000) - parameter (maxamino=31) - parameter (maxnuc=12) - parameter (maxbnd=2*maxatm) - parameter (maxang=3*maxatm) - parameter (maxtors=4*maxatm) - parameter (maxpi=100) - parameter (maxpib=2*maxpi) - parameter (maxpit=4*maxpi) diff --git a/source/unres/src_MD-M-newcorr/sort.f b/source/unres/src_MD-M-newcorr/sort.f deleted file mode 100644 index 46b43d9..0000000 --- a/source/unres/src_MD-M-newcorr/sort.f +++ /dev/null @@ -1,589 +0,0 @@ -c -c -c ################################################### -c ## COPYRIGHT (C) 1990 by Jay William Ponder ## -c ## All Rights Reserved ## -c ################################################### -c -c ######################################################### -c ## ## -c ## subroutine sort -- heapsort of an integer array ## -c ## ## -c ######################################################### -c -c -c "sort" takes an input list of integers and sorts it -c into ascending order using the Heapsort algorithm -c -c - subroutine sort (n,list) - implicit none - integer i,j,k,n - integer index,lists - integer list(*) -c -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end -c -c -c ############################################################## -c ## ## -c ## subroutine sort2 -- heapsort of real array with keys ## -c ## ## -c ############################################################## -c -c -c "sort2" takes an input list of reals and sorts it -c into ascending order using the Heapsort algorithm; -c it also returns a key into the original ordering -c -c - subroutine sort2 (n,list,key) - implicit none - integer i,j,k,n - integer index,keys - integer key(*) - real*8 lists - real*8 list(*) -c -c -c initialize index into the original ordering -c - do i = 1, n - key(i) = i - end do -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - keys = key(k) - else - lists = list(index) - keys = key(index) - list(index) = list(1) - key(index) = key(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - key(1) = keys - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - key(i) = key(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - key(i) = keys - end do - return - end -c -c -c ################################################################# -c ## ## -c ## subroutine sort3 -- heapsort of integer array with keys ## -c ## ## -c ################################################################# -c -c -c "sort3" takes an input list of integers and sorts it -c into ascending order using the Heapsort algorithm; -c it also returns a key into the original ordering -c -c - subroutine sort3 (n,list,key) - implicit none - integer i,j,k,n - integer index - integer lists - integer keys - integer list(*) - integer key(*) -c -c -c initialize index into the original ordering -c - do i = 1, n - key(i) = i - end do -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - keys = key(k) - else - lists = list(index) - keys = key(index) - list(index) = list(1) - key(index) = key(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - key(1) = keys - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - key(i) = key(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - key(i) = keys - end do - return - end -c -c -c ################################################################# -c ## ## -c ## subroutine sort4 -- heapsort of integer absolute values ## -c ## ## -c ################################################################# -c -c -c "sort4" takes an input list of integers and sorts it into -c ascending absolute value using the Heapsort algorithm -c -c - subroutine sort4 (n,list) - implicit none - integer i,j,k,n - integer index - integer lists - integer list(*) -c -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (abs(list(j)) .lt. abs(list(j+1))) j = j + 1 - end if - if (abs(lists) .lt. abs(list(j))) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end -c -c -c ################################################################ -c ## ## -c ## subroutine sort5 -- heapsort of integer array modulo m ## -c ## ## -c ################################################################ -c -c -c "sort5" takes an input list of integers and sorts it -c into ascending order based on each value modulo "m" -c -c - subroutine sort5 (n,list,m) - implicit none - integer i,j,k,m,n - integer index,smod - integer jmod,j1mod - integer lists - integer list(*) -c -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - jmod = mod(list(j),m) - j1mod = mod(list(j+1),m) - if (jmod .lt. j1mod) then - j = j + 1 - else if (jmod.eq.j1mod .and. list(j).lt.list(j+1)) then - j = j + 1 - end if - end if - smod = mod(lists,m) - jmod = mod(list(j),m) - if (smod .lt. jmod) then - list(i) = list(j) - i = j - j = j + j - else if (smod.eq.jmod .and. lists.lt.list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end -c -c -c ############################################################# -c ## ## -c ## subroutine sort6 -- heapsort of a text string array ## -c ## ## -c ############################################################# -c -c -c "sort6" takes an input list of character strings and sorts -c it into alphabetical order using the Heapsort algorithm -c -c - subroutine sort6 (n,list) - implicit none - integer i,j,k,n - integer index - character*256 lists - character*(*) list(*) -c -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end -c -c -c ################################################################ -c ## ## -c ## subroutine sort7 -- heapsort of text strings with keys ## -c ## ## -c ################################################################ -c -c -c "sort7" takes an input list of character strings and sorts it -c into alphabetical order using the Heapsort algorithm; it also -c returns a key into the original ordering -c -c - subroutine sort7 (n,list,key) - implicit none - integer i,j,k,n - integer index - integer keys - integer key(*) - character*256 lists - character*(*) list(*) -c -c -c initialize index into the original ordering -c - do i = 1, n - key(i) = i - end do -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - keys = key(k) - else - lists = list(index) - keys = key(index) - list(index) = list(1) - key(index) = key(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - key(1) = keys - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - key(i) = key(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - key(i) = keys - end do - return - end -c -c -c ######################################################### -c ## ## -c ## subroutine sort8 -- heapsort to unique integers ## -c ## ## -c ######################################################### -c -c -c "sort8" takes an input list of integers and sorts it into -c ascending order using the Heapsort algorithm, duplicate -c values are removed from the final sorted list -c -c - subroutine sort8 (n,list) - implicit none - integer i,j,k,n - integer index - integer lists - integer list(*) -c -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists -c -c remove duplicate values from final list -c - j = 1 - do i = 2, n - if (list(i-1) .ne. list(i)) then - j = j + 1 - list(j) = list(i) - end if - end do - if (j .lt. n) n = j - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end -c -c -c ############################################################# -c ## ## -c ## subroutine sort9 -- heapsort to unique text strings ## -c ## ## -c ############################################################# -c -c -c "sort9" takes an input list of character strings and sorts -c it into alphabetical order using the Heapsort algorithm, -c duplicate values are removed from the final sorted list -c -c - subroutine sort9 (n,list) - implicit none - integer i,j,k,n - integer index - character*256 lists - character*(*) list(*) -c -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists -c -c remove duplicate values from final list -c - j = 1 - do i = 2, n - if (list(i-1) .ne. list(i)) then - j = j + 1 - list(j) = list(i) - end if - end do - if (j .lt. n) n = j - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end diff --git a/source/unres/src_MD-M-newcorr/ssMD.F b/source/unres/src_MD-M-newcorr/ssMD.F deleted file mode 100644 index 15800ae..0000000 --- a/source/unres/src_MD-M-newcorr/ssMD.F +++ /dev/null @@ -1,1951 +0,0 @@ -c---------------------------------------------------------------------------- - subroutine check_energies -c implicit none - -c Includes - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.SBRIDGE' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - -c External functions - double precision ran_number - external ran_number - -c Local variables - integer i,j,k,l,lmax,p,pmax - double precision rmin,rmax - double precision eij - - double precision d - double precision wi,rij,tj,pj - - -c return - - i=5 - j=14 - - d=dsc(1) - rmin=2.0D0 - rmax=12.0D0 - - lmax=10000 - pmax=1 - - do k=1,3 - c(k,i)=0.0D0 - c(k,j)=0.0D0 - c(k,nres+i)=0.0D0 - c(k,nres+j)=0.0D0 - enddo - - do l=1,lmax - -ct wi=ran_number(0.0D0,pi) -c wi=ran_number(0.0D0,pi/6.0D0) -c wi=0.0D0 -ct tj=ran_number(0.0D0,pi) -ct pj=ran_number(0.0D0,pi) -c pj=ran_number(0.0D0,pi/6.0D0) -c pj=0.0D0 - - do p=1,pmax -ct rij=ran_number(rmin,rmax) - - c(1,j)=d*sin(pj)*cos(tj) - c(2,j)=d*sin(pj)*sin(tj) - c(3,j)=d*cos(pj) - - c(3,nres+i)=-rij - - c(1,i)=d*sin(wi) - c(3,i)=-rij-d*cos(wi) - - do k=1,3 - dc(k,nres+i)=c(k,nres+i)-c(k,i) - dc_norm(k,nres+i)=dc(k,nres+i)/d - dc(k,nres+j)=c(k,nres+j)-c(k,j) - dc_norm(k,nres+j)=dc(k,nres+j)/d - enddo - - call dyn_ssbond_ene(i,j,eij) - enddo - enddo - - call exit(1) - - return - end - -C----------------------------------------------------------------------------- - - subroutine dyn_ssbond_ene(resi,resj,eij) -c implicit none - -c Includes - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' -#ifndef CLUST -#ifndef WHAM - include 'COMMON.MD' -#endif -#endif - -c External functions - double precision h_base - external h_base - -c Input arguments - integer resi,resj - -c Output arguments - double precision eij - -c Local variables - logical havebond -c integer itypi,itypj,k,l - double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi - double precision sig0ij,ljd,sig,fac,e1,e2 - double precision dcosom1(3),dcosom2(3),ed - double precision pom1,pom2 - double precision ljA,ljB,ljXs - double precision d_ljB(1:3) - double precision ssA,ssB,ssC,ssXs - double precision ssxm,ljxm,ssm,ljm - double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3) - double precision f1,f2,h1,h2,hd1,hd2 - double precision omega,delta_inv,deltasq_inv,fac1,fac2 -c-------FIRST METHOD - double precision xm,d_xm(1:3) -c-------END FIRST METHOD -c-------SECOND METHOD -c$$$ double precision ss,d_ss(0:3),ljf,d_ljf(0:3) -c-------END SECOND METHOD - -c-------TESTING CODE - logical checkstop,transgrad - common /sschecks/ checkstop,transgrad - - integer icheck,nicheck,jcheck,njcheck - double precision echeck(-1:1),deps,ssx0,ljx0 -c-------END TESTING CODE - - - i=resi - j=resj - - itypi=itype(i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) - dsci_inv=vbld_inv(i+nres) - - itypj=itype(j) - xj=c(1,nres+j)-c(1,nres+i) - yj=c(2,nres+j)-c(2,nres+i) - zj=c(3,nres+j)-c(3,nres+i) - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - dscj_inv=vbld_inv(j+nres) - - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse -c The following are set in sc_angular -c erij(1)=xj*rij -c erij(2)=yj*rij -c erij(3)=zj*rij -c om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) -c om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) -c om12=dxi*dxj+dyi*dyj+dzi*dzj - call sc_angular - rij=1.0D0/rij ! Reset this so it makes sense - - sig0ij=sigma(itypi,itypj) - sig=sig0ij*dsqrt(1.0D0/sigsq) - - ljXs=sig-sig0ij - ljA=eps1*eps2rt**2*eps3rt**2 - ljB=ljA*bb(itypi,itypj) - ljA=ljA*aa(itypi,itypj) - ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - - ssXs=d0cm - deltat1=1.0d0-om1 - deltat2=1.0d0+om2 - deltat12=om2-om1+2.0d0 - cosphi=om12-om1*om2 - ssA=akcm - ssB=akct*deltat12 - ssC=ss_depth - & +akth*(deltat1*deltat1+deltat2*deltat2) - & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi - ssxm=ssXs-0.5D0*ssB/ssA - -c-------TESTING CODE -c$$$c Some extra output -c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA -c$$$ ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) -c$$$ ssx0=ssB*ssB-4.0d0*ssA*ssC -c$$$ if (ssx0.gt.0.0d0) then -c$$$ ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA -c$$$ else -c$$$ ssx0=ssxm -c$$$ endif -c$$$ ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -c$$$ write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ", -c$$$ & ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12 -c$$$ return -c-------END TESTING CODE - -c-------TESTING CODE -c Stop and plot energy and derivative as a function of distance - if (checkstop) then - ssm=ssC-0.25D0*ssB*ssB/ssA - ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) - if (ssm.lt.ljm .and. - & dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then - nicheck=1000 - njcheck=1 - deps=0.5d-7 - else - checkstop=.false. - endif - endif - if (.not.checkstop) then - nicheck=0 - njcheck=-1 - endif - - do icheck=0,nicheck - do jcheck=-1,njcheck - if (checkstop) rij=(ssxm-1.0d0)+ - & ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps -c-------END TESTING CODE - - if (rij.gt.ljxm) then - havebond=.false. - ljd=rij-ljXs - fac=(1.0D0/ljd)**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - eij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=eij*eps3rt - eps3der=eij*eps2rt - eij=eij*eps2rt*eps3rt - - sigder=-sig/sigsq - e1=e1*eps1*eps2rt**2*eps3rt**2 - ed=-expon*(e1+eij)/ljd - sigder=ed*sigder - eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 - eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 - eom12=eij*eps1_om12+eps2der*eps2rt_om12 - & -2.0D0*alf12*eps3der+sigder*sigsq_om12 - else if (rij.lt.ssxm) then - havebond=.true. - ssd=rij-ssXs - eij=ssA*ssd*ssd+ssB*ssd+ssC - - ed=2*akcm*ssd+akct*deltat12 - pom1=akct*ssd - pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi - eom1=-2*akth*deltat1-pom1-om2*pom2 - eom2= 2*akth*deltat2+pom1-om1*pom2 - eom12=pom2 - else - omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi - - d_ssxm(1)=0.5D0*akct/ssA - d_ssxm(2)=-d_ssxm(1) - d_ssxm(3)=0.0D0 - - d_ljxm(1)=sig0ij/sqrt(sigsq**3) - d_ljxm(2)=d_ljxm(1)*sigsq_om2 - d_ljxm(3)=d_ljxm(1)*sigsq_om12 - d_ljxm(1)=d_ljxm(1)*sigsq_om1 - -c-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE - xm=0.5d0*(ssxm+ljxm) - do k=1,3 - d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k)) - enddo - if (rij.lt.xm) then - havebond=.true. - ssm=ssC-0.25D0*ssB*ssB/ssA - d_ssm(1)=0.5D0*akct*ssB/ssA - d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) - d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) - d_ssm(3)=omega - f1=(rij-xm)/(ssxm-xm) - f2=(rij-ssxm)/(xm-ssxm) - h1=h_base(f1,hd1) - h2=h_base(f2,hd2) - eij=ssm*h1+Ht*h2 - delta_inv=1.0d0/(xm-ssxm) - deltasq_inv=delta_inv*delta_inv - fac=ssm*hd1-Ht*hd2 - fac1=deltasq_inv*fac*(xm-rij) - fac2=deltasq_inv*fac*(rij-ssxm) - ed=delta_inv*(Ht*hd2-ssm*hd1) - eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1) - eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2) - eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3) - else - havebond=.false. - ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) - d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB - d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt) - d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- - + alf12/eps3rt) - d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt) - f1=(rij-ljxm)/(xm-ljxm) - f2=(rij-xm)/(ljxm-xm) - h1=h_base(f1,hd1) - h2=h_base(f2,hd2) - eij=Ht*h1+ljm*h2 - delta_inv=1.0d0/(ljxm-xm) - deltasq_inv=delta_inv*delta_inv - fac=Ht*hd1-ljm*hd2 - fac1=deltasq_inv*fac*(ljxm-rij) - fac2=deltasq_inv*fac*(rij-xm) - ed=delta_inv*(ljm*hd2-Ht*hd1) - eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1) - eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2) - eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3) - endif -c-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE - -c-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE -c$$$ ssd=rij-ssXs -c$$$ ljd=rij-ljXs -c$$$ fac1=rij-ljxm -c$$$ fac2=rij-ssxm -c$$$ -c$$$ d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt) -c$$$ d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt) -c$$$ d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt) -c$$$ -c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA -c$$$ d_ssm(1)=0.5D0*akct*ssB/ssA -c$$$ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) -c$$$ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) -c$$$ d_ssm(3)=omega -c$$$ -c$$$ ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj) -c$$$ do k=1,3 -c$$$ d_ljm(k)=ljm*d_ljB(k) -c$$$ enddo -c$$$ ljm=ljm*ljB -c$$$ -c$$$ ss=ssA*ssd*ssd+ssB*ssd+ssC -c$$$ d_ss(0)=2.0d0*ssA*ssd+ssB -c$$$ d_ss(2)=akct*ssd -c$$$ d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega -c$$$ d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega -c$$$ d_ss(3)=omega -c$$$ -c$$$ ljf=bb(itypi,itypj)/aa(itypi,itypj) -c$$$ ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0) -c$$$ d_ljf(0)=ljf*2.0d0*ljB*fac1 -c$$$ do k=1,3 -c$$$ d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1- -c$$$ & 2.0d0*ljB*fac1*d_ljxm(k)) -c$$$ enddo -c$$$ ljf=ljm+ljf*ljB*fac1*fac1 -c$$$ -c$$$ f1=(rij-ljxm)/(ssxm-ljxm) -c$$$ f2=(rij-ssxm)/(ljxm-ssxm) -c$$$ h1=h_base(f1,hd1) -c$$$ h2=h_base(f2,hd2) -c$$$ eij=ss*h1+ljf*h2 -c$$$ delta_inv=1.0d0/(ljxm-ssxm) -c$$$ deltasq_inv=delta_inv*delta_inv -c$$$ fac=ljf*hd2-ss*hd1 -c$$$ ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac -c$$$ eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac* -c$$$ & (fac1*d_ssxm(1)-fac2*(d_ljxm(1))) -c$$$ eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac* -c$$$ & (fac1*d_ssxm(2)-fac2*(d_ljxm(2))) -c$$$ eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac* -c$$$ & (fac1*d_ssxm(3)-fac2*(d_ljxm(3))) -c$$$ -c$$$ havebond=.false. -c$$$ if (ed.gt.0.0d0) havebond=.true. -c-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE - - endif - - if (havebond) then -#ifndef CLUST -#ifndef WHAM -c if (dyn_ssbond_ij(i,j).eq.1.0d300) then -c write(iout,'(a15,f12.2,f8.1,2i5)') -c & "SSBOND_E_FORM",totT,t_bath,i,j -c endif -#endif -#endif - dyn_ssbond_ij(i,j)=eij - else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then - dyn_ssbond_ij(i,j)=1.0d300 -#ifndef CLUST -#ifndef WHAM -c write(iout,'(a15,f12.2,f8.1,2i5)') -c & "SSBOND_E_BREAK",totT,t_bath,i,j -#endif -#endif - endif - -c-------TESTING CODE - if (checkstop) then - if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') - & "CHECKSTOP",rij,eij,ed - echeck(jcheck)=eij - endif - enddo - if (checkstop) then - write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps - endif - enddo - if (checkstop) then - transgrad=.true. - checkstop=.false. - endif -c-------END TESTING CODE - - do k=1,3 - dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij - dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij - enddo - do k=1,3 - gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) - enddo - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv - gvdwx(k,j)=gvdwx(k,j)+gg(k) - & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - enddo -cgrad do k=i,j-1 -cgrad do l=1,3 -cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) -cgrad enddo -cgrad enddo - - do l=1,3 - gvdwc(l,i)=gvdwc(l,i)-gg(l) - gvdwc(l,j)=gvdwc(l,j)+gg(l) - enddo - - return - end - -C----------------------------------------------------------------------------- - - double precision function h_base(x,deriv) -c A smooth function going 0->1 in range [0,1] -c It should NOT be called outside range [0,1], it will not work there. - implicit none - -c Input arguments - double precision x - -c Output arguments - double precision deriv - -c Local variables - double precision xsq - - -c Two parabolas put together. First derivative zero at extrema -c$$$ if (x.lt.0.5D0) then -c$$$ h_base=2.0D0*x*x -c$$$ deriv=4.0D0*x -c$$$ else -c$$$ deriv=1.0D0-x -c$$$ h_base=1.0D0-2.0D0*deriv*deriv -c$$$ deriv=4.0D0*deriv -c$$$ endif - -c Third degree polynomial. First derivative zero at extrema - h_base=x*x*(3.0d0-2.0d0*x) - deriv=6.0d0*x*(1.0d0-x) - -c Fifth degree polynomial. First and second derivatives zero at extrema -c$$$ xsq=x*x -c$$$ h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0) -c$$$ deriv=x-1.0d0 -c$$$ deriv=deriv*deriv -c$$$ deriv=30.0d0*xsq*deriv - - return - end - -c---------------------------------------------------------------------------- - - subroutine dyn_set_nss -c Adjust nss and other relevant variables based on dyn_ssbond_ij -c implicit none - -c Includes - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.SETUP' -#ifndef CLUST -#ifndef WHAM - include 'COMMON.MD' -#endif -#endif - -c Local variables - double precision emin - integer i,j,imin - integer diff,allflag(maxdim),allnss, - & allihpb(maxdim),alljhpb(maxdim), - & newnss,newihpb(maxdim),newjhpb(maxdim) - logical found - integer i_newnss(max_fg_procs),displ(0:max_fg_procs) - integer g_newihpb(maxdim),g_newjhpb(maxdim),g_newnss - - allnss=0 - do i=1,nres-1 - do j=i+1,nres - if (dyn_ssbond_ij(i,j).lt.1.0d300) then - allnss=allnss+1 - allflag(allnss)=0 - allihpb(allnss)=i - alljhpb(allnss)=j - endif - enddo - enddo - -cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) - - 1 emin=1.0d300 - do i=1,allnss - if (allflag(i).eq.0 .and. - & dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then - emin=dyn_ssbond_ij(allihpb(i),alljhpb(i)) - imin=i - endif - enddo - if (emin.lt.1.0d300) then - allflag(imin)=1 - do i=1,allnss - if (allflag(i).eq.0 .and. - & (allihpb(i).eq.allihpb(imin) .or. - & alljhpb(i).eq.allihpb(imin) .or. - & allihpb(i).eq.alljhpb(imin) .or. - & alljhpb(i).eq.alljhpb(imin))) then - allflag(i)=-1 - endif - enddo - goto 1 - endif - -cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) - - newnss=0 - do i=1,allnss - if (allflag(i).eq.1) then - newnss=newnss+1 - newihpb(newnss)=allihpb(i) - newjhpb(newnss)=alljhpb(i) - endif - enddo - -#ifdef MPI - if (nfgtasks.gt.1)then - - call MPI_Reduce(newnss,g_newnss,1, - & MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) - call MPI_Gather(newnss,1,MPI_INTEGER, - & i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR) - displ(0)=0 - do i=1,nfgtasks-1,1 - displ(i)=i_newnss(i-1)+displ(i-1) - enddo - call MPI_Gatherv(newihpb,newnss,MPI_INTEGER, - & g_newihpb,i_newnss,displ,MPI_INTEGER, - & king,FG_COMM,IERR) - call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER, - & g_newjhpb,i_newnss,displ,MPI_INTEGER, - & king,FG_COMM,IERR) - if(fg_rank.eq.0) then -c print *,'g_newnss',g_newnss -c print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss) -c print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss) - newnss=g_newnss - do i=1,newnss - newihpb(i)=g_newihpb(i) - newjhpb(i)=g_newjhpb(i) - enddo - endif - endif -#endif - - diff=newnss-nss - -cmc write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss) - - do i=1,nss - found=.false. - do j=1,newnss - if (idssb(i).eq.newihpb(j) .and. - & jdssb(i).eq.newjhpb(j)) found=.true. - enddo -#ifndef CLUST -#ifndef WHAM - if (.not.found.and.fg_rank.eq.0) - & write(iout,'(a15,f12.2,f8.1,2i5)') - & "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i) -#endif -#endif - enddo - - do i=1,newnss - found=.false. - do j=1,nss - if (newihpb(i).eq.idssb(j) .and. - & newjhpb(i).eq.jdssb(j)) found=.true. - enddo -#ifndef CLUST -#ifndef WHAM - if (.not.found.and.fg_rank.eq.0) - & write(iout,'(a15,f12.2,f8.1,2i5)') - & "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i) -#endif -#endif - enddo - - nss=newnss - do i=1,nss - idssb(i)=newihpb(i) - jdssb(i)=newjhpb(i) - enddo - - return - end - -c---------------------------------------------------------------------------- - -#ifdef WHAM - subroutine read_ssHist - implicit none - -c Includes - include 'DIMENSIONS' - include "DIMENSIONS.FREE" - include 'COMMON.FREE' - -c Local variables - integer i,j - character*80 controlcard - - do i=1,dyn_nssHist - call card_concat(controlcard,.true.) - read(controlcard,*) - & dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0)) - enddo - - return - end -#endif - -c---------------------------------------------------------------------------- - - -C----------------------------------------------------------------------------- -C----------------------------------------------------------------------------- -C----------------------------------------------------------------------------- -C----------------------------------------------------------------------------- -C----------------------------------------------------------------------------- -C----------------------------------------------------------------------------- -C----------------------------------------------------------------------------- - -c$$$c----------------------------------------------------------------------------- -c$$$ -c$$$ subroutine ss_relax(i_in,j_in) -c$$$ implicit none -c$$$ -c$$$c Includes -c$$$ include 'DIMENSIONS' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.CHAIN' -c$$$ include 'COMMON.IOUNITS' -c$$$ include 'COMMON.INTERACT' -c$$$ -c$$$c Input arguments -c$$$ integer i_in,j_in -c$$$ -c$$$c Local variables -c$$$ integer i,iretcode,nfun_sc -c$$$ logical scfail -c$$$ double precision var(maxvar),e_sc,etot -c$$$ -c$$$ -c$$$ mask_r=.true. -c$$$ do i=nnt,nct -c$$$ mask_side(i)=0 -c$$$ enddo -c$$$ mask_side(i_in)=1 -c$$$ mask_side(j_in)=1 -c$$$ -c$$$c Minimize the two selected side-chains -c$$$ call overlap_sc(scfail) ! Better not fail! -c$$$ call minimize_sc(e_sc,var,iretcode,nfun_sc) -c$$$ -c$$$ mask_r=.false. -c$$$ -c$$$ return -c$$$ end -c$$$ -c$$$c------------------------------------------------------------- -c$$$ -c$$$ subroutine minimize_sc(etot_sc,iretcode,nfun) -c$$$c Minimize side-chains only, starting from geom but without modifying -c$$$c bond lengths. -c$$$c If mask_r is already set, only the selected side-chains are minimized, -c$$$c otherwise all side-chains are minimized keeping the backbone frozen. -c$$$ implicit none -c$$$ -c$$$c Includes -c$$$ include 'DIMENSIONS' -c$$$ include 'COMMON.IOUNITS' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.CHAIN' -c$$$ include 'COMMON.GEO' -c$$$ include 'COMMON.MINIM' -c$$$ integer icall -c$$$ common /srutu/ icall -c$$$ -c$$$c Output arguments -c$$$ double precision etot_sc -c$$$ integer iretcode,nfun -c$$$ -c$$$c External functions/subroutines -c$$$ external func_sc,grad_sc,fdum -c$$$ -c$$$c Local variables -c$$$ integer liv,lv -c$$$ parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) -c$$$ integer iv(liv) -c$$$ double precision rdum(1) -c$$$ double precision d(maxvar),v(1:lv),x(maxvar),xx(maxvar) -c$$$ integer idum(1) -c$$$ integer i,nvar_restr -c$$$ -c$$$ -c$$$cmc start_minim=.true. -c$$$ call deflt(2,iv,liv,lv,v) -c$$$* 12 means fresh start, dont call deflt -c$$$ iv(1)=12 -c$$$* max num of fun calls -c$$$ if (maxfun.eq.0) maxfun=500 -c$$$ iv(17)=maxfun -c$$$* max num of iterations -c$$$ if (maxmin.eq.0) maxmin=1000 -c$$$ iv(18)=maxmin -c$$$* controls output -c$$$ iv(19)=1 -c$$$* selects output unit -c$$$ iv(21)=0 -c$$$c iv(21)=iout ! DEBUG -c$$$c iv(21)=8 ! DEBUG -c$$$* 1 means to print out result -c$$$ iv(22)=0 -c$$$c iv(22)=1 ! DEBUG -c$$$* 1 means to print out summary stats -c$$$ iv(23)=0 -c$$$c iv(23)=1 ! DEBUG -c$$$* 1 means to print initial x and d -c$$$ iv(24)=0 -c$$$c iv(24)=1 ! DEBUG -c$$$* min val for v(radfac) default is 0.1 -c$$$ v(24)=0.1D0 -c$$$* max val for v(radfac) default is 4.0 -c$$$ v(25)=2.0D0 -c$$$c v(25)=4.0D0 -c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -c$$$* the sumsl default is 0.1 -c$$$ v(26)=0.1D0 -c$$$* false conv if (act fnctn decrease) .lt. v(34) -c$$$* the sumsl default is 100*machep -c$$$ v(34)=v(34)/100.0D0 -c$$$* absolute convergence -c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4 -c$$$ v(31)=tolf -c$$$* relative convergence -c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-1 -c$$$ v(32)=rtolf -c$$$* controls initial step size -c$$$ v(35)=1.0D-1 -c$$$* large vals of d correspond to small components of step -c$$$ do i=1,nphi -c$$$ d(i)=1.0D-1 -c$$$ enddo -c$$$ do i=nphi+1,nvar -c$$$ d(i)=1.0D-1 -c$$$ enddo -c$$$ -c$$$ call geom_to_var(nvar,x) -c$$$ IF (mask_r) THEN -c$$$ do i=1,nres ! Just in case... -c$$$ mask_phi(i)=0 -c$$$ mask_theta(i)=0 -c$$$ enddo -c$$$ call x2xx(x,xx,nvar_restr) -c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc, -c$$$ & iv,liv,lv,v,idum,rdum,fdum) -c$$$ call xx2x(x,xx) -c$$$ ELSE -c$$$c When minimizing ALL side-chains, etotal_sc is a little -c$$$c faster if we don't set mask_r -c$$$ do i=1,nres -c$$$ mask_phi(i)=0 -c$$$ mask_theta(i)=0 -c$$$ mask_side(i)=1 -c$$$ enddo -c$$$ call x2xx(x,xx,nvar_restr) -c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc, -c$$$ & iv,liv,lv,v,idum,rdum,fdum) -c$$$ call xx2x(x,xx) -c$$$ ENDIF -c$$$ call var_to_geom(nvar,x) -c$$$ call chainbuild_sc -c$$$ etot_sc=v(10) -c$$$ iretcode=iv(1) -c$$$ nfun=iv(6) -c$$$ return -c$$$ end -c$$$ -c$$$C-------------------------------------------------------------------------- -c$$$ -c$$$ subroutine chainbuild_sc -c$$$ implicit none -c$$$ include 'DIMENSIONS' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.INTERACT' -c$$$ -c$$$c Local variables -c$$$ integer i -c$$$ -c$$$ -c$$$ do i=nnt,nct -c$$$ if (.not.mask_r .or. mask_side(i).eq.1) then -c$$$ call locate_side_chain(i) -c$$$ endif -c$$$ enddo -c$$$ -c$$$ return -c$$$ end -c$$$ -c$$$C-------------------------------------------------------------------------- -c$$$ -c$$$ subroutine func_sc(n,x,nf,f,uiparm,urparm,ufparm) -c$$$ implicit none -c$$$ -c$$$c Includes -c$$$ include 'DIMENSIONS' -c$$$ include 'COMMON.DERIV' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.MINIM' -c$$$ include 'COMMON.IOUNITS' -c$$$ -c$$$c Input arguments -c$$$ integer n -c$$$ double precision x(maxvar) -c$$$ double precision ufparm -c$$$ external ufparm -c$$$ -c$$$c Input/Output arguments -c$$$ integer nf -c$$$ integer uiparm(1) -c$$$ double precision urparm(1) -c$$$ -c$$$c Output arguments -c$$$ double precision f -c$$$ -c$$$c Local variables -c$$$ double precision energia(0:n_ene) -c$$$#ifdef OSF -c$$$c Variables used to intercept NaNs -c$$$ double precision x_sum -c$$$ integer i_NAN -c$$$#endif -c$$$ -c$$$ -c$$$ nfl=nf -c$$$ icg=mod(nf,2)+1 -c$$$ -c$$$#ifdef OSF -c$$$c Intercept NaNs in the coordinates, before calling etotal_sc -c$$$ x_sum=0.D0 -c$$$ do i_NAN=1,n -c$$$ x_sum=x_sum+x(i_NAN) -c$$$ enddo -c$$$c Calculate the energy only if the coordinates are ok -c$$$ if ((.not.(x_sum.lt.0.D0)) .and. (.not.(x_sum.ge.0.D0))) then -c$$$ write(iout,*)" *** func_restr_sc : Found NaN in coordinates" -c$$$ f=1.0D+77 -c$$$ nf=0 -c$$$ else -c$$$#endif -c$$$ -c$$$ call var_to_geom_restr(n,x) -c$$$ call zerograd -c$$$ call chainbuild_sc -c$$$ call etotal_sc(energia(0)) -c$$$ f=energia(0) -c$$$ if (energia(1).eq.1.0D20 .or. energia(0).eq.1.0D99) nf=0 -c$$$ -c$$$#ifdef OSF -c$$$ endif -c$$$#endif -c$$$ -c$$$ return -c$$$ end -c$$$ -c$$$c------------------------------------------------------- -c$$$ -c$$$ subroutine grad_sc(n,x,nf,g,uiparm,urparm,ufparm) -c$$$ implicit none -c$$$ -c$$$c Includes -c$$$ include 'DIMENSIONS' -c$$$ include 'COMMON.CHAIN' -c$$$ include 'COMMON.DERIV' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.INTERACT' -c$$$ include 'COMMON.MINIM' -c$$$ -c$$$c Input arguments -c$$$ integer n -c$$$ double precision x(maxvar) -c$$$ double precision ufparm -c$$$ external ufparm -c$$$ -c$$$c Input/Output arguments -c$$$ integer nf -c$$$ integer uiparm(1) -c$$$ double precision urparm(1) -c$$$ -c$$$c Output arguments -c$$$ double precision g(maxvar) -c$$$ -c$$$c Local variables -c$$$ double precision f,gphii,gthetai,galphai,gomegai -c$$$ integer ig,ind,i,j,k,igall,ij -c$$$ -c$$$ -c$$$ icg=mod(nf,2)+1 -c$$$ if (nf-nfl+1) 20,30,40 -c$$$ 20 call func_sc(n,x,nf,f,uiparm,urparm,ufparm) -c$$$c write (iout,*) 'grad 20' -c$$$ if (nf.eq.0) return -c$$$ goto 40 -c$$$ 30 call var_to_geom_restr(n,x) -c$$$ call chainbuild_sc -c$$$C -c$$$C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -c$$$C -c$$$ 40 call cartder -c$$$C -c$$$C Convert the Cartesian gradient into internal-coordinate gradient. -c$$$C -c$$$ -c$$$ ig=0 -c$$$ ind=nres-2 -c$$$ do i=2,nres-2 -c$$$ IF (mask_phi(i+2).eq.1) THEN -c$$$ gphii=0.0D0 -c$$$ do j=i+1,nres-1 -c$$$ ind=ind+1 -c$$$ do k=1,3 -c$$$ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) -c$$$ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) -c$$$ enddo -c$$$ enddo -c$$$ ig=ig+1 -c$$$ g(ig)=gphii -c$$$ ELSE -c$$$ ind=ind+nres-1-i -c$$$ ENDIF -c$$$ enddo -c$$$ -c$$$ -c$$$ ind=0 -c$$$ do i=1,nres-2 -c$$$ IF (mask_theta(i+2).eq.1) THEN -c$$$ ig=ig+1 -c$$$ gthetai=0.0D0 -c$$$ do j=i+1,nres-1 -c$$$ ind=ind+1 -c$$$ do k=1,3 -c$$$ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) -c$$$ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) -c$$$ enddo -c$$$ enddo -c$$$ g(ig)=gthetai -c$$$ ELSE -c$$$ ind=ind+nres-1-i -c$$$ ENDIF -c$$$ enddo -c$$$ -c$$$ do i=2,nres-1 -c$$$ if (itype(i).ne.10) then -c$$$ IF (mask_side(i).eq.1) THEN -c$$$ ig=ig+1 -c$$$ galphai=0.0D0 -c$$$ do k=1,3 -c$$$ galphai=galphai+dxds(k,i)*gradx(k,i,icg) -c$$$ enddo -c$$$ g(ig)=galphai -c$$$ ENDIF -c$$$ endif -c$$$ enddo -c$$$ -c$$$ -c$$$ do i=2,nres-1 -c$$$ if (itype(i).ne.10) then -c$$$ IF (mask_side(i).eq.1) THEN -c$$$ ig=ig+1 -c$$$ gomegai=0.0D0 -c$$$ do k=1,3 -c$$$ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) -c$$$ enddo -c$$$ g(ig)=gomegai -c$$$ ENDIF -c$$$ endif -c$$$ enddo -c$$$ -c$$$C -c$$$C Add the components corresponding to local energy terms. -c$$$C -c$$$ -c$$$ ig=0 -c$$$ igall=0 -c$$$ do i=4,nres -c$$$ igall=igall+1 -c$$$ if (mask_phi(i).eq.1) then -c$$$ ig=ig+1 -c$$$ g(ig)=g(ig)+gloc(igall,icg) -c$$$ endif -c$$$ enddo -c$$$ -c$$$ do i=3,nres -c$$$ igall=igall+1 -c$$$ if (mask_theta(i).eq.1) then -c$$$ ig=ig+1 -c$$$ g(ig)=g(ig)+gloc(igall,icg) -c$$$ endif -c$$$ enddo -c$$$ -c$$$ do ij=1,2 -c$$$ do i=2,nres-1 -c$$$ if (itype(i).ne.10) then -c$$$ igall=igall+1 -c$$$ if (mask_side(i).eq.1) then -c$$$ ig=ig+1 -c$$$ g(ig)=g(ig)+gloc(igall,icg) -c$$$ endif -c$$$ endif -c$$$ enddo -c$$$ enddo -c$$$ -c$$$cd do i=1,ig -c$$$cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) -c$$$cd enddo -c$$$ -c$$$ return -c$$$ end -c$$$ -c$$$C----------------------------------------------------------------------------- -c$$$ -c$$$ subroutine etotal_sc(energy_sc) -c$$$ implicit none -c$$$ -c$$$c Includes -c$$$ include 'DIMENSIONS' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.INTERACT' -c$$$ include 'COMMON.DERIV' -c$$$ include 'COMMON.FFIELD' -c$$$ -c$$$c Output arguments -c$$$ double precision energy_sc(0:n_ene) -c$$$ -c$$$c Local variables -c$$$ double precision evdw,escloc -c$$$ integer i,j -c$$$ -c$$$ -c$$$ do i=1,n_ene -c$$$ energy_sc(i)=0.0D0 -c$$$ enddo -c$$$ -c$$$ if (mask_r) then -c$$$ call egb_sc(evdw) -c$$$ call esc_sc(escloc) -c$$$ else -c$$$ call egb(evdw) -c$$$ call esc(escloc) -c$$$ endif -c$$$ -c$$$ if (evdw.eq.1.0D20) then -c$$$ energy_sc(0)=evdw -c$$$ else -c$$$ energy_sc(0)=wsc*evdw+wscloc*escloc -c$$$ endif -c$$$ energy_sc(1)=evdw -c$$$ energy_sc(12)=escloc -c$$$ -c$$$C -c$$$C Sum up the components of the Cartesian gradient. -c$$$C -c$$$ do i=1,nct -c$$$ do j=1,3 -c$$$ gradx(j,i,icg)=wsc*gvdwx(j,i) -c$$$ enddo -c$$$ enddo -c$$$ -c$$$ return -c$$$ end -c$$$ -c$$$C----------------------------------------------------------------------------- -c$$$ -c$$$ subroutine egb_sc(evdw) -c$$$C -c$$$C This subroutine calculates the interaction energy of nonbonded side chains -c$$$C assuming the Gay-Berne potential of interaction. -c$$$C -c$$$ implicit real*8 (a-h,o-z) -c$$$ include 'DIMENSIONS' -c$$$ include 'COMMON.GEO' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.LOCAL' -c$$$ include 'COMMON.CHAIN' -c$$$ include 'COMMON.DERIV' -c$$$ include 'COMMON.NAMES' -c$$$ include 'COMMON.INTERACT' -c$$$ include 'COMMON.IOUNITS' -c$$$ include 'COMMON.CALC' -c$$$ include 'COMMON.CONTROL' -c$$$ logical lprn -c$$$ evdw=0.0D0 -c$$$ energy_dec=.false. -c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon -c$$$ evdw=0.0D0 -c$$$ lprn=.false. -c$$$c if (icall.eq.0) lprn=.false. -c$$$ ind=0 -c$$$ do i=iatsc_s,iatsc_e -c$$$ itypi=itype(i) -c$$$ itypi1=itype(i+1) -c$$$ xi=c(1,nres+i) -c$$$ yi=c(2,nres+i) -c$$$ zi=c(3,nres+i) -c$$$ dxi=dc_norm(1,nres+i) -c$$$ dyi=dc_norm(2,nres+i) -c$$$ dzi=dc_norm(3,nres+i) -c$$$c dsci_inv=dsc_inv(itypi) -c$$$ dsci_inv=vbld_inv(i+nres) -c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) -c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi -c$$$C -c$$$C Calculate SC interaction energy. -c$$$C -c$$$ do iint=1,nint_gr(i) -c$$$ do j=istart(i,iint),iend(i,iint) -c$$$ IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN -c$$$ ind=ind+1 -c$$$ itypj=itype(j) -c$$$c dscj_inv=dsc_inv(itypj) -c$$$ dscj_inv=vbld_inv(j+nres) -c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, -c$$$c & 1.0d0/vbld(j+nres) -c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) -c$$$ sig0ij=sigma(itypi,itypj) -c$$$ chi1=chi(itypi,itypj) -c$$$ chi2=chi(itypj,itypi) -c$$$ chi12=chi1*chi2 -c$$$ chip1=chip(itypi) -c$$$ chip2=chip(itypj) -c$$$ chip12=chip1*chip2 -c$$$ alf1=alp(itypi) -c$$$ alf2=alp(itypj) -c$$$ alf12=0.5D0*(alf1+alf2) -c$$$C For diagnostics only!!! -c$$$c chi1=0.0D0 -c$$$c chi2=0.0D0 -c$$$c chi12=0.0D0 -c$$$c chip1=0.0D0 -c$$$c chip2=0.0D0 -c$$$c chip12=0.0D0 -c$$$c alf1=0.0D0 -c$$$c alf2=0.0D0 -c$$$c alf12=0.0D0 -c$$$ xj=c(1,nres+j)-xi -c$$$ yj=c(2,nres+j)-yi -c$$$ zj=c(3,nres+j)-zi -c$$$ dxj=dc_norm(1,nres+j) -c$$$ dyj=dc_norm(2,nres+j) -c$$$ dzj=dc_norm(3,nres+j) -c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi -c$$$c write (iout,*) "j",j," dc_norm", -c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) -c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj) -c$$$ rij=dsqrt(rrij) -c$$$C Calculate angle-dependent terms of energy and contributions to their -c$$$C derivatives. -c$$$ call sc_angular -c$$$ sigsq=1.0D0/sigsq -c$$$ sig=sig0ij*dsqrt(sigsq) -c$$$ rij_shift=1.0D0/rij-sig+sig0ij -c$$$c for diagnostics; uncomment -c$$$c rij_shift=1.2*sig0ij -c$$$C I hate to put IF's in the loops, but here don't have another choice!!!! -c$$$ if (rij_shift.le.0.0D0) then -c$$$ evdw=1.0D20 -c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -c$$$cd & restyp(itypi),i,restyp(itypj),j, -c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) -c$$$ return -c$$$ endif -c$$$ sigder=-sig*sigsq -c$$$c--------------------------------------------------------------- -c$$$ rij_shift=1.0D0/rij_shift -c$$$ fac=rij_shift**expon -c$$$ e1=fac*fac*aa(itypi,itypj) -c$$$ e2=fac*bb(itypi,itypj) -c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2) -c$$$ eps2der=evdwij*eps3rt -c$$$ eps3der=evdwij*eps2rt -c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, -c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 -c$$$ evdwij=evdwij*eps2rt*eps3rt -c$$$ evdw=evdw+evdwij -c$$$ if (lprn) then -c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))') -c$$$ & restyp(itypi),i,restyp(itypj),j, -c$$$ & epsi,sigm,chi1,chi2,chip1,chip2, -c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, -c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, -c$$$ & evdwij -c$$$ endif -c$$$ -c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)') -c$$$ & 'evdw',i,j,evdwij -c$$$ -c$$$C Calculate gradient components. -c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2 -c$$$ fac=-expon*(e1+evdwij)*rij_shift -c$$$ sigder=fac*sigder -c$$$ fac=rij*fac -c$$$c fac=0.0d0 -c$$$C Calculate the radial part of the gradient -c$$$ gg(1)=xj*fac -c$$$ gg(2)=yj*fac -c$$$ gg(3)=zj*fac -c$$$C Calculate angular part of the gradient. -c$$$ call sc_grad -c$$$ ENDIF -c$$$ enddo ! j -c$$$ enddo ! iint -c$$$ enddo ! i -c$$$ energy_dec=.false. -c$$$ return -c$$$ end -c$$$ -c$$$c----------------------------------------------------------------------------- -c$$$ -c$$$ subroutine esc_sc(escloc) -c$$$C Calculate the local energy of a side chain and its derivatives in the -c$$$C corresponding virtual-bond valence angles THETA and the spherical angles -c$$$C ALPHA and OMEGA. -c$$$ implicit real*8 (a-h,o-z) -c$$$ include 'DIMENSIONS' -c$$$ include 'COMMON.GEO' -c$$$ include 'COMMON.LOCAL' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.INTERACT' -c$$$ include 'COMMON.DERIV' -c$$$ include 'COMMON.CHAIN' -c$$$ include 'COMMON.IOUNITS' -c$$$ include 'COMMON.NAMES' -c$$$ include 'COMMON.FFIELD' -c$$$ include 'COMMON.CONTROL' -c$$$ double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), -c$$$ & ddersc0(3),ddummy(3),xtemp(3),temp(3) -c$$$ common /sccalc/ time11,time12,time112,theti,it,nlobit -c$$$ delta=0.02d0*pi -c$$$ escloc=0.0D0 -c$$$c write (iout,'(a)') 'ESC' -c$$$ do i=loc_start,loc_end -c$$$ IF (mask_side(i).eq.1) THEN -c$$$ it=itype(i) -c$$$ if (it.eq.10) goto 1 -c$$$ nlobit=nlob(it) -c$$$c print *,'i=',i,' it=',it,' nlobit=',nlobit -c$$$c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad -c$$$ theti=theta(i+1)-pipol -c$$$ x(1)=dtan(theti) -c$$$ x(2)=alph(i) -c$$$ x(3)=omeg(i) -c$$$ -c$$$ if (x(2).gt.pi-delta) then -c$$$ xtemp(1)=x(1) -c$$$ xtemp(2)=pi-delta -c$$$ xtemp(3)=x(3) -c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) -c$$$ xtemp(2)=pi -c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.) -c$$$ call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), -c$$$ & escloci,dersc(2)) -c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), -c$$$ & ddersc0(1),dersc(1)) -c$$$ call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), -c$$$ & ddersc0(3),dersc(3)) -c$$$ xtemp(2)=pi-delta -c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) -c$$$ xtemp(2)=pi -c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) -c$$$ call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, -c$$$ & dersc0(2),esclocbi,dersc02) -c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), -c$$$ & dersc12,dersc01) -c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd) -c$$$ dersc0(1)=dersc01 -c$$$ dersc0(2)=dersc02 -c$$$ dersc0(3)=0.0d0 -c$$$ do k=1,3 -c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) -c$$$ enddo -c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c$$$c & esclocbi,ss,ssd -c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi -c$$$c escloci=esclocbi -c$$$c write (iout,*) escloci -c$$$ else if (x(2).lt.delta) then -c$$$ xtemp(1)=x(1) -c$$$ xtemp(2)=delta -c$$$ xtemp(3)=x(3) -c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) -c$$$ xtemp(2)=0.0d0 -c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.) -c$$$ call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), -c$$$ & escloci,dersc(2)) -c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), -c$$$ & ddersc0(1),dersc(1)) -c$$$ call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), -c$$$ & ddersc0(3),dersc(3)) -c$$$ xtemp(2)=delta -c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) -c$$$ xtemp(2)=0.0d0 -c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) -c$$$ call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, -c$$$ & dersc0(2),esclocbi,dersc02) -c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), -c$$$ & dersc12,dersc01) -c$$$ dersc0(1)=dersc01 -c$$$ dersc0(2)=dersc02 -c$$$ dersc0(3)=0.0d0 -c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd) -c$$$ do k=1,3 -c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) -c$$$ enddo -c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c$$$c & esclocbi,ss,ssd -c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi -c$$$c write (iout,*) escloci -c$$$ else -c$$$ call enesc(x,escloci,dersc,ddummy,.false.) -c$$$ endif -c$$$ -c$$$ escloc=escloc+escloci -c$$$ if (energy_dec) write (iout,'(a6,i,0pf7.3)') -c$$$ & 'escloc',i,escloci -c$$$c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc -c$$$ -c$$$ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ -c$$$ & wscloc*dersc(1) -c$$$ gloc(ialph(i,1),icg)=wscloc*dersc(2) -c$$$ gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) -c$$$ 1 continue -c$$$ ENDIF -c$$$ enddo -c$$$ return -c$$$ end -c$$$ -c$$$C----------------------------------------------------------------------------- -c$$$ -c$$$ subroutine egb_ij(i_sc,j_sc,evdw) -c$$$C -c$$$C This subroutine calculates the interaction energy of nonbonded side chains -c$$$C assuming the Gay-Berne potential of interaction. -c$$$C -c$$$ implicit real*8 (a-h,o-z) -c$$$ include 'DIMENSIONS' -c$$$ include 'COMMON.GEO' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.LOCAL' -c$$$ include 'COMMON.CHAIN' -c$$$ include 'COMMON.DERIV' -c$$$ include 'COMMON.NAMES' -c$$$ include 'COMMON.INTERACT' -c$$$ include 'COMMON.IOUNITS' -c$$$ include 'COMMON.CALC' -c$$$ include 'COMMON.CONTROL' -c$$$ logical lprn -c$$$ evdw=0.0D0 -c$$$ energy_dec=.false. -c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon -c$$$ evdw=0.0D0 -c$$$ lprn=.false. -c$$$ ind=0 -c$$$c$$$ do i=iatsc_s,iatsc_e -c$$$ i=i_sc -c$$$ itypi=itype(i) -c$$$ itypi1=itype(i+1) -c$$$ xi=c(1,nres+i) -c$$$ yi=c(2,nres+i) -c$$$ zi=c(3,nres+i) -c$$$ dxi=dc_norm(1,nres+i) -c$$$ dyi=dc_norm(2,nres+i) -c$$$ dzi=dc_norm(3,nres+i) -c$$$c dsci_inv=dsc_inv(itypi) -c$$$ dsci_inv=vbld_inv(i+nres) -c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) -c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi -c$$$C -c$$$C Calculate SC interaction energy. -c$$$C -c$$$c$$$ do iint=1,nint_gr(i) -c$$$c$$$ do j=istart(i,iint),iend(i,iint) -c$$$ j=j_sc -c$$$ ind=ind+1 -c$$$ itypj=itype(j) -c$$$c dscj_inv=dsc_inv(itypj) -c$$$ dscj_inv=vbld_inv(j+nres) -c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, -c$$$c & 1.0d0/vbld(j+nres) -c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) -c$$$ sig0ij=sigma(itypi,itypj) -c$$$ chi1=chi(itypi,itypj) -c$$$ chi2=chi(itypj,itypi) -c$$$ chi12=chi1*chi2 -c$$$ chip1=chip(itypi) -c$$$ chip2=chip(itypj) -c$$$ chip12=chip1*chip2 -c$$$ alf1=alp(itypi) -c$$$ alf2=alp(itypj) -c$$$ alf12=0.5D0*(alf1+alf2) -c$$$C For diagnostics only!!! -c$$$c chi1=0.0D0 -c$$$c chi2=0.0D0 -c$$$c chi12=0.0D0 -c$$$c chip1=0.0D0 -c$$$c chip2=0.0D0 -c$$$c chip12=0.0D0 -c$$$c alf1=0.0D0 -c$$$c alf2=0.0D0 -c$$$c alf12=0.0D0 -c$$$ xj=c(1,nres+j)-xi -c$$$ yj=c(2,nres+j)-yi -c$$$ zj=c(3,nres+j)-zi -c$$$ dxj=dc_norm(1,nres+j) -c$$$ dyj=dc_norm(2,nres+j) -c$$$ dzj=dc_norm(3,nres+j) -c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi -c$$$c write (iout,*) "j",j," dc_norm", -c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) -c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj) -c$$$ rij=dsqrt(rrij) -c$$$C Calculate angle-dependent terms of energy and contributions to their -c$$$C derivatives. -c$$$ call sc_angular -c$$$ sigsq=1.0D0/sigsq -c$$$ sig=sig0ij*dsqrt(sigsq) -c$$$ rij_shift=1.0D0/rij-sig+sig0ij -c$$$c for diagnostics; uncomment -c$$$c rij_shift=1.2*sig0ij -c$$$C I hate to put IF's in the loops, but here don't have another choice!!!! -c$$$ if (rij_shift.le.0.0D0) then -c$$$ evdw=1.0D20 -c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -c$$$cd & restyp(itypi),i,restyp(itypj),j, -c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) -c$$$ return -c$$$ endif -c$$$ sigder=-sig*sigsq -c$$$c--------------------------------------------------------------- -c$$$ rij_shift=1.0D0/rij_shift -c$$$ fac=rij_shift**expon -c$$$ e1=fac*fac*aa(itypi,itypj) -c$$$ e2=fac*bb(itypi,itypj) -c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2) -c$$$ eps2der=evdwij*eps3rt -c$$$ eps3der=evdwij*eps2rt -c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, -c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 -c$$$ evdwij=evdwij*eps2rt*eps3rt -c$$$ evdw=evdw+evdwij -c$$$ if (lprn) then -c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))') -c$$$ & restyp(itypi),i,restyp(itypj),j, -c$$$ & epsi,sigm,chi1,chi2,chip1,chip2, -c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, -c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, -c$$$ & evdwij -c$$$ endif -c$$$ -c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)') -c$$$ & 'evdw',i,j,evdwij -c$$$ -c$$$C Calculate gradient components. -c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2 -c$$$ fac=-expon*(e1+evdwij)*rij_shift -c$$$ sigder=fac*sigder -c$$$ fac=rij*fac -c$$$c fac=0.0d0 -c$$$C Calculate the radial part of the gradient -c$$$ gg(1)=xj*fac -c$$$ gg(2)=yj*fac -c$$$ gg(3)=zj*fac -c$$$C Calculate angular part of the gradient. -c$$$ call sc_grad -c$$$c$$$ enddo ! j -c$$$c$$$ enddo ! iint -c$$$c$$$ enddo ! i -c$$$ energy_dec=.false. -c$$$ return -c$$$ end -c$$$ -c$$$C----------------------------------------------------------------------------- -c$$$ -c$$$ subroutine perturb_side_chain(i,angle) -c$$$ implicit none -c$$$ -c$$$c Includes -c$$$ include 'DIMENSIONS' -c$$$ include 'COMMON.CHAIN' -c$$$ include 'COMMON.GEO' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.LOCAL' -c$$$ include 'COMMON.IOUNITS' -c$$$ -c$$$c External functions -c$$$ external ran_number -c$$$ double precision ran_number -c$$$ -c$$$c Input arguments -c$$$ integer i -c$$$ double precision angle ! In degrees -c$$$ -c$$$c Local variables -c$$$ integer i_sc -c$$$ double precision rad_ang,rand_v(3),length,cost,sint -c$$$ -c$$$ -c$$$ i_sc=i+nres -c$$$ rad_ang=angle*deg2rad -c$$$ -c$$$ length=0.0 -c$$$ do while (length.lt.0.01) -c$$$ rand_v(1)=ran_number(0.01D0,1.0D0) -c$$$ rand_v(2)=ran_number(0.01D0,1.0D0) -c$$$ rand_v(3)=ran_number(0.01D0,1.0D0) -c$$$ length=rand_v(1)*rand_v(1)+rand_v(2)*rand_v(2)+ -c$$$ + rand_v(3)*rand_v(3) -c$$$ length=sqrt(length) -c$$$ rand_v(1)=rand_v(1)/length -c$$$ rand_v(2)=rand_v(2)/length -c$$$ rand_v(3)=rand_v(3)/length -c$$$ cost=rand_v(1)*dc_norm(1,i_sc)+rand_v(2)*dc_norm(2,i_sc)+ -c$$$ + rand_v(3)*dc_norm(3,i_sc) -c$$$ length=1.0D0-cost*cost -c$$$ if (length.lt.0.0D0) length=0.0D0 -c$$$ length=sqrt(length) -c$$$ rand_v(1)=rand_v(1)-cost*dc_norm(1,i_sc) -c$$$ rand_v(2)=rand_v(2)-cost*dc_norm(2,i_sc) -c$$$ rand_v(3)=rand_v(3)-cost*dc_norm(3,i_sc) -c$$$ enddo -c$$$ rand_v(1)=rand_v(1)/length -c$$$ rand_v(2)=rand_v(2)/length -c$$$ rand_v(3)=rand_v(3)/length -c$$$ -c$$$ cost=dcos(rad_ang) -c$$$ sint=dsin(rad_ang) -c$$$ dc(1,i_sc)=vbld(i_sc)*(dc_norm(1,i_sc)*cost+rand_v(1)*sint) -c$$$ dc(2,i_sc)=vbld(i_sc)*(dc_norm(2,i_sc)*cost+rand_v(2)*sint) -c$$$ dc(3,i_sc)=vbld(i_sc)*(dc_norm(3,i_sc)*cost+rand_v(3)*sint) -c$$$ dc_norm(1,i_sc)=dc(1,i_sc)*vbld_inv(i_sc) -c$$$ dc_norm(2,i_sc)=dc(2,i_sc)*vbld_inv(i_sc) -c$$$ dc_norm(3,i_sc)=dc(3,i_sc)*vbld_inv(i_sc) -c$$$ c(1,i_sc)=c(1,i)+dc(1,i_sc) -c$$$ c(2,i_sc)=c(2,i)+dc(2,i_sc) -c$$$ c(3,i_sc)=c(3,i)+dc(3,i_sc) -c$$$ -c$$$ call chainbuild_cart -c$$$ -c$$$ return -c$$$ end -c$$$ -c$$$c---------------------------------------------------------------------------- -c$$$ -c$$$ subroutine ss_relax3(i_in,j_in) -c$$$ implicit none -c$$$ -c$$$c Includes -c$$$ include 'DIMENSIONS' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.CHAIN' -c$$$ include 'COMMON.IOUNITS' -c$$$ include 'COMMON.INTERACT' -c$$$ -c$$$c External functions -c$$$ external ran_number -c$$$ double precision ran_number -c$$$ -c$$$c Input arguments -c$$$ integer i_in,j_in -c$$$ -c$$$c Local variables -c$$$ double precision energy_sc(0:n_ene),etot -c$$$ double precision org_dc(3),org_dc_norm(3),org_c(3) -c$$$ double precision ang_pert,rand_fact,exp_fact,beta -c$$$ integer n,i_pert,i -c$$$ logical notdone -c$$$ -c$$$ -c$$$ beta=1.0D0 -c$$$ -c$$$ mask_r=.true. -c$$$ do i=nnt,nct -c$$$ mask_side(i)=0 -c$$$ enddo -c$$$ mask_side(i_in)=1 -c$$$ mask_side(j_in)=1 -c$$$ -c$$$ call etotal_sc(energy_sc) -c$$$ etot=energy_sc(0) -c$$$c write(iout,'(a,3d15.5)')" SS_MC_START ",energy_sc(0), -c$$$c + energy_sc(1),energy_sc(12) -c$$$ -c$$$ notdone=.true. -c$$$ n=0 -c$$$ do while (notdone) -c$$$ if (mod(n,2).eq.0) then -c$$$ i_pert=i_in -c$$$ else -c$$$ i_pert=j_in -c$$$ endif -c$$$ n=n+1 -c$$$ -c$$$ do i=1,3 -c$$$ org_dc(i)=dc(i,i_pert+nres) -c$$$ org_dc_norm(i)=dc_norm(i,i_pert+nres) -c$$$ org_c(i)=c(i,i_pert+nres) -c$$$ enddo -c$$$ ang_pert=ran_number(0.0D0,3.0D0) -c$$$ call perturb_side_chain(i_pert,ang_pert) -c$$$ call etotal_sc(energy_sc) -c$$$ exp_fact=exp(beta*(etot-energy_sc(0))) -c$$$ rand_fact=ran_number(0.0D0,1.0D0) -c$$$ if (rand_fact.lt.exp_fact) then -c$$$c write(iout,'(a,3d15.5)')" SS_MC_ACCEPT ",energy_sc(0), -c$$$c + energy_sc(1),energy_sc(12) -c$$$ etot=energy_sc(0) -c$$$ else -c$$$c write(iout,'(a,3d15.5)')" SS_MC_REJECT ",energy_sc(0), -c$$$c + energy_sc(1),energy_sc(12) -c$$$ do i=1,3 -c$$$ dc(i,i_pert+nres)=org_dc(i) -c$$$ dc_norm(i,i_pert+nres)=org_dc_norm(i) -c$$$ c(i,i_pert+nres)=org_c(i) -c$$$ enddo -c$$$ endif -c$$$ -c$$$ if (n.eq.10000.or.etot.lt.30.0D0) notdone=.false. -c$$$ enddo -c$$$ -c$$$ mask_r=.false. -c$$$ -c$$$ return -c$$$ end -c$$$ -c$$$c---------------------------------------------------------------------------- -c$$$ -c$$$ subroutine ss_relax2(etot,iretcode,nfun,i_in,j_in) -c$$$ implicit none -c$$$ include 'DIMENSIONS' -c$$$ integer liv,lv -c$$$ parameter (liv=60,lv=(77+maxres6*(maxres6+17)/2)) -c$$$********************************************************************* -c$$$* OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * -c$$$* the calling subprogram. * -c$$$* when d(i)=1.0, then v(35) is the length of the initial step, * -c$$$* calculated in the usual pythagorean way. * -c$$$* absolute convergence occurs when the function is within v(31) of * -c$$$* zero. unless you know the minimum value in advance, abs convg * -c$$$* is probably not useful. * -c$$$* relative convergence is when the model predicts that the function * -c$$$* will decrease by less than v(32)*abs(fun). * -c$$$********************************************************************* -c$$$ include 'COMMON.IOUNITS' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.GEO' -c$$$ include 'COMMON.MINIM' -c$$$ include 'COMMON.CHAIN' -c$$$ -c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist -c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar), -c$$$ + orig_ss_dist(maxres2,maxres2) -c$$$ -c$$$ double precision etot -c$$$ integer iretcode,nfun,i_in,j_in -c$$$ -c$$$ external dist -c$$$ double precision dist -c$$$ external ss_func,fdum -c$$$ double precision ss_func,fdum -c$$$ -c$$$ integer iv(liv),uiparm(2) -c$$$ double precision v(lv),x(maxres6),d(maxres6),rdum -c$$$ integer i,j,k -c$$$ -c$$$ -c$$$ call deflt(2,iv,liv,lv,v) -c$$$* 12 means fresh start, dont call deflt -c$$$ iv(1)=12 -c$$$* max num of fun calls -c$$$ if (maxfun.eq.0) maxfun=500 -c$$$ iv(17)=maxfun -c$$$* max num of iterations -c$$$ if (maxmin.eq.0) maxmin=1000 -c$$$ iv(18)=maxmin -c$$$* controls output -c$$$ iv(19)=2 -c$$$* selects output unit -c$$$c iv(21)=iout -c$$$ iv(21)=0 -c$$$* 1 means to print out result -c$$$ iv(22)=0 -c$$$* 1 means to print out summary stats -c$$$ iv(23)=0 -c$$$* 1 means to print initial x and d -c$$$ iv(24)=0 -c$$$* min val for v(radfac) default is 0.1 -c$$$ v(24)=0.1D0 -c$$$* max val for v(radfac) default is 4.0 -c$$$ v(25)=2.0D0 -c$$$c v(25)=4.0D0 -c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -c$$$* the sumsl default is 0.1 -c$$$ v(26)=0.1D0 -c$$$* false conv if (act fnctn decrease) .lt. v(34) -c$$$* the sumsl default is 100*machep -c$$$ v(34)=v(34)/100.0D0 -c$$$* absolute convergence -c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4 -c$$$ v(31)=tolf -c$$$ v(31)=1.0D-1 -c$$$* relative convergence -c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-4 -c$$$ v(32)=rtolf -c$$$ v(32)=1.0D-1 -c$$$* controls initial step size -c$$$ v(35)=1.0D-1 -c$$$* large vals of d correspond to small components of step -c$$$ do i=1,6*nres -c$$$ d(i)=1.0D0 -c$$$ enddo -c$$$ -c$$$ do i=0,2*nres -c$$$ do j=1,3 -c$$$ orig_ss_dc(j,i)=dc(j,i) -c$$$ enddo -c$$$ enddo -c$$$ call geom_to_var(nvar,orig_ss_var) -c$$$ -c$$$ do i=1,nres -c$$$ do j=i,nres -c$$$ orig_ss_dist(j,i)=dist(j,i) -c$$$ orig_ss_dist(j+nres,i)=dist(j+nres,i) -c$$$ orig_ss_dist(j,i+nres)=dist(j,i+nres) -c$$$ orig_ss_dist(j+nres,i+nres)=dist(j+nres,i+nres) -c$$$ enddo -c$$$ enddo -c$$$ -c$$$ k=0 -c$$$ do i=1,nres-1 -c$$$ do j=1,3 -c$$$ k=k+1 -c$$$ x(k)=dc(j,i) -c$$$ enddo -c$$$ enddo -c$$$ do i=2,nres-1 -c$$$ if (ialph(i,1).gt.0) then -c$$$ do j=1,3 -c$$$ k=k+1 -c$$$ x(k)=dc(j,i+nres) -c$$$ enddo -c$$$ endif -c$$$ enddo -c$$$ -c$$$ uiparm(1)=i_in -c$$$ uiparm(2)=j_in -c$$$ call smsno(k,d,x,ss_func,iv,liv,lv,v,uiparm,rdum,fdum) -c$$$ etot=v(10) -c$$$ iretcode=iv(1) -c$$$ nfun=iv(6)+iv(30) -c$$$ -c$$$ k=0 -c$$$ do i=1,nres-1 -c$$$ do j=1,3 -c$$$ k=k+1 -c$$$ dc(j,i)=x(k) -c$$$ enddo -c$$$ enddo -c$$$ do i=2,nres-1 -c$$$ if (ialph(i,1).gt.0) then -c$$$ do j=1,3 -c$$$ k=k+1 -c$$$ dc(j,i+nres)=x(k) -c$$$ enddo -c$$$ endif -c$$$ enddo -c$$$ call chainbuild_cart -c$$$ -c$$$ return -c$$$ end -c$$$ -c$$$C----------------------------------------------------------------------------- -c$$$ -c$$$ subroutine ss_func(n,x,nf,f,uiparm,urparm,ufparm) -c$$$ implicit none -c$$$ include 'DIMENSIONS' -c$$$ include 'COMMON.DERIV' -c$$$ include 'COMMON.IOUNITS' -c$$$ include 'COMMON.VAR' -c$$$ include 'COMMON.CHAIN' -c$$$ include 'COMMON.INTERACT' -c$$$ include 'COMMON.SBRIDGE' -c$$$ -c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist -c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar), -c$$$ + orig_ss_dist(maxres2,maxres2) -c$$$ -c$$$ integer n -c$$$ double precision x(maxres6) -c$$$ integer nf -c$$$ double precision f -c$$$ integer uiparm(2) -c$$$ real*8 urparm(1) -c$$$ external ufparm -c$$$ double precision ufparm -c$$$ -c$$$ external dist -c$$$ double precision dist -c$$$ -c$$$ integer i,j,k,ss_i,ss_j -c$$$ double precision tempf,var(maxvar) -c$$$ -c$$$ -c$$$ ss_i=uiparm(1) -c$$$ ss_j=uiparm(2) -c$$$ f=0.0D0 -c$$$ -c$$$ k=0 -c$$$ do i=1,nres-1 -c$$$ do j=1,3 -c$$$ k=k+1 -c$$$ dc(j,i)=x(k) -c$$$ enddo -c$$$ enddo -c$$$ do i=2,nres-1 -c$$$ if (ialph(i,1).gt.0) then -c$$$ do j=1,3 -c$$$ k=k+1 -c$$$ dc(j,i+nres)=x(k) -c$$$ enddo -c$$$ endif -c$$$ enddo -c$$$ call chainbuild_cart -c$$$ -c$$$ call geom_to_var(nvar,var) -c$$$ -c$$$c Constraints on all angles -c$$$ do i=1,nvar -c$$$ tempf=var(i)-orig_ss_var(i) -c$$$ f=f+tempf*tempf -c$$$ enddo -c$$$ -c$$$c Constraints on all distances -c$$$ do i=1,nres-1 -c$$$ if (i.gt.1) then -c$$$ tempf=dist(i+nres,i)-orig_ss_dist(i+nres,i) -c$$$ f=f+tempf*tempf -c$$$ endif -c$$$ do j=i+1,nres -c$$$ tempf=dist(j,i)-orig_ss_dist(j,i) -c$$$ if (tempf.lt.0.0D0 .or. j.eq.i+1) f=f+tempf*tempf -c$$$ tempf=dist(j+nres,i)-orig_ss_dist(j+nres,i) -c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf -c$$$ tempf=dist(j,i+nres)-orig_ss_dist(j,i+nres) -c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf -c$$$ tempf=dist(j+nres,i+nres)-orig_ss_dist(j+nres,i+nres) -c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf -c$$$ enddo -c$$$ enddo -c$$$ -c$$$c Constraints for the relevant CYS-CYS -c$$$ tempf=dist(nres+ss_i,nres+ss_j)-8.0D0 -c$$$ f=f+tempf*tempf -c$$$CCCCCCCCCCCCCCCCC ADD SOME ANGULAR STUFF -c$$$ -c$$$c$$$ if (nf.ne.nfl) then -c$$$c$$$ write(iout,'(a,i10,2d15.5)')"IN DIST_FUNC (NF,F,DIST)",nf, -c$$$c$$$ + f,dist(5+nres,14+nres) -c$$$c$$$ endif -c$$$ -c$$$ nfl=nf -c$$$ -c$$$ return -c$$$ end -c$$$ -c$$$C----------------------------------------------------------------------------- diff --git a/source/unres/src_MD-M-newcorr/stochfric.F b/source/unres/src_MD-M-newcorr/stochfric.F deleted file mode 100644 index 13d02fb..0000000 --- a/source/unres/src_MD-M-newcorr/stochfric.F +++ /dev/null @@ -1,627 +0,0 @@ - subroutine friction_force - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.IOUNITS' - double precision gamvec(MAXRES6) - common /syfek/ gamvec - double precision vv(3),vvtot(3,maxres),v_work(MAXRES6), - & ginvfric(maxres2,maxres2) - common /przechowalnia/ ginvfric - - logical lprn /.false./, checkmode /.false./ - - do i=0,MAXRES2 - do j=1,3 - friction(j,i)=0.0d0 - enddo - enddo - - do j=1,3 - d_t_work(j)=d_t(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t_work(ind+j)=d_t(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then - do j=1,3 - d_t_work(ind+j)=d_t(j,i+nres) - enddo - ind=ind+3 - endif - enddo - - call fricmat_mult(d_t_work,fric_work) - - if (.not.checkmode) return - - if (lprn) then - write (iout,*) "d_t_work and fric_work" - do i=1,3*dimen - write (iout,'(i3,2e15.5)') i,d_t_work(i),fric_work(i) - enddo - endif - do j=1,3 - friction(j,0)=fric_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - friction(j,i)=fric_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then - do j=1,3 - friction(j,i+nres)=fric_work(ind+j) - enddo - ind=ind+3 - endif - enddo - if (lprn) then - write(iout,*) "Friction backbone" - do i=0,nct-1 - write(iout,'(i5,3e15.5,5x,3e15.5)') - & i,(friction(j,i),j=1,3),(d_t(j,i),j=1,3) - enddo - write(iout,*) "Friction side chain" - do i=nnt,nct - write(iout,'(i5,3e15.5,5x,3e15.5)') - & i,(friction(j,i+nres),j=1,3),(d_t(j,i+nres),j=1,3) - enddo - endif - if (lprn) then - do j=1,3 - vv(j)=d_t(j,0) - enddo - do i=nnt,nct - do j=1,3 - vvtot(j,i)=vv(j)+0.5d0*d_t(j,i) - vvtot(j,i+nres)=vv(j)+d_t(j,i+nres) - vv(j)=vv(j)+d_t(j,i) - enddo - enddo - write (iout,*) "vvtot backbone and sidechain" - do i=nnt,nct - write (iout,'(i5,3e15.5,5x,3e15.5)') i,(vvtot(j,i),j=1,3), - & (vvtot(j,i+nres),j=1,3) - enddo - ind=0 - do i=nnt,nct-1 - do j=1,3 - v_work(ind+j)=vvtot(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - do j=1,3 - v_work(ind+j)=vvtot(j,i+nres) - enddo - ind=ind+3 - enddo - write (iout,*) "v_work gamvec and site-based friction forces" - do i=1,dimen1 - write (iout,'(i5,3e15.5)') i,v_work(i),gamvec(i), - & gamvec(i)*v_work(i) - enddo -c do i=1,dimen -c fric_work1(i)=0.0d0 -c do j=1,dimen1 -c fric_work1(i)=fric_work1(i)-A(j,i)*gamvec(j)*v_work(j) -c enddo -c enddo -c write (iout,*) "fric_work and fric_work1" -c do i=1,dimen -c write (iout,'(i5,2e15.5)') i,fric_work(i),fric_work1(i) -c enddo - do i=1,dimen - do j=1,dimen - ginvfric(i,j)=0.0d0 - do k=1,dimen - ginvfric(i,j)=ginvfric(i,j)+ginv(i,k)*fricmat(k,j) - enddo - enddo - enddo - write (iout,*) "ginvfric" - do i=1,dimen - write (iout,'(i5,100f8.3)') i,(ginvfric(i,j),j=1,dimen) - enddo - write (iout,*) "symmetry check" - do i=1,dimen - do j=1,i-1 - write (iout,*) i,j,ginvfric(i,j)-ginvfric(j,i) - enddo - enddo - endif - return - end -c----------------------------------------------------- - subroutine stochastic_force(stochforcvec) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.TIME1' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.IOUNITS' - - double precision x,sig,lowb,highb, - & ff(3),force(3,0:MAXRES2),zeta2,lowb2, - & highb2,sig2,forcvec(MAXRES6),stochforcvec(MAXRES6) - logical lprn /.false./ - do i=0,MAXRES2 - do j=1,3 - stochforc(j,i)=0.0d0 - enddo - enddo - x=0.0d0 - -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif -c Compute the stochastic forces acting on bodies. Store in force. - do i=nnt,nct-1 - sig=stdforcp(i) - lowb=-5*sig - highb=5*sig - do j=1,3 - force(j,i)=anorm_distr(x,sig,lowb,highb) - enddo - enddo - do i=nnt,nct - sig2=stdforcsc(i) - lowb2=-5*sig2 - highb2=5*sig2 - do j=1,3 - force(j,i+nres)=anorm_distr(x,sig2,lowb2,highb2) - enddo - enddo -#ifdef MPI - time_fsample=time_fsample+MPI_Wtime()-time00 -#else - time_fsample=time_fsample+tcpu()-time00 -#endif -c Compute the stochastic forces acting on virtual-bond vectors. - do j=1,3 - ff(j)=0.0d0 - enddo - do i=nct-1,nnt,-1 - do j=1,3 - stochforc(j,i)=ff(j)+0.5d0*force(j,i) - enddo - do j=1,3 - ff(j)=ff(j)+force(j,i) - enddo - if (itype(i+1).ne.ntyp1) then - do j=1,3 - stochforc(j,i)=stochforc(j,i)+force(j,i+nres+1) - ff(j)=ff(j)+force(j,i+nres+1) - enddo - endif - enddo - do j=1,3 - stochforc(j,0)=ff(j)+force(j,nnt+nres) - enddo - do i=nnt,nct - if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then - do j=1,3 - stochforc(j,i+nres)=force(j,i+nres) - enddo - endif - enddo - - do j=1,3 - stochforcvec(j)=stochforc(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - stochforcvec(ind+j)=stochforc(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if ((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then - do j=1,3 - stochforcvec(ind+j)=stochforc(j,i+nres) - enddo - ind=ind+3 - endif - enddo - if (lprn) then - write (iout,*) "stochforcvec" - do i=1,3*dimen - write(iout,'(i5,e15.5)') i,stochforcvec(i) - enddo - write(iout,*) "Stochastic forces backbone" - do i=0,nct-1 - write(iout,'(i5,3e15.5)') i,(stochforc(j,i),j=1,3) - enddo - write(iout,*) "Stochastic forces side chain" - do i=nnt,nct - write(iout,'(i5,3e15.5)') - & i,(stochforc(j,i+nres),j=1,3) - enddo - endif - - if (lprn) then - - ind=0 - do i=nnt,nct-1 - write (iout,*) i,ind - do j=1,3 - forcvec(ind+j)=force(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - write (iout,*) i,ind - do j=1,3 - forcvec(j+ind)=force(j,i+nres) - enddo - ind=ind+3 - enddo - - write (iout,*) "forcvec" - ind=0 - do i=nnt,nct-1 - do j=1,3 - write (iout,'(2i3,2f10.5)') i,j,force(j,i), - & forcvec(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - do j=1,3 - write (iout,'(2i3,2f10.5)') i,j,force(j,i+nres), - & forcvec(ind+j) - enddo - ind=ind+3 - enddo - - endif - - return - end -c------------------------------------------------------------------ - subroutine setup_fricmat - implicit real*8 (a-h,o-z) -#ifdef MPI - include 'mpif.h' -#endif - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.SETUP' - include 'COMMON.TIME1' -c integer licznik /0/ -c save licznik -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.IOUNITS' - integer IERROR - integer i,j,ind,ind1,m - logical lprn /.false./ - double precision dtdi,gamvec(MAXRES2), - & ginvfric(maxres2,maxres2),Ghalf(mmaxres2),fcopy(maxres2,maxres2) - common /syfek/ gamvec - double precision work(8*maxres2) - integer iwork(maxres2) - common /przechowalnia/ ginvfric,Ghalf,fcopy -#ifdef MPI - if (fg_rank.ne.king) goto 10 -#endif -c Zeroing out fricmat - do i=1,dimen - do j=1,dimen - fricmat(i,j)=0.0d0 - enddo - enddo -c Load the friction coefficients corresponding to peptide groups - ind1=0 - do i=nnt,nct-1 - ind1=ind1+1 - gamvec(ind1)=gamp - enddo -c Load the friction coefficients corresponding to side chains - m=nct-nnt - ind=0 - gamsc(ntyp1)=1.0d0 - do i=nnt,nct - ind=ind+1 - ii = ind+m - iti=itype(i) - gamvec(ii)=gamsc(iabs(iti)) - enddo - if (surfarea) call sdarea(gamvec) -c if (lprn) then -c write (iout,*) "Matrix A and vector gamma" -c do i=1,dimen1 -c write (iout,'(i2,$)') i -c do j=1,dimen -c write (iout,'(f4.1,$)') A(i,j) -c enddo -c write (iout,'(f8.3)') gamvec(i) -c enddo -c endif - if (lprn) then - write (iout,*) "Vector gamvec" - do i=1,dimen1 - write (iout,'(i5,f10.5)') i, gamvec(i) - enddo - endif - -c The friction matrix - do k=1,dimen - do i=1,dimen - dtdi=0.0d0 - do j=1,dimen1 - dtdi=dtdi+A(j,k)*A(j,i)*gamvec(j) - enddo - fricmat(k,i)=dtdi - enddo - enddo - - if (lprn) then - write (iout,'(//a)') "Matrix fricmat" - call matout2(dimen,dimen,maxres2,maxres2,fricmat) - endif - if (lang.eq.2 .or. lang.eq.3) then -c Mass-scale the friction matrix if non-direct integration will be performed - do i=1,dimen - do j=1,dimen - Ginvfric(i,j)=0.0d0 - do k=1,dimen - do l=1,dimen - Ginvfric(i,j)=Ginvfric(i,j)+ - & Gsqrm(i,k)*Gsqrm(l,j)*fricmat(k,l) - enddo - enddo - enddo - enddo -c Diagonalize the friction matrix - ind=0 - do i=1,dimen - do j=1,i - ind=ind+1 - Ghalf(ind)=Ginvfric(i,j) - enddo - enddo - call gldiag(maxres2,dimen,dimen,Ghalf,work,fricgam,fricvec, - & ierr,iwork) - if (lprn) then - write (iout,'(//2a)') "Eigenvectors and eigenvalues of the", - & " mass-scaled friction matrix" - call eigout(dimen,dimen,maxres2,maxres2,fricvec,fricgam) - endif -c Precompute matrices for tinker stochastic integrator -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - mt1(i,j)=0.0d0 - mt2(i,j)=0.0d0 - do k=1,dimen - mt1(i,j)=mt1(i,j)+fricvec(k,i)*gsqrm(k,j) - mt2(i,j)=mt2(i,j)+fricvec(k,i)*gsqrp(k,j) - enddo - mt3(j,i)=mt1(i,j) - enddo - enddo -#endif - else if (lang.eq.4) then -c Diagonalize the friction matrix - ind=0 - do i=1,dimen - do j=1,i - ind=ind+1 - Ghalf(ind)=fricmat(i,j) - enddo - enddo - call gldiag(maxres2,dimen,dimen,Ghalf,work,fricgam,fricvec, - & ierr,iwork) - if (lprn) then - write (iout,'(//2a)') "Eigenvectors and eigenvalues of the", - & " friction matrix" - call eigout(dimen,dimen,maxres2,maxres2,fricvec,fricgam) - endif -c Determine the number of zero eigenvalues of the friction matrix - nzero=max0(dimen-dimen1,0) -c do while (fricgam(nzero+1).le.1.0d-5 .and. nzero.lt.dimen) -c nzero=nzero+1 -c enddo - write (iout,*) "Number of zero eigenvalues:",nzero - do i=1,dimen - do j=1,dimen - fricmat(i,j)=0.0d0 - do k=nzero+1,dimen - fricmat(i,j)=fricmat(i,j) - & +fricvec(i,k)*fricvec(j,k)/fricgam(k) - enddo - enddo - enddo - if (lprn) then - write (iout,'(//a)') "Generalized inverse of fricmat" - call matout(dimen,dimen,maxres6,maxres6,fricmat) - endif - endif -#ifdef MPI - 10 continue - if (nfgtasks.gt.1) then - if (fg_rank.eq.0) then -c The matching BROADCAST for fg processors is called in ERGASTULUM -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif - call MPI_Bcast(10,1,MPI_INTEGER,king,FG_COMM,IERROR) -#ifdef MPI - time_Bcast=time_Bcast+MPI_Wtime()-time00 -#else - time_Bcast=time_Bcast+tcpu()-time00 -#endif -c print *,"Processor",myrank, -c & " BROADCAST iorder in SETUP_FRICMAT" - endif -c licznik=licznik+1 -c write (iout,*) "setup_fricmat licznik",licznik -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif -c Scatter the friction matrix - call MPI_Scatterv(fricmat(1,1),nginv_counts(0), - & nginv_start(0),MPI_DOUBLE_PRECISION,fcopy(1,1), - & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) -#ifdef TIMING -#ifdef MPI - time_scatter=time_scatter+MPI_Wtime()-time00 - time_scatter_fmat=time_scatter_fmat+MPI_Wtime()-time00 -#else - time_scatter=time_scatter+tcpu()-time00 - time_scatter_fmat=time_scatter_fmat+tcpu()-time00 -#endif -#endif - do i=1,dimen - do j=1,2*my_ng_count - fricmat(j,i)=fcopy(i,j) - enddo - enddo -c write (iout,*) "My chunk of fricmat" -c call MATOUT2(my_ng_count,dimen,maxres2,maxres2,fcopy) - endif -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sdarea(gamvec) -c -c Scale the friction coefficients according to solvent accessible surface areas -c Code adapted from TINKER -c AL 9/3/04 -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision radius(maxres2),gamvec(maxres2) - parameter (twosix=1.122462048309372981d0) - logical lprn /.false./ -c -c determine new friction coefficients every few SD steps -c -c set the atomic radii to estimates of sigma values -c -c print *,"Entered sdarea" - probe = 0.0d0 - - do i=1,2*nres - radius(i)=0.0d0 - enddo -c Load peptide group radii - do i=nnt,nct-1 - radius(i)=pstok - enddo -c Load side chain radii - do i=nnt,nct - iti=itype(i) - radius(i+nres)=restok(iti) - enddo -c do i=1,2*nres -c write (iout,*) "i",i," radius",radius(i) -c enddo - do i = 1, 2*nres - radius(i) = radius(i) / twosix - if (radius(i) .ne. 0.0d0) radius(i) = radius(i) + probe - end do -c -c scale atomic friction coefficients by accessible area -c - if (lprn) write (iout,*) - & "Original gammas, surface areas, scaling factors, new gammas, ", - & "std's of stochastic forces" - ind=0 - do i=nnt,nct-1 - if (radius(i).gt.0.0d0) then - call surfatom (i,area,radius) - ratio = dmax1(area/(4.0d0*pi*radius(i)**2),1.0d-1) - if (lprn) write (iout,'(i5,3f10.5,$)') - & i,gamvec(ind+1),area,ratio - do j=1,3 - ind=ind+1 - gamvec(ind) = ratio * gamvec(ind) - enddo - stdforcp(i)=stdfp*dsqrt(gamvec(ind)) - if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcp(i) - endif - enddo - do i=nnt,nct - if (radius(i+nres).gt.0.0d0) then - call surfatom (i+nres,area,radius) - ratio = dmax1(area/(4.0d0*pi*radius(i+nres)**2),1.0d-1) - if (lprn) write (iout,'(i5,3f10.5,$)') - & i,gamvec(ind+1),area,ratio - do j=1,3 - ind=ind+1 - gamvec(ind) = ratio * gamvec(ind) - enddo - stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamvec(ind)) - if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcsc(i) - endif - enddo - - return - end diff --git a/source/unres/src_MD-M-newcorr/sumsld.f b/source/unres/src_MD-M-newcorr/sumsld.f deleted file mode 100644 index 1ce7b78..0000000 --- a/source/unres/src_MD-M-newcorr/sumsld.f +++ /dev/null @@ -1,1446 +0,0 @@ - subroutine sumsl(n, d, x, calcf, calcg, iv, liv, lv, v, - 1 uiparm, urparm, ufparm) -c -c *** minimize general unconstrained objective function using *** -c *** analytic gradient and hessian approx. from secant update *** -c - integer n, liv, lv - integer iv(liv), uiparm(1) - double precision d(n), x(n), v(lv), urparm(1) -c dimension v(71 + n*(n+15)/2), uiparm(*), urparm(*) - external calcf, calcg, ufparm -c -c *** purpose *** -c -c this routine interacts with subroutine sumit in an attempt -c to find an n-vector x* that minimizes the (unconstrained) -c objective function computed by calcf. (often the x* found is -c a local minimizer rather than a global one.) -c -c-------------------------- parameter usage -------------------------- -c -c n........ (input) the number of variables on which f depends, i.e., -c the number of components in x. -c d........ (input/output) a scale vector such that d(i)*x(i), -c i = 1,2,...,n, are all in comparable units. -c d can strongly affect the behavior of sumsl. -c finding the best choice of d is generally a trial- -c and-error process. choosing d so that d(i)*x(i) -c has about the same value for all i often works well. -c the defaults provided by subroutine deflt (see i -c below) require the caller to supply d. -c x........ (input/output) before (initially) calling sumsl, the call- -c er should set x to an initial guess at x*. when -c sumsl returns, x contains the best point so far -c found, i.e., the one that gives the least value so -c far seen for f(x). -c calcf.... (input) a subroutine that, given x, computes f(x). calcf -c must be declared external in the calling program. -c it is invoked by -c call calcf(n, x, nf, f, uiparm, urparm, ufparm) -c when calcf is called, nf is the invocation -c count for calcf. nf is included for possible use -c with calcg. if x is out of bounds (e.g., if it -c would cause overflow in computing f(x)), then calcf -c should set nf to 0. this will cause a shorter step -c to be attempted. (if x is in bounds, then calcf -c should not change nf.) the other parameters are as -c described above and below. calcf should not change -c n, p, or x. -c calcg.... (input) a subroutine that, given x, computes g(x), the gra- -c dient of f at x. calcg must be declared external in -c the calling program. it is invoked by -c call calcg(n, x, nf, g, uiparm, urparm, ufaprm) -c when calcg is called, nf is the invocation -c count for calcf at the time f(x) was evaluated. the -c x passed to calcg is usually the one passed to calcf -c on either its most recent invocation or the one -c prior to it. if calcf saves intermediate results -c for use by calcg, then it is possible to tell from -c nf whether they are valid for the current x (or -c which copy is valid if two copies are kept). if g -c cannot be computed at x, then calcg should set nf to -c 0. in this case, sumsl will return with iv(1) = 65. -c (if g can be computed at x, then calcg should not -c changed nf.) the other parameters to calcg are as -c described above and below. calcg should not change -c n or x. -c iv....... (input/output) an integer value array of length liv (see -c below) that helps control the sumsl algorithm and -c that is used to store various intermediate quanti- -c ties. of particular interest are the initialization/ -c return code iv(1) and the entries in iv that control -c printing and limit the number of iterations and func- -c tion evaluations. see the section on iv input -c values below. -c liv...... (input) length of iv array. must be at least 60. if li -c is too small, then sumsl returns with iv(1) = 15. -c when sumsl returns, the smallest allowed value of -c liv is stored in iv(lastiv) -- see the section on -c iv output values below. (this is intended for use -c with extensions of sumsl that handle constraints.) -c lv....... (input) length of v array. must be at least 71+n*(n+15)/2. -c (at least 77+n*(n+17)/2 for smsno, at least -c 78+n*(n+12) for humsl). if lv is too small, then -c sumsl returns with iv(1) = 16. when sumsl returns, -c the smallest allowed value of lv is stored in -c iv(lastv) -- see the section on iv output values -c below. -c v........ (input/output) a floating-point value array of length l -c (see below) that helps control the sumsl algorithm -c and that is used to store various intermediate -c quantities. of particular interest are the entries -c in v that limit the length of the first step -c attempted (lmax0) and specify convergence tolerances -c (afctol, lmaxs, rfctol, sctol, xctol, xftol). -c uiparm... (input) user integer parameter array passed without change -c to calcf and calcg. -c urparm... (input) user floating-point parameter array passed without -c change to calcf and calcg. -c ufparm... (input) user external subroutine or function passed without -c change to calcf and calcg. -c -c *** iv input values (from subroutine deflt) *** -c -c iv(1)... on input, iv(1) should have a value between 0 and 14...... -c 0 and 12 mean this is a fresh start. 0 means that -c deflt(2, iv, liv, lv, v) -c is to be called to provide all default values to iv and -c v. 12 (the value that deflt assigns to iv(1)) means the -c caller has already called deflt and has possibly changed -c some iv and/or v entries to non-default values. -c 13 means deflt has been called and that sumsl (and -c sumit) should only do their storage allocation. that is, -c they should set the output components of iv that tell -c where various subarrays arrays of v begin, such as iv(g) -c (and, for humsl and humit only, iv(dtol)), and return. -c 14 means that a storage has been allocated (by a call -c with iv(1) = 13) and that the algorithm should be -c started. when called with iv(1) = 13, sumsl returns -c iv(1) = 14 unless liv or lv is too small (or n is not -c positive). default = 12. -c iv(inith).... iv(25) tells whether the hessian approximation h should -c be initialized. 1 (the default) means sumit should -c initialize h to the diagonal matrix whose i-th diagonal -c element is d(i)**2. 0 means the caller has supplied a -c cholesky factor l of the initial hessian approximation -c h = l*(l**t) in v, starting at v(iv(lmat)) = v(iv(42)) -c (and stored compactly by rows). note that iv(lmat) may -c be initialized by calling sumsl with iv(1) = 13 (see -c the iv(1) discussion above). default = 1. -c iv(mxfcal)... iv(17) gives the maximum number of function evaluations -c (calls on calcf) allowed. if this number does not suf- -c fice, then sumsl returns with iv(1) = 9. default = 200. -c iv(mxiter)... iv(18) gives the maximum number of iterations allowed. -c it also indirectly limits the number of gradient evalua- -c tions (calls on calcg) to iv(mxiter) + 1. if iv(mxiter) -c iterations do not suffice, then sumsl returns with -c iv(1) = 10. default = 150. -c iv(outlev)... iv(19) controls the number and length of iteration sum- -c mary lines printed (by itsum). iv(outlev) = 0 means do -c not print any summary lines. otherwise, print a summary -c line after each abs(iv(outlev)) iterations. if iv(outlev) -c is positive, then summary lines of length 78 (plus carri- -c age control) are printed, including the following... the -c iteration and function evaluation counts, f = the current -c function value, relative difference in function values -c achieved by the latest step (i.e., reldf = (f0-v(f))/f01, -c where f01 is the maximum of abs(v(f)) and abs(v(f0)) and -c v(f0) is the function value from the previous itera- -c tion), the relative function reduction predicted for the -c step just taken (i.e., preldf = v(preduc) / f01, where -c v(preduc) is described below), the scaled relative change -c in x (see v(reldx) below), the step parameter for the -c step just taken (stppar = 0 means a full newton step, -c between 0 and 1 means a relaxed newton step, between 1 -c and 2 means a double dogleg step, greater than 2 means -c a scaled down cauchy step -- see subroutine dbldog), the -c 2-norm of the scale vector d times the step just taken -c (see v(dstnrm) below), and npreldf, i.e., -c v(nreduc)/f01, where v(nreduc) is described below -- if -c npreldf is positive, then it is the relative function -c reduction predicted for a newton step (one with -c stppar = 0). if npreldf is negative, then it is the -c negative of the relative function reduction predicted -c for a step computed with step bound v(lmaxs) for use in -c testing for singular convergence. -c if iv(outlev) is negative, then lines of length 50 -c are printed, including only the first 6 items listed -c above (through reldx). -c default = 1. -c iv(parprt)... iv(20) = 1 means print any nondefault v values on a -c fresh start or any changed v values on a restart. -c iv(parprt) = 0 means skip this printing. default = 1. -c iv(prunit)... iv(21) is the output unit number on which all printing -c is done. iv(prunit) = 0 means suppress all printing. -c default = standard output unit (unit 6 on most systems). -c iv(solprt)... iv(22) = 1 means print out the value of x returned (as -c well as the gradient and the scale vector d). -c iv(solprt) = 0 means skip this printing. default = 1. -c iv(statpr)... iv(23) = 1 means print summary statistics upon return- -c ing. these consist of the function value, the scaled -c relative change in x caused by the most recent step (see -c v(reldx) below), the number of function and gradient -c evaluations (calls on calcf and calcg), and the relative -c function reductions predicted for the last step taken and -c for a newton step (or perhaps a step bounded by v(lmaxs) -c -- see the descriptions of preldf and npreldf under -c iv(outlev) above). -c iv(statpr) = 0 means skip this printing. -c iv(statpr) = -1 means skip this printing as well as that -c of the one-line termination reason message. default = 1. -c iv(x0prt).... iv(24) = 1 means print the initial x and scale vector d -c (on a fresh start only). iv(x0prt) = 0 means skip this -c printing. default = 1. -c -c *** (selected) iv output values *** -c -c iv(1)........ on output, iv(1) is a return code.... -c 3 = x-convergence. the scaled relative difference (see -c v(reldx)) between the current parameter vector x and -c a locally optimal parameter vector is very likely at -c most v(xctol). -c 4 = relative function convergence. the relative differ- -c ence between the current function value and its lo- -c cally optimal value is very likely at most v(rfctol). -c 5 = both x- and relative function convergence (i.e., the -c conditions for iv(1) = 3 and iv(1) = 4 both hold). -c 6 = absolute function convergence. the current function -c value is at most v(afctol) in absolute value. -c 7 = singular convergence. the hessian near the current -c iterate appears to be singular or nearly so, and a -c step of length at most v(lmaxs) is unlikely to yield -c a relative function decrease of more than v(sctol). -c 8 = false convergence. the iterates appear to be converg- -c ing to a noncritical point. this may mean that the -c convergence tolerances (v(afctol), v(rfctol), -c v(xctol)) are too small for the accuracy to which -c the function and gradient are being computed, that -c there is an error in computing the gradient, or that -c the function or gradient is discontinuous near x. -c 9 = function evaluation limit reached without other con- -c vergence (see iv(mxfcal)). -c 10 = iteration limit reached without other convergence -c (see iv(mxiter)). -c 11 = stopx returned .true. (external interrupt). see the -c usage notes below. -c 14 = storage has been allocated (after a call with -c iv(1) = 13). -c 17 = restart attempted with n changed. -c 18 = d has a negative component and iv(dtype) .le. 0. -c 19...43 = v(iv(1)) is out of range. -c 63 = f(x) cannot be computed at the initial x. -c 64 = bad parameters passed to assess (which should not -c occur). -c 65 = the gradient could not be computed at x (see calcg -c above). -c 67 = bad first parameter to deflt. -c 80 = iv(1) was out of range. -c 81 = n is not positive. -c iv(g)........ iv(28) is the starting subscript in v of the current -c gradient vector (the one corresponding to x). -c iv(lastiv)... iv(44) is the least acceptable value of liv. (it is -c only set if liv is at least 44.) -c iv(lastv).... iv(45) is the least acceptable value of lv. (it is -c only set if liv is large enough, at least iv(lastiv).) -c iv(nfcall)... iv(6) is the number of calls so far made on calcf (i.e., -c function evaluations). -c iv(ngcall)... iv(30) is the number of gradient evaluations (calls on -c calcg). -c iv(niter).... iv(31) is the number of iterations performed. -c -c *** (selected) v input values (from subroutine deflt) *** -c -c v(bias)..... v(43) is the bias parameter used in subroutine dbldog -- -c see that subroutine for details. default = 0.8. -c v(afctol)... v(31) is the absolute function convergence tolerance. -c if sumsl finds a point where the function value is less -c than v(afctol) in absolute value, and if sumsl does not -c return with iv(1) = 3, 4, or 5, then it returns with -c iv(1) = 6. this test can be turned off by setting -c v(afctol) to zero. default = max(10**-20, machep**2), -c where machep is the unit roundoff. -c v(dinit).... v(38), if nonnegative, is the value to which the scale -c vector d is initialized. default = -1. -c v(lmax0).... v(35) gives the maximum 2-norm allowed for d times the -c very first step that sumsl attempts. this parameter can -c markedly affect the performance of sumsl. -c v(lmaxs).... v(36) is used in testing for singular convergence -- if -c the function reduction predicted for a step of length -c bounded by v(lmaxs) is at most v(sctol) * abs(f0), where -c f0 is the function value at the start of the current -c iteration, and if sumsl does not return with iv(1) = 3, -c 4, 5, or 6, then it returns with iv(1) = 7. default = 1. -c v(rfctol)... v(32) is the relative function convergence tolerance. -c if the current model predicts a maximum possible function -c reduction (see v(nreduc)) of at most v(rfctol)*abs(f0) -c at the start of the current iteration, where f0 is the -c then current function value, and if the last step attempt- -c ed achieved no more than twice the predicted function -c decrease, then sumsl returns with iv(1) = 4 (or 5). -c default = max(10**-10, machep**(2/3)), where machep is -c the unit roundoff. -c v(sctol).... v(37) is the singular convergence tolerance -- see the -c description of v(lmaxs) above. -c v(tuner1)... v(26) helps decide when to check for false convergence. -c this is done if the actual function decrease from the -c current step is no more than v(tuner1) times its predict- -c ed value. default = 0.1. -c v(xctol).... v(33) is the x-convergence tolerance. if a newton step -c (see v(nreduc)) is tried that has v(reldx) .le. v(xctol) -c and if this step yields at most twice the predicted func- -c tion decrease, then sumsl returns with iv(1) = 3 (or 5). -c (see the description of v(reldx) below.) -c default = machep**0.5, where machep is the unit roundoff. -c v(xftol).... v(34) is the false convergence tolerance. if a step is -c tried that gives no more than v(tuner1) times the predict- -c ed function decrease and that has v(reldx) .le. v(xftol), -c and if sumsl does not return with iv(1) = 3, 4, 5, 6, or -c 7, then it returns with iv(1) = 8. (see the description -c of v(reldx) below.) default = 100*machep, where -c machep is the unit roundoff. -c v(*)........ deflt supplies to v a number of tuning constants, with -c which it should ordinarily be unnecessary to tinker. see -c section 17 of version 2.2 of the nl2sol usage summary -c (i.e., the appendix to ref. 1) for details on v(i), -c i = decfac, incfac, phmnfc, phmxfc, rdfcmn, rdfcmx, -c tuner2, tuner3, tuner4, tuner5. -c -c *** (selected) v output values *** -c -c v(dgnorm)... v(1) is the 2-norm of (diag(d)**-1)*g, where g is the -c most recently computed gradient. -c v(dstnrm)... v(2) is the 2-norm of diag(d)*step, where step is the -c current step. -c v(f)........ v(10) is the current function value. -c v(f0)....... v(13) is the function value at the start of the current -c iteration. -c v(nreduc)... v(6), if positive, is the maximum function reduction -c possible according to the current model, i.e., the func- -c tion reduction predicted for a newton step (i.e., -c step = -h**-1 * g, where g is the current gradient and -c h is the current hessian approximation). -c if v(nreduc) is negative, then it is the negative of -c the function reduction predicted for a step computed with -c a step bound of v(lmaxs) for use in testing for singular -c convergence. -c v(preduc)... v(7) is the function reduction predicted (by the current -c quadratic model) for the current step. this (divided by -c v(f0)) is used in testing for relative function -c convergence. -c v(reldx).... v(17) is the scaled relative change in x caused by the -c current step, computed as -c max(abs(d(i)*(x(i)-x0(i)), 1 .le. i .le. p) / -c max(d(i)*(abs(x(i))+abs(x0(i))), 1 .le. i .le. p), -c where x = x0 + step. -c -c------------------------------- notes ------------------------------- -c -c *** algorithm notes *** -c -c this routine uses a hessian approximation computed from the -c bfgs update (see ref 3). only a cholesky factor of the hessian -c approximation is stored, and this is updated using ideas from -c ref. 4. steps are computed by the double dogleg scheme described -c in ref. 2. the steps are assessed as in ref. 1. -c -c *** usage notes *** -c -c after a return with iv(1) .le. 11, it is possible to restart, -c i.e., to change some of the iv and v input values described above -c and continue the algorithm from the point where it was interrupt- -c ed. iv(1) should not be changed, nor should any entries of i -c and v other than the input values (those supplied by deflt). -c those who do not wish to write a calcg which computes the -c gradient analytically should call smsno rather than sumsl. -c smsno uses finite differences to compute an approximate gradient. -c those who would prefer to provide f and g (the function and -c gradient) by reverse communication rather than by writing subrou- -c tines calcf and calcg may call on sumit directly. see the com- -c ments at the beginning of sumit. -c those who use sumsl interactively may wish to supply their -c own stopx function, which should return .true. if the break key -c has been pressed since stopx was last invoked. this makes it -c possible to externally interrupt sumsl (which will return with -c iv(1) = 11 if stopx returns .true.). -c storage for g is allocated at the end of v. thus the caller -c may make v longer than specified above and may allow calcg to use -c elements of g beyond the first n as scratch storage. -c -c *** portability notes *** -c -c the sumsl distribution tape contains both single- and double- -c precision versions of the sumsl source code, so it should be un- -c necessary to change precisions. -c only the functions imdcon and rmdcon contain machine-dependent -c constants. to change from one machine to another, it should -c suffice to change the (few) relevant lines in these functions. -c intrinsic functions are explicitly declared. on certain com- -c puters (e.g. univac), it may be necessary to comment out these -c declarations. so that this may be done automatically by a simple -c program, such declarations are preceded by a comment having c/+ -c in columns 1-3 and blanks in columns 4-72 and are followed by -c a comment having c/ in columns 1 and 2 and blanks in columns 3-72. -c the sumsl source code is expressed in 1966 ansi standard -c fortran. it may be converted to fortran 77 by commenting out all -c lines that fall between a line having c/6 in columns 1-3 and a -c line having c/7 in columns 1-3 and by removing (i.e., replacing -c by a blank) the c in column 1 of the lines that follow the c/7 -c line and precede a line having c/ in columns 1-2 and blanks in -c columns 3-72. these changes convert some data statements into -c parameter statements, convert some variables from real to -c character*4, and make the data statements that initialize these -c variables use character strings delimited by primes instead -c of hollerith constants. (such variables and data statements -c appear only in modules itsum and parck. parameter statements -c appear nearly everywhere.) these changes also add save state- -c ments for variables given machine-dependent constants by rmdcon. -c -c *** references *** -c -c 1. dennis, j.e., gay, d.m., and welsch, r.e. (1981), algorithm 573 -- -c an adaptive nonlinear least-squares algorithm, acm trans. -c math. software 7, pp. 369-383. -c -c 2. dennis, j.e., and mei, h.h.w. (1979), two new unconstrained opti- -c mization algorithms which use function and gradient -c values, j. optim. theory applic. 28, pp. 453-482. -c -c 3. dennis, j.e., and more, j.j. (1977), quasi-newton methods, motiva- -c tion and theory, siam rev. 19, pp. 46-89. -c -c 4. goldfarb, d. (1976), factorized variable metric methods for uncon- -c strained optimization, math. comput. 30, pp. 796-811. -c -c *** general *** -c -c coded by david m. gay (winter 1980). revised summer 1982. -c this subroutine was written in connection with research -c supported in part by the national science foundation under -c grants mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, -c and mcs-7906671. -c. -c -c---------------------------- declarations --------------------------- -c - external deflt, sumit -c -c deflt... supplies default iv and v input components. -c sumit... reverse-communication routine that carries out sumsl algo- -c rithm. -c - integer g1, iv1, nf - double precision f -c -c *** subscripts for iv *** -c - integer nextv, nfcall, nfgcal, g, toobig, vneed -c -c/6 -c data nextv/47/, nfcall/6/, nfgcal/7/, g/28/, toobig/2/, vneed/4/ -c/7 - parameter (nextv=47, nfcall=6, nfgcal=7, g=28, toobig=2, vneed=4) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - iv1 = iv(1) - if (iv1 .eq. 12 .or. iv1 .eq. 13) iv(vneed) = iv(vneed) + n - if (iv1 .eq. 14) go to 10 - if (iv1 .gt. 2 .and. iv1 .lt. 12) go to 10 - g1 = 1 - if (iv1 .eq. 12) iv(1) = 13 - go to 20 -c - 10 g1 = iv(g) -c - 20 call sumit(d, f, v(g1), iv, liv, lv, n, v, x) - if (iv(1) - 2) 30, 40, 50 -c - 30 nf = iv(nfcall) - call calcf(n, x, nf, f, uiparm, urparm, ufparm) - if (nf .le. 0) iv(toobig) = 1 - go to 20 -c - 40 call calcg(n, x, iv(nfgcal), v(g1), uiparm, urparm, ufparm) - go to 20 -c - 50 if (iv(1) .ne. 14) go to 999 -c -c *** storage allocation -c - iv(g) = iv(nextv) - iv(nextv) = iv(g) + n - if (iv1 .ne. 13) go to 10 -c - 999 return -c *** last card of sumsl follows *** - end - subroutine sumit(d, fx, g, iv, liv, lv, n, v, x) -c -c *** carry out sumsl (unconstrained minimization) iterations, using -c *** double-dogleg/bfgs steps. -c -c *** parameter declarations *** -c - integer liv, lv, n - integer iv(liv) - double precision d(n), fx, g(n), v(lv), x(n) -c -c-------------------------- parameter usage -------------------------- -c -c d.... scale vector. -c fx... function value. -c g.... gradient vector. -c iv... integer value array. -c liv.. length of iv (at least 60). -c lv... length of v (at least 71 + n*(n+13)/2). -c n.... number of variables (components in x and g). -c v.... floating-point value array. -c x.... vector of parameters to be optimized. -c -c *** discussion *** -c -c parameters iv, n, v, and x are the same as the corresponding -c ones to sumsl (which see), except that v can be shorter (since -c the part of v that sumsl uses for storing g is not needed). -c moreover, compared with sumsl, iv(1) may have the two additional -c output values 1 and 2, which are explained below, as is the use -c of iv(toobig) and iv(nfgcal). the value iv(g), which is an -c output value from sumsl (and smsno), is not referenced by -c sumit or the subroutines it calls. -c fx and g need not have been initialized when sumit is called -c with iv(1) = 12, 13, or 14. -c -c iv(1) = 1 means the caller should set fx to f(x), the function value -c at x, and call sumit again, having changed none of the -c other parameters. an exception occurs if f(x) cannot be -c (e.g. if overflow would occur), which may happen because -c of an oversized step. in this case the caller should set -c iv(toobig) = iv(2) to 1, which will cause sumit to ig- -c nore fx and try a smaller step. the parameter nf that -c sumsl passes to calcf (for possible use by calcg) is a -c copy of iv(nfcall) = iv(6). -c iv(1) = 2 means the caller should set g to g(x), the gradient vector -c of f at x, and call sumit again, having changed none of -c the other parameters except possibly the scale vector d -c when iv(dtype) = 0. the parameter nf that sumsl passes -c to calcg is iv(nfgcal) = iv(7). if g(x) cannot be -c evaluated, then the caller may set iv(nfgcal) to 0, in -c which case sumit will return with iv(1) = 65. -c. -c *** general *** -c -c coded by david m. gay (december 1979). revised sept. 1982. -c this subroutine was written in connection with research supported -c in part by the national science foundation under grants -c mcs-7600324 and mcs-7906671. -c -c (see sumsl for references.) -c -c+++++++++++++++++++++++++++ declarations ++++++++++++++++++++++++++++ -c -c *** local variables *** -c - integer dg1, dummy, g01, i, k, l, lstgst, nwtst1, step1, - 1 temp1, w, x01, z - double precision t -c -c *** constants *** -c - double precision half, negone, one, onep2, zero -c -c *** no intrinsic functions *** -c -c *** external functions and subroutines *** -c - external assst, dbdog, deflt, dotprd, itsum, litvmu, livmul, - 1 ltvmul, lupdat, lvmul, parck, reldst, stopx, vaxpy, - 2 vcopy, vscopy, vvmulp, v2norm, wzbfgs - logical stopx - double precision dotprd, reldst, v2norm -c -c assst.... assesses candidate step. -c dbdog.... computes double-dogleg (candidate) step. -c deflt.... supplies default iv and v input components. -c dotprd... returns inner product of two vectors. -c itsum.... prints iteration summary and info on initial and final x. -c litvmu... multiplies inverse transpose of lower triangle times vector. -c livmul... multiplies inverse of lower triangle times vector. -c ltvmul... multiplies transpose of lower triangle times vector. -c lupdt.... updates cholesky factor of hessian approximation. -c lvmul.... multiplies lower triangle times vector. -c parck.... checks validity of input iv and v values. -c reldst... computes v(reldx) = relative step size. -c stopx.... returns .true. if the break key has been pressed. -c vaxpy.... computes scalar times one vector plus another. -c vcopy.... copies one vector to another. -c vscopy... sets all elements of a vector to a scalar. -c vvmulp... multiplies vector by vector raised to power (componentwise). -c v2norm... returns the 2-norm of a vector. -c wzbfgs... computes w and z for lupdat corresponding to bfgs update. -c -c *** subscripts for iv and v *** -c - integer afctol - integer cnvcod, dg, dgnorm, dinit, dstnrm, dst0, f, f0, fdif, - 1 gthg, gtstep, g0, incfac, inith, irc, kagqt, lmat, lmax0, - 2 lmaxs, mode, model, mxfcal, mxiter, nextv, nfcall, nfgcal, - 3 ngcall, niter, nreduc, nwtstp, preduc, radfac, radinc, - 4 radius, rad0, reldx, restor, step, stglim, stlstg, toobig, - 5 tuner4, tuner5, vneed, xirc, x0 -c -c *** iv subscript values *** -c -c/6 -c data cnvcod/55/, dg/37/, g0/48/, inith/25/, irc/29/, kagqt/33/, -c 1 mode/35/, model/5/, mxfcal/17/, mxiter/18/, nfcall/6/, -c 2 nfgcal/7/, ngcall/30/, niter/31/, nwtstp/34/, radinc/8/, -c 3 restor/9/, step/40/, stglim/11/, stlstg/41/, toobig/2/, -c 4 vneed/4/, xirc/13/, x0/43/ -c/7 - parameter (cnvcod=55, dg=37, g0=48, inith=25, irc=29, kagqt=33, - 1 mode=35, model=5, mxfcal=17, mxiter=18, nfcall=6, - 2 nfgcal=7, ngcall=30, niter=31, nwtstp=34, radinc=8, - 3 restor=9, step=40, stglim=11, stlstg=41, toobig=2, - 4 vneed=4, xirc=13, x0=43) -c/ -c -c *** v subscript values *** -c -c/6 -c data afctol/31/ -c data dgnorm/1/, dinit/38/, dstnrm/2/, dst0/3/, f/10/, f0/13/, -c 1 fdif/11/, gthg/44/, gtstep/4/, incfac/23/, lmat/42/, -c 2 lmax0/35/, lmaxs/36/, nextv/47/, nreduc/6/, preduc/7/, -c 3 radfac/16/, radius/8/, rad0/9/, reldx/17/, tuner4/29/, -c 4 tuner5/30/ -c/7 - parameter (afctol=31) - parameter (dgnorm=1, dinit=38, dstnrm=2, dst0=3, f=10, f0=13, - 1 fdif=11, gthg=44, gtstep=4, incfac=23, lmat=42, - 2 lmax0=35, lmaxs=36, nextv=47, nreduc=6, preduc=7, - 3 radfac=16, radius=8, rad0=9, reldx=17, tuner4=29, - 4 tuner5=30) -c/ -c -c/6 -c data half/0.5d+0/, negone/-1.d+0/, one/1.d+0/, onep2/1.2d+0/, -c 1 zero/0.d+0/ -c/7 - parameter (half=0.5d+0, negone=-1.d+0, one=1.d+0, onep2=1.2d+0, - 1 zero=0.d+0) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c -C Following SAVE statement inserted. - save l - i = iv(1) - if (i .eq. 1) go to 50 - if (i .eq. 2) go to 60 -c -c *** check validity of iv and v input values *** -c - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - if (iv(1) .eq. 12 .or. iv(1) .eq. 13) - 1 iv(vneed) = iv(vneed) + n*(n+13)/2 - call parck(2, d, iv, liv, lv, n, v) - i = iv(1) - 2 - if (i .gt. 12) go to 999 - go to (180, 180, 180, 180, 180, 180, 120, 90, 120, 10, 10, 20), i -c -c *** storage allocation *** -c -10 l = iv(lmat) - iv(x0) = l + n*(n+1)/2 - iv(step) = iv(x0) + n - iv(stlstg) = iv(step) + n - iv(g0) = iv(stlstg) + n - iv(nwtstp) = iv(g0) + n - iv(dg) = iv(nwtstp) + n - iv(nextv) = iv(dg) + n - if (iv(1) .ne. 13) go to 20 - iv(1) = 14 - go to 999 -c -c *** initialization *** -c - 20 iv(niter) = 0 - iv(nfcall) = 1 - iv(ngcall) = 1 - iv(nfgcal) = 1 - iv(mode) = -1 - iv(model) = 1 - iv(stglim) = 1 - iv(toobig) = 0 - iv(cnvcod) = 0 - iv(radinc) = 0 - v(rad0) = zero - if (v(dinit) .ge. zero) call vscopy(n, d, v(dinit)) - if (iv(inith) .ne. 1) go to 40 -c -c *** set the initial hessian approximation to diag(d)**-2 *** -c - l = iv(lmat) - call vscopy(n*(n+1)/2, v(l), zero) - k = l - 1 - do 30 i = 1, n - k = k + i - t = d(i) - if (t .le. zero) t = one - v(k) = t - 30 continue -c -c *** compute initial function value *** -c - 40 iv(1) = 1 - go to 999 -c - 50 v(f) = fx - if (iv(mode) .ge. 0) go to 180 - iv(1) = 2 - if (iv(toobig) .eq. 0) go to 999 - iv(1) = 63 - go to 300 -c -c *** make sure gradient could be computed *** -c - 60 if (iv(nfgcal) .ne. 0) go to 70 - iv(1) = 65 - go to 300 -c - 70 dg1 = iv(dg) - call vvmulp(n, v(dg1), g, d, -1) - v(dgnorm) = v2norm(n, v(dg1)) -c -c *** test norm of gradient *** -c - if (v(dgnorm) .gt. v(afctol)) go to 75 - iv(irc) = 10 - iv(cnvcod) = iv(irc) - 4 -c - 75 if (iv(cnvcod) .ne. 0) go to 290 - if (iv(mode) .eq. 0) go to 250 -c -c *** allow first step to have scaled 2-norm at most v(lmax0) *** -c - v(radius) = v(lmax0) -c - iv(mode) = 0 -c -c -c----------------------------- main loop ----------------------------- -c -c -c *** print iteration summary, check iteration limit *** -c - 80 call itsum(d, g, iv, liv, lv, n, v, x) - 90 k = iv(niter) - if (k .lt. iv(mxiter)) go to 100 - iv(1) = 10 - go to 300 -c -c *** update radius *** -c - 100 iv(niter) = k + 1 - if(k.gt.0)v(radius) = v(radfac) * v(dstnrm) -c -c *** initialize for start of next iteration *** -c - g01 = iv(g0) - x01 = iv(x0) - v(f0) = v(f) - iv(irc) = 4 - iv(kagqt) = -1 -c -c *** copy x to x0, g to g0 *** -c - call vcopy(n, v(x01), x) - call vcopy(n, v(g01), g) -c -c *** check stopx and function evaluation limit *** -c -C AL 4/30/95 - dummy=iv(nfcall) - 110 if (.not. stopx(dummy)) go to 130 - iv(1) = 11 - go to 140 -c -c *** come here when restarting after func. eval. limit or stopx. -c - 120 if (v(f) .ge. v(f0)) go to 130 - v(radfac) = one - k = iv(niter) - go to 100 -c - 130 if (iv(nfcall) .lt. iv(mxfcal)) go to 150 - iv(1) = 9 - 140 if (v(f) .ge. v(f0)) go to 300 -c -c *** in case of stopx or function evaluation limit with -c *** improved v(f), evaluate the gradient at x. -c - iv(cnvcod) = iv(1) - go to 240 -c -c. . . . . . . . . . . . . compute candidate step . . . . . . . . . . -c - 150 step1 = iv(step) - dg1 = iv(dg) - nwtst1 = iv(nwtstp) - if (iv(kagqt) .ge. 0) go to 160 - l = iv(lmat) - call livmul(n, v(nwtst1), v(l), g) - v(nreduc) = half * dotprd(n, v(nwtst1), v(nwtst1)) - call litvmu(n, v(nwtst1), v(l), v(nwtst1)) - call vvmulp(n, v(step1), v(nwtst1), d, 1) - v(dst0) = v2norm(n, v(step1)) - call vvmulp(n, v(dg1), v(dg1), d, -1) - call ltvmul(n, v(step1), v(l), v(dg1)) - v(gthg) = v2norm(n, v(step1)) - iv(kagqt) = 0 - 160 call dbdog(v(dg1), lv, n, v(nwtst1), v(step1), v) - if (iv(irc) .eq. 6) go to 180 -c -c *** check whether evaluating f(x0 + step) looks worthwhile *** -c - if (v(dstnrm) .le. zero) go to 180 - if (iv(irc) .ne. 5) go to 170 - if (v(radfac) .le. one) go to 170 - if (v(preduc) .le. onep2 * v(fdif)) go to 180 -c -c *** compute f(x0 + step) *** -c - 170 x01 = iv(x0) - step1 = iv(step) - call vaxpy(n, x, one, v(step1), v(x01)) - iv(nfcall) = iv(nfcall) + 1 - iv(1) = 1 - iv(toobig) = 0 - go to 999 -c -c. . . . . . . . . . . . . assess candidate step . . . . . . . . . . . -c - 180 x01 = iv(x0) - v(reldx) = reldst(n, d, x, v(x01)) - call assst(iv, liv, lv, v) - step1 = iv(step) - lstgst = iv(stlstg) - if (iv(restor) .eq. 1) call vcopy(n, x, v(x01)) - if (iv(restor) .eq. 2) call vcopy(n, v(lstgst), v(step1)) - if (iv(restor) .ne. 3) go to 190 - call vcopy(n, v(step1), v(lstgst)) - call vaxpy(n, x, one, v(step1), v(x01)) - v(reldx) = reldst(n, d, x, v(x01)) -c - 190 k = iv(irc) - go to (200,230,230,230,200,210,220,220,220,220,220,220,280,250), k -c -c *** recompute step with changed radius *** -c - 200 v(radius) = v(radfac) * v(dstnrm) - go to 110 -c -c *** compute step of length v(lmaxs) for singular convergence test. -c - 210 v(radius) = v(lmaxs) - go to 150 -c -c *** convergence or false convergence *** -c - 220 iv(cnvcod) = k - 4 - if (v(f) .ge. v(f0)) go to 290 - if (iv(xirc) .eq. 14) go to 290 - iv(xirc) = 14 -c -c. . . . . . . . . . . . process acceptable step . . . . . . . . . . . -c - 230 if (iv(irc) .ne. 3) go to 240 - step1 = iv(step) - temp1 = iv(stlstg) -c -c *** set temp1 = hessian * step for use in gradient tests *** -c - l = iv(lmat) - call ltvmul(n, v(temp1), v(l), v(step1)) - call lvmul(n, v(temp1), v(l), v(temp1)) -c -c *** compute gradient *** -c - 240 iv(ngcall) = iv(ngcall) + 1 - iv(1) = 2 - go to 999 -c -c *** initializations -- g0 = g - g0, etc. *** -c - 250 g01 = iv(g0) - call vaxpy(n, v(g01), negone, v(g01), g) - step1 = iv(step) - temp1 = iv(stlstg) - if (iv(irc) .ne. 3) go to 270 -c -c *** set v(radfac) by gradient tests *** -c -c *** set temp1 = diag(d)**-1 * (hessian*step + (g(x0)-g(x))) *** -c - call vaxpy(n, v(temp1), negone, v(g01), v(temp1)) - call vvmulp(n, v(temp1), v(temp1), d, -1) -c -c *** do gradient tests *** -c - if (v2norm(n, v(temp1)) .le. v(dgnorm) * v(tuner4)) - 1 go to 260 - if (dotprd(n, g, v(step1)) - 1 .ge. v(gtstep) * v(tuner5)) go to 270 - 260 v(radfac) = v(incfac) -c -c *** update h, loop *** -c - 270 w = iv(nwtstp) - z = iv(x0) - l = iv(lmat) - call wzbfgs(v(l), n, v(step1), v(w), v(g01), v(z)) -c -c ** use the n-vectors starting at v(step1) and v(g01) for scratch.. - call lupdat(v(temp1), v(step1), v(l), v(g01), v(l), n, v(w), v(z)) - iv(1) = 2 - go to 80 -c -c. . . . . . . . . . . . . . misc. details . . . . . . . . . . . . . . -c -c *** bad parameters to assess *** -c - 280 iv(1) = 64 - go to 300 -c -c *** print summary of final iteration and other requested items *** -c - 290 iv(1) = iv(cnvcod) - iv(cnvcod) = 0 - 300 call itsum(d, g, iv, liv, lv, n, v, x) -c - 999 return -c -c *** last line of sumit follows *** - end - subroutine dbdog(dig, lv, n, nwtstp, step, v) -c -c *** compute double dogleg step *** -c -c *** parameter declarations *** -c - integer lv, n - double precision dig(n), nwtstp(n), step(n), v(lv) -c -c *** purpose *** -c -c this subroutine computes a candidate step (for use in an uncon- -c strained minimization code) by the double dogleg algorithm of -c dennis and mei (ref. 1), which is a variation on powell*s dogleg -c scheme (ref. 2, p. 95). -c -c-------------------------- parameter usage -------------------------- -c -c dig (input) diag(d)**-2 * g -- see algorithm notes. -c g (input) the current gradient vector. -c lv (input) length of v. -c n (input) number of components in dig, g, nwtstp, and step. -c nwtstp (input) negative newton step -- see algorithm notes. -c step (output) the computed step. -c v (i/o) values array, the following components of which are -c used here... -c v(bias) (input) bias for relaxed newton step, which is v(bias) of -c the way from the full newton to the fully relaxed newton -c step. recommended value = 0.8 . -c v(dgnorm) (input) 2-norm of diag(d)**-1 * g -- see algorithm notes. -c v(dstnrm) (output) 2-norm of diag(d) * step, which is v(radius) -c unless v(stppar) = 0 -- see algorithm notes. -c v(dst0) (input) 2-norm of diag(d) * nwtstp -- see algorithm notes. -c v(grdfac) (output) the coefficient of dig in the step returned -- -c step(i) = v(grdfac)*dig(i) + v(nwtfac)*nwtstp(i). -c v(gthg) (input) square-root of (dig**t) * (hessian) * dig -- see -c algorithm notes. -c v(gtstep) (output) inner product between g and step. -c v(nreduc) (output) function reduction predicted for the full newton -c step. -c v(nwtfac) (output) the coefficient of nwtstp in the step returned -- -c see v(grdfac) above. -c v(preduc) (output) function reduction predicted for the step returned. -c v(radius) (input) the trust region radius. d times the step returned -c has 2-norm v(radius) unless v(stppar) = 0. -c v(stppar) (output) code telling how step was computed... 0 means a -c full newton step. between 0 and 1 means v(stppar) of the -c way from the newton to the relaxed newton step. between -c 1 and 2 means a true double dogleg step, v(stppar) - 1 of -c the way from the relaxed newton to the cauchy step. -c greater than 2 means 1 / (v(stppar) - 1) times the cauchy -c step. -c -c------------------------------- notes ------------------------------- -c -c *** algorithm notes *** -c -c let g and h be the current gradient and hessian approxima- -c tion respectively and let d be the current scale vector. this -c routine assumes dig = diag(d)**-2 * g and nwtstp = h**-1 * g. -c the step computed is the same one would get by replacing g and h -c by diag(d)**-1 * g and diag(d)**-1 * h * diag(d)**-1, -c computing step, and translating step back to the original -c variables, i.e., premultiplying it by diag(d)**-1. -c -c *** references *** -c -c 1. dennis, j.e., and mei, h.h.w. (1979), two new unconstrained opti- -c mization algorithms which use function and gradient -c values, j. optim. theory applic. 28, pp. 453-482. -c 2. powell, m.j.d. (1970), a hybrid method for non-linear equations, -c in numerical methods for non-linear equations, edited by -c p. rabinowitz, gordon and breach, london. -c -c *** general *** -c -c coded by david m. gay. -c this subroutine was written in connection with research supported -c by the national science foundation under grants mcs-7600324 and -c mcs-7906671. -c -c------------------------ external quantities ------------------------ -c -c *** functions and subroutines called *** -c - external dotprd, v2norm - double precision dotprd, v2norm -c -c dotprd... returns inner product of two vectors. -c v2norm... returns 2-norm of a vector. -c -c *** intrinsic functions *** -c/+ - double precision dsqrt -c/ -c-------------------------- local variables -------------------------- -c - integer i - double precision cfact, cnorm, ctrnwt, ghinvg, femnsq, gnorm, - 1 nwtnrm, relax, rlambd, t, t1, t2 - double precision half, one, two, zero -c -c *** v subscripts *** -c - integer bias, dgnorm, dstnrm, dst0, grdfac, gthg, gtstep, - 1 nreduc, nwtfac, preduc, radius, stppar -c -c *** data initializations *** -c -c/6 -c data half/0.5d+0/, one/1.d+0/, two/2.d+0/, zero/0.d+0/ -c/7 - parameter (half=0.5d+0, one=1.d+0, two=2.d+0, zero=0.d+0) -c/ -c -c/6 -c data bias/43/, dgnorm/1/, dstnrm/2/, dst0/3/, grdfac/45/, -c 1 gthg/44/, gtstep/4/, nreduc/6/, nwtfac/46/, preduc/7/, -c 2 radius/8/, stppar/5/ -c/7 - parameter (bias=43, dgnorm=1, dstnrm=2, dst0=3, grdfac=45, - 1 gthg=44, gtstep=4, nreduc=6, nwtfac=46, preduc=7, - 2 radius=8, stppar=5) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - nwtnrm = v(dst0) - rlambd = one - if (nwtnrm .gt. zero) rlambd = v(radius) / nwtnrm - gnorm = v(dgnorm) - ghinvg = two * v(nreduc) - v(grdfac) = zero - v(nwtfac) = zero - if (rlambd .lt. one) go to 30 -c -c *** the newton step is inside the trust region *** -c - v(stppar) = zero - v(dstnrm) = nwtnrm - v(gtstep) = -ghinvg - v(preduc) = v(nreduc) - v(nwtfac) = -one - do 20 i = 1, n - 20 step(i) = -nwtstp(i) - go to 999 -c - 30 v(dstnrm) = v(radius) - cfact = (gnorm / v(gthg))**2 -c *** cauchy step = -cfact * g. - cnorm = gnorm * cfact - relax = one - v(bias) * (one - gnorm*cnorm/ghinvg) - if (rlambd .lt. relax) go to 50 -c -c *** step is between relaxed newton and full newton steps *** -c - v(stppar) = one - (rlambd - relax) / (one - relax) - t = -rlambd - v(gtstep) = t * ghinvg - v(preduc) = rlambd * (one - half*rlambd) * ghinvg - v(nwtfac) = t - do 40 i = 1, n - 40 step(i) = t * nwtstp(i) - go to 999 -c - 50 if (cnorm .lt. v(radius)) go to 70 -c -c *** the cauchy step lies outside the trust region -- -c *** step = scaled cauchy step *** -c - t = -v(radius) / gnorm - v(grdfac) = t - v(stppar) = one + cnorm / v(radius) - v(gtstep) = -v(radius) * gnorm - v(preduc) = v(radius)*(gnorm - half*v(radius)*(v(gthg)/gnorm)**2) - do 60 i = 1, n - 60 step(i) = t * dig(i) - go to 999 -c -c *** compute dogleg step between cauchy and relaxed newton *** -c *** femur = relaxed newton step minus cauchy step *** -c - 70 ctrnwt = cfact * relax * ghinvg / gnorm -c *** ctrnwt = inner prod. of cauchy and relaxed newton steps, -c *** scaled by gnorm**-1. - t1 = ctrnwt - gnorm*cfact**2 -c *** t1 = inner prod. of femur and cauchy step, scaled by -c *** gnorm**-1. - t2 = v(radius)*(v(radius)/gnorm) - gnorm*cfact**2 - t = relax * nwtnrm - femnsq = (t/gnorm)*t - ctrnwt - t1 -c *** femnsq = square of 2-norm of femur, scaled by gnorm**-1. - t = t2 / (t1 + dsqrt(t1**2 + femnsq*t2)) -c *** dogleg step = cauchy step + t * femur. - t1 = (t - one) * cfact - v(grdfac) = t1 - t2 = -t * relax - v(nwtfac) = t2 - v(stppar) = two - t - v(gtstep) = t1*gnorm**2 + t2*ghinvg - v(preduc) = -t1*gnorm * ((t2 + one)*gnorm) - 1 - t2 * (one + half*t2)*ghinvg - 2 - half * (v(gthg)*t1)**2 - do 80 i = 1, n - 80 step(i) = t1*dig(i) + t2*nwtstp(i) -c - 999 return -c *** last line of dbdog follows *** - end - subroutine ltvmul(n, x, l, y) -c -c *** compute x = (l**t)*y, where l is an n x n lower -c *** triangular matrix stored compactly by rows. x and y may -c *** occupy the same storage. *** -c - integer n -cal double precision x(n), l(1), y(n) - double precision x(n), l(n*(n+1)/2), y(n) -c dimension l(n*(n+1)/2) - integer i, ij, i0, j - double precision yi, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - i0 = 0 - do 20 i = 1, n - yi = y(i) - x(i) = zero - do 10 j = 1, i - ij = i0 + j - x(j) = x(j) + yi*l(ij) - 10 continue - i0 = i0 + i - 20 continue - 999 return -c *** last card of ltvmul follows *** - end - subroutine lupdat(beta, gamma, l, lambda, lplus, n, w, z) -c -c *** compute lplus = secant update of l *** -c -c *** parameter declarations *** -c - integer n -cal double precision beta(n), gamma(n), l(1), lambda(n), lplus(1), - double precision beta(n), gamma(n), l(n*(n+1)/2), lambda(n), - 1 lplus(n*(n+1)/2),w(n), z(n) -c dimension l(n*(n+1)/2), lplus(n*(n+1)/2) -c -c-------------------------- parameter usage -------------------------- -c -c beta = scratch vector. -c gamma = scratch vector. -c l (input) lower triangular matrix, stored rowwise. -c lambda = scratch vector. -c lplus (output) lower triangular matrix, stored rowwise, which may -c occupy the same storage as l. -c n (input) length of vector parameters and order of matrices. -c w (input, destroyed on output) right singular vector of rank 1 -c correction to l. -c z (input, destroyed on output) left singular vector of rank 1 -c correction to l. -c -c------------------------------- notes ------------------------------- -c -c *** application and usage restrictions *** -c -c this routine updates the cholesky factor l of a symmetric -c positive definite matrix to which a secant update is being -c applied -- it computes a cholesky factor lplus of -c l * (i + z*w**t) * (i + w*z**t) * l**t. it is assumed that w -c and z have been chosen so that the updated matrix is strictly -c positive definite. -c -c *** algorithm notes *** -c -c this code uses recurrence 3 of ref. 1 (with d(j) = 1 for all j) -c to compute lplus of the form l * (i + z*w**t) * q, where q -c is an orthogonal matrix that makes the result lower triangular. -c lplus may have some negative diagonal elements. -c -c *** references *** -c -c 1. goldfarb, d. (1976), factorized variable metric methods for uncon- -c strained optimization, math. comput. 30, pp. 796-811. -c -c *** general *** -c -c coded by david m. gay (fall 1979). -c this subroutine was written in connection with research supported -c by the national science foundation under grants mcs-7600324 and -c mcs-7906671. -c -c------------------------ external quantities ------------------------ -c -c *** intrinsic functions *** -c/+ - double precision dsqrt -c/ -c-------------------------- local variables -------------------------- -c - integer i, ij, j, jj, jp1, k, nm1, np1 - double precision a, b, bj, eta, gj, lj, lij, ljj, nu, s, theta, - 1 wj, zj - double precision one, zero -c -c *** data initializations *** -c -c/6 -c data one/1.d+0/, zero/0.d+0/ -c/7 - parameter (one=1.d+0, zero=0.d+0) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - nu = one - eta = zero - if (n .le. 1) go to 30 - nm1 = n - 1 -c -c *** temporarily store s(j) = sum over k = j+1 to n of w(k)**2 in -c *** lambda(j). -c - s = zero - do 10 i = 1, nm1 - j = n - i - s = s + w(j+1)**2 - lambda(j) = s - 10 continue -c -c *** compute lambda, gamma, and beta by goldfarb*s recurrence 3. -c - do 20 j = 1, nm1 - wj = w(j) - a = nu*z(j) - eta*wj - theta = one + a*wj - s = a*lambda(j) - lj = dsqrt(theta**2 + a*s) - if (theta .gt. zero) lj = -lj - lambda(j) = lj - b = theta*wj + s - gamma(j) = b * nu / lj - beta(j) = (a - b*eta) / lj - nu = -nu / lj - eta = -(eta + (a**2)/(theta - lj)) / lj - 20 continue - 30 lambda(n) = one + (nu*z(n) - eta*w(n))*w(n) -c -c *** update l, gradually overwriting w and z with l*w and l*z. -c - np1 = n + 1 - jj = n * (n + 1) / 2 - do 60 k = 1, n - j = np1 - k - lj = lambda(j) - ljj = l(jj) - lplus(jj) = lj * ljj - wj = w(j) - w(j) = ljj * wj - zj = z(j) - z(j) = ljj * zj - if (k .eq. 1) go to 50 - bj = beta(j) - gj = gamma(j) - ij = jj + j - jp1 = j + 1 - do 40 i = jp1, n - lij = l(ij) - lplus(ij) = lj*lij + bj*w(i) + gj*z(i) - w(i) = w(i) + lij*wj - z(i) = z(i) + lij*zj - ij = ij + i - 40 continue - 50 jj = jj - j - 60 continue -c - 999 return -c *** last card of lupdat follows *** - end - subroutine lvmul(n, x, l, y) -c -c *** compute x = l*y, where l is an n x n lower triangular -c *** matrix stored compactly by rows. x and y may occupy the same -c *** storage. *** -c - integer n -cal double precision x(n), l(1), y(n) - double precision x(n), l(n*(n+1)/2), y(n) -c dimension l(n*(n+1)/2) - integer i, ii, ij, i0, j, np1 - double precision t, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - np1 = n + 1 - i0 = n*(n+1)/2 - do 20 ii = 1, n - i = np1 - ii - i0 = i0 - i - t = zero - do 10 j = 1, i - ij = i0 + j - t = t + l(ij)*y(j) - 10 continue - x(i) = t - 20 continue - 999 return -c *** last card of lvmul follows *** - end - subroutine vvmulp(n, x, y, z, k) -c -c *** set x(i) = y(i) * z(i)**k, 1 .le. i .le. n (for k = 1 or -1) *** -c - integer n, k - double precision x(n), y(n), z(n) - integer i -c - if (k .ge. 0) go to 20 - do 10 i = 1, n - 10 x(i) = y(i) / z(i) - go to 999 -c - 20 do 30 i = 1, n - 30 x(i) = y(i) * z(i) - 999 return -c *** last card of vvmulp follows *** - end - subroutine wzbfgs (l, n, s, w, y, z) -c -c *** compute y and z for lupdat corresponding to bfgs update. -c - integer n -cal double precision l(1), s(n), w(n), y(n), z(n) - double precision l(n*(n+1)/2), s(n), w(n), y(n), z(n) -c dimension l(n*(n+1)/2) -c -c-------------------------- parameter usage -------------------------- -c -c l (i/o) cholesky factor of hessian, a lower triang. matrix stored -c compactly by rows. -c n (input) order of l and length of s, w, y, z. -c s (input) the step just taken. -c w (output) right singular vector of rank 1 correction to l. -c y (input) change in gradients corresponding to s. -c z (output) left singular vector of rank 1 correction to l. -c -c------------------------------- notes ------------------------------- -c -c *** algorithm notes *** -c -c when s is computed in certain ways, e.g. by gqtstp or -c dbldog, it is possible to save n**2/2 operations since (l**t)*s -c or l*(l**t)*s is then known. -c if the bfgs update to l*(l**t) would reduce its determinant to -c less than eps times its old value, then this routine in effect -c replaces y by theta*y + (1 - theta)*l*(l**t)*s, where theta -c (between 0 and 1) is chosen to make the reduction factor = eps. -c -c *** general *** -c -c coded by david m. gay (fall 1979). -c this subroutine was written in connection with research supported -c by the national science foundation under grants mcs-7600324 and -c mcs-7906671. -c -c------------------------ external quantities ------------------------ -c -c *** functions and subroutines called *** -c - external dotprd, livmul, ltvmul - double precision dotprd -c dotprd returns inner product of two vectors. -c livmul multiplies l**-1 times a vector. -c ltvmul multiplies l**t times a vector. -c -c *** intrinsic functions *** -c/+ - double precision dsqrt -c/ -c-------------------------- local variables -------------------------- -c - integer i - double precision cs, cy, eps, epsrt, one, shs, ys, theta -c -c *** data initializations *** -c -c/6 -c data eps/0.1d+0/, one/1.d+0/ -c/7 - parameter (eps=0.1d+0, one=1.d+0) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - call ltvmul(n, w, l, s) - shs = dotprd(n, w, w) - ys = dotprd(n, y, s) - if (ys .ge. eps*shs) go to 10 - theta = (one - eps) * shs / (shs - ys) - epsrt = dsqrt(eps) - cy = theta / (shs * epsrt) - cs = (one + (theta-one)/epsrt) / shs - go to 20 - 10 cy = one / (dsqrt(ys) * dsqrt(shs)) - cs = one / shs - 20 call livmul(n, z, l, y) - do 30 i = 1, n - 30 z(i) = cy * z(i) - cs * w(i) -c - 999 return -c *** last card of wzbfgs follows *** - end diff --git a/source/unres/src_MD-M-newcorr/surfatom.f b/source/unres/src_MD-M-newcorr/surfatom.f deleted file mode 100644 index 9974842..0000000 --- a/source/unres/src_MD-M-newcorr/surfatom.f +++ /dev/null @@ -1,494 +0,0 @@ -c -c -c ################################################### -c ## COPYRIGHT (C) 1996 by Jay William Ponder ## -c ## All Rights Reserved ## -c ################################################### -c -c ################################################################ -c ## ## -c ## subroutine surfatom -- exposed surface area of an atom ## -c ## ## -c ################################################################ -c -c -c "surfatom" performs an analytical computation of the surface -c area of a specified atom; a simplified version of "surface" -c -c literature references: -c -c T. J. Richmond, "Solvent Accessible Surface Area and -c Excluded Volume in Proteins", Journal of Molecular Biology, -c 178, 63-89 (1984) -c -c L. Wesson and D. Eisenberg, "Atomic Solvation Parameters -c Applied to Molecular Dynamics of Proteins in Solution", -c Protein Science, 1, 227-235 (1992) -c -c variables and parameters: -c -c ir number of atom for which area is desired -c area accessible surface area of the atom -c radius radii of each of the individual atoms -c -c - subroutine surfatom (ir,area,radius) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizes.i' - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - integer nres,nsup,nstart_sup - double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm - common /chain/ c(3,maxres2+2),dc(3,0:maxres2),dc_old(3,0:maxres2), - & xloc(3,maxres),xrot(3,maxres),dc_norm(3,0:maxres2), - & dc_work(MAXRES6),nres,nres0 - integer maxarc - parameter (maxarc=300) - integer i,j,k,m - integer ii,ib,jb - integer io,ir - integer mi,ni,narc - integer key(maxarc) - integer intag(maxarc) - integer intag1(maxarc) - real*8 area,arcsum - real*8 arclen,exang - real*8 delta,delta2 - real*8 eps,rmove - real*8 xr,yr,zr - real*8 rr,rrsq - real*8 rplus,rminus - real*8 axx,axy,axz - real*8 ayx,ayy - real*8 azx,azy,azz - real*8 uxj,uyj,uzj - real*8 tx,ty,tz - real*8 txb,tyb,td - real*8 tr2,tr,txr,tyr - real*8 tk1,tk2 - real*8 thec,the,t,tb - real*8 txk,tyk,tzk - real*8 t1,ti,tf,tt - real*8 txj,tyj,tzj - real*8 ccsq,cc,xysq - real*8 bsqk,bk,cosine - real*8 dsqj,gi,pix2 - real*8 therk,dk,gk - real*8 risqk,rik - real*8 radius(maxatm) - real*8 ri(maxarc),risq(maxarc) - real*8 ux(maxarc),uy(maxarc),uz(maxarc) - real*8 xc(maxarc),yc(maxarc),zc(maxarc) - real*8 xc1(maxarc),yc1(maxarc),zc1(maxarc) - real*8 dsq(maxarc),bsq(maxarc) - real*8 dsq1(maxarc),bsq1(maxarc) - real*8 arci(maxarc),arcf(maxarc) - real*8 ex(maxarc),lt(maxarc),gr(maxarc) - real*8 b(maxarc),b1(maxarc),bg(maxarc) - real*8 kent(maxarc),kout(maxarc) - real*8 ther(maxarc) - logical moved,top - logical omit(maxarc) -c -c -c zero out the surface area for the sphere of interest -c - area = 0.0d0 -c write (2,*) "ir",ir," radius",radius(ir) - if (radius(ir) .eq. 0.0d0) return -c -c set the overlap significance and connectivity shift -c - pix2 = 2.0d0 * pi - delta = 1.0d-8 - delta2 = delta * delta - eps = 1.0d-8 - moved = .false. - rmove = 1.0d-8 -c -c store coordinates and radius of the sphere of interest -c - xr = c(1,ir) - yr = c(2,ir) - zr = c(3,ir) - rr = radius(ir) - rrsq = rr * rr -c -c initialize values of some counters and summations -c - 10 continue - io = 0 - jb = 0 - ib = 0 - arclen = 0.0d0 - exang = 0.0d0 -c -c test each sphere to see if it overlaps the sphere of interest -c - do i = 1, 2*nres - if (i.eq.ir .or. radius(i).eq.0.0d0) goto 30 - rplus = rr + radius(i) - tx = c(1,i) - xr - if (abs(tx) .ge. rplus) goto 30 - ty = c(2,i) - yr - if (abs(ty) .ge. rplus) goto 30 - tz = c(3,i) - zr - if (abs(tz) .ge. rplus) goto 30 -c -c check for sphere overlap by testing distance against radii -c - xysq = tx*tx + ty*ty - if (xysq .lt. delta2) then - tx = delta - ty = 0.0d0 - xysq = delta2 - end if - ccsq = xysq + tz*tz - cc = sqrt(ccsq) - if (rplus-cc .le. delta) goto 30 - rminus = rr - radius(i) -c -c check to see if sphere of interest is completely buried -c - if (cc-abs(rminus) .le. delta) then - if (rminus .le. 0.0d0) goto 170 - goto 30 - end if -c -c check for too many overlaps with sphere of interest -c - if (io .ge. maxarc) then - write (iout,20) - 20 format (/,' SURFATOM -- Increase the Value of MAXARC') - stop - end if -c -c get overlap between current sphere and sphere of interest -c - io = io + 1 - xc1(io) = tx - yc1(io) = ty - zc1(io) = tz - dsq1(io) = xysq - bsq1(io) = ccsq - b1(io) = cc - gr(io) = (ccsq+rplus*rminus) / (2.0d0*rr*b1(io)) - intag1(io) = i - omit(io) = .false. - 30 continue - end do -c -c case where no other spheres overlap the sphere of interest -c - if (io .eq. 0) then - area = 4.0d0 * pi * rrsq - return - end if -c -c case where only one sphere overlaps the sphere of interest -c - if (io .eq. 1) then - area = pix2 * (1.0d0 + gr(1)) - area = mod(area,4.0d0*pi) * rrsq - return - end if -c -c case where many spheres intersect the sphere of interest; -c sort the intersecting spheres by their degree of overlap -c - call sort2 (io,gr,key) - do i = 1, io - k = key(i) - intag(i) = intag1(k) - xc(i) = xc1(k) - yc(i) = yc1(k) - zc(i) = zc1(k) - dsq(i) = dsq1(k) - b(i) = b1(k) - bsq(i) = bsq1(k) - end do -c -c get radius of each overlap circle on surface of the sphere -c - do i = 1, io - gi = gr(i) * rr - bg(i) = b(i) * gi - risq(i) = rrsq - gi*gi - ri(i) = sqrt(risq(i)) - ther(i) = 0.5d0*pi - asin(min(1.0d0,max(-1.0d0,gr(i)))) - end do -c -c find boundary of inaccessible area on sphere of interest -c - do k = 1, io-1 - if (.not. omit(k)) then - txk = xc(k) - tyk = yc(k) - tzk = zc(k) - bk = b(k) - therk = ther(k) -c -c check to see if J circle is intersecting K circle; -c get distance between circle centers and sum of radii -c - do j = k+1, io - if (omit(j)) goto 60 - cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j)) - cc = acos(min(1.0d0,max(-1.0d0,cc))) - td = therk + ther(j) -c -c check to see if circles enclose separate regions -c - if (cc .ge. td) goto 60 -c -c check for circle J completely inside circle K -c - if (cc+ther(j) .lt. therk) goto 40 -c -c check for circles that are essentially parallel -c - if (cc .gt. delta) goto 50 - 40 continue - omit(j) = .true. - goto 60 -c -c check to see if sphere of interest is completely buried -c - 50 continue - if (pix2-cc .le. td) goto 170 - 60 continue - end do - end if - end do -c -c find T value of circle intersections -c - do k = 1, io - if (omit(k)) goto 110 - omit(k) = .true. - narc = 0 - top = .false. - txk = xc(k) - tyk = yc(k) - tzk = zc(k) - dk = sqrt(dsq(k)) - bsqk = bsq(k) - bk = b(k) - gk = gr(k) * rr - risqk = risq(k) - rik = ri(k) - therk = ther(k) -c -c rotation matrix elements -c - t1 = tzk / (bk*dk) - axx = txk * t1 - axy = tyk * t1 - axz = dk / bk - ayx = tyk / dk - ayy = txk / dk - azx = txk / bk - azy = tyk / bk - azz = tzk / bk - do j = 1, io - if (.not. omit(j)) then - txj = xc(j) - tyj = yc(j) - tzj = zc(j) -c -c rotate spheres so K vector colinear with z-axis -c - uxj = txj*axx + tyj*axy - tzj*axz - uyj = tyj*ayy - txj*ayx - uzj = txj*azx + tyj*azy + tzj*azz - cosine = min(1.0d0,max(-1.0d0,uzj/b(j))) - if (acos(cosine) .lt. therk+ther(j)) then - dsqj = uxj*uxj + uyj*uyj - tb = uzj*gk - bg(j) - txb = uxj * tb - tyb = uyj * tb - td = rik * dsqj - tr2 = risqk*dsqj - tb*tb - tr2 = max(eps,tr2) - tr = sqrt(tr2) - txr = uxj * tr - tyr = uyj * tr -c -c get T values of intersection for K circle -c - tb = (txb+tyr) / td - tb = min(1.0d0,max(-1.0d0,tb)) - tk1 = acos(tb) - if (tyb-txr .lt. 0.0d0) tk1 = pix2 - tk1 - tb = (txb-tyr) / td - tb = min(1.0d0,max(-1.0d0,tb)) - tk2 = acos(tb) - if (tyb+txr .lt. 0.0d0) tk2 = pix2 - tk2 - thec = (rrsq*uzj-gk*bg(j)) / (rik*ri(j)*b(j)) - if (abs(thec) .lt. 1.0d0) then - the = -acos(thec) - else if (thec .ge. 1.0d0) then - the = 0.0d0 - else if (thec .le. -1.0d0) then - the = -pi - end if -c -c see if "tk1" is entry or exit point; check t=0 point; -c "ti" is exit point, "tf" is entry point -c - cosine = min(1.0d0,max(-1.0d0, - & (uzj*gk-uxj*rik)/(b(j)*rr))) - if ((acos(cosine)-ther(j))*(tk2-tk1) .le. 0.0d0) then - ti = tk2 - tf = tk1 - else - ti = tk2 - tf = tk1 - end if - narc = narc + 1 - if (narc .ge. maxarc) then - write (iout,70) - 70 format (/,' SURFATOM -- Increase the Value', - & ' of MAXARC') - stop - end if - if (tf .le. ti) then - arcf(narc) = tf - arci(narc) = 0.0d0 - tf = pix2 - lt(narc) = j - ex(narc) = the - top = .true. - narc = narc + 1 - end if - arcf(narc) = tf - arci(narc) = ti - lt(narc) = j - ex(narc) = the - ux(j) = uxj - uy(j) = uyj - uz(j) = uzj - end if - end if - end do - omit(k) = .false. -c -c special case; K circle without intersections -c - if (narc .le. 0) goto 90 -c -c general case; sum up arclength and set connectivity code -c - call sort2 (narc,arci,key) - arcsum = arci(1) - mi = key(1) - t = arcf(mi) - ni = mi - if (narc .gt. 1) then - do j = 2, narc - m = key(j) - if (t .lt. arci(j)) then - arcsum = arcsum + arci(j) - t - exang = exang + ex(ni) - jb = jb + 1 - if (jb .ge. maxarc) then - write (iout,80) - 80 format (/,' SURFATOM -- Increase the Value', - & ' of MAXARC') - stop - end if - i = lt(ni) - kent(jb) = maxarc*i + k - i = lt(m) - kout(jb) = maxarc*k + i - end if - tt = arcf(m) - if (tt .ge. t) then - t = tt - ni = m - end if - end do - end if - arcsum = arcsum + pix2 - t - if (.not. top) then - exang = exang + ex(ni) - jb = jb + 1 - i = lt(ni) - kent(jb) = maxarc*i + k - i = lt(mi) - kout(jb) = maxarc*k + i - end if - goto 100 - 90 continue - arcsum = pix2 - ib = ib + 1 - 100 continue - arclen = arclen + gr(k)*arcsum - 110 continue - end do - if (arclen .eq. 0.0d0) goto 170 - if (jb .eq. 0) goto 150 -c -c find number of independent boundaries and check connectivity -c - j = 0 - do k = 1, jb - if (kout(k) .ne. 0) then - i = k - 120 continue - m = kout(i) - kout(i) = 0 - j = j + 1 - do ii = 1, jb - if (m .eq. kent(ii)) then - if (ii .eq. k) then - ib = ib + 1 - if (j .eq. jb) goto 150 - goto 130 - end if - i = ii - goto 120 - end if - end do - 130 continue - end if - end do - ib = ib + 1 -c -c attempt to fix connectivity error by moving atom slightly -c - if (moved) then - write (iout,140) ir - 140 format (/,' SURFATOM -- Connectivity Error at Atom',i6) - else - moved = .true. - xr = xr + rmove - yr = yr + rmove - zr = zr + rmove - goto 10 - end if -c -c compute the exposed surface area for the sphere of interest -c - 150 continue - area = ib*pix2 + exang + arclen - area = mod(area,4.0d0*pi) * rrsq -c -c attempt to fix negative area by moving atom slightly -c - if (area .lt. 0.0d0) then - if (moved) then - write (iout,160) ir - 160 format (/,' SURFATOM -- Negative Area at Atom',i6) - else - moved = .true. - xr = xr + rmove - yr = yr + rmove - zr = zr + rmove - goto 10 - end if - end if - 170 continue - return - end diff --git a/source/unres/src_MD-M-newcorr/symbols-lang0.txt b/source/unres/src_MD-M-newcorr/symbols-lang0.txt deleted file mode 100644 index 6550c2d..0000000 --- a/source/unres/src_MD-M-newcorr/symbols-lang0.txt +++ /dev/null @@ -1,257 +0,0 @@ -bm_outfile 0x64 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_I_LONG_LONG_INT - 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -frag_ 0xa0 geomout.o -calcthet_ 0x9c energy_p_new_barrier.o -wagi_ 0x10 geomout.o -cache_ 0x5dcd0 mcm.o -rm_outfile_head 0x64 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -header_ 0x50 unres.o -mvstat_ 0x250 readrtns_CSA.o -timing_ 0x140 unres.o -MPIR_I_COMPLEX 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -MPIR_I_LONG_INT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -ffield_ 0x174 unres.o -chuju_ 0x4 minimize_p.o -deriv_loc_ 0x1e0 initialize_p.o -splitele_ 0x10 initialize_p.o -cipiszcze_ 0x4 /tmp/ipo_ifortB4EXK9.o -MPIR_I_DOUBLE_PRECISION - 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -MPIR_I_SHORT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPI_LONG_DOUBLE_INT_var - 0x20 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_dtes 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_I_UB 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -refstruct_ 0x1c26c unres.o -dih_control_ 0xc readrtns_CSA.o -MPIR_I_FLOAT_INT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_I_SHORT_INT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -frozen_ 0x12c0 geomout.o -sumsl_flag_ 0x4 unres.o -execer_pg 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -links_split_ 0x8 unres.o -precomp1_ 0x70800 unres.o -bounds_ 0x4b00 readrtns_CSA.o -MPIR_I_2DCOMPLEX 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -alphaa_ 0x1e788 readrtns_CSA.o -MPIR_errhandlers 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initutil.o) -chain_ 0x54680 unres.o -parfiles_ 0xb00 unres.o -globmemsize 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -rotat_old_ 0x9600 unres.o -bank_ 0x25920 readrtns_CSA.o -p4_rm_rank 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -contacts1_ 0xc5d3c0 unres.o -mce_ 0x230 readrtns_CSA.o -diploc_ 0x3938 unres.o -mucarem_ 0x8000 readrtns_CSA.o -mdpmpi_ 0x8014 unres.o -iounits_ 0x6c unres.o -MPI_DOUBLE_INT_var 0x10 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -mapp_ 0x25804 readrtns_CSA.o -MPIR_real8_dte 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -p4_brdcst_info 0x18 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -langforc_ 0x582a594 readrtns_CSA.o -MPIR_I_2INT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -minvar_ 0x12d78 readrtns_CSA.o -torsion_ 0x5adc parmread.o -struct_ 0xa2c readrtns_CSA.o -procgroup_file 0x100 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -mdpar_ 0x6c unres.o -MPID_MyWorldSize 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(adi2init.o) -spinka_ 0x384c newconf.o -thetas_ 0x960 chainbuild.o -__P4FROM 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4priv.o) -MPIR_int1_dte 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -MPIR_debug_q 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -MPIR_debug_sq 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -MPID_MyWorldRank 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(adi2init.o) -remdrestart_ 0x411808 unres.o -for__pthread_mutex_unlock_ptr - 0x8 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_aio.o) -restr_ 0xce44 unres.o -locel_ 0x274 energy_p_new_barrier.o -MPIR_I_REAL 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -fourier_ 0x344 initialize_p.o -precomp2_ 0x70800 unres.o -torsiond_ 0x14200 initialize_p.o -for__a_argv 0x8 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_init.o) -MPIR_debug_rh 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -pool_ 0x5dc5c readrtns_CSA.o -maxgrad_ 0xa8 energy_p_new_barrier.o -double_muca_ 0x25828 readrtns_CSA.o -links_ 0x107035c unres.o -MPID_byte_order 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(chhetero.o) -p4_global 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_I_2REAL 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -mdgrad_ 0x1c230 unres.o -execer_mastport 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -from_zscore_ 0xc unres.o -csa_input_ 0x98 readrtns_CSA.o -for__pthread_mutex_init_ptr - 0x8 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_aio.o) -machsw_ 0xc initialize_p.o -types_ 0x54 unres.o -MPIR_I_USHORT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_I_FLOAT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -sccalc_ 0x28 energy_p_new_barrier.o -pochodne_ 0xb01310 geomout.o -loc_work_ 0x30c local_move.o -peptbond_ 0x28 chainbuild.o -MPIR_I_UINT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -calc_ 0x1f0 gen_rand_conf.o -execer_id 0x84 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPI_FLOAT_INT_var 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -execer_numtotnodes 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -derivat_ 0x436dbe8 initialize_p.o -MPIR_I_BYTE 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_I_CHAR 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -deriv_scloc_ 0x3f480 initialize_p.o -listener_info 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -przechowalnia_ 0x7080000 MREMD.o -MPIR_All_communicators - 0x10 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -diffcuta_ 0x8 readrtns_CSA.o -vectors_ 0x62700 energy_p_new_barrier.o -thread_ 0x148 readrtns_CSA.o -back_constr_ 0x165cc unres.o -MPIR_I_PACKED 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_I_INT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -p4_local 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_I_DCOMPLEX 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -logging_flag 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -pizda_ 0x12c0 readrtns_CSA.o -execer_myhost 0x64 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_rhandles 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(adi2init.o) -MPIR_topo_els 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initutil.o) -par_ 0x20 eigen.o -info_ 0x4010 timing.o -MPIR_I_INTEGER 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -tty_orig 0x12 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_secure.o) -MPIR_I_DOUBLE_INT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -mpgrad_ 0x2588 initialize_p.o -info1_ 0x2824 timing.o -setup_ 0x6040 unres.o -p4_wd 0x100 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_Op_errno 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(global_ops.o) -restraints_ 0x8 unres.o -MPIR_I_LONG_DOUBLE 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -torcnstr_ 0x7098 initialize_p.o -stochcalc_ 0xe100 MD_A-MTS.o -MPIR_I_2FLOAT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_real4_dte 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -indices_ 0x7060 chainbuild.o -qmeas_ 0x7633c unres.o -MPID_recvs 0x20 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(queue.o) -mpipriv_ 0x24 unres.o -p4_remote_debug_level - 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_shandles 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(adi2init.o) -total_pack_unacked 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(chpackflow.o) -kutas_ 0x4 energy_p_new_barrier.o -cntrl_ 0x7c unres.o -sserver_port 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -rotmat_ 0x54600 unres.o -varin_ 0x12d48 readrtns_CSA.o -p4_myname_in_procgroup - 0x40 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -lagrange_ 0x1085e2b8 unres.o -message_catalog 0x8 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_diags_intel.o) -MPIR_I_UCHAR 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -fnames_ 0x1007 unres.o -loc_const_ 0x40 local_move.o -stoptim_ 0x4 unres.o -sclocal_ 0x22cc chainbuild.o -time1_ 0x30 unres.o -MPIR_I_2DOUBLE 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -bank_disulfid_ 0x1f0 readrtns_CSA.o -MPID_pack_info 0x10 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(chpackflow.o) -MPIR_debug_qh 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -mdcalc_ 0x108 unres.o -dipmat_ 0xafc8000 unres.o -hand_start_remotes 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -execer_starting_remotes - 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -remdcommon_ 0x6030 unres.o -sbridge_ 0x9c unres.o -refer_ 0x98 bond_move.o -csafiles_ 0xc00 unres.o -MPIR_tid 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initutil.o) -thread1_ 0x1cd0 readrtns_CSA.o -langmat_ 0xc readrtns_CSA.o -__P4GLOBALTYPE 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4priv.o) -integer_muca_ 0xc readrtns_CSA.o -MPI_SHORT_INT_var 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -inertia_ 0x160 unres.o -mcm_ 0x20a4 initialize_p.o -MPIR_I_2DOUBLE_PRECISION - 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -for__pthread_mutex_lock_ptr - 0x8 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_aio.o) -mce_counters_ 0x14 readrtns_CSA.o -aaaa_ 0x8 MP.o -store0_ 0x4 geomout.o -MPIR_I_2INTEGER 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -banii_ 0xe100 banach.o -scrot_ 0x28a0 parmread.o -c_frag_ 0x2588 geomout.o -move_ 0x4b78 initialize_p.o -MPIR_fdtels 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initutil.o) -MPIR_I_LONG 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -vrandd_ 0x3f0 randgens.o -syfek_ 0xe100 stochfric.o -whoami_p4 0x64 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -windows_ 0x3844 initialize_p.o -contacts_hb_ 0x4e483c0 unres.o -MPIR_debug_s 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -MPIR_I_ULONG 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_hbt_els 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(util_hbt.o) -srutu_ 0x4 unres.o -contdistrib_ 0x2c0944c unres.o -expect_ack 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(chpackflow.o) -MPIR_hbts 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(util_hbt.o) -__P4TYPE 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4priv.o) -traj1cache_ 0x480dc unres.o -accept_stats_ 0x2008 initialize_p.o -execer_masthost 0x64 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -for__l_argc 0x4 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_init.o) -invlen_ 0x4b00 chainbuild.o -MPIR_I_LONG_DOUBLE_INT - 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_debug_c 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -MPI_LONG_INT_var 0x10 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_I_LB 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -p4_debug_level 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -stretch_ 0x608 unres.o -for__aio_lub_table 0x400 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_aio.o) -iofile_ 0x65c initialize_p.o -MPIR_qels 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initutil.o) -__P4LEN 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4priv.o) -local_domain 0x64 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -minimm_ 0x20 initialize_p.o -MPIR_debug_qel 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -send2_ 0x151b0 readrtns_CSA.o -MPIR_debug_sqel 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -MPIR_I_2COMPLEX 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -gucio_ 0x18 MD_A-MTS.o -ch_debug_buf 0x80 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(adi2init.o) -execer_mynumprocs 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -contacts_ 0x38408 unres.o -__BLNK__ 0xc djacob.o -MPIR_I_LOGICAL 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -MPIR_int2_dte 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -geo_ 0x40 unres.o -execer_mynodenum 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_int4_dte 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -MPIR_I_DOUBLE 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -csaunits_ 0x34 unres.o -body_ 0x6180 unres.o -interact_ 0x154bc unres.o -theta_abinitio_ 0x24a70 chainbuild.o -oldgeo_ 0xbb8f4 unres.o -rotat_ 0x38400 unres.o -var_ 0x35e90 unres.o -secondarys_ 0x4b0 dihed_cons.o -MPIR_debug_cl 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) - diff --git a/source/unres/src_MD-M-newcorr/symbolsizes.txt b/source/unres/src_MD-M-newcorr/symbolsizes.txt deleted file mode 100644 index e2c457b..0000000 --- a/source/unres/src_MD-M-newcorr/symbolsizes.txt +++ /dev/null @@ -1,257 +0,0 @@ -bm_outfile 0x64 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_I_LONG_LONG_INT - 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -frag_ 0xa0 geomout.o -calcthet_ 0x9c energy_p_new_barrier.o -wagi_ 0x10 geomout.o -cache_ 0x5dcd0 mcm.o -rm_outfile_head 0x64 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -header_ 0x50 unres.o -mvstat_ 0x250 readrtns_CSA.o -timing_ 0x140 unres.o -MPIR_I_COMPLEX 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -MPIR_I_LONG_INT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -ffield_ 0x174 unres.o -chuju_ 0x4 minimize_p.o -deriv_loc_ 0x1e0 initialize_p.o -splitele_ 0x10 initialize_p.o -cipiszcze_ 0x4 /tmp/ipo_ifortx3jrsv.o -MPIR_I_DOUBLE_PRECISION - 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -MPIR_I_SHORT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPI_LONG_DOUBLE_INT_var - 0x20 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_dtes 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_I_UB 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -refstruct_ 0x1c26c unres.o -dih_control_ 0xc readrtns_CSA.o -MPIR_I_FLOAT_INT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_I_SHORT_INT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -frozen_ 0x12c0 geomout.o -sumsl_flag_ 0x4 unres.o -execer_pg 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -links_split_ 0x8 unres.o -precomp1_ 0x70800 unres.o -bounds_ 0x4b00 readrtns_CSA.o -MPIR_I_2DCOMPLEX 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -alphaa_ 0x1e788 readrtns_CSA.o -MPIR_errhandlers 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initutil.o) -chain_ 0x54680 unres.o -parfiles_ 0xb00 unres.o -globmemsize 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -rotat_old_ 0x9600 unres.o -bank_ 0x25920 readrtns_CSA.o -p4_rm_rank 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -contacts1_ 0xc5d3c0 unres.o -mce_ 0x230 readrtns_CSA.o -diploc_ 0x3938 unres.o -mucarem_ 0x8000 readrtns_CSA.o -mdpmpi_ 0x8014 unres.o -iounits_ 0x6c unres.o -MPI_DOUBLE_INT_var 0x10 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -mapp_ 0x25804 readrtns_CSA.o -MPIR_real8_dte 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -p4_brdcst_info 0x18 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -langforc_ 0x26782534 readrtns_CSA.o -MPIR_I_2INT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -minvar_ 0x12d78 readrtns_CSA.o -torsion_ 0x5adc parmread.o -struct_ 0xa2c readrtns_CSA.o -procgroup_file 0x100 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -mdpar_ 0x6c unres.o -MPID_MyWorldSize 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(adi2init.o) -spinka_ 0x384c newconf.o -thetas_ 0x960 chainbuild.o -__P4FROM 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4priv.o) -MPIR_int1_dte 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -MPIR_debug_q 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -MPIR_debug_sq 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -MPID_MyWorldRank 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(adi2init.o) -remdrestart_ 0x411808 unres.o -for__pthread_mutex_unlock_ptr - 0x8 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_aio.o) -restr_ 0xce44 unres.o -locel_ 0x274 energy_p_new_barrier.o -MPIR_I_REAL 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -fourier_ 0x344 initialize_p.o -precomp2_ 0x70800 unres.o -torsiond_ 0x14200 initialize_p.o -for__a_argv 0x8 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_init.o) -MPIR_debug_rh 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -pool_ 0x5dc5c readrtns_CSA.o -maxgrad_ 0xa8 energy_p_new_barrier.o -double_muca_ 0x25828 readrtns_CSA.o -links_ 0x107035c unres.o -MPID_byte_order 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(chhetero.o) -p4_global 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_I_2REAL 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -mdgrad_ 0x1c230 unres.o -execer_mastport 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -from_zscore_ 0xc unres.o -csa_input_ 0x98 readrtns_CSA.o -for__pthread_mutex_init_ptr - 0x8 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_aio.o) -machsw_ 0xc initialize_p.o -types_ 0x54 unres.o -MPIR_I_USHORT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_I_FLOAT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -sccalc_ 0x28 energy_p_new_barrier.o -pochodne_ 0xb01310 geomout.o -loc_work_ 0x30c local_move.o -peptbond_ 0x28 chainbuild.o -MPIR_I_UINT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -calc_ 0x1f0 gen_rand_conf.o -execer_id 0x84 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPI_FLOAT_INT_var 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -execer_numtotnodes 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -derivat_ 0x436dbe8 initialize_p.o -MPIR_I_BYTE 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_I_CHAR 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -deriv_scloc_ 0x3f480 initialize_p.o -listener_info 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -przechowalnia_ 0x7080000 MREMD.o -MPIR_All_communicators - 0x10 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -diffcuta_ 0x8 readrtns_CSA.o -vectors_ 0x62700 energy_p_new_barrier.o -thread_ 0x148 readrtns_CSA.o -back_constr_ 0x165cc unres.o -MPIR_I_PACKED 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_I_INT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -p4_local 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_I_DCOMPLEX 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -logging_flag 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -pizda_ 0x12c0 readrtns_CSA.o -execer_myhost 0x64 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_rhandles 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(adi2init.o) -MPIR_topo_els 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initutil.o) -par_ 0x20 eigen.o -info_ 0x4010 timing.o -MPIR_I_INTEGER 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -tty_orig 0x12 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_secure.o) -MPIR_I_DOUBLE_INT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -mpgrad_ 0x2588 initialize_p.o -info1_ 0x2824 timing.o -setup_ 0x6040 unres.o -p4_wd 0x100 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_Op_errno 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(global_ops.o) -restraints_ 0x8 unres.o -MPIR_I_LONG_DOUBLE 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -torcnstr_ 0x7098 initialize_p.o -stochcalc_ 0xe100 MD_A-MTS.o -MPIR_I_2FLOAT 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_real4_dte 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -indices_ 0x7060 chainbuild.o -qmeas_ 0x7633c unres.o -MPID_recvs 0x20 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(queue.o) -mpipriv_ 0x24 unres.o -p4_remote_debug_level - 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_shandles 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(adi2init.o) -total_pack_unacked 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(chpackflow.o) -kutas_ 0x4 energy_p_new_barrier.o -cntrl_ 0x7c unres.o -sserver_port 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -rotmat_ 0x54600 unres.o -varin_ 0x12d48 readrtns_CSA.o -p4_myname_in_procgroup - 0x40 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -lagrange_ 0x1085e2b8 unres.o -message_catalog 0x8 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_diags_intel.o) -MPIR_I_UCHAR 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -fnames_ 0x1007 unres.o -loc_const_ 0x40 local_move.o -stoptim_ 0x4 unres.o -sclocal_ 0x22cc chainbuild.o -time1_ 0x30 unres.o -MPIR_I_2DOUBLE 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -bank_disulfid_ 0x1f0 readrtns_CSA.o -MPID_pack_info 0x10 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(chpackflow.o) -MPIR_debug_qh 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -mdcalc_ 0x108 unres.o -dipmat_ 0xafc8000 unres.o -hand_start_remotes 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -execer_starting_remotes - 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -remdcommon_ 0x6030 unres.o -sbridge_ 0x9c unres.o -refer_ 0x98 bond_move.o -csafiles_ 0xc00 unres.o -MPIR_tid 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initutil.o) -thread1_ 0x1cd0 readrtns_CSA.o -langmat_ 0x83d6000 readrtns_CSA.o -__P4GLOBALTYPE 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4priv.o) -integer_muca_ 0xc readrtns_CSA.o -MPI_SHORT_INT_var 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -inertia_ 0x160 unres.o -mcm_ 0x20a4 initialize_p.o -MPIR_I_2DOUBLE_PRECISION - 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -for__pthread_mutex_lock_ptr - 0x8 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_aio.o) -mce_counters_ 0x14 readrtns_CSA.o -aaaa_ 0x8 MP.o -store0_ 0x4 geomout.o -MPIR_I_2INTEGER 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -banii_ 0xe100 banach.o -scrot_ 0x28a0 parmread.o -c_frag_ 0x2588 geomout.o -move_ 0x4b78 initialize_p.o -MPIR_fdtels 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initutil.o) -MPIR_I_LONG 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -vrandd_ 0x3f0 randgens.o -syfek_ 0xe100 stochfric.o -whoami_p4 0x64 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -windows_ 0x3844 initialize_p.o -contacts_hb_ 0x4e483c0 unres.o -MPIR_debug_s 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -MPIR_I_ULONG 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_hbt_els 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(util_hbt.o) -srutu_ 0x4 unres.o -contdistrib_ 0x2c0944c unres.o -expect_ack 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(chpackflow.o) -MPIR_hbts 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(util_hbt.o) -__P4TYPE 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4priv.o) -traj1cache_ 0x480dc unres.o -accept_stats_ 0x2008 initialize_p.o -execer_masthost 0x64 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -for__l_argc 0x4 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_init.o) -invlen_ 0x4b00 chainbuild.o -MPIR_I_LONG_DOUBLE_INT - 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_debug_c 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -MPI_LONG_INT_var 0x10 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -MPIR_I_LB 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -p4_debug_level 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -stretch_ 0x608 unres.o -for__aio_lub_table 0x400 /opt/intel/Compiler/11.1/046/lib/intel64/libifcore.a(for_aio.o) -iofile_ 0x65c initialize_p.o -MPIR_qels 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initutil.o) -__P4LEN 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4priv.o) -local_domain 0x64 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -minimm_ 0x20 initialize_p.o -MPIR_debug_qel 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -send2_ 0x151b0 readrtns_CSA.o -MPIR_debug_sqel 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) -MPIR_I_2COMPLEX 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -gucio_ 0x18 MD_A-MTS.o -ch_debug_buf 0x80 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(adi2init.o) -execer_mynumprocs 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -contacts_ 0x38408 unres.o -__BLNK__ 0xc djacob.o -MPIR_I_LOGICAL 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -MPIR_int2_dte 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -geo_ 0x40 unres.o -execer_mynodenum 0x4 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(p4_globals.o) -MPIR_int4_dte 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initfutil.o) -MPIR_I_DOUBLE 0xa8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(initdte.o) -csaunits_ 0x34 unres.o -body_ 0x6180 unres.o -interact_ 0x154bc unres.o -theta_abinitio_ 0x24a70 chainbuild.o -oldgeo_ 0xbb8f4 unres.o -rotat_ 0x38400 unres.o -var_ 0x35e90 unres.o -secondarys_ 0x4b0 dihed_cons.o -MPIR_debug_cl 0x8 /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/lib/libmpich.a(debugutil.o) - diff --git a/source/unres/src_MD-M-newcorr/tau.options b/source/unres/src_MD-M-newcorr/tau.options deleted file mode 100644 index f17ddc3..0000000 --- a/source/unres/src_MD-M-newcorr/tau.options +++ /dev/null @@ -1,41 +0,0 @@ -Usage: tau_compiler.sh - -optVerbose Turn on verbose debugging message - -optDetectMemoryLeaks Track mallocs/frees using TAU's memory wrapper - -optPdtDir="" PDT architecture directory. Typically $(PDTDIR)/$(PDTARCHDIR) - -optPdtF95Opts="" Options for Fortran parser in PDT (f95parse) - -optPdtF95Reset="" Reset options to the Fortran parser to the given list - -optPdtCOpts="" Options for C parser in PDT (cparse). Typically $(TAU_MPI_INCLUDE) $(TAU_INCLUDE) $(TAU_DEFS) - -optPdtCReset="" Reset options to the C parser to the given list - -optPdtCxxOpts="" Options for C++ parser in PDT (cxxparse). Typically $(TAU_MPI_INCLUDE) $(TAU_INCLUDE) $(TAU_DEFS) - -optPdtCxxReset="" Reset options to the C++ parser to the given list - -optPdtF90Parser="" Specify a different Fortran parser. For e.g., f90parse instead of f95parse - -optPdtGnuFortranParser Specify the GNU gfortran PDT parser gfparse instead of f95parse - -optPdtUser="" Optional arguments for parsing source code - -optTauInstr="" Specify location of tau_instrumentor. Typically $(TAUROOT)/$(CONFIG_ARCH)/bin/tau_instrumentor - -optPreProcess Preprocess the source code before parsing. Uses /usr/bin/cpp -P by default. - -optCPP="" Specify an alternative preprocessor and pre-process the sources. - -optCPPOpts="" Specify additional options to the C pre-processor. - -optCPPReset="" Reset C preprocessor options to the specified list. - -optTauSelectFile="" Specify selective instrumentation file for tau_instrumentor - -optPDBFile="" Specify PDB file for tau_instrumentor. Skips parsing stage. - -optTau="" Specify options for tau_instrumentor - -optCompile="" Options passed to the compiler by the user. - -optTauDefs="" Options passed to the compiler by TAU. Typically $(TAU_DEFS) - -optTauIncludes="" Options passed to the compiler by TAU. Typically $(TAU_MPI_INCLUDE) $(TAU_INCLUDE) - -optIncludeMemory="" Flags for replacement of malloc/free. Typically -I$(TAU_DIR)/include/Memory - -optReset="" Reset options to the compiler to the given list - -optLinking="" Options passed to the linker. Typically $(TAU_MPI_FLIBS) $(TAU_LIBS) $(TAU_CXXLIBS) - -optLinkReset="" Reset options to the linker to the given list - -optTauCC="" Specifies the C compiler used by TAU - -optOpariTool="" Specifies the location of the Opari tool - -optOpariDir="" Specifies the location of the Opari directory - -optOpariOpts="" Specifies optional arguments to the Opari tool - -optOpariReset="" Resets options passed to the Opari tool - -optNoMpi Removes -l*mpi* libraries during linking (default) - -optMpi Does not remove -l*mpi* libraries during linking - -optNoRevert Exit on error. Does not revert to the original compilation rule on error. - -optRevert Revert to the original compilation rule on error (default). - -optKeepFiles Does not remove intermediate .pdb and .inst.* files - -optAppCC="" Specifies the fallback C compiler. - -optAppCXX="" Specifies the fallback C++ compiler. - -optAppF90="" Specifies the fallback F90 compiler. diff --git a/source/unres/src_MD-M-newcorr/test.F b/source/unres/src_MD-M-newcorr/test.F deleted file mode 100644 index 4c7a728..0000000 --- a/source/unres/src_MD-M-newcorr/test.F +++ /dev/null @@ -1,2707 +0,0 @@ - subroutine test - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.CHAIN' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar),var1(maxvar) - integer j1,j2 - logical debug,accepted - debug=.true. - - - call geom_to_var(nvar,var1) - call chainbuild - call etotal(energy(0)) - etot=energy(0) - call rmsd(rms) - write(iout,*) 'etot=',0,etot,rms - call secondary2(.false.) - - call write_pdb(0,'first structure',etot) - - j1=13 - j2=21 - da=180.0*deg2rad - - - - temp=3000.0d0 - betbol=1.0D0/(1.9858D-3*temp) - jr=iran_num(j1,j2) - d=ran_number(-pi,pi) -c phi(jr)=pinorm(phi(jr)+d) - call chainbuild - call etotal(energy(0)) - etot0=energy(0) - call rmsd(rms) - write(iout,*) 'etot=',1,etot0,rms - call write_pdb(1,'perturb structure',etot0) - - do i=2,500,2 - jr=iran_num(j1,j2) - d=ran_number(-da,da) - phiold=phi(jr) - phi(jr)=pinorm(phi(jr)+d) - call chainbuild - call etotal(energy(0)) - etot=energy(0) - - if (etot.lt.etot0) then - accepted=.true. - else - accepted=.false. - xxr=ran_number(0.0D0,1.0D0) - xxh=betbol*(etot-etot0) - if (xxh.lt.50.0D0) then - xxh=dexp(-xxh) - if (xxh.gt.xxr) accepted=.true. - endif - endif - accepted=.true. -c print *,etot0,etot,accepted - if (accepted) then - etot0=etot - call rmsd(rms) - write(iout,*) 'etot=',i,etot,rms - call write_pdb(i,'MC structure',etot) -c minimize -c call geom_to_var(nvar,var1) - call sc_move(2,nres-1,1,10d0,nft_sc,etot) - call geom_to_var(nvar,var) - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun - call var_to_geom(nvar,var) - call chainbuild - call rmsd(rms) - write(iout,*) 'etot mcm=',i,etot,rms - call write_pdb(i+1,'MCM structure',etot) - call var_to_geom(nvar,var1) -c -------- - else - phi(jr)=phiold - endif - enddo - -c minimize -c call sc_move(2,nres-1,1,10d0,nft_sc,etot) -c call geom_to_var(nvar,var) -c -c call chainbuild -c call write_pdb(998 ,'sc min',etot) -c -c call minimize(etot,var,iretcode,nfun) -c write(iout,*)'------------------------------------------------' -c write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun -c -c call var_to_geom(nvar,var) -c call chainbuild -c call write_pdb(999,'full min',etot) - - - return - end - - - subroutine test_n16 - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.CHAIN' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar),var1(maxvar) - integer jdata(5) - logical debug - debug=.true. - -c - call geom_to_var(nvar,var1) - call chainbuild - call etotal(energy(0)) - etot=energy(0) - write(iout,*) nnt,nct,etot - call write_pdb(1,'first structure',etot) - call secondary2(.true.) - - do i=1,4 - jdata(i)=bfrag(i,2) - enddo - - DO ij=1,4 - ieval=0 - jdata(5)=ij - call var_to_geom(nvar,var1) - write(iout,*) 'N16 test',(jdata(i),i=1,5) - call beta_slide(jdata(1),jdata(2),jdata(3),jdata(4),jdata(5) - & ,ieval,ij) - call geom_to_var(nvar,var) - - if (minim) then - time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, - & '+ DIST eval',ieval - - time1=MPI_WTIME() - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(ij*100+99,'full min',etot) - endif - - - ENDDO - - return - end - - - subroutine test_local - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision varia(maxvar) -c - call chainbuild -c call geom_to_var(nvar,varia) - call write_pdb(1,'first structure',0d0) - - call etotal(energy(0)) - etot=energy(0) - write(iout,*) nnt,nct,etot - - write(iout,*) 'calling sc_move' - call sc_move(nnt,nct,5,10d0,nft_sc,etot) - write(iout,*) nft_sc,etot - call write_pdb(2,'second structure',etot) - - write(iout,*) 'calling local_move' - call local_move_init(.false.) - call local_move(24,29,20d0,50d0) - call chainbuild - call write_pdb(3,'third structure',etot) - - write(iout,*) 'calling sc_move' - call sc_move(24,29,5,10d0,nft_sc,etot) - write(iout,*) nft_sc,etot - call write_pdb(2,'last structure',etot) - - - return - end - - subroutine test_sc - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision varia(maxvar) -c - call chainbuild -c call geom_to_var(nvar,varia) - call write_pdb(1,'first structure',0d0) - - call etotal(energy(0)) - etot=energy(0) - write(iout,*) nnt,nct,etot - - write(iout,*) 'calling sc_move' - - call sc_move(nnt,nct,5,10d0,nft_sc,etot) - write(iout,*) nft_sc,etot - call write_pdb(2,'second structure',etot) - - write(iout,*) 'calling sc_move 2nd time' - - call sc_move(nnt,nct,5,1d0,nft_sc,etot) - write(iout,*) nft_sc,etot - call write_pdb(3,'last structure',etot) - return - end -c-------------------------------------------------------- - subroutine bgrow(bstrand,nbstrand,in,ind,new) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - integer bstrand(maxres/3,6) - - ishift=iabs(bstrand(in,ind+4)-new) - - print *,'bgrow',bstrand(in,ind+4),new,ishift - - bstrand(in,ind)=new - - if(ind.eq.1)then - bstrand(nbstrand,5)=bstrand(nbstrand,1) - do i=1,nbstrand-1 - IF (bstrand(nbstrand,3).eq.bstrand(i,3)) THEN - if (bstrand(i,5).lt.bstrand(i,6)) then - bstrand(i,5)=bstrand(i,5)-ishift - else - bstrand(i,5)=bstrand(i,5)+ishift - endif - ENDIF - enddo - else - bstrand(nbstrand,6)=bstrand(nbstrand,2) - do i=1,nbstrand-1 - IF (bstrand(nbstrand,3).eq.bstrand(i,3)) THEN - if (bstrand(i,6).lt.bstrand(i,5)) then - bstrand(i,6)=bstrand(i,6)-ishift - else - bstrand(i,6)=bstrand(i,6)+ishift - endif - ENDIF - enddo - endif - - - return - end - - -c------------------------------------------ - subroutine test11 - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' -c - include 'COMMON.DISTFIT' - integer if(20,maxres),nif,ifa(20) - integer ibc(0:maxres,0:maxres),istrand(20) - integer ibd(maxres),ifb(10,2),nifb,lifb(10),lifb0 - integer itmp(20,maxres) - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision varia(maxvar),vorg(maxvar) -c - logical debug,ltest,usedbfrag(maxres/3) - character*50 linia -c - integer betasheet(maxres),ibetasheet(maxres),nbetasheet - integer bstrand(maxres/3,6),nbstrand - -c------------------------ - - debug=.true. -c------------------------ - nbstrand=0 - nbetasheet=0 - do i=1,nres - betasheet(i)=0 - ibetasheet(i)=0 - enddo - call geom_to_var(nvar,vorg) - call secondary2(debug) - - if (nbfrag.le.1) return - - do i=1,nbfrag - usedbfrag(i)=.false. - enddo - - - nbetasheet=nbetasheet+1 - nbstrand=2 - bstrand(1,1)=bfrag(1,1) - bstrand(1,2)=bfrag(2,1) - bstrand(1,3)=nbetasheet - bstrand(1,4)=1 - bstrand(1,5)=bfrag(1,1) - bstrand(1,6)=bfrag(2,1) - do i=bfrag(1,1),bfrag(2,1) - betasheet(i)=nbetasheet - ibetasheet(i)=1 - enddo -c - bstrand(2,1)=bfrag(3,1) - bstrand(2,2)=bfrag(4,1) - bstrand(2,3)=nbetasheet - bstrand(2,5)=bfrag(3,1) - bstrand(2,6)=bfrag(4,1) - - if (bfrag(3,1).le.bfrag(4,1)) then - bstrand(2,4)=2 - do i=bfrag(3,1),bfrag(4,1) - betasheet(i)=nbetasheet - ibetasheet(i)=2 - enddo - else - bstrand(2,4)=-2 - do i=bfrag(4,1),bfrag(3,1) - betasheet(i)=nbetasheet - ibetasheet(i)=2 - enddo - endif - - iused_nbfrag=1 - - do while (iused_nbfrag.ne.nbfrag) - - do j=2,nbfrag - - IF (.not.usedbfrag(j)) THEN - - write (*,*) j,(bfrag(i,j),i=1,4) - do jk=6,1,-1 - write (*,'(i4,a3,10i4)') jk,'B',(bstrand(i,jk),i=1,nbstrand) - enddo - write (*,*) '------------------' - - - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - if(betasheet(i).eq.nbetasheet) then - in=ibetasheet(i) - do k=bfrag(3,j),bfrag(4,j) - betasheet(k)=nbetasheet - ibetasheet(k)=in - enddo - nbstrand=nbstrand+1 - usedbfrag(j)=.true. - iused_nbfrag=iused_nbfrag+1 - do k=bfrag(1,j),bfrag(2,j) - betasheet(k)=nbetasheet - ibetasheet(k)=nbstrand - enddo - if (bstrand(in,4).lt.0) then - bstrand(nbstrand,1)=bfrag(2,j) - bstrand(nbstrand,2)=bfrag(1,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=-nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).lt.bfrag(4,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(4,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)+ - & (bstrand(in,5)-bfrag(4,j)) - endif - if(bstrand(in,2).gt.bfrag(3,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(3,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)- - & (-bstrand(in,6)+bfrag(3,j)) - endif - else - bstrand(nbstrand,1)=bfrag(1,j) - bstrand(nbstrand,2)=bfrag(2,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).gt.bfrag(3,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(3,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)- - & (-bstrand(in,5)+bfrag(3,j)) - endif - if(bstrand(in,2).lt.bfrag(4,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(4,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)+ - & (bstrand(in,6)-bfrag(4,j)) - endif - endif - goto 11 - endif - if(betasheet(bfrag(1,j)+i-bfrag(3,j)).eq.nbetasheet) then - in=ibetasheet(bfrag(1,j)+i-bfrag(3,j)) - do k=bfrag(1,j),bfrag(2,j) - betasheet(k)=nbetasheet - ibetasheet(k)=in - enddo - nbstrand=nbstrand+1 - usedbfrag(j)=.true. - iused_nbfrag=iused_nbfrag+1 - do k=bfrag(3,1),bfrag(4,1) - betasheet(k)=nbetasheet - ibetasheet(k)=nbstrand - enddo - if (bstrand(in,4).lt.0) then - bstrand(nbstrand,1)=bfrag(4,j) - bstrand(nbstrand,2)=bfrag(3,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=-nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).lt.bfrag(2,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(2,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)+ - & (bstrand(in,5)-bfrag(2,j)) - endif - if(bstrand(in,2).gt.bfrag(1,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(1,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)- - & (-bstrand(in,6)+bfrag(1,j)) - endif - else - bstrand(nbstrand,1)=bfrag(3,j) - bstrand(nbstrand,2)=bfrag(4,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).gt.bfrag(1,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(1,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)- - & (-bstrand(in,5)+bfrag(1,j)) - endif - if(bstrand(in,2).lt.bfrag(2,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(2,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)+ - & (bstrand(in,6)-bfrag(2,j)) - endif - endif - goto 11 - endif - enddo - else - do i=bfrag(4,j),bfrag(3,j) - if(betasheet(i).eq.nbetasheet) then - in=ibetasheet(i) - do k=bfrag(4,j),bfrag(3,j) - betasheet(k)=nbetasheet - ibetasheet(k)=in - enddo - nbstrand=nbstrand+1 - usedbfrag(j)=.true. - iused_nbfrag=iused_nbfrag+1 - do k=bfrag(1,j),bfrag(2,j) - betasheet(k)=nbetasheet - ibetasheet(k)=nbstrand - enddo - if (bstrand(in,4).lt.0) then - bstrand(nbstrand,1)=bfrag(1,j) - bstrand(nbstrand,2)=bfrag(2,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).lt.bfrag(3,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(3,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)- - & (bstrand(in,5)-bfrag(3,j)) - endif - if(bstrand(in,2).gt.bfrag(4,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(4,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)+ - & (-bstrand(in,6)+bfrag(4,j)) - endif - else - bstrand(nbstrand,1)=bfrag(2,j) - bstrand(nbstrand,2)=bfrag(1,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=-nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).gt.bfrag(4,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(4,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)+ - & (-bstrand(in,5)+bfrag(4,j)) - endif - if(bstrand(in,2).lt.bfrag(3,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(3,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)- - & (bstrand(in,6)-bfrag(3,j)) - endif - endif - goto 11 - endif - if(betasheet(bfrag(2,j)-i+bfrag(4,j)).eq.nbetasheet) then - in=ibetasheet(bfrag(2,j)-i+bfrag(4,j)) - do k=bfrag(1,j),bfrag(2,j) - betasheet(k)=nbetasheet - ibetasheet(k)=in - enddo - nbstrand=nbstrand+1 - usedbfrag(j)=.true. - iused_nbfrag=iused_nbfrag+1 - do k=bfrag(4,j),bfrag(3,j) - betasheet(k)=nbetasheet - ibetasheet(k)=nbstrand - enddo - if (bstrand(in,4).lt.0) then - bstrand(nbstrand,1)=bfrag(4,j) - bstrand(nbstrand,2)=bfrag(3,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).lt.bfrag(2,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(2,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)- - & (bstrand(in,5)-bfrag(2,j)) - endif - if(bstrand(in,2).gt.bfrag(1,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(1,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)+ - & (-bstrand(in,6)+bfrag(1,j)) - endif - else - bstrand(nbstrand,1)=bfrag(3,j) - bstrand(nbstrand,2)=bfrag(4,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=-nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).gt.bfrag(1,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(1,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)+ - & (-bstrand(in,5)+bfrag(1,j)) - endif - if(bstrand(in,2).lt.bfrag(2,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(2,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)- - & (bstrand(in,6)-bfrag(2,j)) - endif - endif - goto 11 - endif - enddo - endif - - - - ENDIF - enddo - - j=2 - do while (usedbfrag(j)) - j=j+1 - enddo - - nbstrand=nbstrand+1 - nbetasheet=nbetasheet+1 - bstrand(nbstrand,1)=bfrag(1,j) - bstrand(nbstrand,2)=bfrag(2,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,5)=bfrag(1,j) - bstrand(nbstrand,6)=bfrag(2,j) - - bstrand(nbstrand,4)=nbstrand - do i=bfrag(1,j),bfrag(2,j) - betasheet(i)=nbetasheet - ibetasheet(i)=nbstrand - enddo -c - nbstrand=nbstrand+1 - bstrand(nbstrand,1)=bfrag(3,j) - bstrand(nbstrand,2)=bfrag(4,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,5)=bfrag(3,j) - bstrand(nbstrand,6)=bfrag(4,j) - - if (bfrag(3,j).le.bfrag(4,j)) then - bstrand(nbstrand,4)=nbstrand - do i=bfrag(3,j),bfrag(4,j) - betasheet(i)=nbetasheet - ibetasheet(i)=nbstrand - enddo - else - bstrand(nbstrand,4)=-nbstrand - do i=bfrag(4,j),bfrag(3,j) - betasheet(i)=nbetasheet - ibetasheet(i)=nbstrand - enddo - endif - - iused_nbfrag=iused_nbfrag+1 - usedbfrag(j)=.true. - - - 11 continue - do jk=6,1,-1 - write (*,'(i4,a3,10i4)') jk,'A',(bstrand(i,jk),i=1,nbstrand) - enddo - - - enddo - - do i=1,nres - if (betasheet(i).ne.0) write(*,*) i,betasheet(i),ibetasheet(i) - enddo - write(*,*) - do j=6,1,-1 - write (*,'(i4,a3,10i4)') j,':',(bstrand(i,j),i=1,nbstrand) - enddo - -c------------------------ - nifb=0 - do i=1,nbstrand - do j=i+1,nbstrand - if(iabs(bstrand(i,5)-bstrand(j,5)).le.5 .or. - & iabs(bstrand(i,6)-bstrand(j,6)).le.5 ) then - nifb=nifb+1 - ifb(nifb,1)=bstrand(i,4) - ifb(nifb,2)=bstrand(j,4) - endif - enddo - enddo - - write(*,*) - do i=1,nifb - write (*,'(a3,20i4)') "ifb",i,ifb(i,1),ifb(i,2) - enddo - - do i=1,nbstrand - ifa(i)=bstrand(i,4) - enddo - write (*,'(a3,20i4)') "ifa",(ifa(i),i=1,nbstrand) - - nif=iabs(bstrand(1,6)-bstrand(1,5))+1 - do j=2,nbstrand - if (iabs(bstrand(j,6)-bstrand(j,5))+1.gt.nif) - & nif=iabs(bstrand(j,6)-bstrand(j,5))+1 - enddo - - write(*,*) nif - do i=1,nif - do j=1,nbstrand - if(j,i)=bstrand(j,6)+(i-1)*sign(1,bstrand(j,5)-bstrand(j,6)) - if (if(j,i).gt.0) then - if(betasheet(if(j,i)).eq.0 .or. - & ibetasheet(if(j,i)).ne.iabs(bstrand(j,4))) if(j,i)=0 - else - if(j,i)=0 - endif - enddo - write(*,'(a3,10i4)') 'if ',(if(j,i),j=1,nbstrand) - enddo - -c read (inp,*) (ifa(i),i=1,4) -c do i=1,nres -c read (inp,*,err=20,end=20) (if(j,i),j=1,4) -c enddo -c 20 nif=i-1 - stop -c------------------------ - - isa=4 - is=2*isa-1 - iconf=0 -cccccccccccccccccccccccccccccccccc - DO ig=1,is**isa-1 -cccccccccccccccccccccccccccccccccc - - ii=ig - do j=1,is - istrand(is-j+1)=int(ii/is**(is-j)) - ii=ii-istrand(is-j+1)*is**(is-j) - enddo - ltest=.true. - do k=1,isa - istrand(k)=istrand(k)+1 - if(istrand(k).gt.isa) istrand(k)=istrand(k)-2*isa-1 - enddo - do k=1,isa - do l=1,isa - if(istrand(k).eq.istrand(l).and.k.ne.l.or. - & istrand(k).eq.-istrand(l).and.k.ne.l) ltest=.false. - enddo - enddo - - lifb0=1 - do m=1,nifb - lifb(m)=0 - do k=1,isa-1 - if( - & ifb(m,1).eq.istrand(k).and.ifb(m,2).eq.istrand(k+1).or. - & ifb(m,2).eq.istrand(k).and.ifb(m,1).eq.istrand(k+1).or. - & -ifb(m,1).eq.istrand(k).and.-ifb(m,2).eq.istrand(k+1).or. - & -ifb(m,2).eq.istrand(k).and.-ifb(m,1).eq.istrand(k+1)) - & lifb(m)=1 - enddo - lifb0=lifb0*lifb(m) - enddo - - if (mod(isa,2).eq.0) then - do k=isa/2+1,isa - if (istrand(k).eq.1) ltest=.false. - enddo - else - do k=(isa+1)/2+1,isa - if (istrand(k).eq.1) ltest=.false. - enddo - endif - - IF (ltest.and.lifb0.eq.1) THEN - iconf=iconf+1 - - call var_to_geom(nvar,vorg) - - write (*,'(i5,i10,10i3)') iconf,ig,(istrand(k),k=1,isa) - write (iout,'(i5,i10,10i3)') iconf,ig,(istrand(k),k=1,isa) - write (linia,'(10i3)') (istrand(k),k=1,isa) - - do i=1,nres - do j=1,nres - ibc(i,j)=0 - enddo - enddo - - - do i=1,4 - if ( sign(1,istrand(i)).eq.sign(1,ifa(iabs(istrand(i)))) ) then - do j=1,nif - itmp(iabs(istrand(i)),j)=if(iabs(ifa(iabs(istrand(i)))),j) - enddo - else - do j=1,nif - itmp(iabs(istrand(i)),j)=if(iabs(ifa(iabs(istrand(i)))),nif-j+1) - enddo - endif - enddo - - do i=1,nif - write(*,*) (itmp(j,i),j=1,4) - enddo - - do i=1,nif -c ifa(1),ifa(2),ifa(3),ifa(4) -c if(1,i),if(2,i),if(3,i),if(4,i) - do k=1,isa-1 - ltest=.false. - do m=1,nifb - if( - & ifb(m,1).eq.istrand(k).and.ifb(m,2).eq.istrand(k+1).or. - & ifb(m,2).eq.istrand(k).and.ifb(m,1).eq.istrand(k+1).or. - & -ifb(m,1).eq.istrand(k).and.-ifb(m,2).eq.istrand(k+1).or. - & -ifb(m,2).eq.istrand(k).and.-ifb(m,1).eq.istrand(k+1)) - & then - ltest=.true. - goto 110 - endif - enddo - 110 continue - if (ltest) then - ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+1)),i))=-1 - else - ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+1)),i))=-2 - endif -c - if (k.lt.3) - & ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+2)),i))=-3 - if (k.lt.2) - & ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+3)),i))=-4 - enddo - enddo -c------------------------ - -c -c freeze sec.elements -c - do i=1,nres - mask(i)=1 - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - enddo - - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - enddo - mask_r=.true. - -c------------------------ -c generate constrains -c - nhpb0=nhpb - call chainbuild - ind=0 - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if ( ibc(i,j).eq.-1 .or. ibc(j,i).eq.-1) then - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).eq.-2 .or. ibc(j,i).eq.-2) then - d0(ind)=5.0 - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).eq.-3 .or. ibc(j,i).eq.-3) then - d0(ind)=11.0 - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).eq.-4 .or. ibc(j,i).eq.-4) then - d0(ind)=16.0 - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).gt.0 ) then - d0(ind)=DIST(i,ibc(i,j)) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(j,i).gt.0 ) then - d0(ind)=DIST(ibc(j,i),j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - w(ind)=0.0 - endif - dd(ind)=d0(ind) - enddo - enddo - call hpb_partition -cd-------------------------- - - write(iout,'(i3,2i4,a3,2i4,f7.2)') (i,ibc(ihpb(i),jhpb(i)), - & ibc(jhpb(i),ihpb(i)),' --', - & ihpb(i),jhpb(i),dhpb(i),i=1,nhpb) - -cd nhpb=0 -cd goto 901 -c -c - call contact_cp_min(varia,ifun,iconf,linia,debug) - if (minim) then - time0=MPI_WTIME() - call minimize(etot,varia,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, - & '+ DIST eval',ifun - - time1=MPI_WTIME() - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - write (linia,'(a10,10i3)') 'full_min',(istrand(k),k=1,isa) - call var_to_geom(nvar,varia) - call chainbuild - call write_pdb(900+iconf,linia,etot) - endif - - call etotal(energy(0)) - etot=energy(0) - call enerprint(energy(0)) -cd call intout -cd call briefout(0,etot) -cd call secondary2(.true.) - - 901 CONTINUE -ctest return -cccccccccccccccccccccccccccccccccccc - ENDIF - ENDDO -cccccccccccccccccccccccccccccccccccc - - return - 10 write (iout,'(a)') 'Error reading test structure.' - return - end -c-------------------------------------------------------- - - subroutine test3 - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' -c - include 'COMMON.DISTFIT' - integer if(3,maxres),nif - integer ibc(maxres,maxres),istrand(20) - integer ibd(maxres),ifb(10,2),nifb,lifb(10),lifb0 - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision varia(maxvar) -c - logical debug,ltest - character*50 linia -c - do i=1,nres - read (inp,*,err=20,end=20) if(1,i),if(2,i),if(3,i) - enddo - 20 nif=i-1 - write (*,'(a4,3i5)') ('if =',if(1,i),if(2,i),if(3,i), - & i=1,nif) - - -c------------------------ - call secondary2(debug) -c------------------------ - do i=1,nres - do j=1,nres - ibc(i,j)=0 - enddo - enddo - -c -c freeze sec.elements and store indexes for beta constrains -c - do i=1,nres - mask(i)=1 - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - enddo - - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - ibc(bfrag(1,j)+i-bfrag(3,j),i)=-1 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - ibc(bfrag(2,j)-i+bfrag(4,j),i)=-1 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - enddo - mask_r=.true. - - -c ---------------- test -------------- - do i=1,nif - if (ibc(if(1,i),if(2,i)).eq.-1) then - ibc(if(1,i),if(2,i))=if(3,i) - ibc(if(1,i),if(3,i))=if(2,i) - else if (ibc(if(2,i),if(1,i)).eq.-1) then - ibc(if(2,i),if(1,i))=0 - ibc(if(1,i),if(2,i))=if(3,i) - ibc(if(1,i),if(3,i))=if(2,i) - else - ibc(if(1,i),if(2,i))=if(3,i) - ibc(if(1,i),if(3,i))=if(2,i) - endif - enddo - - do i=1,nres - do j=1,nres - if (ibc(i,j).ne.0) write(*,'(3i5)') i,j,ibc(i,j) - enddo - enddo -c------------------------ - call chainbuild - ind=0 - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if ( ibc(i,j).eq.-1 ) then - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).gt.0 ) then - d0(ind)=DIST(i,ibc(i,j)) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(j,i).gt.0 ) then - d0(ind)=DIST(ibc(j,i),j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - w(ind)=0.0 - endif - enddo - enddo - call hpb_partition - -cd-------------------------- - write(*,'(i3,2i4,a3,2i4,f7.2)') (i,ibc(ihpb(i),jhpb(i)), - & ibc(jhpb(i),ihpb(i)),' --', - & ihpb(i),jhpb(i),dhpb(i),i=1,nhpb) - - - linia='dist' - debug=.true. - in_pdb=7 -c - call contact_cp_min(varia,ieval,in_pdb,linia,debug) - if (minim) then - time0=MPI_WTIME() - call minimize(etot,varia,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, - & '+ DIST eval',ieval - - time1=MPI_WTIME() - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - - call var_to_geom(nvar,varia) - call chainbuild - call write_pdb(999,'full min',etot) - endif - - call etotal(energy(0)) - etot=energy(0) - call enerprint(energy(0)) - call intout - call briefout(0,etot) - call secondary2(.true.) - - return - 10 write (iout,'(a)') 'Error reading test structure.' - return - end - - - - - subroutine test__ - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' -c - include 'COMMON.DISTFIT' - integer if(2,2),ind - integer iff(maxres) - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision theta2(maxres),phi2(maxres),alph2(maxres), - & omeg2(maxres), - & theta1(maxres),phi1(maxres),alph1(maxres), - & omeg1(maxres) - double precision varia(maxvar),varia2(maxvar) -c - - - read (inp,*,err=10,end=10) if(1,1),if(1,2),if(2,1),if(2,2) - write (iout,'(a4,4i5)') 'if =',if(1,1),if(1,2),if(2,1),if(2,2) - read (inp,*,err=10,end=10) (theta2(i),i=3,nres) - read (inp,*,err=10,end=10) (phi2(i),i=4,nres) - read (inp,*,err=10,end=10) (alph2(i),i=2,nres-1) - read (inp,*,err=10,end=10) (omeg2(i),i=2,nres-1) - do i=1,nres - theta2(i)=deg2rad*theta2(i) - phi2(i)=deg2rad*phi2(i) - alph2(i)=deg2rad*alph2(i) - omeg2(i)=deg2rad*omeg2(i) - enddo - do i=1,nres - theta1(i)=theta(i) - phi1(i)=phi(i) - alph1(i)=alph(i) - omeg1(i)=omeg(i) - enddo - - do i=1,nres - mask(i)=1 - enddo - - -c------------------------ - do i=1,nres - iff(i)=0 - enddo - do j=1,2 - do i=if(j,1),if(j,2) - iff(i)=1 - enddo - enddo - - call chainbuild - call geom_to_var(nvar,varia) - call write_pdb(1,'first structure',0d0) - - call secondary(.true.) - - call secondary2(.true.) - - do j=1,nbfrag - if ( (bfrag(3,j).lt.bfrag(4,j) .or. - & bfrag(4,j)-bfrag(2,j).gt.4) .and. - & bfrag(2,j)-bfrag(1,j).gt.3 ) then - nn=nn+1 - - if (bfrag(3,j).lt.bfrag(4,j)) then - write(iout,'(a6,i3,a1,i3,a1,i3,a1,i3)') - & "select",bfrag(1,j)-1,"-",bfrag(2,j)-1 - & ,",",bfrag(3,j)-1,"-",bfrag(4,j)-1 - else - write(iout,'(a6,i3,a1,i3,a1,i3,a1,i3)') - & "select",bfrag(1,j)-1,"-",bfrag(2,j)-1 - & ,",",bfrag(4,j)-1,"-",bfrag(3,j)-1 - endif - endif - enddo - - do i=1,nres - theta(i)=theta2(i) - phi(i)=phi2(i) - alph(i)=alph2(i) - omeg(i)=omeg2(i) - enddo - - call chainbuild - call geom_to_var(nvar,varia2) - call write_pdb(2,'second structure',0d0) - - - -c------------------------------------------------------- - - ifun=-1 - call contact_cp(varia,varia2,iff,ifun,7) - if (minim) then - time0=MPI_WTIME() - call minimize(etot,varia,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, - & '+ DIST eval',ifun - - time1=MPI_WTIME() - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - - call var_to_geom(nvar,varia) - call chainbuild - call write_pdb(999,'full min',etot) - endif - - call etotal(energy(0)) - etot=energy(0) - call enerprint(energy(0)) - call intout - call briefout(0,etot) - - return - 10 write (iout,'(a)') 'Error reading test structure.' - return - end - -c------------------------------------------------- -c------------------------------------------------- - - subroutine secondary(lprint) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - - integer ncont,icont(2,maxres*maxres/2),isec(maxres,3) - logical lprint,not_done - real dcont(maxres*maxres/2),d - real rcomp /7.0/ - real rbeta /5.2/ - real ralfa /5.2/ - real r310 /6.6/ - double precision xpi(3),xpj(3) - - - - call chainbuild -cd call write_pdb(99,'sec structure',0d0) - ncont=0 - nbfrag=0 - nhfrag=0 - do i=1,nres - isec(i,1)=0 - isec(i,2)=0 - isec(i,3)=0 - enddo - - do i=2,nres-3 - do k=1,3 - xpi(k)=0.5d0*(c(k,i-1)+c(k,i)) - enddo - do j=i+2,nres - do k=1,3 - xpj(k)=0.5d0*(c(k,j-1)+c(k,j)) - enddo -cd d = (c(1,i)-c(1,j))*(c(1,i)-c(1,j)) + -cd & (c(2,i)-c(2,j))*(c(2,i)-c(2,j)) + -cd & (c(3,i)-c(3,j))*(c(3,i)-c(3,j)) -cd print *,'CA',i,j,d - d = (xpi(1)-xpj(1))*(xpi(1)-xpj(1)) + - & (xpi(2)-xpj(2))*(xpi(2)-xpj(2)) + - & (xpi(3)-xpj(3))*(xpi(3)-xpj(3)) - if ( d.lt.rcomp*rcomp) then - ncont=ncont+1 - icont(1,ncont)=i - icont(2,ncont)=j - dcont(ncont)=sqrt(d) - endif - enddo - enddo - if (lprint) then - write (iout,*) - write (iout,'(a)') '#PP contact map distances:' - do i=1,ncont - write (iout,'(3i4,f10.5)') - & i,icont(1,i),icont(2,i),dcont(i) - enddo - endif - -c finding parallel beta -cd write (iout,*) '------- looking for parallel beta -----------' - nbeta=0 - nstrand=0 - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if(dcont(i).le.rbeta .and. j1-i1.gt.4 .and. - & isec(i1,1).le.1.and.isec(j1,1).le.1.and. - & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. - & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. - & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. - & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) - & ) then - ii1=i1 - jj1=j1 -cd write (iout,*) i1,j1,dcont(i) - not_done=.true. - do while (not_done) - i1=i1+1 - j1=j1+1 - do j=1,ncont - if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j) - & .and. dcont(j).le.rbeta .and. - & isec(i1,1).le.1.and.isec(j1,1).le.1.and. - & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. - & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. - & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. - & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) - & ) goto 5 - enddo - not_done=.false. - 5 continue -cd write (iout,*) i1,j1,dcont(j),not_done - enddo - j1=j1-1 - i1=i1-1 - if (i1-ii1.gt.1) then - ii1=max0(ii1-1,1) - jj1=max0(jj1-1,1) - nbeta=nbeta+1 - if(lprint)write(iout,*)'parallel beta',nbeta,ii1,i1,jj1,j1 - - nbfrag=nbfrag+1 - bfrag(1,nbfrag)=ii1 - bfrag(2,nbfrag)=i1 - bfrag(3,nbfrag)=jj1 - bfrag(4,nbfrag)=j1 - - do ij=ii1,i1 - isec(ij,1)=isec(ij,1)+1 - isec(ij,1+isec(ij,1))=nbeta - enddo - do ij=jj1,j1 - isec(ij,1)=isec(ij,1)+1 - isec(ij,1+isec(ij,1))=nbeta - enddo - - if(lprint) then - nstrand=nstrand+1 - if (nbeta.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-1,"..",i1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-1,"..",i1-1,"'" - endif - nstrand=nstrand+1 - if (nbeta.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",jj1-1,"..",j1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",jj1-1,"..",j1-1,"'" - endif - write(12,'(a8,4i4)') - & "SetNeigh",ii1-1,i1-1,jj1-1,j1-1 - endif - endif - endif - enddo - -c finding antiparallel beta -cd write (iout,*) '--------- looking for antiparallel beta ---------' - - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if (dcont(i).le.rbeta.and. - & isec(i1,1).le.1.and.isec(j1,1).le.1.and. - & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. - & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. - & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. - & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) - & ) then - ii1=i1 - jj1=j1 -cd write (iout,*) i1,j1,dcont(i) - - not_done=.true. - do while (not_done) - i1=i1+1 - j1=j1-1 - do j=1,ncont - if (i1.eq.icont(1,j).and.j1.eq.icont(2,j) .and. - & isec(i1,1).le.1.and.isec(j1,1).le.1.and. - & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. - & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. - & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. - & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) - & .and. dcont(j).le.rbeta ) goto 6 - enddo - not_done=.false. - 6 continue -cd write (iout,*) i1,j1,dcont(j),not_done - enddo - i1=i1-1 - j1=j1+1 - if (i1-ii1.gt.1) then - if(lprint)write (iout,*)'antiparallel beta', - & nbeta,ii1-1,i1,jj1,j1-1 - - nbfrag=nbfrag+1 - bfrag(1,nbfrag)=max0(ii1-1,1) - bfrag(2,nbfrag)=i1 - bfrag(3,nbfrag)=jj1 - bfrag(4,nbfrag)=max0(j1-1,1) - - nbeta=nbeta+1 - iii1=max0(ii1-1,1) - do ij=iii1,i1 - isec(ij,1)=isec(ij,1)+1 - isec(ij,1+isec(ij,1))=nbeta - enddo - jjj1=max0(j1-1,1) - do ij=jjj1,jj1 - isec(ij,1)=isec(ij,1)+1 - isec(ij,1+isec(ij,1))=nbeta - enddo - - - if (lprint) then - nstrand=nstrand+1 - if (nstrand.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-2,"..",i1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-2,"..",i1-1,"'" - endif - nstrand=nstrand+1 - if (nstrand.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",j1-2,"..",jj1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",j1-2,"..",jj1-1,"'" - endif - write(12,'(a8,4i4)') - & "SetNeigh",ii1-2,i1-1,jj1-1,j1-2 - endif - endif - endif - enddo - - if (nstrand.gt.0.and.lprint) then - write(12,'(a27,$)') "DefPropRes 'sheet' 'strand1" - do i=2,nstrand - if (i.le.9) then - write(12,'(a9,i1,$)') " | strand",i - else - write(12,'(a9,i2,$)') " | strand",i - endif - enddo - write(12,'(a1)') "'" - endif - - -c finding alpha or 310 helix - - nhelix=0 - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if (j1.eq.i1+3.and.dcont(i).le.r310 - & .or.j1.eq.i1+4.and.dcont(i).le.ralfa ) then -cd if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,dcont(i) -cd if (j1.eq.i1+4) write (iout,*) "found 1-5 ",i1,j1,dcont(i) - ii1=i1 - jj1=j1 - if (isec(ii1,1).eq.0) then - not_done=.true. - else - not_done=.false. - endif - do while (not_done) - i1=i1+1 - j1=j1+1 - do j=1,ncont - if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10 - enddo - not_done=.false. - 10 continue -cd write (iout,*) i1,j1,not_done - enddo - j1=j1-1 - if (j1-ii1.gt.4) then - nhelix=nhelix+1 -cd write (iout,*)'helix',nhelix,ii1,j1 - - nhfrag=nhfrag+1 - hfrag(1,nhfrag)=ii1 - hfrag(2,nhfrag)=max0(j1-1,1) - - do ij=ii1,j1 - isec(ij,1)=-1 - enddo - if (lprint) then - write (iout,'(a6,i3,2i4)') "Helix",nhelix,ii1-1,j1-2 - if (nhelix.le.9) then - write(12,'(a17,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'helix",nhelix, - & "' 'num = ",ii1-1,"..",j1-2,"'" - else - write(12,'(a17,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'helix",nhelix, - & "' 'num = ",ii1-1,"..",j1-2,"'" - endif - endif - endif - endif - enddo - - if (nhelix.gt.0.and.lprint) then - write(12,'(a26,$)') "DefPropRes 'helix' 'helix1" - do i=2,nhelix - if (nhelix.le.9) then - write(12,'(a8,i1,$)') " | helix",i - else - write(12,'(a8,i2,$)') " | helix",i - endif - enddo - write(12,'(a1)') "'" - endif - - if (lprint) then - write(12,'(a37)') "DefPropRes 'coil' '! (helix | sheet)'" - write(12,'(a20)') "XMacStand ribbon.mac" - endif - - - return - end -c---------------------------------------------------------------------------- - - subroutine write_pdb(npdb,titelloc,ee) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - character*50 titelloc1 - character*(*) titelloc - character*3 zahl - character*5 liczba5 - double precision ee - integer npdb,ilen - external ilen - - titelloc1=titelloc - lenpre=ilen(prefix) - if (npdb.lt.1000) then - call numstr(npdb,zahl) - open(ipdb,file=prefix(:lenpre)//'@@'//zahl//'.pdb') - else - if (npdb.lt.10000) then - write(liczba5,'(i1,i4)') 0,npdb - else - write(liczba5,'(i5)') npdb - endif - open(ipdb,file=prefix(:lenpre)//'@@'//liczba5//'.pdb') - endif - call pdbout(ee,titelloc1,ipdb) - close(ipdb) - return - end - -c----------------------------------------------------------- - subroutine contact_cp2(var,var2,iff,ieval,in_pdb) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.MINIM' - - character*50 linia - integer nf,ij(4) - double precision var(maxvar),var2(maxvar) - double precision time0,time1 - integer iff(maxres),ieval - double precision theta1(maxres),phi1(maxres),alph1(maxres), - & omeg1(maxres) - - - call var_to_geom(nvar,var) - call chainbuild - nhpb0=nhpb - ind=0 - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if ( iff(i).eq.1.and.iff(j).eq.1 ) then - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - w(ind)=0.0 - endif - enddo - enddo - call hpb_partition - - do i=1,nres - theta1(i)=theta(i) - phi1(i)=phi(i) - alph1(i)=alph(i) - omeg1(i)=omeg(i) - enddo - - call var_to_geom(nvar,var2) - - do i=1,nres - if ( iff(i).eq.1 ) then - theta(i)=theta1(i) - phi(i)=phi1(i) - alph(i)=alph1(i) - omeg(i)=omeg1(i) - endif - enddo - - call chainbuild -cd call write_pdb(3,'combined structure',0d0) -cd time0=MPI_WTIME() - - NX=NRES-3 - NY=((NRES-4)*(NRES-5))/2 - call distfit(.true.,200) - -cd time1=MPI_WTIME() -cd write (iout,'(a,f6.2,a)') ' Time for distfit ',time1-time0,' sec' - - ipot0=ipot - maxmin0=maxmin - maxfun0=maxfun - wstrain0=wstrain - - ipot=6 - maxmin=2000 - maxfun=5000 - call geom_to_var(nvar,var) -cd time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun - -cd time1=MPI_WTIME() -cd write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, -cd & nfun/(time1-time0),' SOFT eval/s' - call var_to_geom(nvar,var) - call chainbuild - - - iwsk=0 - nf=0 - if (iff(1).eq.1) then - iwsk=1 - nf=nf+1 - ij(nf)=0 - endif - do i=2,nres - if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then - iwsk=1 - nf=nf+1 - ij(nf)=i - endif - if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then - iwsk=0 - nf=nf+1 - ij(nf)=i-1 - endif - enddo - if (iff(nres).eq.1) then - nf=nf+1 - ij(nf)=nres - endif - - -cd write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') -cd & "select",ij(1),"-",ij(2), -cd & ",",ij(3),"-",ij(4) -cd call write_pdb(in_pdb,linia,etot) - - - ipot=ipot0 - maxmin=maxmin0 - maxfun=maxfun0 -cd time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) -cd write(iout,*)'SUMSL DIST return code is',iretcode,' eval ',nfun - ieval=nfun - -cd time1=MPI_WTIME() -cd write (iout,'(a,f6.2,f8.2,a)')' Time for DIST min.',time1-time0, -cd & nfun/(time1-time0),' eval/s' -cd call var_to_geom(nvar,var) -cd call chainbuild -cd call write_pdb(6,'dist structure',etot) - - - nhpb= nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - - return - end -c----------------------------------------------------------- - subroutine contact_cp(var,var2,iff,ieval,in_pdb) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.MINIM' - - character*50 linia - integer nf,ij(4) - double precision energy(0:n_ene) - double precision var(maxvar),var2(maxvar) - double precision time0,time1 - integer iff(maxres),ieval - double precision theta1(maxres),phi1(maxres),alph1(maxres), - & omeg1(maxres) - logical debug - - debug=.false. -c debug=.true. - if (ieval.eq.-1) debug=.true. - - -c -c store selected dist. constrains from 1st structure -c -#ifdef OSF -c Intercept NaNs in the coordinates -c write(iout,*) (var(i),i=1,nvar) - x_sum=0.D0 - do i=1,nvar - x_sum=x_sum+var(i) - enddo - if (x_sum.ne.x_sum) then - write(iout,*)" *** contact_cp : Found NaN in coordinates" - call flush(iout) - print *," *** contact_cp : Found NaN in coordinates" - return - endif -#endif - - - call var_to_geom(nvar,var) - call chainbuild - nhpb0=nhpb - ind=0 - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if ( iff(i).eq.1.and.iff(j).eq.1 ) then - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - w(ind)=0.0 - endif - enddo - enddo - call hpb_partition - - do i=1,nres - theta1(i)=theta(i) - phi1(i)=phi(i) - alph1(i)=alph(i) - omeg1(i)=omeg(i) - enddo - -c -c freeze sec.elements from 2nd structure -c - do i=1,nres - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - enddo - - call var_to_geom(nvar,var2) - call secondary2(debug) - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - enddo - mask_r=.true. - -c -c copy selected res from 1st to 2nd structure -c - - do i=1,nres - if ( iff(i).eq.1 ) then - theta(i)=theta1(i) - phi(i)=phi1(i) - alph(i)=alph1(i) - omeg(i)=omeg1(i) - endif - enddo - - if(debug) then -c -c prepare description in linia variable -c - iwsk=0 - nf=0 - if (iff(1).eq.1) then - iwsk=1 - nf=nf+1 - ij(nf)=1 - endif - do i=2,nres - if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then - iwsk=1 - nf=nf+1 - ij(nf)=i - endif - if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then - iwsk=0 - nf=nf+1 - ij(nf)=i-1 - endif - enddo - if (iff(nres).eq.1) then - nf=nf+1 - ij(nf)=nres - endif - - write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') - & "SELECT",ij(1)-1,"-",ij(2)-1, - & ",",ij(3)-1,"-",ij(4)-1 - - endif -c -c run optimization -c - call contact_cp_min(var,ieval,in_pdb,linia,debug) - - return - end - - subroutine contact_cp_min(var,ieval,in_pdb,linia,debug) -c -c input : theta,phi,alph,omeg,in_pdb,linia,debug -c output : var,ieval -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.MINIM' - - character*50 linia - integer nf,ij(4) - double precision energy(0:n_ene) - double precision var(maxvar) - double precision time0,time1 - integer ieval,info(3) - logical debug,fail,check_var,reduce,change - - write(iout,'(a20,i6,a20)') - & '------------------',in_pdb,'-------------------' - - if (debug) then - call chainbuild - call write_pdb(1000+in_pdb,'combined structure',0d0) - time0=MPI_WTIME() - endif - -c -c run optimization of distances -c -c uses d0(),w() and mask() for frozen 2D -c -ctest--------------------------------------------- -ctest NX=NRES-3 -ctest NY=((NRES-4)*(NRES-5))/2 -ctest call distfit(debug,5000) - - do i=1,nres - mask_side(i)=0 - enddo - - ipot01=ipot - maxmin01=maxmin - maxfun01=maxfun -c wstrain01=wstrain - wsc01=wsc - wscp01=wscp - welec01=welec - wvdwpp01=wvdwpp -c wang01=wang - wscloc01=wscloc - wtor01=wtor - wtor_d01=wtor_d - - ipot=6 - maxmin=2000 - maxfun=4000 -c wstrain=1.0 - wsc=0.0 - wscp=0.0 - welec=0.0 - wvdwpp=0.0 -c wang=0.0 - wscloc=0.0 - wtor=0.0 - wtor_d=0.0 - - call geom_to_var(nvar,var) -cde change=reduce(var) - if (check_var(var,info)) then - write(iout,*) 'cp_min error in input' - print *,'cp_min error in input' - return - endif - -cd call etotal(energy(0)) -cd call enerprint(energy(0)) -cd call check_eint - - time0=MPI_WTIME() -cdtest call minimize(etot,var,iretcode,nfun) -cdtest write(iout,*)'SUMSL return code is',iretcode,' eval SDIST',nfun - time1=MPI_WTIME() - -cd call etotal(energy(0)) -cd call enerprint(energy(0)) -cd call check_eint - - do i=1,nres - mask_side(i)=1 - enddo - - ipot=ipot01 - maxmin=maxmin01 - maxfun=maxfun01 -c wstrain=wstrain01 - wsc=wsc01 - wscp=wscp01 - welec=welec01 - wvdwpp=wvdwpp01 -c wang=wang01 - wscloc=wscloc01 - wtor=wtor01 - wtor_d=wtor_d01 -ctest-------------------------------------------------- - - if(debug) then - time1=MPI_WTIME() - write (iout,'(a,f6.2,a)')' Time for distfit ',time1-time0,' sec' - call write_pdb(2000+in_pdb,'distfit structure',0d0) - endif - - - ipot0=ipot - maxmin0=maxmin - maxfun0=maxfun - wstrain0=wstrain -c -c run soft pot. optimization -c with constrains: -c nhpb,ihpb(),jhpb(),forcon(),dhpb() and hpb_partition -c and frozen 2D: -c mask_phi(),mask_theta(),mask_side(),mask_r -c - ipot=6 - maxmin=2000 - maxfun=4000 - -cde change=reduce(var) -cde if (check_var(var,info)) write(iout,*) 'error before soft' - time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - - write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun - time1=MPI_WTIME() - write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, - & nfun/(time1-time0),' SOFT eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(3000+in_pdb,'soft structure',etot) - endif -c -c run full UNRES optimization with constrains and frozen 2D -c the same variables as soft pot. optimizatio -c - ipot=ipot0 - maxmin=maxmin0 - maxfun=maxfun0 -c -c check overlaps before calling full UNRES minim -c - call var_to_geom(nvar,var) - call chainbuild - call etotal(energy(0)) -#ifdef OSF - write(iout,*) 'N7 ',energy(0) - if (energy(0).ne.energy(0)) then - write(iout,*) 'N7 error - gives NaN',energy(0) - endif -#endif - ieval=1 - if (energy(1).eq.1.0d20) then - write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw=1d20',energy(1) - call overlap_sc(fail) - if(.not.fail) then - call etotal(energy(0)) - ieval=ieval+1 - write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw after',energy(1) - else - mask_r=.false. - nhpb= nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - return - endif - endif - call flush(iout) -c -cdte time0=MPI_WTIME() -cde change=reduce(var) -cde if (check_var(var,info)) then -cde write(iout,*) 'error before mask dist' -cde call var_to_geom(nvar,var) -cde call chainbuild -cde call write_pdb(10000+in_pdb,'before mask dist',etot) -cde endif -cdte call minimize(etot,var,iretcode,nfun) -cdte write(iout,*)'SUMSL MASK DIST return code is',iretcode, -cdte & ' eval ',nfun -cdte ieval=ieval+nfun -cdte -cdte time1=MPI_WTIME() -cdte write (iout,'(a,f6.2,f8.2,a)') -cdte & ' Time for mask dist min.',time1-time0, -cdte & nfun/(time1-time0),' eval/s' -cdte call flush(iout) - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(4000+in_pdb,'mask dist',etot) - endif -c -c switch off freezing of 2D and -c run full UNRES optimization with constrains -c - mask_r=.false. - time0=MPI_WTIME() -cde change=reduce(var) -cde if (check_var(var,info)) then -cde write(iout,*) 'error before dist' -cde call var_to_geom(nvar,var) -cde call chainbuild -cde call write_pdb(11000+in_pdb,'before dist',etot) -cde endif - - call minimize(etot,var,iretcode,nfun) - -cde change=reduce(var) -cde if (check_var(var,info)) then -cde write(iout,*) 'error after dist',ico -cde call var_to_geom(nvar,var) -cde call chainbuild -cde call write_pdb(12000+in_pdb+ico*1000,'after dist',etot) -cde endif - write(iout,*)'SUMSL DIST return code is',iretcode,' eval ',nfun - ieval=ieval+nfun - - time1=MPI_WTIME() - write (iout,'(a,f6.2,f8.2,a)')' Time for dist min.',time1-time0, - & nfun/(time1-time0),' eval/s' -cde call etotal(energy(0)) -cde write(iout,*) 'N7 after dist',energy(0) - call flush(iout) - - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(in_pdb,linia,etot) - endif -c -c reset constrains -c - nhpb= nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - - return - end -c-------------------------------------------------------- - subroutine softreg - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.INTERACT' -c - include 'COMMON.DISTFIT' - integer iff(maxres) - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar) - integer ieval -c - logical debug,ltest,fail - character*50 linia -c - linia='test' - debug=.true. - in_pdb=0 - - - -c------------------------ -c -c freeze sec.elements -c - do i=1,nres - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - iff(i)=0 - enddo - - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - enddo - mask_r=.true. - - - - nhpb0=nhpb -c -c store dist. constrains -c - do i=1,nres-3 - do j=i+3,nres - if ( iff(i).eq.1.and.iff(j).eq.1 ) then - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=0.1 - dhpb(nhpb)=DIST(i,j) - endif - enddo - enddo - call hpb_partition - - if (debug) then - call chainbuild - call write_pdb(100+in_pdb,'input reg. structure',0d0) - endif - - - ipot0=ipot - maxmin0=maxmin - maxfun0=maxfun - wstrain0=wstrain - wang0=wang -c -c run soft pot. optimization -c - ipot=6 - wang=3.0 - maxmin=2000 - maxfun=4000 - call geom_to_var(nvar,var) - time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - - write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun - time1=MPI_WTIME() - write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, - & nfun/(time1-time0),' SOFT eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(300+in_pdb,'soft structure',etot) - endif -c -c run full UNRES optimization with constrains and frozen 2D -c the same variables as soft pot. optimizatio -c - ipot=ipot0 - wang=wang0 - maxmin=maxmin0 - maxfun=maxfun0 - time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL MASK DIST return code is',iretcode, - & ' eval ',nfun - ieval=nfun - - time1=MPI_WTIME() - write (iout,'(a,f6.2,f8.2,a)') - & ' Time for mask dist min.',time1-time0, - & nfun/(time1-time0),' eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(400+in_pdb,'mask & dist',etot) - endif -c -c switch off constrains and -c run full UNRES optimization with frozen 2D -c - -c -c reset constrains -c - nhpb_c=nhpb - nhpb=nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - - - time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL MASK return code is',iretcode,' eval ',nfun - ieval=ieval+nfun - - time1=MPI_WTIME() - write (iout,'(a,f6.2,f8.2,a)')' Time for mask min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(500+in_pdb,'mask 2d frozen',etot) - endif - - mask_r=.false. - - -c -c run full UNRES optimization with constrains and NO frozen 2D -c - - nhpb=nhpb_c - link_start=1 - link_end=nhpb - maxfun=maxfun0/5 - - do ico=1,5 - - wstrain=wstrain0/ico - - time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,'(a10,f6.3,a14,i3,a6,i5)') - & ' SUMSL DIST',wstrain,' return code is',iretcode, - & ' eval ',nfun - ieval=nfun - - time1=MPI_WTIME() - write (iout,'(a,f6.2,f8.2,a)') - & ' Time for dist min.',time1-time0, - & nfun/(time1-time0),' eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(600+in_pdb+ico,'dist cons',etot) - endif - - enddo -c - nhpb=nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - maxfun=maxfun0 - - -c - if (minim) then - time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, - & '+ DIST eval',ieval - - time1=MPI_WTIME() - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(999,'full min',etot) - endif - - return - end - - - subroutine beta_slide(i1,i2,i3,i4,i5,ieval,ij) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.CHAIN' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar) - integer jdata(5),isec(maxres) -c - jdata(1)=i1 - jdata(2)=i2 - jdata(3)=i3 - jdata(4)=i4 - jdata(5)=i5 - - call secondary2(.false.) - - do i=1,nres - isec(i)=0 - enddo - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - isec(i)=1 - enddo - do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j)) - isec(i)=1 - enddo - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - isec(i)=2 - enddo - enddo - -c -c cut strands at the ends -c - if (jdata(2)-jdata(1).gt.3) then - jdata(1)=jdata(1)+1 - jdata(2)=jdata(2)-1 - if (jdata(3).lt.jdata(4)) then - jdata(3)=jdata(3)+1 - jdata(4)=jdata(4)-1 - else - jdata(3)=jdata(3)-1 - jdata(4)=jdata(4)+1 - endif - endif - -cv call chainbuild -cv call etotal(energy(0)) -cv etot=energy(0) -cv write(iout,*) nnt,nct,etot -cv call write_pdb(ij*100,'first structure',etot) -cv write(iout,*) 'N16 test',(jdata(i),i=1,5) - -c------------------------ -c generate constrains -c - ishift=jdata(5)-2 - if(ishift.eq.0) ishift=-2 - nhpb0=nhpb - call chainbuild - do i=jdata(1),jdata(2) - isec(i)=-1 - if(jdata(4).gt.jdata(3))then - do j=jdata(3)+i-jdata(1)-2,jdata(3)+i-jdata(1)+2 - isec(j)=-1 -cd print *,i,j,j+ishift - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=1000.0 - dhpb(nhpb)=DIST(i,j+ishift) - enddo - else - do j=jdata(3)-i+jdata(1)+2,jdata(3)-i+jdata(1)-2,-1 - isec(j)=-1 -cd print *,i,j,j+ishift - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=1000.0 - dhpb(nhpb)=DIST(i,j+ishift) - enddo - endif - enddo - - do i=nnt,nct-2 - do j=i+2,nct - if(isec(i).gt.0.or.isec(j).gt.0) then -cd print *,i,j - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=0.1 - dhpb(nhpb)=DIST(i,j) - endif - enddo - enddo - - call hpb_partition - - call geom_to_var(nvar,var) - maxfun0=maxfun - wstrain0=wstrain - maxfun=4000/5 - - do ico=1,5 - - wstrain=wstrain0/ico - -cv time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,'(a10,f6.3,a14,i3,a6,i5)') - & ' SUMSL DIST',wstrain,' return code is',iretcode, - & ' eval ',nfun - ieval=ieval+nfun -cv time1=MPI_WTIME() -cv write (iout,'(a,f6.2,f8.2,a)') -cv & ' Time for dist min.',time1-time0, -cv & nfun/(time1-time0),' eval/s' -cv call var_to_geom(nvar,var) -cv call chainbuild -cv call write_pdb(ij*100+ico,'dist cons',etot) - - enddo -c - nhpb=nhpb0 - call hpb_partition - wstrain=wstrain0 - maxfun=maxfun0 -c -cd print *,etot - wscloc0=wscloc - wscloc=10.0 - call sc_move(nnt,nct,100,100d0,nft_sc,etot) - wscloc=wscloc0 -cv call chainbuild -cv call etotal(energy(0)) -cv etot=energy(0) -cv call write_pdb(ij*100+10,'sc_move',etot) -cd call intout -cd print *,nft_sc,etot - - return - end - - subroutine beta_zip(i1,i2,ieval,ij) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.CHAIN' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar) - character*10 test - -cv call chainbuild -cv call etotal(energy(0)) -cv etot=energy(0) -cv write(test,'(2i5)') i1,i2 -cv call write_pdb(ij*100,test,etot) -cv write(iout,*) 'N17 test',i1,i2,etot,ij - -c -c generate constrains -c - nhpb0=nhpb - nhpb=nhpb+1 - ihpb(nhpb)=i1 - jhpb(nhpb)=i2 - forcon(nhpb)=1000.0 - dhpb(nhpb)=4.0 - - call hpb_partition - - call geom_to_var(nvar,var) - maxfun0=maxfun - wstrain0=wstrain - maxfun=1000/5 - - do ico=1,5 - wstrain=wstrain0/ico -cv time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,'(a10,f6.3,a14,i3,a6,i5)') - & ' SUMSL DIST',wstrain,' return code is',iretcode, - & ' eval ',nfun - ieval=ieval+nfun -cv time1=MPI_WTIME() -cv write (iout,'(a,f6.2,f8.2,a)') -cv & ' Time for dist min.',time1-time0, -cv & nfun/(time1-time0),' eval/s' -c do not comment the next line - call var_to_geom(nvar,var) -cv call chainbuild -cv call write_pdb(ij*100+ico,'dist cons',etot) - enddo - - nhpb=nhpb0 - call hpb_partition - wstrain=wstrain0 - maxfun=maxfun0 - -cv call etotal(energy(0)) -cv etot=energy(0) -cv write(iout,*) 'N17 test end',i1,i2,etot,ij - - - return - end diff --git a/source/unres/src_MD-M-newcorr/thread.F b/source/unres/src_MD-M-newcorr/thread.F deleted file mode 100644 index f713744..0000000 --- a/source/unres/src_MD-M-newcorr/thread.F +++ /dev/null @@ -1,549 +0,0 @@ - subroutine thread_seq -C Thread the sequence through a database of known structures - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.DBASE' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.THREAD' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.CONTACTS' - include 'COMMON.MCM' - include 'COMMON.NAMES' -#ifdef MPI - include 'COMMON.INFO' - integer ThreadId,ThreadType,Kwita -#endif - double precision varia(maxvar) - double precision przes(3),obr(3,3) - double precision time_for_thread - logical found_pattern,non_conv - character*32 head_pdb - double precision energia(0:n_ene) - n_ene_comp=nprint_ene -C -C Body -C -#ifdef MPI - if (me.eq.king) then - do i=1,nctasks - nsave_part(i)=0 - enddo - endif - nacc_tot=0 -#endif - Kwita=0 - close(igeom) - close(ipdb) - close(istat) - do i=1,maxthread - do j=1,14 - ener0(j,i)=0.0D0 - ener(j,i)=0.0D0 - enddo - enddo - nres0=nct-nnt+1 - ave_time_for_thread=0.0D0 - max_time_for_thread=0.0D0 -cd print *,'nthread=',nthread,' nseq=',nseq,' nres0=',nres0 - nthread=nexcl+nthread - do ithread=1,nthread - found_pattern=.false. - itrial=0 - do while (.not.found_pattern) - itrial=itrial+1 - if (itrial.gt.1000) then - write (iout,'(/a/)') 'Too many attempts to find pattern.' - nthread=ithread-1 -#ifdef MPI - call recv_stop_sig(Kwita) - call send_stop_sig(-3) -#endif - goto 777 - endif -C Find long enough chain in the database - ii=iran_num(1,nseq) - nres_t=nres_base(1,ii) -C Select the starting position to thread. - print *,'nseq',nseq,' ii=',ii,' nres_t=', - & nres_t,' nres0=',nres0 - if (nres_t.ge.nres0) then - ist=iran_num(0,nres_t-nres0) -#ifdef MPI - if (Kwita.eq.0) call recv_stop_sig(Kwita) - if (Kwita.lt.0) then - write (iout,*) 'Stop signal received. Terminating.' - write (*,*) 'Stop signal received. Terminating.' - nthread=ithread-1 - write (*,*) 'ithread=',ithread,' nthread=',nthread - goto 777 - endif - call pattern_receive -#endif - do i=1,nexcl - if (iexam(1,i).eq.ii .and. iexam(2,i).eq.ist) goto 10 - enddo - found_pattern=.true. - endif -C If this point is reached, the pattern has not yet been examined. - 10 continue -c print *,'found_pattern:',found_pattern - enddo - nexcl=nexcl+1 - iexam(1,nexcl)=ii - iexam(2,nexcl)=ist -#ifdef MPI - if (Kwita.eq.0) call recv_stop_sig(Kwita) - if (Kwita.lt.0) then - write (iout,*) 'Stop signal received. Terminating.' - nthread=ithread-1 - write (*,*) 'ithread=',ithread,' nthread=',nthread - goto 777 - endif - call pattern_send -#endif - ipatt(1,ithread)=ii - ipatt(2,ithread)=ist -#ifdef MPI - write (iout,'(/80(1h*)/a,i4,a,i5,2a,i3,a,i3,a,i3/)') - & 'Processor:',me,' Attempt:',ithread, - & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii), - & ' start at res.',ist+1 - write (*,'(a,i4,a,i5,2a,i3,a,i3,a,i3)') 'Processor:',me, - & ' Attempt:',ithread, - & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii), - & ' start at res.',ist+1 -#else - write (iout,'(/80(1h*)/a,i5,2a,i3,a,i3,a,i3/)') - & 'Attempt:',ithread, - & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii), - & ' start at res.',ist+1 - write (*,'(a,i5,2a,i3,a,i3,a,i3)') - & 'Attempt:',ithread, - & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii), - & ' start at res.',ist+1 -#endif - ipattern=ii -C Copy coordinates from the database. - ist=ist-(nnt-1) - do i=nnt,nct - do j=1,3 - c(j,i)=cart_base(j,i+ist,ii) -c cref(j,i)=c(j,i) - enddo -cd write (iout,'(a,i4,3f10.5)') restyp(itype(i)),i,(c(j,i),j=1,3) - enddo -cd call fitsq(rms,c(1,nnt),cref(1,nnt),nct-nnt+1,przes,obr, -cd non_conv) -cd write (iout,'(a,f10.5)') -cd & 'Initial RMS deviation from reference structure:',rms - if (itype(nres).eq.ntyp1) then - do j=1,3 - dcj=c(j,nres-2)-c(j,nres-3) - c(j,nres)=c(j,nres-1)+dcj - c(j,2*nres)=c(j,nres) - enddo - endif - if (itype(1).eq.ntyp1) then - do j=1,3 - dcj=c(j,4)-c(j,3) - c(j,1)=c(j,2)-dcj - c(j,nres+1)=c(j,1) - enddo - endif - call int_from_cart(.false.,.false.) -cd print *,'Exit INT_FROM_CART.' -cd print *,'nhpb=',nhpb - do i=nss+1,nhpb - ii=ihpb(i) - jj=jhpb(i) - dhpb(i)=dist(ii,jj) -c write (iout,'(2i5,2f10.5)') ihpb(i),jhpb(i),dhpb(i),forcon(i) - enddo -c stop 'End generate' -C Generate SC conformations. - call sc_conf -c call intout -#ifdef MPI -cd print *,'Processor:',me,': exit GEN_SIDE.' -#else -cd print *,'Exit GEN_SIDE.' -#endif -C Calculate initial energy. - call chainbuild - call etotal(energia(0)) - etot=energia(0) - do i=1,n_ene_comp - ener0(i,ithread)=energia(i) - enddo - ener0(n_ene_comp+1,ithread)=energia(0) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - ener0(n_ene_comp+3,ithread)=contact_fract(ncont,ncont_ref, - & icont,icont_ref) - ener0(n_ene_comp+2,ithread)=rms - ener0(n_ene_comp+4,ithread)=frac - ener0(n_ene_comp+5,ithread)=frac_nn - endif - ener0(n_ene_comp+3,ithread)=0.0d0 -C Minimize energy. -#ifdef MPI - print*,'Processor:',me,' ithread=',ithread,' Start REGULARIZE.' -#else - print*,'ithread=',ithread,' Start REGULARIZE.' -#endif - curr_tim=tcpu() - call regularize(nct-nnt+1,etot,rms, - & cart_base(1,ist+nnt,ipattern),iretcode) - curr_tim1=tcpu() - time_for_thread=curr_tim1-curr_tim - ave_time_for_thread= - & ((ithread-1)*ave_time_for_thread+time_for_thread)/ithread - if (time_for_thread.gt.max_time_for_thread) - & max_time_for_thread=time_for_thread -#ifdef MPI - print *,'Processor',me,': Exit REGULARIZE.' - if (WhatsUp.eq.2) then - write (iout,*) - & 'Sufficient number of confs. collected. Terminating.' - nthread=ithread-1 - goto 777 - else if (WhatsUp.eq.-1) then - nthread=ithread-1 - write (iout,*) 'Time up in REGULARIZE. Call SEND_STOP_SIG.' - if (Kwita.eq.0) call recv_stop_sig(Kwita) - call send_stop_sig(-2) - goto 777 - else if (WhatsUp.eq.-2) then - nthread=ithread-1 - write (iout,*) 'Timeup signal received. Terminating.' - goto 777 - else if (WhatsUp.eq.-3) then - nthread=ithread-1 - write (iout,*) 'Error stop signal received. Terminating.' - goto 777 - endif -#else - print *,'Exit REGULARIZE.' - if (iretcode.eq.11) then - write (iout,'(/a/)') - &'******* Allocated time exceeded in SUMSL. The program will stop.' - nthread=ithread-1 - goto 777 - endif -#endif - head_pdb=titel(:24)//':'//str_nam(ipattern) - if (outpdb) call pdbout(etot,head_pdb,ipdb) - if (outmol2) call mol2out(etot,head_pdb) -c call intout - call briefout(ithread,etot) - link_end0=link_end - link_end=min0(link_end,nss) - write (iout,*) 'link_end=',link_end,' link_end0=',link_end0, - & ' nss=',nss - call etotal(energia(0)) -c call enerprint(energia(0)) - link_end=link_end0 -cd call chainbuild -cd call fitsq(rms,c(1,nnt),cref(1,nnt),nct-nnt+1,przes,obr,non_conv) -cd write (iout,'(a,f10.5)') -cd & 'RMS deviation from reference structure:',dsqrt(rms) - do i=1,n_ene_comp - ener(i,ithread)=energia(i) - enddo - ener(n_ene_comp+1,ithread)=energia(0) - ener(n_ene_comp+3,ithread)=rms - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - ener(n_ene_comp+2,ithread)=rms - ener(n_ene_comp+4,ithread)=frac - ener(n_ene_comp+5,ithread)=frac_nn - endif - call write_stat_thread(ithread,ipattern,ist) -c write (istat,'(i4,2x,a8,i4,11(1pe14.5),2(0pf8.3),f8.5)') -c & ithread,str_nam(ipattern),ist+1,(ener(k,ithread),k=1,11), -c & (ener(k,ithread),k=12,14) -#ifdef MPI - if (me.eq.king) then - nacc_tot=nacc_tot+1 - call pattern_receive - call receive_MCM_info - if (nacc_tot.ge.nthread) then - write (iout,*) - & 'Sufficient number of conformations collected nacc_tot=', - & nacc_tot,'. Stopping other processors and terminating.' - write (*,*) - & 'Sufficient number of conformations collected nacc_tot=', - & nacc_tot,'. Stopping other processors and terminating.' - call recv_stop_sig(Kwita) - if (Kwita.eq.0) call send_stop_sig(-1) - nthread=ithread - goto 777 - endif - else - call send_MCM_info(2) - endif -#endif - if (timlim-curr_tim1-safety .lt. max_time_for_thread) then - write (iout,'(/2a)') - & '********** There would be not enough time for another thread. ', - & 'The program will stop.' - write (*,'(/2a)') - & '********** There would be not enough time for another thread. ', - & 'The program will stop.' - write (iout,'(a,1pe14.4/)') - & 'Elapsed time for last threading step: ',time_for_thread - nthread=ithread -#ifdef MPI - call recv_stop_sig(Kwita) - call send_stop_sig(-2) -#endif - goto 777 - else - curr_tim=curr_tim1 - write (iout,'(a,1pe14.4)') - & 'Elapsed time for this threading step: ',time_for_thread - endif -#ifdef MPI - if (Kwita.eq.0) call recv_stop_sig(Kwita) - if (Kwita.lt.0) then - write (iout,*) 'Stop signal received. Terminating.' - write (*,*) 'Stop signal received. Terminating.' - nthread=ithread - write (*,*) 'nthread=',nthread,' ithread=',ithread - goto 777 - endif -#endif - enddo -#ifdef MPI - call send_stop_sig(-1) -#endif - 777 continue -#ifdef MPI -C Any messages left for me? - call pattern_receive - if (Kwita.eq.0) call recv_stop_sig(Kwita) -#endif - call write_thread_summary -#ifdef MPI - if (king.eq.king) then - Kwita=1 - do while (Kwita.ne.0 .or. nacc_tot.ne.0) - Kwita=0 - nacc_tot=0 - call recv_stop_sig(Kwita) - call receive_MCM_info - enddo - do iproc=1,nprocs-1 - call receive_thread_results(iproc) - enddo - call write_thread_summary - else - call send_thread_results - endif -#endif - return - end -c-------------------------------------------------------------------------- - subroutine write_thread_summary -C Thread the sequence through a database of known structures - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.DBASE' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.THREAD' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' -#ifdef MPI - include 'COMMON.INFO' -#endif - dimension ip(maxthread) - double precision energia(0:n_ene) - write (iout,'(30x,a/)') - & ' *********** Summary threading statistics ************' - write (iout,'(a)') 'Initial energies:' - write (iout,'(a4,2x,a12,14a14,3a8)') - & 'No','seq',(ename(print_order(i)),i=1,nprint_ene),'ETOT', - & 'RMSnat','NatCONT','NNCONT','RMS' -C Energy sort patterns - do i=1,nthread - ip(i)=i - enddo - do i=1,nthread-1 - enet=ener(n_ene-1,ip(i)) - jj=i - do j=i+1,nthread - if (ener(n_ene-1,ip(j)).lt.enet) then - jj=j - enet=ener(n_ene-1,ip(j)) - endif - enddo - if (jj.ne.i) then - ipj=ip(jj) - ip(jj)=ip(i) - ip(i)=ipj - endif - enddo - do ik=1,nthread - i=ip(ik) - ii=ipatt(1,i) - ist=nres_base(2,ii)+ipatt(2,i) - do kk=1,n_ene_comp - energia(i)=ener0(kk,i) - enddo - etot=ener0(n_ene_comp+1,i) - rmsnat=ener0(n_ene_comp+2,i) - rms=ener0(n_ene_comp+3,i) - frac=ener0(n_ene_comp+4,i) - frac_nn=ener0(n_ene_comp+5,i) - - if (refstr) then - write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') - & i,str_nam(ii),ist+1, - & (energia(print_order(kk)),kk=1,nprint_ene), - & etot,rmsnat,frac,frac_nn,rms - else - write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3)') - & i,str_nam(ii),ist+1, - & (energia(print_order(kk)),kk=1,nprint_ene),etot - endif - enddo - write (iout,'(//a)') 'Final energies:' - write (iout,'(a4,2x,a12,17a14,3a8)') - & 'No','seq',(ename(print_order(kk)),kk=1,nprint_ene),'ETOT', - & 'RMSnat','NatCONT','NNCONT','RMS' - do ik=1,nthread - i=ip(ik) - ii=ipatt(1,i) - ist=nres_base(2,ii)+ipatt(2,i) - do kk=1,n_ene_comp - energia(kk)=ener(kk,ik) - enddo - etot=ener(n_ene_comp+1,i) - rmsnat=ener(n_ene_comp+2,i) - rms=ener(n_ene_comp+3,i) - frac=ener(n_ene_comp+4,i) - frac_nn=ener(n_ene_comp+5,i) - write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') - & i,str_nam(ii),ist+1, - & (energia(print_order(kk)),kk=1,nprint_ene), - & etot,rmsnat,frac,frac_nn,rms - enddo - write (iout,'(/a/)') 'IEXAM array:' - write (iout,'(i5)') nexcl - do i=1,nexcl - write (iout,'(2i5)') iexam(1,i),iexam(2,i) - enddo - write (iout,'(/a,1pe14.4/a,1pe14.4/)') - & 'Max. time for threading step ',max_time_for_thread, - & 'Average time for threading step: ',ave_time_for_thread - return - end -c---------------------------------------------------------------------------- - subroutine sc_conf -C Sample (hopefully) optimal SC orientations given backcone conformation. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DBASE' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.THREAD' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - double precision varia(maxvar) - common /srutu/ icall - double precision energia(0:n_ene) - logical glycine,fail - maxsample=10 - link_end0=link_end - link_end=min0(link_end,nss) - do i=nnt,nct - if (itype(i).ne.10) then -cd print *,'i=',i,' itype=',itype(i),' theta=',theta(i+1) - call gen_side(itype(i),theta(i+1),alph(i),omeg(i),fail) - endif - enddo - call chainbuild - call etotal(energia(0)) - do isample=1,maxsample -C Choose a non-glycine side chain. - glycine=.true. - do while(glycine) - ind_sc=iran_num(nnt,nct) - glycine=(itype(ind_sc).eq.10) - enddo - alph0=alph(ind_sc) - omeg0=omeg(ind_sc) - call gen_side(itype(ind_sc),theta(ind_sc+1),alph(ind_sc), - & omeg(ind_sc),fail) - call chainbuild - call etotal(energia(0)) -cd write (iout,'(a,i5,a,i4,2(a,f8.3),2(a,1pe14.5))') -cd & 'Step:',isample,' SC',ind_sc,' alpha',alph(ind_sc)*rad2deg, -cd & ' omega',omeg(ind_sc)*rad2deg,' old energy',e0,' new energy',e1 - e1=0.0d0 - if (e0.le.e1) then - alph(ind_sc)=alph0 - omeg(ind_sc)=omeg0 - else - e0=e1 - endif - enddo - link_end=link_end0 - return - end -c--------------------------------------------------------------------------- - subroutine write_stat_thread(ithread,ipattern,ist) - implicit real*8 (a-h,o-z) - include "DIMENSIONS" - include "COMMON.CONTROL" - include "COMMON.IOUNITS" - include "COMMON.THREAD" - include "COMMON.FFIELD" - include "COMMON.DBASE" - include "COMMON.NAMES" - double precision energia(0:n_ene) - -#if defined(AIX) || defined(PGI) - open(istat,file=statname,position='append') -#else - open(istat,file=statname,access='append') -#endif - do i=1,n_ene_comp - energia(i)=ener(i,ithread) - enddo - etot=ener(n_ene_comp+1,ithread) - rmsnat=ener(n_ene_comp+2,ithread) - rms=ener(n_ene_comp+3,ithread) - frac=ener(n_ene_comp+4,ithread) - frac_nn=ener(n_ene_comp+5,ithread) - write (istat,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') - & ithread,str_nam(ipattern),ist+1, - & (energia(print_order(i)),i=1,nprint_ene), - & etot,rmsnat,frac,frac_nn,rms - close (istat) - return - end diff --git a/source/unres/src_MD-M-newcorr/timing.F b/source/unres/src_MD-M-newcorr/timing.F deleted file mode 100644 index 838d2d7..0000000 --- a/source/unres/src_MD-M-newcorr/timing.F +++ /dev/null @@ -1,337 +0,0 @@ -C $Date: 1994/10/05 16:41:52 $ -C $Revision: 2.2 $ -C -C -C - subroutine set_timers -c - implicit none - double precision tcpu - include 'COMMON.TIME1' -#ifdef MP - include 'mpif.h' -#endif -C Diminish the assigned time limit a little so that there is some time to -C end a batch job -c timlim=batime-150.0 -C Calculate the initial time, if it is not zero (e.g. for the SUN). - stime=tcpu() -#ifdef MPI - walltime=MPI_WTIME() - time_reduce=0.0d0 - time_allreduce=0.0d0 - time_bcast=0.0d0 - time_gather=0.0d0 - time_sendrecv=0.0d0 - time_scatter=0.0d0 - time_scatter_fmat=0.0d0 - time_scatter_ginv=0.0d0 - time_scatter_fmatmult=0.0d0 - time_scatter_ginvmult=0.0d0 - time_barrier_e=0.0d0 - time_barrier_g=0.0d0 - time_enecalc=0.0d0 - time_sumene=0.0d0 - time_lagrangian=0.0d0 - time_sumgradient=0.0d0 - time_intcartderiv=0.0d0 - time_inttocart=0.0d0 - time_ginvmult=0.0d0 - time_fricmatmult=0.0d0 - time_cartgrad=0.0d0 - time_bcastc=0.0d0 - time_bcast7=0.0d0 - time_bcastw=0.0d0 - time_intfcart=0.0d0 - time_vec=0.0d0 - time_mat=0.0d0 - time_fric=0.0d0 - time_stoch=0.0d0 - time_fricmatmult=0.0d0 - time_fsample=0.0d0 -#endif -cd print *,' in SET_TIMERS stime=',stime - return - end -C------------------------------------------------------------------------------ - logical function stopx(nf) -C This function returns .true. if one of the following reasons to exit SUMSL -C occurs. The "reason" code is stored in WHATSUP passed thru a COMMON block: -C -C... WHATSUP = 0 - go on, no reason to stop. Stopx will return .false. -C... 1 - Time up in current node; -C... 2 - STOP signal was received from another node because the -C... node's task was accomplished (parallel only); -C... -1 - STOP signal was received from another node because of error; -C... -2 - STOP signal was received from another node, because -C... the node's time was up. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - integer nf - logical ovrtim -#ifdef MP - include 'mpif.h' - include 'COMMON.INFO' -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - integer Kwita - -cd print *,'Processor',MyID,' NF=',nf -#ifndef MPI - if (ovrtim()) then -C Finish if time is up. - stopx = .true. - WhatsUp=1 -#ifdef MPL - else if (mod(nf,100).eq.0) then -C Other processors might have finished. Check this every 100th function -C evaluation. -C Master checks if any other processor has sent accepted conformation(s) to it. - if (MyID.ne.MasterID) call receive_mcm_info - if (MyID.eq.MasterID) call receive_conf -cd print *,'Processor ',MyID,' is checking STOP: nf=',nf - call recv_stop_sig(Kwita) - if (Kwita.eq.-1) then - write (iout,'(a,i4,a,i5)') 'Processor', - & MyID,' has received STOP signal in STOPX; NF=',nf - write (*,'(a,i4,a,i5)') 'Processor', - & MyID,' has received STOP signal in STOPX; NF=',nf - stopx=.true. - WhatsUp=2 - elseif (Kwita.eq.-2) then - write (iout,*) - & 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.' - write (*,*) - & 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.' - WhatsUp=-2 - stopx=.true. - else if (Kwita.eq.-3) then - write (iout,*) - & 'Processor',MyID,' received ERROR-STOP signal in SUMSL.' - write (*,*) - & 'Processor',MyID,' received ERROR-STOP signal in SUMSL.' - WhatsUp=-1 - stopx=.true. - else - stopx=.false. - WhatsUp=0 - endif -#endif - else - stopx = .false. - WhatsUp=0 - endif -#else - stopx=.false. -#endif - -#ifdef OSF -c Check for FOUND_NAN flag - if (FOUND_NAN) then - write(iout,*)" *** stopx : Found a NaN" - stopx=.true. - endif -#endif - - return - end -C-------------------------------------------------------------------------- - logical function ovrtim() - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - 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 -C--------------------------------------------------------------------------- - subroutine print_detailed_timing - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.SETUP' - time1=MPI_WTIME() - write (iout,'(80(1h=)/a/(80(1h=)))') - & "Details of FG communication time" - write (*,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))') - & "BROADCAST:",time_bcast,"REDUCE:",time_reduce, - & "GATHER:",time_gather, - & "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv, - & "BARRIER ene",time_barrier_e, - & "BARRIER grad",time_barrier_g, - & "TOTAL:", - & time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv - write (*,*) fg_rank,myrank, - & ': Total wall clock time',time1-walltime,' sec' - write (*,*) "Processor",fg_rank,myrank, - & ": BROADCAST time",time_bcast," REDUCE time", - & time_reduce," GATHER time",time_gather," SCATTER time", - & time_scatter, - & " SCATTER fmatmult",time_scatter_fmatmult, - & " SCATTER ginvmult",time_scatter_ginvmult, - & " SCATTER fmat",time_scatter_fmat, - & " SCATTER ginv",time_scatter_ginv, - & " SENDRECV",time_sendrecv, - & " BARRIER ene",time_barrier_e, - & " BARRIER GRAD",time_barrier_g, - & " BCAST7",time_bcast7," BCASTC",time_bcastc, - & " BCASTW",time_bcastw," ALLREDUCE",time_allreduce, - & " TOTAL", - & time_bcast+time_reduce+time_gather+time_scatter+ - & time_sendrecv+time_barrier+time_bcastc - write (*,*) "Processor",fg_rank,myrank," enecalc",time_enecalc - write (*,*) "Processor",fg_rank,myrank," sumene",time_sumene - write (*,*) "Processor",fg_rank,myrank," intfromcart", - & time_intfcart - write (*,*) "Processor",fg_rank,myrank," vecandderiv", - & time_vec - write (*,*) "Processor",fg_rank,myrank," setmatrices", - & time_mat - write (*,*) "Processor",fg_rank,myrank," ginvmult", - & time_ginvmult - write (*,*) "Processor",fg_rank,myrank," fricmatmult", - & time_fricmatmult - write (*,*) "Processor",fg_rank,myrank," inttocart", - & time_inttocart - write (*,*) "Processor",fg_rank,myrank," sumgradient", - & time_sumgradient - write (*,*) "Processor",fg_rank,myrank," intcartderiv", - & time_intcartderiv - if (fg_rank.eq.0) then - write (*,*) "Processor",fg_rank,myrank," lagrangian", - & time_lagrangian - write (*,*) "Processor",fg_rank,myrank," cartgrad", - & time_cartgrad - endif - return - end diff --git a/source/unres/src_MD-M-newcorr/together.F b/source/unres/src_MD-M-newcorr/together.F deleted file mode 100644 index b0e0997..0000000 --- a/source/unres/src_MD-M-newcorr/together.F +++ /dev/null @@ -1,1222 +0,0 @@ - Subroutine together -c feeds tasks for parallel processing - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - real ran1,ran2 - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.TIME1' - include 'COMMON.SETUP' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - real tcpu - double precision time_start,time_start_c,time0f,time0i - logical ovrtim,sync_iter,timeout,flag,timeout1 - dimension muster(mpi_status_size) - dimension t100(0:100),indx(mxio) - dimension xout(maxvar),eout(mxch*(mxch+1)/2+1),ind(9) - dimension cout(2) - parameter (rad=1.745329252d-2) - -cccccccccccccccccccccccccccccccccccccccccccccccc - IF (ME.EQ.KING) THEN - - time0f=MPI_WTIME() - ilastnstep=1 - sync_iter=.false. - numch=1 - nrmsdb=0 - nrmsdb1=0 - rmsdbc1c=rmsdbc1 - nstep=0 - call csa_read - call make_array - - if(iref.ne.0) call from_int(1,0,idum) - -c To minimize input conformation (bank conformation) -c Output to $mol.reminimized - if (irestart.lt.0) then - call read_bank(0,nft,cutdifr) - if (irestart.lt.-10) then - p_cut=nres*4.d0 - call prune_bank(p_cut) - return - endif - call reminimize(jlee) - return - endif - - if (irestart.eq.0) then - call initial_write - nbank=nconf - ntbank=nconf - if (ntbankm.eq.0) ntbank=0 - nstep=0 - nft=0 - do i=1,mxio - ibank(i)=0 - jbank(i)=0 - enddo - else - call restart_write -c!bankt call read_bankt(jlee,nft,cutdifr) - call read_bank(jlee,nft,cutdifr) - call read_rbank(jlee,adif) - if(iref.ne.0) call from_int(1,0,idum) - endif - - nstmax=nstmax+nstep - ntrial=n1+n2+n3+n4+n5+n6+n7+n8 - ntry=ntrial+1 - ntry=ntry*nseed - -c ntrial : number of trial conformations per seed. -c ntry : total number of trial conformations including seed conformations. - - idum2=-123 -c imax=2**31-1 - imax=huge(0) - ENDIF - - call mpi_bcast(jend,1,mpi_integer,0,CG_COMM,ierr) -cccccccccccccccccccccccccccccccccccccccc - do 300 jlee=1,jend -cccccccccccccccccccccccccccccccccccccccc - 331 continue - IF (ME.EQ.KING) THEN - if(sync_iter) goto 333 - idum=- ran2(idum2)*imax - if(jlee.lt.jstart) goto 300 - -C Restart the random number generator for conformation generation - - if(irestart.gt.0) then - idum2=idum2+nstep - if(idum2.le.0) idum2=-idum2+1 - idum=- ran2(idum2)*imax - endif - - idumm=idum - call vrndst(idumm) - - open(icsa_seed,file=csa_seed,status="old") - write(icsa_seed,*) "jlee : ",jlee - close(icsa_seed) - - call history_append - write(icsa_history,*) "number of procs is ",nodes - write(icsa_history,*) jlee,idum,idum2 - close(icsa_history) - -cccccccccccccccccccccccccccccccccccccccccccccccc - 333 icycle=0 - - call history_append - write(icsa_history,*) "nbank is ",nbank - close(icsa_history) - - if(irestart.eq.1) goto 111 - if(irestart.eq.2) then - icycle=0 - do i=1,nbank - ibank(i)=1 - enddo - do i=nbank+1,nbank+nconf - ibank(i)=0 - enddo - endif - -c start energy minimization - nconfr=max0(nconf+nadd,nodes-1) - if (sync_iter) nconf_in=0 -c king-emperor - feed input and sort output - write (iout,*) "NCONF_IN",nconf_in - m=0 - if (nconf_in.gt.0) then -c al 7/2/00 - added possibility to read in some of the initial conformations - do m=1,nconf_in - read (intin,'(i5)',end=11,err=12) iconf - 12 continue - write (iout,*) "write READ_ANGLES",iconf,m - call read_angles(intin,*11) - if (iref.eq.0) then - mm=m - else - mm=m+1 - endif - do j=2,nres-1 - dihang_in(1,j,1,mm)=theta(j+1) - dihang_in(2,j,1,mm)=phi(j+2) - dihang_in(3,j,1,mm)=alph(j) - dihang_in(4,j,1,mm)=omeg(j) - enddo - enddo ! m - goto 13 - 11 write (iout,*) nconf_in," conformations requested, but only", - & m-1," found in the angle file." - nconf_in=m-1 - 13 continue - m=nconf_in - write (iout,*) nconf_in, - & " initial conformations have been read in." - endif - if (iref.eq.0) then - if (nconfr.gt.nconf_in) then - call make_ranvar(nconfr,m,idum) - write (iout,*) nconfr-nconf_in, - & " conformations have been generated randomly." - endif - else - nconfr=nconfr*2 - call from_int(nconfr,m,idum) -c call from_pdb(nconfr,idum) - endif - write (iout,*) 'Exitted from make_ranvar nconfr=',nconfr - write (*,*) 'Exitted from make_ranvar nconfr=',nconfr - do m=1,nconfr - write (iout,*) 'Initial conformation',m - write(iout,'(8f10.4)') (rad2deg*dihang_in(1,j,1,m),j=2,nres-1) - write(iout,'(8f10.4)') (rad2deg*dihang_in(2,j,1,m),j=2,nres-1) - write(iout,'(8f10.4)') (rad2deg*dihang_in(3,j,1,m),j=2,nres-1) - write(iout,'(8f10.4)') (rad2deg*dihang_in(4,j,1,m),j=2,nres-1) - enddo - write(iout,*)'Calling FEEDIN NCONF',nconfr - time1i=MPI_WTIME() - call feedin(nconfr,nft) - write (iout,*) ' Time for first bank min.',MPI_WTIME()-time1i - call history_append - write(icsa_history,*) jlee,nft,nbank - write(icsa_history,851) (etot(i),i=1,nconfr) - write(icsa_history,850) (rmsn(i),i=1,nconfr) - write(icsa_history,850) (pncn(i),i=1,nconfr) - write(icsa_history,*) - close(icsa_history) - ELSE -c To minimize input conformation (bank conformation) -c Output to $mol.reminimized - if (irestart.lt.0) then - call reminimize(jlee) - return - endif - if (irestart.eq.1) goto 111 -c soldier - perform energy minimization - 334 call minim_jlee - ENDIF - -ccccccccccccccccccccccccccccccccccc -c need to syncronize all procs - call mpi_barrier(CG_COMM,ierr) - if (ierr.ne.0) then - print *, ' cannot synchronize MPI' - stop - endif -ccccccccccccccccccccccccccccccccccc - - IF (ME.EQ.KING) THEN - -c print *,"ok after minim" - nstep=nstep+nconf - if(irestart.eq.2) then - nbank=nbank+nconf -c ntbank=ntbank+nconf - if(ntbank.gt.ntbankm) ntbank=ntbankm - endif -c print *,"ok before indexx" - if(iref.eq.0) then - call indexx(nconfr,etot,indx) - else -c cc/al 7/6/00 - do k=1,nconfr - indx(k)=k - enddo - call indexx(nconfr-nconf_in,rmsn(nconf_in+1),indx(nconf_in+1)) - do k=nconf_in+1,nconfr - indx(k)=indx(k)+nconf_in - enddo -c cc/al -c call indexx(nconfr,rmsn,indx) - endif -c print *,"ok after indexx" - do im=1,nconf - m=indx(im) - if (m.gt.mxio .or. m.lt.1) then - write (iout,*) 'Dimension ERROR in TOGEHER: IM',im,' M',m - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - jbank(im+nbank-nconf)=0 - bene(im+nbank-nconf)=etot(m) - rene(im+nbank-nconf)=etot(m) -c!bankt btene(im)=etot(m) -c - brmsn(im+nbank-nconf)=rmsn(m) - bpncn(im+nbank-nconf)=pncn(m) - rrmsn(im+nbank-nconf)=rmsn(m) - rpncn(im+nbank-nconf)=pncn(m) - if (im+nbank-nconf.gt.mxio .or. im+nbank-nconf.lt.1) then - write (iout,*) 'Dimension ERROR in TOGEHER: IM',im, - & ' NBANK',nbank,' NCONF',nconf,' IM+NBANK-NCONF',im+nbank-nconf - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - bvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m) - rvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m) -c!bankt btvar(i,j,k,im)=dihang(i,j,k,m) -c - enddo - enddo - enddo - if(iref.eq.1) then - if(brmsn(im+nbank-nconf).gt.rmscut.or. - & bpncn(im+nbank-nconf).lt.pnccut) ibank(im+nbank-nconf)=9 - endif - if(vdisulf) then - bvar_ns(im+nbank-nconf)=ns-2*nss - k=0 - do i=1,ns - j=1 - do while( iss(i).ne.ihpb(j)-nres .and. - & iss(i).ne.jhpb(j)-nres .and. j.le.nss) - j=j+1 - enddo - if (j.gt.nss) then - k=k+1 - bvar_s(k,im+nbank-nconf)=iss(i) - endif - enddo - endif - bvar_nss(im+nbank-nconf)=nss - do i=1,nss - bvar_ss(1,i,im+nbank-nconf)=ihpb(i) - bvar_ss(2,i,im+nbank-nconf)=jhpb(i) - enddo - enddo - ENDIF - - 111 continue - - IF (ME.EQ.KING) THEN - - call find_max - call find_min - - call get_diff - if(nbank.eq.nconf.and.irestart.eq.0) then - adif=avedif - endif - - cutdif=adif/cut1 - ctdif1=adif/cut2 - -cd print *,"adif,xctdif,cutdifr" -cd print *,adif,xctdif,cutdifr - nst=ntotal/ntrial/nseed - xctdif=(cutdif/ctdif1)**(-1.0/nst) - if(irestart.ge.1) call estimate_cutdif(adif,xctdif,cutdifr) -c print *,"ok after estimate" - - irestart=0 - - call write_rbank(jlee,adif,nft) - call write_bank(jlee,nft) -c!bankt call write_bankt(jlee,nft) -c call write_bank1(jlee) - call history_append - write(icsa_history,*) "xctdif: ", xctdif,nst,adif/cut1,ctdif1 - write(icsa_history,851) (bene(i),i=1,nbank) - write(icsa_history,850) (brmsn(i),i=1,nbank) - write(icsa_history,850) (bpncn(i),i=1,nbank) - close(icsa_history) - 850 format(10f8.3) - 851 format(5e15.6) - - ifar=nseed/4*3+1 - ifar=nseed+1 - ENDIF - - - finished=.false. - iter = 0 - irecv = 0 - isent =0 - ifrom= 0 - time0i=MPI_WTIME() - time1i=time0i - time_start_c=time0i - if (.not.sync_iter) then - time_start=time0i - nft00=nft - else - sync_iter=.false. - endif - nft00_c=nft - nft0i=nft -ccccccccccccccccccccccccccccccccccccccc - do while (.not. finished) -ccccccccccccccccccccccccccccccccccccccc -crc print *,"iter ", iter,' isent=',isent - - IF (ME.EQ.KING) THEN -c start energy minimization - - if (isent.eq.0) then -c king-emperor - select seeds & make var & feed input -cd print *,'generating new conf',ntrial,MPI_WTIME() - call select_is(nseed,ifar,idum) - - open(icsa_seed,file=csa_seed,status="old") - write(icsa_seed,39) - & jlee,icycle,nstep,(is(i),bene(is(i)),i=1,nseed) - close(icsa_seed) - call history_append - write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, - * ebmin,ebmax,nft,iuse,nbank,ntbank - close(icsa_history) - - - - call make_var(ntry,idum,iter) -cd print *,'new trial generated',ntrial,MPI_WTIME() - time2i=MPI_WTIME() - write (iout,'(a20,i4,f12.2)') - & 'Time for make trial',iter+1,time2i-time1i - endif - -crc write(iout,*)'1:Calling FEEDIN NTRY',NTRY,' ntrial',ntrial -crc call feedin(ntry,nft) - - isent=isent+1 - if (isent.ge.nodes.or.iter.gt.0) then -ct print *,'waiting ',MPI_WTIME() - irecv=irecv+1 - call recv(0,ifrom,xout,eout,ind,timeout) -ct print *,' ',irecv,' received from',ifrom,MPI_WTIME() - else - ifrom=ifrom+1 - endif - -ct print *,'sending to',ifrom,MPI_WTIME() - call send(isent,ifrom,iter) -ct print *,isent,' sent ',MPI_WTIME() - -c store results ----------------------------------------------- - if (isent.ge.nodes.or.iter.gt.0) then - nft=nft+ind(3) - movernx(irecv)=iabs(ind(5)) - call getx(ind,xout,eout,cout,rad,iw_pdb,irecv) - if(vdisulf) then - nss_out(irecv)=nss - do i=1,nss - iss_out(i,irecv)=ihpb(i) - jss_out(i,irecv)=jhpb(i) - enddo - endif - if(iw_pdb.gt.0) - & call write_csa_pdb(xout,eout,nft,irecv,iw_pdb) - endif -c-------------------------------------------------------------- - if (isent.eq.ntry) then - time1i=MPI_WTIME() - write (iout,'(a18,f12.2,a14,f10.2)') - & 'Nonsetup time ',time1i-time_start_c, - & ' sec, Eval/s =',(nft-nft00_c)/(time1i-time_start_c) - write (iout,'(a14,i4,f12.2,a14,f10.2)') - & 'Time for iter ',iter+1,time1i-time0i, - & ' sec, Eval/s =',(nft-nft0i)/(time1i-time0i) - time0i=time1i - nft0i=nft - cutdif=cutdif*xctdif - if(cutdif.lt.ctdif1) cutdif=ctdif1 - if (iter.eq.0) then - print *,'UPDATING ',ntry-nodes+1,irecv - write(iout,*) 'UPDATING ',ntry-nodes+1 - iter=iter+1 -c----------------- call update(ntry-nodes+1) ------------------- - nstep=nstep+ntry-nseed-(nodes-1) - call refresh_bank(ntry-nodes+1) -c!bankt call refresh_bankt(ntry-nodes+1) - else -c----------------- call update(ntry) --------------------------- - iter=iter+1 - print *,'UPDATING ',ntry,irecv - write(iout,*) 'UPDATING ',ntry - nstep=nstep+ntry-nseed - call refresh_bank(ntry) -c!bankt call refresh_bankt(ntry) - endif -c----------------------------------------------------------------- - - call write_bank(jlee,nft) -c!bankt call write_bankt(jlee,nft) - call find_min - - time1i=MPI_WTIME() - write (iout,'(a20,i4,f12.2)') - & 'Time for refresh ',iter,time1i-time0i - - if(ebmin.lt.estop) finished=.true. - if(icycle.gt.icmax) then - call write_bank1(jlee) - do i=1,nbank - ibank(i)=2 - ibank(i)=1 - enddo - nbank=nbank+nconf - if(nbank.gt.1000) then - finished=.true. - else -crc goto 333 - sync_iter=.true. - endif - endif - if(nstep.gt.nstmax) finished=.true. - - if(finished.or.sync_iter) then - do ij=1,nodes-1 - call recv(1,ifrom,xout,eout,ind,timeout) - if (timeout) then - nstep=nstep+ij-1 - print *,'ERROR worker is not responding' - write(iout,*) 'ERROR worker is not responding' - time1i=MPI_WTIME()-time_start_c - print *,'End of cycle, master time for ',iter,' iters ', - & time1i,'sec, Eval/s ',(nft-nft00_c)/time1i - write (iout,*) 'End of cycle, master time for ',iter, - & ' iters ',time1i,' sec' - write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i - print *,'UPDATING ',ij-1 - write(iout,*) 'UPDATING ',ij-1 - call flush(iout) - call refresh_bank(ij-1) -c!bankt call refresh_bankt(ij-1) - goto 1002 - endif -c print *,'node ',ifrom,' finished ',ij,nft - write(iout,*) 'node ',ifrom,' finished ',ij,nft - call flush(iout) - nft=nft+ind(3) - movernx(ij)=iabs(ind(5)) - call getx(ind,xout,eout,cout,rad,iw_pdb,ij) - if(vdisulf) then - nss_out(ij)=nss - do i=1,nss - iss_out(i,ij)=ihpb(i) - jss_out(i,ij)=jhpb(i) - enddo - endif - if(iw_pdb.gt.0) - & call write_csa_pdb(xout,eout,nft,ij,iw_pdb) - enddo - nstep=nstep+nodes-1 -crc print *,'---------bcast finished--------',finished - time1i=MPI_WTIME()-time_start_c - print *,'End of cycle, master time for ',iter,' iters ', - & time1i,'sec, Eval/s ',(nft-nft00_c)/time1i - write (iout,*) 'End of cycle, master time for ',iter, - & ' iters ',time1i,' sec' - write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i - -ctimeout call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr) -ctimeout call mpi_bcast(sync_iter,1,mpi_logical,0, -ctimeout & CG_COMM,ierr) - do ij=1,nodes-1 - tstart=MPI_WTIME() - call mpi_issend(finished,1,mpi_logical,ij,idchar, - & CG_COMM,ireq,ierr) - call mpi_issend(sync_iter,1,mpi_logical,ij,idchar, - & CG_COMM,ireq2,ierr) - flag=.false. - timeout1=.false. - do while(.not. (flag .or. timeout1)) - call MPI_TEST(ireq2,flag,muster,ierr) - tend1=MPI_WTIME() - if(tend1-tstart.gt.60) then - print *,'ERROR worker ',ij,' is not responding' - write(iout,*) 'ERROR worker ',ij,' is not responding' - timeout1=.true. - endif - enddo - if(timeout1) then - write(iout,*) 'worker ',ij,' NOT OK ',tend1-tstart - timeout=.true. - else - write(iout,*) 'worker ',ij,' OK ',tend1-tstart - endif - enddo - print *,'UPDATING ',nodes-1,ij - write(iout,*) 'UPDATING ',nodes-1 - call refresh_bank(nodes-1) -c!bankt call refresh_bankt(nodes-1) - 1002 continue - call write_bank(jlee,nft) -c!bankt call write_bankt(jlee,nft) - call find_min - - do i=0,mxmv - do j=1,3 - nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) - nstatnx(i,j)=0 - enddo - enddo - - write(iout,*)'### Total stats:' - do i=0,mxmv - if(nstatnx_tot(i,1).ne.0) then - if (i.le.9) then - write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') - & '### N',i,' total=',nstatnx_tot(i,1), - & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc', - & (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1) - else - write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') - & '###N',i,' total=',nstatnx_tot(i,1), - & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc', - & (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1) - endif - else - if (i.le.9) then - write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') - & '### N',i,' total=',nstatnx_tot(i,1), - & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3), - & ' %acc',0.0 - else - write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') - & '###N',i,' total=',nstatnx_tot(i,1), - & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3), - & ' %acc',0.0 - endif - endif - enddo - - endif - if(sync_iter) goto 331 - - 39 format(2i3,i7,5(i4,f8.3,1x),19(/,13x,5(i4,f8.3,1x))) - 40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4) - 43 format(10i8) - 44 format('jlee =',i3,':',4f10.1,' E =',f8.3,i7,i10) - - isent=0 - irecv=0 - endif - ELSE -c soldier - perform energy minimization - call minim_jlee - print *,'End of minim, proc',me,'time ',MPI_WTIME()-time_start - write (iout,*) 'End of minim, proc',me,'time ', - & MPI_WTIME()-time_start - call flush(iout) -ctimeout call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr) -ctimeout call mpi_bcast(sync_iter,1,mpi_logical,0,CG_COMM,ierr) - call mpi_recv(finished,1,mpi_logical,0,idchar, - * CG_COMM,muster,ierr) - call mpi_recv(sync_iter,1,mpi_logical,0,idchar, - * CG_COMM,muster,ierr) - if(sync_iter) goto 331 - ENDIF - -ccccccccccccccccccccccccccccccccccccccc - enddo -ccccccccccccccccccccccccccccccccccccccc - - IF (ME.EQ.KING) THEN - call history_append - write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, - * ebmin,ebmax,nft,iuse,nbank,ntbank - - write(icsa_history,44) jlee,0.0,0.0,0.0, - & 0.0,ebmin,nstep,nft - write(icsa_history,*) - close(icsa_history) - - time1i=MPI_WTIME()-time_start - print *,'End of RUN, master time ', - & time1i,'sec, Eval/s ',(nft-nft00)/time1i - write (iout,*) 'End of RUN, master time ', - & time1i,' sec' - write (iout,*) 'Total eval/s ',(nft-nft00)/time1i - - if(timeout) then - write(iout,*) '!!!! ERROR worker was not responding' - write(iout,*) '!!!! cannot finish work normally' - write(iout,*) 'Processor0 is calling MPI_ABORT' - print *,'!!!! ERROR worker was not responding' - print *,'!!!! cannot finish work normally' - print *,'Processor0 is calling MPI_ABORT' - call flush(iout) - call mpi_abort(mpi_comm_world, 111, ierr) - endif - ENDIF - -cccccccccccccccccccccccccccccc - 300 continue -cccccccccccccccccccccccccccccc - - return - end -c------------------------------------------------- - subroutine feedin(nconf,nft) -c sends out starting conformations and receives results of energy minimization - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'mpif.h' - dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1), - * cout(2),ind(9),info(12) - dimension muster(mpi_status_size) - include 'COMMON.SETUP' - parameter (rad=1.745329252d-2) - - print *,'FEEDIN: NCONF=',nconf - mm=0 -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - if (nconf .lt. nodes-1) then - write (*,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1', - & nconf,nodes-1 - write (iout,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1', - & nconf,nodes-1 - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do n=1,nconf -c pull out external and internal variables for next start - call putx(xin,n,rad) -! write (iout,*) 'XIN from FEEDIN N=',n -! write(iout,'(8f10.4)') (xin(j),j=1,nvar) - mm=mm+1 - if (mm.lt.nodes) then -c feed task to soldier -! print *, ' sending input for start # ',n - info(1)=n - info(2)=-1 - info(3)=0 - info(4)=0 - info(5)=0 - info(6)=0 - call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM, - * ierr) - call mpi_send(xin,nvar,mpi_double_precision,mm, - * idreal,CG_COMM,ierr) - else -c find an available soldier - call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, - * CG_COMM,muster,ierr) -! print *, ' receiving output from start # ',ind(1) - man=muster(mpi_source) -c receive final energies and variables - nft=nft+ind(3) - call mpi_recv(eout,1,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) -! print *,eout -#ifdef CO_BIAS - call mpi_recv(co,1,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) - write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co -#endif - call mpi_recv(xout,nvar,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) -! print *,nvar , ierr -c feed next task to soldier -! print *, ' sending input for start # ',n - info(1)=n - info(2)=-1 - info(3)=0 - info(4)=0 - info(5)=0 - info(6)=0 - info(7)=0 - info(8)=0 - info(9)=0 - call mpi_send(info,12,mpi_integer,man,idint,CG_COMM, - * ierr) - call mpi_send(xin,nvar,mpi_double_precision,man, - * idreal,CG_COMM,ierr) -c retrieve latest results - call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1)) - if(iw_pdb.gt.0) - & call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb) - endif - enddo -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c no more input -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - do j=1,nodes-1 -c wait for a soldier - call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, - * CG_COMM,muster,ierr) -crc if (ierr.ne.0) go to 30 -! print *, ' receiving output from start # ',ind(1) - man=muster(mpi_source) -c receive final energies and variables - nft=nft+ind(3) - call mpi_recv(eout,1, - * mpi_double_precision,man,idreal, - * CG_COMM,muster,ierr) -! print *,eout -#ifdef CO_BIAS - call mpi_recv(co,1,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) - write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co -#endif -crc if (ierr.ne.0) go to 30 - call mpi_recv(xout,nvar,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) -! print *,nvar , ierr -crc if (ierr.ne.0) go to 30 -c halt soldier - info(1)=0 - info(2)=-1 - info(3)=0 - info(4)=0 - info(5)=0 - info(6)=0 - call mpi_send(info,12,mpi_integer,man,idint,CG_COMM, - * ierr) -c retrieve results - call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1)) - if(iw_pdb.gt.0) - & call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb) - enddo -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - return - 10 print *, ' dispatching error' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 20 print *, ' communication error' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 30 print *, ' receiving error' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - end -cccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine getx(ind,xout,eout,cout,rad,iw_pdb,k) -c receives and stores data from soldiers - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.CONTACTS' - dimension ind(9),xout(maxvar),eout(mxch*(mxch+1)/2+1) -cjlee - double precision przes(3),obr(3,3),cout(2) - logical non_conv -cjlee - iw_pdb=2 - if (k.gt.mxio .or. k.lt.1) then - write (iout,*) - & 'ERROR - dimensions of ANGMIN have been exceeded K=',k - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif -c store ind() - do j=1,9 - indb(k,j)=ind(j) - enddo -c store energies - etot(k)=eout(1) -c retrieve dihedral angles etc - call var_to_geom(nvar,xout) - do j=2,nres-1 - dihang(1,j,1,k)=theta(j+1) - dihang(2,j,1,k)=phi(j+2) - dihang(3,j,1,k)=alph(j) - dihang(4,j,1,k)=omeg(j) - enddo - dihang(2,nres-1,1,k)=0.0d0 -cjlee - if(iref.eq.0) then - iw_pdb=1 -cd write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4)') -cd & ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' mv ', -cd & ind(5),ind(4) - return - endif - call chainbuild -c call dihang_to_c(dihang(1,1,1,k)) -c call fitsq(rms,c(1,1),crefjlee(1,1),nres,przes,obr,non_conv) -c call fitsq(rms,c(1,2),crefjlee(1,2),nres-1,przes,obr,non_conv) -c call fitsq(rms,c(1,nstart_seq),crefjlee(1,nstart_sup), -c & nsup,przes,obr,non_conv) -c rmsn(k)=dsqrt(rms) - - call rmsd_csa(rmsn(k)) - call contact(.false.,ncont,icont,co) - pncn(k)=contact_fract(ncont,ncont_ref,icont,icont_ref) - -cd write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a5 -cd & ,0pf5.2,a5,f5.1,a,f6.3,a4,i3,i4)') -cd & ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' rms ', -cd & rmsn(k),' %NC ',pncn(k)*100,' cont.order',co,' mv ', -cd & ind(5),ind(4) - - - if (rmsn(k).gt.rmscut.or.pncn(k).lt.pnccut) iw_pdb=0 - return - end -cccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine putx(xin,n,rad) -c gets starting variables - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - dimension xin(maxvar) - -c pull out starting values for variables -! write (iout,*)'PUTX: N=',n - do m=1,numch -! write (iout,'(8f10.4)') (dihang_in(1,j,m,n),j=2,nres-1) -! write (iout,'(8f10.4)') (dihang_in(2,j,m,n),j=2,nres-1) -! write (iout,'(8f10.4)') (dihang_in(3,j,m,n),j=2,nres-1) -! write (iout,'(8f10.4)') (dihang_in(4,j,m,n),j=2,nres-1) - do j=2,nres-1 - theta(j+1)=dihang_in(1,j,m,n) - phi(j+2)=dihang_in(2,j,m,n) - alph(j)=dihang_in(3,j,m,n) - omeg(j)=dihang_in(4,j,m,n) - enddo - enddo -c set up array of variables - call geom_to_var(nvar,xin) -! write (iout,*) 'xin in PUTX N=',n -! call intout -! write (iout,'(8f10.4)') (xin(i),i=1,nvar) - return - end -c-------------------------------------------------------- - subroutine putx2(xin,iff,n) -c gets starting variables - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - dimension xin(maxvar),iff(maxres) - -c pull out starting values for variables - do m=1,numch - do j=2,nres-1 - theta(j+1)=dihang_in2(1,j,m,n) - phi(j+2)=dihang_in2(2,j,m,n) - alph(j)=dihang_in2(3,j,m,n) - omeg(j)=dihang_in2(4,j,m,n) - enddo - enddo -c set up array of variables - call geom_to_var(nvar,xin) - - do i=1,nres - iff(i)=iff_in(i,n) - enddo - return - end - -c------------------------------------------------------- - subroutine prune_bank(p_cut) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.TIME1' - include 'COMMON.SETUP' -c--------------------------- -c This subroutine prunes bank conformations using p_cut -c--------------------------- - - nprune=0 - nprune=nprune+1 - m=1 - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang(i,j,k,nprune)=bvar(i,j,k,m) - enddo - enddo - enddo - bene(nprune)=bene(m) - brmsn(nprune)=brmsn(m) - bpncn(nprune)=bpncn(m) - - do m=2,nbank - ddmin=9.d190 - do ip=1,nprune - call get_diff12(dihang(1,1,1,ip),bvar(1,1,1,m),diff) - if(diff.lt.p_cut) goto 100 - if(diff.lt.ddmin) ddmin=diff - enddo - nprune=nprune+1 - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang(i,j,k,nprune)=bvar(i,j,k,m) - enddo - enddo - enddo - bene(nprune)=bene(m) - brmsn(nprune)=brmsn(m) - bpncn(nprune)=bpncn(m) - 100 continue - write (iout,*) 'Pruning :',m,nprune,p_cut,ddmin - enddo - nbank=nprune - print *, 'Pruning :',m,nprune,p_cut - call write_bank(0,0) - - return - end -c------------------------------------------------------- - - subroutine reminimize(jlee) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.TIME1' - include 'COMMON.SETUP' -c--------------------------- -c This subroutine re-minimizes bank conformations: -c--------------------------- - - ntry=nbank - - call find_max - call find_min - - if (me.eq.king) then - open(icsa_history,file=csa_history,status="old") - write(icsa_history,*) "Re-minimization",nodes,"nodes" - write(icsa_history,851) (bene(i),i=1,nbank) - write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, - * ebmin,ebmax,nft,iuse,nbank,ntbank - close(icsa_history) - do index=1,ntry - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,index) - enddo - enddo - enddo - enddo - nft=0 - call feedin(ntry,nft) - else - call minim_jlee - endif - - call find_max - call find_min - - if (me.eq.king) then - do i=1,ntry - call replace_bvar(i,i) - enddo - open(icsa_history,file=csa_history,status="old") - write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, - * ebmin,ebmax,nft,iuse,nbank,ntbank - write(icsa_history,851) (bene(i),i=1,nbank) - close(icsa_history) - call write_bank_reminimized(jlee,nft) - endif - - 40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4) - 851 format(5e15.6) - 850 format(5e15.10) -c 850 format(10f8.3) - - return - end -c------------------------------------------------------- - subroutine send(n,mm,it) -c sends out starting conformation for minimization - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'mpif.h' - dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1), - * cout(2),ind(8),xin2(maxvar),iff(maxres),info(12) - dimension muster(mpi_status_size) - include 'COMMON.SETUP' - parameter (rad=1.745329252d-2) - - if (isend2(n).eq.0) then -c pull out external and internal variables for next start - call putx(xin,n,rad) - info(1)=n - info(2)=it - info(3)=movenx(n) - info(4)=nss_in(n) - info(5)=parent(1,n) - info(6)=parent(2,n) - - if (movenx(n).eq.14.or.movenx(n).eq.17) then - info(7)=idata(1,n) - info(8)=idata(2,n) - else if (movenx(n).eq.16) then - info(7)=idata(1,n) - info(8)=idata(2,n) - info(10)=idata(3,n) - info(11)=idata(4,n) - info(12)=idata(5,n) - else - info(7)=0 - info(8)=0 - info(10)=0 - info(11)=0 - info(12)=0 - endif - - if (movenx(n).eq.15) then - info(9)=parent(3,n) - else - info(9)=0 - endif - call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM, - * ierr) - call mpi_send(xin,nvar,mpi_double_precision,mm, - * idreal,CG_COMM,ierr) - else -c distfit & minimization for n7 move - info(1)=-n - info(2)=it - info(3)=movenx(n) - info(4)=nss_in(n) - info(5)=parent(1,n) - info(6)=parent(2,n) - info(7)=0 - info(8)=0 - info(9)=0 - call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM, - * ierr) - call putx2(xin,iff,isend2(n)) - call mpi_send(xin,nvar,mpi_double_precision,mm, - * idreal,CG_COMM,ierr) - call mpi_send(iff,nres,mpi_integer,mm, - * idint,CG_COMM,ierr) - call putx(xin2,n,rad) - call mpi_send(xin2,nvar,mpi_double_precision,mm, - * idreal,CG_COMM,ierr) - endif - if (vdisulf.and.nss_in(n).ne.0) then - call mpi_send(iss_in(1,n),nss_in(n),mpi_integer,mm, - * idint,CG_COMM,ierr) - call mpi_send(jss_in(1,n),nss_in(n),mpi_integer,mm, - * idint,CG_COMM,ierr) - endif - return - end -c------------------------------------------------- - - subroutine recv(ihalt,man,xout,eout,ind,tout) -c receives results of energy minimization - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'mpif.h' - dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1), - * cout(2),ind(9),info(12) - dimension muster(mpi_status_size) - include 'COMMON.SETUP' - logical tout,flag - double precision twait,tstart,tend1 - parameter(twait=600.0d0) - -c find an available soldier - tout=.false. - flag=.false. - tstart=MPI_WTIME() - do while(.not. (flag .or. tout)) - call MPI_IPROBE(mpi_any_source,idint,CG_COMM,flag, - * muster,ierr) - tend1=MPI_WTIME() - if(tend1-tstart.gt.twait .and. ihalt.eq.1) tout=.true. -c_error if(tend1-tstart.gt.twait) tout=.true. - enddo - if (tout) then - write(iout,*) 'ERROR = timeout for recv ',tend1-tstart - call flush(iout) - return - endif - man=muster(mpi_source) - -ctimeout call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, -ctimeout * CG_COMM,muster,ierr) -! print *, ' receiving output from start # ',ind(1) -ct print *,'receiving ',MPI_WTIME() -ctimeout man=muster(mpi_source) - call mpi_recv(ind,9,mpi_integer,man,idint, - * CG_COMM,muster,ierr) -ctimeout -c receive final energies and variables - call mpi_recv(eout,1,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) -! print *,eout -#ifdef CO_BIAS - call mpi_recv(co,1,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) - write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co -#endif - call mpi_recv(xout,nvar,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) -! print *,nvar , ierr - if(vdisulf) nss=ind(6) - if(vdisulf.and.nss.ne.0) then - call mpi_recv(ihpb,nss,mpi_integer, - * man,idint,CG_COMM,muster,ierr) - call mpi_recv(jhpb,nss,mpi_integer, - * man,idint,CG_COMM,muster,ierr) - endif -c halt soldier - if(ihalt.eq.1) then -c print *,'sending halt to ',man - write(iout,*) 'sending halt to ',man - info(1)=0 - call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,ierr) - endif - return - end - -c---------------------------------------------------------- - subroutine history_append - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - -#if defined(AIX) || defined(PGI) - open(icsa_history,file=csa_history,position="append") -#else - open(icsa_history,file=csa_history,access="append") -#endif - return - end diff --git a/source/unres/src_MD-M-newcorr/unres.F b/source/unres/src_MD-M-newcorr/unres.F deleted file mode 100644 index d5031f0..0000000 --- a/source/unres/src_MD-M-newcorr/unres.F +++ /dev/null @@ -1,771 +0,0 @@ -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C U N R E S C -C C -C Program to carry out conformational search of proteins in an united-residue C -C approximation. C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - - -#ifdef MPI - include 'mpif.h' - include 'COMMON.SETUP' -#endif - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.REMD' - include 'COMMON.MD' - include 'COMMON.SBRIDGE' - double precision hrtime,mintime,sectime - character*64 text_mode_calc(-2:14) /'test', - & 'SC rotamer distribution', - & 'Energy evaluation or minimization', - & 'Regularization of PDB structure', - & 'Threading of a sequence on PDB structures', - & 'Monte Carlo (with minimization) ', - & 'Energy minimization of multiple conformations', - & 'Checking energy gradient', - & 'Entropic sampling Monte Carlo (with minimization)', - & 'Energy map', - & 'CSA calculations', - & 'Not used 9', - & 'Not used 10', - & 'Soft regularization of PDB structure', - & 'Mesoscopic molecular dynamics (MD) ', - & 'Not used 13', - & 'Replica exchange molecular dynamics (REMD)'/ - external ilen - -c call memmon_print_usage() - - call init_task - if (me.eq.king) - & write(iout,*)'### LAST MODIFIED 4/25/08 7:29PM by adam' - if (me.eq.king) call cinfo -C Read force field parameters and job setup data - call readrtns - call flush(iout) -C - if (me.eq.king .or. .not. out1file) then - write (iout,'(2a/)') - & text_mode_calc(modecalc)(:ilen(text_mode_calc(modecalc))), - & ' calculation.' - if (minim) write (iout,'(a)') - & 'Conformations will be energy-minimized.' - write (iout,'(80(1h*)/)') - endif - call flush(iout) -C - if (modecalc.eq.-2) then - call test - stop - else if (modecalc.eq.-1) then - write(iout,*) "call check_sc_map next" - call check_bond - stop - endif -#ifdef MPI - if (fg_rank.gt.0) then -C Fine-grain slaves just do energy and gradient components. - call ergastulum ! slave workhouse in Latin - else -#endif - if (modecalc.eq.0) then - call exec_eeval_or_minim - else if (modecalc.eq.1) then - call exec_regularize - else if (modecalc.eq.2) then - call exec_thread - else if (modecalc.eq.3 .or. modecalc .eq.6) then - call exec_MC - else if (modecalc.eq.4) then - call exec_mult_eeval_or_minim - else if (modecalc.eq.5) then - call exec_checkgrad - call exec_checkgrad - else if (ModeCalc.eq.7) then - call exec_map - else if (ModeCalc.eq.8) then - call exec_CSA - else if (modecalc.eq.11) then - call exec_softreg - else if (modecalc.eq.12) then - call exec_MD - else if (modecalc.eq.14) then - call exec_MREMD - else - write (iout,'(a)') 'This calculation type is not supported', - & ModeCalc - endif -#ifdef MPI - endif -C Finish task. - if (fg_rank.eq.0) call finish_task -c call memmon_print_usage() -#ifdef TIMING - call print_detailed_timing -#endif - call MPI_Finalize(ierr) - stop 'Bye Bye...' -#else - call dajczas(tcpu(),hrtime,mintime,sectime) - stop '********** Program terminated normally.' -#endif - end -c-------------------------------------------------------------------------- - subroutine exec_MD - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - if (me.eq.king .or. .not. out1file) - & write (iout,*) "Calling chainbuild" - call chainbuild - call MD - return - end -c--------------------------------------------------------------------------- - subroutine exec_MREMD - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - if (me.eq.king .or. .not. out1file) - & write (iout,*) "Calling chainbuild" - call chainbuild - if (me.eq.king .or. .not. out1file) - & write (iout,*) "Calling REMD" - if (remd_mlist) then - call MREMD - else - do i=1,nrep - remd_m(i)=1 - enddo - call MREMD - endif - return - end -c--------------------------------------------------------------------------- - subroutine exec_eeval_or_minim - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.REMD' - include 'COMMON.MD' - include 'COMMON.SBRIDGE' - common /srutu/ icall - double precision energy(0:n_ene) - double precision energy_long(0:n_ene),energy_short(0:n_ene) - double precision varia(maxvar) - if (indpdb.eq.0) call chainbuild - time00=MPI_Wtime() - call chainbuild_cart - if (split_ene) then - print *,"Processor",myrank," after chainbuild" - icall=1 - call etotal_long(energy_long(0)) - write (iout,*) "Printing long range energy" - call enerprint(energy_long(0)) - call etotal_short(energy_short(0)) - write (iout,*) "Printing short range energy" - call enerprint(energy_short(0)) - do i=0,n_ene - energy(i)=energy_long(i)+energy_short(i) - write (iout,*) i,energy_long(i),energy_short(i),energy(i) - enddo - write (iout,*) "Printing long+short range energy" - call enerprint(energy(0)) - endif - call etotal(energy(0)) - time_ene=MPI_Wtime()-time00 - write (iout,*) "Time for energy evaluation",time_ene - print *,"after etotal" - etota = energy(0) - etot =etota - call enerprint(energy(0)) - call hairpin(.true.,nharp,iharp) - call secondary2(.true.) - if (minim) then -crc overlap test - if (overlapsc) then - print *, 'Calling OVERLAP_SC' - call overlap_sc(fail) - endif - - if (searchsc) then - call sc_move(2,nres-1,10,1d10,nft_sc,etot) - print *,'SC_move',nft_sc,etot - write(iout,*) 'SC_move',nft_sc,etot - endif - - if (dccart) then - print *, 'Calling MINIM_DC' - time1=MPI_WTIME() - call minim_dc(etot,iretcode,nfun) - else - if (indpdb.ne.0) then - call bond_regular - call chainbuild - endif - call geom_to_var(nvar,varia) - print *,'Calling MINIMIZE.' - time1=MPI_WTIME() - call minimize(etot,varia,iretcode,nfun) - endif - print *,'SUMSL return code is',iretcode,' eval ',nfun - evals=nfun/(MPI_WTIME()-time1) - print *,'# eval/s',evals - print *,'refstr=',refstr - call hairpin(.true.,nharp,iharp) - call secondary2(.true.) - call etotal(energy(0)) - etot = energy(0) - call enerprint(energy(0)) - - call intout - call briefout(0,etot) - if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (iout,'(a,i3)') 'SUMSL return code:',iretcode - write (iout,'(a,i20)') '# of energy evaluations:',nfun+1 - write (iout,'(a,f16.3)')'# of energy evaluations/sec:',evals - else - print *,'refstr=',refstr - if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - call briefout(0,etot) - endif - if (outpdb) call pdbout(etot,titel(:50),ipdb) - if (outmol2) call mol2out(etot,titel) - return - end -c--------------------------------------------------------------------------- - subroutine exec_regularize - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.REMD' - include 'COMMON.MD' - include 'COMMON.SBRIDGE' - double precision energy(0:n_ene) - - call gen_dist_constr - call sc_conf - call intout - call regularize(nct-nnt+1,etot,rms,cref(1,nnt,1),iretcode) - call etotal(energy(0)) - energy(0)=energy(0)-energy(14) - etot=energy(0) - call enerprint(energy(0)) - call intout - call briefout(0,etot) - if (outpdb) call pdbout(etot,titel,ipdb) - if (outmol2) call mol2out(etot,titel(:32)) - if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (iout,'(a,i3)') 'SUMSL return code:',iretcode - return - end -c--------------------------------------------------------------------------- - subroutine exec_thread - include 'DIMENSIONS' -#ifdef MP - include "mpif.h" -#endif - include "COMMON.SETUP" - call thread_seq - return - end -c--------------------------------------------------------------------------- - subroutine exec_MC - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - character*10 nodeinfo - double precision varia(maxvar) -#ifdef MPI - include "mpif.h" -#endif - include "COMMON.SETUP" - include 'COMMON.CONTROL' - call mcm_setup - if (minim) then -#ifdef MPI - if (modecalc.eq.3) then - call do_mcm(ipar) - else - call entmcm - endif -#else - if (modecalc.eq.3) then - call do_mcm(ipar) - else - call entmcm - endif -#endif - else - call monte_carlo - endif - return - end -c--------------------------------------------------------------------------- - subroutine exec_mult_eeval_or_minim - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - dimension muster(mpi_status_size) -#endif - include 'COMMON.SETUP' - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.REMD' - include 'COMMON.MD' - include 'COMMON.SBRIDGE' - double precision varia(maxvar) - dimension ind(6) - double precision energy(0:max_ene) - logical eof - eof=.false. -#ifdef MPI - if(me.ne.king) then - call minim_mcmf - return - endif - - close (intin) - open(intin,file=intinname,status='old') - write (istat,'(a5,20a12)')"# ", - & (wname(print_order(i)),i=1,nprint_ene) - if (refstr) then - write (istat,'(a5,20a12)')"# ", - & (ename(print_order(i)),i=1,nprint_ene), - & "ETOT total","RMSD","nat.contact","nnt.contact" - else - write (istat,'(a5,20a12)')"# ", - & (ename(print_order(i)),i=1,nprint_ene),"ETOT total" - endif - - if (.not.minim) then - do while (.not. eof) - if (read_cart) then - read (intin,'(e15.10,e15.5)',end=1100,err=1100) time,ene - call read_x(intin,*11) -#ifdef MPI -c Broadcast the order to compute internal coordinates to the slaves. - if (nfgtasks.gt.1) - & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - call int_from_cart1(.false.) - else - read (intin,'(i5)',end=1100,err=1100) iconf - call read_angles(intin,*11) - call geom_to_var(nvar,varia) - call chainbuild - endif - write (iout,'(a,i7)') 'Conformation #',iconf - call etotal(energy(0)) - call briefout(iconf,energy(0)) - call enerprint(energy(0)) - etot=energy(0) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (istat,'(i5,20(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot, - & rms,frac,frac_nn,co -cjlee end - else - write (istat,'(i5,16(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot - endif - enddo -1100 continue - goto 1101 - endif - - mm=0 - imm=0 - nft=0 - ene0=0.0d0 - n=0 - iconf=0 -c do n=1,nzsc - do while (.not. eof) - mm=mm+1 - if (mm.lt.nodes) then - if (read_cart) then - read (intin,'(e15.10,e15.5)',end=11,err=11) time,ene - call read_x(intin,*11) -#ifdef MPI -c Broadcast the order to compute internal coordinates to the slaves. - if (nfgtasks.gt.1) - & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - call int_from_cart1(.false.) - else - read (intin,'(i5)',end=11,err=11) iconf - call read_angles(intin,*11) - call geom_to_var(nvar,varia) - call chainbuild - endif - write (iout,'(a,i7)') 'Conformation #',iconf - n=n+1 - imm=imm+1 - ind(1)=1 - ind(2)=n - ind(3)=0 - ind(4)=0 - ind(5)=0 - ind(6)=0 - ene0=0.0d0 - call mpi_send(ind,6,mpi_integer,mm,idint,CG_COMM, - * ierr) - call mpi_send(varia,nvar,mpi_double_precision,mm, - * idreal,CG_COMM,ierr) - call mpi_send(ene0,1,mpi_double_precision,mm, - * idreal,CG_COMM,ierr) -c print *,'task ',n,' sent to worker ',mm,nvar - else - call mpi_recv(ind,6,mpi_integer,mpi_any_source,idint, - * CG_COMM,muster,ierr) - man=muster(mpi_source) -c print *,'receiving result from worker ',man,' (',iii1,iii,')' - call mpi_recv(varia,nvar,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) - call mpi_recv(ene,1, - * mpi_double_precision,man,idreal, - * CG_COMM,muster,ierr) - call mpi_recv(ene0,1, - * mpi_double_precision,man,idreal, - * CG_COMM,muster,ierr) -c print *,'result received from worker ',man,' sending now' - - call var_to_geom(nvar,varia) - call chainbuild - call etotal(energy(0)) - iconf=ind(2) - write (iout,*) - write (iout,*) - write (iout,'(a,2i7)') 'Conformation #',iconf,ind(5) - - etot=energy(0) - call enerprint(energy(0)) - call briefout(it,etot) -c if (minim) call briefout(it,etot) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (istat,'(i5,19(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot, - & rms,frac,frac_nn,co - else - write (istat,'(i5,15(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot - endif - - imm=imm-1 - if (read_cart) then - read (intin,'(e15.10,e15.5)',end=1101,err=1101) time,ene - call read_x(intin,*11) -#ifdef MPI -c Broadcast the order to compute internal coordinates to the slaves. - if (nfgtasks.gt.1) - & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - call int_from_cart1(.false.) - else - read (intin,'(i5)',end=1101,err=1101) iconf - call read_angles(intin,*11) - call geom_to_var(nvar,varia) - call chainbuild - endif - n=n+1 - imm=imm+1 - ind(1)=1 - ind(2)=n - ind(3)=0 - ind(4)=0 - ind(5)=0 - ind(6)=0 - call mpi_send(ind,6,mpi_integer,man,idint,CG_COMM, - * ierr) - call mpi_send(varia,nvar,mpi_double_precision,man, - * idreal,CG_COMM,ierr) - call mpi_send(ene0,1,mpi_double_precision,man, - * idreal,CG_COMM,ierr) - nf_mcmf=nf_mcmf+ind(4) - nmin=nmin+1 - endif - enddo -11 continue - do j=1,imm - call mpi_recv(ind,6,mpi_integer,mpi_any_source,idint, - * CG_COMM,muster,ierr) - man=muster(mpi_source) - call mpi_recv(varia,nvar,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) - call mpi_recv(ene,1, - * mpi_double_precision,man,idreal, - * CG_COMM,muster,ierr) - call mpi_recv(ene0,1, - * mpi_double_precision,man,idreal, - * CG_COMM,muster,ierr) - - call var_to_geom(nvar,varia) - call chainbuild - call etotal(energy(0)) - iconf=ind(2) - write (iout,*) - write (iout,*) - write (iout,'(a,2i7)') 'Conformation #',iconf,ind(5) - - etot=energy(0) - call enerprint(energy(0)) - call briefout(it,etot) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (istat,'(i5,19(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot, - & rms,frac,frac_nn,co - else - write (istat,'(i5,15(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot - endif - nmin=nmin+1 - enddo -1101 continue - do i=1, nodes-1 - ind(1)=0 - ind(2)=0 - ind(3)=0 - ind(4)=0 - ind(5)=0 - ind(6)=0 - call mpi_send(ind,6,mpi_integer,i,idint,CG_COMM, - * ierr) - enddo -#else - close (intin) - open(intin,file=intinname,status='old') - write (istat,'(a5,20a12)')"# ", - & (wname(print_order(i)),i=1,nprint_ene) - write (istat,'("# ",20(1pe12.4))') - & (weights(print_order(i)),i=1,nprint_ene) - if (refstr) then - write (istat,'(a5,20a12)')"# ", - & (ename(print_order(i)),i=1,nprint_ene), - & "ETOT total","RMSD","nat.contact","nnt.contact" - else - write (istat,'(a5,14a12)')"# ", - & (ename(print_order(i)),i=1,nprint_ene),"ETOT total" - endif - do while (.not. eof) - if (read_cart) then - read (intin,'(e15.10,e15.5)',end=1100,err=1100) time,ene - call read_x(intin,*11) -#ifdef MPI -c Broadcast the order to compute internal coordinates to the slaves. - if (nfgtasks.gt.1) - & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - call int_from_cart1(.false.) - else - read (intin,'(i5)',end=1100,err=1100) iconf - call read_angles(intin,*11) - call geom_to_var(nvar,varia) - call chainbuild - endif - write (iout,'(a,i7)') 'Conformation #',iconf - if (minim) call minimize(etot,varia,iretcode,nfun) - call etotal(energy(0)) - - etot=energy(0) - call enerprint(energy(0)) - if (minim) call briefout(it,etot) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (istat,'(i5,18(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene), - & etot,rms,frac,frac_nn,co -cjlee end - else - write (istat,'(i5,14(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot - endif - enddo - 11 continue -#endif - return - end -c--------------------------------------------------------------------------- - subroutine exec_checkgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.REMD' - include 'COMMON.MD' - include 'COMMON.SBRIDGE' - common /srutu/ icall - double precision energy(0:max_ene) -c do i=2,nres -c vbld(i)=vbld(i)+ran_number(-0.1d0,0.1d0) -c if (itype(i).ne.10) -c & vbld(i+nres)=vbld(i+nres)+ran_number(-0.001d0,0.001d0) -c enddo - if (indpdb.eq.0) call chainbuild -c do i=0,nres -c do j=1,3 -c dc(j,i)=dc(j,i)+ran_number(-0.2d0,0.2d0) -c enddo -c enddo -c do i=1,nres-1 -c if (itype(i).ne.10) then -c do j=1,3 -c dc(j,i+nres)=dc(j,i+nres)+ran_number(-0.2d0,0.2d0) -c enddo -c endif -c enddo -c do j=1,3 -c dc(j,0)=ran_number(-0.2d0,0.2d0) -c enddo - usampl=.true. - totT=1.d0 - eq_time=0.0d0 - call read_fragments - call chainbuild_cart - call cartprint - call intout - icall=1 - call etotal(energy(0)) - etot = energy(0) - call enerprint(energy(0)) - write (iout,*) "Uconst",Uconst," Uconst_back",uconst_back - print *,'icheckgrad=',icheckgrad - goto (10,20,30) icheckgrad - 10 print *,'kurwa0' - call check_ecartint - print *,'kurwa' - call check_ecartint - return - 20 print *,'ja pierdole' - call check_cartgrad - call check_cartgrad - return - 30 call check_eint - return - end -c--------------------------------------------------------------------------- - subroutine exec_map -C Energy maps - call map_read - call map - return - end -c--------------------------------------------------------------------------- - subroutine exec_CSA -#ifdef MPI - include "mpif.h" -#endif - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -C Conformational Space Annealling programmed by Jooyoung Lee. -C This method works only with parallel machines! -#ifdef MPI - call together -#else - write (iout,*) "CSA works on parallel machines only" -#endif - return - end -c--------------------------------------------------------------------------- - subroutine exec_softreg - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - double precision energy(0:max_ene) - call chainbuild - call etotal(energy(0)) - call enerprint(energy(0)) - if (.not.lsecondary) then - write(iout,*) 'Calling secondary structure recognition' - call secondary2(debug) - else - write(iout,*) 'Using secondary structure supplied in pdb' - endif - - call softreg - - call etotal(energy(0)) - etot=energy(0) - call enerprint(energy(0)) - call intout - call briefout(0,etot) - call secondary2(.true.) - if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - return - end diff --git a/source/unres/src_MD-M-newcorr/xdrf b/source/unres/src_MD-M-newcorr/xdrf deleted file mode 120000 index 26825c5..0000000 --- a/source/unres/src_MD-M-newcorr/xdrf +++ /dev/null @@ -1 +0,0 @@ -../../lib/xdrf \ No newline at end of file diff --git a/source/unres/src_MD_DFA/CMakeLists.txt b/source/unres/src_MD_DFA/CMakeLists.txt deleted file mode 100644 index 71479a0..0000000 --- a/source/unres/src_MD_DFA/CMakeLists.txt +++ /dev/null @@ -1,401 +0,0 @@ -# -# CMake project file for UNRES with MD for single chains -# - -enable_language (Fortran) - - -#================================ -# Set source file lists -#================================ -set(UNRES_MD_DFA_SRC0 - add.f - arcos.f - banach.f - blas.f - bond_move.f - cartder.F - cartprint.f - check_sc_distr.f - check_bond.f - chainbuild.F - checkder_p.F - compare_s1.F - contact.f - convert.f - cored.f - dfa.F - dihed_cons.F - djacob.f - econstr_local.F - eigen.f - elecont.f - energy_split-sep.F - entmcm.F - fitsq.f - gauss.f - gen_rand_conf.F - geomout.F - gnmr1.f - intcartderiv.F - initialize_p.F - int_to_cart.f - intcor.f - intlocal.f - kinetic_lesyng.f - lagrangian_lesyng.F - local_move.f - map.f - matmult.f - mc.F - mcm.F - MD_A-MTS.F - minimize_p.F - minim_mcmf.F - misc.f - moments.f - MP.F - MREMD.F - muca_md.f - parmread.F - pinorm.f - printmat.f - prng_32.F - q_measure.F - randgens.f - rattle.F - readpdb.F - readrtns.F - refsys.f - regularize.F - rescode.f - rmdd.f - rmsd.F - sc_move.F - sort.f - stochfric.F - sumsld.f - surfatom.f - test.F - timing.F - thread.F - unres.F -) - -set(UNRES_MD_DFA_SRC3 - energy_p_new_barrier.F - energy_p_new-sep_barrier.F - gradient_p.F ) - -set(UNRES_MD_DFA_PP_SRC - cartder.F - chainbuild.F - checkder_p.F - compare_s1.F - dihed_cons.F - dfa.F - econstr_local.F - energy_p_new_barrier.F - energy_p_new-sep_barrier.F - energy_split-sep.F - entmcm.F - gen_rand_conf.F - geomout.F - gradient_p.F - initialize_p.F - intcartderiv.F - lagrangian_lesyng.F - mc.F - mcm.F - MD_A-MTS.F - minimize_p.F - minim_mcmf.F - MP.F - MREMD.F - parmread.F - q_measure1.F - q_measure3.F - q_measure.F - rattle.F - readpdb.F - readrtns.F - regularize.F - rmsd.F - sc_move.F - stochfric.F - test.F - thread.F - timing.F - unres.F - proc_proc.c -) - - -if(NOT Fortran_COMPILER_NAME STREQUAL "ifort") - set(UNRES_MD_PP_SRC ${UNRES_MD_PP_SRC} prng_32.F) -endif(NOT Fortran_COMPILER_NAME STREQUAL "ifort") - -#================================================ -# Set comipiler flags for different sourcefiles -#================================================ -if (Fortran_COMPILER_NAME STREQUAL "ifort") - set(FFLAGS0 "-ip -w" ) - set(FFLAGS1 "-w -g -d2 -CA -CB" ) - set(FFLAGS2 "-w -g -00 ") - #set(FFLAGS3 "-c -w -O3 -ipo -ipo_obj -opt_report" ) - set(FFLAGS3 "-w -ipo " ) -elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") - set(FFLAGS0 "-std=legacy -I. " ) - set(FFLAGS1 "-std=legacy -g -I. " ) - set(FFLAGS2 "-std=legacy -I. ") - #set(FFLAGS3 "-c -w -O3 -ipo -ipo_obj -opt_report" ) - set(FFLAGS3 "-std=legacy -I. " ) -endif (Fortran_COMPILER_NAME STREQUAL "ifort") - - -# Add MPI compiler flags -if(UNRES_WITH_MPI) - set(FFLAGS0 "${FFLAGS0} -I${MPI_Fortran_INCLUDE_PATH}") - set(FFLAGS1 "${FFLAGS1} -I${MPI_Fortran_INCLUDE_PATH}") - set(FFLAGS2 "${FFLAGS2} -I${MPI_Fortran_INCLUDE_PATH}") - set(FFLAGS3 "${FFLAGS3} -I${MPI_Fortran_INCLUDE_PATH}") -endif(UNRES_WITH_MPI) - -set_property(SOURCE ${UNRES_MD_DFA_SRC0} APPEND PROPERTY COMPILE_FLAGS ${FFLAGS0} ) -#set_property(SOURCE ${UNRES_MD_DFA_SRC1} PROPERTY COMPILE_FLAGS ${FFLAGS1} ) -#set_property(SOURCE ${UNRES_MD_DFA_SRC2} PROPERTY COMPILE_FLAGS ${FFLAGS2} ) -set_property(SOURCE ${UNRES_MD_DFA_SRC3} PROPERTY COMPILE_FLAGS ${FFLAGS3} ) - -#========================================= -# Settings for GAB force field -#========================================= -if(UNRES_MD_FF STREQUAL "GAB" ) - # set preprocesor flags - set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" ) - -#========================================= -# Settings for E0LL2Y force field -#========================================= -elseif(UNRES_MD_FF STREQUAL "E0LL2Y") - # set preprocesor flags - set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0" ) -endif(UNRES_MD_FF STREQUAL "GAB") - -#========================================= -# System specific flags -#========================================= -if(${CMAKE_SYSTEM_NAME} MATCHES "Linux") - set(CPPFLAGS "${CPPFLAGS} -DLINUX") -endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux") - -#========================================= -# Compiler specific flags -#========================================= - -if (Fortran_COMPILER_NAME STREQUAL "ifort") - # Add ifort preprocessor flags - set(CPPFLAGS "${CPPFLAGS} -DPGI") -elseif (Fortran_COMPILER_NAME STREQUAL "f95") - # Add new gfortran flags - set(CPPFLAGS "${CPPFLAGS} -DG77") -elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") - # Add old gfortran flags - set(CPPFLAGS "${CPPFLAGS} -DG77") -endif (Fortran_COMPILER_NAME STREQUAL "ifort") - -#========================================= -# Add MPI preprocessor flags -#========================================= -if (UNRES_WITH_MPI) - set(CPPFLAGS "${CPPFLAGS} -DMP -DMPI") -endif(UNRES_WITH_MPI) - -#========================================= -# 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_MD_DFA_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) - - -#======================================== -# Setting binary name -#======================================== -if(UNRES_WITH_MPI) - # binary with mpi - set(UNRES_BIN "unresMD-DFA_${Fortran_COMPILER_NAME}_MPICH_${UNRES_MD_FF}.exe") -else(UNRES_WITH_MPI) - # binary without mpi - set(UNRES_BIN "unresMD-DFA_${Fortran_COMPILER_NAME}_single_${UNRES_MD_FF}.exe") -endif(UNRES_WITH_MPI) - -#========================================= -# cinfo.f workaround for cmake -#========================================= -# get the current date -TODAY(DATE) -# generate cinfo.f - -set(CINFO "${CMAKE_CURRENT_BINARY_DIR}/cinfo.f") -FILE(WRITE ${CINFO} -"C CMake generated file - subroutine cinfo - include 'COMMON.IOUNITS' - write(iout,*)'++++ Compile info ++++' - write(iout,*)'Version ${UNRES_MAJOR}.${UNRES_MINOR} build ${UNRES_PATCH}' -") - -CINFO_FORMAT(${CINFO} "Compiled" "${DATE}" ) -CINFO_FORMAT(${CINFO} "Compiled by" "$ENV{USER}@$ENV{HOST}" ) -CINFO_FORMAT(${CINFO} "OS name:" "${CMAKE_SYSTEM_NAME}" ) -CINFO_FORMAT(${CINFO} "OS release:" "${CMAKE_SYSTEM}" ) -CINFO_FORMAT(${CINFO} "Fortran Compiler:" "${CMAKE_Fortran_COMPILER}" ) -CINFO_FORMAT(${CINFO} "MD Force field:" "${UNRES_MD_FF}" ) -CINFO_FORMAT(${CINFO} "CPPFLAGS =" "${CPPFLAGS}") - -FILE(APPEND ${CINFO} -" write(iout,*)'++++ End of compile info ++++' - return - end ") - -# add include path -set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f PROPERTY COMPILE_FLAGS "${FFLAGS0} -I${CMAKE_CURRENT_SOURCE_DIR}") - -#========================================= -# Set full unres MD sources -#========================================= -set(UNRES_MD_DFA_SRCS ${UNRES_MD_DFA_SRC0} ${UNRES_MD_DFA_SRC3} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f ) - - -#========================================= -# Build the binary -#========================================= -add_executable(UNRES_BIN-MD-DFA ${UNRES_MD_DFA_SRCS} ) -set_target_properties(UNRES_BIN-MD-DFA PROPERTIES OUTPUT_NAME ${UNRES_BIN}) -set_property(TARGET UNRES_BIN-MD-DFA PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin ) -#add_dependencies (${UNRES_BIN} ${UNRES_XDRFLIB}) - - -#========================================= -# Link libraries -#========================================= -# link MPI library (libmpich.a) -if(UNRES_WITH_MPI) - target_link_libraries( UNRES_BIN-MD-DFA ${MPI_Fortran_LIBRARIES} ) -endif(UNRES_WITH_MPI) -# link libxdrf.a -#message("UNRES_XDRFLIB=${UNRES_XDRFLIB}") -target_link_libraries( UNRES_BIN-MD-DFA xdrf ) - -#========================================= -# TESTS -#========================================= - -#-- Copy all the data files from the test directory into the source directory -#SET(UNRES_TEST_FILES -# ala10.inp -# ) - -#FOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) -# SET (unres_test_dest "${CMAKE_CURRENT_BINARY_DIR}/${UNRES_TEST_FILE}") -# MESSAGE (STATUS " Copying ${UNRES_TEST_FILE} from ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} to ${unres_test_dest}") -# ADD_CUSTOM_COMMAND ( -# TARGET ${UNRES_BIN} -# POST_BUILD -# COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} ${unres_test_dest} -# ) -#ENDFOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) - -#========================================= -# Generate data test files -#========================================= -# test_single_ala.sh -#========================================= -# -# Set parmaeters depending on force field -if(UNRES_MD_FF STREQUAL "GAB") - set(UNRES_BONDPAR "bond.parm") -elseif(UNRES_MD_FF STREQUAL "E0LL2Y") - set(UNRES_BONDPAR "bond_AM1.parm") -endif(UNRES_MD_FF STREQUAL "GAB") - -FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/scripts/test_single_ala.sh -"#!/bin/sh -export POT=GB -export PREFIX=ala10 -#----------------------------------------------------------------------------- -UNRES_BIN=${CMAKE_BINARY_DIR}/bin/${UNRES_BIN} -#----------------------------------------------------------------------------- -DD=${CMAKE_SOURCE_DIR}/PARAM -export BONDPAR=$DD/${UNRES_BONDPAR} -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 -") - -# -# File permissions workaround -# -FILE( COPY ${CMAKE_CURRENT_BINARY_DIR}/scripts/test_single_ala.sh - DESTINATION ${CMAKE_CURRENT_BINARY_DIR} - FILE_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE -) - - - -#========================================= -# ala10.inp -#========================================= - -file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/ala10.inp -"ala10 unblocked -SEED=-1111333 MD ONE_LETTER rescale_mode=2 -nstep=15000 ntwe=100 ntwx=1000 dt=0.1 lang=0 tbf t_bath=300 damax=1.0 & -reset_moment=1000 reset_vel=1000 -WLONG=1.35279 WSCP=1.59304 WELEC=0.71534 WBOND=1.00000 WANG=1.13873 & -WSCLOC=0.16258 WTOR=1.98599 WTORD=1.57069 WCORRH=0.42887 WCORR5=0.00000 & -WCORR6=0.00000 WEL_LOC=0.16036 WTURN3=1.68722 WTURN4=0.66230 WTURN6=0.00000 & -WVDWPP=0.11371 WHPB=1.00000 & -CUTOFF=7.00000 WCORR4=0.00000 -12 -XAAAAAAAAAAX - 0 - 0 - 90.0000 90.0000 90.0000 90.000 90.000 90.000 90.000 90.000 - 90.0000 90.0000 - 180.0000 180.0000 180.0000 180.000 180.000 180.000 180.000 180.000 - 180.0000 - 110.0000 110.0000 110.0000 100.000 110.000 100.000 110.000 110.000 - 110.0000 110.0000 - -120.0000 -120.0000 -120.000 -120.000 -120.000 -120.000 -120.000 -120.000 - -120.0000 -120.0000 -") - - -# Add tests - -if(NOT UNRES_WITH_MPI) - - add_test(NAME UNRES_MD_DFA_Ala10 COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh ) - -else(NOT UNRES_WITH_MPI) - - - add_test(NAME UNRES_MD_DFA_MPI_Ala10 COMMAND mpiexec -boot ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh ) - -endif(NOT UNRES_WITH_MPI) - diff --git a/source/unres/src_MD_DFA/COMMON.BOUNDS b/source/unres/src_MD_DFA/COMMON.BOUNDS deleted file mode 100644 index f3859ae..0000000 --- a/source/unres/src_MD_DFA/COMMON.BOUNDS +++ /dev/null @@ -1,2 +0,0 @@ - double precision phibound(2,maxres) - common /bounds/ phibound diff --git a/source/unres/src_MD_DFA/COMMON.CACHE b/source/unres/src_MD_DFA/COMMON.CACHE deleted file mode 100644 index 8cb0cbc..0000000 --- a/source/unres/src_MD_DFA/COMMON.CACHE +++ /dev/null @@ -1,6 +0,0 @@ - integer ncache,CachSrc(max_cache),isent(max_cache), - & iused(max_cache) - logical cache_update - double precision ecache(max_cache),xcache(maxvar,max_cache) - common /cache/ ecache,xcache,ncache,CachSrc,isent,iused, - & cache_update diff --git a/source/unres/src_MD_DFA/COMMON.CALC b/source/unres/src_MD_DFA/COMMON.CALC deleted file mode 100644 index 67b4bb9..0000000 --- a/source/unres/src_MD_DFA/COMMON.CALC +++ /dev/null @@ -1,15 +0,0 @@ - integer i,j,k,l - double precision erij,rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, - & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, - & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, - & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, - & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, - & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, - & dsci_inv,dscj_inv,gg - common /calc/ erij(3),rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, - & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, - & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, - & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, - & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, - & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, - & dsci_inv,dscj_inv,gg(3),i,j diff --git a/source/unres/src_MD_DFA/COMMON.CHAIN b/source/unres/src_MD_DFA/COMMON.CHAIN deleted file mode 100644 index 6e19f8d..0000000 --- a/source/unres/src_MD_DFA/COMMON.CHAIN +++ /dev/null @@ -1,13 +0,0 @@ - integer nres,nsup,nstart_sup,nz_start,nz_end,iz_sc, - & nres0,nstart_seq - double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm,t,r, - & prod,rt,dc_work,cref,crefjlee,dc_norm2 - common /chain/ c(3,maxres2+2),dc(3,0:maxres2),dc_old(3,0:maxres2), - & xloc(3,maxres),xrot(3,maxres),dc_norm(3,0:maxres2), - & dc_norm2(3,0:maxres2), - & dc_work(MAXRES6),nres,nres0 - common /rotmat/ t(3,3,maxres),r(3,3,maxres),prod(3,3,maxres), - & rt(3,3,maxres) - common /refstruct/ cref(3,maxres2+2),crefjlee(3,maxres2+2), - & nsup,nstart_sup,nstart_seq - common /from_zscore/ nz_start,nz_end,iz_sc diff --git a/source/unres/src_MD_DFA/COMMON.CONTACTS b/source/unres/src_MD_DFA/COMMON.CONTACTS deleted file mode 100644 index 5b3a90d..0000000 --- a/source/unres/src_MD_DFA/COMMON.CONTACTS +++ /dev/null @@ -1,82 +0,0 @@ -C Change 12/1/95 - common block CONTACTS1 included. - integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont - double precision facont,gacont - common /contacts/ ncont,ncont_ref,icont(2,maxcont), - & icont_ref(2,maxcont) - common /contacts1/ facont(maxconts,maxres), - & gacont(3,maxconts,maxres), - & num_cont(maxres),jcont(maxconts,maxres) -C 12/26/95 - H-bonding contacts - common /contacts_hb/ - & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), - & gacontp_hb3(3,maxconts,maxres), - & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), - & gacontm_hb3(3,maxconts,maxres), - & gacont_hbr(3,maxconts,maxres), - & grij_hb_cont(3,maxconts,maxres), - & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), - & ees0m(maxconts,maxres),d_cont(maxconts,maxres), - & num_cont_hb(maxres),jcont_hb(maxconts,maxres) -C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole -C interactions -c 7/25/08 Commented out; not needed when cumulants used -C Interactions of pseudo-dipoles generated by loc-el interactions. -c double precision dip,dipderg,dipderx -c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), -c & dipderx(3,5,4,maxconts,maxres) -C 10/30/99 Added other pre-computed vectors and matrices needed -C to calculate three - six-order el-loc correlation terms - double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, - & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder, - & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der - common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), - & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), - & obrot_der(2,maxres),obrot2_der(2,maxres) -C This common block contains vectors and matrices dependent on a single -C amino-acid residue. - common /precomp1/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres), - & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres), - & Dtobr2(2,maxres),Dtobr2der(2,maxres), - & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), - & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), - & DtUg2(2,2,maxres),DtUg2der(2,2,maxres) -C This common block contains vectors and matrices dependent on two -C consecutive amino-acid residues. - double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, - & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder - common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), - & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), - & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), - & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres), - & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres) - double precision costab,sintab,costab2,sintab2 - common /rotat_old/ costab(maxres),sintab(maxres), - & costab2(maxres),sintab2(maxres) -C This common block contains dipole-interaction matrices and their -C Cartesian derivatives. - double precision a_chuj,a_chuj_der - common /dipmat/ a_chuj(2,2,maxconts,maxres), - & a_chuj_der(2,2,3,5,maxconts,maxres) - double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, - & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, - & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont - common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), - & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), - & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), - & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), - & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), - & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), - & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), - & g_contij(3,2),ekont -C 12/13/2008 (again Poland-Jaruzel war anniversary) -C RE: Parallelization of 4th and higher order loc-el correlations - integer ncont_sent,ncont_recv,iint_sent,iisent_local, - & itask_cont_from,itask_cont_to,ntask_cont_from,ntask_cont_to, - & nat_sent,iat_sent,iturn3_sent,iturn4_sent,iturn3_sent_local, - & iturn4_sent_local - common /contdistrib/ ncont_sent(maxres),ncont_recv(maxres), - & iint_sent(4,maxres,maxres),iint_sent_local(4,maxres,maxres), - & iturn3_sent(4,maxres),iturn4_sent(4,maxres), - & iturn3_sent_local(4,maxres),iturn4_sent_local(4,maxres), - & nat_sent,iat_sent(maxres),itask_cont_from(0:max_fg_procs-1), - & itask_cont_to(0:max_fg_procs-1),ntask_cont_from,ntask_cont_to diff --git a/source/unres/src_MD_DFA/COMMON.CONTACTS.moment b/source/unres/src_MD_DFA/COMMON.CONTACTS.moment deleted file mode 100644 index d07a0f0..0000000 --- a/source/unres/src_MD_DFA/COMMON.CONTACTS.moment +++ /dev/null @@ -1,68 +0,0 @@ -C Change 12/1/95 - common block CONTACTS1 included. - integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont - double precision facont,gacont - common /contacts/ ncont,ncont_ref,icont(2,maxcont), - & icont_ref(2,maxcont) - common /contacts1/ facont(maxconts,maxres), - & gacont(3,maxconts,maxres), - & num_cont(maxres),jcont(maxconts,maxres) -C 12/26/95 - H-bonding contacts - common /contacts_hb/ - & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), - & gacontp_hb3(3,maxconts,maxres), - & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), - & gacontm_hb3(3,maxconts,maxres), - & gacont_hbr(3,maxconts,maxres), - & grij_hb_cont(3,maxconts,maxres), - & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), - & ees0m(maxconts,maxres),d_cont(maxconts,maxres), - & num_cont_hb(maxres),jcont_hb(maxconts,maxres) -C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole -C interactions -C Interactions of pseudo-dipoles generated by loc-el interactions. - double precision dip,dipderg,dipderx - common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), - & dipderx(3,5,4,maxconts,maxres) -C 10/30/99 Added other pre-computed vectors and matrices needed -C to calculate three - six-order el-loc correlation terms - double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, - & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder, - & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der - common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), - & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), - & obrot_der(2,maxres),obrot2_der(2,maxres) -C This common block contains vectors and matrices dependent on a single -C amino-acid residue. - common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres), - & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), - & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), - & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres), - & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres) -C This common block contains vectors and matrices dependent on two -C consecutive amino-acid residues. - double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, - & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder - common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), - & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), - & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), - & DtUg2EUg(2,2,maxres),DtUg2EUgder(2,2,2,maxres), - & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres) - double precision costab,sintab,costab2,sintab2 - common /rotat_old/ costab(maxres),sintab(maxres), - & costab2(maxres),sintab2(maxres),muder(2,maxres) -C This common block contains dipole-interaction matrices and their -C Cartesian derivatives. - double precision a_chuj,a_chuj_der - common /dipmat/ a_chuj(2,2,maxconts,maxres), - & a_chuj_der(2,2,3,5,maxconts,maxres) - double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, - & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, - & AEAb2,AEAb2derg,AEAb2derx - common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), - & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), - & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), - & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), - & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), - & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), - & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), - & g_contij(3,2),ekont diff --git a/source/unres/src_MD_DFA/COMMON.CONTROL b/source/unres/src_MD_DFA/COMMON.CONTROL deleted file mode 100644 index c12ef3a..0000000 --- a/source/unres/src_MD_DFA/COMMON.CONTROL +++ /dev/null @@ -1,13 +0,0 @@ - integer modecalc,iscode,indpdb,indback,indphi,iranconf,icheckgrad, - & inprint,i2ndstr,mucadyn,constr_dist - logical minim,refstr,pdbref,outpdb,outmol2,overlapsc,energy_dec, - & sideadd,lsecondary,read_cart,unres_pdb, - & vdisulf,searchsc,lmuca,dccart,extconf,out1file, - & gnorm_check,gradout,split_ene - common /cntrl/ modecalc,iscode,indpdb,indback,indphi,iranconf, - & icheckgrad,minim,i2ndstr,refstr,pdbref,outpdb,outmol2,iprint, - & overlapsc,energy_dec,sideadd,lsecondary,read_cart,unres_pdb - & ,vdisulf,searchsc,lmuca,dccart,mucadyn,extconf,out1file, - & constr_dist,gnorm_check,gradout,split_ene -C... minim = .true. means DO minimization. -C... energy_dec = .true. means print energy decomposition matrix diff --git a/source/unres/src_MD_DFA/COMMON.DBASE b/source/unres/src_MD_DFA/COMMON.DBASE deleted file mode 100644 index 4f07780..0000000 --- a/source/unres/src_MD_DFA/COMMON.DBASE +++ /dev/null @@ -1,3 +0,0 @@ - common /struct/ cart_base(3,maxres_base,maxseq),str_nam(maxseq), - & nres_base(3,maxseq),nseq - character*8 str_nam diff --git a/source/unres/src_MD_DFA/COMMON.DERIV b/source/unres/src_MD_DFA/COMMON.DERIV deleted file mode 100644 index f065a41..0000000 --- a/source/unres/src_MD_DFA/COMMON.DERIV +++ /dev/null @@ -1,37 +0,0 @@ - double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gelc_long, - & gvdwpp,gel_loc,gel_loc_long,gvdwc_scpp, - & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gloc_x,dtheta,dphi,dalpha, - & domega,gscloc,gsclocx,gradcorr,gradcorr_long,gradcorr5_long, - & gradcorr6_long,gcorr6_turn_long,gvdwcT,gvdwxT - integer nfl,icg - common /derivatT/ gvdwcT(3,maxres),gvdwxT(3,maxres) - common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), - & gradx(3,maxres,2),gradc(3,maxres,2),gvdwx(3,maxres), - & gvdwc(3,maxres),gelc(3,maxres),gelc_long(3,maxres), - & gvdwpp(3,maxres),gvdwc_scpp(3,maxres), - & gradx_scp(3,maxres),gvdwc_scp(3,maxres),ghpbx(3,maxres), - & ghpbc(3,maxres),gloc(maxvar,2),gradcorr(3,maxres), - & gradcorr_long(3,maxres),gradcorr5_long(3,maxres), - & gradcorr6_long(3,maxres),gcorr6_turn_long(3,maxres), - & gradxorr(3,maxres),gradcorr5(3,maxres),gradcorr6(3,maxres), - & gloc_x(maxvar,2),gel_loc(3,maxres),gel_loc_long(3,maxres), - & gcorr3_turn(3,maxres), - & gcorr4_turn(3,maxres),gcorr6_turn(3,maxres),gradb(3,maxres), - & gradbx(3,maxres),gel_loc_loc(maxvar),gel_loc_turn3(maxvar), - & gel_loc_turn4(maxvar),gel_loc_turn6(maxvar),gcorr_loc(maxvar), - & g_corr5_loc(maxvar),g_corr6_loc(maxvar),gsccorc(3,maxres), - & gsccorx(3,maxres),gsccor_loc(maxres),dtheta(3,2,maxres), - & gscloc(3,maxres),gsclocx(3,maxres), - & dphi(3,3,maxres),dalpha(3,3,maxres),domega(3,3,maxres),nfl,icg, - & gdfad(3,maxres),gdfat(3,maxres),gdfan(3,maxres),gdfab(3,maxres) - double precision derx,derx_turn - common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2) - double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres), - & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres), - & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres), - & dZZ_XYZtab(3,maxres) - common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab, - & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab - integer igrad_start,igrad_end,jgrad_start(maxres), - & jgrad_end(maxres) - common /mpgrad/ igrad_start,igrad_end,jgrad_start,jgrad_end diff --git a/source/unres/src_MD_DFA/COMMON.DFA b/source/unres/src_MD_DFA/COMMON.DFA deleted file mode 100644 index c6add4f..0000000 --- a/source/unres/src_MD_DFA/COMMON.DFA +++ /dev/null @@ -1,101 +0,0 @@ -C ======= -C COMMON.DFA -C ======= -C 2010/12/20 By Juyong Lee -C -c parameter -C [ 8 * ( Nres - 8 ) ] distance restraints -C [ 2 * ( Nres - 8 ) ] angle restraints -C [ Nres ] neighbor restraints -C Total : ~ 11 * Nres restraints -C -C - INTEGER IDFAMAX,IDFAMX2,IDFACMD,IDMAXMIN, MAXN - PARAMETER(IDFAMAX=4000,IDFAMX2=1000,IDFACMD=500,IDMAXMIN=500) - PARAMETER(MAXN=4) - real*8 wwdist,wwangle,wwnei - parameter(wwdist=1.0d0,wwangle=1.0d0,wwnei=1.0d0) - -C IDFAMAX - maximum number of DFA restraint including distance, angle and -C number of neighbors ( Max of assign statement ) -C IDFAMX2 - maximum number of atoms which are targets of restraints -C IDFACMD - maximum number of 'DFA' command call -C IDMAXMIN - Maximum number of minima of dist, angle and neighbor info. from fragments -C MAXN - Maximum Number of shell, currently 4 -C MAXRES - Maximum number of CAs - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc -C INTEGER -C DFANUM - Number of ALL DFA restrants -c IDFA[DIS, PHI, THE, NEI] - NUMBER of restraints -c IDISNUM - number of minima for a distance restraint -c IPHINUM - number of minima for a phi angle restraint -c ITHENUM - number of minima for a theta angle restraint -c INEINUM - number of minima for a number of neighbors restraint - -c IDISLIS - atom number of two atoms for distance restraint -c IPHILIS - atom numbers of four atoms for angle restraint -c ITHELIS - atom numbers of four atoms for angle restraint -c INEILIS - atom number of center of neighbor calculation -c JNEILIS - atom number of target of neighboring calculation -c JNEINUM - number of target atoms of neighboring term -C KSHELL - SHELL number - -C ishiftca - index shift for CA atoms in UNRES (1 if the 1st aa != GLY) -C ilastca - index of the last CA atom in UNRES (nres-1 if last aa != GLY) - -C old only for CHARMM -C STOAGDF - Store assign information ( How many assign within one command ) -C NMAP - mapping between dfanum and ndis, nphi, nthe, nnei - - INTEGER IDFADIS,IDFAPHI,IDFATHE,IDFANEI, - & IDISLIS,IPHILIS,ITHELIS,INEILIS, - & IDISNUM,IPHINUM,ITHENUM,INEINUM, - & FNEI,DFACMD, DFANUM, - & NCA,ICAIDX, - & STOAGDF, NMAP, IDFACAT, KDISNUM, KSHELL - & ishiftca,ilastca - COMMON /IDFA/ DFACMD, DFANUM, - & IDFADIS, IDFAPHI, IDFANEI, IDFATHE, - & IDISNUM(IDFAMAX), IPHINUM(IDFAMAX), - & ITHENUM(IDFAMAX), INEINUM(IDFAMAX), - & FNEI(IDFAMAX,IDMAXMIN), IDISLIS(2,IDFAMAX), - & IPHILIS(5,IDFAMAX), ITHELIS(5,IDFAMAX), - & INEILIS(IDFAMAX), - & KSHELL(IDFAMAX), - & IDFACAT(IDFACMD), - & KDISNUM(IDFAMAX), - & NCA, ICAIDX(MAXRES) - COMMON /IDFA2/ ishiftca,ilastca - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C REAL VARIABLES -C -c SCC[DIST, PHI, THE] - weight of each calculations -c FDIST - distance minima -C FPHI - phi minima -c FTHE - theta minima -C DFAEXP : calculate expential function in advance -C - REAL*8 SCCDIST, SCCPHI, SCCTHE, SCCNEI, FDIST, FPHI1, FPHI2, - & FTHE1, FTHE2, - & DIS_INC, PHI_INC, THE_INC, NEI_INC, BETA_INC, - & WSHET, EDFABET, - & CK, SCK, S1, S2 -c & ,DFAEXP - - COMMON /RDFA/ SCCDIST(IDFAMAX,IDMAXMIN),FDIST(IDFAMAX,IDMAXMIN), - & SCCPHI(IDFAMAX,IDMAXMIN), SCCTHE(IDFAMAX,IDMAXMIN), - & SCCNEI(IDFAMAX,IDMAXMIN), - & FPHI1(IDFAMAX,IDMAXMIN), FPHI2(IDFAMAX,IDMAXMIN), - & FTHE1(IDFAMAX,IDMAXMIN), FTHE2(IDFAMAX,IDMAXMIN), - & DIS_INC, PHI_INC, THE_INC, NEI_INC, BETA_INC, - & WSHET(MAXRES,MAXRES), EDFABET, - & CK(4),SCK(4),S1(4),S2(4) -c & ,DFAEXP(15001), - - DATA CK/1.0D0,1.58740105197D0,2.08008382305D0,2.51984209979D0/ - DATA SCK/1.0D0,1.25992104989D0,1.44224957031D0,1.58740105197D0/ - DATA S1/3.75D0,5.75D0,7.75D0,9.75D0/ - DATA S2/4.25D0,6.25D0,8.25D0,10.25D0/ diff --git a/source/unres/src_MD_DFA/COMMON.DISTFIT b/source/unres/src_MD_DFA/COMMON.DISTFIT deleted file mode 100644 index 683228a..0000000 --- a/source/unres/src_MD_DFA/COMMON.DISTFIT +++ /dev/null @@ -1,14 +0,0 @@ -c parameter (maxres22=maxres*(maxres+1)/2) - parameter (maxres22=1) - double precision w,d0,DRDG,DD,H,XX - integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0, - 1 lvar_frag,svar_frag,avar_frag - COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3) -csa COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3), -csa 1 lvar_frag(mxio,3),svar_frag(mxio,3), -csa 2 avar_frag(mxio,5) - COMMON /WAGI/ w(MAXRES22),d0(MAXRES22) - COMMON /POCHODNE/ NX,NY,DRDG(MAXRES22,MAXRES),DD(MAXRES22), - 1 H(MAXRES,MAXRES),XX(MAXRES) - COMMON /frozen/ mask(maxres) - COMMON /store0/ nhpb0 diff --git a/source/unres/src_MD_DFA/COMMON.FFIELD b/source/unres/src_MD_DFA/COMMON.FFIELD deleted file mode 100644 index 29c73f0..0000000 --- a/source/unres/src_MD_DFA/COMMON.FFIELD +++ /dev/null @@ -1,26 +0,0 @@ -C----------------------------------------------------------------------- -C The following COMMON block selects the type of the force field used in -C calculations and defines weights of various energy terms. -C 12/1/95 wcorr added -C----------------------------------------------------------------------- - integer n_ene_comp,rescale_mode - common /ffield/ wsc,wscp,welec,wbond,wstrain,wtor,wtor_d,wang, - & wscloc,wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4, - & wturn6,wvdwpp,wsct,weights(n_ene),temp0, - & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta, - & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp, - & rescale_mode - common /potentials/ potname(5) - character*3 potname -C----------------------------------------------------------------------- -C wlong,welec,wtor,wang,wscloc are the weight of the energy terms -C corresponding to side-chain, electrostatic, torsional, valence-angle, -C and local side-chain terms. -C -C IPOT determines which SC...SC interaction potential will be used: -C 1 - LJ: 2n-n Lennard-Jones -C 2 - LJK: 2n-n Kihara type (shifted Lennard-Jones) -C 3 - BP; Berne-Pechukas (angular dependence) -C 4 - GB; Gay-Berne (angular dependence) -C 5 - GBV; Gay-Berne-Vorobjev; angularly-dependent Kihara potential -C------------------------------------------------------------------------ diff --git a/source/unres/src_MD_DFA/COMMON.GEO b/source/unres/src_MD_DFA/COMMON.GEO deleted file mode 100644 index 8cfbbde..0000000 --- a/source/unres/src_MD_DFA/COMMON.GEO +++ /dev/null @@ -1,2 +0,0 @@ - double precision pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin - common /geo/ pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin diff --git a/source/unres/src_MD_DFA/COMMON.HAIRPIN b/source/unres/src_MD_DFA/COMMON.HAIRPIN deleted file mode 100644 index f103268..0000000 --- a/source/unres/src_MD_DFA/COMMON.HAIRPIN +++ /dev/null @@ -1,5 +0,0 @@ - integer nharp_seed(max_seed),nharp_tot, - & iharp_seed(4,maxres/3,max_seed),iharp_use(0:4,maxres/3,max_seed), - & nharp_use(max_seed) - common /spinka/ nharp_seed,nharp_tot,iharp_seed,iharp_use, - & nharp_use diff --git a/source/unres/src_MD_DFA/COMMON.HEADER b/source/unres/src_MD_DFA/COMMON.HEADER deleted file mode 100644 index 7154812..0000000 --- a/source/unres/src_MD_DFA/COMMON.HEADER +++ /dev/null @@ -1,2 +0,0 @@ - character*80 titel - common /header/ titel diff --git a/source/unres/src_MD_DFA/COMMON.INFO b/source/unres/src_MD_DFA/COMMON.INFO deleted file mode 100644 index 4f63708..0000000 --- a/source/unres/src_MD_DFA/COMMON.INFO +++ /dev/null @@ -1,21 +0,0 @@ -c NPROCS - total number of processors; -c MyID - processor's ID; -c MasterID - master processor's ID. - integer MyId,AllGrp,DontCare,MasterId,WhatsUp,ifinish - logical koniec - integer tag,status(MPI_STATUS_SIZE) - common /info/ myid,masterid,allgrp,dontcare, - & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1) -c... 5/12/96 - added variables for collective communication -c FGPROCS - Number of fine-grain processors per coarse-grain task; -c NCTASKS - Number of coarse-grain tasks; -c MYGROUP - label of the processor's FG group id; -c BOSSID - ID of group's master; -c FGLIST - list of group's FG processors. -c MSGLEN_VAR - length of the vector of variables passed to the fine-grain -c slave processors - integer fgprocs,nctasks,mygroup,bossid,cglabel, - & cglist(max_cg_procs),cgGroupID,fglist(max_fg_procs), - & fgGroupID,MyRank - common /info1/ fgprocs,nctasks,mygroup,bossid,cglabel,cglist, - & cgGroupID,fglist,fgGroupID,MyRank,msglen_var diff --git a/source/unres/src_MD_DFA/COMMON.INTERACT b/source/unres/src_MD_DFA/COMMON.INTERACT deleted file mode 100644 index fabad93..0000000 --- a/source/unres/src_MD_DFA/COMMON.INTERACT +++ /dev/null @@ -1,34 +0,0 @@ - double precision aa,bb,augm,aad,bad,app,bpp,ale6,ael3,ael6 - integer expon,expon2 - integer nnt,nct,nint_gr,istart,iend,itype,itel,itypro, - & ielstart,ielend,ielstart_vdw,ielend_vdw,nscp_gr,iscpstart, - & iscpend,iatsc_s,iatsc_e, - & iatel_s,iatel_e,iatscp_s,iatscp_e,iatel_s_vdw,iatel_e_vdw, - & ispp,iscp - common /interact/aa(ntyp,ntyp),bb(ntyp,ntyp),augm(ntyp,ntyp), - & aad(ntyp,2),bad(ntyp,2),app(2,2),bpp(2,2),ael6(2,2),ael3(2,2), - & expon,expon2,nnt,nct,nint_gr(maxres),istart(maxres,maxint_gr), - & iend(maxres,maxint_gr),itype(maxres),itel(maxres),itypro, - & ielstart(maxres),ielend(maxres),ielstart_vdw(maxres), - & ielend_vdw(maxres),nscp_gr(maxres), - & iscpstart(maxres,maxint_gr),iscpend(maxres,maxint_gr), - & iatsc_s,iatsc_e,iatel_s,iatel_e,iatel_s_vdw,iatel_e_vdw, - & iatscp_s,iatscp_e,ispp,iscp -C 12/1/95 Array EPS included in the COMMON block. - double precision eps,sigma,sigmaii,rs0,chi,chip,alp,sigma0,sigii, - & rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp - common /body/eps(ntyp,ntyp),sigma(0:ntyp1,0:ntyp1), - & sigmaii(ntyp,ntyp), - & rs0(ntyp,ntyp),chi(ntyp,ntyp),chip(ntyp),alp(ntyp),sigma0(ntyp), - & sigii(ntyp),rr0(ntyp),r0(ntyp,ntyp),r0e(ntyp,ntyp),r0d(ntyp,2), - & rpp(2,2),epp(2,2),elpp6(2,2),elpp3(2,2),eps_scp(20,2),rscp(20,2) -c 12/5/03 modified 09/18/03 Bond stretching parameters. - double precision vbldp0,vbldsc0,akp,aksc,abond0 - integer nbondterm - common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp, - & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp),nbondterm(ntyp) - double precision wdti,wdti2,wdti4,wdti8, - & wdtii,wdtii2,wdtii4,wdtii8 - common /nosehoover_dt/ - & wdti(maxyosh),wdti2(maxyosh),wdti4(maxyosh),wdti8(maxyosh), - & wdtii(maxyosh),wdtii2(maxyosh),wdtii4(maxyosh),wdtii8(maxyosh) diff --git a/source/unres/src_MD_DFA/COMMON.IOUNITS b/source/unres/src_MD_DFA/COMMON.IOUNITS deleted file mode 100644 index 49b6db3..0000000 --- a/source/unres/src_MD_DFA/COMMON.IOUNITS +++ /dev/null @@ -1,69 +0,0 @@ -C----------------------------------------------------------------------- -C I/O units used by the program -C----------------------------------------------------------------------- -C 9/18/99 - unit ifourier and filename fouriername included to identify -C the file from which the coefficients of second-order Fourier expansion -C of the local-interaction energy are read. -C 8/9/01 - file for SCP interaction constants named scpname (unit iscpp) -C included. -C----------------------------------------------------------------------- -C General I/O units & files - integer inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,irotam, - & itorp,itordp,ifourier,ielep,isidep,iscpp,icbase,istat, - & ientin,ientout,izs1,isecpred,ibond,irest2,iifrag,icart, - & irest1,isccor,ithep_pdb,irotam_pdb - common /iounits/ inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep, - & irotam,itorp,itordp,ifourier,ielep,isidep,iscpp,icbase, - & istat,ientin,ientout,izs1,isecpred,ibond,irest2,iifrag, - & icart,irest1,isccor,ithep_pdb,irotam_pdb - character*256 outname,intname,pdbname,mol2name,statname,intinname, - & entname,prefix,secpred,rest2name,qname,cartname,tmpdir, - & mremd_rst_name,curdir,pref_orig - character*4 liczba - common /fnames/ outname,intname,pdbname,mol2name,statname, - & intinname,entname,prefix,pot,secpred,rest2name,qname, - & cartname,tmpdir,mremd_rst_name,curdir,pref_orig,liczba -C CSA I/O units & files - character*256 csa_rbank,csa_seed,csa_history,csa_bank, - & csa_bank1,csa_alpha,csa_alpha1,csa_bankt,csa_int, - & csa_bank_reminimized,csa_native_int,csa_in - common /csafiles/ csa_rbank,csa_seed,csa_history,csa_bank, - & csa_bank1,csa_alpha,csa_alpha1,csa_bankt,csa_int, - & csa_bank_reminimized,csa_native_int,csa_in - integer icsa_rbank,icsa_seed,icsa_history,icsa_bank, - & icsa_bank1,icsa_alpha,icsa_alpha1,icsa_bankt,icsa_int, - & icsa_bank_reminimized,icsa_native_int,icsa_in,icsa_pdb - common /csaunits/ icsa_rbank,icsa_seed,icsa_history,icsa_bank, - & icsa_bank1,icsa_alpha,icsa_alpha1,icsa_bankt,icsa_int, - & icsa_bank_reminimized,icsa_native_int,icsa_in,icsa_pdb -C Parameter files - character*256 bondname,thetname,rotname,torname,tordname, - & fouriername,elename,sidename,scpname,sccorname,patname, - & thetname_pdb,rotname_pdb - common /parfiles/ bondname,thetname,rotname,torname,tordname, - & fouriername,elename,sidename,scpname,sccorname,patname, - & thetname_pdb,rotname_pdb - character*3 pot -C----------------------------------------------------------------------- -C INP - main input file -C IOUT - list file -C IGEOM - geometry output in the form of virtual-chain internal coordinates -C INTIN - geometry input (for multiple conformation processing) in int. coords. -C IPDB - Cartesian-coordinate output in PDB format -C IMOL2 - Cartesian-coordinate output in Tripos mol2 format -C IPDBIN - PDB input file -C ITHEP - virtual-bond torsional angle parametrs -C IROTAM - side-chain geometry and local-interaction parameters -C ITORP - torsional parameters -C ITORDP - double torsional parameters -C IFOURIER - coefficients of the expansion of local-interaction energy -C IELEP - electrostatic-interaction parameters -C ISIDEP - side-chain interaction parameters. -C ISCPP - SCp interaction parameters. -C IBOND - virtual-bond constant parameters and moments of inertia. -C ISCCOR - parameters of the potential of SCCOR term -C ICBASE - data base with Cartesian coords of known structures. -C ISTAT - energies and other conf. characteristics from an MCM run. -C IENTIN - entropy from preceeding simulation(s) to be read in. -C SECPRED - SECONDARY STRUCTURE PREDICTION for dihedral constraint generation. -C----------------------------------------------------------------------- diff --git a/source/unres/src_MD_DFA/COMMON.LANGEVIN b/source/unres/src_MD_DFA/COMMON.LANGEVIN deleted file mode 100644 index 6a703e2..0000000 --- a/source/unres/src_MD_DFA/COMMON.LANGEVIN +++ /dev/null @@ -1,21 +0,0 @@ - double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), - & fricmat(MAXRES2,MAXRES2),fric_work(MAXRES6), - & stoch_work(MAXRES6), - & fricgam(MAXRES6),fricvec(MAXRES2,MAXRES2), - & pfric_mat(MAXRES2,MAXRES2),vfric_mat(MAXRES2,MAXRES2), - & afric_mat(MAXRES2,MAXRES2),prand_mat(MAXRES2,MAXRES2), - & vrand_mat1(MAXRES2,MAXRES2),vrand_mat2(MAXRES2,MAXRES2), - & pfric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), - & afric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), - & vfric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), - & prand0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), - & vrand0_mat1(MAXRES2,MAXRES2,0:maxflag_stoch), - & vrand0_mat2(MAXRES2,MAXRES2,0:maxflag_stoch), - & mt1(maxres2,maxres2),mt2(maxres2,maxres2),mt3(maxres2,maxres2) - logical flag_stoch(0:maxflag_stoch) - common /langforc/ friction,stochforc, - & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1, - & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat, - & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1, - & vrand0_mat2,flag_stoch - common /langmat/ mt1,mt2,mt3 diff --git a/source/unres/src_MD_DFA/COMMON.LANGEVIN.lang0 b/source/unres/src_MD_DFA/COMMON.LANGEVIN.lang0 deleted file mode 100644 index 354a0c4..0000000 --- a/source/unres/src_MD_DFA/COMMON.LANGEVIN.lang0 +++ /dev/null @@ -1,11 +0,0 @@ - double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), - & fricmat(MAXRES2,MAXRES2),fric_work(MAXRES6), - & stoch_work(MAXRES6), - & fricgam(MAXRES6),fricvec(MAXRES2,MAXRES2) - logical flag_stoch(0:maxflag_stoch) - common /langforc/ friction,stochforc, - & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1, - & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat, - & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1, - & vrand0_mat2,flag_stoch - common /langmat/ mt1,mt2,mt3 diff --git a/source/unres/src_MD_DFA/COMMON.LOCAL b/source/unres/src_MD_DFA/COMMON.LOCAL deleted file mode 100644 index a3f68dc..0000000 --- a/source/unres/src_MD_DFA/COMMON.LOCAL +++ /dev/null @@ -1,55 +0,0 @@ - double precision a0thet,athet,bthet,polthet,gthet,theta0,sig0, - & sigc0,dsc,dsc_inv,bsc,censc,gaussc,dsc0 - integer nlob -C Parameters of the virtual-bond-angle probability distribution - common /thetas/ a0thet(ntyp),athet(2,ntyp),bthet(2,ntyp), - & polthet(0:3,ntyp),gthet(3,ntyp),theta0(ntyp),sig0(ntyp), - & sigc0(ntyp) -C Parameters of the side-chain probability distribution - common /sclocal/ dsc(ntyp1),dsc_inv(ntyp1),bsc(maxlob,ntyp), - & censc(3,maxlob,ntyp),gaussc(3,3,maxlob,ntyp),dsc0(ntyp1), - & nlob(ntyp1) -C Parameters of ab initio-derived potential of virtual-bond-angle bending - integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, - & ithetyp(ntyp1),nntheterm - double precision aa0thet(maxthetyp1,maxthetyp1,maxthetyp1), - & aathet(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1), - & bbthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ccthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ddthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & eethet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ffthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1), - & ggthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1) - common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet, - & ffthet, - & ggthet,ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle, - & ndouble,nntheterm -C Virtual-bond lenghts - double precision vbl,vblinv,vblinv2,vbl_cis,vbl0,vbld_inv - integer loc_start,loc_end,ithet_start,ithet_end,iphi_start, - & iphi_end,iphid_start,iphid_end,itau_start,itau_end,ibond_start, - & ibond_end, - & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end, - & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start, - & iint_end,iphi1_start,iphi1_end, - & ibond_displ(0:max_fg_procs-1),ibond_count(0:max_fg_procs-1), - & ithet_displ(0:max_fg_procs-1),ithet_count(0:max_fg_procs-1), - & iphi_displ(0:max_fg_procs-1),iphi_count(0:max_fg_procs-1), - & iphi1_displ(0:max_fg_procs-1),iphi1_count(0:max_fg_procs-1), - & ivec_displ(0:max_fg_procs-1),ivec_count(0:max_fg_procs-1), - & iset_displ(0:max_fg_procs-1),iset_count(0:max_fg_procs-1), - & iint_count(0:max_fg_procs-1),iint_displ(0:max_fg_procs-1) - common /peptbond/ vbl,vblinv,vblinv2,vbl_cis,vbl0 - common /indices/ loc_start,loc_end,ithet_start,ithet_end, - & iphi_start,iphi_end,iphid_start,iphid_end,itau_start,itau_end, - & ibond_start,ibond_end, - & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end, - & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start, - & iint_end,iphi1_start,iphi1_end,iint_count,iint_displ,ivec_displ, - & ivec_count,iset_displ, - & iset_count,ibond_displ,ibond_count,ithet_displ,ithet_count, - & iphi_displ,iphi_count,iphi1_displ,iphi1_count -C Inverses of the actual virtual bond lengths - common /invlen/ vbld_inv(maxres2) diff --git a/source/unres/src_MD_DFA/COMMON.LOCMOVE b/source/unres/src_MD_DFA/COMMON.LOCMOVE deleted file mode 100644 index 211516d..0000000 --- a/source/unres/src_MD_DFA/COMMON.LOCMOVE +++ /dev/null @@ -1,19 +0,0 @@ -c Variables (set in init routine) never modified by local_move - integer init_called - logical locmove_output - double precision min_theta, max_theta - double precision dmin2,dmax2 - double precision flag,small,small2 - - common /loc_const/ init_called,locmove_output,min_theta, - + max_theta,dmin2,dmax2,flag,small,small2 - -c Workspace for local_move - integer a_n,b_n,res_n - double precision a_ang,b_ang,res_ang - logical a_tab,b_tab,res_tab - - common /loc_work/ res_ang(0:11),a_ang(0:7),b_ang(0:3), - + res_n,res_tab(0:2,0:2,0:11), - + a_n,a_tab(0:2,0:7), - + b_n,b_tab(0:2,0:3) diff --git a/source/unres/src_MD_DFA/COMMON.MAP b/source/unres/src_MD_DFA/COMMON.MAP deleted file mode 100644 index 77e97e7..0000000 --- a/source/unres/src_MD_DFA/COMMON.MAP +++ /dev/null @@ -1,4 +0,0 @@ - integer nmap,res1,res2,nstep - double precision ang_from,ang_to - common /mapp/ ang_from(maxvar),ang_to(maxvar),nmap,kang(maxvar), - & res1(maxvar),res2(maxvar),nstep(maxvar) diff --git a/source/unres/src_MD_DFA/COMMON.MAXGRAD b/source/unres/src_MD_DFA/COMMON.MAXGRAD deleted file mode 100644 index 285241a..0000000 --- a/source/unres/src_MD_DFA/COMMON.MAXGRAD +++ /dev/null @@ -1,12 +0,0 @@ - double precision - & gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max - common /maxgrad/ - & gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max diff --git a/source/unres/src_MD_DFA/COMMON.MCE b/source/unres/src_MD_DFA/COMMON.MCE deleted file mode 100644 index 2d79184..0000000 --- a/source/unres/src_MD_DFA/COMMON.MCE +++ /dev/null @@ -1,13 +0,0 @@ - double precision entropy(-max_ene-4:max_ene),nminima(maxsave), - & nhist(-max_ene:max_ene) - logical ent_read,multican - common /mce/ entropy,emin,emax,nhist,nminima,ent_read,multican, - & indminn,indmaxx - integer npool - double precision xpool,epool,pool_fraction - common /pool/ xpool(maxvar,max_pool),epool(max_pool), - & pool_fraction,npool - integer save_frequency,message_frequency,pool_read_freq, - & pool_save_freq,print_freq - common /mce_counters/ save_frequency,message_frequency, - & pool_read_freq,pool_save_freq,print_freq diff --git a/source/unres/src_MD_DFA/COMMON.MCM b/source/unres/src_MD_DFA/COMMON.MCM deleted file mode 100644 index 576f912..0000000 --- a/source/unres/src_MD_DFA/COMMON.MCM +++ /dev/null @@ -1,70 +0,0 @@ -C... Following COMMON block contains general variables controlling the MC/MCM -C... procedure -c----------------------------------------------------------------------------- - double precision Tcur,Tmin,Tmax,TstepH,TstepC,RanFract, - & overlap_cut,e_up,delte - integer nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter, - & maxrepm,ngen,ntrial,ntherm,nrepm,neneval,nsave,maxoverlap, - & nsave_part,max_mcm_it,nsweep,print_mc - logical print_stat,print_int - common /mcm/ Tcur,Tmin,Tmax,TstepH,TstepC,Rbol,betbol,RanFract, - & overlap_cut,e_up,delte, - & nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter,maxrepm, - & maxoverlap,ntrial,max_mcm_it, - & ngen,ntherm,nrepm,neneval,nsave,nsave_part(max_cg_procs),nsweep, - & print_mc,print_stat,print_int -c----------------------------------------------------------------------------- -C... The meaning of the above variables is as follows: -C... Tcur,Tmin,Tmax - Current,minimum and maximum temperature, respectively; -C... NstepC,NStepH - Number of cooling and heating steps, respectively; -C... TstepH,TstepC - factors by which T is multiplied in order to be -C... increased or decreased. -C... betbol - Boltzmann's inverse temperature (1/(Rbol*Tcur)); -C... Rbol - the gas constant; -C... RanFract - the chance that a new conformation will be random-generated; -C... maxacc - maximum number of accepted conformations; -C... maxgen,ngen - Maximum and current number of generated conformations; -C... maxtrial,ntrial - maximum number of trials before temperature is increased -C... and current number of trials, respectively; -C... maxrepm,nrepm - maximum number of allowed minima repetition and current -C... number of minima repetitions, respectively; -C... maxoverlap - max. # of overlapping confs generated in a single iteration; -C... neneval - number of energy evaluations; -C... nsave - number of confs. in the backup array; -C... nsweep - the number of macroiterations in generating the distributions. -c------------------------------------------------------------------------------ -C... Following COMMON block contains variables controlling motion. -c------------------------------------------------------------------------------ - double precision sumpro_type,sumpro_bond - integer koniecl, Nbm,MaxSideMove,nmove,moves(-1:MaxMoveType+1), - & moves_acc(-1:MaxMoveType+1),nacc_tot,nacc_part(0:MaxProcs) - common /move/ sumpro_type(0:MaxMoveType),sumpro_bond(0:maxres), - & koniecl,Nbm,MaxSideMove,nmove,nbond_move(maxres), - & nbond_acc(maxres),moves,moves_acc - common /accept_stats/ nacc_tot,nacc_part - integer nwindow,winstart,winend,winlen - common /windows/ nwindow,winstart(maxres),winend(maxres), - & winlen(maxres) - character*16 MovTypID - common /moveID/ MovTypID(-1:MaxMoveType+1) -c------------------------------------------------------------------------------ -C... koniecl - the number of bonds to be considered "end bonds" subjected to -C... end moves; -C... Nbm - The maximum length of N-bond segment to be moved; -C... MaxSideMove - maximum number of side chains subjected to local moves -C... simultaneously; -C... nmove - the current number of attempted moves; -C... nbond_move(*) array that stores the total numbers of 2-bond,3-bond,... -C... moves; -C... nendmove - number of endmoves; -C... nbackmove - number of backbone moves; -C... nsidemove - number of local side chain moves; -C... sumpro_type(*) - array that stores the lower and upper boundary of the -C... random-number range that determines the type of move -C... (N-bond, backbone or side chain); -C... sumpro_bond(*) - array that stores the probabilities to perform bond -C... moves of consecutive segment length. -C... winstart(*) - the starting position of the perturbation window; -C... winend(*) - the end position of the perturbation window; -C... winlen(*) - length of the perturbation window; -C... nwindow - the number of perturbation windows (0 - entire chain). diff --git a/source/unres/src_MD_DFA/COMMON.MD b/source/unres/src_MD_DFA/COMMON.MD deleted file mode 100644 index 40131bd..0000000 --- a/source/unres/src_MD_DFA/COMMON.MD +++ /dev/null @@ -1,77 +0,0 @@ - double precision gcart, gxcart, gradcag,gradxag - common /mdgrad/ gcart(3,0:MAXRES), gxcart(3,0:MAXRES), - & gradcag(3,MAXRES),gradxag(3,MAXRES) - integer dimen,dimen1, dimen3, ifrag(2,50,maxprocs/20), - & ipair(2,100,maxprocs/20),iset, - & mset(maxprocs/20),nset - double precision IP,ISC(ntyp+1),mp, - & msc(ntyp+1),d_t_work(MAXRES6), - & d_t_work_new(MAXRES6),d_t(3,0:MAXRES2),d_t_new(3,0:MAXRES2), - & d_af_work(MAXRES6),d_as_work(MAXRES6), - & d_t_old(3,0:MAXRES2),d_a_old(3,0:MAXRES2),d_a_short(3,0:MAXRES2), - & Gmat(MAXRES2,MAXRES2),Ginv(MAXRES2,MAXRES2),A(MAXRES2,MAXRES2), - & d_a(3,0:MAXRES2),d_a_work(6*MAXRES),kinetic_force(MAXRES6), - & Gsqrp(MAXRES2,MAXRES2),Gsqrm(MAXRES2,MAXRES2), - & vtot(MAXRES2),Gvec(maxres2,maxres2),Geigen(maxres2) - double precision v_ini,d_time,d_time0,t_bath,tau_bath, - & EK,potE,potEcomp(0:n_ene+4),totE,totT,amax,kinetic_T,dvmax,damax, - & edriftmax, - & eq_time,wfrag(50,maxprocs/20),wpair(100,maxprocs/20), - & qfrag(50),qpair(100), - & qinfrag(50,maxprocs/20),qinpair(100,maxprocs/20), - & Ucdfrag,Ucdpair,dUdconst(3,0:MAXRES),Uconst, - & dUdxconst(3,0:MAXRES),dqwol(3,0:MAXRES),dxqwol(3,0:MAXRES), - & utheta(maxfrag_back),ugamma(maxfrag_back),uscdiff(maxfrag_back), - & dutheta(maxres),dugamma(maxres),duscdiff(3,maxres), - & duscdiffx(3,maxres),wfrag_back(3,maxfrag_back,maxprocs/20), - & uconst_back - integer n_timestep,ntwx,ntwe,lang,count_reset_moment, - & count_reset_vel,reset_fricmat,nfrag,npair,nfrag_back, - & ifrag_back(3,maxfrag_back,maxprocs/20),ntime_split,ntime_split0, - & maxtime_split - integer nresn,nyosh,nnos - double precision glogs,qmass,vlogs,xlogs - logical large,print_compon,tbf,rest,reset_moment,reset_vel, - & surfarea,rattle,usampl,mdpdb,RESPA,tnp,tnp1,tnh,xiresp - integer igmult_start,igmult_end,my_ng_count,ng_start,ng_counts, - & nginv_start,nginv_counts,myginv_ng_count - common /back_constr/ uconst_back,utheta,ugamma,uscdiff, - & dutheta,dugamma,duscdiff,duscdiffx, - & wfrag_back,nfrag_back,ifrag_back - common /qmeas/ qfrag,qpair,qinfrag,qinpair,wfrag,wpair,eq_time, - & Ucdfrag,Ucdpair,dUdconst,dUdxconst,dqwol,dxqwol,Uconst, - & iset,mset,nset,usampl,ifrag,ipair,npair,nfrag - common /mdpar/ v_ini,d_time,d_time0,scal_fric, - & t_bath,tau_bath,dvmax,damax,n_timestep,mdpdb, - & ntime_split,ntime_split0,maxtime_split, - & ntwx,ntwe,large,print_compon,tbf,rest,tnp,tnp1,tnh - common /MDcalc/ totT,totE,potE,potEcomp,EK,amax,edriftmax, - & kinetic_T - common /lagrange/ d_t,d_t_old,d_t_new,d_t_work, - & d_t_work_new,d_a,d_a_old,d_a_work,d_af_work,d_as_work,d_a_short, - & kinetic_force, - & A,Ginv,Gmat,Gvec,Geigen,Gsqrp,Gsqrm, - & vtot,dimen,dimen1,dimen3,lang, - & reset_moment,reset_vel,count_reset_moment,count_reset_vel, - & rattle,RESPA - common /inertia/ IP,ISC,MP,MSC - double precision scal_fric,rwat,etawat,gamp, - & gamsc(ntyp),stdfp,stdfsc(ntyp),stdforcp(MAXRES), - & stdforcsc(MAXRES),pstok,restok(ntyp+1),cPoise,Rb - common /langevin/ pstok,restok,gamp,gamsc, - & stdfp,stdfsc,stdforcp,stdforcsc,rwat,etawat,cPoise,Rb,surfarea, - & reset_fricmat - common /mdpmpi/ igmult_start,igmult_end,my_ng_count, - & myginv_ng_count, - & ng_start(0:MaxProcs-1),ng_counts(0:MaxProcs-1), - & nginv_start(0:MaxProcs),nginv_counts(0:MaxProcs-1) - double precision pi_np,pistar,s_np,s12_np,Q_np,E_old,H0,E_long, - & sold_np,d_t_half,Csplit,hhh - common /nosepoincare/ pi_np,pistar,s_np,s12_np,Q_np,E_old,H0, - & E_long,sold_np,d_t_half(3,0:MAXRES2),Csplit,hhh - common /nosehoover/ glogs(maxmnh),qmass(maxmnh), - & vlogs(maxmnh),xlogs(maxmnh), - & nresn,nyosh,nnos,xiresp - integer hmc,hmc_acc - double precision dc_hmc,hmc_etot,totThmc - common /hmc_md/ dc_hmc(3,0:maxres2),hmc_etot,totThmc,hmc,hmc_acc diff --git a/source/unres/src_MD_DFA/COMMON.MINIM b/source/unres/src_MD_DFA/COMMON.MINIM deleted file mode 100644 index e44f9cd..0000000 --- a/source/unres/src_MD_DFA/COMMON.MINIM +++ /dev/null @@ -1,5 +0,0 @@ - double precision tolf,rtolf - integer maxfun,maxmin,minfun,minmin, - & print_min_ini,print_min_stat,print_min_res - common /minimm/ tolf,rtolf,maxfun,maxmin,minfun,minmin, - & print_min_ini,print_min_stat,print_min_res diff --git a/source/unres/src_MD_DFA/COMMON.MUCA b/source/unres/src_MD_DFA/COMMON.MUCA deleted file mode 100644 index 7529c15..0000000 --- a/source/unres/src_MD_DFA/COMMON.MUCA +++ /dev/null @@ -1,10 +0,0 @@ - double precision emuca(4*maxres),nemuca(4*maxres), - & nemuca2(4*maxres),elow,ehigh,factor, - & elowi(maxprocs),ehighi(maxprocs),hbin, - & hist(4*maxres),factor_min - integer nmuca,imtime,muca_smooth - common /double_muca/ emuca,nemuca, - & nemuca2,elow,ehigh,factor,hbin,hist,factor_min - common /integer_muca/ nmuca,imtime,muca_smooth - common /mucarem/ elowi,ehighi - diff --git a/source/unres/src_MD_DFA/COMMON.NAMES b/source/unres/src_MD_DFA/COMMON.NAMES deleted file mode 100644 index e6f926b..0000000 --- a/source/unres/src_MD_DFA/COMMON.NAMES +++ /dev/null @@ -1,7 +0,0 @@ - character*3 restyp - character*1 onelet - common /names/ restyp(ntyp+1),onelet(ntyp+1) - character*10 ename,wname - integer nprint_ene,print_order - common /namterm/ ename(n_ene),wname(n_ene),nprint_ene, - & print_order(n_ene) diff --git a/source/unres/src_MD_DFA/COMMON.REFSYS b/source/unres/src_MD_DFA/COMMON.REFSYS deleted file mode 100644 index 9eaa3c3..0000000 --- a/source/unres/src_MD_DFA/COMMON.REFSYS +++ /dev/null @@ -1,3 +0,0 @@ - double precision e1,e2,e3,u,z,s1,s2 - integer i1,i2,i3,i4 - common /refer/ e1(3),e2(3),e3(3),u(3),z(3),s1,s2,i1,i2,i3,i4 diff --git a/source/unres/src_MD_DFA/COMMON.REMD b/source/unres/src_MD_DFA/COMMON.REMD deleted file mode 100644 index b283b5b..0000000 --- a/source/unres/src_MD_DFA/COMMON.REMD +++ /dev/null @@ -1,36 +0,0 @@ - integer nrep,nstex,hremd - logical remd_tlist,remd_mlist,mremdsync,restart1file,traj1file - double precision retmin,retmax,remd_t(maxprocs) - double precision hweights(maxprocs/20,n_ene) - integer remd_m(maxprocs),i_sync_step - integer*2 i2rep(0:maxprocs),i2set(0:maxprocs) - integer*2 ifirst(maxprocs) - integer*2 nupa(0:maxprocs/4,0:maxprocs), - & ndowna(0:maxprocs/4,0:maxprocs) - real t_restart1(5,maxprocs) - integer iset_restart1(maxprocs) - logical t_exchange_only - common /remdcommon/ nrep,nstex,retmin,retmax,remd_t,remd_tlist, - & remd_mlist,remd_m,mremdsync,restart1file, - & traj1file,i_sync_step,t_exchange_only - common /hamilt_remd/ hweights,hremd - common /remdrestart/ i2rep,i2set,ifirst,nupa,ndowna,t_restart1, - & iset_restart1 - real totT_cache,EK_cache,potE_cache,t_bath_cache,Uconst_cache, - & qfrag_cache,qpair_cache,c_cache,uscdiff_cache, - & ugamma_cache,utheta_cache - integer ntwx_cache,ii_write,max_cache_traj_use - common /traj1cache/ totT_cache(max_cache_traj), - & EK_cache(max_cache_traj), - & potE_cache(max_cache_traj), - & t_bath_cache(max_cache_traj), - & Uconst_cache(max_cache_traj), - & qfrag_cache(50,max_cache_traj), - & qpair_cache(100,max_cache_traj), - & ugamma_cache(maxfrag_back,max_cache_traj), - & utheta_cache(maxfrag_back,max_cache_traj), - & uscdiff_cache(maxfrag_back,max_cache_traj), - & c_cache(3,maxres2+2,max_cache_traj), - & iset_cache(max_cache_traj),ntwx_cache, - & ii_write,max_cache_traj_use - diff --git a/source/unres/src_MD_DFA/COMMON.SBRIDGE b/source/unres/src_MD_DFA/COMMON.SBRIDGE deleted file mode 100644 index d75482c..0000000 --- a/source/unres/src_MD_DFA/COMMON.SBRIDGE +++ /dev/null @@ -1,12 +0,0 @@ - double precision ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss - integer ns,nss,nfree,iss - common /sbridge/ ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss, - & ns,nss,nfree,iss(maxss) - double precision dhpb,dhpb1,forcon - integer ihpb,jhpb,nhpb - common /links/ dhpb(maxdim),dhpb1(maxdim),forcon(maxdim), - & ihpb(maxdim),jhpb(maxdim),ibecarb(maxdim),nhpb - double precision weidis - common /restraints/ weidis - integer link_start,link_end - common /links_split/ link_start,link_end diff --git a/source/unres/src_MD_DFA/COMMON.SCCOR b/source/unres/src_MD_DFA/COMMON.SCCOR deleted file mode 100644 index 395e4e2..0000000 --- a/source/unres/src_MD_DFA/COMMON.SCCOR +++ /dev/null @@ -1,17 +0,0 @@ -cc Parameters of the SCCOR term - double precision v1sccor,v2sccor,vlor1sccor, - & vlor2sccor,vlor3sccor,gloc_sc, - & dcostau,dsintau,dtauangle,dcosomicron, - & domicron - integer nterm_sccor,isccortyp,nsccortyp,nlor_sccor - common/sccor/v1sccor(maxterm_sccor,3,20,20), - & v2sccor(maxterm_sccor,3,20,20), - & vlor1sccor(maxterm_sccor,20,20), - & vlor2sccor(maxterm_sccor,20,20), - & vlor3sccor(maxterm_sccor,20,20),gloc_sc(3,0:maxres2,10), - & v0sccor(ntyp,ntyp), - & dcostau(3,3,3,maxres2),dsintau(3,3,3,maxres2), - & dtauangle(3,3,3,maxres2),dcosomicron(3,3,3,maxres2), - & domicron(3,3,3,maxres2), - & nterm_sccor(ntyp,ntyp),isccortyp(ntyp),nsccortyp, - & nlor_sccor(ntyp,ntyp) diff --git a/source/unres/src_MD_DFA/COMMON.SCROT b/source/unres/src_MD_DFA/COMMON.SCROT deleted file mode 100644 index 2da7b8f..0000000 --- a/source/unres/src_MD_DFA/COMMON.SCROT +++ /dev/null @@ -1,3 +0,0 @@ -C Parameters of the SC rotamers (local) term - double precision sc_parmin - common/scrot/sc_parmin(maxsccoef,20) diff --git a/source/unres/src_MD_DFA/COMMON.SETUP b/source/unres/src_MD_DFA/COMMON.SETUP deleted file mode 100644 index 5039116..0000000 --- a/source/unres/src_MD_DFA/COMMON.SETUP +++ /dev/null @@ -1,21 +0,0 @@ - integer king,idint,idreal,idchar,is_done - parameter (king=0,idint=1105,idreal=1729,idchar=1597,is_done=1) - integer me,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,nfgtasks,kolor, - & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1),CG_COMM,FG_COMM, - & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp(0:maxprocs-1), - & kolor1,key1,nfgtasks1,MyRank, - & max_gs_size - logical yourjob, finished, cgdone - common/setup/me,MyRank,cg_rank,fg_rank,fg_rank1,nodes,Nprocs, - & nfgtasks,nfgtasks1, - & max_gs_size,kolor,koniec,WhatsUp,ifinish,CG_COMM,FG_COMM, - & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp - integer MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, - & MPI_THET,MPI_GAM, - & MPI_ROTAT1(0:1),MPI_ROTAT2(0:1),MPI_ROTAT_OLD(0:1), - & MPI_PRECOMP11(0:1),MPI_PRECOMP12(0:1),MPI_PRECOMP22(0:1), - & MPI_PRECOMP23(0:1) - common /types/ MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, - & MPI_THET,MPI_GAM, - & MPI_ROTAT1,MPI_ROTAT2,MPI_ROTAT_OLD,MPI_PRECOMP11,MPI_PRECOMP12, - & MPI_PRECOMP22,MPI_PRECOMP23 diff --git a/source/unres/src_MD_DFA/COMMON.SPLITELE b/source/unres/src_MD_DFA/COMMON.SPLITELE deleted file mode 100644 index a2f0447..0000000 --- a/source/unres/src_MD_DFA/COMMON.SPLITELE +++ /dev/null @@ -1,2 +0,0 @@ - double precision r_cut,rlamb - common /splitele/ r_cut,rlamb diff --git a/source/unres/src_MD_DFA/COMMON.THREAD b/source/unres/src_MD_DFA/COMMON.THREAD deleted file mode 100644 index 5c814cc..0000000 --- a/source/unres/src_MD_DFA/COMMON.THREAD +++ /dev/null @@ -1,7 +0,0 @@ - integer nthread,nexcl,iexam,ipatt - double precision ener0,ener,max_time_for_thread, - & ave_time_for_thread - common /thread/ nthread,nexcl,iexam(2,maxthread), - & ipatt(2,maxthread) - common /thread1/ ener0(n_ene+2,maxthread),ener(n_ene+2,maxthread), - & max_time_for_thread,ave_time_for_thread diff --git a/source/unres/src_MD_DFA/COMMON.TIME1 b/source/unres/src_MD_DFA/COMMON.TIME1 deleted file mode 100644 index d6203a6..0000000 --- a/source/unres/src_MD_DFA/COMMON.TIME1 +++ /dev/null @@ -1,28 +0,0 @@ - DOUBLE PRECISION BATIME,TIMLIM,STIME,PREVTIM,SAFETY - DOUBLE PRECISION WALLTIME - INTEGER ISTOP -c FOUND_NAN - set by calcf to stop sumsl via stopx - logical FOUND_NAN - COMMON/TIME1/STIME,TIMLIM,BATIME,PREVTIM,SAFETY,WALLTIME - COMMON/STOPTIM/ISTOP - common /sumsl_flag/ FOUND_NAN - double precision t_init,t_MDsetup,t_langsetup,t_MD, - & t_enegrad,t_sdsetup,time_bcast,time_reduce,time_gather, - & time_sendrecv,time_barrier_e,time_barrier_g,time_scatter, - & t_eelecij,time_bcast7,time_bcastc,time_bcastw,time_allreduce, - & time_enecalc,time_sumene,time_lagrangian,time_cartgrad, - & time_sumgradient,time_intcartderiv,time_inttocart,time_intfcart, - & time_vec,time_mat,time_ginvmult,time_fricmatmult,time_fric, - & time_scatter_fmat,time_scatter_ginv, - & time_fsample,time_scatter_fmatmult,time_scatter_ginvmult, - & time_stoch,t_eshort,t_elong,t_etotal - common /timing/ t_init,t_MDsetup,t_langsetup, - & t_MD,t_enegrad,t_sdsetup,time_bcast,time_reduce,time_gather, - & time_sendrecv,time_scatter,time_barrier_e,time_barrier_g, - & time_bcast7,time_bcastc,time_bcastw,time_allreduce, - & t_eelecij,time_enecalc,time_sumene,time_lagrangian,time_cartgrad, - & time_sumgradient,time_intcartderiv,time_inttocart,time_intfcart, - & time_vec,time_mat,time_ginvmult,time_fricmatmult,time_fric, - & time_fsample,time_scatter_fmatmult,time_scatter_ginvmult, - & time_scatter_fmat,time_scatter_ginv, - & time_stoch,t_eshort,t_elong,t_etotal diff --git a/source/unres/src_MD_DFA/COMMON.TORCNSTR b/source/unres/src_MD_DFA/COMMON.TORCNSTR deleted file mode 100644 index e4af17c..0000000 --- a/source/unres/src_MD_DFA/COMMON.TORCNSTR +++ /dev/null @@ -1,6 +0,0 @@ - integer ndih_constr,idih_constr(maxdih_constr) - integer ndih_nconstr,idih_nconstr(maxdih_constr) - integer idihconstr_start,idihconstr_end - double precision phi0(maxdih_constr),drange(maxdih_constr),ftors - common /torcnstr/ phi0,drange,ftors,ndih_constr,idih_constr, - & ndih_nconstr,idih_nconstr,idihconstr_start,idihconstr_end diff --git a/source/unres/src_MD_DFA/COMMON.TORSION b/source/unres/src_MD_DFA/COMMON.TORSION deleted file mode 100644 index 6b6605f..0000000 --- a/source/unres/src_MD_DFA/COMMON.TORSION +++ /dev/null @@ -1,23 +0,0 @@ -C Torsional constants of the rotation about virtual-bond dihedral angles - double precision v1,v2,vlor1,vlor2,vlor3,v0 - integer itortyp,ntortyp,nterm,nlor,nterm_old - common/torsion/v0(maxtor,maxtor),v1(maxterm,maxtor,maxtor), - & v2(maxterm,maxtor,maxtor),vlor1(maxlor,maxtor,maxtor), - & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor), - & itortyp(ntyp),ntortyp,nterm(maxtor,maxtor),nlor(maxtor,maxtor) - & ,nterm_old -C 6/23/01 - constants for double torsionals - double precision v1c,v1s,v2c,v2s - integer ntermd_1,ntermd_2 - common /torsiond/ v1c(2,maxtermd_1,maxtor,maxtor,maxtor), - & v1s(2,maxtermd_1,maxtor,maxtor,maxtor), - & v2c(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor), - & v2s(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor), - & ntermd_1(maxtor,maxtor,maxtor),ntermd_2(maxtor,maxtor,maxtor) -C 9/18/99 - added Fourier coeffficients of the expansion of local energy -C surface - double precision b1,b2,cc,dd,ee,ctilde,dtilde,b2tilde - integer nloctyp - common/fourier/ b1(2,maxtor),b2(2,maxtor),cc(2,2,maxtor), - & dd(2,2,maxtor),ee(2,2,maxtor),ctilde(2,2,maxtor), - & dtilde(2,2,maxtor),b1tilde(2,maxtor),nloctyp diff --git a/source/unres/src_MD_DFA/COMMON.VAR b/source/unres/src_MD_DFA/COMMON.VAR deleted file mode 100644 index edc81d7..0000000 --- a/source/unres/src_MD_DFA/COMMON.VAR +++ /dev/null @@ -1,21 +0,0 @@ -C Store the geometric variables in the following COMMON block. - integer ntheta,nphi,nside,nvar,Origin,nstore,ialph,ivar, - & mask_theta,mask_phi,mask_side - double precision theta,phi,alph,omeg,varsave,esave,varall,vbld, - & thetaref,phiref,costtab,sinttab,cost2tab,sint2tab, - & xxtab,yytab,zztab,xxref,yyref,zzref,tauangle,omicron - common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), - & omicron(2,maxres),tauangle(3,maxres), - & vbld(2*maxres),thetaref(maxres),phiref(maxres), - & costtab(maxres), sinttab(maxres), cost2tab(maxres), - & sint2tab(maxres),xxtab(maxres),yytab(maxres), - & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres), - & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar -C Store the angles and variables corresponding to old conformations (for use -C in MCM). - common /oldgeo/ varsave(maxvar,maxsave),esave(maxsave), - & Origin(maxsave),nstore -C freeze some variables - logical mask_r - common /restr/ varall(maxvar),mask_r,mask_theta(maxres), - & mask_phi(maxres),mask_side(maxres) diff --git a/source/unres/src_MD_DFA/COMMON.VECTORS b/source/unres/src_MD_DFA/COMMON.VECTORS deleted file mode 100644 index d880c24..0000000 --- a/source/unres/src_MD_DFA/COMMON.VECTORS +++ /dev/null @@ -1,3 +0,0 @@ - common /vectors/ uy(3,maxres),uz(3,maxres), - & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres) - diff --git a/source/unres/src_MD_DFA/DIMENSIONS b/source/unres/src_MD_DFA/DIMENSIONS deleted file mode 100644 index c6613e3..0000000 --- a/source/unres/src_MD_DFA/DIMENSIONS +++ /dev/null @@ -1,139 +0,0 @@ -******************************************************************************** -* Settings for the program of united-residue peptide simulation in real space * -* * -* ------- As of 6/23/01 ----------- * -* * -******************************************************************************** -C Max. number of processors. - integer maxprocs - parameter (maxprocs=2048) -C Max. number of fine-grain processors - integer max_fg_procs -c parameter (max_fg_procs=maxprocs) - parameter (max_fg_procs=512) -C Max. number of coarse-grain processors - integer max_cg_procs - parameter (max_cg_procs=maxprocs) -C Max. number of AA residues - integer maxres - parameter (maxres=800) -C Appr. max. number of interaction sites - integer maxres2,maxres6,mmaxres2 - parameter (maxres2=2*maxres,maxres6=6*maxres) - parameter (mmaxres2=(maxres2*(maxres2+1)/2)) -C Max. number of variables - integer maxvar - parameter (maxvar=6*maxres) -C Max. number of groups of interactions that a given SC is involved in - integer maxint_gr - parameter (maxint_gr=2) -C Max. number of derivatives of virtual-bond and side-chain vectors in theta -C or phi. - integer maxdim - parameter (maxdim=(maxres-1)*(maxres-2)/2) -C Max. number of SC contacts - integer maxcont - parameter (maxcont=12*maxres) -C Max. number of contacts per residue - integer maxconts - parameter (maxconts=maxres/4) -c parameter (maxconts=50) -C Number of AA types (at present only natural AA's will be handled - integer ntyp,ntyp1 - parameter (ntyp=20,ntyp1=ntyp+1) -C Max. number of types of dihedral angles & multiplicity of torsional barriers -C and the number of terms in double torsionals - integer maxtor,maxterm,maxlor,maxtermd_1,maxtermd_2 - parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) -C Max. number of residue types and parameters in expressions for -C virtual-bond angle bending potentials - integer maxthetyp,maxthetyp1,maxtheterm,maxtheterm2,maxtheterm3, - & maxsingle,maxdouble,mmaxtheterm - parameter (maxthetyp=3,maxthetyp1=maxthetyp+1,maxtheterm=20, - & maxtheterm2=6,maxtheterm3=4,maxsingle=6,maxdouble=4, - & mmaxtheterm=maxtheterm) -c Max number of torsional terms in SCCOR - integer maxterm_sccor - parameter (maxterm_sccor=6) -C Max. number of lobes in SC distribution - integer maxlob - parameter (maxlob=4) -C Max. number of S-S bridges - integer maxss - parameter (maxss=20) -C Max. number of dihedral angle constraints - integer maxdih_constr - parameter (maxdih_constr=maxres) -C Max. number of patterns in the pattern database - integer maxseq - parameter (maxseq=10) -C Max. number of residues in a peptide in the database - integer maxres_base - parameter (maxres_base=10) -C Max. number of threading attempts - integer maxthread - parameter (maxthread=20) -C Max. number of move types in MCM - integer maxmovetype - parameter (maxmovetype=4) -C Max. number of stored confs. in MC/MCM simulation - integer maxsave - parameter (maxsave=20) -C Max. number of energy intervals - integer max_ene - parameter (max_ene=10) -C Max. number of conformations in Master's cache array - integer max_cache - parameter (max_cache=10) -C Max. number of conformations in the pool - integer max_pool - parameter (max_pool=10) -C Number of energy components - integer n_ene,n_ene2 - parameter (n_ene=27,n_ene2=2*n_ene) -C Number of threads in deformation - integer max_thread,max_thread2 - parameter (max_thread=4,max_thread2=2*max_thread) -C Number of structures to compare at t=0 - integer max_threadss,max_threadss2 - parameter (max_threadss=8,max_threadss2=2*max_threadss) -C Maxmimum number of angles per residue - integer mxang - parameter (mxang=4) -C Maximum number of groups of angles - integer mxgr - parameter (mxgr=2*maxres) -C Maximum number of chains - integer mxch - parameter (mxch=1) -csaC Maximum number of generated conformations -csa integer mxio -csa parameter (mxio=2) -csaC Maximum number of n7 generated conformations -csa integer mxio2 -csa parameter (mxio2=2) -csaC Maximum number of moves (n1-n8) -csa integer mxmv -csa parameter (mxmv=18) -csaC Maximum number of seed -csa integer max_seed -csa parameter (max_seed=1) -C Maximum number of timesteps for which stochastic MD matrices can be stored - integer maxflag_stoch - parameter (maxflag_stoch=0) -C Maximum number of backbone fragments in restraining - integer maxfrag_back - parameter (maxfrag_back=4) -C Maximum number of SC local term fitting function coefficiants - integer maxsccoef - parameter (maxsccoef=65) -C Maximum number of terms in SC bond-stretching potential - integer maxbondterm - parameter (maxbondterm=3) -C Maximum number of conformation stored in cache on each CPU before sending -C to master; depends on nstex / ntwx ratio - integer max_cache_traj - parameter (max_cache_traj=10) -C Nose-Hoover chain - chain length and order of Yoshida algorithm - integer maxmnh,maxyosh - parameter(maxmnh=10,maxyosh=5) diff --git a/source/unres/src_MD_DFA/DIMENSIONS.2100 b/source/unres/src_MD_DFA/DIMENSIONS.2100 deleted file mode 100644 index ea1d287..0000000 --- a/source/unres/src_MD_DFA/DIMENSIONS.2100 +++ /dev/null @@ -1,80 +0,0 @@ -******************************************************************************** -* Settings for the program of united-residue peptide simulation in real space * -* * -* ------- As of 6/23/01 ----------- * -* * -******************************************************************************** -C Max. number of processors. - parameter (maxprocs=2100) -C Max. number of fine-grain processors - parameter (max_fg_procs=maxprocs) -C Max. number of coarse-grain processors - parameter (max_cg_procs=maxprocs) -C Max. number of AA residues - parameter (maxres=150) -C Appr. max. number of interaction sites - parameter (maxres2=2*maxres,maxres6=6*maxres) - parameter (mmaxres6=(maxres6*(maxres6+1)/2)) -C Max. number of variables - parameter (maxvar=6*maxres) -C Max. number of groups of interactions that a given SC is involved in - parameter (maxint_gr=2) -C Max. number of derivatives of virtual-bond and side-chain vectors in theta -C or phi. - parameter (maxdim=(maxres-1)*(maxres-2)/2) -C Max. number of SC contacts - parameter (maxcont=12*maxres) -C Max. number of contacts per residue - parameter (maxconts=maxres) -C Number of AA types (at present only natural AA's will be handled - parameter (ntyp=20,ntyp1=ntyp+1) -C Max. number of types of dihedral angles & multiplicity of torsional barriers -C and the number of terms in double torsionals - parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) -C Max. number of lobes in SC distribution - parameter (maxlob=4) -C Max. number of S-S bridges - parameter (maxss=20) -C Max. number of dihedral angle constraints - parameter (maxdih_constr=maxres) -C Max. number of patterns in the pattern database - parameter (maxseq=10) -C Max. number of residues in a peptide in the database - parameter (maxres_base=10) -C Max. number of threading attempts - parameter (maxthread=20) -C Max. number of move types in MCM - parameter (maxmovetype=4) -C Max. number of stored confs. in MC/MCM simulation - parameter (maxsave=20) -C Max. number of energy intervals - parameter (max_ene=10) -C Max. number of conformations in Master's cache array - parameter (max_cache=10) -C Max. number of conformations in the pool - parameter (max_pool=10) -C Number of energy components - parameter (n_ene=21,n_ene2=2*n_ene) -C Number of threads in deformation - integer max_thread,max_thread2 - parameter (max_thread=4,max_thread2=2*max_thread) -C Number of structures to compare at t=0 - integer max_threadss,max_threadss2 - parameter (max_threadss=8,max_threadss2=2*max_threadss) -C Maxmimum number of angles per residue - parameter (mxang=4) -C Maximum number of groups of angles - parameter (mxgr=2*maxres) -C Maximum number of chains - parameter (mxch=1) -C Maximum number of generated conformations - parameter (mxio=2) -C Maximum number of n7 generated conformations - parameter (mxio2=2) -C Maximum number of moves (n1-n8) - parameter (mxmv=18) -C Maximum number of seed - parameter (max_seed=1) -C Maximum number of timesteps for which stochastic MD matrices can be stored - integer maxflag_stoch - parameter (maxflag_stoch=0) diff --git a/source/unres/src_MD_DFA/DIMENSIONS.4100 b/source/unres/src_MD_DFA/DIMENSIONS.4100 deleted file mode 100644 index a4558b9..0000000 --- a/source/unres/src_MD_DFA/DIMENSIONS.4100 +++ /dev/null @@ -1,80 +0,0 @@ -******************************************************************************** -* Settings for the program of united-residue peptide simulation in real space * -* * -* ------- As of 6/23/01 ----------- * -* * -******************************************************************************** -C Max. number of processors. - parameter (maxprocs=4100) -C Max. number of fine-grain processors - parameter (max_fg_procs=maxprocs) -C Max. number of coarse-grain processors - parameter (max_cg_procs=maxprocs) -C Max. number of AA residues - parameter (maxres=150) -C Appr. max. number of interaction sites - parameter (maxres2=2*maxres,maxres6=6*maxres) - parameter (mmaxres6=(maxres6*(maxres6+1)/2)) -C Max. number of variables - parameter (maxvar=6*maxres) -C Max. number of groups of interactions that a given SC is involved in - parameter (maxint_gr=2) -C Max. number of derivatives of virtual-bond and side-chain vectors in theta -C or phi. - parameter (maxdim=(maxres-1)*(maxres-2)/2) -C Max. number of SC contacts - parameter (maxcont=12*maxres) -C Max. number of contacts per residue - parameter (maxconts=maxres) -C Number of AA types (at present only natural AA's will be handled - parameter (ntyp=20,ntyp1=ntyp+1) -C Max. number of types of dihedral angles & multiplicity of torsional barriers -C and the number of terms in double torsionals - parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) -C Max. number of lobes in SC distribution - parameter (maxlob=4) -C Max. number of S-S bridges - parameter (maxss=20) -C Max. number of dihedral angle constraints - parameter (maxdih_constr=maxres) -C Max. number of patterns in the pattern database - parameter (maxseq=10) -C Max. number of residues in a peptide in the database - parameter (maxres_base=10) -C Max. number of threading attempts - parameter (maxthread=20) -C Max. number of move types in MCM - parameter (maxmovetype=4) -C Max. number of stored confs. in MC/MCM simulation - parameter (maxsave=20) -C Max. number of energy intervals - parameter (max_ene=10) -C Max. number of conformations in Master's cache array - parameter (max_cache=10) -C Max. number of conformations in the pool - parameter (max_pool=10) -C Number of energy components - parameter (n_ene=21,n_ene2=2*n_ene) -C Number of threads in deformation - integer max_thread,max_thread2 - parameter (max_thread=4,max_thread2=2*max_thread) -C Number of structures to compare at t=0 - integer max_threadss,max_threadss2 - parameter (max_threadss=8,max_threadss2=2*max_threadss) -C Maxmimum number of angles per residue - parameter (mxang=4) -C Maximum number of groups of angles - parameter (mxgr=2*maxres) -C Maximum number of chains - parameter (mxch=1) -C Maximum number of generated conformations - parameter (mxio=2) -C Maximum number of n7 generated conformations - parameter (mxio2=2) -C Maximum number of moves (n1-n8) - parameter (mxmv=18) -C Maximum number of seed - parameter (max_seed=1) -C Maximum number of timesteps for which stochastic MD matrices can be stored - integer maxflag_stoch - parameter (maxflag_stoch=0) diff --git a/source/unres/src_MD_DFA/MD_A-MTS.F b/source/unres/src_MD_DFA/MD_A-MTS.F deleted file mode 100644 index d4d6be6..0000000 --- a/source/unres/src_MD_DFA/MD_A-MTS.F +++ /dev/null @@ -1,3461 +0,0 @@ - subroutine MD -c------------------------------------------------ -c The driver for molecular dynamics subroutines -c------------------------------------------------ - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" - integer IERROR,ERRCODE -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision cm(3),L(3),vcm(3) -#ifdef VOUT - double precision v_work(maxres6),v_transf(maxres6) -#endif - integer ilen,rstcount - external ilen - character*50 tytul - common /gucio/ cm - integer itime -c -#ifdef MPI - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_" - & //liczba(:ilen(liczba))//'.rst') -#else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_"//'.rst') -#endif - t_MDsetup=0.0d0 - t_langsetup=0.0d0 - t_MD=0.0d0 - t_enegrad=0.0d0 - t_sdsetup=0.0d0 - write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" -#ifdef MPI - tt0=MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Determine the inverse of the inertia matrix. - call setup_MD_matrices -c Initialize MD - call init_MD -#ifdef MPI - t_MDsetup = MPI_Wtime()-tt0 -#else - t_MDsetup = tcpu()-tt0 -#endif - rstcount=0 -c Entering the MD loop -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen3 - do j=1,dimen3 - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif -#ifdef MPI - t_langsetup=MPI_Wtime()-tt0 - tt0=MPI_Wtime() -#else - t_langsetup=tcpu()-tt0 - tt0=tcpu() -#endif - do itime=1,n_timestep - rstcount=rstcount+1 - if (lang.gt.0 .and. surfarea .and. - & mod(itime,reset_fricmat).eq.0) then - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen3 - do j=1,dimen3 - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - write (iout,'(a,i10)') - & "Friction matrix reset based on surface area, itime",itime - endif - if (reset_vel .and. tbf .and. lang.eq.0 - & .and. mod(itime,count_reset_vel).eq.0) then - call random_vel - write(iout,'(a,f20.2)') - & "Velocities reset to random values, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - endif - if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then - call inertia_tensor - call vcm_vel(vcm) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen3*Rb)*EK - scalfac=dsqrt(T_bath/kinetic_T) - write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=scalfac*d_t(j,i) - enddo - enddo - endif - if (lang.ne.4) then - if (RESPA) then -c Time-reversible RESPA algorithm -c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) - call RESPA_step(itime) - else -c Variable time step algorithm. - call velverlet_step(itime) - endif - else -#ifdef BROWN - call brown_step(itime) -#else - print *,"Brown dynamics not here!" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) call statout(itime) -#ifdef VOUT - do j=1,3 - v_work(j)=d_t(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - v_work(ind)=d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - ind=ind+1 - v_work(ind)=d_t(j,i+nres) - enddo - endif - enddo - - write (66,'(80f10.5)') - & ((d_t(j,i),j=1,3),i=0,nres-1),((d_t(j,i+nres),j=1,3),i=1,nres) - do i=1,ind - v_transf(i)=0.0d0 - do j=1,ind - v_transf(i)=v_transf(i)+gvec(j,i)*v_work(j) - enddo - v_transf(i)= v_transf(i)*dsqrt(geigen(i)) - enddo - write (67,'(80f10.5)') (v_transf(i),i=1,ind) -#endif - endif - if (mod(itime,ntwx).eq.0) then - write (tytul,'("time",f8.2)') totT - if(mdpdb) then - call pdbout(potE,tytul,ipdb) - else - call cartout(totT) - endif - endif - if (rstcount.eq.1000.or.itime.eq.n_timestep) then - open(irest2,file=rest2name,status='unknown') - write(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - write (irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - close(irest2) - rstcount=0 - endif - enddo -#ifdef MPI - t_MD=MPI_Wtime()-tt0 -#else - t_MD=tcpu()-tt0 -#endif - write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') - & ' Timing ', - & 'MD calculations setup:',t_MDsetup, - & 'Energy & gradient evaluation:',t_enegrad, - & 'Stochastic MD setup:',t_langsetup, - & 'Stochastic MD step setup:',t_sdsetup, - & 'MD steps:',t_MD - write (iout,'(/28(1h=),a25,27(1h=))') - & ' End of MD calculation ' -#ifdef TIMING_ENE - write (iout,*) "time for etotal",t_etotal," elong",t_elong, - & " eshort",t_eshort - write (iout,*) "time_fric",time_fric," time_stoch",time_stoch, - & " time_fricmatmult",time_fricmatmult," time_fsample ", - & time_fsample -#endif - return - end -c------------------------------------------------------------------------------- - subroutine velverlet_step(itime) -c------------------------------------------------------------------------------- -c Perform a single velocity Verlet step; the time step can be rescaled if -c increments in accelerations exceed the threshold -c------------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer ierror,ierrcode -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - include 'COMMON.MUCA' - double precision vcm(3),incr(3) - double precision cm(3),L(3) - integer ilen,count,rstcount - external ilen - character*50 tytul - integer maxcount_scale /20/ - common /gucio/ cm - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - integer itime - logical scale - double precision HNose1,HNose,HNose_nh,H,vtnp(maxres6) - double precision vtnp_(maxres6),vtnp_a(maxres6) -c - scale=.true. - icount_scale=0 - if (lang.eq.1) then - call sddir_precalc - else if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call stochastic_force(stochforcvec) -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - itime_scal=0 - do while (scale) - icount_scale=icount_scale+1 - if (icount_scale.gt.maxcount_scale) then - write (iout,*) - & "ERROR: too many attempts at scaling down the time step. ", - & "amax=",amax,"epdrift=",epdrift, - & "damax=",damax,"edriftmax=",edriftmax, - & "d_time=",d_time - call flush(iout) -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,IERRCODE) -#endif - stop - endif -c First step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet1 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet1_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet1 - else if (tnp1) then - call tnp1_step1 - else if (tnp) then - call tnp_step1 - else - if (tnh) then - call nhcint(EK,scale_nh,wdti,wdti2,wdti4,wdti8) - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t_old(j,i)*scale_nh - enddo - enddo - endif - call verlet1 - endif -c Build the chain from the newly calculated coordinates - call chainbuild_cart - if (rattle) call rattle1 - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "Cartesian and internal coordinates: step 1" - call cartprint - call intout - write (iout,*) "dC" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo - write (iout,*) "Accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 1" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Calculate energy and forces - call zerograd - call etotal(potEcomp) -#ifdef TIMING_ENE -#ifdef MPI - t_etotal=t_etotal+MPI_Wtime()-tt0 -#else - t_etotal=t_etotal+tcpu()-tt0 -#endif -#endif - E_old=potE - potE=potEcomp(0)-potEcomp(20) - call cartgrad -c Get the new accelerations - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Determine maximum acceleration and scale down the timestep if needed - call max_accel - amax=amax/(itime_scal+1)**2 - call predict_edrift(epdrift) - if (amax/(itime_scal+1).gt.damax .or. epdrift.gt.edriftmax) then -c Maximum acceleration or maximum predicted energy drift exceeded, rescale the time step - scale=.true. - ifac_time=dmax1(dlog(amax/damax),dlog(epdrift/edriftmax)) - & /dlog(2.0d0)+1 - itime_scal=itime_scal+ifac_time -c fac_time=dmin1(damax/amax,0.5d0) - fac_time=0.5d0**ifac_time - d_time=d_time*fac_time - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 -c write (iout,*) "Calling sd_verlet_setup: 1" -c Rescale the stochastic forces and recalculate or restore -c the matrices of tinker integrator - if (itime_scal.gt.maxflag_stoch) then - if (large) write (iout,'(a,i5,a)') - & "Calculate matrices for stochastic step;", - & " itime_scal ",itime_scal - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - write (iout,'(2a,i3,a,i3,1h.)') - & "Warning: cannot store matrices for stochastic", - & " integration because the index",itime_scal, - & " is greater than",maxflag_stoch - write (iout,'(2a)')"Increase MAXFLAG_STOCH or use direct", - & " integration Langevin algorithm for better efficiency." - else if (flag_stoch(itime_scal)) then - if (large) write (iout,'(a,i5,a,l1)') - & "Restore matrices for stochastic step; itime_scal ", - & itime_scal," flag ",flag_stoch(itime_scal) - do i=1,dimen3 - do j=1,dimen3 - pfric_mat(i,j)=pfric0_mat(i,j,itime_scal) - afric_mat(i,j)=afric0_mat(i,j,itime_scal) - vfric_mat(i,j)=vfric0_mat(i,j,itime_scal) - prand_mat(i,j)=prand0_mat(i,j,itime_scal) - vrand_mat1(i,j)=vrand0_mat1(i,j,itime_scal) - vrand_mat2(i,j)=vrand0_mat2(i,j,itime_scal) - enddo - enddo - else - if (large) write (iout,'(2a,i5,a,l1)') - & "Calculate & store matrices for stochastic step;", - & " itime_scal ",itime_scal," flag ",flag_stoch(itime_scal) - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - flag_stoch(ifac_time)=.true. - do i=1,dimen3 - do j=1,dimen3 - pfric0_mat(i,j,itime_scal)=pfric_mat(i,j) - afric0_mat(i,j,itime_scal)=afric_mat(i,j) - vfric0_mat(i,j,itime_scal)=vfric_mat(i,j) - prand0_mat(i,j,itime_scal)=prand_mat(i,j) - vrand0_mat1(i,j,itime_scal)=vrand_mat1(i,j) - vrand0_mat2(i,j,itime_scal)=vrand_mat2(i,j) - enddo - enddo - endif - fac_time=1.0d0/dsqrt(fac_time) - do i=1,dimen3 - stochforcvec(i)=fac_time*stochforcvec(i) - enddo -#endif - else if (lang.eq.1) then -c Rescale the accelerations due to stochastic forces - fac_time=1.0d0/dsqrt(fac_time) - do i=1,dimen3 - d_as_work(i)=d_as_work(i)*fac_time - enddo - endif - if (large) write (iout,'(a,i10,a,f8.6,a,i3,a,i3)') - & "itime",itime," Timestep scaled down to ", - & d_time," ifac_time",ifac_time," itime_scal",itime_scal - else -c Second step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet2 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet2_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet2 - else if (tnp1) then - call tnp1_step2 - else if (tnp) then - call tnp_step2 - else - call verlet2 - if (tnh) then - call kinetic(EK) - call nhcint(EK,scale_nh,wdti,wdti2,wdti4,wdti8) - do i=0,2*nres - do j=1,3 - d_t(j,i)=d_t(j,i)*scale_nh - enddo - enddo - endif - endif - if (rattle) call rattle2 - totT=totT+d_time - if (d_time.ne.d_time0) then - d_time=d_time0 -#ifndef LANG0 - if (lang.eq.2 .or. lang.eq.3) then - if (large) write (iout,'(a)') - & "Restore original matrices for stochastic step" -c write (iout,*) "Calling sd_verlet_setup: 2" -c Restore the matrices of tinker integrator if the time step has been restored - do i=1,dimen3 - do j=1,dimen3 - pfric_mat(i,j)=pfric0_mat(i,j,0) - afric_mat(i,j)=afric0_mat(i,j,0) - vfric_mat(i,j)=vfric0_mat(i,j,0) - prand_mat(i,j)=prand0_mat(i,j,0) - vrand_mat1(i,j)=vrand0_mat1(i,j,0) - vrand_mat2(i,j)=vrand0_mat2(i,j,0) - enddo - enddo - endif -#endif - endif - scale=.false. - endif - enddo -c Calculate the kinetic and the total energy and the kinetic temperature - if (tnp .or. tnp1) then - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - d_t(j,i)=d_t(j,i)/s_np - enddo - enddo - endif - call kinetic(EK) - totE=EK+potE -c diagnostics -c call kinetic1(EK1) -c write (iout,*) "step",itime," EK",EK," EK1",EK1 -c end diagnostics -c Couple the system to Berendsen bath if needed - if (tbf .and. lang.eq.0) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK -c Backup the coordinates, velocities, and accelerations - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - if(.not.(tnp .or. tnp1)) d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) then - - if(tnp .or. tnp1) then - HNose1=Hnose(EK,s_np,potE,pi_np,Q_np,t_bath,dimen3) - H=(HNose1-H0)*s_np -cd write (iout,'(a,10f)') "hhh",EK,s_np,potE,pi_np,H0 -cd & ,EK+potE+pi_np**2/(2*Q_np)+dimen3*0.001986d0*t_bath*log(s_np) -cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 - hhh=h - endif - - if(tnh) then - HNose1=Hnose_nh(EK,potE) - H=HNose1-H0 - hhh=h -cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 - endif - - if (large) then - itnp=0 - do j=1,3 - itnp=itnp+1 - vtnp(itnp)=d_t(j,0) - enddo - do i=nnt,nct-1 - do j=1,3 - itnp=itnp+1 - vtnp(itnp)=d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - itnp=itnp+1 - vtnp(itnp)=d_t(j,inres) - enddo - endif - enddo - -c Transform velocities from UNRES coordinate space to cartesian and Gvec -c eigenvector space - - do i=1,dimen3 - vtnp_(i)=0.0d0 - vtnp_a(i)=0.0d0 - do j=1,dimen3 - vtnp_(i)=vtnp_(i)+Gvec(j,i)*vtnp(j) - vtnp_a(i)=vtnp_a(i)+A(i,j)*vtnp(j) - enddo - vtnp_(i)=vtnp_(i)*dsqrt(geigen(i)) - enddo - - do i=1,dimen3 - write (iout,'("WWW",i3,3f10.5)') i,vtnp(i),vtnp_(i),vtnp_a(i) - enddo - - write (iout,*) "Velocities, step 2" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif - endif - return - end -c------------------------------------------------------------------------------- - subroutine RESPA_step(itime) -c------------------------------------------------------------------------------- -c Perform a single RESPA step. -c------------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer IERROR,ERRCODE -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision energia_short(0:n_ene), - & energia_long(0:n_ene) - double precision cm(3),L(3),vcm(3),incr(3) - double precision dc_old0(3,0:maxres2),d_t_old0(3,0:maxres2), - & d_a_old0(3,0:maxres2) - integer ilen,count,rstcount - external ilen - character*50 tytul - integer maxcount_scale /10/ - common /gucio/ cm,energia_short - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - integer itime - logical scale - double precision vtnp(maxres6), vtnp_(maxres6), vtnp_a(maxres6) - common /cipiszcze/ itt - itt=itime - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "***************** RESPA itime",itime - write (iout,*) "Cartesian and internal coordinates: step 0" -c call cartprint - call pdbout(0.0d0,"cipiszcze",iout) - call intout - write (iout,*) "Accelerations from long-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 0" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c -c Perform the initial RESPA step (increment velocities) -c write (iout,*) "*********************** RESPA ini" - if (tnp1) then - call tnp_respa_step1 - else if (tnp) then - call tnp_respa_step1 - else - if (tnh.and..not.xiresp) then - call nhcint(EK,scale_nh,wdti,wdti2,wdti4,wdti8) - do i=0,2*nres - do j=1,3 - d_t(j,i)=d_t(j,i)*scale_nh - enddo - enddo - endif - call RESPA_vel - endif - -cd if(tnp .or. tnp1) then -cd write (iout,'(a,3f)') "EE1 NP S, pi",totT, s_np, pi_np -cd endif - - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, end" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c Compute the short-range forces -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif -C 7/2/2009 commented out -c call zerograd -c call etotal_short(energia_short) - if (tnp.or.tnp1) potE=energia_short(0) -c call cartgrad -c call lagrangian -C 7/2/2009 Copy accelerations due to short-lange forces from previous MD step - do i=0,2*nres - do j=1,3 - d_a(j,i)=d_a_short(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "energia_short",energia_short(0) - write (iout,*) "Accelerations from short-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - if(.not.(tnp .or. tnp1)) d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo -c 6/30/08 A-MTS: attempt at increasing the split number - do i=0,2*nres - do j=1,3 - dc_old0(j,i)=dc_old(j,i) - d_t_old0(j,i)=d_t_old(j,i) - d_a_old0(j,i)=d_a_old(j,i) - enddo - enddo - if (ntime_split.gt.ntime_split0) ntime_split=ntime_split/2 - if (ntime_split.lt.ntime_split0) ntime_split=ntime_split0 -c - scale=.true. - d_time0=d_time - do while (scale) - - scale=.false. -c write (iout,*) "itime",itime," ntime_split",ntime_split -c Split the time step - d_time=d_time0/ntime_split -c Perform the short-range RESPA steps (velocity Verlet increments of -c positions and velocities using short-range forces) -c write (iout,*) "*********************** RESPA split" - do itsplit=1,ntime_split - if (lang.eq.1) then - call sddir_precalc - else if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call stochastic_force(stochforcvec) -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif -c First step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet1 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet1_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet1 - else if (tnp1) then - call tnp1_respa_i_step1 - else if (tnp) then - call tnp_respa_i_step1 - else - if (tnh.and.xiresp) then - call kinetic(EK) - call nhcint(EK,scale_nh,wdtii,wdtii2,wdtii4,wdtii8) - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t_old(j,i)*scale_nh - enddo - enddo -cd write(iout,*) "SSS1",itsplit,EK,scale_nh - endif - call verlet1 - endif -c Build the chain from the newly calculated coordinates - call chainbuild_cart - if (rattle) call rattle1 - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "***** ITSPLIT",itsplit - write (iout,*) "Cartesian and internal coordinates: step 1" - call pdbout(0.0d0,"cipiszcze",iout) -c call cartprint - call intout - write (iout,*) "Velocities, step 1" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Calculate energy and forces - call zerograd - call etotal_short(energia_short) - E_old=potE - potE=energia_short(0) -#ifdef TIMING_ENE -#ifdef MPI - t_eshort=t_eshort+MPI_Wtime()-tt0 -#else - t_eshort=t_eshort+tcpu()-tt0 -#endif -#endif - call cartgrad -c Get the new accelerations - call lagrangian -C 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array - do i=0,2*nres - do j=1,3 - d_a_short(j,i)=d_a(j,i) - enddo - enddo - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*)"energia_short",energia_short(0) - write (iout,*) "Accelerations from short-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - endif -c 6/30/08 A-MTS -c Determine maximum acceleration and scale down the timestep if needed - call max_accel - amax=amax/ntime_split**2 - call predict_edrift(epdrift) - if (ntwe.gt.0 .and. large .and. mod(itime,ntwe).eq.0) - & write (iout,*) "amax",amax," damax",damax, - & " epdrift",epdrift," epdriftmax",epdriftmax -c Exit loop and try with increased split number if the change of -c acceleration is too big - if (amax.gt.damax .or. epdrift.gt.edriftmax) then - if (ntime_split.lt.maxtime_split) then - scale=.true. - ntime_split=ntime_split*2 - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc_old0(j,i) - d_t_old(j,i)=d_t_old0(j,i) - d_a_old(j,i)=d_a_old0(j,i) - enddo - enddo - write (iout,*) "acceleration/energy drift too large",amax, - & epdrift," split increased to ",ntime_split," itime",itime, - & " itsplit",itsplit - exit - else - write (iout,*) - & "Uh-hu. Bumpy landscape. Maximum splitting number", - & maxtime_split, - & " already reached!!! Trying to carry on!" - endif - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Second step of the velocity Verlet algorithm - if (lang.eq.2) then -#ifndef LANG0 - call sd_verlet2 -#endif - else if (lang.eq.3) then -#ifndef LANG0 - call sd_verlet2_ciccotti -#endif - else if (lang.eq.1) then - call sddir_verlet2 - else if (tnp1) then - call tnp1_respa_i_step2 - else if (tnp) then - call tnp_respa_i_step2 - else - call verlet2 - if (tnh.and.xiresp) then - call kinetic(EK) - call nhcint(EK,scale_nh,wdtii,wdtii2,wdtii4,wdtii8) - do i=0,2*nres - do j=1,3 - d_t(j,i)=d_t(j,i)*scale_nh - enddo - enddo -cd write(iout,*) "SSS2",itsplit,EK,scale_nh - endif - endif - if (rattle) call rattle2 -c Backup the coordinates, velocities, and accelerations - if (tnp .or. tnp1) then - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - if (tnp) d_t(j,i)=d_t(j,i)/s_np - if (tnp1) d_t(j,i)=d_t(j,i)/s_np - enddo - enddo - endif - - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - if(.not.(tnp .or. tnp1)) d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo - enddo - enddo - - enddo ! while scale - -c Restore the time step - d_time=d_time0 -c Compute long-range forces -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_long(energia_long) - E_long=energia_long(0) - potE=energia_short(0)+energia_long(0) -#ifdef TIMING_ENE -#ifdef MPI - t_elong=t_elong+MPI_Wtime()-tt0 -#else - t_elong=t_elong+tcpu()-tt0 -#endif -#endif - call cartgrad - call lagrangian -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif -c Compute accelerations from long-range forces - if (ntwe.ne.0) then - if (large.and. mod(itime,ntwe).eq.0) then - write (iout,*) "energia_long",energia_long(0) - write (iout,*) "Cartesian and internal coordinates: step 2" -c call cartprint - call pdbout(0.0d0,"cipiszcze",iout) - call intout - write (iout,*) "Accelerations from long-range forces" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - write (iout,*) "Velocities, step 2" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - endif -c Compute the final RESPA step (increment velocities) -c write (iout,*) "*********************** RESPA fin" - if (tnp1) then - call tnp_respa_step2 - else if (tnp) then - call tnp_respa_step2 - else - call RESPA_vel - if (tnh.and..not.xiresp) then - call kinetic(EK) - call nhcint(EK,scale_nh,wdti,wdti2,wdti4,wdti8) - do i=0,2*nres - do j=1,3 - d_t(j,i)=d_t(j,i)*scale_nh - enddo - enddo - endif - endif - - if (tnp .or. tnp1) then - do i=0,2*nres - do j=1,3 - d_t(j,i)=d_t_old(j,i)/s_np - enddo - enddo - endif - -c Compute the complete potential energy - do i=0,n_ene - potEcomp(i)=energia_short(i)+energia_long(i) - enddo - potE=potEcomp(0)-potEcomp(20) -c potE=energia_short(0)+energia_long(0) - totT=totT+d_time -c Calculate the kinetic and the total energy and the kinetic temperature - call kinetic(EK) - totE=EK+potE -c Couple the system to Berendsen bath if needed - if (tbf .and. lang.eq.0) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK -c Backup the coordinates, velocities, and accelerations - if (ntwe.ne.0) then - if (mod(itime,ntwe).eq.0 .and. large) then - write (iout,*) "Velocities, end" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - endif - - if (mod(itime,ntwe).eq.0) then - - if(tnp .or. tnp1) then -#ifndef G77 - write (iout,'(a3,7f)') "TTT",EK,s_np,potE,pi_np,Csplit, - & E_long,energia_short(0) -#else - write (iout,'(a3,7f20.10)') "TTT",EK,s_np,potE,pi_np,Csplit, - & E_long,energia_short(0) -#endif - HNose1=Hnose(EK,s_np,potE,pi_np,Q_np,t_bath,dimen3) - H=(HNose1-H0)*s_np -cd write (iout,'(a,10f)') "hhh",EK,s_np,potE,pi_np,H0 -cd & ,EK+potE+pi_np**2/(2*Q_np)+dimen3*0.001986d0*t_bath*log(s_np) -cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 - hhh=h -cd write (iout,'(a,3f)') "EE2 NP S, pi",totT, s_np, pi_np - endif - - if(tnh) then - HNose1=Hnose_nh(EK,potE) - H=HNose1-H0 -cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 - hhh=h - endif - - - if (large) then - itnp=0 - do j=1,3 - itnp=itnp+1 - vtnp(itnp)=d_t(j,0) - enddo - do i=nnt,nct-1 - do j=1,3 - itnp=itnp+1 - vtnp(itnp)=d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - itnp=itnp+1 - vtnp(itnp)=d_t(j,inres) - enddo - endif - enddo - -c Transform velocities from UNRES coordinate space to cartesian and Gvec -c eigenvector space - - do i=1,dimen3 - vtnp_(i)=0.0d0 - vtnp_a(i)=0.0d0 - do j=1,dimen3 - vtnp_(i)=vtnp_(i)+Gvec(j,i)*vtnp(j) - vtnp_a(i)=vtnp_a(i)+A(i,j)*vtnp(j) - enddo - vtnp_(i)=vtnp_(i)*dsqrt(geigen(i)) - enddo - - do i=1,dimen3 - write (iout,'("WWW",i3,3f10.5)') i,vtnp(i),vtnp_(i),vtnp_a(i) - enddo - - endif - endif - endif - - - return - end -c--------------------------------------------------------------------- - subroutine RESPA_vel -c First and last RESPA step (incrementing velocities using long-range -c forces). - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - do j=1,3 - d_t(j,0)=d_t(j,0)+0.5d0*d_a(j,0)*d_time - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t(j,i)+0.5d0*d_a(j,i)*d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t(j,inres)+0.5d0*d_a(j,inres)*d_time - enddo - endif - enddo - return - end -c----------------------------------------------------------------- - subroutine verlet1 -c Applying velocity Verlet algorithm - step 1 to coordinates - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision adt,adt2 - -#ifdef DEBUG - write (iout,*) "VELVERLET1 START: DC" - do i=0,nres - write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo -#endif - do j=1,3 - adt=d_a_old(j,0)*d_time - adt2=0.5d0*adt - dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time - d_t_new(j,0)=d_t_old(j,0)+adt2 - d_t(j,0)=d_t_old(j,0)+adt - enddo - do i=nnt,nct-1 - do j=1,3 - adt=d_a_old(j,i)*d_time - adt2=0.5d0*adt - dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time - d_t_new(j,i)=d_t_old(j,i)+adt2 - d_t(j,i)=d_t_old(j,i)+adt - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - adt=d_a_old(j,inres)*d_time - adt2=0.5d0*adt - dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time - d_t_new(j,inres)=d_t_old(j,inres)+adt2 - d_t(j,inres)=d_t_old(j,inres)+adt - enddo - endif - enddo -#ifdef DEBUG - write (iout,*) "VELVERLET1 END: DC" - do i=0,nres - write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo -#endif - return - end -c--------------------------------------------------------------------- - subroutine verlet2 -c Step 2 of the velocity Verlet algorithm: update velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - do j=1,3 - d_t(j,0)=d_t_new(j,0)+0.5d0*d_a(j,0)*d_time - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+0.5d0*d_a(j,i)*d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+0.5d0*d_a(j,inres)*d_time - enddo - endif - enddo - return - end -c----------------------------------------------------------------- - subroutine sddir_precalc -c Applying velocity Verlet algorithm - step 1 to coordinates - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute friction and stochastic forces -c -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif - call friction_force -#ifdef MPI - time_fric=time_fric+MPI_Wtime()-time00 - time00=MPI_Wtime() -#else - time_fric=time_fric+tcpu()-time00 - time00=tcpu() -#endif - call stochastic_force(stochforcvec) -#ifdef MPI - time_stoch=time_stoch+MPI_Wtime()-time00 -#else - time_stoch=time_stoch+tcpu()-time00 -#endif -c -c Compute the acceleration due to friction forces (d_af_work) and stochastic -c forces (d_as_work) -c - call ginv_mult(fric_work, d_af_work) - call ginv_mult(stochforcvec, d_as_work) - return - end -c--------------------------------------------------------------------- - subroutine sddir_verlet1 -c Applying velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' -c Revised 3/31/05 AL: correlation between random contributions to -c position and velocity increments included. - double precision sqrt13 /0.57735026918962576451d0/ ! 1/sqrt(3) - double precision adt,adt2 -c -c Add the contribution from BOTH friction and stochastic force to the -c coordinates, but ONLY the contribution from the friction forces to velocities -c - do j=1,3 - adt=(d_a_old(j,0)+d_af_work(j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(j)*d_time - dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time - d_t_new(j,0)=d_t_old(j,0)+0.5d0*adt - d_t(j,0)=d_t_old(j,0)+adt - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - adt=(d_a_old(j,i)+d_af_work(ind+j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time - dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time - d_t_new(j,i)=d_t_old(j,i)+0.5d0*adt - d_t(j,i)=d_t_old(j,i)+adt - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - adt=(d_a_old(j,inres)+d_af_work(ind+j))*d_time - adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time - dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time - d_t_new(j,inres)=d_t_old(j,inres)+0.5d0*adt - d_t(j,inres)=d_t_old(j,inres)+adt - enddo - ind=ind+3 - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine sddir_verlet2 -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),d_as_work1(MAXRES6) - double precision cos60 /0.5d0/, sin60 /0.86602540378443864676d0/ -c Revised 3/31/05 AL: correlation between random contributions to -c position and velocity increments included. -c The correlation coefficients are calculated at low-friction limit. -c Also, friction forces are now not calculated with new velocities. - -c call friction_force - call stochastic_force(stochforcvec) -c -c Compute the acceleration due to friction forces (d_af_work) and stochastic -c forces (d_as_work) -c - call ginv_mult(stochforcvec, d_as_work1) - -c -c Update velocities -c - do j=1,3 - d_t(j,0)=d_t_new(j,0)+(0.5d0*(d_a(j,0)+d_af_work(j)) - & +sin60*d_as_work(j)+cos60*d_as_work1(j))*d_time - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+(0.5d0*(d_a(j,i)+d_af_work(ind+j)) - & +sin60*d_as_work(ind+j)+cos60*d_as_work1(ind+j))*d_time - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+(0.5d0*(d_a(j,inres) - & +d_af_work(ind+j))+sin60*d_as_work(ind+j) - & +cos60*d_as_work1(ind+j))*d_time - enddo - ind=ind+3 - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine max_accel -c -c Find the maximum difference in the accelerations of the the sites -c at the beginning and the end of the time step. -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - double precision aux(3),accel(3),accel_old(3),dacc - do j=1,3 -c aux(j)=d_a(j,0)-d_a_old(j,0) - accel_old(j)=d_a_old(j,0) - accel(j)=d_a(j,0) - enddo - amax=0.0d0 - do i=nnt,nct -c Backbone - if (i.lt.nct) then -c 7/3/08 changed to asymmetric difference - do j=1,3 -c accel(j)=aux(j)+0.5d0*(d_a(j,i)-d_a_old(j,i)) - accel_old(j)=accel_old(j)+0.5d0*d_a_old(j,i) - accel(j)=accel(j)+0.5d0*d_a(j,i) -c if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) - if (dabs(accel(j)).gt.dabs(accel_old(j))) then - dacc=dabs(accel(j)-accel_old(j)) - if (dacc.gt.amax) amax=dacc - endif - enddo - endif - enddo -c Side chains - do j=1,3 -c accel(j)=aux(j) - accel_old(j)=d_a_old(j,0) - accel(j)=d_a(j,0) - enddo - if (nnt.eq.2) then - do j=1,3 - accel_old(j)=accel_old(j)+d_a_old(j,1) - accel(j)=accel(j)+d_a(j,1) - enddo - endif - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 -c accel(j)=accel(j)+d_a(j,i+nres)-d_a_old(j,i+nres) - accel_old(j)=accel_old(j)+d_a_old(j,i+nres) - accel(j)=accel(j)+d_a(j,i+nres) - enddo - endif - do j=1,3 -c if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) - if (dabs(accel(j)).gt.dabs(accel_old(j))) then - dacc=dabs(accel(j)-accel_old(j)) - if (dacc.gt.amax) amax=dacc - endif - enddo - do j=1,3 - accel_old(j)=accel_old(j)+d_a_old(j,i) - accel(j)=accel(j)+d_a(j,i) -c aux(j)=aux(j)+d_a(j,i)-d_a_old(j,i) - enddo - enddo - return - end -c--------------------------------------------------------------------- - subroutine predict_edrift(epdrift) -c -c Predict the drift of the potential energy -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.MUCA' - double precision epdrift,epdriftij -c Drift of the potential energy - epdrift=0.0d0 - do i=nnt,nct -c Backbone - if (i.lt.nct) then - do j=1,3 - epdriftij=dabs((d_a(j,i)-d_a_old(j,i))*gcart(j,i)) - if (lmuca) epdriftij=epdriftij*factor -c write (iout,*) "back",i,j,epdriftij - if (epdriftij.gt.epdrift) epdrift=epdriftij - enddo - endif -c Side chains - if (itype(i).ne.10) then - do j=1,3 - epdriftij= - & dabs((d_a(j,i+nres)-d_a_old(j,i+nres))*gxcart(j,i)) - if (lmuca) epdriftij=epdriftij*factor -c write (iout,*) "side",i,j,epdriftij - if (epdriftij.gt.epdrift) epdrift=epdriftij - enddo - endif - enddo - epdrift=0.5d0*epdrift*d_time*d_time -c write (iout,*) "epdrift",epdrift - return - end -c----------------------------------------------------------------------- - subroutine verlet_bath -c -c Coupling to the thermostat by using the Berendsen algorithm -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision T_half,fact -c - T_half=2.0d0/(dimen3*Rb)*EK - fact=dsqrt(1.0d0+(d_time/tau_bath)*(t_bath/T_half-1.0d0)) -c write(iout,*) "T_half", T_half -c write(iout,*) "EK", EK -c write(iout,*) "fact", fact - do j=1,3 - d_t(j,0)=fact*d_t(j,0) - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=fact*d_t(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=fact*d_t(j,inres) - enddo - endif - enddo - return - end -c--------------------------------------------------------- - subroutine init_MD -c Set up the initial conditions of a MD simulation - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MP - include 'mpif.h' - character*16 form - integer IERROR,ERRCODE -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.REMD' - real*8 energia_long(0:n_ene), - & energia_short(0:n_ene),vcm(3),incr(3),E_short - double precision cm(3),L(3),xv,sigv,lowb,highb - double precision varia(maxvar) - character*256 qstr - integer ilen - external ilen - character*50 tytul - logical file_exist - common /gucio/ cm - d_time0=d_time -c write(iout,*) "d_time", d_time -c Compute the standard deviations of stochastic forces for Langevin dynamics -c if the friction coefficients do not depend on surface area - if (lang.gt.0 .and. .not.surfarea) then - do i=nnt,nct-1 - stdforcp(i)=stdfp*dsqrt(gamp) - enddo - do i=nnt,nct - stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamsc(itype(i))) - enddo - endif -c Open the pdb file for snapshotshots -#ifdef MPI - if(mdpdb) then - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".pdb") - open(ipdb, - & file=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".pdb") - else -#ifdef NOXDR - if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".x") - cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".x" -#else - if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// - & liczba(:ilen(liczba))//".cx") - cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) - & //".cx" -#endif - endif -#else - if(mdpdb) then - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.pdb") - open(ipdb,file=prefix(:ilen(prefix))//"_MD.pdb") - else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.cx") - cartname=prefix(:ilen(prefix))//"_MD.cx" - endif -#endif - if (usampl) then - write (qstr,'(256(1h ))') - ipos=1 - do i=1,nfrag - iq = qinfrag(i,iset)*10 - iw = wfrag(i,iset)/100 - if (iw.gt.0) then - if(me.eq.king.or..not.out1file) - & write (iout,*) "Frag",qinfrag(i,iset),wfrag(i,iset),iq,iw - write (qstr(ipos:ipos+6),'(2h_f,i1,1h_,i1,1h_,i1)') i,iq,iw - ipos=ipos+7 - endif - enddo - do i=1,npair - iq = qinpair(i,iset)*10 - iw = wpair(i,iset)/100 - if (iw.gt.0) then - if(me.eq.king.or..not.out1file) - & write (iout,*) "Pair",i,qinpair(i,iset),wpair(i,iset),iq,iw - write (qstr(ipos:ipos+6),'(2h_p,i1,1h_,i1,1h_,i1)') i,iq,iw - ipos=ipos+7 - endif - enddo -c pdbname=pdbname(:ilen(pdbname)-4)//qstr(:ipos-1)//'.pdb' -#ifdef NOXDR -c cartname=cartname(:ilen(cartname)-2)//qstr(:ipos-1)//'.x' -#else -c cartname=cartname(:ilen(cartname)-3)//qstr(:ipos-1)//'.cx' -#endif -c statname=statname(:ilen(statname)-5)//qstr(:ipos-1)//'.stat' - endif - icg=1 - if (rest) then - if (restart1file) then - if (me.eq.king) - & inquire(file=mremd_rst_name,exist=file_exist) - write (*,*) me," Before broadcast: file_exist",file_exist -#ifdef MPI - call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM, - & IERR) - write (*,*) me," After broadcast: file_exist",file_exist -#endif -c inquire(file=mremd_rst_name,exist=file_exist) - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial state read by master and distributed" - else - if (ilen(tmpdir).gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_' - & //liczba(:ilen(liczba))//'.rst') - inquire(file=rest2name,exist=file_exist) - endif - if(file_exist) then - if(.not.restart1file) then - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial state will be read from file ", - & rest2name(:ilen(rest2name)) - call readrst - endif - call rescale_weights(t_bath) - else - if(me.eq.king.or..not.out1file)then - if (restart1file) then - write(iout,*) "File ",mremd_rst_name(:ilen(mremd_rst_name)), - & " does not exist" - else - write(iout,*) "File ",rest2name(:ilen(rest2name)), - & " does not exist" - endif - write(iout,*) "Initial velocities randomly generated" - endif - call random_vel - totT=0.0d0 - endif - else -c Generate initial velocities - if(me.eq.king.or..not.out1file) - & write(iout,*) "Initial velocities randomly generated" - call random_vel - totT=0.0d0 - endif -c rest2name = prefix(:ilen(prefix))//'.rst' - if(me.eq.king.or..not.out1file)then - write (iout,*) "Initial velocities" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - call flush(iout) -c Zeroing the total angular momentum of the system - write(iout,*) "Calling the zero-angular - & momentum subroutine" - endif - call inertia_tensor -c Getting the potential energy and forces and velocities and accelerations - call vcm_vel(vcm) -c write (iout,*) "velocity of the center of the mass:" -c write (iout,*) (vcm(j),j=1,3) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo -c Removing the velocity of the center of mass - call vcm_vel(vcm) - if(me.eq.king.or..not.out1file)then - write (iout,*) "vcm right after adjustment:" - write (iout,*) (vcm(j),j=1,3) - call flush(iout) - endif - if (.not.rest) then - call chainbuild - if(iranconf.ne.0) then - if (overlapsc) then - print *, 'Calling OVERLAP_SC' - call overlap_sc(fail) - endif - - if (searchsc) then - call sc_move(2,nres-1,10,1d10,nft_sc,etot) - print *,'SC_move',nft_sc,etot - if(me.eq.king.or..not.out1file) - & write(iout,*) 'SC_move',nft_sc,etot - endif - - if(dccart)then - print *, 'Calling MINIM_DC' - call minim_dc(etot,iretcode,nfun) - else - call geom_to_var(nvar,varia) - print *,'Calling MINIMIZE.' - call minimize(etot,varia,iretcode,nfun) - call var_to_geom(nvar,varia) - endif - if(me.eq.king.or..not.out1file) - & write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun - endif - endif - call chainbuild_cart - call kinetic(EK) - if (tbf) then - call verlet_bath - endif - kinetic_T=2.0d0/(dimen3*Rb)*EK - if(me.eq.king.or..not.out1file)then - call cartprint - call intout - endif -#ifdef MPI - tt0=MPI_Wtime() -#else - tt0=tcpu() -#endif - call zerograd - call etotal(potEcomp) -#ifdef TIMING_ENE -#ifdef MPI - t_etotal=t_etotal+MPI_Wtime()-tt0 -#else - t_etotal=t_etotal+tcpu()-tt0 -#endif -#endif - potE=potEcomp(0) - - if(tnp .or. tnp1) then - s_np=1.0 - pi_np=0.0 - HNose1=Hnose(EK,s_np,potE,pi_np,Q_np,t_bath,dimen3) - H0=Hnose1 - write(iout,*) 'H0= ',H0 - endif - - if(tnh) then - HNose1=Hnose_nh(EK,potE) - H0=HNose1 - write (iout,*) 'H0= ',H0 - endif - - if (hmc.gt.0) then - hmc_acc=0 - hmc_etot=potE+EK - if(me.eq.king.or..not.out1file) - & write(iout,*) 'HMC',hmc_etot,potE,EK - do i=1,2*nres - do j=1,3 - dc_hmc(j,i)=dc(j,i) - enddo - enddo - endif - - call cartgrad - call lagrangian - call max_accel - if (amax*d_time .gt. dvmax) then - d_time=d_time*dvmax/amax - if(me.eq.king.or..not.out1file) write (iout,*) - & "Time step reduced to",d_time, - & " because of too large initial acceleration." - endif - if(me.eq.king.or..not.out1file)then - write(iout,*) "Potential energy and its components" - call enerprint(potEcomp) -c write(iout,*) (potEcomp(i),i=0,n_ene) - endif - potE=potEcomp(0)-potEcomp(20) - totE=EK+potE - itime=0 - if (ntwe.ne.0) call statout(itime) - if(me.eq.king.or..not.out1file) - & write (iout,'(/a/3(a25,1pe14.5/))') "Initial:", - & " Kinetic energy",EK," potential energy",potE, - & " total energy",totE," maximum acceleration ", - & amax - if (large) then - write (iout,*) "Initial coordinates" - do i=1,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(c(j,i),j=1,3), - & (c(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial dC" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3), - & (dc(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial velocities" - write (iout,"(13x,' backbone ',23x,' side chain')") - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), - & (d_t(j,i+nres),j=1,3) - enddo - write (iout,*) "Initial accelerations" - do i=0,nres -c write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - write (iout,'(i3,3f15.10,3x,3f15.10)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif - do i=0,2*nres - do j=1,3 - dc_old(j,i)=dc(j,i) - d_t_old(j,i)=d_t(j,i) - d_a_old(j,i)=d_a(j,i) - enddo -c write (iout,*) "dc_old",i,(dc_old(j,i),j=1,3) - enddo - if (RESPA) then -#ifdef MPI - tt0 =MPI_Wtime() -#else - tt0 = tcpu() -#endif - call zerograd - call etotal_short(energia_short) -#ifdef TIMING_ENE -#ifdef MPI - t_eshort=t_eshort+MPI_Wtime()-tt0 -#else - t_eshort=t_eshort+tcpu()-tt0 -#endif -#endif - - if(tnp .or. tnp1) then - E_short=energia_short(0) - HNose1=Hnose(EK,s_np,E_short,pi_np,Q_np,t_bath,dimen3) - Csplit=Hnose1 -c Csplit =110 -c_new_var_csplit Csplit=H0-E_long -c Csplit = H0-energia_short(0) - write(iout,*) 'Csplit= ',Csplit - endif - - - call cartgrad - call lagrangian - if(.not.out1file .and. large) then - write (iout,*) "energia_long",energia_long(0), - & " energia_short",energia_short(0), - & " total",energia_long(0)+energia_short(0) - write (iout,*) "Initial fast-force accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif -C 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array - do i=0,2*nres - do j=1,3 - d_a_short(j,i)=d_a(j,i) - enddo - enddo -#ifdef MPI - tt0=MPI_Wtime() -#else - tt0=tcpu() -#endif - call zerograd - call etotal_long(energia_long) -#ifdef TIMING_ENE -#ifdef MPI - t_elong=t_elong+MPI_Wtime()-tt0 -#else - t_elong=t_elong+tcpu()-tt0 -#endif -#endif - call cartgrad - call lagrangian - if(.not.out1file .and. large) then - write (iout,*) "energia_long",energia_long(0) - write (iout,*) "Initial slow-force accelerations" - do i=0,nres - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), - & (d_a(j,i+nres),j=1,3) - enddo - endif -#ifdef MPI - t_enegrad=t_enegrad+MPI_Wtime()-tt0 -#else - t_enegrad=t_enegrad+tcpu()-tt0 -#endif - endif - - - - return - end -c----------------------------------------------------------- - subroutine random_vel - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision xv,sigv,lowb,highb -c Generate random velocities from Gaussian distribution of mean 0 and std of KT/m -c First generate velocities in the eigenspace of the G matrix -c write (iout,*) "Calling random_vel dimen dimen3",dimen,dimen3 -c call flush(iout) -c write (iout,*) "RANDOM_VEL dimen",dimen - xv=0.0d0 - ii=0 - do i=1,dimen - do k=1,3 - ii=ii+1 - sigv=dsqrt((Rb*t_bath)/geigen(i)) - lowb=-5*sigv - highb=5*sigv - d_t_work_new(ii)=anorm_distr(xv,sigv,lowb,highb) -c write (iout,*) "i",i," ii",ii," geigen",geigen(i), -c & " d_t_work_new",d_t_work_new(ii) - enddo - enddo - call flush(iout) -c diagnostics -c Ek1=0.0d0 -c ii=0 -c do i=1,dimen -c do k=1,3 -c ii=ii+1 -c Ek1=Ek1+0.5d0*geigen(i)*d_t_work_new(ii)**2 -c enddo -c enddo -c write (iout,*) "Ek from eigenvectors",Ek1 -c end diagnostics -c Transform velocities to UNRES coordinate space - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - d_t_work(ind)=0.0d0 - do j=1,dimen - d_t_work(ind)=d_t_work(ind) - & +Gvec(i,j)*d_t_work_new((j-1)*3+k+1) - enddo -c write (iout,*) "i",i," ind",ind," d_t_work",d_t_work(ind) -c call flush(iout) - enddo - enddo -c Transfer to the d_t vector - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - d_t(j,i)=d_t_work(ind) - enddo - enddo -c do i=0,nres-1 -c write (iout,*) "d_t",i,(d_t(j,i),j=1,3) -c enddo -c call flush(iout) - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - ind=ind+1 - d_t(j,i+nres)=d_t_work(ind) - enddo - endif - enddo -c call kinetic(EK) -c write (iout,*) "Kinetic energy",Ek,EK1," kinetic temperature", -c & 2.0d0/(dimen3*Rb)*EK,2.0d0/(dimen3*Rb)*EK1 -c call flush(iout) - return - end -#ifndef LANG0 -c----------------------------------------------------------- - subroutine sd_verlet_p_setup -c Sets up the parameters of stochastic Verlet algorithm - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision emgdt(MAXRES6), - & pterm,vterm,rho,rhoc,vsig, - & pfric_vec(MAXRES6),vfric_vec(MAXRES6), - & afric_vec(MAXRES6),prand_vec(MAXRES6), - & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6) - logical lprn /.false./ - double precision zero /1.0d-8/, gdt_radius /0.05d0/ - double precision ktm -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c -c AL 8/17/04 Code adapted from tinker -c -c Get the frictional and random terms for stochastic dynamics in the -c eigenspace of mass-scaled UNRES friction matrix -c - do i = 1, dimen - gdt = fricgam(i) * d_time -c -c Stochastic dynamics reduces to simple MD for zero friction -c - if (gdt .le. zero) then - pfric_vec(i) = 1.0d0 - vfric_vec(i) = d_time - afric_vec(i) = 0.5d0 * d_time * d_time - prand_vec(i) = 0.0d0 - vrand_vec1(i) = 0.0d0 - vrand_vec2(i) = 0.0d0 -c -c Analytical expressions when friction coefficient is large -c - else - if (gdt .ge. gdt_radius) then - egdt = dexp(-gdt) - pfric_vec(i) = egdt - vfric_vec(i) = (1.0d0-egdt) / fricgam(i) - afric_vec(i) = (d_time-vfric_vec(i)) / fricgam(i) - pterm = 2.0d0*gdt - 3.0d0 + (4.0d0-egdt)*egdt - vterm = 1.0d0 - egdt**2 - rho = (1.0d0-egdt)**2 / sqrt(pterm*vterm) -c -c Use series expansions when friction coefficient is small -c - else - gdt2 = gdt * gdt - gdt3 = gdt * gdt2 - gdt4 = gdt2 * gdt2 - gdt5 = gdt2 * gdt3 - gdt6 = gdt3 * gdt3 - gdt7 = gdt3 * gdt4 - gdt8 = gdt4 * gdt4 - gdt9 = gdt4 * gdt5 - afric_vec(i) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0 - & - gdt5/120.0d0 + gdt6/720.0d0 - & - gdt7/5040.0d0 + gdt8/40320.0d0 - & - gdt9/362880.0d0) / fricgam(i)**2 - vfric_vec(i) = d_time - fricgam(i)*afric_vec(i) - pfric_vec(i) = 1.0d0 - fricgam(i)*vfric_vec(i) - pterm = 2.0d0*gdt3/3.0d0 - gdt4/2.0d0 - & + 7.0d0*gdt5/30.0d0 - gdt6/12.0d0 - & + 31.0d0*gdt7/1260.0d0 - gdt8/160.0d0 - & + 127.0d0*gdt9/90720.0d0 - vterm = 2.0d0*gdt - 2.0d0*gdt2 + 4.0d0*gdt3/3.0d0 - & - 2.0d0*gdt4/3.0d0 + 4.0d0*gdt5/15.0d0 - & - 4.0d0*gdt6/45.0d0 + 8.0d0*gdt7/315.0d0 - & - 2.0d0*gdt8/315.0d0 + 4.0d0*gdt9/2835.0d0 - rho = sqrt(3.0d0) * (0.5d0 - 3.0d0*gdt/16.0d0 - & - 17.0d0*gdt2/1280.0d0 - & + 17.0d0*gdt3/6144.0d0 - & + 40967.0d0*gdt4/34406400.0d0 - & - 57203.0d0*gdt5/275251200.0d0 - & - 1429487.0d0*gdt6/13212057600.0d0) - end if -c -c Compute the scaling factors of random terms for the nonzero friction case -c - ktm = 0.5d0*d_time/fricgam(i) - psig = dsqrt(ktm*pterm) / fricgam(i) - vsig = dsqrt(ktm*vterm) - rhoc = dsqrt(1.0d0 - rho*rho) - prand_vec(i) = psig - vrand_vec1(i) = vsig * rho - vrand_vec2(i) = vsig * rhoc - end if - end do - if (lprn) then - write (iout,*) - & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,", - & " vrand_vec2" - do i=1,dimen - write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i), - & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) - enddo - endif -c -c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables -c -#ifndef LANG0 - call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) - call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec1,vrand_mat1) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) -#endif -#ifdef MPI - t_sdsetup=t_sdsetup+MPI_Wtime() -#else - t_sdsetup=t_sdsetup+tcpu()-tt0 -#endif - return - end -c------------------------------------------------------------- - subroutine eigtransf1(n,ndim,ab,d,c) - implicit none - integer n,ndim - double precision ab(ndim,ndim,n),c(ndim,n),d(ndim) - integer i,j,k - do i=1,n - do j=1,n - c(i,j)=0.0d0 - do k=1,n - c(i,j)=c(i,j)+ab(k,j,i)*d(k) - enddo - enddo - enddo - return - end -c------------------------------------------------------------- - subroutine eigtransf(n,ndim,a,b,d,c) - implicit none - integer n,ndim - double precision a(ndim,n),b(ndim,n),c(ndim,n),d(ndim) - integer i,j,k - do i=1,n - do j=1,n - c(i,j)=0.0d0 - do k=1,n - c(i,j)=c(i,j)+a(i,k)*b(k,j)*d(k) - enddo - enddo - enddo - return - end -c------------------------------------------------------------- - subroutine sd_verlet1 -c Applying stochastic velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - logical lprn /.false./ - -c write (iout,*) "dc_old" -c do i=0,nres -c write (iout,'(i5,3f10.5,5x,3f10.5)') -c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) -c enddo - do j=1,3 - dc_work(j)=dc_old(j,0) - d_t_work(j)=d_t_old(j,0) - d_a_work(j)=d_a_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc_work(ind+j)=dc_old(j,i) - d_t_work(ind+j)=d_t_old(j,i) - d_a_work(ind+j)=d_a_old(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc_work(ind+j)=dc_old(j,i+nres) - d_t_work(ind+j)=d_t_old(j,i+nres) - d_a_work(ind+j)=d_a_old(j,i+nres) - enddo - ind=ind+3 - endif - enddo -#ifndef LANG0 - if (lprn) then - write (iout,*) - & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,", - & " vrand_mat2" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j), - & vfric_mat(i,j),afric_mat(i,j), - & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) - enddo - enddo - endif - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) - & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) - ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) - ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) - enddo - d_t_work_new(i)=ddt1+0.5d0*ddt2 - d_t_work(i)=ddt1+ddt2 - enddo -#endif - do j=1,3 - dc(j,0)=dc_work(j) - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_work(ind+j) - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_work(ind+j) - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c-------------------------------------------------------------------------- - subroutine sd_verlet2 -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute the stochastic forces which contribute to velocity change -c - call stochastic_force(stochforcvecV) - -#ifndef LANG0 - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) - ddt2=ddt2+vrand_mat1(i,j)*stochforcvec(j)+ - & vrand_mat2(i,j)*stochforcvecV(j) - enddo - d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 - enddo -#endif - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c----------------------------------------------------------- - subroutine sd_verlet_ciccotti_setup -c Sets up the parameters of stochastic velocity Verlet algorithmi; Ciccotti's -c version - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision emgdt(MAXRES6), - & pterm,vterm,rho,rhoc,vsig, - & pfric_vec(MAXRES6),vfric_vec(MAXRES6), - & afric_vec(MAXRES6),prand_vec(MAXRES6), - & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6) - logical lprn /.false./ - double precision zero /1.0d-8/, gdt_radius /0.05d0/ - double precision ktm -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c -c AL 8/17/04 Code adapted from tinker -c -c Get the frictional and random terms for stochastic dynamics in the -c eigenspace of mass-scaled UNRES friction matrix -c - do i = 1, dimen - write (iout,*) "i",i," fricgam",fricgam(i) - gdt = fricgam(i) * d_time -c -c Stochastic dynamics reduces to simple MD for zero friction -c - if (gdt .le. zero) then - pfric_vec(i) = 1.0d0 - vfric_vec(i) = d_time - afric_vec(i) = 0.5d0*d_time*d_time - prand_vec(i) = afric_vec(i) - vrand_vec2(i) = vfric_vec(i) -c -c Analytical expressions when friction coefficient is large -c - else - egdt = dexp(-gdt) - pfric_vec(i) = egdt - vfric_vec(i) = dexp(-0.5d0*gdt)*d_time - afric_vec(i) = 0.5d0*dexp(-0.25d0*gdt)*d_time*d_time - prand_vec(i) = afric_vec(i) - vrand_vec2(i) = vfric_vec(i) -c -c Compute the scaling factors of random terms for the nonzero friction case -c -c ktm = 0.5d0*d_time/fricgam(i) -c psig = dsqrt(ktm*pterm) / fricgam(i) -c vsig = dsqrt(ktm*vterm) -c prand_vec(i) = psig*afric_vec(i) -c vrand_vec2(i) = vsig*vfric_vec(i) - end if - end do - if (lprn) then - write (iout,*) - & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,", - & " vrand_vec2" - do i=1,dimen - write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i), - & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) - enddo - endif -c -c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables -c - call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) - call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) - call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) - call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) -#ifdef MPI - t_sdsetup=t_sdsetup+MPI_Wtime() -#else - t_sdsetup=t_sdsetup+tcpu()-tt0 -#endif - return - end -c------------------------------------------------------------- - subroutine sd_verlet1_ciccotti -c Applying stochastic velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6) - common /stochcalc/ stochforcvec - logical lprn /.false./ - -c write (iout,*) "dc_old" -c do i=0,nres -c write (iout,'(i5,3f10.5,5x,3f10.5)') -c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) -c enddo - do j=1,3 - dc_work(j)=dc_old(j,0) - d_t_work(j)=d_t_old(j,0) - d_a_work(j)=d_a_old(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc_work(ind+j)=dc_old(j,i) - d_t_work(ind+j)=d_t_old(j,i) - d_a_work(ind+j)=d_a_old(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc_work(ind+j)=dc_old(j,i+nres) - d_t_work(ind+j)=d_t_old(j,i+nres) - d_a_work(ind+j)=d_a_old(j,i+nres) - enddo - ind=ind+3 - endif - enddo - -#ifndef LANG0 - if (lprn) then - write (iout,*) - & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,", - & " vrand_mat2" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j), - & vfric_mat(i,j),afric_mat(i,j), - & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) - enddo - enddo - endif - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) - & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) - ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) - ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) - enddo - d_t_work_new(i)=ddt1+0.5d0*ddt2 - d_t_work(i)=ddt1+ddt2 - enddo -#endif - do j=1,3 - dc(j,0)=dc_work(j) - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_work(ind+j) - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_work(ind+j) - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -c-------------------------------------------------------------------------- - subroutine sd_verlet2_ciccotti -c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) - common /stochcalc/ stochforcvec -c -c Compute the stochastic forces which contribute to velocity change -c - call stochastic_force(stochforcvecV) -#ifndef LANG0 - do i=1,dimen - ddt1=0.0d0 - ddt2=0.0d0 - do j=1,dimen - - ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) -c ddt2=ddt2+vrand_mat2(i,j)*stochforcvecV(j) - ddt2=ddt2+vrand_mat2(i,j)*stochforcvec(j) - enddo - d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 - enddo -#endif - do j=1,3 - d_t(j,0)=d_t_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_work(ind+j) - enddo - ind=ind+3 - endif - enddo - return - end -#endif -c------------------------------------------------------ - double precision function HNose(ek,s,e,pi,Q,t_bath,dimenl) - implicit none - double precision ek,s,e,pi,Q,t_bath,Rb - integer dimenl - Rb=0.001986d0 - HNose=ek+e+pi**2/(2*Q)+dimenl*Rb*t_bath*log(s) -c print '(6f15.5,i5,a2,2f15.5)',ek,s,e,pi,Q,t_bath,dimenl,"--", -c & pi**2/(2*Q),dimenl*Rb*t_bath*log(s) - return - end -c----------------------------------------------------------------- - double precision function HNose_nh(eki,e) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MD' - HNose_nh=eki+e+dimen3*Rb*t_bath*xlogs(1)+qmass(1)*vlogs(1)**2/2 - do i=2,nnos - HNose_nh=HNose_nh+qmass(i)*vlogs(i)**2/2+Rb*t_bath*xlogs(i) - enddo -c write(4,'(5e15.5)') -c & vlogs(1),xlogs(1),HNose,eki,e - return - end -c----------------------------------------------------------------- - SUBROUTINE NHCINT(akin,scale,wdti,wdti2,wdti4,wdti8) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MD' - double precision akin,gnkt,dt,aa,gkt,scale - double precision wdti(maxyosh),wdti2(maxyosh), - & wdti4(maxyosh),wdti8(maxyosh) - integer i,iresn,iyosh,inos,nnos1 - - dt=d_time - nnos1=nnos+1 - GKT = Rb*t_bath - GNKT = dimen3*GKT - akin=akin*2 - - -C THIS ROUTINE DOES THE NOSE-HOOVER PART OF THE -C INTEGRATION FROM t=0 TO t=DT/2 -C GET THE TOTAL KINETIC ENERGY - SCALE = 1.D0 -c CALL GETKINP(MASS,VX,VY,VZ,AKIN) -C UPDATE THE FORCES - GLOGS(1) = (AKIN - GNKT)/QMASS(1) -C START THE MULTIPLE TIME STEP PROCEDURE - DO IRESN = 1,NRESN - DO IYOSH = 1,NYOSH -C UPDATE THE THERMOSTAT VELOCITIES - VLOGS(NNOS) = VLOGS(NNOS) + GLOGS(NNOS)*WDTI4(IYOSH) - DO INOS = 1,NNOS-1 - AA = EXP(-WDTI8(IYOSH)*VLOGS(NNOS1-INOS) ) - VLOGS(NNOS-INOS) = VLOGS(NNOS-INOS)*AA*AA - & + WDTI4(IYOSH)*GLOGS(NNOS-INOS)*AA - ENDDO -C UPDATE THE PARTICLE VELOCITIES - AA = EXP(-WDTI2(IYOSH)*VLOGS(1) ) - SCALE = SCALE*AA -C UPDATE THE FORCES - GLOGS(1) = (SCALE*SCALE*AKIN - GNKT)/QMASS(1) -C UPDATE THE THERMOSTAT POSITIONS - DO INOS = 1,NNOS - XLOGS(INOS) = XLOGS(INOS) + VLOGS(INOS)*WDTI2(IYOSH) - ENDDO -C UPDATE THE THERMOSTAT VELOCITIES - DO INOS = 1,NNOS-1 - AA = EXP(-WDTI8(IYOSH)*VLOGS(INOS+1) ) - VLOGS(INOS) = VLOGS(INOS)*AA*AA - & + WDTI4(IYOSH)*GLOGS(INOS)*AA - GLOGS(INOS+1) = (QMASS(INOS)*VLOGS(INOS)*VLOGS(INOS) - & -GKT)/QMASS(INOS+1) - ENDDO - VLOGS(NNOS) = VLOGS(NNOS) + GLOGS(NNOS)*WDTI4(IYOSH) - ENDDO - ENDDO -C UPDATE THE PARTICLE VELOCITIES -c outside of this subroutine -c DO I = 1,N -c VX(I) = VX(I)*SCALE -c VY(I) = VY(I)*SCALE -c VZ(I) = VZ(I)*SCALE -c ENDDO - RETURN - END -c----------------------------------------------------------------- - subroutine tnp1_respa_i_step1 -c Applying Nose-Poincare algorithm - step 1 to coordinates -c JPSJ 70 75 (2001) S. Nose -c -c d_t is not updated here -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision adt,adt2,tmp - - tmp=1+pi_np/(2*Q_np)*0.5*d_time - s12_np=s_np*tmp**2 - pistar=pi_np/tmp - s12_dt=d_time/s12_np - d_time_s12=d_time*0.5*s12_np - - do j=1,3 - d_t_new(j,0)=d_t_old(j,0)+d_a_old(j,0)*d_time_s12 - dc(j,0)=dc_old(j,0)+d_t_new(j,0)*s12_dt - enddo - do i=nnt,nct-1 - do j=1,3 - d_t_new(j,i)=d_t_old(j,i)+d_a_old(j,i)*d_time_s12 - dc(j,i)=dc_old(j,i)+d_t_new(j,i)*s12_dt - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t_new(j,inres)=d_t_old(j,inres)+d_a_old(j,inres)*d_time_s12 - dc(j,inres)=dc_old(j,inres)+d_t_new(j,inres)*s12_dt - enddo - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine tnp1_respa_i_step2 -c Step 2 of the velocity Verlet algorithm: update velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - - double precision d_time_s12 - - do i=0,2*nres - do j=1,3 - d_t(j,i)=d_t_new(j,i) - enddo - enddo - - call kinetic(EK) - EK=EK/s12_np**2 - - d_time_s12=0.5d0*s12_np*d_time - - do j=1,3 - d_t(j,0)=d_t_new(j,0)+d_a(j,0)*d_time_s12 - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+d_a(j,i)*d_time_s12 - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+d_a(j,inres)*d_time_s12 - enddo - endif - enddo - - pistar=pistar+(EK-0.5*(E_old+potE) - & -dimen3*Rb*t_bath*log(s12_np)+Csplit-dimen3*Rb*t_bath)*d_time - tmp=1+pistar/(2*Q_np)*0.5*d_time - s_np=s12_np*tmp**2 - pi_np=pistar/tmp - - return - end -c------------------------------------------------------- - - subroutine tnp1_step1 -c Applying Nose-Poincare algorithm - step 1 to coordinates -c JPSJ 70 75 (2001) S. Nose -c -c d_t is not updated here -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision adt,adt2,tmp - - tmp=1+pi_np/(2*Q_np)*0.5*d_time - s12_np=s_np*tmp**2 - pistar=pi_np/tmp - s12_dt=d_time/s12_np - d_time_s12=d_time*0.5*s12_np - - do j=1,3 - d_t_new(j,0)=d_t_old(j,0)+d_a_old(j,0)*d_time_s12 - dc(j,0)=dc_old(j,0)+d_t_new(j,0)*s12_dt - enddo - do i=nnt,nct-1 - do j=1,3 - d_t_new(j,i)=d_t_old(j,i)+d_a_old(j,i)*d_time_s12 - dc(j,i)=dc_old(j,i)+d_t_new(j,i)*s12_dt - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t_new(j,inres)=d_t_old(j,inres)+d_a_old(j,inres)*d_time_s12 - dc(j,inres)=dc_old(j,inres)+d_t_new(j,inres)*s12_dt - enddo - endif - enddo - return - end -c--------------------------------------------------------------------- - subroutine tnp1_step2 -c Step 2 of the velocity Verlet algorithm: update velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - - double precision d_time_s12 - - do i=0,2*nres - do j=1,3 - d_t(j,i)=d_t_new(j,i) - enddo - enddo - - call kinetic(EK) - EK=EK/s12_np**2 - - d_time_s12=0.5d0*s12_np*d_time - - do j=1,3 - d_t(j,0)=d_t_new(j,0)+d_a(j,0)*d_time_s12 - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+d_a(j,i)*d_time_s12 - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+d_a(j,inres)*d_time_s12 - enddo - endif - enddo - -cd write(iout,*) 'pistar',pistar,EK,E_old,potE,s12_np - pistar=pistar+(EK-0.5*(E_old+potE) - & -dimen3*Rb*t_bath*log(s12_np)+H0-dimen3*Rb*t_bath)*d_time - tmp=1+pistar/(2*Q_np)*0.5*d_time - s_np=s12_np*tmp**2 - pi_np=pistar/tmp - - return - end - -c----------------------------------------------------------------- - subroutine tnp_respa_i_step1 -c Applying Nose-Poincare algorithm - step 1 to coordinates -c J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird -c -c d_t is not updated here, it is destroyed -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision C_np,d_time_s,tmp,d_time_ss - - d_time_s=d_time*0.5*s_np -ct2 d_time_s=d_time*0.5*s12_np - - do j=1,3 - d_t_new(j,0)=d_t_old(j,0)+d_a_old(j,0)*d_time_s - enddo - do i=nnt,nct-1 - do j=1,3 - d_t_new(j,i)=d_t_old(j,i)+d_a_old(j,i)*d_time_s - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t_new(j,inres)=d_t_old(j,inres)+d_a_old(j,inres)*d_time_s - enddo - endif - enddo - - do i=0,2*nres - do j=1,3 - d_t(j,i)=d_t_new(j,i) - enddo - enddo - - call kinetic(EK) - EK=EK/s_np**2 - - C_np=0.5*d_time*(dimen3*Rb*t_bath*(1.0+log(s_np))-EK+potE-Csplit) - & -pi_np - - pistar=-2.0*C_np/(1.0+sqrt(1.0-C_np*d_time/Q_np)) - tmp=0.5*d_time*pistar/Q_np - s12_np=s_np*(1.0+tmp)/(1.0-tmp) - - d_time_ss=0.5*d_time*(1.0/s12_np+1.0/s_np) -ct2 d_time_ss=d_time/s12_np -c d_time_ss=0.5*d_time*(1.0/sold_np+1.0/s_np) - - do j=1,3 - dc(j,0)=dc_old(j,0)+d_t_new(j,0)*d_time_ss - enddo - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_old(j,i)+d_t_new(j,i)*d_time_ss - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_old(j,inres)+d_t_new(j,inres)*d_time_ss - enddo - endif - enddo - - return - end -c--------------------------------------------------------------------- - - subroutine tnp_respa_i_step2 -c Step 2 of the velocity Verlet algorithm: update velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - - double precision d_time_s - - EK=EK*(s_np/s12_np)**2 - HNose1=Hnose(EK,s12_np,potE,pistar,Q_np,t_bath,dimen3) - pi_np=pistar+0.5*d_time*(2*EK-dimen3*Rb*t_bath - & -HNose1+Csplit) - -cr print '(a,5f)','i_step2',EK,potE,HNose1,pi_np,E_long - d_time_s=d_time*0.5*s12_np -c d_time_s=d_time*0.5*s_np - - do j=1,3 - d_t(j,0)=d_t_new(j,0)+d_a(j,0)*d_time_s - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+d_a(j,i)*d_time_s - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+d_a(j,inres)*d_time_s - enddo - endif - enddo - - s_np=s12_np - - return - end -c----------------------------------------------------------------- - subroutine tnp_respa_step1 -c Applying Nose-Poincare algorithm - step 1 to vel for RESPA -c J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird -c -c d_t is not updated here, it is destroyed -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision C_np,d_time_s,tmp,d_time_ss - double precision energia(0:n_ene) - - d_time_s=d_time*0.5*s_np - - do j=1,3 - d_t_old(j,0)=d_t_old(j,0)+d_a(j,0)*d_time_s - enddo - do i=nnt,nct-1 - do j=1,3 - d_t_old(j,i)=d_t_old(j,i)+d_a(j,i)*d_time_s - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t_old(j,inres)=d_t_old(j,inres)+d_a(j,inres)*d_time_s - enddo - endif - enddo - - -c C_np=0.5*d_time*(dimen3*Rb*t_bath*(1.0+log(s_np))-EK+potE-H0) -c & -pi_np -c -c pistar=-2.0*C_np/(1.0+sqrt(1.0-C_np*d_time/Q_np)) -c tmp=0.5*d_time*pistar/Q_np -c s12_np=s_np*(1.0+tmp)/(1.0-tmp) -c write(iout,*) 'tnp_respa_step1',s_np,s12_np,EK,potE,C_np,pistar,tmp - -ct1 pi_np=pistar -c sold_np=s_np -c s_np=s12_np - -c------------------------------------- -c test of reviewer's comment - pi_np=pi_np-0.5*d_time*(E_long+Csplit-H0) -cr print '(a,3f)','1 pi_np,s_np',pi_np,s_np,E_long -c------------------------------------- - - return - end -c--------------------------------------------------------------------- - subroutine tnp_respa_step2 -c Step 2 of the velocity Verlet algorithm: update velocities for RESPA - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - - double precision d_time_s - -ct1 s12_np=s_np -ct2 pistar=pi_np - -ct call kinetic(EK) -ct HNose1=Hnose(EK,s12_np,potE,pistar,Q_np,t_bath,dimen3) -ct pi_np=pistar+0.5*d_time*(2*EK-dimen3*Rb*t_bath) -ct & -0.5*d_time*(HNose1-H0) - -c------------------------------------- -c test of reviewer's comment - pi_np=pi_np-0.5*d_time*(E_long+Csplit-H0) -cr print '(a,3f)','2 pi_np,s_np',pi_np,s_np,E_long -c------------------------------------- - d_time_s=d_time*0.5*s_np - - do j=1,3 - d_t_old(j,0)=d_t_old(j,0)+d_a(j,0)*d_time_s - enddo - do i=nnt,nct-1 - do j=1,3 - d_t_old(j,i)=d_t_old(j,i)+d_a(j,i)*d_time_s - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t_old(j,inres)=d_t_old(j,inres)+d_a(j,inres)*d_time_s - enddo - endif - enddo - -cd s_np=s12_np - - return - end -c--------------------------------------------------------------------- - subroutine tnp_step1 -c Applying Nose-Poincare algorithm - step 1 to coordinates -c J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird -c -c d_t is not updated here, it is destroyed -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision C_np,d_time_s,tmp,d_time_ss - - d_time_s=d_time*0.5*s_np - - do j=1,3 - d_t_new(j,0)=d_t_old(j,0)+d_a_old(j,0)*d_time_s - enddo - do i=nnt,nct-1 - do j=1,3 - d_t_new(j,i)=d_t_old(j,i)+d_a_old(j,i)*d_time_s - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t_new(j,inres)=d_t_old(j,inres)+d_a_old(j,inres)*d_time_s - enddo - endif - enddo - - do i=0,2*nres - do j=1,3 - d_t(j,i)=d_t_new(j,i) - enddo - enddo - - call kinetic(EK) - EK=EK/s_np**2 - - C_np=0.5*d_time*(dimen3*Rb*t_bath*(1.0+log(s_np))-EK+potE-H0) - & -pi_np - - pistar=-2.0*C_np/(1.0+sqrt(1.0-C_np*d_time/Q_np)) - tmp=0.5*d_time*pistar/Q_np - s12_np=s_np*(1.0+tmp)/(1.0-tmp) -c write(iout,*) 'tnp_step1',s_np,s12_np,EK,potE,C_np,pistar,tmp - - d_time_ss=0.5*d_time*(1.0/s12_np+1.0/s_np) - - do j=1,3 - dc(j,0)=dc_old(j,0)+d_t_new(j,0)*d_time_ss - enddo - do i=nnt,nct-1 - do j=1,3 - dc(j,i)=dc_old(j,i)+d_t_new(j,i)*d_time_ss - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - dc(j,inres)=dc_old(j,inres)+d_t_new(j,inres)*d_time_ss - enddo - endif - enddo - - return - end -c----------------------------------------------------------------- - subroutine tnp_step2 -c Step 2 of the velocity Verlet algorithm: update velocities - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - - double precision d_time_s - - EK=EK*(s_np/s12_np)**2 - HNose1=Hnose(EK,s12_np,potE,pistar,Q_np,t_bath,dimen3) - pi_np=pistar+0.5*d_time*(2*EK-dimen3*Rb*t_bath) - & -0.5*d_time*(HNose1-H0) - -cd write(iout,'(a,4f)') 'mmm',EK,potE,HNose1,pi_np - d_time_s=d_time*0.5*s12_np - - do j=1,3 - d_t(j,0)=d_t_new(j,0)+d_a(j,0)*d_time_s - enddo - do i=nnt,nct-1 - do j=1,3 - d_t(j,i)=d_t_new(j,i)+d_a(j,i)*d_time_s - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - inres=i+nres - do j=1,3 - d_t(j,inres)=d_t_new(j,inres)+d_a(j,inres)*d_time_s - enddo - endif - enddo - - s_np=s12_np - - return - end - - subroutine hmc_test(itime) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.MD' - include 'COMMON.CHAIN' - - hmc_acc=hmc_acc+1 - delta=-(potE+EK-hmc_etot)/(Rb*t_bath) - if (delta .lt. -50.0d0) then - delta=0.0d0 - else - delta=dexp(delta) - endif - xxx=ran_number(0.0d0,1.0d0) - - if (me.eq.king .or. .not. out1file) - & write(iout,'(a8,i5,6f10.4)') - & 'HMC',itime,potE+EK,potE,EK,hmc_etot,delta,xxx - - if (delta .le. xxx) then - do i=1,2*nres - do j=1,3 - dc(j,i)=dc_hmc(j,i) - enddo - enddo - itime=itime-hmc - totT=totThmc - else - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'HMC accepting new' - totThmc=totT - do i=1,2*nres - do j=1,3 - dc_hmc(j,i)=dc(j,i) - enddo - enddo - endif - - call chainbuild_cart - call random_vel - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen3*Rb)*EK - call etotal(potEcomp) - potE=potEcomp(0) - hmc_etot=potE+EK - if (me.eq.king .or. .not. out1file) - & write(iout,'(a8,i5,3f10.4)')'HMC new',itime,potE+EK,potE,EK - - - return - end diff --git a/source/unres/src_MD_DFA/MP.F b/source/unres/src_MD_DFA/MP.F deleted file mode 100644 index b08897c..0000000 --- a/source/unres/src_MD_DFA/MP.F +++ /dev/null @@ -1,516 +0,0 @@ -#ifdef MPI - subroutine init_task - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - logical lprn /.false./ -c real*8 text1 /'group_i '/,text2/'group_f '/, -c & text3/'initialb'/,text4/'initiale'/, -c & text5/'openb'/,text6/'opene'/ - integer cgtasks(0:max_cg_procs) - character*3 cfgprocs - integer cg_size,fg_size,fg_size1 -c start parallel processing -c print *,'Initializing MPI' - call mpi_init(ierr) - if (ierr.ne.0) then - print *, ' cannot initialize MPI' - stop - endif -c determine # of nodes and current node - call MPI_Comm_rank( MPI_COMM_WORLD, me, ierr ) - if (ierr.ne.0) then - print *, ' cannot determine rank of all processes' - call MPI_Finalize( MPI_COMM_WORLD, IERR ) - stop - endif - call MPI_Comm_size( MPI_Comm_world, nodes, ierr ) - if (ierr.ne.0) then - print *, ' cannot determine number of processes' - stop - endif - Nprocs=nodes - MyRank=me -C Determine the number of "fine-grain" tasks - call getenv_loc("FGPROCS",cfgprocs) - read (cfgprocs,'(i3)') nfgtasks - if (nfgtasks.eq.0) nfgtasks=1 - call getenv_loc("MAXGSPROCS",cfgprocs) - read (cfgprocs,'(i3)') max_gs_size - if (max_gs_size.eq.0) max_gs_size=2 - if (lprn) - & print *,"Processor",me," nfgtasks",nfgtasks, - & " max_gs_size",max_gs_size - if (nfgtasks.eq.1) then - CG_COMM = MPI_COMM_WORLD - fg_size=1 - fg_rank=0 - nfgtasks1=1 - fg_rank1=0 - else - nodes=nprocs/nfgtasks - if (nfgtasks*nodes.ne.nprocs) then - write (*,'(a)') 'ERROR: Number of processors assigned', - & ' to coarse-grained tasks must be divisor', - & ' of the total number of processors.' - call MPI_Finalize( MPI_COMM_WORLD, IERR ) - stop - endif -C Put the ranks of coarse-grain processes in one table and create -C the respective communicator. The processes with ranks "in between" -C the ranks of CG processes will perform fine graining for the CG -C process with the next lower rank. - do i=0,nprocs-1,nfgtasks - cgtasks(i/nfgtasks)=i - enddo - if (lprn) then - print*,"Processor",me," cgtasks",(cgtasks(i),i=0,nodes-1) -c print "(a,i5,a)","Processor",myrank," Before MPI_Comm_group" - endif -c call memmon_print_usage() - call MPI_Comm_group(MPI_COMM_WORLD,world_group,IERR) - call MPI_Group_incl(world_group,nodes,cgtasks,cg_group,IERR) - call MPI_Comm_create(MPI_COMM_WORLD,cg_group,CG_COMM,IERR) - call MPI_Group_rank(cg_group,me,ierr) - call MPI_Group_free(world_group,ierr) - call MPI_Group_free(cg_group,ierr) -c print "(a,i5,a)","Processor",myrank," After MPI_Comm_group" -c call memmon_print_usage() - if (me.ne.MPI_UNDEFINED) call MPI_Comm_Rank(CG_COMM,me,ierr) - if (lprn) print *," Processor",myrank," CG rank",me -C Create communicators containig processes doing "fine grain" tasks. -C The processes within each FG_COMM should have fast communication. - kolor=MyRank/nfgtasks - key=mod(MyRank,nfgtasks) - call MPI_Comm_split(MPI_COMM_WORLD,kolor,key,FG_COMM,ierr) - call MPI_Comm_size(FG_COMM,fg_size,ierr) - if (fg_size.ne.nfgtasks) then - write (*,*) "OOOOps... the number of fg tasks is",fg_size, - & " but",nfgtasks," was requested. MyRank=",MyRank - endif - call MPI_Comm_rank(FG_COMM,fg_rank,ierr) - if (fg_size.gt.max_gs_size) then - kolor1=fg_rank/max_gs_size - key1=mod(fg_rank,max_gs_size) - call MPI_Comm_split(FG_COMM,kolor1,key1,FG_COMM1,ierr) - call MPI_Comm_size(FG_COMM1,nfgtasks1,ierr) - call MPI_Comm_rank(FG_COMM1,fg_rank1,ierr) - else - FG_COMM1=FG_COMM - nfgtasks1=nfgtasks - fg_rank1=fg_rank - endif - endif - if (fg_rank.eq.0) then - write (*,*) "Processor",MyRank," out of",nprocs, - & " rank in CG_COMM",me," size of CG_COMM",nodes, - & " size of FG_COMM",fg_size, - & " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1 - else - write (*,*) "Processor",MyRank," out of",nprocs, - & " rank in FG_COMM",fg_rank," size of FG_COMM",fg_size, - & " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1 - endif -C Initialize other variables. -c print '(a)','Before initialize' -c call memmon_print_usage() - call initialize -c print '(a,i5,a)','Processor',myrank,' After initialize' -c call memmon_print_usage() -C Open task-dependent files. -c print '(a,i5,a)','Processor',myrank,' Before openunits' -c call memmon_print_usage() - call openunits -c print '(a,i5,a)','Processor',myrank,' After openunits' -c call memmon_print_usage() - if (me.eq.king .or. fg_rank.eq.0 .and. .not. out1file) - & write (iout,'(80(1h*)/a/80(1h*))') - & 'United-residue force field calculation - parallel job.' -c print *,"Processor",myrank," exited OPENUNITS" - return - end -C----------------------------------------------------------------------------- - subroutine finish_task - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.REMD' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TIME1' - include 'COMMON.MD' - integer ilen - external ilen -c - call MPI_Barrier(CG_COMM,ierr) - if (nfgtasks.gt.1) - & call MPI_Bcast(-1,1,MPI_INTEGER,king,FG_COMM,IERROR) - time1=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write (iout,'(a,i4,a)') 'CG processor',me,' is finishing work.' - write (iout,*) 'Total wall clock time',time1-walltime,' sec' - if (nfgtasks.gt.1) then - write (iout,'(80(1h=)/a/(80(1h=)))') - & "Details of FG communication time" - write (iout,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))') - & "BROADCAST:",time_bcast,"REDUCE:",time_reduce, - & "GATHER:",time_gather, - & "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv, - & "BARRIER ene",time_barrier_e, - & "BARRIER grad",time_barrier_g,"TOTAL:", - & time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv - & +time_barrier_e+time_barrier_g - write (*,*) 'Total wall clock time',time1-walltime,' sec' - write (*,*) "Processor",me," BROADCAST time",time_bcast, - & " REDUCE time", - & time_reduce," GATHER time",time_gather," SCATTER time", - & time_scatter," SENDRECV",time_sendrecv, - & " BARRIER ene",time_barrier_e," BARRIER grad",time_barrier_g - endif - endif - write (*,'(a,i4,a)') 'CG processor',me,' is finishing work.' - if (ilen(tmpdir).gt.0) then - write (*,*) "Processor",me, - & ": moving output files to the parent directory..." - close(inp) - close(istat,status='keep') - if (ntwe.gt.0) call move_from_tmp(statname) - close(irest2,status='keep') - if (modecalc.eq.12.or. - & (modecalc.eq.14 .and. .not.restart1file)) then - call move_from_tmp(rest2name) - else if (modecalc.eq.14.and. me.eq.king) then - call move_from_tmp(mremd_rst_name) - endif - if (mdpdb) then - close(ipdb,status='keep') - call move_from_tmp(pdbname) - else if (me.eq.king .or. .not.traj1file) then - close(icart,status='keep') - call move_from_tmp(cartname) - endif - if (me.eq.king .or. .not. out1file) then - close (iout,status='keep') - call move_from_tmp(outname) - endif - endif - return - end -c------------------------------------------------------------------------- - subroutine pattern_receive - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.THREAD' - include 'COMMON.IOUNITS' - integer tag,status(MPI_STATUS_SIZE) - integer source,ThreadType - logical flag - ThreadType=45 - source=mpi_any_source - call mpi_iprobe(source,ThreadType, - & CG_COMM,flag,status,ierr) - do while (flag) - write (iout,*) 'Processor ',Me,' is receiving threading', - & ' pattern from processor',status(mpi_source) - write (*,*) 'Processor ',Me,' is receiving threading', - & ' pattern from processor',status(mpi_source) - nexcl=nexcl+1 - call mpi_irecv(iexam(1,nexcl),2,mpi_integer,status(mpi_source), - & ThreadType, CG_COMM,ireq,ierr) - write (iout,*) 'Received pattern:',nexcl,iexam(1,nexcl), - & iexam(2,nexcl) - source=mpi_any_source - call mpi_iprobe(source,ThreadType, - & CG_COMM,flag,status,ierr) - enddo - return - end -c---------------------------------------------------------------------------- - subroutine pattern_send - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.INFO' - include 'COMMON.THREAD' - include 'COMMON.IOUNITS' - integer source,ThreadType,ireq - ThreadType=45 - do iproc=0,nprocs-1 - if (iproc.ne.me .and. .not.Koniec(iproc) ) then - call mpi_isend(iexam(1,nexcl),2,mpi_integer,iproc, - & ThreadType, CG_COMM, ireq, ierr) - write (iout,*) 'CG processor ',me,' has sent pattern ', - & 'to processor',iproc - write (*,*) 'CG processor ',me,' has sent pattern ', - & 'to processor',iproc - write (iout,*) 'Pattern:',nexcl,iexam(1,nexcl),iexam(2,nexcl) - endif - enddo - return - end -c----------------------------------------------------------------------------- - subroutine send_stop_sig(Kwita) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.INFO' - include 'COMMON.IOUNITS' - integer StopType,StopId,iproc,Kwita,NBytes - StopType=66 -c Kwita=-1 -C print *,'CG processor',me,' StopType=',StopType - Koniec(me)=.true. - if (me.eq.king) then -C Master sends the STOP signal to everybody. - write (iout,'(a,a)') - & 'Master is sending STOP signal to other processors.' - do iproc=1,nprocs-1 - print *,'Koniec(',iproc,')=',Koniec(iproc) - if (.not. Koniec(iproc)) then - call mpi_send(Kwita,1,mpi_integer,iproc,StopType, - & mpi_comm_world,ierr) - write (iout,*) 'Iproc=',iproc,' StopID=',StopID - write (*,*) 'Iproc=',iproc,' StopID=',StopID - endif - enddo - else -C Else send the STOP signal to Master. - call mpi_send(Kwita,1,mpi_integer,MasterID,StopType, - & mpi_comm_world,ierr) - write (iout,*) 'CG processor=',me,' StopID=',StopID - write (*,*) 'CG processor=',me,' StopID=',StopID - endif - return - end -c----------------------------------------------------------------------------- - subroutine recv_stop_sig(Kwita) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.INFO' - include 'COMMON.IOUNITS' - integer source,StopType,StopId,iproc,Kwita - logical flag - StopType=66 - Kwita=0 - source=mpi_any_source -c print *,'CG processor:',me,' StopType=',StopType - call mpi_iprobe(source,StopType, - & mpi_comm_world,flag,status,ierr) - do while (flag) - Koniec(status(mpi_source))=.true. - write (iout,*) 'CG processor ',me,' is receiving STOP signal', - & ' from processor',status(mpi_source) - write (*,*) 'CG processor ',me,' is receiving STOP signal', - & ' from processor',status(mpi_source) - call mpi_irecv(Kwita,1,mpi_integer,status(mpi_source),StopType, - & mpi_comm_world,ireq,ierr) - call mpi_iprobe(source,StopType, - & mpi_comm_world,flag,status,ierr) - enddo - return - end -c----------------------------------------------------------------------------- - subroutine send_MCM_info(ione) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - integer tag,status(MPI_STATUS_SIZE) - integer MCM_info_Type,MCM_info_ID,iproc,one,NBytes - common /aaaa/ isend,irecv - integer nsend - save nsend - nsend=nsend+1 - MCM_info_Type=77 -cd write (iout,'(a,i4,a)') 'CG Processor',me, -cd & ' is sending MCM info to Master.' - write (*,'(a,i4,a,i8)') 'CG processor',me, - & ' is sending MCM info to Master, MCM_info_ID=',MCM_info_ID - call mpi_isend(ione,1,mpi_integer,MasterID, - & MCM_info_Type,mpi_comm_world, MCM_info_ID, ierr) -cd write (iout,*) 'CG processor',me,' has sent info to the master;', -cd & ' MCM_info_ID=',MCM_info_ID - write (*,*) 'CG processor',me,' has sent info to the master;', - & ' MCM_info_ID=',MCM_info_ID,' ierr ',ierr - isend=0 - irecv=0 - return - end -c---------------------------------------------------------------------------- - subroutine receive_MCM_info - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - integer tag,status(MPI_STATUS_SIZE) - integer source,MCM_info_Type,MCM_info_ID,iproc,ione - logical flag - MCM_info_Type=77 - source=mpi_any_source -c print *,'source=',source,' dontcare=',dontcare - call mpi_iprobe(source,MCM_info_Type, - & mpi_comm_world,flag,status,ierr) - do while (flag) - source=status(mpi_source) - itask=source/fgProcs+1 -cd write (iout,*) 'Master is receiving MCM info from processor ', -cd & source,' itask',itask - write (*,*) 'Master is receiving MCM info from processor ', - & source,' itask',itask - call mpi_irecv(ione,1,mpi_integer,source,MCM_info_type, - & mpi_comm_world,MCM_info_ID,ierr) -cd write (iout,*) 'Received from processor',source,' IONE=',ione - write (*,*) 'Received from processor',source,' IONE=',ione - nacc_tot=nacc_tot+1 - if (ione.eq.2) nsave_part(itask)=nsave_part(itask)+1 -cd print *,'nsave_part(',itask,')=',nsave_part(itask) -cd write (iout,*) 'Nacc_tot=',Nacc_tot -cd write (*,*) 'Nacc_tot=',Nacc_tot - source=mpi_any_source - call mpi_iprobe(source,MCM_info_Type, - & mpi_comm_world,flag,status,ierr) - enddo - return - end -c--------------------------------------------------------------------------- - subroutine send_thread_results - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.THREAD' - include 'COMMON.IOUNITS' - integer tag,status(MPI_STATUS_SIZE) - integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType, - & EnerID,msglen,nbytes - double precision buffer(20*maxthread+2) - ThreadType=444 - EnerType=555 - ipatt(1,nthread+1)=nthread - ipatt(2,nthread+1)=nexcl - do i=1,nthread - do j=1,n_ene - ener(j,i+nthread)=ener0(j,i) - enddo - enddo - ener(1,2*nthread+1)=max_time_for_thread - ener(2,2*nthread+1)=ave_time_for_thread -C Send the IPATT array - write (iout,*) 'CG processor',me, - & ' is sending IPATT array to master: NTHREAD=',nthread - write (*,*) 'CG processor',me, - & ' is sending IPATT array to master: NTHREAD=',nthread - msglen=2*nthread+2 - call mpi_send(ipatt(1,1),msglen,MPI_INTEGER,MasterID, - & ThreadType,mpi_comm_world,ierror) - write (iout,*) 'CG processor',me, - & ' has sent IPATT array to master MSGLEN',msglen - write (*,*) 'CG processor',me, - & ' has sent IPATT array to master MSGLEN',msglen -C Send the energies. - msglen=n_ene2*nthread+2 - write (iout,*) 'CG processor',me,' is sending energies to master.' - write (*,*) 'CG processor',me,' is sending energies to master.' - call mpi_send(ener(1,1),msglen,MPI_DOUBLE_PRECISION,MasterID, - & EnerType,mpi_comm_world,ierror) - write (iout,*) 'CG processor',me,' has sent energies to master.' - write (*,*) 'CG processor',me,' has sent energies to master.' - return - end -c---------------------------------------------------------------------------- - subroutine receive_thread_results(iproc) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.INFO' - include 'COMMON.THREAD' - include 'COMMON.IOUNITS' - integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType, - & EnerID,ReadyType,ReadyID,Ready,msglen,nbytes,nthread_temp - double precision buffer(20*maxthread+2),max_time_for_thread_t, - & ave_time_for_thread_t - logical flag - ThreadType=444 - EnerType=555 -C Receive the IPATT array - call mpi_probe(iproc,ThreadType, - & mpi_comm_world,status,ierr) - call MPI_GET_COUNT(STATUS, MPI_INTEGER, MSGLEN, IERROR) - write (iout,*) 'Master is receiving IPATT array from processor:', - & iproc,' MSGLEN',msglen - write (*,*) 'Master is receiving IPATT array from processor:', - & iproc,' MSGLEN',msglen - call mpi_recv(ipatt(1,nthread+1),msglen,mpi_integer,iproc, - & ThreadType, - & mpi_comm_world,status,ierror) - write (iout,*) 'Master has received IPATT array from processor:', - & iproc,' MSGLEN=',msglen - write (*,*) 'Master has received IPATT array from processor:', - & iproc,' MSGLEN=',msglen - nthread_temp=ipatt(1,nthread+msglen/2) - nexcl_temp=ipatt(2,nthread+msglen/2) -C Receive the energies. - call mpi_probe(iproc,EnerType, - & mpi_comm_world,status,ierr) - call MPI_GET_COUNT(STATUS, MPI_DOUBLE_PRECISION, MSGLEN, IERROR) - write (iout,*) 'Master is receiving energies from processor:', - & iproc,' MSGLEN=',MSGLEN - write (*,*) 'Master is receiving energies from processor:', - & iproc,' MSGLEN=',MSGLEN - call mpi_recv(ener(1,nthread+1),msglen, - & MPI_DOUBLE_PRECISION,iproc, - & EnerType,MPI_COMM_WORLD,status,ierror) - write (iout,*) 'Msglen=',Msglen - write (*,*) 'Msglen=',Msglen - write (iout,*) 'Master has received energies from processor',iproc - write (*,*) 'Master has received energies from processor',iproc - write (iout,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp - write (*,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp - do i=1,nthread_temp - do j=1,n_ene - ener0(j,nthread+i)=ener(j,nthread+nthread_temp+i) - enddo - enddo - max_time_for_thread_t=ener(1,nthread+2*nthread_temp+1) - ave_time_for_thread_t=ener(2,nthread+2*nthread_temp+1) - write (iout,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t - write (iout,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t - write (*,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t - write (*,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t - if (max_time_for_thread_t.gt.max_time_for_thread) - & max_time_for_thread=max_time_for_thread_t - ave_time_for_thread=(nthread*ave_time_for_thread+ - & nthread_temp*ave_time_for_thread_t)/(nthread+nthread_temp) - nthread=nthread+nthread_temp - return - end -#else - subroutine init_task - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SETUP' - me=0 - myrank=0 - fg_rank=0 - fg_size=1 - nodes=1 - nprocs=1 - call initialize - call openunits - write (iout,'(80(1h*)/a/80(1h*))') - & 'United-residue force field calculation - serial job.' - return - end -#endif diff --git a/source/unres/src_MD_DFA/MREMD.F b/source/unres/src_MD_DFA/MREMD.F deleted file mode 100644 index 576e43d..0000000 --- a/source/unres/src_MD_DFA/MREMD.F +++ /dev/null @@ -1,2102 +0,0 @@ -#ifdef MPI - subroutine MREMD - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.MUCA' - integer ERRCODE - double precision cm(3),L(3),vcm(3) - double precision energia(0:n_ene) - double precision remd_t_bath(maxprocs) - integer iremd_iset(maxprocs) - integer*2 i_index - & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) - double precision remd_ene(0:n_ene+4,maxprocs),t_bath_old - integer iremd_acc(maxprocs),iremd_tot(maxprocs) - integer iremd_acc_usa(maxprocs),iremd_tot_usa(maxprocs) - integer ilen,rstcount - external ilen - character*50 tytul - common /gucio/ cm - integer itime -cold integer nup(0:maxprocs),ndown(0:maxprocs) - integer rep2i(0:maxprocs),ireqi(maxprocs) - integer icache_all(maxprocs) - integer status(MPI_STATUS_SIZE),statusi(MPI_STATUS_SIZE,maxprocs) - logical synflag,end_of_run,file_exist /.false./,ovrtim - real ene_tol /1.0e-5/ - -cdeb imin_itime_old=0 - ntwx_cache=0 - time00=MPI_WTIME() - time01=time00 - if(me.eq.king.or..not.out1file) then - write (iout,*) 'MREMD',nodes,'time before',time00-walltime - write (iout,*) "NREP=",nrep - endif - - synflag=.false. - if (ilen(tmpdir).gt.0 .and. (me.eq.king)) then - call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_mremd.rst") - endif - mremd_rst_name=prefix(:ilen(prefix))//"_mremd.rst" - -cd print *,'MREMD',nodes -cd print *,'mmm',me,remd_mlist,(remd_m(i),i=1,nrep) -cde write (iout,*) "Start MREMD: me",me," t_bath",t_bath - - if(hremd.gt.0) then - nset=hremd - do i=1,nset - mset(i)=1 - enddo - endif - - k=0 - rep2i(k)=-1 - do il=1,max0(nset,1) - do il1=1,max0(mset(il),1) - do i=1,nrep - iremd_acc(i)=0 - iremd_acc_usa(i)=0 - iremd_tot(i)=0 - do j=1,remd_m(i) - i2rep(k)=i - i2set(k)=il - rep2i(i)=k - k=k+1 - i_index(i,j,il,il1)=k - enddo - enddo - enddo - enddo - - if(me.eq.king.or..not.out1file) then - write(iout,*) "i2rep",(i2rep(i),i=0,nodes-1) - write(iout,*) "i2set",(i2set(i),i=0,nodes-1) - write(iout,*) "i,j,il,il1,i_index(i,j,il,il1)" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - write(iout,*) i,j,il,il1,i_index(i,j,il,il1) - enddo - enddo - enddo - enddo - endif - -c print *,'i2rep',me,i2rep(me) -c print *,'rep2i',(rep2i(i),i=0,nrep) - -cold if (i2rep(me).eq.nrep) then -cold nup(0)=0 -cold else -cold nup(0)=remd_m(i2rep(me)+1) -cold k=rep2i(int(i2rep(me)))+1 -cold do i=1,nup(0) -cold nup(i)=k -cold k=k+1 -cold enddo -cold endif - -cd print '(i4,a4,100i4)',me,' nup',(nup(i),i=0,nup(0)) - -cold if (i2rep(me).eq.1) then -cold ndown(0)=0 -cold else -cold ndown(0)=remd_m(i2rep(me)-1) -cold k=rep2i(i2rep(me)-2)+1 -cold do i=1,ndown(0) -cold ndown(i)=k -cold k=k+1 -cold enddo -cold endif - -cd print '(i4,a6,100i4)',me,' ndown',(ndown(i),i=0,ndown(0)) - - - write (*,*) "Processor",me," rest",rest," - & restart1fie",restart1file - if(rest.and.restart1file) then - if (me.eq.king) - & inquire(file=mremd_rst_name,exist=file_exist) -cd write (*,*) me," Before broadcast: file_exist",file_exist - call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM, - & IERR) -cd write (*,*) me," After broadcast: file_exist",file_exist - if(file_exist) then - if(me.eq.king.or..not.out1file) - & write (iout,*) 'Master is reading restart1file' - call read1restart(i_index) - else - if(me.eq.king.or..not.out1file) - & write (iout,*) 'WARNING : no restart1file' - endif - - if(me.eq.king.or..not.out1file) then - write(iout,*) "i2set",(i2set(i),i=0,nodes-1) - write(iout,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - write(iout,*) i,j,il,il1,i_index(i,j,il,il1) - enddo - enddo - enddo - enddo - endif - endif - - if(me.eq.king) then - if (rest.and..not.restart1file) - & inquire(file=mremd_rst_name,exist=file_exist) - if(.not.file_exist.and.rest.and..not.restart1file) - & write(iout,*) 'WARNING : no restart file',mremd_rst_name - IF (rest.and.file_exist.and..not.restart1file) THEN - write (iout,*) 'Master is reading restart file', - & mremd_rst_name - open(irest2,file=mremd_rst_name,status='unknown') - read (irest2,*) - read (irest2,*) (i2rep(i),i=0,nodes-1) - read (irest2,*) - read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - read (irest2,*) - read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - read (irest2,*) - read (irest2,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - if(usampl.or.hremd.gt.0) then - read (irest2,*) - read (irest2,*) nset - read (irest2,*) - read (irest2,*) (mset(i),i=1,nset) - read (irest2,*) - read (irest2,*) (i2set(i),i=0,nodes-1) - read (irest2,*) - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - read(irest2,*) (i_index(i,j,il,il1),j=1,remd_m(i)) - enddo - enddo - enddo - - write(iout,*) "i2set",(i2set(i),i=0,nodes-1) - write(iout,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - write(iout,*) i,j,il,il1,i_index(i,j,il,il1) - enddo - enddo - enddo - enddo - endif - - close(irest2) - - write (iout,'(a6,1000i5)') "i2rep",(i2rep(i),i=0,nodes-1) - write (iout,'(a6,1000i5)') "ifirst", - & (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (iout,'(a6,i4,a1,100i4)') "nupa",il,":", - & (nupa(i,il),i=1,nupa(0,il)) - write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":", - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - ELSE IF (.not.(rest.and.file_exist)) THEN - do il=1,remd_m(1) - ifirst(il)=il - enddo - - do il=1,nodes - if (i2rep(il-1).eq.nrep) then - nupa(0,il)=0 - else - nupa(0,il)=remd_m(i2rep(il-1)+1) - k=rep2i(int(i2rep(il-1)))+1 - do i=1,nupa(0,il) - nupa(i,il)=k+1 - k=k+1 - enddo - endif - if (i2rep(il-1).eq.1) then - ndowna(0,il)=0 - else - ndowna(0,il)=remd_m(i2rep(il-1)-1) - k=rep2i(i2rep(il-1)-2)+1 - do i=1,ndowna(0,il) - ndowna(i,il)=k+1 - k=k+1 - enddo - endif - enddo - - write (iout,'(a6,100i4)') "ifirst", - & (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (iout,'(a6,i4,a1,100i4)') "nupa",il,":", - & (nupa(i,il),i=1,nupa(0,il)) - write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":", - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - - ENDIF - endif -c -c t_bath=retmin+(retmax-retmin)*me/(nodes-1) - if(.not.(rest.and.file_exist.and.restart1file)) then - if (me .eq. king) then - t_bath=retmin - else - t_bath=retmin+(retmax-retmin)*exp(float(i2rep(me)-nrep)) - endif -cd print *,'ttt',me,remd_tlist,(remd_t(i),i=1,nrep) - if (remd_tlist) t_bath=remd_t(int(i2rep(me))) - - endif - if(usampl.or.hremd.gt.0) then - iset=i2set(me) - if (hremd.gt.0) call set_hweights(iset) - if(me.eq.king.or..not.out1file) - & write(iout,*) me,"iset=",iset,"t_bath=",t_bath - endif -c - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - -c print *,'irep',me,t_bath - if (.not.rest) then - if (me.eq.king .or. .not. out1file) - & write (iout,'(a60,f10.5)') "REMD Temperature:",t_bath - call rescale_weights(t_bath) - endif - - -c------copy MD-------------- -c The driver for molecular dynamics subroutines -c------------------------------------------------ - t_MDsetup=0.0d0 - t_langsetup=0.0d0 - t_MD=0.0d0 - t_enegrad=0.0d0 - t_sdsetup=0.0d0 - if(me.eq.king.or..not.out1file) - & write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif -c Determine the inverse of the inertia matrix. - call setup_MD_matrices -c Initialize MD - call init_MD - if (rest) then - if (me.eq.king .or. .not. out1file) - & write (iout,'(a60,f10.5)') "REMD restart Temperature:",t_bath - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - if (lang.gt.0 .and. .not.surfarea) then - do i=nnt,nct-1 - stdforcp(i)=stdfp*dsqrt(gamp) - enddo - do i=nnt,nct - stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamsc(itype(i))) - enddo - elseif (lang.gt.0 .and. surfarea ) then - call setup_fricmat - endif - call rescale_weights(t_bath) - endif - -#ifdef MPI - t_MDsetup = MPI_Wtime()-tt0 -#else - t_MDsetup = tcpu()-tt0 -#endif - rstcount=0 -c Entering the MD loop -#ifdef MPI - tt0 = MPI_Wtime() -#else - tt0 = tcpu() -#endif - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#else - write (iout,*) - & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - time00=MPI_WTIME() - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'Setup time',time00-walltime -ctime call flush(iout) -#ifdef MPI - t_langsetup=MPI_Wtime()-tt0 - tt0=MPI_Wtime() -#else - t_langsetup=tcpu()-tt0 - tt0=tcpu() -#endif - itime=0 - end_of_run=.false. - do while(.not.end_of_run) - itime=itime+1 - if(itime.eq.n_timestep.and.me.eq.king) end_of_run=.true. - if(mremdsync.and.itime.eq.n_timestep) end_of_run=.true. - rstcount=rstcount+1 - if (lang.gt.0 .and. surfarea .and. - & mod(itime,reset_fricmat).eq.0) then - if (lang.eq.2 .or. lang.eq.3) then -#ifndef LANG0 - call setup_fricmat - if (lang.eq.2) then - call sd_verlet_p_setup - else - call sd_verlet_ciccotti_setup - endif - do i=1,dimen - do j=1,dimen - pfric0_mat(i,j,0)=pfric_mat(i,j) - afric0_mat(i,j,0)=afric_mat(i,j) - vfric0_mat(i,j,0)=vfric_mat(i,j) - prand0_mat(i,j,0)=prand_mat(i,j) - vrand0_mat1(i,j,0)=vrand_mat1(i,j) - vrand0_mat2(i,j,0)=vrand_mat2(i,j) - enddo - enddo - flag_stoch(0)=.true. - do i=1,maxflag_stoch - flag_stoch(i)=.false. - enddo -#endif - else if (lang.eq.1 .or. lang.eq.4) then - call setup_fricmat - endif - write (iout,'(a,i10)') - & "Friction matrix reset based on surface area, itime",itime - endif - if (reset_vel .and. tbf .and. lang.eq.0 - & .and. mod(itime,count_reset_vel).eq.0) then - call random_vel - if (me.eq.king .or. .not. out1file) - & write(iout,'(a,f20.2)') - & "Velocities reset to random values, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=d_t(j,i) - enddo - enddo - endif - if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then - call inertia_tensor - call vcm_vel(vcm) - do j=1,3 - d_t(j,0)=d_t(j,0)-vcm(j) - enddo - call kinetic(EK) - kinetic_T=2.0d0/(dimen3*Rb)*EK - scalfac=dsqrt(T_bath/kinetic_T) -cd write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT - do i=0,2*nres - do j=1,3 - d_t_old(j,i)=scalfac*d_t(j,i) - enddo - enddo - endif - if (lang.ne.4) then - if (RESPA) then -c Time-reversible RESPA algorithm -c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) - call RESPA_step(itime) - else -c Variable time step algorithm. - call velverlet_step(itime) - endif - else -#ifdef BROWN - call brown_step(itime) -#else - print *,"Brown dynamics not here!" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop -#endif - endif - if(hmc.gt.0 .and. mod(itime,hmc).eq.0) then - call statout(itime) - call hmc_test(itime) - endif - if(ntwe.ne.0) then - if (mod(itime,ntwe).eq.0) call statout(itime) - endif - if (mod(itime,ntwx).eq.0.and..not.traj1file) then - write (tytul,'("time",f8.2," temp",f8.1)') totT,t_bath - if(mdpdb) then - call pdbout(potE,tytul,ipdb) - else - call cartout(totT) - endif - endif - if (mod(itime,ntwx).eq.0.and.traj1file) then - if(ntwx_cache.lt.max_cache_traj_use) then - ntwx_cache=ntwx_cache+1 - else - if (max_cache_traj_use.ne.1) - & print *,itime,"processor ",me," over cache ",ntwx_cache - do i=1,ntwx_cache-1 - - totT_cache(i)=totT_cache(i+1) - EK_cache(i)=EK_cache(i+1) - potE_cache(i)=potE_cache(i+1) - t_bath_cache(i)=t_bath_cache(i+1) - Uconst_cache(i)=Uconst_cache(i+1) - iset_cache(i)=iset_cache(i+1) - - do ii=1,nfrag - qfrag_cache(ii,i)=qfrag_cache(ii,i+1) - enddo - do ii=1,npair - qpair_cache(ii,i)=qpair_cache(ii,i+1) - enddo - do ii=1,nfrag_back - utheta_cache(ii,i)=utheta_cache(ii,i+1) - ugamma_cache(ii,i)=ugamma_cache(ii,i+1) - uscdiff_cache(ii,i)=uscdiff_cache(ii,i+1) - enddo - - - do ii=1,nres*2 - do j=1,3 - c_cache(j,ii,i)=c_cache(j,ii,i+1) - enddo - enddo - enddo - endif - - totT_cache(ntwx_cache)=totT - EK_cache(ntwx_cache)=EK - potE_cache(ntwx_cache)=potE - t_bath_cache(ntwx_cache)=t_bath - Uconst_cache(ntwx_cache)=Uconst - iset_cache(ntwx_cache)=iset - - do i=1,nfrag - qfrag_cache(i,ntwx_cache)=qfrag(i) - enddo - do i=1,npair - qpair_cache(i,ntwx_cache)=qpair(i) - enddo - do i=1,nfrag_back - utheta_cache(i,ntwx_cache)=utheta(i) - ugamma_cache(i,ntwx_cache)=ugamma(i) - uscdiff_cache(i,ntwx_cache)=uscdiff(i) - enddo - - do i=1,nres*2 - do j=1,3 - c_cache(j,i,ntwx_cache)=c(j,i) - enddo - enddo - - endif - if ((rstcount.eq.1000.or.itime.eq.n_timestep) - & .and..not.restart1file) then - - if(me.eq.king) then - open(irest1,file=mremd_rst_name,status='unknown') - write (irest1,*) "i2rep" - write (irest1,*) (i2rep(i),i=0,nodes-1) - write (irest1,*) "ifirst" - write (irest1,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - write (irest1,*) "nupa",il - write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - write (irest1,*) "ndowna",il - write (irest1,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - if(usampl.or.hremd.gt.0) then - write (irest1,*) "nset" - write (irest1,*) nset - write (irest1,*) "mset" - write (irest1,*) (mset(i),i=1,nset) - write (irest1,*) "i2set" - write (irest1,*) (i2set(i),i=0,nodes-1) - write (irest1,*) "i_index" - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - write(irest1,*) (i_index(i,j,il,il1),j=1,remd_m(i)) - enddo - enddo - enddo - - endif - close(irest1) - endif - open(irest2,file=rest2name,status='unknown') - write(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - write (irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - if(usampl.or.hremd.gt.0) then - write (irest2,*) iset - endif - close(irest2) - rstcount=0 - endif - -c REMD - exchange -c forced synchronization - if (mod(itime,i_sync_step).eq.0 .and. me.ne.king - & .and. .not. mremdsync) then - synflag=.false. - call mpi_iprobe(0,101,CG_COMM,synflag,status,ierr) - if (synflag) then - call mpi_recv(itime_master, 1, MPI_INTEGER, - & 0,101,CG_COMM, status, ierr) - call mpi_barrier(CG_COMM, ierr) -cdeb if (out1file.or.traj1file) then -cdeb call mpi_gather(itime,1,mpi_integer, -cdeb & icache_all,1,mpi_integer,king, -cdeb & CG_COMM,ierr) - if(traj1file) - & call mpi_gather(ntwx_cache,1,mpi_integer, - & icache_all,1,mpi_integer,king, - & CG_COMM,ierr) - if (.not.out1file) - & write(iout,*) 'REMD synchro at',itime_master,itime - if (itime_master.ge.n_timestep .or. ovrtim()) - & end_of_run=.true. -ctime call flush(iout) - endif - endif - -c REMD - exchange - if ((mod(itime,nstex).eq.0.and.me.eq.king - & .or.end_of_run.and.me.eq.king ) - & .and. .not. mremdsync ) then - synflag=.true. - time01_=MPI_WTIME() - do i=1,nodes-1 - call mpi_isend(itime,1,MPI_INTEGER,i,101, - & CG_COMM, ireqi(i), ierr) -cd write(iout,*) 'REMD synchro with',i -cd call flush(iout) - enddo - call mpi_waitall(nodes-1,ireqi,statusi,ierr) - call mpi_barrier(CG_COMM, ierr) - time01=MPI_WTIME() - write(iout,*) 'REMD synchro at',itime,'time=',time01-time01_ - if (out1file.or.traj1file) then -cdeb call mpi_gather(itime,1,mpi_integer, -cdeb & itime_all,1,mpi_integer,king, -cdeb & CG_COMM,ierr) -cdeb write(iout,'(a19,8000i8)') ' REMD synchro itime', -cdeb & (itime_all(i),i=1,nodes) - if(traj1file) then -cdeb imin_itime=itime_all(1) -cdeb do i=2,nodes -cdeb if(itime_all(i).lt.imin_itime) imin_itime=itime_all(i) -cdeb enddo -cdeb ii_write=(imin_itime-imin_itime_old)/ntwx -cdeb imin_itime_old=int(imin_itime/ntwx)*ntwx -cdeb write(iout,*) imin_itime,imin_itime_old,ii_write - call mpi_gather(ntwx_cache,1,mpi_integer, - & icache_all,1,mpi_integer,king, - & CG_COMM,ierr) -c write(iout,'(a19,8000i8)') ' ntwx_cache', -c & (icache_all(i),i=1,nodes) - ii_write=icache_all(1) - do i=2,nodes - if(icache_all(i).lt.ii_write) ii_write=icache_all(i) - enddo -c write(iout,*) "MIN ii_write=",ii_write - endif - endif -ctime call flush(iout) - endif - if(mremdsync .and. mod(itime,nstex).eq.0) then - synflag=.true. - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'REMD synchro at',itime - - if(traj1file) then - call mpi_gather(ntwx_cache,1,mpi_integer, - & icache_all,1,mpi_integer,king, - & CG_COMM,ierr) - if (me.eq.king) then - write(iout,'(a19,8000i8)') ' ntwx_cache', - & (icache_all(i),i=1,nodes) - ii_write=icache_all(1) - do i=2,nodes - if(icache_all(i).lt.ii_write) ii_write=icache_all(i) - enddo - write(iout,*) "MIN ii_write=",ii_write - endif - endif -ctest call flush(iout) - endif - if (synflag) then -c Update the time safety limiy - if (time001-time00.gt.safety) then - safety=time001-time00+600 - if (me.eq.king .or. .not. out1file) - & write (iout,*) "****** SAFETY increased to",safety," s" - endif - if (ovrtim()) end_of_run=.true. - endif - if(synflag.and..not.end_of_run) then - time02=MPI_WTIME() - synflag=.false. - -c write(iout,*) 'REMD before',me,t_bath - -c call mpi_gather(t_bath,1,mpi_double_precision, -c & remd_t_bath,1,mpi_double_precision,king, -c & CG_COMM,ierr) - potEcomp(n_ene+1)=t_bath - t_bath_old=t_bath - if (usampl) then - potEcomp(n_ene+2)=iset - if (iset.lt.nset) then - i_set_temp=iset - iset=iset+1 - call EconstrQ - potEcomp(n_ene+3)=Uconst - iset=i_set_temp - endif - if (iset.gt.1) then - i_set_temp=iset - iset=iset-1 - call EconstrQ - potEcomp(n_ene+4)=Uconst - iset=i_set_temp - endif - endif - if(hremd.gt.0) potEcomp(n_ene+2)=iset - call mpi_gather(potEcomp(0),n_ene+5,mpi_double_precision, - & remd_ene(0,1),n_ene+5,mpi_double_precision,king, - & CG_COMM,ierr) - if(lmuca) then - call mpi_gather(elow,1,mpi_double_precision, - & elowi,1,mpi_double_precision,king, - & CG_COMM,ierr) - call mpi_gather(ehigh,1,mpi_double_precision, - & ehighi,1,mpi_double_precision,king, - & CG_COMM,ierr) - endif - - time03=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD gather times=',time03-time01 - & ,time03-time02 - endif - - if (restart1file) call write1rst(i_index) - - time04=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD writing rst time=',time04-time03 - endif - - if (traj1file) call write1traj -cd debugging -cdeb call mpi_gather(ntwx_cache,1,mpi_integer, -cdeb & icache_all,1,mpi_integer,king, -cdeb & CG_COMM,ierr) -cdeb write(iout,'(a19,8000i8)') ' ntwx_cache after traj1file', -cdeb & (icache_all(i),i=1,nodes) -cd end - - - time05=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD writing traj time=',time05-time04 -ctime call flush(iout) - endif - - - if (me.eq.king) then - do i=1,nodes - remd_t_bath(i)=remd_ene(n_ene+1,i) - iremd_iset(i)=remd_ene(n_ene+2,i) - enddo -#ifdef DEBUG - if(lmuca) then -co write(iout,*) 'REMD exchange temp,ene,elow,ehigh' - do i=1,nodes - write(iout,'(i4,4f12.5)') i,remd_t_bath(i),remd_ene(0,i), - & elowi(i),ehighi(i) - enddo - else - write(iout,*) 'REMD exchange temp,ene' - do i=1,nodes - write(iout,'(i4,2f12.5)') i,remd_t_bath(i),remd_ene(0,i) - write(iout,'(6f12.5)') (remd_ene(j,i),j=1,n_ene) - enddo - endif -#endif -c------------------------------------- - IF(.not.usampl.and.hremd.eq.0) THEN -#ifdef DEBUG - write (iout,*) "Enter exchnge, remd_m",remd_m(1), - & " nodes",nodes -ctime call flush(iout) - write (iout,*) "remd_m(1)",remd_m(1) -#endif - do irr=1,remd_m(1) - i=ifirst(iran_num(1,remd_m(1))) -#ifdef DEBUG - write (iout,*) "i",i -#endif -ctime call flush(iout) - - do ii=1,nodes-1 - -#ifdef DEBUG - write (iout,*) "i",i," nupa(0,i)",int(nupa(0,i)) -#endif - if(i.gt.0.and.nupa(0,i).gt.0) then - iex=i -c if (i.eq.1 .and. int(nupa(0,i)).eq.1) then -c write (iout,*) -c & "CHUJ ABSOLUTNY!!! No way to sample a distinct replica in MREMD" -c call flush(iout) -c call MPI_Abort(MPI_COMM_WORLD,ERRCODE,ierr) -c endif -c do while (iex.eq.i) -c write (iout,*) "upper",nupa(int(nupa(0,i)),i) - iex=nupa(iran_num(1,int(nupa(0,i))),i) -c enddo -c write (iout,*) "nupa(0,i)",nupa(0,i)," iex",iex - if (lmuca) then - call muca_delta(remd_t_bath,remd_ene,i,iex,delta) - else -c Swap temperatures between conformations i and iex with recalculating the free energies -c following temperature changes. - ene_iex_iex=remd_ene(0,iex) - ene_i_i=remd_ene(0,i) -c write (iout,*) "i",i," ene_i_i",ene_i_i, -c & " iex",iex," ene_iex_iex",ene_iex_iex -c write (iout,*) "rescaling weights with temperature", -c & remd_t_bath(i) -c call flush(iout) - call rescale_weights(remd_t_bath(i)) - -c write (iout,*) "0,iex",remd_t_bath(i) -c call enerprint(remd_ene(0,iex)) - - call sum_energy(remd_ene(0,iex),.false.) - ene_iex_i=remd_ene(0,iex) -c write (iout,*) "ene_iex_i",remd_ene(0,iex) - -c write (iout,*) "0,i",remd_t_bath(i) -c call enerprint(remd_ene(0,i)) - - call sum_energy(remd_ene(0,i),.false.) -c write (iout,*) "ene_i_i",remd_ene(0,i) -c call flush(iout) -c write (iout,*) "rescaling weights with temperature", -c & remd_t_bath(iex) - if (abs(ene_i_i-remd_ene(0,i)).gt.ene_tol) then - write (iout,*) "ERROR: inconsistent energies:",i, - & ene_i_i,remd_ene(0,i) - endif - call rescale_weights(remd_t_bath(iex)) - -c write (iout,*) "0,i",remd_t_bath(iex) -c call enerprint(remd_ene(0,i)) - - call sum_energy(remd_ene(0,i),.false.) -c write (iout,*) "ene_i_iex",remd_ene(0,i) -c call flush(iout) - ene_i_iex=remd_ene(0,i) - -c write (iout,*) "0,iex",remd_t_bath(iex) -c call enerprint(remd_ene(0,iex)) - - call sum_energy(remd_ene(0,iex),.false.) - if (abs(ene_iex_iex-remd_ene(0,iex)).gt.ene_tol) then - write (iout,*) "ERROR: inconsistent energies:",iex, - & ene_iex_iex,remd_ene(0,iex) - endif -c write (iout,*) "ene_iex_iex",remd_ene(0,iex) -c write (iout,*) "i",i," iex",iex -c write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, -c & " ene_i_iex",ene_i_iex, -c & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex -c call flush(iout) - delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- - & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) - delta=-delta -c write(iout,*) 'delta',delta -c delta=(remd_t_bath(i)-remd_t_bath(iex))* -c & (remd_ene(i)-remd_ene(iex))/Rb/ -c & (remd_t_bath(i)*remd_t_bath(iex)) - endif - if (delta .gt. 50.0d0) then - delta=0.0d0 - else -#ifdef OSF - if(isnan(delta))then - delta=0.0d0 - else if (delta.lt.-50.0d0) then - delta=dexp(50.0d0) - else - delta=dexp(-delta) - endif -#else - delta=dexp(-delta) -#endif - endif - iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 - xxx=ran_number(0.0d0,1.0d0) -c write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx -c call flush(iout) - if (delta .gt. xxx) then - tmp=remd_t_bath(i) - remd_t_bath(i)=remd_t_bath(iex) - remd_t_bath(iex)=tmp - remd_ene(0,i)=ene_i_iex - remd_ene(0,iex)=ene_iex_i - if(lmuca) then - tmp=elowi(i) - elowi(i)=elowi(iex) - elowi(iex)=tmp - tmp=ehighi(i) - ehighi(i)=ehighi(iex) - ehighi(iex)=tmp - endif - - - do k=0,nodes - itmp=nupa(k,i) - nupa(k,i)=nupa(k,iex) - nupa(k,iex)=itmp - itmp=ndowna(k,i) - ndowna(k,i)=ndowna(k,iex) - ndowna(k,iex)=itmp - enddo - do il=1,nodes - if (ifirst(il).eq.i) ifirst(il)=iex - do k=1,nupa(0,il) - if (nupa(k,il).eq.i) then - nupa(k,il)=iex - elseif (nupa(k,il).eq.iex) then - nupa(k,il)=i - endif - enddo - do k=1,ndowna(0,il) - if (ndowna(k,il).eq.i) then - ndowna(k,il)=iex - elseif (ndowna(k,il).eq.iex) then - ndowna(k,il)=i - endif - enddo - enddo - - iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 - itmp=i2rep(i-1) - i2rep(i-1)=i2rep(iex-1) - i2rep(iex-1)=itmp - -c write(iout,*) 'exchange',i,iex -c write (iout,'(a8,100i4)') "@ ifirst", -c & (ifirst(k),k=1,remd_m(1)) -c do il=1,nodes -c write (iout,'(a8,i4,a1,100i4)') "@ nupa",il,":", -c & (nupa(k,il),k=1,nupa(0,il)) -c write (iout,'(a8,i4,a1,100i4)') "@ ndowna",il,":", -c & (ndowna(k,il),k=1,ndowna(0,il)) -c enddo -c call flush(iout) - - else - remd_ene(0,iex)=ene_iex_iex - remd_ene(0,i)=ene_i_i - i=iex - endif - endif - enddo - enddo -cd write (iout,*) "exchange completed" -cd call flush(iout) - ELSEIF (usampl) THEN - do ii=1,nodes -cd write(iout,*) "########",ii - - i_temp=iran_num(1,nrep) - i_mult=iran_num(1,remd_m(i_temp)) - i_iset=iran_num(1,nset) - i_mset=iran_num(1,mset(i_iset)) - i=i_index(i_temp,i_mult,i_iset,i_mset) - -cd write(iout,*) "i=",i,i_temp,i_mult,i_iset,i_mset - - if(t_exchange_only)then - i_dir=1 - else - i_dir=iran_num(1,3) - endif -cd write(iout,*) "i_dir=",i_dir - - if(i_dir.eq.1 .and. remd_m(i_temp+1).gt.0 )then - - i_temp1=i_temp+1 - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset - i_mset1=iran_num(1,mset(i_iset1)) - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - - elseif(i_dir.eq.2 .and. mset(i_iset+1).gt.0)then - - i_temp1=i_temp - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset+1 - i_mset1=iran_num(1,mset(i_iset1)) - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - econstr_temp_i=remd_ene(20,i) - econstr_temp_iex=remd_ene(20,iex) - remd_ene(20,i)=remd_ene(n_ene+3,i) - remd_ene(20,iex)=remd_ene(n_ene+4,iex) - - elseif(remd_m(i_temp+1).gt.0.and.mset(i_iset+1).gt.0)then - - i_temp1=i_temp+1 - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset+1 - i_mset1=iran_num(1,mset(i_iset1)) - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - econstr_temp_i=remd_ene(20,i) - econstr_temp_iex=remd_ene(20,iex) - remd_ene(20,i)=remd_ene(n_ene+3,i) - remd_ene(20,iex)=remd_ene(n_ene+4,iex) - - else - goto 444 - endif - -cd write(iout,*) "iex=",iex,i_temp1,i_mult1,i_iset1,i_mset1 -ctime call flush(iout) - -c Swap temperatures between conformations i and iex with recalculating the free energies -c following temperature changes. - ene_iex_iex=remd_ene(0,iex) - ene_i_i=remd_ene(0,i) -co write (iout,*) "rescaling weights with temperature", -co & remd_t_bath(i) - call rescale_weights(remd_t_bath(i)) - - call sum_energy(remd_ene(0,iex),.false.) - ene_iex_i=remd_ene(0,iex) -cd write (iout,*) "ene_iex_i",remd_ene(0,iex) -c call sum_energy(remd_ene(0,i),.false.) -cd write (iout,*) "ene_i_i",remd_ene(0,i) -c write (iout,*) "rescaling weights with temperature", -c & remd_t_bath(iex) -c if (real(ene_i_i).ne.real(remd_ene(0,i))) then -c write (iout,*) "ERROR: inconsistent energies:",i, -c & ene_i_i,remd_ene(0,i) -c endif - call rescale_weights(remd_t_bath(iex)) - call sum_energy(remd_ene(0,i),.false.) -cd write (iout,*) "ene_i_iex",remd_ene(0,i) - ene_i_iex=remd_ene(0,i) -c call sum_energy(remd_ene(0,iex),.false.) -c if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then -c write (iout,*) "ERROR: inconsistent energies:",iex, -c & ene_iex_iex,remd_ene(0,iex) -c endif -cd write (iout,*) "ene_iex_iex",remd_ene(0,iex) -c write (iout,*) "i",i," iex",iex -cd write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, -cd & " ene_i_iex",ene_i_iex, -cd & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex - delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- - & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) - delta=-delta -cd write(iout,*) 'delta',delta -c delta=(remd_t_bath(i)-remd_t_bath(iex))* -c & (remd_ene(i)-remd_ene(iex))/Rb/ -c & (remd_t_bath(i)*remd_t_bath(iex)) - if (delta .gt. 50.0d0) then - delta=0.0d0 - else - delta=dexp(-delta) - endif - if (i_dir.eq.1.or.i_dir.eq.3) - & iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 - if (i_dir.eq.2.or.i_dir.eq.3) - & iremd_tot_usa(int(i2set(i-1)))= - & iremd_tot_usa(int(i2set(i-1)))+1 - xxx=ran_number(0.0d0,1.0d0) -cd write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx - if (delta .gt. xxx) then - tmp=remd_t_bath(i) - remd_t_bath(i)=remd_t_bath(iex) - remd_t_bath(iex)=tmp - - itmp=iremd_iset(i) - iremd_iset(i)=iremd_iset(iex) - iremd_iset(iex)=itmp - - remd_ene(0,i)=ene_i_iex - remd_ene(0,iex)=ene_iex_i - - if (i_dir.eq.1.or.i_dir.eq.3) - & iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 - - itmp=i2rep(i-1) - i2rep(i-1)=i2rep(iex-1) - i2rep(iex-1)=itmp - - if (i_dir.eq.2.or.i_dir.eq.3) - & iremd_acc_usa(int(i2set(i-1)))= - & iremd_acc_usa(int(i2set(i-1)))+1 - - itmp=i2set(i-1) - i2set(i-1)=i2set(iex-1) - i2set(iex-1)=itmp - - itmp=i_index(i_temp,i_mult,i_iset,i_mset) - i_index(i_temp,i_mult,i_iset,i_mset)= - & i_index(i_temp1,i_mult1,i_iset1,i_mset1) - i_index(i_temp1,i_mult1,i_iset1,i_mset1)=itmp - - else - remd_ene(0,iex)=ene_iex_iex - remd_ene(0,i)=ene_i_i - remd_ene(20,iex)=econstr_temp_iex - remd_ene(20,i)=econstr_temp_i - endif - -cd do il=1,nset -cd do il1=1,mset(il) -cd do i=1,nrep -cd do j=1,remd_m(i) -cd write(iout,*) i,j,il,il1,i_index(i,j,il,il1) -cd enddo -cd enddo -cd enddo -cd enddo - - 444 continue - - enddo - - ELSEIF (hremd.gt.0) THEN - do ii=1,nodes -cd write(iout,*) "########",ii - - i_temp=iran_num(1,nrep) - i_mult=iran_num(1,remd_m(i_temp)) - i_iset=iran_num(1,nset) - i_mset=1 - i=i_index(i_temp,i_mult,i_iset,i_mset) - -cd write(iout,*) "i=",i,i_temp,i_mult,i_iset,i_mset - - if(t_exchange_only)then - i_dir=1 - else - i_dir=iran_num(1,3) - endif - -cd write(iout,*) "i_dir=",i_dir - - if(i_dir.eq.1 .and. remd_m(i_temp+1).gt.0 )then - - i_temp1=i_temp+1 - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=i_iset - i_mset1=1 - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - - elseif(i_dir.eq.2)then - - i_temp1=i_temp - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=iran_num(1,hremd) - do while(i_iset1.eq.i_iset) - i_iset1=iran_num(1,hremd) - enddo - i_mset1=1 - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - - elseif(remd_m(i_temp+1).gt.0)then - - i_temp1=i_temp+1 - i_mult1=iran_num(1,remd_m(i_temp1)) - i_iset1=iran_num(1,hremd) - do while(i_iset1.eq.i_iset) - i_iset1=iran_num(1,hremd) - enddo - i_mset1=1 - iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) - - else - goto 445 - endif - -cd write(iout,*) "iex=",iex,i_temp1,i_mult1,i_iset1,i_mset1 -ctime call flush(iout) - -c Swap temperatures between conformations i and iex with recalculating the free energies -c following temperature changes. - ene_iex_iex=remd_ene(0,iex) - ene_i_i=remd_ene(0,i) - - call set_hweights(i_iset) - call rescale_weights(remd_t_bath(i)) - call sum_energy(remd_ene(0,iex),.false.) - ene_iex_i=remd_ene(0,iex) - - call set_hweights(i_iset1) - call rescale_weights(remd_t_bath(iex)) - call sum_energy(remd_ene(0,i),.false.) - ene_i_iex=remd_ene(0,i) - -cd write(iout,*) ene_iex_iex,ene_i_i,ene_iex_i,ene_i_iex - - delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- - & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) - delta=-delta - - if (delta .gt. 50.0d0) then - delta=0.0d0 - else - delta=dexp(-delta) - endif - - if (i_dir.eq.1.or.i_dir.eq.3) - & iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 - if (i_dir.eq.2.or.i_dir.eq.3) - & iremd_tot_usa(int(i2set(i-1)))= - & iremd_tot_usa(int(i2set(i-1)))+1 - xxx=ran_number(0.0d0,1.0d0) -cd write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx - if (delta .gt. xxx) then - -cd write (iout,*) "exchange" - tmp=remd_t_bath(i) - remd_t_bath(i)=remd_t_bath(iex) - remd_t_bath(iex)=tmp - - itmp=iremd_iset(i) - iremd_iset(i)=iremd_iset(iex) - iremd_iset(iex)=itmp - - remd_ene(0,i)=ene_i_iex - remd_ene(0,iex)=ene_iex_i - - if (i_dir.eq.1.or.i_dir.eq.3) - & iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 - - itmp=i2rep(i-1) - i2rep(i-1)=i2rep(iex-1) - i2rep(iex-1)=itmp - - if (i_dir.eq.2.or.i_dir.eq.3) - & iremd_acc_usa(int(i2set(i-1)))= - & iremd_acc_usa(int(i2set(i-1)))+1 - - itmp=i2set(i-1) - i2set(i-1)=i2set(iex-1) - i2set(iex-1)=itmp - - itmp=i_index(i_temp,i_mult,i_iset,i_mset) - i_index(i_temp,i_mult,i_iset,i_mset)= - & i_index(i_temp1,i_mult1,i_iset1,i_mset1) - i_index(i_temp1,i_mult1,i_iset1,i_mset1)=itmp - -cd do il=1,nset -cd do il1=1,mset(il) -cd do i=1,nrep -cd do j=1,remd_m(i) -cd write(iout,*) i,j,il,il1,i_index(i,j,il,il1) -cd enddo -cd enddo -cd enddo -cd enddo - - else - remd_ene(0,iex)=ene_iex_iex - remd_ene(0,i)=ene_i_i - endif - - - - 445 continue - - enddo - - ENDIF - -c------------------------------------- - write (iout,*) "NREP",nrep - do i=1,nrep - if(iremd_tot(i).ne.0) - & write(iout,'(a3,i4,2f12.5,i5)') 'ACC',i,remd_t(i) - & ,iremd_acc(i)/(1.0*iremd_tot(i)),iremd_tot(i) - enddo - - if(usampl) then - do i=1,nset - if(iremd_tot_usa(i).ne.0) - & write(iout,'(a10,i4,f12.5,i8)') 'ACC_usampl',i, - & iremd_acc_usa(i)/(1.0*iremd_tot_usa(i)),iremd_tot_usa(i) - enddo - endif - - if(hremd.gt.0) then - do i=1,nset - if(iremd_tot_usa(i).ne.0) - & write(iout,'(a10,i4,f12.5,i8)') 'ACC_hremd',i, - & iremd_acc_usa(i)/(1.0*iremd_tot_usa(i)),iremd_tot_usa(i) - enddo - endif - - -ctime call flush(iout) - -cd write (iout,'(a6,100i4)') "ifirst", -cd & (ifirst(i),i=1,remd_m(1)) -cd do il=1,nodes -cd write (iout,'(a5,i4,a1,100i4)') "nup",il,":", -cd & (nupa(i,il),i=1,nupa(0,il)) -cd write (iout,'(a5,i4,a1,100i4)') "ndown",il,":", -cd & (ndowna(i,il),i=1,ndowna(0,il)) -cd enddo - endif - - time06=MPI_WTIME() -cd write (iout,*) "Before scatter" -cd call flush(iout) - call mpi_scatter(remd_t_bath,1,mpi_double_precision, - & t_bath,1,mpi_double_precision,king, - & CG_COMM,ierr) -cd write (iout,*) "After scatter" -cd call flush(iout) - if(usampl.or.hremd.gt.0) - & call mpi_scatter(iremd_iset,1,mpi_integer, - & iset,1,mpi_integer,king, - & CG_COMM,ierr) - - time07=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD scatter time=',time07-time06 - endif - - if(lmuca) then - call mpi_scatter(elowi,1,mpi_double_precision, - & elow,1,mpi_double_precision,king, - & CG_COMM,ierr) - call mpi_scatter(ehighi,1,mpi_double_precision, - & ehigh,1,mpi_double_precision,king, - & CG_COMM,ierr) - endif - - if(hremd.gt.0) call set_hweights(iset) - call rescale_weights(t_bath) -co write (iout,*) "Processor",me, -co & " rescaling weights with temperature",t_bath - - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - if (lang.gt.0) then - do i=nnt,nct-1 - stdforcp(i)=stdforcp(i)*sqrt(t_bath/t_bath_old) - enddo - do i=nnt,nct - stdforcsc(i)=stdforcsc(i)*sqrt(t_bath/t_bath_old) - enddo - endif -cde write(iout,*) 'REMD after',me,t_bath - time08=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write(iout,*) 'REMD exchange time=',time08-time02 -ctime call flush(iout) - endif - endif - enddo - - if (restart1file) then - if (me.eq.king .or. .not. out1file) - & write(iout,*) 'writing restart at the end of run' - call write1rst(i_index) - endif - - if (traj1file) call write1traj -cd debugging -cdeb call mpi_gather(ntwx_cache,1,mpi_integer, -cdeb & icache_all,1,mpi_integer,king, -cdeb & CG_COMM,ierr) -cdeb write(iout,'(a40,8000i8)') -cdeb & ' ntwx_cache after traj1file at the end', -cdeb & (icache_all(i),i=1,nodes) -cd end - - -#ifdef MPI - t_MD=MPI_Wtime()-tt0 -#else - t_MD=tcpu()-tt0 -#endif - if (me.eq.king .or. .not. out1file) then - write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') - & ' Timing ', - & 'MD calculations setup:',t_MDsetup, - & 'Energy & gradient evaluation:',t_enegrad, - & 'Stochastic MD setup:',t_langsetup, - & 'Stochastic MD step setup:',t_sdsetup, - & 'MD steps:',t_MD - write (iout,'(/28(1h=),a25,27(1h=))') - & ' End of MD calculation ' - if(hmc.gt.0) write (iout,*) 'HMC acceptance ratio', - & n_timestep*1.0d0/hmc/hmc_acc - endif - return - end - -c----------------------------------------------------------------------- - subroutine write1rst(i_index) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & d_restart2(3,2*maxres*maxprocs) - real t5_restart1(5) - integer iret,itmp - integer*2 i_index - & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) - common /przechowalnia/ d_restart1,d_restart2 - - t5_restart1(1)=totT - t5_restart1(2)=EK - t5_restart1(3)=potE - t5_restart1(4)=t_bath - t5_restart1(5)=Uconst - - call mpi_gather(t5_restart1,5,mpi_real, - & t_restart1,5,mpi_real,king,CG_COMM,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=d_t(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart1,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - - do i=1,2*nres - do j=1,3 - r_d(j,i)=dc(j,i) - enddo - enddo - call mpi_gather(r_d,3*2*nres,mpi_real, - & d_restart2,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - if(me.eq.king) then -#ifdef AIX - call xdrfopen_(ixdrf,mremd_rst_name, "w", iret) - do i=0,nodes-1 - call xdrfint_(ixdrf, i2rep(i), iret) - enddo - do i=1,remd_m(1) - call xdrfint_(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes - do i=0,nupa(0,il) - call xdrfint_(ixdrf, nupa(i,il), iret) - enddo - - do i=0,ndowna(0,il) - call xdrfint_(ixdrf, ndowna(i,il), iret) - enddo - enddo - - do il=1,nodes - do j=1,4 - call xdrffloat_(ixdrf, t_restart1(j,il), iret) - enddo - enddo - - do il=0,nodes-1 - do i=1,2*nres - do j=1,3 - call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) - enddo - enddo - enddo - do il=0,nodes-1 - do i=1,2*nres - do j=1,3 - call xdrffloat_(ixdrf, d_restart2(j,i+2*nres*il), iret) - enddo - enddo - enddo - - if(usampl) then - call xdrfint_(ixdrf, nset, iret) - do i=1,nset - call xdrfint_(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint_(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - itmp=i_index(i,j,il,il1) - call xdrfint_(ixdrf,itmp, iret) - enddo - enddo - enddo - enddo - - endif - call xdrfclose_(ixdrf, iret) -#else - call xdrfopen(ixdrf,mremd_rst_name, "w", iret) - do i=0,nodes-1 - call xdrfint(ixdrf, i2rep(i), iret) - enddo - do i=1,remd_m(1) - call xdrfint(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes - do i=0,nupa(0,il) - call xdrfint(ixdrf, nupa(i,il), iret) - enddo - - do i=0,ndowna(0,il) - call xdrfint(ixdrf, ndowna(i,il), iret) - enddo - enddo - - do il=1,nodes - do j=1,4 - call xdrffloat(ixdrf, t_restart1(j,il), iret) - enddo - enddo - - do il=0,nodes-1 - do i=1,2*nres - do j=1,3 - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) - enddo - enddo - enddo - do il=0,nodes-1 - do i=1,2*nres - do j=1,3 - call xdrffloat(ixdrf, d_restart2(j,i+2*nres*il), iret) - enddo - enddo - enddo - - - if(usampl) then - call xdrfint(ixdrf, nset, iret) - do i=1,nset - call xdrfint(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - itmp=i_index(i,j,il,il1) - call xdrfint(ixdrf,itmp, iret) - enddo - enddo - enddo - enddo - - endif - call xdrfclose(ixdrf, iret) -#endif - endif - return - end - - - subroutine write1traj - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - - real t5_restart1(5) - integer iret,itmp - real xcoord(3,maxres2+2),prec - real r_qfrag(50),r_qpair(100) - real r_utheta(50),r_ugamma(100),r_uscdiff(100) - real p_qfrag(50*maxprocs),p_qpair(100*maxprocs) - real p_utheta(50*maxprocs),p_ugamma(100*maxprocs), - & p_uscdiff(100*maxprocs) - real p_c(3,(maxres2+2)*maxprocs),r_c(3,maxres2+2) - common /przechowalnia/ p_c - - call mpi_bcast(ii_write,1,mpi_integer, - & king,CG_COMM,ierr) - -c debugging - print *,'traj1file',me,ii_write,ntwx_cache -c end debugging - -#ifdef AIX - if(me.eq.king) call xdrfopen_(ixdrf,cartname, "a", iret) -#else - if(me.eq.king) call xdrfopen(ixdrf,cartname, "a", iret) -#endif - do ii=1,ii_write - t5_restart1(1)=totT_cache(ii) - t5_restart1(2)=EK_cache(ii) - t5_restart1(3)=potE_cache(ii) - t5_restart1(4)=t_bath_cache(ii) - t5_restart1(5)=Uconst_cache(ii) - call mpi_gather(t5_restart1,5,mpi_real, - & t_restart1,5,mpi_real,king,CG_COMM,ierr) - - call mpi_gather(iset_cache(ii),1,mpi_integer, - & iset_restart1,1,mpi_integer,king,CG_COMM,ierr) - - do i=1,nfrag - r_qfrag(i)=qfrag_cache(i,ii) - enddo - do i=1,npair - r_qpair(i)=qpair_cache(i,ii) - enddo - do i=1,nfrag_back - r_utheta(i)=utheta_cache(i,ii) - r_ugamma(i)=ugamma_cache(i,ii) - r_uscdiff(i)=uscdiff_cache(i,ii) - enddo - - call mpi_gather(r_qfrag,nfrag,mpi_real, - & p_qfrag,nfrag,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(r_qpair,npair,mpi_real, - & p_qpair,npair,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(r_utheta,nfrag_back,mpi_real, - & p_utheta,nfrag_back,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(r_ugamma,nfrag_back,mpi_real, - & p_ugamma,nfrag_back,mpi_real,king, - & CG_COMM,ierr) - call mpi_gather(r_uscdiff,nfrag_back,mpi_real, - & p_uscdiff,nfrag_back,mpi_real,king, - & CG_COMM,ierr) - -#ifdef DEBUG - write (iout,*) "p_qfrag" - do i=1,nodes - write (iout,*) i,(p_qfrag((i-1)*nfrag+j),j=1,nfrag) - enddo - write (iout,*) "p_qpair" - do i=1,nodes - write (iout,*) i,(p_qpair((i-1)*npair+j),j=1,npair) - enddo -ctime call flush(iout) -#endif - do i=1,nres*2 - do j=1,3 - r_c(j,i)=c_cache(j,i,ii) - enddo - enddo - - call mpi_gather(r_c,3*2*nres,mpi_real, - & p_c,3*2*nres,mpi_real,king, - & CG_COMM,ierr) - - if(me.eq.king) then -#ifdef AIX - do il=1,nodes - call xdrffloat_(ixdrf, real(t_restart1(1,il)), iret) - call xdrffloat_(ixdrf, real(t_restart1(3,il)), iret) - call xdrffloat_(ixdrf, real(t_restart1(5,il)), iret) - call xdrffloat_(ixdrf, real(t_restart1(4,il)), iret) - call xdrfint_(ixdrf, nss, iret) - do j=1,nss - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) - enddo - call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret) - call xdrfint_(ixdrf, iset_restart1(il), iret) - do i=1,nfrag - call xdrffloat_(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) - enddo - do i=1,npair - call xdrffloat_(ixdrf, p_qpair(i+(il-1)*npair), iret) - enddo - do i=1,nfrag_back - call xdrffloat_(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret) - call xdrffloat_(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret) - call xdrffloat_(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret) - enddo - prec=10000.0 - do i=1,nres - do j=1,3 - xcoord(j,i)=p_c(j,i+(il-1)*nres*2) - enddo - enddo - do i=nnt,nct - do j=1,3 - xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) - enddo - enddo - itmp=nres+nct-nnt+1 - call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret) - enddo -#else - do il=1,nodes - call xdrffloat(ixdrf, real(t_restart1(1,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(3,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(5,il)), iret) - call xdrffloat(ixdrf, real(t_restart1(4,il)), iret) - call xdrfint(ixdrf, nss, iret) - do j=1,nss - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - enddo - call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret) - call xdrfint(ixdrf, iset_restart1(il), iret) - do i=1,nfrag - call xdrffloat(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) - enddo - do i=1,npair - call xdrffloat(ixdrf, p_qpair(i+(il-1)*npair), iret) - enddo - do i=1,nfrag_back - call xdrffloat(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret) - call xdrffloat(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret) - call xdrffloat(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret) - enddo - prec=10000.0 - do i=1,nres - do j=1,3 - xcoord(j,i)=p_c(j,i+(il-1)*nres*2) - enddo - enddo - do i=nnt,nct - do j=1,3 - xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) - enddo - enddo - itmp=nres+nct-nnt+1 - call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) - enddo -#endif - endif - enddo -#ifdef AIX - if(me.eq.king) call xdrfclose_(ixdrf, iret) -#else - if(me.eq.king) call xdrfclose(ixdrf, iret) -#endif - do i=1,ntwx_cache-ii_write - - totT_cache(i)=totT_cache(ii_write+i) - EK_cache(i)=EK_cache(ii_write+i) - potE_cache(i)=potE_cache(ii_write+i) - t_bath_cache(i)=t_bath_cache(ii_write+i) - Uconst_cache(i)=Uconst_cache(ii_write+i) - iset_cache(i)=iset_cache(ii_write+i) - - do ii=1,nfrag - qfrag_cache(ii,i)=qfrag_cache(ii,ii_write+i) - enddo - do ii=1,npair - qpair_cache(ii,i)=qpair_cache(ii,ii_write+i) - enddo - do ii=1,nfrag_back - utheta_cache(ii,i)=utheta_cache(ii,ii_write+i) - ugamma_cache(ii,i)=ugamma_cache(ii,ii_write+i) - uscdiff_cache(ii,i)=uscdiff_cache(ii,ii_write+i) - enddo - - do ii=1,nres*2 - do j=1,3 - c_cache(j,ii,i)=c_cache(j,ii,ii_write+i) - enddo - enddo - enddo - ntwx_cache=ntwx_cache-ii_write - return - end - - - subroutine read1restart(i_index) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & t5_restart1(5) - integer*2 i_index - & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) - common /przechowalnia/ d_restart1 - write (*,*) "Processor",me," called read1restart" - - if(me.eq.king)then - open(irest2,file=mremd_rst_name,status='unknown') - read(irest2,*,err=334) i - write(iout,*) "Reading old rst in ASCI format" - close(irest2) - call read1restart_old - return - 334 continue -#ifdef AIX - call xdrfopen_(ixdrf,mremd_rst_name, "r", iret) - - do i=0,nodes-1 - call xdrfint_(ixdrf, i2rep(i), iret) - enddo - do i=1,remd_m(1) - call xdrfint_(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes - call xdrfint_(ixdrf, nupa(0,il), iret) - do i=1,nupa(0,il) - call xdrfint_(ixdrf, nupa(i,il), iret) - enddo - - call xdrfint_(ixdrf, ndowna(0,il), iret) - do i=1,ndowna(0,il) - call xdrfint_(ixdrf, ndowna(i,il), iret) - enddo - enddo - do il=1,nodes - do j=1,4 - call xdrffloat_(ixdrf, t_restart1(j,il), iret) - enddo - enddo -#else - call xdrfopen(ixdrf,mremd_rst_name, "r", iret) - - do i=0,nodes-1 - call xdrfint(ixdrf, i2rep(i), iret) - enddo - do i=1,remd_m(1) - call xdrfint(ixdrf, ifirst(i), iret) - enddo - do il=1,nodes - call xdrfint(ixdrf, nupa(0,il), iret) - do i=1,nupa(0,il) - call xdrfint(ixdrf, nupa(i,il), iret) - enddo - - call xdrfint(ixdrf, ndowna(0,il), iret) - do i=1,ndowna(0,il) - call xdrfint(ixdrf, ndowna(i,il), iret) - enddo - enddo - do il=1,nodes - do j=1,4 - call xdrffloat(ixdrf, t_restart1(j,il), iret) - enddo - enddo -#endif - endif - call mpi_scatter(t_restart1,5,mpi_real, - & t5_restart1,5,mpi_real,king,CG_COMM,ierr) - totT=t5_restart1(1) - EK=t5_restart1(2) - potE=t5_restart1(3) - t_bath=t5_restart1(4) - - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres -c read(irest2,'(3e15.5)') -c & (d_restart1(j,i+2*nres*il),j=1,3) - do j=1,3 -#ifdef AIX - call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) -#else - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) -#endif - enddo - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - - do i=1,2*nres - do j=1,3 - d_t(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres -c read(irest2,'(3e15.5)') -c & (d_restart1(j,i+2*nres*il),j=1,3) - do j=1,3 -#ifdef AIX - call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) -#else - call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) -#endif - enddo - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - do i=1,2*nres - do j=1,3 - dc(j,i)=r_d(j,i) - enddo - enddo - - - if(usampl) then -#ifdef AIX - if(me.eq.king)then - call xdrfint_(ixdrf, nset, iret) - do i=1,nset - call xdrfint_(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint_(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - call xdrfint_(ixdrf,itmp, iret) - i_index(i,j,il,il1)=itmp - enddo - enddo - enddo - enddo - endif -#else - if(me.eq.king)then - call xdrfint(ixdrf, nset, iret) - do i=1,nset - call xdrfint(ixdrf,mset(i), iret) - enddo - do i=0,nodes-1 - call xdrfint(ixdrf,i2set(i), iret) - enddo - do il=1,nset - do il1=1,mset(il) - do i=1,nrep - do j=1,remd_m(i) - call xdrfint(ixdrf,itmp, iret) - i_index(i,j,il,il1)=itmp - enddo - enddo - enddo - enddo - endif -#endif - call mpi_scatter(i2set,1,mpi_integer, - & iset,1,mpi_integer,king, - & CG_COMM,ierr) - - endif - - - if(me.eq.king) close(irest2) - return - end - - subroutine read1restart_old - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.SBRIDGE' - include 'COMMON.INTERACT' - real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), - & t5_restart1(5) - common /przechowalnia/ d_restart1 - if(me.eq.king)then - open(irest2,file=mremd_rst_name,status='unknown') - read (irest2,*) (i2rep(i),i=0,nodes-1) - read (irest2,*) (ifirst(i),i=1,remd_m(1)) - do il=1,nodes - read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) - read (irest2,*) ndowna(0,il), - & (ndowna(i,il),i=1,ndowna(0,il)) - enddo - do il=1,nodes - read(irest2,*) (t_restart1(j,il),j=1,4) - enddo - endif - call mpi_scatter(t_restart1,5,mpi_real, - & t5_restart1,5,mpi_real,king,CG_COMM,ierr) - totT=t5_restart1(1) - EK=t5_restart1(2) - potE=t5_restart1(3) - t_bath=t5_restart1(4) - - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres - read(irest2,'(3e15.5)') - & (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - - do i=1,2*nres - do j=1,3 - d_t(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king)then - do il=0,nodes-1 - do i=1,2*nres - read(irest2,'(3e15.5)') - & (d_restart1(j,i+2*nres*il),j=1,3) - enddo - enddo - endif - call mpi_scatter(d_restart1,3*2*nres,mpi_real, - & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) - do i=1,2*nres - do j=1,3 - dc(j,i)=r_d(j,i) - enddo - enddo - if(me.eq.king) close(irest2) - return - end -c------------------------------------------------------------------- - subroutine set_hweights(iiset) - implicit real*8 (a-h,o-z) - integer i - include 'DIMENSIONS' - include 'COMMON.FFIELD' - include 'COMMON.REMD' - - do i=1,n_ene - weights(i)=hweights(iiset,i) - enddo - - wsc =weights(1) - wscp =weights(2) - welec =weights(3) - wcorr =weights(4) - wcorr5 =weights(5) - wcorr6 =weights(6) - wel_loc=weights(7) - wturn3 =weights(8) - wturn4 =weights(9) - wturn6 =weights(10) - wang =weights(11) - wscloc =weights(12) - wtor =weights(13) - wtor_d =weights(14) - wstrain=weights(15) - wvdwpp =weights(16) - wbond =weights(17) - scal14 =weights(18) - wsccor =weights(21) - - return - end -#endif diff --git a/source/unres/src_MD_DFA/Makefile-intrepid-with-tau b/source/unres/src_MD_DFA/Makefile-intrepid-with-tau deleted file mode 100644 index eae1cc5..0000000 --- a/source/unres/src_MD_DFA/Makefile-intrepid-with-tau +++ /dev/null @@ -1,154 +0,0 @@ -# -FC1=/bgsys/drivers/ppcfloor/comm/bin/mpixlf77 -FC=tau_f90.sh -OPT = -O3 -qarch=450 -qtune=450 -qfixed -#OPT = -O3 -qarch=450 -qtune=450 -qdebug=function_trace -qfixed -#OPT = -O -qarch=450 -qtune=450 -qfixed -#-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ -#-Mprefetch=distance:8,nta - -#OPT = -O0 -C -g -qarch=450 -qtune=450 -qfixed -OPT1 = -O0 -g -qarch=450 -qtune=450 -qfixed -OPT2 = -O2 -qarch=450 -qtune=450 -qfixed -#OPT2 = -O2 -qarch=450 -qtune=450 -qdebug=function_trace -qfixed -#OPT2 = ${OPT} -OPTE = -O4 -qarch=450 -qtune=450 -qfixed -#OPTE = -O4 -qarch=450 -qtune=450 -qdebug=function_trace -qfixed -#OPTE=${OPT} - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include -FFLAGSE = -c ${OPTE} -I$(INSTALL_DIR)/include - -BIN = ../bin/unres_MD_Tc_procor-newparm-gnivpar-O4-test.exe -#LIBS = xdrf/libxdrf.a /home/liwo/UNRES/LIB/libmemmon.a -LIBS = xdrf/libxdrf.a - -CPPFLAGS = -WF,-DAIX -WF,-DISNAN -WF,-DUNRES -WF,-DMP -WF,-DMPI -WF,-DPGI \ - -WF,-DSPLITELE -WF,-DPROCOR -WF,-DAMD64 -WF,-DLANG0 - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new.o \ - energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - ${CC} -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} --print-map ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o; /bin/rm *.pp.* - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS1} ${CPPFLAGS} rmdd.f - -eigen.o : eigen.f - ${FC} ${FFLAGS1} ${CPPFLAGS} eigen.f - -blas.o : blas.f - ${FC} ${FFLAGS1} ${CPPFLAGS} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} ${CPPFLAGS} add.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -energy_p_new-sep.o : energy_p_new-sep.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -compinfo: compinfo.o - ${CC} ${CFLAGS} compfinfo.c - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c - -prng_32.o: prng_32.F - ${FC} -qfixed -O0 prng_32.F - -prng.o: prng.f - ${FC1} ${FFLAGS} prng.f - -readrtns_CSA.o: readrtns_CSA.F - ${FC1} ${FFLAGS} ${CPPFLAGS} readrtns_CSA.F - -gen_rand_conf.o: gen_rand_conf.F - ${FC1} ${FFLAGS} ${CPPFLAGS} gen_rand_conf.F diff --git a/source/unres/src_MD_DFA/Makefile.tau-mpi-f77-pdt b/source/unres/src_MD_DFA/Makefile.tau-mpi-f77-pdt deleted file mode 100644 index c8dc5fe..0000000 --- a/source/unres/src_MD_DFA/Makefile.tau-mpi-f77-pdt +++ /dev/null @@ -1,860 +0,0 @@ -#**************************************************************************** -#* TAU Portable Profiling Package ** -#* http://www.cs.uoregon.edu/research/tau ** -#**************************************************************************** -#* Copyright 1997-2002 ** -#* Department of Computer and Information Science, University of Oregon ** -#* Advanced Computing Laboratory, Los Alamos National Laboratory ** -#**************************************************************************** -####################################################################### -## pC++/Sage++ Copyright (C) 1993,1995 ## -## Indiana University University of Oregon University of Rennes ## -####################################################################### - -####################################################################### -# This is a sample Makefile that contains the Profiling and Tracing -# options. Makefiles of other applications and libraries (not included -# in this distribution) should include this Makefile. -# It defines the following variables that should be added to CFLAGS -# TAU_INCLUDE - Include path for tau headers -# TAU_DEFS - Defines that are needed for tracing and profiling only. -# And for linking add to LIBS -# TAU_LIBS - TAU Tracing and Profiling library libprof.a -# -# When the user needs to turn off tracing and profiling and run the -# application without any runtime overhead of instrumentation, simply -# remove TAUDEFS and TAULIBS from CFLAGS and LIBS respectively but keep -# TAUINC. -####################################################################### - -########### Automatically modified by the configure script ############ -CONFIG_ARCH=bgp -TAU_ARCH=bgp -CONFIG_CC=bgxlc_r -CONFIG_CXX=bgxlC_r -TAU_CC_FE=$(CONFIG_CC) -TAU_CXX_FE=$(CONFIG_CXX) - -# Front end C/C++ Compilers -#BGL#TAU_CC_FE=xlc #ENDIF# -#BGL#TAU_CXX_FE=xlC #ENDIF# -TAU_CC_FE=xlc #ENDIF##BGP# -TAU_CXX_FE=xlC #ENDIF##BGP# -#CATAMOUNT#TAU_CC_FE=gcc #ENDIF# -#CATAMOUNT#TAU_CXX_FE=g++ #ENDIF# -#SC_GFORTRAN#TAU_CC_FE=gcc #ENDIF# -#SC_GFORTRAN#TAU_CXX_FE=g++ #ENDIF# -#SC_PATHSCALE#TAU_CC_FE=gcc #ENDIF# -#SC_PATHSCALE#TAU_CXX_FE=g++ #ENDIF# - -PCXX_OPT=-g -USER_OPT= -EXTRADIR=/opt/ibmcmp/xlf/bg/11.1/bin/.. -EXTRADIRCXX=/opt/ibmcmp/vacpp/bg/9.0/bin/.. -TAUROOT=/soft/apps/tau/tau_latest -TULIPDIR= -TAUEXTRASHLIBOPTS= -TAUGCCLIBOPTS= -TAUGCCLIBDIR= -TAUGFORTRANLIBDIR= -PCLDIR= -PAPIDIR= -PAPISUBDIR= -CHARMDIR= -PDTDIR=/soft/apps/tau/pdtoolkit-3.12 -PDTCOMPDIR= -DYNINSTDIR= -JDKDIR= -SLOG2DIR= -OPARIDIR= -TAU_OPARI_TOOL= -EPILOGDIR= -EPILOGBINDIR= -EPILOGINCDIR= -EPILOGLIBDIR= -EPILOGEXTRALINKCMD= -VAMPIRTRACEDIR= -KTAU_INCDIR= -KTAU_INCUSERDIR= -KTAU_LIB= -KTAU_KALLSYMS_PATH= -PYTHON_INCDIR= -PYTHON_LIBDIR= -PERFINCDIR= -PERFLIBDIR= -PERFLIBRARY= -TAU_SHMEM_INC= -TAU_SHMEM_LIB= -TAU_CONFIG=-mpi-pdt -TAU_MPI_INC=-I/bgsys/drivers/ppcfloor/comm/include -TAU_MPI_LIB=-L/soft/apps/tau/tau_latest/bgp/lib -lTauMpi$(TAU_CONFIG) -L/bgsys/drivers/ppcfloor/comm/lib -TAU_MPI_FLIB=-lfmpich.cnk -L/soft/apps/tau/tau_latest/bgp/lib -lTauMpi$(TAU_CONFIG) -L/bgsys/drivers/ppcfloor/comm/lib -TAU_MPILIB_DIR=/bgsys/drivers/ppcfloor/comm/lib -TAU_MPI_NOWRAP_LIB= -L/bgsys/drivers/ppcfloor/comm/lib -TAU_MPI_NOWRAP_FLIB=-lfmpich.cnk -L/bgsys/drivers/ppcfloor/comm/lib -FULL_CXX=mpixlcxx_r -FULL_CC=mpixlc_r -TAU_PREFIX_INSTALL_DIR=/soft/apps/tau/tau_latest - -TAU_BIN_DIR=$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/bin -TAU_INC_DIR=$(TAU_PREFIX_INSTALL_DIR)/include -TAU_LIB_DIR=$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/lib - -####################################################################### - -#OPARI#TAU_OPARI_TOOL=$(TAU_BIN_DIR)/opari #ENDIF# -#ENABLE64BIT#ABI = -64 #ENDIF# -#ENABLEN32BIT#ABI = -n32 #ENDIF# -#ENABLE32BIT#ABI = -32 #ENDIF# - -####################################################################### -#SP1#IBM_XLC_ABI = -q32 #ENDIF# -#SP1#IBM_GNU_ABI = -maix32 #ENDIF# -#IBM64#IBM_XLC_ABI = -q64 #ENDIF# -#IBM64#IBM_GNU_ABI = -maix64 #ENDIF# -#IBM64LINUX#IBM_XLC_ABI = -q64 #ENDIF# -#IBM64LINUX#IBM_GNU_ABI = -m64 #ENDIF# -#SUNX86_64#SUN_GNU_ABI = -m64 #ENDIF# -#SUNX86_64#SUN_CC_ABI = -xarch=amd64 #ENDIF# -#MIPS32LINUX#SC_GNU_ABI = -mabi=n32 #ENDIF# -#MIPS32LINUX#SC_PATH_ABI = -n32 #ENDIF# -#MIPS64LINUX#SC_GNU_ABI = -mabi=64 #ENDIF# -#MIPS64LINUX#SC_PATH_ABI = -64 #ENDIF# -#GNU#SC_ABI = $(SC_GNU_ABI) #ENDIF# -#USE_PATHCC#SC_ABI = $(SC_PATH_ABI) #ENDIF# -#MIPS32#ABI = $(SC_ABI) #ENDIF# -#MIPS64#ABI = $(SC_ABI) #ENDIF# - -IBM_ABI = $(IBM_XLC_ABI) #ENDIF##USE_IBMXLC# -#GNU#IBM_ABI = $(IBM_GNU_ABI) #ENDIF# -#SP1# ABI = $(IBM_ABI) #ENDIF# -#PPC64# ABI = $(IBM_ABI) #ENDIF# -#SOLARIS64#SUN_GNU_ABI = -mcpu=v9 -m64 #ENDIF# -#SOLARIS64#SUN_CC_ABI = -xarch=v9 -xcode=pic32 #ENDIF# -#SOL2CC#SUN_ABI = $(SUN_CC_ABI) #ENDIF# -#GNU#SUN_ABI = $(SUN_GNU_ABI) #ENDIF# -#SOL2#ABI = $(SUN_ABI) #ENDIF# -#SUNX86_64#ABI = $(SUN_ABI) #ENDIF# -#FORCEIA32#ABI = -m32#ENDIF# -####################################################################### -F90_ABI = $(ABI) -#IBM64_FORTRAN#F90_ABI = -q64 #ENDIF# -####################################################################### - -############# Standard Defines ############## -TAU_CC = $(CONFIG_CC) $(ABI) $(ISA) -TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -TAU_RUN_CC = $(FULL_CC) $(ABI) $(ISA) -TAU_RUN_CXX = $(FULL_CXX) $(ABI) $(ISA) -TAU_INSTALL = /bin/cp -TAU_SHELL = /bin/sh -LSX = .a -############################################# -# JAVA DEFAULT ARCH -############################################# -JDKARCH = linux -#COMPAQ_ALPHA#JDKARCH = alpha #ENDIF# -#SOL2#JDKARCH = solaris #ENDIF# -#SGIMP#JDKARCH = irix #ENDIF# -#SP1#JDKARCH = aix #ENDIF# -#T3E#JDKARCH = cray #ENDIF# -############################################# -# JAVA OBJECTS -############################################# -#JAVA#TAU_JAVA_O = TauJava.o TauJAPI.o #ENDIF# -#JAVA#TAUJAPI = Profile.class #ENDIF# - - -############################################# -# OpenMP OBJECTS -############################################# -#OPENMP#OPENMP_O = OpenMPLayer.o #ENDIF# - -############################################# -# Opari OBJECTS -############################################# -#OPARI#OPARI_O = TauOpari.o #ENDIF# -#KOJAKOPARI#OPARI_O = TauKojakOpari.o #ENDIF# -#EPILOG#OPARI_O = #ENDIF# -#VAMPIRTRACE#OPARI_O = #ENDIF# -#GNU#OPARI_O = #ENDIF# - -############################################# -# CallPath OBJECTS -############################################# -#PROFILECALLPATH#CALLPATH_O = TauCallPath.o #ENDIF# -#PROFILEPARAM#PARAM_O = ProfileParam.o #ENDIF# - -############################################# -# Python Binding OBJECTS -############################################# -#PYTHON#PYTHON_O = PyGroups.o PyExceptions.o PyDatabase.o PyBindings.o PyTimer.o PyTau.o #ENDIF# - -############################################# -# DYNINST DEFAULT ARCH -############################################# -DYNINST_PLATFORM = $(PLATFORM) - - -#PCL##include $(TAU_INC_DIR)/makefiles/PCLMakefile.stub #ENDIF# - -############# OpenMP Fortran Option ######## -#OPENMP#TAU_F90_OPT = -mp #ENDIF# -#SOL2CC_OPENMP#TAU_F90_OPT = -xopenmp #ENDIF# -#SUNCC_OPENMP#TAU_F90_OPT = -xopenmp=parallel #ENDIF# -#COMPAQCXX_OPENMP#TAU_F90_OPT = -omp #ENDIF# -#IBMXLC_OPENMP#TAU_F90_OPT = -qsmp=omp #ENDIF# -#GUIDE#TAU_F90_OPT = #ENDIF# -#PGIOPENMP#TAU_F90_OPT = -mp #ENDIF# -#INTELOPENMP#TAU_F90_OPT = -openmp #ENDIF# -#HITACHI_OPENMP#TAU_F90_OPT = #ENDIF# - -TAU_R =_r #ENDIF##THREADSAFE_COMPILERS# - -############# Fortran Compiler ############# -#GNU_FORTRAN#TAU_F90 = g77 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#GNU_GFORTRAN#TAU_F90 = gfortran $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#G95_FORTRAN#TAU_F90 = g95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#SC_GFORTRAN#TAU_F90 = scgfortran $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#SGI_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -TAU_F90 = xlf77$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF##IBM_FORTRAN# -TAU_F90 = mpixlf77$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF##BGP# -#BGL#TAU_F90 = blrts_xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#IBM64_FORTRAN#TAU_F90 = xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#IBMXLFAPPLE#TAU_F90 = xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#CRAY_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#CRAY_X1_FORTRAN#TAU_F90 = ftn $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#PGI_FORTRAN#TAU_F90 = pgf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#CRAYCNL#TAU_F90 = ftn $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#PGI_CATAMOUNT#TAU_F90 = qk-pgf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#ABSOFT_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#LAHEY_FORTRAN#TAU_F90 = lf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#LAHEY64_FORTRAN#TAU_F90 = lf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#NAGWARE_FORTRAN#TAU_F90 = f95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#FUJITSU_FORTRAN#TAU_F90 = F90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#FUJITSU_SOLARIS#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#SUN_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#COMPAQ_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#KAI_FORTRAN#TAU_F90 = guidef90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#HP_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#HITACHI_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#INTEL_FORTRAN#TAU_F90 = efc $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#INTEL32_FORTRAN#TAU_F90 = ifc $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#INTELIFORT#TAU_F90 = ifort $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#PATHSCALE_FORTRAN#TAU_F90 = pathf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#SC_PATHSCALE#TAU_F90 = scpathf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#OPEN64ORC_FORTRAN#TAU_F90 = orf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# -#NEC_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# - - -############# Portable F90 Options ############# -#IBM64_FORTRAN#TAU_F90_FIXED = -qfixed #ENDIF# -TAU_F90_FIXED = -qfixed #ENDIF##IBM_FORTRAN# -TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF##IBM_FORTRAN# -#IBMXLFAPPLE#TAU_F90_FIXED = -qfixed #ENDIF# -#IBMXLFAPPLE#TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF# -#IBM64_FORTRAN#TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF# - -############# Profiling Options ############# -PROFILEOPT1 = -DPROFILING_ON #ENDIF##PROFILE# -#PCL#PROFILEOPT3 = -DTAU_PCL -I$(PCLDIR)/include #ENDIF# -#PAPI#PROFILEOPT3 = -DTAU_PAPI -I$(PAPIDIR)/src -I$(PAPIDIR)/include #ENDIF# -#PCL#PCL_O = PclLayer.o #ENDIF# -#PAPI#PAPI_O = PapiLayer.o #ENDIF# -#MULTIPLECOUNTERS#MULT_O = MultipleCounters.o #ENDIF# -#PROFILECALLS#PROFILEOPT4 = -DPROFILE_CALLS #ENDIF# -#PROFILESTATS#PROFILEOPT5 = -DPROFILE_STATS #ENDIF# -#DEBUGPROF#PROFILEOPT6 = -DDEBUG_PROF #ENDIF# -PROFILEOPT7 = -DTAU_STDCXXLIB #ENDIF##STDCXXLIB# -#CRAYX1CC#PROFILEOPT7 = #ENDIF# -#CRAYCC#PROFILEOPT7 = #ENDIF# -#INTELTFLOP#PROFILEOPT8 = -DPOOMA_TFLOP #ENDIF# -#NORTTI#PROFILEOPT9 = -DNO_RTTI #ENDIF# -#RTTI#PROFILEOPT9 = -DRTTI #ENDIF# -#GNU#PROFILEOPT10 = -DTAU_GNU -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# -#APPLECXX#PROFILEOPT10 = -DTAU_GNU -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# -#SOL2CC#PROFILEOPT10 = -DTAU_SOL2CC -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#SUNCC#PROFILEOPT10 = -DTAU_SOL2CC -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#USE_PATHCC#PROFILEOPT10 = -DTAU_DOT_H_LESS_HEADERS -fPIC -DTAU_PATHSCALE #ENDIF# -#OPEN64ORC#PROFILEOPT10 = -DTAU_DOT_H_LESS_HEADERS -DTAU_OPEN64ORC -fpic #ENDIF# -#CALLSTACK#PROFILEOPT11 = -DPROFILE_CALLSTACK #ENDIF# -#PGI1.7#PROFILEOPT12 = -DPGI #ENDIF# -#CRAYKAI#PROFILEOPT12 = -DCRAYKAI #ENDIF# -#HP_FORTRAN#PROFILEOPT12 = -DHP_FORTRAN #ENDIF# -#CRAYCC#PROFILEOPT13 = -h instantiate=used -DCRAYCC -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#CRAYX1CC#PROFILEOPT13 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#SGICC#TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -LANG:std #ENDIF# -#INTELCXXLIBICC#TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -cxxlib-icc #ENDIF# -#PTHREAD_AVAILABLE#PROFILEOPT15 = -DPTHREADS #ENDIF# -#COMPAQCXX_PTHREAD#PROFILEOPT15 = -DPTHREADS -pthread #ENDIF# -#TAU_SPROC#PROFILEOPT15 = -DTAU_SPROC #ENDIF# -#TAU_PAPI_THREADS#PROFILEOPT15 = -DTAU_PAPI_THREADS #ENDIF# -#TULIPTHREADS#PROFILEOPT16 = -DTULIPTHREADS #ENDIF# -#TRACE#TRACEOPT = -DTRACING_ON #ENDIF# -#TRACE#EVENTS_O = Tracer.o #ENDIF# -#KTAU#KTAU_O = TauKtau.o KtauProfiler.o KtauSymbols.o #ENDIF# -#KTAU_MERGE#KTAU_MERGE_O = KtauFuncInfo.o KtauMergeInfo.o ktau_syscall.o #ENDIF# -#KTAU_SHCTR#KTAU_SHCTR_O = KtauCounters.o #ENDIF# -#MPITRACE#TRACEOPT = -DTAU_MPITRACE -DTRACING_ON #ENDIF# -#MPITRACE#EVENTS_O = Tracer.o #ENDIF# -#MUSE#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF# -#MUSE_EVENT#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF# -#MUSE_MULTIPLE#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF# -#COMPENSATE#COMPENSATE_O = TauCompensate.o #ENDIF# -#PTHREAD_AVAILABLE#THR_O = PthreadLayer.o #ENDIF# -#TAU_PAPI_THREADS#THR_O = PapiThreadLayer.o #ENDIF# -#TAU_SPROC#THR_O = SprocLayer.o #ENDIF# -#JAVA#THR_O = JavaThreadLayer.o #ENDIF# -#TULIPTHREADS#THR_O = TulipThreadLayer.o #ENDIF# -#LINUXTIMERS#PLATFORM_O = TauLinuxTimers.o #ENDIF# -#TULIPTHREADS#PROFILEOPT17 = -I$(TULIPDIR)/include -I$(TULIPDIR)/Tuliplib #ENDIF# -#SMARTS#PROFILEOPT17 = -I$(TULIPDIR)/include -I$(TULIPDIR)/lib -I$(TULIPDIR)/machine-specific/$(HOSTTYPE) #ENDIF# -#SMARTS#PROFILEOPT18 = -DSMARTS #ENDIF# -#KAI#PROFILEOPT19 = -DKAI -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#USE_DECCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#SGICC#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#USE_INTELCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# -#USE_NECCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#PGI#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# -#ACC#PROFILEOPT19 = -AA +z -DTAU_DOT_H_LESS_HEADERS -DTAU_HPUX #ENDIF# -#FUJITSU#PROFILEOPT19 = -DFUJITSU -DTAU_DOT_H_LESS_HEADERS #ENDIF# -#KAINOEX#PROFILEOPT20 = --no_exceptions #ENDIF# -#SGICCNOEX#PROFILEOPT20 = -LANG:exceptions=off #ENDIF# -#HPGNU#PROFILEOPT21 = -fPIC #ENDIF# -#HITACHI#PROFILEOPT21 = -DTAU_HITACHI #ENDIF# -#SP1#PROFILEOPT21 = -D_POSIX_SOURCE -DTAU_AIX #ENDIF# -#PPC64#TAU_PIC_PROFILEOPT21 = -qpic=large #ENDIF# -#BGL#TAU_PIC_PROFILEOPT21 = #ENDIF# -PROFILEOPT21 = -DTAU_DOT_H_LESS_HEADERS -DTAU_XLC $(TAU_PIC_PROFILEOPT21) #ENDIF##USE_IBMXLC# -#IBMXLCAPPLE#PROFILEOPT21 = -DTAU_DOT_H_LESS_HEADERS -DTAU_XLC -DTAU_APPLE_XLC #ENDIF# -#PCLPTHREAD#PROFILEOPT22 = -DPCL_MUTEX_LOCK #ENDIF# -#JAVA#PROFILEOPT23 = -DJAVA #ENDIF# -#MONITOR#PROFILEOPT24 = -DMONITORING_ON #ENDIF# -#JAVA#PROFILEOPT25 = -I$(JDKDIR)/include -I$(JDKDIR)/include/$(JDKARCH) #ENDIF# -PROFILEOPT26 = -DTAU_MPI #ENDIF##MPI# -PROFILEOPT26 = -DTAU_MPI -DTAU_MPI_THREADED #ENDIF##MPI_THREADED# -#OPENMP#PROFILEOPT27 = -mp -DTAU_OPENMP#ENDIF# -#GNU#PROFILEOPT27 = #ENDIF# -#SOL2CC_OPENMP#PROFILEOPT27 = -xopenmp -DTAU_OPENMP#ENDIF# -#SUNCC_OPENMP#PROFILEOPT27 = -xopenmp=parallel -DTAU_OPENMP#ENDIF# -#SUNCC_OPENMP#PROFILEOPT27 = -xopenmp=parallel -DTAU_OPENMP#ENDIF# -#HITACHI_OPENMP#PROFILEOPT27 = -DTAU_OPENMP#ENDIF# -#COMPAQCXX_OPENMP#PROFILEOPT27 = -omp -DTAU_OPENMP#ENDIF# -#IBMXLC_OPENMP#PROFILEOPT27 = -qsmp=omp -DTAU_OPENMP #ENDIF# -#OPEN64_OPENMP#PROFILEOPT27 = -mp -DTAU_OPENMP #ENDIF# -#GUIDE#PROFILEOPT27 = -DTAU_OPENMP #ENDIF# -#PGIOPENMP#PROFILEOPT27 = -mp -D_OPENMP -DTAU_OPENMP -U_RWSTD_MULTI_THREAD -U_REENTRANT #ENDIF# -#INTELOPENMP#PROFILEOPT27 = -openmp -DTAU_OPENMP #ENDIF# -#GNUOPENMP#PROFILEOPT27 = -fopenmp -DTAU_OPENMP #ENDIF# -#OPARI#PROFILEOPT28 = -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF# -#OPARI_REGION#PROFILEOPT28 = -DTAU_OPARI_REGION -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF# -#OPARI_CONSTRUCT#PROFILEOPT28 = -DTAU_OPARI_CONSTRUCT -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF# -#MULTIPLECOUNTERS#PROFILEOPT29 = -DTAU_MULTIPLE_COUNTERS #ENDIF# -#SGITIMERS#PROFILEOPT30 = -DSGI_TIMERS #ENDIF# -#BGLTIMERS#PROFILEOPT30 = -DBGL_TIMERS -I/bgl/BlueLight/ppcfloor/bglsys/include #ENDIF# -#BGPTIMERS#PROFILEOPT30 = -DBGP_TIMERS -I/bgsys/drivers/ppcfloor/arch/include/common -I/bgsys/drivers/ppcfloor/arch/include -I/bgsys/drivers/ppcfloor/arch/include/spi #ENDIF# -#CRAYTIMERS#PROFILEOPT30 = -DCRAY_TIMERS #ENDIF# -#LINUXTIMERS#PROFILEOPT31 = -DTAU_LINUX_TIMERS #ENDIF# -#ALPHATIMERS#PROFILEOPT31 = -DTAU_ALPHA_TIMERS #ENDIF# -#CPUTIME#PROFILEOPT32 = -DCPU_TIME #ENDIF# -#PAPIWALLCLOCK#PROFILEOPT33 = -DTAU_PAPI_WALLCLOCKTIME #ENDIF# -#PAPIVIRTUAL#PROFILEOPT34 = -DTAU_PAPI_VIRTUAL #ENDIF# -#SGICOUNTERS#PROFILEOPT35 = -DSGI_HW_COUNTERS #ENDIF# -#EPILOG#PROFILEOPT36 = -DTAU_EPILOG -I$(EPILOGINCDIR) #ENDIF# -#SCALASCA#PROFILEOPT36 = -DTAU_SCALASCA -DTAU_EPILOG -I$(EPILOGINCDIR) #ENDIF# -#VAMPIRTRACEINTS#TAU_VAMPIRTRACEOPTS = -DTAU_64BITTYPES_NEEDED -DHAVE_INTTYPES_H #ENDIF# -#VAMPIRTRACE#PROFILEOPT36 = -DTAU_VAMPIRTRACE -I$(VAMPIRTRACEDIR)/vtlib -I$(VAMPIRTRACEDIR)/include $(TAU_VAMPIRTRACEOPTS)#ENDIF# -#PROFILECALLPATH#PROFILEOPT36 = -DTAU_CALLPATH #ENDIF# -#PROFILEPHASE#PROFILEOPT36 = -DTAU_CALLPATH -DTAU_PROFILEPHASE#ENDIF# -#PYTHON#PROFILEOPT37 = -I$(PYTHON_INCDIR) #ENDIF# -#NOCOMM#PROFILEOPT38 = -DTAU_NOCOMM #ENDIF# -#MUSE#PROFILEOPT39 = -DTAU_MUSE #ENDIF# -#SETNODE0#PROFILEOPT40 = -DTAU_SETNODE0 #ENDIF# -#COMPENSATE#PROFILEOPT41 = -DTAU_COMPENSATE #ENDIF# -#MUSE_EVENT#PROFILEOPT42 = -DTAU_MUSE_EVENT #ENDIF# -#MUSE_MULTIPLE#PROFILEOPT43 = -DTAU_MUSE_MULTIPLE #ENDIF# -#DYNINST41##PROFILEOPT44 = -DTAU_DYNINST41BUGFIX #ENDIF# -# DyninstAPI v4.2.1 fixes the bug, so we don't need OPT44 anymore -#PROFILEMEMORY#PROFILEOPT45 = -DTAU_PROFILEMEMORY #ENDIF# -PROFILEOPT46 = -DTAU_MPIGREQUEST #ENDIF##MPIGREQUEST# -#MPIOREQUEST#PROFILEOPT47 = -DTAU_MPIOREQUEST #ENDIF# -PROFILEOPT48 = -DTAU_MPIDATAREP #ENDIF##MPIDATAREP# -PROFILEOPT49 = -DTAU_MPIERRHANDLER #ENDIF##MPIERRHANDLER# -#CATAMOUNT#PROFILEOPT50 = -DTAU_CATAMOUNT #ENDIF# -#MPICONSTCHAR#PROFILEOPT51 = -DTAU_MPICONSTCHAR #ENDIF# -PROFILEOPT52 = -DTAU_MPIATTRFUNCTION #ENDIF##MPIATTR# -PROFILEOPT53 = -DTAU_MPITYPEEX #ENDIF##MPITYPEEX# -PROFILEOPT54 = -DTAU_MPIADDERROR #ENDIF##MPIADDERROR# -#MPINEEDSTATUSCONV#PROFILEOPT55 = -DTAU_MPI_NEEDS_STATUS #ENDIF# - -#DEPTHLIMIT#PROFILEOPT56 = -DTAU_DEPTH_LIMIT #ENDIF# -#TAU_CHARM#PROFILEOPT57 = -DTAU_CHARM -I$(CHARMDIR)/include #ENDIF# -#PROFILEHEADROOM#PROFILEOPT58 = -DTAU_PROFILEHEADROOM #ENDIF# -#JAVACPUTIME#PROFILEOPT59 = -DJAVA_CPU_TIME #ENDIF# -PROFILEOPT60 = -DTAU_LARGEFILE -D_LARGEFILE64_SOURCE #ENDIF##TAU_LARGEFILE# -PROFILEOPT60 = -DTAU_LARGEFILE -D_LARGEFILE64_SOURCE -D__xlc__ #ENDIF##BGP# -# Omit the -D_LARGETFILE64_SOURCE till we can check the IBM crash -#SHMEM#PROFILEOPT61 = -DTAU_SHMEM #ENDIF# -#KTAU#PROFILEOPT62 = -DTAUKTAU -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -I$(KTAU_INCUSERDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF# -#KTAU_MERGE#PROFILEOPT63 = -DTAUKTAU_MERGE -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF# -#FREEBSD#PROFILEOPT64 = -DTAU_FREEBSD #ENDIF# -#PROFILEPARAM#PROFILEOPT65 = -DTAU_PROFILEPARAM #ENDIF# -#IBMMPI#PROFILEOPT66 = -DTAU_IBM_MPI #ENDIF# -#WEAKMPIINIT#PROFILEOPT67 = -DTAU_WEAK_MPI_INIT #ENDIF# -#LAMPI#PROFILEOPT68 = -DTAU_LAMPI #ENDIF# -#MPICH_IGNORE_CXX_SEEK#PROFILEOPT68 = -DMPICH_IGNORE_CXX_SEEK #ENDIF# -PROFILEOPT68 = -DMPICH_IGNORE_CXX_SEEK #ENDIF##BGP# -#MPICH2_MPI_INPLACE#PROFILEOPT73 = -DTAU_MPICH2_MPI_IN_PLACE #ENDIF# - - -############# RENCI Scalable Trace Lib Options ############# -STFF_DIR= -SDDF_DIR= -#RENCI_STFF#PROFILEOPT69 = -DRENCI_STFF -I$(STFF_DIR)/include #ENDIF# -#RENCI_STFF#TAU_LINKER_OPT11 = -L$(STFF_DIR)/lib -lstff -L$(SDDF_DIR)/lib -lPablo $(TAU_MPI_LIB) #ENDIF# -#RENCI_STFF#RENCI_STFF_O = RenciSTFF.o #ENDIF# - -############# KTAU (again) ############# -#KTAU_SHCTR#PROFILEOPT70 = -DTAUKTAU_SHCTR -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF# -#KTAU#TAU_LINKER_OPT12 = -L$(KTAU_LIB) -lktau #ENDIF# - -#MIPS32LINUX#PROFILEOPT71 = -D_ABIN32=2 -D_MIPS_SIM=_ABIN32 #ENDIF# - -#BGL#PROFILEOPT72 = -DTAU_BGL -I/bgl/BlueLight/ppcfloor/bglsys/include #ENDIF# -PROFILEOPT72 = -DTAU_BGP -I/bgsys/drivers/ppcfloor/arch/include/common -I/bgsys/drivers/ppcfloor/arch/include -I/bgsys/drivers/ppcfloor/arch/include/spi #ENDIF##BGP# - -#For F90 support for all platforms -FWRAPPER = TauFMpi.o -MPI2EXTENSIONS = TauMpiExtensions.o #ENDIF##MPI2# -MPI2EXTENSIONS = #ENDIF##BGP# -#CRAYX1CC#MPI2EXTENSIONS = #ENDIF# - -#SGICOUNTERS#LEXTRA = -lperfex #ENDIF# -#ALPHATIMERS#LEXTRA = -lrt #ENDIF# -#SOL2#PCL_EXTRA_LIBS = -lcpc #ENDIF# -#PCL#LEXTRA = -L$(PCLDIR)/lib -lpcl $(PCL_EXTRA_LIBS) #ENDIF# -#PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# -#IA64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi #ENDIF# -#Due to some problems with older versions of libpfm, we are using the static lib -#IA64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# -#PAPIPFM##LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpfm -lpapi -lpfm #ENDIF# -#X86_64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR)/ -L$(PAPIDIR)/lib64/ -lpapi -lperfctr #ENDIF# -#SOL2PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -lcpc #ENDIF# -#IBMPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/usr/lpp/pmtoolkit/lib -L/usr/pmapi/lib -lpmapi#ENDIF# -#PPC64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# -#BGLPAPI_RTS#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.rts.a -L/bgl/BlueLight/ppcfloor/bglsys/lib -lbgl_perfctr.rts -lrts.rts -ldevices.rts #ENDIF# -#BGLPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/bgl/BlueLight/ppcfloor/bglsys/lib -lbgl_perfctr.rts -lrts.rts -ldevices.rts #ENDIF# -#BGPPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/bgsys/drivers/ppcfloor/runtime/SPI -lSPI.cna #ENDIF# -#IBM64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi64.a -L/usr/lpp/pmtoolkit/lib -L/usr/pmapi/lib -lpmapi #ENDIF# -#IBM64PAPILINUX#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# -#SGI64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi64 #ENDIF# -#ALPHAPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a /usr/lib/dcpi/dadd.a -lclu -lrt #ENDIF# - -TAU_PAPI_EXTRA_FLAGS = $(LEXTRA) -#IA64PAPI#TAU_PAPI_EXTRA_FLAGS = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi #ENDIF# - - -# By default make TAU_PAPI_RPATH null. Support it on a compiler by compiler basis. -#PAPI###TAU_PAPI_RPATH = -rpath $(PAPIDIR)/$(PAPISUBDIR) #ENDIF# -#PAPI##TAU_PAPI_RPATH = #ENDIF# -#PPC64PAPI#TAU_PAPI_RPATH = #ENDIF# -#BGLPAPI#TAU_PAPI_RPATH = #ENDIF# -#BGPPAPI#TAU_PAPI_RPATH = #ENDIF# -#USE_INTELCXX#TAU_PAPI_RPATH = #ENDIF# -#CRAYX1CC#TAU_PAPI_RPATH = #ENDIF# -#PGI#TAU_PAPI_RPATH = -R$(PAPIDIR)/$(PAPISUBDIR) #ENDIF# -#GNU#TAU_PAPI_RPATH = -Wl,-rpath $(PAPIDIR)/$(PAPISUBDIR) #ENDIF# -#USE_PATHCC#TAU_PAPI_RPATH = #ENDIF# - -# if the user has specified -cc=gcc -c++=g++ -fortran=intel, we shouldn't use -rpath -# because they are likely going to link with ifort -#INTEL32_FORTRAN#TAU_PAPI_RPATH = #ENDIF# -#SOL2PAPI#TAU_PAPI_RPATH = #ENDIF# -#IBMPAPI#TAU_PAPI_RPATH = #ENDIF# -#IBM64PAPI#TAU_PAPI_RPATH = #ENDIF# -#PAPI#TAU_LINKER_OPT1 = $(TAU_PAPI_RPATH) #ENDIF# - -#PTHREAD_AVAILABLE#LEXTRA1 = -lpthread #ENDIF# -#TULIPTHREADS#LEXTRA1 = -L$(TULIPDIR)/Tuliplib -ltulip #ENDIF# -#SMARTS##include $(TAU_INC_DIR)/makefiles/GNUmakefile-$(HOSTTYPE) #ENDIF# -#SMARTS#LEXTRA1 = $(LSMARTS) #ENDIF# - -TAU_GCCLIB = -lgcc_s -TAU_GCCLIB = #ENDIF##BGP# -#INTEL32_ON_64#TAU_GCCLIB = -lgcc #ENDIF# -#FREEBSD#TAU_GCCLIB = -lgcc #ENDIF# -#BGL#TAU_GCCLIB = -lgcc #ENDIF# -#GNU#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF# -#OPEN64ORC_FORTRAN#TAU_FORTRANLIBS = -lfortran -lffio #ENDIF# -#PATHSCALE_FORTRAN#TAU_FORTRANLIBS = -lpathfstart -lpathfortran #ENDIF# -#SC_PATHSCALE#TAU_FORTRANLIBS = -lpathfstart -lpathfortran #ENDIF# -#NAGWARE_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/quickfit.o -L$(EXTRADIR)/lib -lf96 #ENDIF# -#G95_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR) -lf95 #ENDIF# -#GNU_FORTRAN#TAU_FORTRANLIBS = -lg2c #ENDIF# -#GNU_GFORTRAN#TAU_FORTRANLIBS = -L$(TAUGFORTRANLIBDIR) -lgfortran -lgfortranbegin #ENDIF# -#SC_GFORTRAN#TAU_FORTRANLIBS = -lgfortran -lgfortranbegin #ENDIF# -#SGI_FORTRAN#TAU_FORTRANLIBS = -lfortran -lftn #ENDIF# -TAU_IBM_FORTRANLIBS = -bh:4 -bpT:0x10000000 -bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF##USE_IBMXLC# -#GNU#TAU_IBM_FORTRANLIBS = -Wl,-bh:4 -Wl,-bpT:0x10000000 -Wl,-bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF# -#KAI#TAU_IBM_FORTRANLIBS = --backend -bh:4 --backend -bpT:0x10000000 --backend -bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF# -TAU_FORTRANLIBS = $(TAU_IBM_FORTRANLIBS) #ENDIF##IBM_FORTRAN# - -TAU_IBM64_FORTRANLIBS = -bh:4 -bpT:0x10000000 -bpD:0x20000000 -b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF##USE_IBMXLC# -#GNU#TAU_IBM64_FORTRANLIBS = -Wl,-bh:4 -Wl,-bpT:0x10000000 -Wl,-bpD:0x20000000 -Wl,-b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF# -#KAI#TAU_IBM64_FORTRANLIBS = --backend -bh:4 --backend -bpT:0x10000000 --backend -bpD:0x20000000 --backend -b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF# -#IBM64_FORTRAN#TAU_FORTRANLIBS = $(TAU_IBM64_FORTRANLIBS) #ENDIF# -#IBM64_FORTRAN#TAU_FORLIBDIR=lib64 #ENDIF# -TAU_FORLIBDIR=lib #ENDIF##IBM_FORTRAN# -#BGL#TAU_FORLIBDIR=blrts_dev_lib #ENDIF# -TAU_FORLIBDIR=bglib #ENDIF##BGP# -#PPC64#TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -lxlf90 -lxlfmath -lxl #ENDIF# -#BGL#TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -L$(EXTRADIR)/blrts_lib -lxlf90 -lxlfmath -lxl #ENDIF# - -TAU_BGL_OMP_SERIAL= -lxlomp_ser #ENDIF##BGP# -#OPENMP#TAU_BGL_OMP_SERIAL= #ENDIF# -TAU_OMP_SERIAL=$(TAU_BGL_OMP_SERIAL) #ENDIF##BGP# -TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -lxlf90 -lxlfmath $(TAU_OMP_SERIAL) #ENDIF##BGP# - -#IBMXLFAPPLE#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib -lxlf90 -lxlfmath -lxl #ENDIF# - -#CRAY_FORTRAN#TAU_FORTRANLIBS = #ENDIF# -#CRAY_X1_FORTRAN#TAU_FORTRANLIBS = #ENDIF# -#PGI_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/f90main.o -lpgf90 -lpgf90rtl -lpgf90_rpm1 -lpgf902 -lpgftnrtl -lrt #ENDIF# -#HP_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib/pa2.0 -lF90 -lcl #ENDIF# -#INTEL_FORTRAN#TAU_FORTRANLIBS = -lcprts -lPEPCF90 #ENDIF# -#INTEL32_FORTRAN#TAU_FORTRANLIBS = -lcprts -lCEPCF90 -lF90 #ENDIF# -#INTELIFORT#TAU_FORTRANLIBS = -lcprts #ENDIF# -#INTEL81FIX#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -lcxa -lunwind -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF# -#INTEL10FIX#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF# -#INTELCXXLIBICC#TAU_FORTRANLIBS = -lcprts -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF# -#PGI1.7#LEXTRA = -lstd -lstrm#ENDIF# -#PGI1.7#TAUHELPER = $(TAUROOT)/src/Profile/TauPGIHelper.cpp #ENDIF# -# LINKER OPTIONS -TAU_LINKER_OPT2 = $(LEXTRA) - - -#ACC#TAUHELPER = -AA #ENDIF# -#FUJITSU_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj9i6 -lfj9f6 -lfj9e6 #ENDIF# -#FUJITSU_SOLARIS#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj90l -lfj90f #ENDIF# -#SUN_FORTRAN#TAU_FORTRANLIBS = -lfui -lfsumai -lfprodai -lfminlai -lfmaxlai -lfminvai -lfmaxvai -lfsu -lsunmath #ENDIF# -#SUN_FORTRAN#TAU_FORTRANLIBS_SUN_OPTERON = -lfsu -lsunmath #ENDIF# -#SUN_FORTRAN#TAU_FORTRANLIBS_SUNCC = -lfsu #ENDIF# -#SUN386I#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUN_OPTERON) #ENDIF# -#SUNX86_64#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUN_OPTERON) #ENDIF# -#SUNCC#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUNCC) #ENDIF# -#SOL2#EXTRALIBS = -lsocket -lnsl #ENDIF# -#SUN386I#EXTRALIBS = -lsocket -lnsl -lrt #ENDIF# -#SUNX86_64#EXTRALIBS = -lsocket -lnsl -lrt #ENDIF# -#COMPAQ_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/cmplrs/fort90/for_main.o -L$(EXTRADIR)/lib -L$(EXTRADIR)/lib/cmplrs/fort90 -L$(EXTRADIR)/lib/cmplrs/fort90 -lUfor -lfor -lFutil -lm -lmld -lexc -lc #ENDIF# -#ABSOFT_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib -lfio -lf90math -lU77 -lf77math -lfio #ENDIF# -#LAHEY_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj9i6 -lfj9f6 -lfj9e6 -lfccx86_6a #ENDIF# -#LAHEY64_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib64/fj90rt0.o -L$(EXTRADIR)/lib64 -lfj90f -lfj90i -lelf #ENDIF# -#HITACHI_FORTRAN#TAU_FORTRANLIBS = -lf90 -lhf90math #ENDIF# -#NEC_FORTRAN#TAU_FORTRANLIBS = -f90lib #ENDIF# -#COMPAQ_GUIDEF90#TAU_FORTRANLIBS = $(EXTRADIR)/lib/cmplrs/fort90/for_main.o -lfor #ENDIF# - - -#HITACHI#TAU_HITACHI_EXTRA = -L/usr/local/lib -llrz32 #ENDIF# - -## To use the standard F90 linker instead of TAU_LINKER + TAU_FORTRANLIBS, add -#GNU#TAU_CXXLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF# -#GNU#TAU_GNUCXXLIBS = -L$(TAUGCCLIBDIR) -lstdc++ $(TAU_GCCLIB) #ENDIF# -#OPEN64ORC#TAU_CXXLIBS = -lstdc++ #ENDIF# -#PATHSCALE_FORTRAN#TAU_CXXLIBS = -lstdc++ #ENDIF# -#LAHEY_FORTRAN#TAU_CXXLIBS = $(TAU_GNUCXXLIBS) /usr/lib/libc.a #ENDIF# -#NAGWARE_FORTRAN#TAU_CXXLIBS = $(TAU_GNUCXXLIBS) /usr/lib/libc.a #ENDIF# -#PGI#TAU_CXXLIBS = -lstd -lC #ENDIF# -#CRAYCNL#TAU_CXXLIBS = -L$(EXTRADIR)/lib -lstd -lC -lpgc #ENDIF# -#CRAYX1CC#TAU_CXXLIBS = -L/opt/ctl/CC/CC/lib -lC #ENDIF# - -TAU_SGI_INIT = /usr/lib32/c++init.o -#ENABLE64BIT#TAU_SGI_INIT = /usr/lib64/c++init.o #ENDIF# -#ENABLEN32BIT#TAU_SGI_INIT = /usr/lib32/c++init.o #ENDIF# -#ENABLE32BIT#TAU_SGI_INIT = /usr/lib/c++init.o #ENDIF# - -#SGICC#TAU_CXXLIBS = $(TAU_SGI_INIT) -lC #ENDIF# -#APPLECXX#TAU_CXXLIBS = -lstd -lC #ENDIF# -#SOL2#TAU_CXXLIBS = -lCstd -lCrun #ENDIF# -#SOL2CC#TAU_CXXLIBS_SUN_OPTERON = -lCstd -lCrun -lm #ENDIF# -#SUNCC#TAU_CXXLIBS_SUNCC = -lCstd -lCrun #ENDIF# -#SUN386I#TAU_CXXLIBS = $(TAU_CXXLIBS_SUN_OPTERON) #ENDIF# -#SUNCC#TAU_CXXLIBS = $(TAU_CXXLIBS_SUNCC) #ENDIF# -#SUNX86_64#TAU_CXXLIBS = $(TAU_CXXLIBS_SUN_OPTERON) #ENDIF# -#FUJITSU_SOLARIS#TAU_CXXLIBS = -lstd -lstdm #ENDIF# -#PPC64#TAU_XLCLIBS = -L$(EXTRADIRCXX)/$(TAU_FORLIBDIR) -libmc++ -lstdc++ #ENDIF# -#IBMXLCAPPLE#TAU_FORLIBDIR =lib #ENDIF# -#IBMXLCAPPLE#TAU_XLCLIBS = -L$(EXTRADIRCXX)/$(TAU_FORLIBDIR) -libmc++ -lstdc++ #ENDIF# -#BGL#TAU_XLCLIBS = -L$(EXTRADIRCXX)/blrts_dev_lib -L$(EXTRADIRCXX)/blrts_lib -libmc++ -L/bgl/BlueLight/ppcfloor/blrts-gnu/powerpc-bgl-blrts-gnu/lib -lstdc++ #ENDIF# -TAU_XLCLIBS = -L$(EXTRADIRCXX)/bglib -libmc++ -lstdc++ #ENDIF##BGP# -#SP1#TAU_XLCLIBS = -lC #ENDIF# -TAU_CXXLIBS = $(TAU_XLCLIBS) #ENDIF##USE_IBMXLC# -#USE_DECCXX#TAU_CXXLIBS = -lcxxstd -lcxx #ENDIF# -#USE_INTELCXX#TAU_CXXLIBS_INTEL = -lcprts -lPEPCF90 #ENDIF# -#USE_INTELCXX#TAU_CXXLIBS_INTEL = -lcprts #ENDIF# -#INTELIFORT#TAU_CXXLIBS_INTEL = -lcprts #ENDIF# -#INTEL81FIX#TAU_CXXLIBS_INTEL = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -lcxa -lunwind#ENDIF# -#INTEL10FIX#TAU_CXXLIBS_INTEL = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF# -#INTELCXXLIBICC#TAU_CXXLIBS_INTEL = -lcprts #ENDIF# -#USE_INTELCXX#TAU_CXXLIBS = $(TAU_CXXLIBS_INTEL) #ENDIF# -#APPLECXX#TAU_CXXLIBS = -lstdc++ -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lgcc_s.1 -lSystemStubs #ENDIF# - -# EXTERNAL PACKAGES: VAMPIRTRACE -#VAMPIRTRACE#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# -#VAMPIRTRACEMPI#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.mpi -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# -#VAMPIRTRACEOMPI#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.ompi -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# -#VAMPIRTRACEOMP#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.omp -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# - -# EXTERNAL PACKAGES: EPILOG -#SCALASCA#TAU_ELG_SERIAL_SUFFIX =.ser #ENDIF# -#EPILOG#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg$(TAU_ELG_SERIAL_SUFFIX) $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# -#EPILOGMPI#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.mpi $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# -#EPILOGOMPI#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.ompi $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# -#EPILOGOMP#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.omp $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# - -# When using shared, we don't want -lelg.mpi or -lvt.mpi showing up -#FORCESHARED#TAU_LINKER_OPT3=#ENDIF# - -TAU_LINKER_OPT4 = $(LEXTRA1) -#HITACHI_OPENMP#TAU_LINKER_OPT4 = -lcompas -lpthreads -lc_r #ENDIF# -#OPENMP#TAU_LINKER_OPT5 = -mp #ENDIF# -#SOL2CC_OPENMP#TAU_LINKER_OPT5 = -xopenmp #ENDIF# -#SUNCC_OPENMP#TAU_LINKER_OPT5 = -xopenmp=parallel #ENDIF# -#GNU#TAU_LINKER_OPT5 = #ENDIF# -#COMPAQCXX_OPENMP#TAU_LINKER_OPT5 = -omp #ENDIF# -#IBMXLC_OPENMP#TAU_LINKER_OPT5 = -qsmp=omp #ENDIF# -#OPEN64_OPENMP#TAU_LINKER_OPT5 = -mp #ENDIF# -#GUIDE#TAU_LINKER_OPT5 = #ENDIF# -#PGIOPENMP#TAU_LINKER_OPT5 = -mp #ENDIF# -#INTELOPENMP#TAU_LINKER_OPT5 = -openmp #ENDIF# - -# MALLINFO needs -lmalloc on sgi, sun -#SGIMP#TAU_LINKER_OPT6 = -lmalloc #ENDIF# -#SOL2#TAU_LINKER_OPT6 = #ENDIF# -#SUN386I#TAU_LINKER_OPT6 = -lmalloc #ENDIF# -#SUNX86_64#TAU_LINKER_OPT6 = -lmalloc #ENDIF# - -# We need -lCio with SGI CC 7.4+ -#SGICC#TAU_LINKER_OPT7 = -lCio #ENDIF# - -# charm -#TAU_CHARM#TAU_LINKER_OPT8 = -lconv-core #ENDIF# - -# extra libs -#SUN386I#TAU_LINKER_OPT9 = $(EXTRALIBS) #ENDIF# -#SUNX86_64#TAU_LINKER_OPT9 = $(EXTRALIBS) #ENDIF# -#SOL2#TAU_LINKER_OPT9 = $(ExTRALIBS) #ENDIF# - -#BGL#TAU_LINKER_OPT10 = -L/bgl/BlueLight/ppcfloor/bglsys/lib -lrts.rts #ENDIF# - -TAU_IBM_PYTHON_SHFLAG = -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp -Wl,-einitpytau#ENDIF##USE_IBMXLC# -#GNU#TAU_IBM_PYTHON_SHFLAG = -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp -Wl,-einitpytau#ENDIF# -#KAI#TAU_IBM_PYTHON_SHFLAG = --backend -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp --backend -Wl,-einitpytau#ENDIF# -#ACC#TAU_HPUX_PYTHON_SHFLAG = -lstd_v2 -lCsup_v2 -lm -lcl -lc #ENDIF# - -TAU_IBM_LD_FLAGS = -binitfini:poe_remote_main #ENDIF##USE_IBMXLC# -#GNU#TAU_IBM_LD_FLAGS = -Wl,-binitfini:poe_remote_main #ENDIF# -#KAI#TAU_IBM_LD_FLAGS = --backend -binitfini:poe_remote_main #ENDIF# - - -#PYTHON#TAU_IBM_SHFLAGS = $(TAU_IBM_PYTHON_SHFLAG) #ENDIF# -#PYTHON#TAU_HPUX_SHFLAGS = $(TAU_HPUX_PYTHON_SHFLAG) #ENDIF# -#SP1#TAU_EXTRA_LIBRARY_FLAGS = $(TAU_IBM_SHFLAGS) #ENDIF# -#SOL2#TAU_EXTRA_LIBRARY_FLAGS = #ENDIF# -#SGIMP#TAU_EXTRA_LIBRARY_FLAGS = -lmalloc #ENDIF# -#HP#TAU_EXTRA_LIBRARY_FLAGS = $(TAU_HPUX_SHFLAGS) #ENDIF# - -TAU_MPI_WRAPPER_LIB= -L$(TAU_LIB_DIR) -lTauMpi$(TAU_CONFIG) #ENDIF##MPI# -#EPILOGMPI#TAU_MPI_WRAPPER_LIB= #ENDIF# -#EPILOGOMPI#TAU_MPI_WRAPPER_LIB= #ENDIF# - -############################################## -# Build TAU_LINKER_SHOPTS -#GNU#TAU_IBM_LINKER_SHOPTS=-Wl,-brtl -Wl,-bexpall #ENDIF# -TAU_IBM_LINKER_SHOPTS= -brtl -bexpall #ENDIF##USE_IBMXLC# -#KAI#TAU_IBM_LINKER_SHOPTS= --backend -brtl #ENDIF# -#SP1#TAU_LINKER_SHOPTS= $(TAU_IBM_LINKER_SHOPTS) #ENDIF# - -############################################## -# MPI _r suffix check (as in libmpi_r) -#MPI_R_SUFFIX#TAU_MPI_R_SUFFIX=_r #ENDIF# - -############################################## -# Flags to build a shared object: TAU_SHFLAGS -#GNU#AR_SHFLAGS = -shared #ENDIF# -#PGI#AR_SHFLAGS = -shared #ENDIF# -#SGICC#AR_SHFLAGS = -shared #ENDIF# -#APPLECXX#AR_SHFLAGS = -dynamiclib -flat_namespace -undefined suppress #ENDIF# -#SOL2#AR_SHFLAGS = -G #ENDIF# -#SUN386I#AR_SHFLAGS = -G #ENDIF# -#SUNX86_64#AR_SHFLAGS = -G #ENDIF# -AR_SHFLAGS = -G #ENDIF##USE_IBMXLC# -#USE_DECCXX#AR_SHFLAGS = -shared #ENDIF# -#USE_INTELCXX#AR_SHFLAGS = -shared #ENDIF# -#ACC#AR_SHFLAGS = -b #ENDIF# -TAU_SHFLAGS = $(AR_SHFLAGS) -o - -############# RANLIB Options ############# -TAU_RANLIB = echo "Built" -#APPLECXX#TAU_RANLIB = ranlib #ENDIF# -#IBMXLCAPPLE#TAU_RANLIB = ranlib #ENDIF# - -############################################## -TAU_AR = ar #ENDIF# -#SP1#TAU_AR = ar -X32 #ENDIF# -#IBM64#TAU_AR = ar -X64 #ENDIF# -#PPC64#TAU_AR = ar #ENDIF# -#IBM64LINUX#TAU_AR = ar #ENDIF# - - -############################################## -# PDT OPTIONS -# You can specify -pdtcompdir=intel -pdtarchdir=x86_64 -# If nothing is specified, PDTARCHDIR uses TAU_ARCH -PDTARCHDIRORIG=$(TAU_ARCH) -PDTARCHITECTURE=x86_64 -PDTARCHDIRFINAL=$(PDTARCHDIRORIG) -#PDTARCHITECTURE#PDTARCHDIRFINAL=$(PDTARCHITECTURE)#ENDIF# -PDTARCHDIR=$(PDTARCHDIRFINAL) -#PDTARCH#PDTARCHDIR=$(PDTARCHDIRFINAL)/$(PDTCOMPDIR)#ENDIF# - - -############################################## - -PROFILEOPTS = $(PROFILEOPT1) $(PROFILEOPT2) $(PROFILEOPT3) $(PROFILEOPT4) \ - $(PROFILEOPT5) $(PROFILEOPT6) $(PROFILEOPT7) $(PROFILEOPT8) \ - $(PROFILEOPT9) $(PROFILEOPT10) $(PROFILEOPT11) $(PROFILEOPT12) \ - $(PROFILEOPT13) $(PROFILEOPT14) $(PROFILEOPT15) $(PROFILEOPT16) \ - $(PROFILEOPT17) $(PROFILEOPT18) $(PROFILEOPT19) $(PROFILEOPT20) \ - $(PROFILEOPT21) $(PROFILEOPT22) $(PROFILEOPT23) $(PROFILEOPT24) \ - $(PROFILEOPT25) $(PROFILEOPT26) $(PROFILEOPT27) $(PROFILEOPT28) \ - $(PROFILEOPT29) $(PROFILEOPT30) $(PROFILEOPT31) $(PROFILEOPT32) \ - $(PROFILEOPT33) $(PROFILEOPT34) $(PROFILEOPT35) $(PROFILEOPT36) \ - $(PROFILEOPT37) $(PROFILEOPT38) $(PROFILEOPT39) $(PROFILEOPT40) \ - $(PROFILEOPT41) $(PROFILEOPT42) $(PROFILEOPT43) $(PROFILEOPT44) \ - $(PROFILEOPT45) $(PROFILEOPT46) $(PROFILEOPT47) $(PROFILEOPT48) \ - $(PROFILEOPT49) $(PROFILEOPT50) $(PROFILEOPT51) $(PROFILEOPT52) \ - $(PROFILEOPT53) $(PROFILEOPT54) $(PROFILEOPT55) $(PROFILEOPT56) \ - $(PROFILEOPT57) $(PROFILEOPT58) $(PROFILEOPT59) $(PROFILEOPT60) \ - $(PROFILEOPT61) $(PROFILEOPT62) $(PROFILEOPT63) $(PROFILEOPT64) \ - $(PROFILEOPT65) $(PROFILEOPT66) $(PROFILEOPT67) $(PROFILEOPT68) \ - $(PROFILEOPT69) $(PROFILEOPT70) $(PROFILEOPT71) $(PROFILEOPT72) \ - $(PROFILEOPT73) $(PROFILEOPT74) $(PROFILEOPT75) $(PROFILEOPT76) \ - $(TRACEOPT) - -############################################## - -TAU_LINKER_OPTS = $(TAU_LINKER_OPT1) $(TAU_LINKER_OPT2) $(TAU_LINKER_OPT3) \ - $(TAU_LINKER_OPT4) $(TAU_LINKER_OPT5) $(TAU_LINKER_OPT6) \ - $(TAU_LINKER_OPT7) $(TAU_LINKER_OPT8) $(TAU_LINKER_OPT9) \ - $(TAU_LINKER_OPT10) $(TAU_LINKER_OPT11) $(TAU_LINKER_OPT12) - -############################################## - -############# TAU Fortran #################### -TAU_LINKER=$(TAU_CXX) -#INTEL_FORTRAN##TAU_LINKER=$(TAU_F90) #ENDIF# -#INTEL32_FORTRAN##TAU_LINKER=$(TAU_F90) #ENDIF# -# Intel efc compiler acts as a linker - NO. Let C++ be the linker. - -############################################## -############# TAU Options #################### -TAUDEFS = $(PROFILEOPTS) - -TAUINC = -I$(TAU_INC_DIR) - -TAULIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -ltau$(TAU_CONFIG) $(TAU_LINKER_OPTS) - -TAUMPILIBS = $(TAU_MPI_LIB) - -TAUMPIFLIBS = $(TAU_MPI_FLIB) - -### ACL S/W requirement -TAU_DEFS = $(TAUDEFS) - -TAU_INCLUDE = -I$(TAU_INC_DIR) -#PERFLIB#TAU_INCLUDE = -I$(PERFINCDIR) #ENDIF# -#PERFLIB#TAU_DEFS = #ENDIF# -#PERFLIB#TAU_COMPILER_EXTRA_OPTIONS=-optTau=-p #ENDIF# - -TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/Memory -#IBMXLCAPPLE#TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/MemoryWrapper #ENDIF# -#APPLECXX#TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/MemoryWrapper #ENDIF# - -TAU_LIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -ltau$(TAU_CONFIG) $(TAU_LINKER_OPTS) -#PERFLIB#TAU_LIBS = #ENDIF# - -TAU_SHLIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAUsh$(TAU_CONFIG) $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) $(TAU_MPI_LIB) -#PERFLIB#TAU_SHLIBS = #ENDIF# -TAU_EXLIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAU $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) $(TAU_MPI_LIB) - -TAU_SHLIBS_NOSHOPTS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAUsh$(TAU_CONFIG) $(TAU_LINKER_OPTS) - -TAU_DISABLE = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTauDisable - -TAU_MPI_INCLUDE = $(TAU_MPI_INC) - -TAU_MPI_LIBS = $(TAU_MPI_LIB) - -TAU_MPI_FLIBS = $(TAU_MPI_FLIB) - -## TAU TRACE INPUT LIBRARY (can build a trace converter using TAU TIL) -TAU_TRACE_INPUT_LIB = -L$(TAU_LIB_DIR) -lTAU_traceinput$(TAU_CONFIG) - -## Don't include -lpthread or -lsmarts. Let app. do that. -############################################# -## IBM SPECIFIC CHANGES TO TAU_MPI_LIBS -#SP1#TAU_MPI_LDFLAGS = $(TAU_IBM_LD_FLAGS) #ENDIF# -TAU_LDFLAGS = $(TAU_MPI_LDFLAGS) #ENDIF##MPI# -#SP1#TAU_IBM_MPI_LIBS = $(TAU_MPI_LIB) -L$(TAU_MPILIB_DIR)/ip -lvtd$(TAU_MPI_R_SUFFIX) #ENDIF# -#SP1#TAU_IBM_FMPI_LIBS = $(TAU_MPI_FLIB) -L$(TAU_MPILIB_DIR)/ip -lvtd$(TAU_MPI_R_SUFFIX) #ENDIF# -#SP1#TAU_MPI_LIBS_FLAGS= $(TAU_IBM_MPI_LIBS) #ENDIF# -#SP1#TAU_MPI_FLIBS_FLAGS = $(TAU_IBM_MPI_FLIBS) #ENDIF# -TAU_MPI_LIBS_FLAGS = $(TAU_MPI_LIB) #ENDIF##MPI# -TAU_MPI_FLIBS_FLAGS = $(TAU_MPI_FLIB) #ENDIF##MPI# -TAU_MPI_LIBS = $(TAU_MPI_LIBS_FLAGS) #ENDIF##MPI# -TAU_MPI_FLIBS = $(TAU_MPI_FLIBS_FLAGS) #ENDIF##MPI# - -#SP1#TAUMPILIBS = $(TAU_MPI_LIBS) #ENDIF# -#SP1#TAUMPIFLIBS = $(TAU_MPI_FLIBS) #ENDIF# -############################################# -#SHMEM#TAU_SHMEM_OBJS = TauShmemCray.o #ENDIF# -#SP1#TAU_SHMEM_OBJS = TauShmemTurbo.o #ENDIF# -#GPSHMEM#TAU_SHMEM_OBJS = TauShmemGpshmem.o #ENDIF# - -TAU_SHMEM_INCLUDE = $(TAU_SHMEM_INC) - -TAU_SHMEM_LIBS = -L$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/ -lTauShmem$(TAU_CONFIG) $(TAU_SHMEM_LIB) -############################################# -# TAU COMPILER SHELL SCRIPT OPTIONS -TAUCOMPILEROPTS= -optPdtDir="$(PDTDIR)/${PDTARCHDIR}"\ - -optPdtCOpts="$(TAU_INCLUDE) $(TAU_DEFS) $(TAU_MPI_INCLUDE)"\ - -optPdtCxxOpts="$(TAU_INCLUDE) $(TAU_DEFS) $(TAU_MPI_INCLUDE)"\ - -optTauInstr="$(TAU_BIN_DIR)/tau_instrumentor" \ - -optNoMpi \ - -optOpariDir="$(OPARIDIR)" -optOpariTool="$(TAU_OPARI_TOOL)" \ - -optTauCC="$(TAU_CC)" \ - -optTauIncludes="$(TAU_INCLUDE) $(TAU_MPI_INCLUDE)" \ - -optTauDefs="$(TAU_DEFS)" \ - -optTauCompile="$(TAU_INCLUDE) $(TAU_MPI_INCLUDE) $(TAU_DEFS) "\ - -optLinking="$(TAU_MPI_FLIBS) $(TAU_LIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS)"\ - -optSharedLinking="$(TAU_MPI_FLIBS) $(TAU_EXLIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS)"\ - $(TAU_COMPILER_EXTRA_OPTIONS) \ - -optIncludeMemory="$(TAU_INCLUDE_MEMORY)" -############################################# - -TAU_SHAREDLIBS=$(TAUHELPER) -L$(TAU_LIB_DIR) -lTAU $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) -SHAREDEXTRAS= -#FORCESHARED#SHAREDEXTRAS=-optSharedLinkReset="$(TAU_SHAREDLIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS) $(TAU_MPI_NOWRAP_FLIB)" -optShared #ENDIF# -TAU_COMPILER=$(TAU_BIN_DIR)/tau_compiler.sh $(TAUCOMPILEROPTS) $(SHAREDEXTRAS) -############################################# -# These options could be included in the application Makefile as -#CFLAGS = $(TAUDEFS) $(TAUINC) -# -#LIBS = $(TAULIBS) -# -# To run the application without Profiling/Tracing use -#CFLAGS = $(TAUINC) -# Don't use TAUDEFS but do include TAUINC -# Also ignore TAULIBS when Profiling/Tracing is not used. -############################################# - diff --git a/source/unres/src_MD_DFA/Makefile_MPICH_ifort b/source/unres/src_MD_DFA/Makefile_MPICH_ifort deleted file mode 100644 index 4505541..0000000 --- a/source/unres/src_MD_DFA/Makefile_MPICH_ifort +++ /dev/null @@ -1,124 +0,0 @@ -################################################################### -INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh - - -FC= ifort - -OPT = -g -ip -w -CB - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - - -LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf/libxdrf.a - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - MP.o compare_s1.o prng.o \ - banach.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o test.o - -GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -GAB: BIN = ../../../bin/unres/MD/unres_ifort_MPICH_GAB.exe -GAB: ${object} xdrf/libxdrf.a - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - -E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -E0LL2Y: BIN = ../../../bin/unres/MD/unres_ifort_MPICH_E0LL2Y.exe -E0LL2Y: ${object} xdrf/libxdrf.a - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - -xdrf/libxdrf.a: - cd xdrf && make - - -clean: - /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new_barrier.o : energy_p_new_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F - -gradient_p.o : gradient_p.F - ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F - -energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -MD_A-MTS.o : MD_A-MTS.F - ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS2} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD_DFA/Makefile_aix_xlf b/source/unres/src_MD_DFA/Makefile_aix_xlf deleted file mode 100644 index b226425..0000000 --- a/source/unres/src_MD_DFA/Makefile_aix_xlf +++ /dev/null @@ -1,113 +0,0 @@ -CPPFLAGS = -WF,-DUNRES -WF,-DMP -WF,-DMPI -WF,-DSPLITELE -WF,-DISNAN -WF,-DAIX -#-DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -INSTALL_DIR = -# -FC= mpxlf90 -qfixed -w - -OPT = -q64 - -FFLAGS = -c ${OPT} -O3 -FFLAGS1 = -c ${OPT} -O2 -FFLAGS2 = -c ${OPT} -O -FFLAGSE = -c ${OPT} -O4 - - -BIN = ${HOME}/UNRES/bin/unres_MD.exe -LIBS = -qipa - -ARCH = LINUX -PP = /lib/cpp -P - -all: unresCSA - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - - -unresCSA: ${objectCSA} - cc -o compinfo compinfo.c - ./compinfo - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${objectCSA} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - /bin/rm *.il - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F diff --git a/source/unres/src_MD_DFA/Makefile_bigben b/source/unres/src_MD_DFA/Makefile_bigben deleted file mode 100644 index 261dd8e..0000000 --- a/source/unres/src_MD_DFA/Makefile_bigben +++ /dev/null @@ -1,138 +0,0 @@ -# -FC= ftn -OPT = -fast \ --Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ --Mprefetch=distance:8,nta - -#OPT = -C -g -#OPT1 = -g -fast -OPT1 = ${OPT} -OPT2 = -fast -OPT2 = ${OPT} -OPTE = ${OPT} - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include -FFLAGSE = ${FFLAGS} - -CFLAGS = -DSGI -c - -BIN = ../bin/unres_MD_Tc_procor-newmat-novec-noparint_barrier_corr-split.exe -LIBS = xdrf/libxdrf.a - -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \ - -DSPLITELE -DPROCOR -DAMD64 -DLANG0 \ -#-DTIMING \ -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -#-DPARVEC #-DPARINT -DPARINTDER - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} proc_proc.o - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -energy_p_new-sep.o : energy_p_new-sep.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS1} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD_DFA/Makefile_bigben-oldparm b/source/unres/src_MD_DFA/Makefile_bigben-oldparm deleted file mode 100644 index 87d66c7..0000000 --- a/source/unres/src_MD_DFA/Makefile_bigben-oldparm +++ /dev/null @@ -1,136 +0,0 @@ -# -FC= ftn -OPT = -fast \ --Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ --Mprefetch=distance:8,nta - -#OPT = -C -g -#OPT1 = -g -fast -OPT1 = -fast -OPT2 = -fast -OPT2 = ${OPT} -OPTE = ${OPT} - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include -FFLAGSE = ${FFLAGS} - -CFLAGS = -DSGI -c - -BIN = ../bin/unres_MD_Tc_procor-newmat-matgather-oldparm.exe -LIBS = xdrf/libxdrf.a - -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \ - -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -DPARVEC -DPARINT -DPARINTDER \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new.o \ - energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} proc_proc.o - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -energy_p_new-sep.o : energy_p_new-sep.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS1} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD_DFA/Makefile_bigben-tau b/source/unres/src_MD_DFA/Makefile_bigben-tau deleted file mode 100644 index ee02905..0000000 --- a/source/unres/src_MD_DFA/Makefile_bigben-tau +++ /dev/null @@ -1,137 +0,0 @@ -# -#FC= ftn -TAU_MAKEFILE=/usr/local/packages/TAU-2.17/tau-2.17/xt3/lib/Makefile.tau-mpi-pdt-pgi -FC=tau_f90.sh -OPT = -fast \ --Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ --Mprefetch=distance:8,nta - -#OPT = -C -g -#OPT1 = -g -fast -OPT1 = -fast -OPT2 = -fast -OPT2 = ${OPT} -OPTE = ${OPT} - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include -FFLAGSE = ${FFLAGS} - -CFLAGS = -DSGI -c - -BIN = ../bin/unres_MD_Tc_procor-newmat-noparint-barrier-tau.exe -LIBS = xdrf/libxdrf.a - -CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \ - -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -DPARVEC - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} proc_proc.o - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o *.pp.[fF] *.pp.inst.[fF] - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -energy_p_new-sep.o : energy_p_new-sep.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS1} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD_DFA/Makefile_galera b/source/unres/src_MD_DFA/Makefile_galera deleted file mode 100644 index 899ec63..0000000 --- a/source/unres/src_MD_DFA/Makefile_galera +++ /dev/null @@ -1,147 +0,0 @@ -CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DMP -DMPI -DPGI -DISNAN \ - -DSPLITELE -DAMD64 -DLANG0 -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -#-DCRYST_TOR -# -DPROCOR -# -DTSCSC -#-DTIMING \ -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -# -DMOMENT -#-DPARVEC -#-DPARINT -DPARINTDER - -#INSTALL_DIR = /users/local/mpi64/mpich-1.2.7p1/ -#INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh -#INSTALL_DIR = /users/software/mpich2.x86_64/ -#INSTALL_DIR = /opt/mpi/mvapich2 -INSTALL_DIR = /opt/mpi/mvapich - -FC= ifort -FCL= ${INSTALL_DIR}/bin/mpif77 - -OPT = -O3 -ip -w -xHost - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -xHost -O3 -ipo -ipo_obj -no-prec-div -opt_report -I$(INSTALL_DIR)/include - - -BIN = ../bin/unres_Tc_procor_new_em64_hremd_mpich1.exe -LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf_em64/libxdrf.a -lpthread - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FCL} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o *.il - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new_barrier.o : energy_p_new_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F - -gradient_p.o : gradient_p.F - ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F - -energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -MD_A-MTS.o : MD_A-MTS.F - ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS2} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD_DFA/Makefile_intrepid b/source/unres/src_MD_DFA/Makefile_intrepid deleted file mode 100644 index 2b57f9e..0000000 --- a/source/unres/src_MD_DFA/Makefile_intrepid +++ /dev/null @@ -1,151 +0,0 @@ -# -FC=/bgsys/drivers/ppcfloor/comm/bin/mpixlf77 -OPT = -O4 -qarch=450 -qtune=450 -#OPT = -O3 -qarch=450 -qtune=450 -qdebug=function_trace -#OPT = -O -qarch=450 -qtune=450 -#OPT = -O0 -C -g -qarch=450 -qtune=450 #-qdebug=function_trace -#-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ -#-Mprefetch=distance:8,nta - -#OPT1 = -O -g -qarch=450 -qtune=450 -#OPT1 = -O -g -qarch=450 -qtune=450 -qdebug=function_trace -OPT1 = ${OPT} -#OPT2 = -O2 -qarch=450 -qtune=450 -#OPT2 = -O2 -qarch=450 -qtune=450 -qdebug=function_trace -OPT2 = ${OPT} -#OPTE = -O4 -qarch=450 -qtune=450 -#OPTE = -O4 -qarch=450 -qtune=450 -OPTE=${OPT} - -CFLAGS = -c -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include -FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include -FFLAGSE = -c ${OPTE} -I$(INSTALL_DIR)/include - -BIN = ../bin/unres_MD_Tc_procor-newparm-O4-parcorr.exe -#BIN = ../bin/unres_MD_Tc_procor-newparm-O4-PARINT-parcorr.exe -#BIN = ../bin/unres_MD_Tc_procor-newparm-parvecmatint-O4-notau1.exe -#BIN = ../bin/unres_MD_Tc_procor-newparm-O4-notau1.exe -#LIBS = xdrf/libxdrf.a /home/liwo/UNRES/LIB/libmemmon.a -LIBS = xdrf/libxdrf.a - -CPPFLAGS = -WF,-DAIX -WF,-DISNAN -WF,-DUNRES -WF,-DMP -WF,-DMPI -WF,-DPGI \ - -WF,-DSPLITELE -WF,-DPROCOR -WF,-DAMD64 -WF,-DLANG0 -#-WF,-DPARINT -WF,-DPARINTDER -#-WF,-DPARVEC -WF,-DPARMAT -WF,-DMATGATHER - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -obj: ${object} - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - ${CC} -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.f - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -eigen.o : eigen.f - ${FC} ${FFLAGS1} ${CPPFLAGS} eigen.f - -blas.o : blas.f - ${FC} ${FFLAGS1} ${CPPFLAGS} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} ${CPPFLAGS} add.f - -energy_p_new.o : energy_p_new.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F - -energy_p_new-sep.o : energy_p_new-sep.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c - -compinfo: compinfo.c - ${CC} ${CFLAGS} compinfo.c diff --git a/source/unres/src_MD_DFA/Makefile_lnx_ifc10_opteron b/source/unres/src_MD_DFA/Makefile_lnx_ifc10_opteron deleted file mode 100644 index 13c3249..0000000 --- a/source/unres/src_MD_DFA/Makefile_lnx_ifc10_opteron +++ /dev/null @@ -1,143 +0,0 @@ -CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DMP -DMPI -DPGI -DISNAN \ - -DSPLITELE -DAMD64 -DLANG0 -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -#-DCRYST_TOR -# -DPROCOR -# -DTSCSC -#-DTIMING \ -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -# -DMOMENT -#-DPARVEC -#-DPARINT -DPARINTDER - -INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh - - -FC= ifort - -OPT = -O3 -ip -w - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - - -BIN = ../bin/unres_Tc_procor_new_em64_nh_hremd_92110.exe -LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf_em64/libxdrf.a -lpthread - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o *.il - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new_barrier.o : energy_p_new_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F - -gradient_p.o : gradient_p.F - ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F - -energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -MD_A-MTS.o : MD_A-MTS.F - ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS2} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD_DFA/Makefile_lnx_ifc10_opteron_oldparm b/source/unres/src_MD_DFA/Makefile_lnx_ifc10_opteron_oldparm deleted file mode 100644 index d155fa2..0000000 --- a/source/unres/src_MD_DFA/Makefile_lnx_ifc10_opteron_oldparm +++ /dev/null @@ -1,143 +0,0 @@ -CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DMP -DMPI -DPGI -DISNAN \ - -DSPLITELE -DAMD64 -DLANG0 \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -#-DCRYST_TOR -# -DPROCOR -# -DTSCSC -#-DTIMING \ -# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -# -DMOMENT -#-DPARVEC -#-DPARINT -DPARINTDER - -INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh - - -FC= ifort - -OPT = -O3 -ip -w - -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - - -BIN = ../bin/unres_Tc_procor_old_em64_nh_hremd_92110.exe -LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf_em64/libxdrf.a -lpthread - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ - indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o - -unres: ${object} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o *.il - -newconf.o: newconf.f - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new_barrier.o : energy_p_new_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F - -gradient_p.o : gradient_p.F - ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F - -energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -MD_A-MTS.o : MD_A-MTS.F - ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS2} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD_DFA/Makefile_single_gfortran b/source/unres/src_MD_DFA/Makefile_single_gfortran deleted file mode 100644 index 8e393f8..0000000 --- a/source/unres/src_MD_DFA/Makefile_single_gfortran +++ /dev/null @@ -1,130 +0,0 @@ -FC= gfortran -FFLAGS = -c ${OPT} -I. -FFLAGS1 = -c ${OPT1} -I. - -CC = cc - -CFLAGS = -DLINUX -DPGI -c - -OPT = -O -#OPT1 = -fbounds-check -g -O - -#OPT = -fbounds-check -g -OPT1 = -g - -# -Mvect <---slows down -# -Minline=name:matmat2 <---false convergence - -LIBS = -Lxdrf -lxdrf -#-DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -ARCH = LINUX -PP = /lib/cpp -P - -all: - @echo "Specify force field: GAB or E0LL2Y" - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - MP.o compare_s1.o prng_32.o \ - banach.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o test.o - -GAB: CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DISNAN \ - -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -GAB: BIN = ../../../bin/unres/MD/unres_gfortran_single_GAB.exe -GAB: ${object} xdrf/libxdrf.a - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - -E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DISNAN \ - -DSPLITELE -DLANG0 -E0LL2Y: BIN = ../../../bin/unres/MD/unres_gfortran_single_E0LL2Y.exe -E0LL2Y: ${object} xdrf/libxdrf.a - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - -xdrf/libxdrf.a: - cd xdrf && make - -clean: - /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean - -newconf.o: newconf.F - ${FC} ${FFLAGS} ${CPPFLAGS} newconf.F - -bank.o: bank.F - ${FC} ${FFLAGS} ${CPPFLAGS} bank.F - -diff12.o: diff12.f - ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f - -csa.o: csa.f - ${FC} ${FFLAGS1} ${CPPFLAGS} csa.f - -shift.o: shift.F - ${FC} ${FFLAGS1} ${CPPFLAGS} shift.F - -ran.o: ran.f - ${FC} ${FFLAGS1} ${CPPFLAGS} ran.f - -together.o: together.F - ${FC} ${FFLAGS} ${CPPFLAGS} together.F - -fitsq.o: fitsq.f - ${FC} ${FFLAGS1} ${CPPFLAGS} fitsq.f - -rmsd.o: rmsd.F - ${FC} ${FFLAGS1} ${CPPFLAGS} rmsd.F - -contact.o: contact.f - ${FC} ${FFLAGS1} ${CPPFLAGS} contact.f - -minim_jlee.o: minim_jlee.F - ${FC} ${FFLAGS1} ${CPPFLAGS} minim_jlee.F - -minimize_p.o: minimize_p.F - ${FC} ${FFLAGS1} ${CPPFLAGS} minimize_p.F - -gen_rand_conf.o: gen_rand_conf.F - ${FC} ${FFLAGS} ${CPPFLAGS} gen_rand_conf.F - - -test.o: test.F - ${FC} ${FFLAGS1} ${CPPFLAGS} test.F - -elecont.o: elecont.f - ${FC} ${FFLAGS} ${CPPFLAGS} elecont.f - -eigen.o: eigen.f - ${FC} ${FFLAGS1} eigen.f - -blas.o: blas.f - ${FC} ${FFLAGS1} blas.f - -add.o: add.f - ${FC} ${FFLAGS1} add.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD_DFA/Makefile_single_ifort b/source/unres/src_MD_DFA/Makefile_single_ifort deleted file mode 100644 index 245206b..0000000 --- a/source/unres/src_MD_DFA/Makefile_single_ifort +++ /dev/null @@ -1,127 +0,0 @@ -FC = ifort -FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include -FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include -FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include - -CC = cc - -CFLAGS = -DLINUX -DPGI -c - -OPT = -O3 -ip -w - -# -Mvect <---slows down -# -Minline=name:matmat2 <---false convergence - -LIBS = -Lxdrf -lxdrf -#-DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -ARCH = LINUX -PP = /lib/cpp -P - -all: - @echo "Specify force field: GAB or E0LL2Y" - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ - mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ - eigen.o blas.o add.o entmcm.o minim_mcmf.o \ - MP.o compare_s1.o prng.o \ - banach.o rmsd.o elecont.o dihed_cons.o \ - sc_move.o local_move.o \ - intcartderiv.o lagrangian_lesyng.o\ - stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ - surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ - q_measure.o gnmr1.o test.o - -GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN \ - -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -GAB: BIN = ../../../bin/unres/MD/unres_ifort_single_GAB.exe -GAB: ${object} xdrf/libxdrf.a - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - -E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN \ - -DSPLITELE -DLANG0 -E0LL2Y: BIN = ../../../bin/unres/MD/unres_ifort_single_E0LL2Y.exe -E0LL2Y: ${object} xdrf/libxdrf.a - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - -xdrf/libxdrf.a: - cd xdrf && make - -clean: - /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean - -test.o: test.F - ${FC} ${FFLAGS} ${CPPFLAGS} test.F - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new_barrier.o : energy_p_new_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F - -gradient_p.o : gradient_p.F - ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F - -energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F - -lagrangian_lesyng.o : lagrangian_lesyng.F - ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F - -MD_A-MTS.o : MD_A-MTS.F - ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F - -blas.o : blas.f - ${FC} ${FFLAGS1} blas.f - -add.o : add.f - ${FC} ${FFLAGS1} add.f - -eigen.o : eigen.f - ${FC} ${FFLAGS2} eigen.f - -proc_proc.o: proc_proc.c - ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD_DFA/README b/source/unres/src_MD_DFA/README deleted file mode 100644 index 2b1d2be..0000000 --- a/source/unres/src_MD_DFA/README +++ /dev/null @@ -1,2 +0,0 @@ -The program will fail if there is no "Makefile" file. -You must copy (cp MakeXXXX Makefile) or use a symbolic link (ln -s MakeXXXX Makefile) before compiling. diff --git a/source/unres/src_MD_DFA/add.f b/source/unres/src_MD_DFA/add.f deleted file mode 100644 index fd91a70..0000000 --- a/source/unres/src_MD_DFA/add.f +++ /dev/null @@ -1,28 +0,0 @@ - SUBROUTINE ABRT - STOP 'IN ABRT' - END -C*MODULE MTHLIB *DECK VCLR - SUBROUTINE VCLR(A,INCA,N) -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) -C - DIMENSION A(*) -C - PARAMETER (ZERO=0.0D+00) -C -C ----- ZERO OUT VECTOR -A-, USING INCREMENT -INCA- ----- -C - IF (INCA .NE. 1) GO TO 200 - DO 110 L=1,N - A(L) = ZERO - 110 CONTINUE - RETURN -C - 200 CONTINUE - LA=1-INCA - DO 210 L=1,N - LA=LA+INCA - A(LA) = ZERO - 210 CONTINUE - RETURN - END diff --git a/source/unres/src_MD_DFA/arcos.f b/source/unres/src_MD_DFA/arcos.f deleted file mode 100644 index 69810ea..0000000 --- a/source/unres/src_MD_DFA/arcos.f +++ /dev/null @@ -1,9 +0,0 @@ - FUNCTION ARCOS(X) - implicit real*8 (a-h,o-z) - include 'COMMON.GEO' - IF (DABS(X).LT.1.0D0) GOTO 1 - ARCOS=0.5D0*(PI+DSIGN(1.0D0,X)*PI) - RETURN - 1 ARCOS=DACOS(X) - RETURN - END diff --git a/source/unres/src_MD_DFA/banach.f b/source/unres/src_MD_DFA/banach.f deleted file mode 100644 index 7c43d77..0000000 --- a/source/unres/src_MD_DFA/banach.f +++ /dev/null @@ -1,99 +0,0 @@ -C -C********************** - SUBROUTINE BANACH(N,NMAX,A,X,osob) -C********************** -C Banachiewicz - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A(NMAX,NMAX),X(NMAX),D(MAXRES6) - COMMON /BANII/ D - logical osob - osob=.false. - if (dabs(a(1,1)).lt.1.0d-15) then - osob=.true. - return - endif - D(1)=1./A(1,1) - DO 80 I=2,N - A(I,1)=A(1,I) - DO 81 J=2,I-1 - XX=A(J,I) - DO 82 K=1,J-1 - XX=XX-A(I,K)*A(J,K) - 82 CONTINUE - A(I,J)=XX - 81 CONTINUE - XX=A(I,I) - JJJJ=I-1 - DO 83 J=1,JJJJ - AIJ=A(I,J) - AIJD=AIJ*D(J) - A(I,J)=AIJD - XX=XX-AIJ*AIJD - 83 CONTINUE - if (dabs(xx).lt.1.0d-15) then - osob=.true. - return - endif - D(I)=1./XX - 80 CONTINUE -C - CALL BANAII(N,NMAX,A,X) - RETURN - END -C************************ - SUBROUTINE BANAII(N,NMAX,A,X) -C************************ - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A(NMAX,NMAX),X(NMAX),D(MAXRES6) - COMMON /BANII/ D - DO 90 I=1,N - Z=X(I) - JJJJ=I-1 - DO 91 J=JJJJ,1,-1 - Z=Z-A(I,J)*X(J) - 91 CONTINUE - X(I)=Z - 90 CONTINUE - DO 92 I=N,1,-1 - Z=X(I)*D(I) - JJJJ=I+1 - DO 93 J=JJJJ,N - Z=Z-A(J,I)*X(J) - 93 CONTINUE - X(I)=Z - 92 CONTINUE - RETURN - END -C - SUBROUTINE MATINVERT(N,NMAX,A,A1,osob) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A(NMAX,NMAX),A1(NMAX,NMAX),D(MAXRES6) - COMMON /BANII/ D - DIMENSION X(NMAX) - logical osob - DO I=1,N - X(I)=0.0 - ENDDO - X(1)=1.0 - CALL BANACH(N,NMAX,A,X,osob) - if (osob) return - DO I=1,N - A1(I,1)=X(I) - ENDDO - DO I=2,N - DO J=1,N - X(J)=0.0 - ENDDO - X(I)=1.0 - CALL BANAII(N,NMAX,A,X) - DO J=1,N - A1(J,I)=X(J) - ENDDO - ENDDO - RETURN - END - - diff --git a/source/unres/src_MD_DFA/blas.f b/source/unres/src_MD_DFA/blas.f deleted file mode 100644 index 142d821..0000000 --- a/source/unres/src_MD_DFA/blas.f +++ /dev/null @@ -1,575 +0,0 @@ -C 10 NOV 94 - MWS - DNRM2: REMOVE FTNCHECK WARNINGS -C 11 JUN 94 - MWS - INCLUDE A COPY OF DGEMV (LEVEL TWO ROUTINE) -C 11 AUG 87 - MWS - SANITIZE FLOATING POINT CONSTANTS IN DNRM2 -C 26 MAR 87 - MWS - USE GENERIC SIGN IN DROTG -C 28 NOV 86 - STE - SUPPLY ALL LEVEL ONE BLAS -C 7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS -C -C BASIC LINEAR ALGEBRA SUBPROGRAMS (BLAS) FROM LINPACK (LEVEL 1) -C -C THIS MODULE SHOULD BE COMPILED ONLY IF SPECIALLY CODED -C VERSIONS OF THESE ROUTINES ARE NOT AVAILABLE ON THE TARGET MACHINE -C -C*MODULE BLAS1 *DECK DASUM - DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) -C -C TAKES THE SUM OF THE ABSOLUTE VALUES. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DX(1),DTEMP - INTEGER I,INCX,M,MP1,N,NINCX -C - DASUM = 0.0D+00 - DTEMP = 0.0D+00 - IF(N.LE.0)RETURN - IF(INCX.EQ.1)GO TO 20 -C -C CODE FOR INCREMENT NOT EQUAL TO 1 -C - NINCX = N*INCX - DO 10 I = 1,NINCX,INCX - DTEMP = DTEMP + ABS(DX(I)) - 10 CONTINUE - DASUM = DTEMP - RETURN -C -C CODE FOR INCREMENT EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,6) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP = DTEMP + ABS(DX(I)) - 30 CONTINUE - IF( N .LT. 6 ) GO TO 60 - 40 MP1 = M + 1 - DO 50 I = MP1,N,6 - DTEMP = DTEMP + ABS(DX(I)) + ABS(DX(I + 1)) + ABS(DX(I + 2)) - * + ABS(DX(I + 3)) + ABS(DX(I + 4)) + ABS(DX(I + 5)) - 50 CONTINUE - 60 DASUM = DTEMP - RETURN - END -C*MODULE BLAS1 *DECK DAXPY - SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(1),DY(1) -C -C CONSTANT TIMES A VECTOR PLUS A VECTOR. -C DY(I) = DY(I) + DA * DX(I) -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - IF(N.LE.0)RETURN - IF (DA .EQ. 0.0D+00) RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DY(IY) = DY(IY) + DA*DX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,4) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DY(I) = DY(I) + DA*DX(I) - 30 CONTINUE - IF( N .LT. 4 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,4 - DY(I) = DY(I) + DA*DX(I) - DY(I + 1) = DY(I + 1) + DA*DX(I + 1) - DY(I + 2) = DY(I + 2) + DA*DX(I + 2) - DY(I + 3) = DY(I + 3) + DA*DX(I + 3) - 50 CONTINUE - RETURN - END -C*MODULE BLAS1 *DECK DCOPY - SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(*),DY(*) -C -C COPIES A VECTOR. -C DY(I) <== DX(I) -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DY(IY) = DX(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,7) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DY(I) = DX(I) - 30 CONTINUE - IF( N .LT. 7 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,7 - DY(I) = DX(I) - DY(I + 1) = DX(I + 1) - DY(I + 2) = DX(I + 2) - DY(I + 3) = DX(I + 3) - DY(I + 4) = DX(I + 4) - DY(I + 5) = DX(I + 5) - DY(I + 6) = DX(I + 6) - 50 CONTINUE - RETURN - END -C*MODULE BLAS1 *DECK DDOT - DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(1),DY(1) -C -C FORMS THE DOT PRODUCT OF TWO VECTORS. -C DOT = DX(I) * DY(I) -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DDOT = 0.0D+00 - DTEMP = 0.0D+00 - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS -C NOT EQUAL TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP = DTEMP + DX(IX)*DY(IY) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - DDOT = DTEMP - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP = DTEMP + DX(I)*DY(I) - 30 CONTINUE - IF( N .LT. 5 ) GO TO 60 - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + - * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) - 50 CONTINUE - 60 DDOT = DTEMP - RETURN - END -C*MODULE BLAS1 *DECK DNRM2 - DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) - INTEGER NEXT - DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE - DATA ZERO, ONE /0.0D+00, 1.0D+00/ -C -C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE -C INCREMENT INCX . -C IF N .LE. 0 RETURN WITH RESULT = 0. -C IF N .GE. 1 THEN INCX MUST BE .GE. 1 -C -C C.L.LAWSON, 1978 JAN 08 -C -C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE -C HOPEFULLY APPLICABLE TO ALL MACHINES. -C CUTLO = MAXIMUM OF SQRT(U/EPS) OVER ALL KNOWN MACHINES. -C CUTHI = MINIMUM OF SQRT(V) OVER ALL KNOWN MACHINES. -C WHERE -C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. -C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) -C V = LARGEST NO. (OVERFLOW LIMIT) -C -C BRIEF OUTLINE OF ALGORITHM.. -C -C PHASE 1 SCANS ZERO COMPONENTS. -C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO -C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO -C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M -C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. -C -C VALUES FOR CUTLO AND CUTHI.. -C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER -C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. -C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE -C UNIVAC AND DEC AT 2**(-103) -C THUS CUTLO = 2**(-51) = 4.44089E-16 -C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. -C THUS CUTHI = 2**(63.5) = 1.30438E19 -C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. -C THUS CUTLO = 2**(-33.5) = 8.23181D-11 -C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D+19 -C DATA CUTLO, CUTHI / 8.232D-11, 1.304D+19 / -C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / - DATA CUTLO, CUTHI / 8.232D-11, 1.304D+19 / -C - J=0 - IF(N .GT. 0) GO TO 10 - DNRM2 = ZERO - GO TO 300 -C - 10 ASSIGN 30 TO NEXT - SUM = ZERO - NN = N * INCX -C BEGIN MAIN LOOP - I = 1 - 20 GO TO NEXT,(30, 50, 70, 110) - 30 IF( ABS(DX(I)) .GT. CUTLO) GO TO 85 - ASSIGN 50 TO NEXT - XMAX = ZERO -C -C PHASE 1. SUM IS ZERO -C - 50 IF( DX(I) .EQ. ZERO) GO TO 200 - IF( ABS(DX(I)) .GT. CUTLO) GO TO 85 -C -C PREPARE FOR PHASE 2. - ASSIGN 70 TO NEXT - GO TO 105 -C -C PREPARE FOR PHASE 4. -C - 100 I = J - ASSIGN 110 TO NEXT - SUM = (SUM / DX(I)) / DX(I) - 105 XMAX = ABS(DX(I)) - GO TO 115 -C -C PHASE 2. SUM IS SMALL. -C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. -C - 70 IF( ABS(DX(I)) .GT. CUTLO ) GO TO 75 -C -C COMMON CODE FOR PHASES 2 AND 4. -C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. -C - 110 IF( ABS(DX(I)) .LE. XMAX ) GO TO 115 - SUM = ONE + SUM * (XMAX / DX(I))**2 - XMAX = ABS(DX(I)) - GO TO 200 -C - 115 SUM = SUM + (DX(I)/XMAX)**2 - GO TO 200 -C -C -C PREPARE FOR PHASE 3. -C - 75 SUM = (SUM * XMAX) * XMAX -C -C -C FOR REAL OR D.P. SET HITEST = CUTHI/N -C FOR COMPLEX SET HITEST = CUTHI/(2*N) -C - 85 HITEST = CUTHI/N -C -C PHASE 3. SUM IS MID-RANGE. NO SCALING. -C - DO 95 J =I,NN,INCX - IF(ABS(DX(J)) .GE. HITEST) GO TO 100 - 95 SUM = SUM + DX(J)**2 - DNRM2 = SQRT( SUM ) - GO TO 300 -C - 200 CONTINUE - I = I + INCX - IF ( I .LE. NN ) GO TO 20 -C -C END OF MAIN LOOP. -C -C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. -C - DNRM2 = XMAX * SQRT(SUM) - 300 CONTINUE - RETURN - END -C*MODULE BLAS1 *DECK DROT - SUBROUTINE DROT (N,DX,INCX,DY,INCY,C,S) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(1),DY(1) -C -C APPLIES A PLANE ROTATION. -C DX(I) = C*DX(I) + S*DY(I) -C DY(I) = -S*DX(I) + C*DY(I) -C JACK DONGARRA, LINPACK, 3/11/78. -C - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL -C TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP = C*DX(IX) + S*DY(IY) - DY(IY) = C*DY(IY) - S*DX(IX) - DX(IX) = DTEMP - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C - 20 DO 30 I = 1,N - DTEMP = C*DX(I) + S*DY(I) - DY(I) = C*DY(I) - S*DX(I) - DX(I) = DTEMP - 30 CONTINUE - RETURN - END -C*MODULE BLAS1 *DECK DROTG - SUBROUTINE DROTG(DA,DB,C,S) -C -C CONSTRUCT GIVENS PLANE ROTATION. -C JACK DONGARRA, LINPACK, 3/11/78. -C - DOUBLE PRECISION DA,DB,C,S,ROE,SCALE,R,Z - DOUBLE PRECISION ZERO, ONE -C - PARAMETER (ZERO=0.0D+00, ONE=1.0D+00) -C -C----------------------------------------------------------------------- -C -C - ROE = DB - IF( ABS(DA) .GT. ABS(DB) ) ROE = DA - SCALE = ABS(DA) + ABS(DB) - IF( SCALE .NE. ZERO ) GO TO 10 - C = ONE - S = ZERO - R = ZERO - GO TO 20 -C - 10 R = SCALE*SQRT((DA/SCALE)**2 + (DB/SCALE)**2) - R = SIGN(ONE,ROE)*R - C = DA/R - S = DB/R - 20 Z = ONE - IF( ABS(DA) .GT. ABS(DB) ) Z = S - IF( ABS(DB) .GE. ABS(DA) .AND. C .NE. ZERO ) Z = ONE/C - DA = R - DB = Z - RETURN - END -C*MODULE BLAS1 *DECK DSCAL - SUBROUTINE DSCAL(N,DA,DX,INCX) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(1) -C -C SCALES A VECTOR BY A CONSTANT. -C DX(I) = DA * DX(I) -C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - IF(N.LE.0)RETURN - IF(INCX.EQ.1)GO TO 20 -C -C CODE FOR INCREMENT NOT EQUAL TO 1 -C - NINCX = N*INCX - DO 10 I = 1,NINCX,INCX - DX(I) = DA*DX(I) - 10 CONTINUE - RETURN -C -C CODE FOR INCREMENT EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,5) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DX(I) = DA*DX(I) - 30 CONTINUE - IF( N .LT. 5 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,5 - DX(I) = DA*DX(I) - DX(I + 1) = DA*DX(I + 1) - DX(I + 2) = DA*DX(I + 2) - DX(I + 3) = DA*DX(I + 3) - DX(I + 4) = DA*DX(I + 4) - 50 CONTINUE - RETURN - END -C*MODULE BLAS1 *DECK DSWAP - SUBROUTINE DSWAP (N,DX,INCX,DY,INCY) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(1),DY(1) -C -C INTERCHANGES TWO VECTORS. -C DX(I) <==> DY(I) -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - IF(N.LE.0)RETURN - IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL -C TO 1 -C - IX = 1 - IY = 1 - IF(INCX.LT.0)IX = (-N+1)*INCX + 1 - IF(INCY.LT.0)IY = (-N+1)*INCY + 1 - DO 10 I = 1,N - DTEMP = DX(IX) - DX(IX) = DY(IY) - DY(IY) = DTEMP - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,3) - IF( M .EQ. 0 ) GO TO 40 - DO 30 I = 1,M - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - 30 CONTINUE - IF( N .LT. 3 ) RETURN - 40 MP1 = M + 1 - DO 50 I = MP1,N,3 - DTEMP = DX(I) - DX(I) = DY(I) - DY(I) = DTEMP - DTEMP = DX(I + 1) - DX(I + 1) = DY(I + 1) - DY(I + 1) = DTEMP - DTEMP = DX(I + 2) - DX(I + 2) = DY(I + 2) - DY(I + 2) = DTEMP - 50 CONTINUE - RETURN - END -C*MODULE BLAS1 *DECK IDAMAX - INTEGER FUNCTION IDAMAX(N,DX,INCX) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DX(1) -C -C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. -C JACK DONGARRA, LINPACK, 3/11/78. -C - IDAMAX = 0 - IF( N .LT. 1 ) RETURN - IDAMAX = 1 - IF(N.EQ.1)RETURN - IF(INCX.EQ.1)GO TO 20 -C -C CODE FOR INCREMENT NOT EQUAL TO 1 -C - IX = 1 - RMAX = ABS(DX(1)) - IX = IX + INCX - DO 10 I = 2,N - IF(ABS(DX(IX)).LE.RMAX) GO TO 5 - IDAMAX = I - RMAX = ABS(DX(IX)) - 5 IX = IX + INCX - 10 CONTINUE - RETURN -C -C CODE FOR INCREMENT EQUAL TO 1 -C - 20 RMAX = ABS(DX(1)) - DO 30 I = 2,N - IF(ABS(DX(I)).LE.RMAX) GO TO 30 - IDAMAX = I - RMAX = ABS(DX(I)) - 30 CONTINUE - RETURN - END -C*MODULE BLAS *DECK DGEMV - SUBROUTINE DGEMV(FORMA,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - CHARACTER*1 FORMA - DIMENSION A(LDA,*),X(*),Y(*) - PARAMETER (ZERO=0.0D+00, ONE=1.0D+00) -C -C CLONE OF -DGEMV- WRITTEN BY MIKE SCHMIDT -C - LOCY = 1 - IF(FORMA.EQ.'T') GO TO 200 -C -C Y = ALPHA * A * X + BETA * Y -C - IF(ALPHA.EQ.ONE .AND. BETA.EQ.ZERO) THEN - DO 110 I=1,M - Y(LOCY) = DDOT(N,A(I,1),LDA,X,INCX) - LOCY = LOCY+INCY - 110 CONTINUE - ELSE - DO 120 I=1,M - Y(LOCY) = ALPHA*DDOT(N,A(I,1),LDA,X,INCX) + BETA*Y(LOCY) - LOCY = LOCY+INCY - 120 CONTINUE - END IF - RETURN -C -C Y = ALPHA * A-TRANSPOSE * X + BETA * Y -C - 200 CONTINUE - IF(ALPHA.EQ.ONE .AND. BETA.EQ.ZERO) THEN - DO 210 I=1,N - Y(LOCY) = DDOT(M,A(1,I),1,X,INCX) - LOCY = LOCY+INCY - 210 CONTINUE - ELSE - DO 220 I=1,N - Y(LOCY) = ALPHA*DDOT(M,A(1,I),1,X,INCX) + BETA*Y(LOCY) - LOCY = LOCY+INCY - 220 CONTINUE - END IF - RETURN - END diff --git a/source/unres/src_MD_DFA/bond_move.f b/source/unres/src_MD_DFA/bond_move.f deleted file mode 100644 index 4c0761a..0000000 --- a/source/unres/src_MD_DFA/bond_move.f +++ /dev/null @@ -1,125 +0,0 @@ - subroutine bond_move(nbond,nstart,psi,lprint,error) -C Move NBOND fragment starting from the CA(nstart) by angle PSI. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - integer nbond,nstart - double precision psi - logical fail,error,lprint - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.REFSYS' - include 'COMMON.IOUNITS' - include 'COMMON.MCM' - dimension x(3),e(3,3),rot(3,3),trans(3,3) - error=.false. - nend=nstart+nbond - if (print_mc.gt.2) then - write (iout,*) 'nstart=',nstart,' nend=',nend,' nbond=',nbond - write (iout,*) 'psi=',psi - write (iout,'(a)') 'Original coordinates of the fragment' - do i=nstart,nend - write (iout,'(i5,3f10.5)') i,(c(j,i),j=1,3) - enddo - endif - if (nstart.lt.1 .or. nend .gt.nres .or. nbond.lt.2 .or. - & nbond.ge.nres-1) then - write (iout,'(a)') 'Bad data in BOND_MOVE.' - error=.true. - return - endif -C Generate the reference system. - i2=nend - i3=nstart - i4=nstart+1 - call refsys(error) -C Return, if couldn't define the reference system. - if (error) return -C Compute the transformation matrix. - cospsi=dcos(psi) - sinpsi=dsin(psi) - rot(1,1)=1.0D0 - rot(1,2)=0.0D0 - rot(1,3)=0.0D0 - rot(2,1)=0.0D0 - rot(2,2)=cospsi - rot(2,3)=-sinpsi - rot(3,1)=0.0D0 - rot(3,2)=sinpsi - rot(3,3)=cospsi - do i=1,3 - e(1,i)=e1(i) - e(2,i)=e2(i) - e(3,i)=e3(i) - enddo - - if (print_mc.gt.2) then - write (iout,'(a)') 'Reference system and matrix r:' - do i=1,3 - write(iout,'(i5,2(3f10.5,5x))')i,(e(i,j),j=1,3),(rot(i,j),j=1,3) - enddo - endif - - call matmult(rot,e,trans) - do i=1,3 - do j=1,3 - e(i,1)=e1(i) - e(i,2)=e2(i) - e(i,3)=e3(i) - enddo - enddo - call matmult(e,trans,trans) - - if (lprint) then - write (iout,'(a)') 'The trans matrix:' - do i=1,3 - write (iout,'(i5,3f10.5)') i,(trans(i,j),j=1,3) - enddo - endif - - do i=nstart,nend - do j=1,3 - rij=c(j,nstart) - do k=1,3 - rij=rij+trans(j,k)*(c(k,i)-c(k,nstart)) - enddo - x(j)=rij - enddo - do j=1,3 - c(j,i)=x(j) - enddo - enddo - - if (lprint) then - write (iout,'(a)') 'Rotated coordinates of the fragment' - do i=nstart,nend - write (iout,'(i5,3f10.5)') i,(c(j,i),j=1,3) - enddo - endif - -c call int_from_cart(.false.,lprint) - if (nstart.gt.1) then - theta(nstart+1)=alpha(nstart-1,nstart,nstart+1) - phi(nstart+2)=beta(nstart-1,nstart,nstart+1,nstart+2) - if (nstart.gt.2) phi(nstart+1)= - & beta(nstart-2,nstart-1,nstart,nstart+1) - endif - if (nend.lt.nres) then - theta(nend+1)=alpha(nend-1,nend,nend+1) - phi(nend+1)=beta(nend-2,nend-1,nend,nend+1) - if (nend.lt.nres-1) phi(nend+2)= - & beta(nend-1,nend,nend+1,nend+2) - endif - if (print_mc.gt.2) then - write (iout,'(/a,i3,a,i3,a/)') - & 'Moved internal coordinates of the ',nstart,'-',nend, - & ' fragment:' - do i=nstart+1,nstart+2 - write (iout,'(i5,2f10.5)') i,rad2deg*theta(i),rad2deg*phi(i) - enddo - do i=nend+1,nend+2 - write (iout,'(i5,2f10.5)') i,rad2deg*theta(i),rad2deg*phi(i) - enddo - endif - return - end diff --git a/source/unres/src_MD_DFA/cartder.F b/source/unres/src_MD_DFA/cartder.F deleted file mode 100644 index e2e8c1a..0000000 --- a/source/unres/src_MD_DFA/cartder.F +++ /dev/null @@ -1,314 +0,0 @@ - subroutine cartder -*********************************************************************** -* This subroutine calculates the derivatives of the consecutive virtual -* bond vectors and the SC vectors in the virtual-bond angles theta and -* virtual-torsional angles phi, as well as the derivatives of SC vectors -* in the angles alpha and omega, describing the location of a side chain -* in its local coordinate system. -* -* The derivatives are stored in the following arrays: -* -* DDCDV - the derivatives of virtual-bond vectors DC in theta and phi. -* The structure is as follows: -* -* dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0, 0, 0 -* dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4) -* . . . . . . . . . . . . . . . . . . -* dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4) -* . -* . -* . -* dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N) -* -* DXDV - the derivatives of the side-chain vectors in theta and phi. -* The structure is same as above. -* -* DCDS - the derivatives of the side chain vectors in the local spherical -* andgles alph and omega: -* -* dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2) -* dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3) -* . -* . -* . -* dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1) -* -* Version of March '95, based on an early version of November '91. -* -*********************************************************************** - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - dimension drt(3,3,maxres),rdt(3,3,maxres),dp(3,3),temp(3,3), - & fromto(3,3,maxdim),prordt(3,3,maxres),prodrt(3,3,maxres) - dimension xx(3),xx1(3) -c common /przechowalnia/ fromto -* get the position of the jth ijth fragment of the chain coordinate system -* in the fromto array. - indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 -* -* calculate the derivatives of transformation matrix elements in theta -* - do i=1,nres-2 - rdt(1,1,i)=-rt(1,2,i) - rdt(1,2,i)= rt(1,1,i) - rdt(1,3,i)= 0.0d0 - rdt(2,1,i)=-rt(2,2,i) - rdt(2,2,i)= rt(2,1,i) - rdt(2,3,i)= 0.0d0 - rdt(3,1,i)=-rt(3,2,i) - rdt(3,2,i)= rt(3,1,i) - rdt(3,3,i)= 0.0d0 - enddo -* -* derivatives in phi -* - do i=2,nres-2 - drt(1,1,i)= 0.0d0 - drt(1,2,i)= 0.0d0 - drt(1,3,i)= 0.0d0 - drt(2,1,i)= rt(3,1,i) - drt(2,2,i)= rt(3,2,i) - drt(2,3,i)= rt(3,3,i) - drt(3,1,i)=-rt(2,1,i) - drt(3,2,i)=-rt(2,2,i) - drt(3,3,i)=-rt(2,3,i) - enddo -* -* generate the matrix products of type r(i)t(i)...r(j)t(j) -* - do i=2,nres-2 - ind=indmat(i,i+1) - do k=1,3 - do l=1,3 - temp(k,l)=rt(k,l,i) - enddo - enddo - do k=1,3 - do l=1,3 - fromto(k,l,ind)=temp(k,l) - enddo - enddo - do j=i+1,nres-2 - ind=indmat(i,j+1) - do k=1,3 - do l=1,3 - dpkl=0.0d0 - do m=1,3 - dpkl=dpkl+temp(k,m)*rt(m,l,j) - enddo - dp(k,l)=dpkl - fromto(k,l,ind)=dpkl - enddo - enddo - do k=1,3 - do l=1,3 - temp(k,l)=dp(k,l) - enddo - enddo - enddo - enddo -* -* Calculate derivatives. -* - ind1=0 - do i=1,nres-2 - ind1=ind1+1 -* -* Derivatives of DC(i+1) in theta(i+2) -* - do j=1,3 - do k=1,2 - dpjk=0.0D0 - do l=1,3 - dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) - enddo - dp(j,k)=dpjk - prordt(j,k,i)=dp(j,k) - enddo - dp(j,3)=0.0D0 - dcdv(j,ind1)=vbld(i+1)*dp(j,1) - enddo -* -* Derivatives of SC(i+1) in theta(i+2) -* - xx1(1)=-0.5D0*xloc(2,i+1) - xx1(2)= 0.5D0*xloc(1,i+1) - do j=1,3 - xj=0.0D0 - do k=1,2 - xj=xj+r(j,k,i)*xx1(k) - enddo - xx(j)=xj - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i)*xx(k) - enddo - dxdv(j,ind1)=rj - enddo -* -* Derivatives of SC(i+1) in theta(i+3). The have to be handled differently -* than the other off-diagonal derivatives. -* - do j=1,3 - dxoiij=0.0D0 - do k=1,3 - dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) - enddo - dxdv(j,ind1+1)=dxoiij - enddo -cd print *,ind1+1,(dxdv(j,ind1+1),j=1,3) -* -* Derivatives of DC(i+1) in phi(i+2) -* - do j=1,3 - do k=1,3 - dpjk=0.0 - do l=2,3 - dpjk=dpjk+prod(j,l,i)*drt(l,k,i) - enddo - dp(j,k)=dpjk - prodrt(j,k,i)=dp(j,k) - enddo - dcdv(j+3,ind1)=vbld(i+1)*dp(j,1) - enddo -* -* Derivatives of SC(i+1) in phi(i+2) -* - xx(1)= 0.0D0 - xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i) - xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i) - do j=1,3 - rj=0.0D0 - do k=2,3 - rj=rj+prod(j,k,i)*xx(k) - enddo - dxdv(j+3,ind1)=-rj - enddo -* -* Derivatives of SC(i+1) in phi(i+3). -* - do j=1,3 - dxoiij=0.0D0 - do k=1,3 - dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) - enddo - dxdv(j+3,ind1+1)=dxoiij - enddo -* -* Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru -* theta(nres) and phi(i+3) thru phi(nres). -* - do j=i+1,nres-2 - ind1=ind1+1 - ind=indmat(i+1,j+1) -cd print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 - do k=1,3 - do l=1,3 - tempkl=0.0D0 - do m=1,2 - tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind) - enddo - temp(k,l)=tempkl - enddo - enddo -cd print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3) -cd print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3) -cd print '(9f8.3)',((temp(k,l),l=1,3),k=1,3) -* Derivatives of virtual-bond vectors in theta - do k=1,3 - dcdv(k,ind1)=vbld(i+1)*temp(k,1) - enddo -cd print '(3f8.3)',(dcdv(k,ind1),k=1,3) -* Derivatives of SC vectors in theta - do k=1,3 - dxoijk=0.0D0 - do l=1,3 - dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) - enddo - dxdv(k,ind1+1)=dxoijk - enddo -* -*--- Calculate the derivatives in phi -* - do k=1,3 - do l=1,3 - tempkl=0.0D0 - do m=1,3 - tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind) - enddo - temp(k,l)=tempkl - enddo - enddo - do k=1,3 - dcdv(k+3,ind1)=vbld(i+1)*temp(k,1) - enddo - do k=1,3 - dxoijk=0.0D0 - do l=1,3 - dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) - enddo - dxdv(k+3,ind1+1)=dxoijk - enddo - enddo - enddo -* -* Derivatives in alpha and omega: -* - do i=2,nres-1 -c dsci=dsc(itype(i)) - dsci=vbld(i+nres) -#ifdef OSF - alphi=alph(i) - omegi=omeg(i) - if(alphi.ne.alphi) alphi=100.0 - if(omegi.ne.omegi) omegi=-100.0 -#else - alphi=alph(i) - omegi=omeg(i) -#endif -cd print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - temp(1,1)=-dsci*sinalphi - temp(2,1)= dsci*cosalphi*cosomegi - temp(3,1)=-dsci*cosalphi*sinomegi - temp(1,2)=0.0D0 - temp(2,2)=-dsci*sinalphi*sinomegi - temp(3,2)=-dsci*sinalphi*cosomegi - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - jjj=0 -cd print *,((temp(l,k),l=1,3),k=1,2) - do j=1,2 - xp=temp(1,j) - yp=temp(2,j) - xxp= xp*cost2+yp*sint2 - yyp=-xp*sint2+yp*cost2 - zzp=temp(3,j) - xx(1)=xxp - xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) - xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) - do k=1,3 - dj=0.0D0 - do l=1,3 - dj=dj+prod(k,l,i-1)*xx(l) - enddo - dxds(jjj+k,i)=dj - enddo - jjj=jjj+3 - enddo - enddo - return - end - diff --git a/source/unres/src_MD_DFA/cartprint.f b/source/unres/src_MD_DFA/cartprint.f deleted file mode 100644 index d79409e..0000000 --- a/source/unres/src_MD_DFA/cartprint.f +++ /dev/null @@ -1,19 +0,0 @@ - subroutine cartprint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - write (iout,100) - do i=1,nres - write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i), - & c(3,i),c(1,nres+i),c(2,nres+i),c(3,nres+i) - enddo - 100 format (//' alpha-carbon coordinates ', - & ' centroid coordinates'/ - 1 ' ', 6X,'X',11X,'Y',11X,'Z', - & 10X,'X',11X,'Y',11X,'Z') - 110 format (a,'(',i3,')',6f12.5) - return - end diff --git a/source/unres/src_MD_DFA/chainbuild.F b/source/unres/src_MD_DFA/chainbuild.F deleted file mode 100644 index 45a1a53..0000000 --- a/source/unres/src_MD_DFA/chainbuild.F +++ /dev/null @@ -1,274 +0,0 @@ - subroutine chainbuild -C -C Build the virtual polypeptide chain. Side-chain centroids are moveable. -C As of 2/17/95. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - logical lprn -C Set lprn=.true. for debugging - lprn = .false. -C -C Define the origin and orientation of the coordinate system and locate the -C first three CA's and SC(2). -C - call orig_frame -* -* Build the alpha-carbon chain. -* - do i=4,nres - call locate_next_res(i) - enddo -C -C First and last SC must coincide with the corresponding CA. -C - do j=1,3 - dc(j,nres+1)=0.0D0 - dc_norm(j,nres+1)=0.0D0 - dc(j,nres+nres)=0.0D0 - dc_norm(j,nres+nres)=0.0D0 - c(j,nres+1)=c(j,1) - c(j,nres+nres)=c(j,nres) - enddo -* -* Temporary diagnosis -* - if (lprn) then - - call cartprint - write (iout,'(/a)') 'Recalculated internal coordinates' - do i=2,nres-1 - do j=1,3 - c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) - enddo - be=0.0D0 - if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i) - be1=rad2deg*beta(nres+i,i,maxres2,i+1) - alfai=0.0D0 - if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i) - write (iout,1212) restyp(itype(i)),i,dist(i-1,i), - & alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,maxres2),be1 - enddo - 1212 format (a3,'(',i3,')',2(f10.5,2f10.2)) - - endif - - return - end -c------------------------------------------------------------------------- - subroutine orig_frame -C -C Define the origin and orientation of the coordinate system and locate -C the first three atoms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - cost=dcos(theta(3)) - sint=dsin(theta(3)) - t(1,1,1)=-cost - t(1,2,1)=-sint - t(1,3,1)= 0.0D0 - t(2,1,1)=-sint - t(2,2,1)= cost - t(2,3,1)= 0.0D0 - t(3,1,1)= 0.0D0 - t(3,2,1)= 0.0D0 - t(3,3,1)= 1.0D0 - r(1,1,1)= 1.0D0 - r(1,2,1)= 0.0D0 - r(1,3,1)= 0.0D0 - r(2,1,1)= 0.0D0 - r(2,2,1)= 1.0D0 - r(2,3,1)= 0.0D0 - r(3,1,1)= 0.0D0 - r(3,2,1)= 0.0D0 - r(3,3,1)= 1.0D0 - do i=1,3 - do j=1,3 - rt(i,j,1)=t(i,j,1) - enddo - enddo - do i=1,3 - do j=1,3 - prod(i,j,1)=0.0D0 - prod(i,j,2)=t(i,j,1) - enddo - prod(i,i,1)=1.0D0 - enddo - c(1,1)=0.0D0 - c(2,1)=0.0D0 - c(3,1)=0.0D0 - c(1,2)=vbld(2) - c(2,2)=0.0D0 - c(3,2)=0.0D0 - dc(1,0)=0.0d0 - dc(2,0)=0.0D0 - dc(3,0)=0.0D0 - dc(1,1)=vbld(2) - dc(2,1)=0.0D0 - dc(3,1)=0.0D0 - dc_norm(1,0)=0.0D0 - dc_norm(2,0)=0.0D0 - dc_norm(3,0)=0.0D0 - dc_norm(1,1)=1.0D0 - dc_norm(2,1)=0.0D0 - dc_norm(3,1)=0.0D0 - do j=1,3 - dc_norm(j,2)=prod(j,1,2) - dc(j,2)=vbld(3)*prod(j,1,2) - c(j,3)=c(j,2)+dc(j,2) - enddo - call locate_side_chain(2) - return - end -c----------------------------------------------------------------------------- - subroutine locate_next_res(i) -C -C Locate CA(i) and SC(i-1) -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' -C -C Define the rotation matrices corresponding to CA(i) -C -#ifdef OSF - theti=theta(i) - if (theti.ne.theti) theti=100.0 - phii=phi(i) - if (phii.ne.phii) phii=180.0 -#else - theti=theta(i) - phii=phi(i) -#endif - cost=dcos(theti) - sint=dsin(theti) - cosphi=dcos(phii) - sinphi=dsin(phii) -* Define the matrices of the rotation about the virtual-bond valence angles -* theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this -* program), R(i,j,k), and, the cumulative matrices of rotation RT - t(1,1,i-2)=-cost - t(1,2,i-2)=-sint - t(1,3,i-2)= 0.0D0 - t(2,1,i-2)=-sint - t(2,2,i-2)= cost - t(2,3,i-2)= 0.0D0 - t(3,1,i-2)= 0.0D0 - t(3,2,i-2)= 0.0D0 - t(3,3,i-2)= 1.0D0 - r(1,1,i-2)= 1.0D0 - r(1,2,i-2)= 0.0D0 - r(1,3,i-2)= 0.0D0 - r(2,1,i-2)= 0.0D0 - r(2,2,i-2)=-cosphi - r(2,3,i-2)= sinphi - r(3,1,i-2)= 0.0D0 - r(3,2,i-2)= sinphi - r(3,3,i-2)= cosphi - rt(1,1,i-2)=-cost - rt(1,2,i-2)=-sint - rt(1,3,i-2)=0.0D0 - rt(2,1,i-2)=sint*cosphi - rt(2,2,i-2)=-cost*cosphi - rt(2,3,i-2)=sinphi - rt(3,1,i-2)=-sint*sinphi - rt(3,2,i-2)=cost*sinphi - rt(3,3,i-2)=cosphi - call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1)) - do j=1,3 - dc_norm(j,i-1)=prod(j,1,i-1) - dc(j,i-1)=vbld(i)*prod(j,1,i-1) - c(j,i)=c(j,i-1)+dc(j,i-1) - enddo -cd print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3) -C -C Now calculate the coordinates of SC(i-1) -C - call locate_side_chain(i-1) - return - end -c----------------------------------------------------------------------------- - subroutine locate_side_chain(i) -C -C Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - dimension xx(3) - -c dsci=dsc(itype(i)) -c dsci_inv=dsc_inv(itype(i)) - dsci=vbld(i+nres) - dsci_inv=vbld_inv(i+nres) -#ifdef OSF - alphi=alph(i) - omegi=omeg(i) - if (alphi.ne.alphi) alphi=100.0 - if (omegi.ne.omegi) omegi=-100.0 -#else - alphi=alph(i) - omegi=omeg(i) -#endif - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - xp= dsci*cosalphi - yp= dsci*sinalphi*cosomegi - zp=-dsci*sinalphi*sinomegi -* Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its -* X-axis aligned with the vector DC(*,i) - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - xx(1)= xp*cost2+yp*sint2 - xx(2)=-xp*sint2+yp*cost2 - xx(3)= zp -cd print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i, -cd & xp,yp,zp,(xx(k),k=1,3) - do j=1,3 - xloc(j,i)=xx(j) - enddo -* Bring the SC vectors to the common coordinate system. - xx(1)=xloc(1,i) - xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1) - xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1) - do j=1,3 - xrot(j,i)=xx(j) - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i-1)*xx(k) - enddo - dc(j,nres+i)=rj - dc_norm(j,nres+i)=rj*dsci_inv - c(j,nres+i)=c(j,i)+rj - enddo - return - end diff --git a/source/unres/src_MD_DFA/change.awk b/source/unres/src_MD_DFA/change.awk deleted file mode 100644 index d192a6e..0000000 --- a/source/unres/src_MD_DFA/change.awk +++ /dev/null @@ -1,11 +0,0 @@ -{ - if($0==" include 'COMMON.LANGEVIN'") { - print "#ifndef LANG0" - print " include 'COMMON.LANGEVIN'" - print "#else" - print " include 'COMMON.LANGEVIN.lang0'" - print "#endif" - }else{ - print $0 - } -} diff --git a/source/unres/src_MD_DFA/check_bond.f b/source/unres/src_MD_DFA/check_bond.f deleted file mode 100644 index c8a4ad1..0000000 --- a/source/unres/src_MD_DFA/check_bond.f +++ /dev/null @@ -1,20 +0,0 @@ - subroutine check_bond -C Subroutine is checking if the fitted function which describs sc_rot_pot -C is correct, printing, alpha,beta, energy, data - for some known theta. -C theta angle is read from the input file. Sc_rot_pot are printed -C for the second residue in sequance. - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.CHAIN' - double precision energia(0:n_ene) - it=itype(2) - do i=1,101 - vbld(nres+2)=0.5d0+0.05d0*(i-1) - call chainbuild - call etotal(energia) - write (2,*) vbld(nres+2),energia(17) - enddo - return - end diff --git a/source/unres/src_MD_DFA/check_sc_distr.f b/source/unres/src_MD_DFA/check_sc_distr.f deleted file mode 100644 index db2ed1b..0000000 --- a/source/unres/src_MD_DFA/check_sc_distr.f +++ /dev/null @@ -1,43 +0,0 @@ - subroutine check_sc_distr - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - logical fail - double precision varia(maxvar) - double precision hrtime,mintime,sectime - parameter (MaxSample=10000000,delt=1.0D0/MaxSample) - dimension prob(0:72,0:90) - dV=2.0D0*5.0D0*deg2rad*deg2rad - print *,'dv=',dv - do 10 it=1,1 - if (it.eq.10) goto 10 - open (20,file=restyp(it)//'_distr.sdc',status='unknown') - call gen_side(it,90.0D0*deg2rad,al,om,fail) - close (20) - goto 10 - open (20,file=restyp(it)//'_distr1.sdc',status='unknown') - do i=0,90 - do j=0,72 - prob(j,i)=0.0D0 - enddo - enddo - do isample=1,MaxSample - call gen_side(it,90.0D0*deg2rad,al,om) - indal=rad2deg*al/2 - indom=(rad2deg*om+180.0D0)/5 - prob(indom,indal)=prob(indom,indal)+delt - enddo - do i=45,90 - do j=0,72 - write (20,'(2f10.3,1pd15.5)') 2*i+0.0D0,5*j-180.0D0, - & prob(j,i)/dV - enddo - enddo - 10 continue - return - end diff --git a/source/unres/src_MD_DFA/checkder_p.F b/source/unres/src_MD_DFA/checkder_p.F deleted file mode 100644 index 4d0379e..0000000 --- a/source/unres/src_MD_DFA/checkder_p.F +++ /dev/null @@ -1,713 +0,0 @@ - subroutine check_cartgrad -C Check the gradient of Cartesian coordinates in internal coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.DERIV' - include 'COMMON.SCCOR' - dimension temp(6,maxres),xx(3),gg(3) - indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 -* -* Check the gradient of the virtual-bond and SC vectors in the internal -* coordinates. -* - aincr=1.0d-7 - aincr2=5.0d-8 - call cartder - write (iout,'(a)') '**************** dx/dalpha' - write (iout,'(a)') - do i=2,nres-1 - alphi=alph(i) - alph(i)=alph(i)+aincr - do k=1,3 - temp(k,i)=dc(k,nres+i) - enddo - call chainbuild - do k=1,3 - gg(k)=(dc(k,nres+i)-temp(k,i))/aincr - xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr)) - enddo - write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') - & i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - alph(i)=alphi - call chainbuild - enddo - write (iout,'(a)') - write (iout,'(a)') '**************** dx/domega' - write (iout,'(a)') - do i=2,nres-1 - omegi=omeg(i) - omeg(i)=omeg(i)+aincr - do k=1,3 - temp(k,i)=dc(k,nres+i) - enddo - call chainbuild - do k=1,3 - gg(k)=(dc(k,nres+i)-temp(k,i))/aincr - xx(k)=dabs((gg(k)-dxds(k+3,i))/ - & (aincr*dabs(dxds(k+3,i))+aincr)) - enddo - write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') - & i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - omeg(i)=omegi - call chainbuild - enddo - write (iout,'(a)') - write (iout,'(a)') '**************** dx/dtheta' - write (iout,'(a)') - do i=3,nres - theti=theta(i) - theta(i)=theta(i)+aincr - do j=i-1,nres-1 - do k=1,3 - temp(k,j)=dc(k,nres+j) - enddo - enddo - call chainbuild - do j=i-1,nres-1 - ii = indmat(i-2,j) -c print *,'i=',i-2,' j=',j-1,' ii=',ii - do k=1,3 - gg(k)=(dc(k,nres+j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dxdv(k,ii))/ - & (aincr*dabs(dxdv(k,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3) - write(iout,'(a)') - enddo - write (iout,'(a)') - theta(i)=theti - call chainbuild - enddo - write (iout,'(a)') '***************** dx/dphi' - write (iout,'(a)') - do i=4,nres - phi(i)=phi(i)+aincr - do j=i-1,nres-1 - do k=1,3 - temp(k,j)=dc(k,nres+j) - enddo - enddo - call chainbuild - do j=i-1,nres-1 - ii = indmat(i-2,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,nres+j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ - & (aincr*dabs(dxdv(k+3,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3) - write(iout,'(a)') - enddo - phi(i)=phi(i)-aincr - call chainbuild - enddo - write (iout,'(a)') '****************** ddc/dtheta' - do i=1,nres-2 - thet=theta(i+2) - theta(i+2)=thet+aincr - do j=i,nres - do k=1,3 - temp(k,j)=dc(k,j) - enddo - enddo - call chainbuild - do j=i+1,nres-1 - ii = indmat(i,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dcdv(k,ii))/ - & (aincr*dabs(dcdv(k,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - enddo - do j=1,nres - do k=1,3 - dc(k,j)=temp(k,j) - enddo - enddo - theta(i+2)=thet - enddo - write (iout,'(a)') '******************* ddc/dphi' - do i=1,nres-3 - phii=phi(i+3) - phi(i+3)=phii+aincr - do j=1,nres - do k=1,3 - temp(k,j)=dc(k,j) - enddo - enddo - call chainbuild - do j=i+2,nres-1 - ii = indmat(i+1,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ - & (aincr*dabs(dcdv(k+3,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - enddo - do j=1,nres - do k=1,3 - dc(k,j)=temp(k,j) - enddo - enddo - phi(i+3)=phii - enddo - return - end -C---------------------------------------------------------------------------- - subroutine check_ecart -C Check the gradient of the energy in Cartesian coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTACTS' - include 'COMMON.SCCOR' - common /srutu/ icall - dimension ggg(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar),g(maxvar) - dimension grad_s(6,maxres) - double precision energia(0:n_ene),energia1(0:n_ene) - integer uiparm(1) - double precision urparm(1) - external fdum - icg=1 - nf=0 - nfl=0 - call zerograd - aincr=1.0D-7 - print '(a)','CG processor',me,' calling CHECK_CART.' - nf=0 - icall=0 - call geom_to_var(nvar,x) - call etotal(energia(0)) - etot=energia(0) - call enerprint(energia(0)) - call gradient(nvar,x,nf,g,uiparm,urparm,fdum) - icall =1 - do i=1,nres - write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) - enddo - do i=1,nres - do j=1,3 - grad_s(j,i)=gradc(j,i,icg) - grad_s(j+3,i)=gradx(j,i,icg) - enddo - enddo - call flush(iout) - write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' - do i=1,nres - do j=1,3 - xx(j)=c(j,i+nres) - ddc(j)=dc(j,i) - ddx(j)=dc(j,i+nres) - enddo - do j=1,3 - dc(j,i)=dc(j,i)+aincr - do k=i+1,nres - c(j,k)=c(j,k)+aincr - c(j,k+nres)=c(j,k+nres)+aincr - enddo - call etotal(energia1(0)) - etot1=energia1(0) - ggg(j)=(etot1-etot)/aincr - dc(j,i)=ddc(j) - do k=i+1,nres - c(j,k)=c(j,k)-aincr - c(j,k+nres)=c(j,k+nres)-aincr - enddo - enddo - do j=1,3 - c(j,i+nres)=c(j,i+nres)+aincr - dc(j,i+nres)=dc(j,i+nres)+aincr - call etotal(energia1(0)) - etot1=energia1(0) - ggg(j+3)=(etot1-etot)/aincr - c(j,i+nres)=xx(j) - dc(j,i+nres)=ddx(j) - enddo - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') - & i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6) - enddo - return - end -c---------------------------------------------------------------------------- - subroutine check_ecartint -C Check the gradient of the energy in Cartesian coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTACTS' - include 'COMMON.MD' - include 'COMMON.LOCAL' - include 'COMMON.SPLITELE' - include 'COMMON.SCCOR' - common /srutu/ icall - dimension ggg(6),ggg1(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar), - & g(maxvar) - dimension dcnorm_safe(3),dxnorm_safe(3) - dimension grad_s(6,0:maxres),grad_s1(6,0:maxres) - double precision phi_temp(maxres),theta_temp(maxres), - & alph_temp(maxres),omeg_temp(maxres) - double precision energia(0:n_ene),energia1(0:n_ene) - integer uiparm(1) - double precision urparm(1) - external fdum - r_cut=2.0d0 - rlambd=0.3d0 - icg=1 - nf=0 - nfl=0 - call intout -c call intcartderiv -c call checkintcartgrad - call zerograd - aincr=1.0D-5 - write(iout,*) 'Calling CHECK_ECARTINT.' - nf=0 - icall=0 - call geom_to_var(nvar,x) - if (.not.split_ene) then - call etotal(energia(0)) -c do i=1,nres -c write (iout,*) "atu?", gloc_sc(1,i,icg),gloc(i,icg) -c enddo - etot=energia(0) - call enerprint(energia(0)) - call flush(iout) - write (iout,*) "enter cartgrad" -c do i=1,nres -c write (iout,*) gloc_sc(1,i,icg) -c enddo - call flush(iout) - call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) - icall =1 - do i=1,nres - write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) - enddo - do j=1,3 - grad_s(j,0)=gcart(j,0) - enddo - do i=1,nres - do j=1,3 - grad_s(j,i)=gcart(j,i) - grad_s(j+3,i)=gxcart(j,i) - enddo - enddo - else -!- split gradient check - call zerograd - call etotal_long(energia(0)) - call enerprint(energia(0)) - call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) - call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) - icall =1 - write (iout,*) "longrange grad" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), - & (gxcart(j,i),j=1,3) - enddo - do j=1,3 - grad_s(j,0)=gcart(j,0) - enddo - do i=1,nres - do j=1,3 - grad_s(j,i)=gcart(j,i) - grad_s(j+3,i)=gxcart(j,i) - enddo - enddo - call zerograd - call etotal_short(energia(0)) - call enerprint(energia(0)) -c do i=1,nres -c write (iout,*) gloc_sc(1,i,icg) -c enddo - call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) - call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) - icall =1 - write (iout,*) "shortrange grad" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), - & (gxcart(j,i),j=1,3) - enddo - do j=1,3 - grad_s1(j,0)=gcart(j,0) - enddo - do i=1,nres - do j=1,3 - grad_s1(j,i)=gcart(j,i) - grad_s1(j+3,i)=gxcart(j,i) - enddo - enddo - endif - write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' - do i=0,nres - do j=1,3 - xx(j)=c(j,i+nres) - ddc(j)=dc(j,i) - ddx(j)=dc(j,i+nres) - do k=1,3 - dcnorm_safe(k)=dc_norm(k,i) - dxnorm_safe(k)=dc_norm(k,i+nres) - enddo - enddo - do j=1,3 - dc(j,i)=ddc(j)+aincr - call chainbuild_cart -#ifdef MPI -c Broadcast the order to compute internal coordinates to the slaves. -c if (nfgtasks.gt.1) -c & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif -c call int_from_cart1(.false.) - if (.not.split_ene) then - call etotal(energia1(0)) - etot1=energia1(0) - else -!- split gradient - call etotal_long(energia1(0)) - etot11=energia1(0) - call etotal_short(energia1(0)) - etot12=energia1(0) -c write (iout,*) "etot11",etot11," etot12",etot12 - endif -!- end split gradient -c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 - dc(j,i)=ddc(j)-aincr - call chainbuild_cart -c call int_from_cart1(.false.) - if (.not.split_ene) then - call etotal(energia1(0)) - etot2=energia1(0) - ggg(j)=(etot1-etot2)/(2*aincr) - else -!- split gradient - call etotal_long(energia1(0)) - etot21=energia1(0) - ggg(j)=(etot11-etot21)/(2*aincr) - call etotal_short(energia1(0)) - etot22=energia1(0) - ggg1(j)=(etot12-etot22)/(2*aincr) -!- end split gradient -c write (iout,*) "etot21",etot21," etot22",etot22 - endif -c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 - dc(j,i)=ddc(j) - call chainbuild_cart - enddo - do j=1,3 - dc(j,i+nres)=ddx(j)+aincr - call chainbuild_cart -c write (iout,*) "i",i," j",j," dxnorm+ and dxnorm" -c write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) -c write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) -c write (iout,*) "dxnormnorm",dsqrt( -c & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) -c write (iout,*) "dxnormnormsafe",dsqrt( -c & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) -c write (iout,*) - if (.not.split_ene) then - call etotal(energia1(0)) - etot1=energia1(0) - else -!- split gradient - call etotal_long(energia1(0)) - etot11=energia1(0) - call etotal_short(energia1(0)) - etot12=energia1(0) - endif -!- end split gradient -c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 - dc(j,i+nres)=ddx(j)-aincr - call chainbuild_cart -c write (iout,*) "i",i," j",j," dxnorm- and dxnorm" -c write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) -c write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) -c write (iout,*) -c write (iout,*) "dxnormnorm",dsqrt( -c & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) -c write (iout,*) "dxnormnormsafe",dsqrt( -c & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) - if (.not.split_ene) then - call etotal(energia1(0)) - etot2=energia1(0) - ggg(j+3)=(etot1-etot2)/(2*aincr) - else -!- split gradient - call etotal_long(energia1(0)) - etot21=energia1(0) - ggg(j+3)=(etot11-etot21)/(2*aincr) - call etotal_short(energia1(0)) - etot22=energia1(0) - ggg1(j+3)=(etot12-etot22)/(2*aincr) -!- end split gradient - endif -c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 - dc(j,i+nres)=ddx(j) - call chainbuild_cart - enddo - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') - & i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6) - if (split_ene) then - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') - & i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i), - & k=1,6) - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') - & i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6), - & ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6) - endif - enddo - return - end -c------------------------------------------------------------------------- - subroutine int_from_cart1(lprn) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer ierror -#endif - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.SETUP' - include 'COMMON.TIME1' - logical lprn - if (lprn) write (iout,'(/a)') 'Recalculated internal coordinates' -#ifdef TIMING - time01=MPI_Wtime() -#endif -#if defined(PARINT) && defined(MPI) - do i=iint_start,iint_end+1 -#else - do i=2,nres -#endif - dnorm1=dist(i-1,i) - dnorm2=dist(i,i+1) - do j=1,3 - c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))/dnorm1 - & +(c(j,i+1)-c(j,i))/dnorm2) - enddo - be=0.0D0 - if (i.gt.2) then - if (i.le.nres) phi(i+1)=beta(i-2,i-1,i,i+1) - if ((itype(i).ne.10).and.(itype(i-1).ne.10)) then - tauangle(3,i+1)=beta(i+nres-1,i-1,i,i+nres) - endif - if (itype(i-1).ne.10) then - tauangle(1,i+1)=beta(i-1+nres,i-1,i,i+1) - omicron(1,i)=alpha(i-2,i-1,i-1+nres) - omicron(2,i)=alpha(i-1+nres,i-1,i) - endif - if (itype(i).ne.10) then - tauangle(2,i+1)=beta(i-2,i-1,i,i+nres) - endif - endif - omeg(i)=beta(nres+i,i,maxres2,i+1) - alph(i)=alpha(nres+i,i,maxres2) - theta(i+1)=alpha(i-1,i,i+1) - vbld(i)=dist(i-1,i) - vbld_inv(i)=1.0d0/vbld(i) - vbld(nres+i)=dist(nres+i,i) - if (itype(i).ne.10) then - vbld_inv(nres+i)=1.0d0/vbld(nres+i) - else - vbld_inv(nres+i)=0.0d0 - endif - enddo - -#if defined(PARINT) && defined(MPI) - if (nfgtasks1.gt.1) then -cd write(iout,*) "iint_start",iint_start," iint_count", -cd & (iint_count(i),i=0,nfgtasks-1)," iint_displ", -cd & (iint_displ(i),i=0,nfgtasks-1) -cd write (iout,*) "Gather vbld backbone" -cd call flush(iout) - time00=MPI_Wtime() - call MPI_Allgatherv(vbld(iint_start),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,vbld(1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather vbld_inv" -cd call flush(iout) - call MPI_Allgatherv(vbld_inv(iint_start),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,vbld_inv(1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather vbld side chain" -cd call flush(iout) - call MPI_Allgatherv(vbld(iint_start+nres),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,vbld(nres+1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather vbld_inv side chain" -cd call flush(iout) - call MPI_Allgatherv(vbld_inv(iint_start+nres), - & iint_count(fg_rank1),MPI_DOUBLE_PRECISION,vbld_inv(nres+1), - & iint_count(0),iint_displ(0),MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather theta" -cd call flush(iout) - call MPI_Allgatherv(theta(iint_start+1),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,theta(2),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather phi" -cd call flush(iout) - call MPI_Allgatherv(phi(iint_start+1),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,phi(2),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -#ifdef CRYST_SC -cd write (iout,*) "Gather alph" -cd call flush(iout) - call MPI_Allgatherv(alph(iint_start),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,alph(1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather omeg" -cd call flush(iout) - call MPI_Allgatherv(omeg(iint_start),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,omeg(1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -#endif - time_gather=time_gather+MPI_Wtime()-time00 - endif -#endif - do i=1,nres-1 - do j=1,3 - dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) - enddo - enddo - do i=2,nres-1 - do j=1,3 - dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) - enddo - enddo - if (lprn) then - do i=2,nres - write (iout,1212) restyp(itype(i)),i,vbld(i), - &rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i), - &rad2deg*alph(i),rad2deg*omeg(i) - enddo - endif - 1212 format (a3,'(',i3,')',2(f15.10,2f10.2)) -#ifdef TIMING - time_intfcart=time_intfcart+MPI_Wtime()-time01 -#endif - return - end -c---------------------------------------------------------------------------- - subroutine check_eint -C Check the gradient of energy in internal coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' - common /srutu/ icall - dimension x(maxvar),gana(maxvar),gg(maxvar) - integer uiparm(1) - double precision urparm(1) - double precision energia(0:n_ene),energia1(0:n_ene), - & energia2(0:n_ene) - character*6 key - external fdum - call zerograd - aincr=1.0D-7 - print '(a)','Calling CHECK_INT.' - nf=0 - nfl=0 - icg=1 - call geom_to_var(nvar,x) - call var_to_geom(nvar,x) - call chainbuild - icall=1 - print *,'ICG=',ICG - call etotal(energia(0)) - etot = energia(0) - call enerprint(energia(0)) - print *,'ICG=',ICG -#ifdef MPL - if (MyID.ne.BossID) then - call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID) - nf=x(nvar+1) - nfl=x(nvar+2) - icg=x(nvar+3) - endif -#endif - nf=1 - nfl=3 -cd write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar) - call gradient(nvar,x,nf,gana,uiparm,urparm,fdum) -cd write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar) - icall=1 - do i=1,nvar - xi=x(i) - x(i)=xi-0.5D0*aincr - call var_to_geom(nvar,x) - call chainbuild - call etotal(energia1(0)) - etot1=energia1(0) - x(i)=xi+0.5D0*aincr - call var_to_geom(nvar,x) - call chainbuild - call etotal(energia2(0)) - etot2=energia2(0) - gg(i)=(etot2-etot1)/aincr - write (iout,*) i,etot1,etot2 - x(i)=xi - enddo - write (iout,'(/2a)')' Variable Numerical Analytical', - & ' RelDiff*100% ' - do i=1,nvar - if (i.le.nphi) then - ii=i - key = ' phi' - else if (i.le.nphi+ntheta) then - ii=i-nphi - key=' theta' - else if (i.le.nphi+ntheta+nside) then - ii=i-(nphi+ntheta) - key=' alpha' - else - ii=i-(nphi+ntheta+nside) - key=' omega' - endif - write (iout,'(i3,a,i3,3(1pd16.6))') - & i,key,ii,gg(i),gana(i), - & 100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr) - enddo - return - end diff --git a/source/unres/src_MD_DFA/compare_s1.F b/source/unres/src_MD_DFA/compare_s1.F deleted file mode 100644 index 300e7ed..0000000 --- a/source/unres/src_MD_DFA/compare_s1.F +++ /dev/null @@ -1,188 +0,0 @@ - subroutine compare_s1(n_thr,num_thread_save,energyx,x, - & icomp,enetbss,coordss,rms_d,modif,iprint) -C This subroutine compares the new conformation, whose variables are in X -C with the previously accumulated conformations whose energies and variables -C are stored in ENETBSS and COORDSS, respectively. The meaning of other -C variables is as follows: -C -C N_THR - on input the previous # of accumulated confs, on output the current -C # of accumulated confs. -C N_REPEAT - an array that indicates how many times the structure has already -C been used to start the reversed-reversing procedure. Addition of -C a new structure replacement of a structure with a similar, but -C lower-energy structure resets the respective entry in N_REPEAT to zero -C I9 - output unit -C ENERGYX,X - the energy and variables of the new conformations. -C ICOMP - comparison result: -C 0 - the new structure is similar to one of the previous ones and does -C not have a remarkably lower energy and is therefore rejected; -C 1 - the new structure is different and is added to the set, because -C there is still room in the COORDSS and ENETBSS arrays; -C 2 - the new structure is different, but higher in energy than any -C previous one and is therefore rejected -C 3 - there is no more room in the COORDSS and ENETBSS arrays, but -C the new structure is lower in energy than at least the highest- -C energy previous structure and therefore replaces it. -C 9 - the new structure is similar to a number of previous structures, -C but has a remarkably lower energy than any of them; therefore -C replaces all these structures; -C MODIF - a logical variable that shows whether to include the new structure -C in the set of accumulated structures - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' -crc include 'COMMON.DEFORM' - include 'COMMON.IOUNITS' -#ifdef UNRES - include 'COMMON.CHAIN' -#endif - - dimension x(maxvar) - dimension x1(maxvar) - double precision przes(3),obrot(3,3) - integer list(max_thread) - logical non_conv,modif - double precision enetbss(max_threadss) - double precision coordss(maxvar,max_threadss) - - nlist=0 -#ifdef UNRES - call var_to_geom(nvar,x) - call chainbuild - do k=1,2*nres - do kk=1,3 - cref(kk,k)=c(kk,k) - enddo - enddo -#endif -c write(iout,*)'*ene=',energyx - j=0 - enex_jp=-1.0d+99 - do i=1,n_thr - do k=1,nvar - x1(k)=coordss(k,i) - enddo - if (iprint.gt.3) then - write (iout,*) 'Compare_ss, i=',i - write (iout,*) 'New structure Energy:',energyx - write (iout,'(10f8.3)') (rad2deg*x(k),k=1,nvar) - write (iout,*) 'Template structure Energy:',enetbss(i) - write (iout,'(10f8.3)') (rad2deg*x1(k),k=1,nvar) - endif - -#ifdef UNRES - call var_to_geom(nvar,x1) - call chainbuild -cd write(iout,*)'C and CREF' -cd write(iout,'(i5,3f10.5,5x,3f10.5)')(k,(c(j,k),j=1,3), -cd & (cref(j,k),j=1,3),k=1,nres) - call fitsq(roznica,c(1,1),cref(1,1),nres,przes,obrot,non_conv) - if (non_conv) then - print *,'Problems in FITSQ!!!' - print *,'X' - print '(10f8.3)',(x(k),k=1,nvar) - print *,'X1' - print '(10f8.3)',(x1(k),k=1,nvar) - print *,'C and CREF' - print '(i5,3f10.5,5x,3f10.5)',(k,(c(j,k),j=1,3), - & (cref(j,k),j=1,3),k=1,nres) - endif - roznica=dsqrt(dabs(roznica)) - iresult = 1 - if (roznica.lt.rms_d) iresult = 0 -#else - energyy=enetbss(i) - call cmprs(x,x1,roznica,energyx,energyy,iresult) -#endif - if (iprint.gt.1) write(iout,'(i5,f10.6,$)') i,roznica -c print '(i5,f8.3)',i,roznica - if(iresult.eq.0) then - nlist = nlist + 1 - list(nlist)=i - if (iprint.gt.1) write(iout,*) - if(energyx.ge.enetbss(i)) then - if (iprint.gt.1) - & write(iout,*)'s*>> structure rejected - same as nr ',i, - & ' RMS',roznica - minimize_s_flag=0 - icomp=0 - go to 1106 - endif - endif - if(energyx.lt.enetbss(i).and.enex_jp.lt.enetbss(i))then - j=i - enex_jp=enetbss(i) - endif - enddo - if (iprint.gt.1) write(iout,*) - if(nlist.gt.0) then - if (modif) then - if (iprint.gt.1) - & write(iout,'(a,i3,$)')'s*>> structure accepted1 - repl nr ', - & list(1) - else - if (iprint.gt.1) - & write(iout,'(a,i3)') - & 's*>> structure accepted1 - would repl nr ',list(1) - endif - icomp=9 - if (.not. modif) goto 1106 - j=list(1) - enetbss(j)=energyx - do i=1,nvar - coordss(i,j)=x(i) - enddo - do j=2,nlist - if (iprint.gt.1) write(iout,'(i3,$)')list(j) - do kk=list(j)+1,nlist - enetbss(kk-1)=enetbss(kk) - do i=1,nvar - coordss(i,kk-1)=coordss(i,kk) - enddo - enddo - enddo - if (iprint.gt.1) write(iout,*) - go to 1106 - endif - if(n_thr.lt.num_thread_save) then - icomp=1 - if (modif) then - if (iprint.gt.1) - & write(iout,*)'s*>> structure accepted - add with nr ',n_thr+1 - else - if (iprint.gt.1) - & write(iout,*)'s*>> structure accepted - would add with nr ', - & n_thr+1 - goto 1106 - endif - n_thr=n_thr+1 - enetbss(n_thr)=energyx - do i=1,nvar - coordss(i,n_thr)=x(i) - enddo - else - if(j.eq.0) then - if (iprint.gt.1) - & write(iout,*)'s*>> structure rejected - too high energy' - icomp=2 - go to 1106 - end if - icomp=3 - if (modif) then - if (iprint.gt.1) - & write(iout,*)'s*>> structure accepted - repl nr ',j - else - if (iprint.gt.1) - & write(iout,*)'s*>> structure accepted - would repl nr ',j - goto 1106 - endif - enetbss(j)=energyx - do i=1,nvar - coordss(i,j)=x(i) - enddo - end if - -1106 continue - return - end diff --git a/source/unres/src_MD_DFA/compinfo.c b/source/unres/src_MD_DFA/compinfo.c deleted file mode 100644 index e28f686..0000000 --- a/source/unres/src_MD_DFA/compinfo.c +++ /dev/null @@ -1,82 +0,0 @@ -#include -#include -#include -#include -#include - -main() -{ -FILE *in, *in1, *out; -int i,j,k,iv1,iv2,iv3; -char *p1,buf[500],buf1[500],buf2[100],buf3[100]; -struct utsname Name; -time_t Tp; - -in=fopen("cinfo.f","r"); -out=fopen("cinfo.f.new","w"); -if (fgets(buf,498,in) != NULL) - fprintf(out,"C DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C\n"); -if (fgets(buf,498,in) != NULL) - sscanf(&buf[1],"%d %d %d",&iv1,&iv2,&iv3); -iv3++; -fprintf(out,"C %d %d %d\n",iv1,iv2,iv3); -fprintf(out," subroutine cinfo\n"); -fprintf(out," include 'COMMON.IOUNITS'\n"); -fprintf(out," write(iout,*)'++++ Compile info ++++'\n"); -fprintf(out," write(iout,*)'Version %d.%-d build %d'\n",iv1,iv2,iv3); -uname(&Name); -time(&Tp); -system("whoami > tmptmp"); -in1=fopen("tmptmp","r"); -if (fscanf(in1,"%s",buf1) != EOF) -{ -p1=ctime(&Tp); -p1[strlen(p1)-1]='\0'; -fprintf(out," write(iout,*)'compiled %s'\n",p1); -fprintf(out," write(iout,*)'compiled by %s@%s'\n",buf1,Name.nodename); -fprintf(out," write(iout,*)'OS name: %s '\n",Name.sysname); -fprintf(out," write(iout,*)'OS release: %s '\n",Name.release); -fprintf(out," write(iout,*)'OS version:',\n"); -fprintf(out," & ' %s '\n",Name.version); -fprintf(out," write(iout,*)'flags:'\n"); -} -system("rm tmptmp"); -fclose(in1); -in1=fopen("Makefile","r"); -while(fgets(buf,498,in1) != NULL) - { - if((p1=strchr(buf,'=')) != NULL && buf[0] != '#') - { - buf[strlen(buf)-1]='\0'; - if(strlen(buf) > 49) - { - buf[47]='\0'; - strcat(buf,"..."); - } - else - { - while(buf[strlen(buf)-1]=='\\') - { - strcat(buf,"\\"); - fprintf(out," write(iout,*)'%s'\n",buf); - if (fgets(buf,498,in1) != NULL) - buf[strlen(buf)-1]='\0'; - if(strlen(buf) > 49) - { - buf[47]='\0'; - strcat(buf,"..."); - } - } - } - - fprintf(out," write(iout,*)'%s'\n",buf); - } - } -fprintf(out," write(iout,*)'++++ End of compile info ++++'\n"); -fprintf(out," return\n"); -fprintf(out," end\n"); -fclose(out); -fclose(in1); -fclose(in); -system("mv cinfo.f.new cinfo.f"); -} diff --git a/source/unres/src_MD_DFA/contact.f b/source/unres/src_MD_DFA/contact.f deleted file mode 100644 index a244d86..0000000 --- a/source/unres/src_MD_DFA/contact.f +++ /dev/null @@ -1,195 +0,0 @@ - subroutine contact(lprint,ncont,icont,co) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.NAMES' - real*8 facont /1.569D0/ ! facont = (2/(1-sqrt(1-1/4)))**(1/6) - integer ncont,icont(2,maxcont) - logical lprint - ncont=0 - kkk=3 - do i=nnt+kkk,nct - iti=itype(i) - do j=nnt,i-kkk - itj=itype(j) - if (ipot.ne.4) then -c rcomp=sigmaii(iti,itj)+1.0D0 - rcomp=facont*sigmaii(iti,itj) - else -c rcomp=sigma(iti,itj)+1.0D0 - rcomp=facont*sigma(iti,itj) - endif -c rcomp=6.5D0 -c print *,'rcomp=',rcomp,' dist=',dist(nres+i,nres+j) - if (dist(nres+i,nres+j).lt.rcomp) then - ncont=ncont+1 - icont(1,ncont)=i - icont(2,ncont)=j - endif - enddo - enddo - if (lprint) then - write (iout,'(a)') 'Contact map:' - do i=1,ncont - i1=icont(1,i) - i2=icont(2,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4)') - & i,restyp(it1),i1,restyp(it2),i2 - enddo - endif - co = 0.0d0 - do i=1,ncont - co = co + dfloat(iabs(icont(1,i)-icont(2,i))) - enddo - co = co / (nres*ncont) - return - end -c---------------------------------------------------------------------------- - double precision function contact_fract(ncont,ncont_ref, - & icont,icont_ref) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - integer ncont,ncont_ref,icont(2,maxcont),icont_ref(2,maxcont) - nmatch=0 -c print *,'ncont=',ncont,' ncont_ref=',ncont_ref -c write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) -c write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) -c write (iout,'(20i4)') (icont(1,i),i=1,ncont) -c write (iout,'(20i4)') (icont(2,i),i=1,ncont) - do i=1,ncont - do j=1,ncont_ref - if (icont(1,i).eq.icont_ref(1,j) .and. - & icont(2,i).eq.icont_ref(2,j)) nmatch=nmatch+1 - enddo - enddo -c print *,' nmatch=',nmatch -c contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) - contact_fract=dfloat(nmatch)/dfloat(ncont_ref) - return - end -c---------------------------------------------------------------------------- - double precision function contact_fract_nn(ncont,ncont_ref, - & icont,icont_ref) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - integer ncont,ncont_ref,icont(2,maxcont),icont_ref(2,maxcont) - nmatch=0 -c print *,'ncont=',ncont,' ncont_ref=',ncont_ref -c write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) -c write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) -c write (iout,'(20i4)') (icont(1,i),i=1,ncont) -c write (iout,'(20i4)') (icont(2,i),i=1,ncont) - do i=1,ncont - do j=1,ncont_ref - if (icont(1,i).eq.icont_ref(1,j) .and. - & icont(2,i).eq.icont_ref(2,j)) nmatch=nmatch+1 - enddo - enddo -c print *,' nmatch=',nmatch -c contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) - contact_fract_nn=dfloat(ncont-nmatch)/dfloat(ncont) - return - end -c---------------------------------------------------------------------------- - subroutine hairpin(lprint,nharp,iharp) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.NAMES' - integer ncont,icont(2,maxcont) - integer nharp,iharp(4,maxres/3) - logical lprint,not_done - real*8 rcomp /6.0d0/ - ncont=0 - kkk=0 -c print *,'nnt=',nnt,' nct=',nct - do i=nnt,nct-3 - do k=1,3 - c(k,2*nres+1)=0.5d0*(c(k,i)+c(k,i+1)) - enddo - do j=i+2,nct-1 - do k=1,3 - c(k,2*nres+2)=0.5d0*(c(k,j)+c(k,j+1)) - enddo - if (dist(2*nres+1,2*nres+2).lt.rcomp) then - ncont=ncont+1 - icont(1,ncont)=i - icont(2,ncont)=j - endif - enddo - enddo - if (lprint) then - write (iout,'(a)') 'PP contact map:' - do i=1,ncont - i1=icont(1,i) - i2=icont(2,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4)') - & i,restyp(it1),i1,restyp(it2),i2 - enddo - endif -c finding hairpins - nharp=0 - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if (j1.eq.i1+2 .and. i1.gt.nnt .and. j1.lt.nct) then -c write (iout,*) "found turn at ",i1,j1 - ii1=i1 - jj1=j1 - not_done=.true. - do while (not_done) - i1=i1-1 - j1=j1+1 - do j=1,ncont - if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10 - enddo - not_done=.false. - 10 continue -c write (iout,*) i1,j1,not_done - enddo - i1=i1+1 - j1=j1-1 - if (j1-i1.gt.4) then - nharp=nharp+1 - iharp(1,nharp)=i1 - iharp(2,nharp)=j1 - iharp(3,nharp)=ii1 - iharp(4,nharp)=jj1 -c write (iout,*)'nharp',nharp,' iharp',(iharp(k,nharp),k=1,4) - endif - endif - enddo -c do i=1,nharp -c write (iout,*)'i',i,' iharp',(iharp(k,i),k=1,4) -c enddo - if (lprint) then - write (iout,*) "Hairpins:" - do i=1,nharp - i1=iharp(1,i) - j1=iharp(2,i) - ii1=iharp(3,i) - jj1=iharp(4,i) - write (iout,*) - write (iout,'(20(a,i3,1x))') (restyp(itype(k)),k,k=i1,ii1) - write (iout,'(20(a,i3,1x))') (restyp(itype(k)),k,k=j1,jj1,-1) -c do k=jj1,j1,-1 -c write (iout,'(a,i3,$)') restyp(itype(k)),k -c enddo - enddo - endif - return - end -c---------------------------------------------------------------------------- - diff --git a/source/unres/src_MD_DFA/convert.f b/source/unres/src_MD_DFA/convert.f deleted file mode 100644 index dc0cccd..0000000 --- a/source/unres/src_MD_DFA/convert.f +++ /dev/null @@ -1,196 +0,0 @@ - subroutine geom_to_var(n,x) -C -C Transfer the geometry parameters to the variable array. -C The positions of variables are as follows: -C 1. Virtual-bond torsional angles: 1 thru nres-3 -C 2. Virtual-bond valence angles: nres-2 thru 2*nres-5 -C 3. The polar angles alpha of local SC orientation: 2*nres-4 thru -C 2*nres-4+nside -C 4. The torsional angles omega of SC orientation: 2*nres-4+nside+1 -C thru 2*nre-4+2*nside -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - double precision x(n) -cd print *,'nres',nres,' nphi',nphi,' ntheta',ntheta,' nvar',nvar - do i=4,nres - x(i-3)=phi(i) -cd print *,i,i-3,phi(i) - enddo - if (n.eq.nphi) return - do i=3,nres - x(i-2+nphi)=theta(i) -cd print *,i,i-2+nphi,theta(i) - enddo - if (n.eq.nphi+ntheta) return - do i=2,nres-1 - if (ialph(i,1).gt.0) then - x(ialph(i,1))=alph(i) - x(ialph(i,1)+nside)=omeg(i) -cd print *,i,ialph(i,1),ialph(i,1)+nside,alph(i),omeg(i) - endif - enddo - return - end -C-------------------------------------------------------------------- - subroutine var_to_geom(n,x) -C -C Update geometry parameters according to the variable array. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - dimension x(n) - logical change,reduce - change=reduce(x) - if (n.gt.nphi+ntheta) then - do i=1,nside - ii=ialph(i,2) - alph(ii)=x(nphi+ntheta+i) - omeg(ii)=pinorm(x(nphi+ntheta+nside+i)) - enddo - endif - do i=4,nres - phi(i)=x(i-3) - enddo - if (n.eq.nphi) return - do i=3,nres - theta(i)=x(i-2+nphi) - if (theta(i).eq.pi) theta(i)=0.99d0*pi - x(i-2+nphi)=theta(i) - enddo - return - end -c------------------------------------------------------------------------- - logical function convert_side(alphi,omegi) - implicit none - double precision alphi,omegi - double precision pinorm - include 'COMMON.GEO' - convert_side=.false. -C Apply periodicity restrictions. - if (alphi.gt.pi) then - alphi=dwapi-alphi - omegi=pinorm(omegi+pi) - convert_side=.true. - endif - return - end -c------------------------------------------------------------------------- - logical function reduce(x) -C -C Apply periodic restrictions to variables. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - logical zm,zmiana,convert_side - dimension x(nvar) - zmiana=.false. - do i=4,nres - x(i-3)=pinorm(x(i-3)) - enddo - if (nvar.gt.nphi+ntheta) then - do i=1,nside - ii=nphi+ntheta+i - iii=ii+nside - x(ii)=thetnorm(x(ii)) - x(iii)=pinorm(x(iii)) -C Apply periodic restrictions. - zm=convert_side(x(ii),x(iii)) - zmiana=zmiana.or.zm - enddo - endif - if (nvar.eq.nphi) return - do i=3,nres - ii=i-2+nphi - iii=i-3 - x(ii)=dmod(x(ii),dwapi) -C Apply periodic restrictions. - if (x(ii).gt.pi) then - zmiana=.true. - x(ii)=dwapi-x(ii) - if (iii.gt.0) x(iii)=pinorm(x(iii)+pi) - if (i.lt.nres) x(iii+1)=pinorm(x(iii+1)+pi) - ii=ialph(i-1,1) - if (ii.gt.0) then - x(ii)=dmod(pi-x(ii),dwapi) - x(ii+nside)=pinorm(-x(ii+nside)) - zm=convert_side(x(ii),x(ii+nside)) - endif - else if (x(ii).lt.-pi) then - zmiana=.true. - x(ii)=dwapi+x(ii) - ii=ialph(i-1,1) - if (ii.gt.0) then - x(ii)=dmod(pi-x(ii),dwapi) - x(ii+nside)=pinorm(-pi-x(ii+nside)) - zm=convert_side(x(ii),x(ii+nside)) - endif - else if (x(ii).lt.0.0d0) then - zmiana=.true. - x(ii)=-x(ii) - if (iii.gt.0) x(iii)=pinorm(x(iii)+pi) - if (i.lt.nres) x(iii+1)=pinorm(x(iii+1)+pi) - ii=ialph(i-1,1) - if (ii.gt.0) then - x(ii+nside)=pinorm(-x(ii+nside)) - zm=convert_side(x(ii),x(ii+nside)) - endif - endif - enddo - reduce=zmiana - return - end -c-------------------------------------------------------------------------- - double precision function thetnorm(x) -C This function puts x within [0,2Pi]. - implicit none - double precision x,xx - include 'COMMON.GEO' - xx=dmod(x,dwapi) - if (xx.lt.0.0d0) xx=xx+dwapi - if (xx.gt.0.9999d0*pi) xx=0.9999d0*pi - thetnorm=xx - return - end -C-------------------------------------------------------------------- - subroutine var_to_geom_restr(n,xx) -C -C Update geometry parameters according to the variable array. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - dimension x(maxvar),xx(maxvar) - logical change,reduce - - call xx2x(x,xx) - change=reduce(x) - do i=1,nside - ii=ialph(i,2) - alph(ii)=x(nphi+ntheta+i) - omeg(ii)=pinorm(x(nphi+ntheta+nside+i)) - enddo - do i=4,nres - phi(i)=x(i-3) - enddo - do i=3,nres - theta(i)=x(i-2+nphi) - if (theta(i).eq.pi) theta(i)=0.99d0*pi - x(i-2+nphi)=theta(i) - enddo - return - end -c------------------------------------------------------------------------- diff --git a/source/unres/src_MD_DFA/cored.f b/source/unres/src_MD_DFA/cored.f deleted file mode 100644 index 1cf25e5..0000000 --- a/source/unres/src_MD_DFA/cored.f +++ /dev/null @@ -1,3151 +0,0 @@ - subroutine assst(iv, liv, lv, v) -c -c *** assess candidate step (***sol version 2.3) *** -c - integer liv, l - integer iv(liv) - double precision v(lv) -c -c *** purpose *** -c -c this subroutine is called by an unconstrained minimization -c routine to assess the next candidate step. it may recommend one -c of several courses of action, such as accepting the step, recom- -c puting it using the same or a new quadratic model, or halting due -c to convergence or false convergence. see the return code listing -c below. -c -c-------------------------- parameter usage -------------------------- -c -c iv (i/o) integer parameter and scratch vector -- see description -c below of iv values referenced. -c liv (in) length of iv array. -c lv (in) length of v array. -c v (i/o) real parameter and scratch vector -- see description -c below of v values referenced. -c -c *** iv values referenced *** -c -c iv(irc) (i/o) on input for the first step tried in a new iteration, -c iv(irc) should be set to 3 or 4 (the value to which it is -c set when step is definitely to be accepted). on input -c after step has been recomputed, iv(irc) should be -c unchanged since the previous return of assst. -c on output, iv(irc) is a return code having one of the -c following values... -c 1 = switch models or try smaller step. -c 2 = switch models or accept step. -c 3 = accept step and determine v(radfac) by gradient -c tests. -c 4 = accept step, v(radfac) has been determined. -c 5 = recompute step (using the same model). -c 6 = recompute step with radius = v(lmaxs) but do not -c evaulate the objective function. -c 7 = x-convergence (see v(xctol)). -c 8 = relative function convergence (see v(rfctol)). -c 9 = both x- and relative function convergence. -c 10 = absolute function convergence (see v(afctol)). -c 11 = singular convergence (see v(lmaxs)). -c 12 = false convergence (see v(xftol)). -c 13 = iv(irc) was out of range on input. -c return code i has precdence over i+1 for i = 9, 10, 11. -c iv(mlstgd) (i/o) saved value of iv(model). -c iv(model) (i/o) on input, iv(model) should be an integer identifying -c the current quadratic model of the objective function. -c if a previous step yielded a better function reduction, -c then iv(model) will be set to iv(mlstgd) on output. -c iv(nfcall) (in) invocation count for the objective function. -c iv(nfgcal) (i/o) value of iv(nfcall) at step that gave the biggest -c function reduction this iteration. iv(nfgcal) remains -c unchanged until a function reduction is obtained. -c iv(radinc) (i/o) the number of radius increases (or minus the number -c of decreases) so far this iteration. -c iv(restor) (out) set to 1 if v(f) has been restored and x should be -c restored to its initial value, to 2 if x should be saved, -c to 3 if x should be restored from the saved value, and to -c 0 otherwise. -c iv(stage) (i/o) count of the number of models tried so far in the -c current iteration. -c iv(stglim) (in) maximum number of models to consider. -c iv(switch) (out) set to 0 unless a new model is being tried and it -c gives a smaller function value than the previous model, -c in which case assst sets iv(switch) = 1. -c iv(toobig) (in) is nonzero if step was too big (e.g. if it caused -c overflow). -c iv(xirc) (i/o) value that iv(irc) would have in the absence of -c convergence, false convergence, and oversized steps. -c -c *** v values referenced *** -c -c v(afctol) (in) absolute function convergence tolerance. if the -c absolute value of the current function value v(f) is less -c than v(afctol), then assst returns with iv(irc) = 10. -c v(decfac) (in) factor by which to decrease radius when iv(toobig) is -c nonzero. -c v(dstnrm) (in) the 2-norm of d*step. -c v(dstsav) (i/o) value of v(dstnrm) on saved step. -c v(dst0) (in) the 2-norm of d times the newton step (when defined, -c i.e., for v(nreduc) .ge. 0). -c v(f) (i/o) on both input and output, v(f) is the objective func- -c tion value at x. if x is restored to a previous value, -c then v(f) is restored to the corresponding value. -c v(fdif) (out) the function reduction v(f0) - v(f) (for the output -c value of v(f) if an earlier step gave a bigger function -c decrease, and for the input value of v(f) otherwise). -c v(flstgd) (i/o) saved value of v(f). -c v(f0) (in) objective function value at start of iteration. -c v(gtslst) (i/o) value of v(gtstep) on saved step. -c v(gtstep) (in) inner product between step and gradient. -c v(incfac) (in) minimum factor by which to increase radius. -c v(lmaxs) (in) maximum reasonable step size (and initial step bound). -c if the actual function decrease is no more than twice -c what was predicted, if a return with iv(irc) = 7, 8, 9, -c or 10 does not occur, if v(dstnrm) .gt. v(lmaxs), and if -c v(preduc) .le. v(sctol) * abs(v(f0)), then assst re- -c turns with iv(irc) = 11. if so doing appears worthwhile, -c then assst repeats this test with v(preduc) computed for -c a step of length v(lmaxs) (by a return with iv(irc) = 6). -c v(nreduc) (i/o) function reduction predicted by quadratic model for -c newton step. if assst is called with iv(irc) = 6, i.e., -c if v(preduc) has been computed with radius = v(lmaxs) for -c use in the singular convervence test, then v(nreduc) is -c set to -v(preduc) before the latter is restored. -c v(plstgd) (i/o) value of v(preduc) on saved step. -c v(preduc) (i/o) function reduction predicted by quadratic model for -c current step. -c v(radfac) (out) factor to be used in determining the new radius, -c which should be v(radfac)*dst, where dst is either the -c output value of v(dstnrm) or the 2-norm of -c diag(newd)*step for the output value of step and the -c updated version, newd, of the scale vector d. for -c iv(irc) = 3, v(radfac) = 1.0 is returned. -c v(rdfcmn) (in) minimum value for v(radfac) in terms of the input -c value of v(dstnrm) -- suggested value = 0.1. -c v(rdfcmx) (in) maximum value for v(radfac) -- suggested value = 4.0. -c v(reldx) (in) scaled relative change in x caused by step, computed -c (e.g.) by function reldst as -c max (d(i)*abs(x(i)-x0(i)), 1 .le. i .le. p) / -c max (d(i)*(abs(x(i))+abs(x0(i))), 1 .le. i .le. p). -c v(rfctol) (in) relative function convergence tolerance. if the -c actual function reduction is at most twice what was pre- -c dicted and v(nreduc) .le. v(rfctol)*abs(v(f0)), then -c assst returns with iv(irc) = 8 or 9. -c v(stppar) (in) marquardt parameter -- 0 means full newton step. -c v(tuner1) (in) tuning constant used to decide if the function -c reduction was much less than expected. suggested -c value = 0.1. -c v(tuner2) (in) tuning constant used to decide if the function -c reduction was large enough to accept step. suggested -c value = 10**-4. -c v(tuner3) (in) tuning constant used to decide if the radius -c should be increased. suggested value = 0.75. -c v(xctol) (in) x-convergence criterion. if step is a newton step -c (v(stppar) = 0) having v(reldx) .le. v(xctol) and giving -c at most twice the predicted function decrease, then -c assst returns iv(irc) = 7 or 9. -c v(xftol) (in) false convergence tolerance. if step gave no or only -c a small function decrease and v(reldx) .le. v(xftol), -c then assst returns with iv(irc) = 12. -c -c------------------------------- notes ------------------------------- -c -c *** application and usage restrictions *** -c -c this routine is called as part of the nl2sol (nonlinear -c least-squares) package. it may be used in any unconstrained -c minimization solver that uses dogleg, goldfeld-quandt-trotter, -c or levenberg-marquardt steps. -c -c *** algorithm notes *** -c -c see (1) for further discussion of the assessing and model -c switching strategies. while nl2sol considers only two models, -c assst is designed to handle any number of models. -c -c *** usage notes *** -c -c on the first call of an iteration, only the i/o variables -c step, x, iv(irc), iv(model), v(f), v(dstnrm), v(gtstep), and -c v(preduc) need have been initialized. between calls, no i/o -c values execpt step, x, iv(model), v(f) and the stopping toler- -c ances should be changed. -c after a return for convergence or false convergence, one can -c change the stopping tolerances and call assst again, in which -c case the stopping tests will be repeated. -c -c *** references *** -c -c (1) dennis, j.e., jr., gay, d.m., and welsch, r.e. (1981), -c an adaptive nonlinear least-squares algorithm, -c acm trans. math. software, vol. 7, no. 3. -c -c (2) powell, m.j.d. (1970) a fortran subroutine for solving -c systems of nonlinear algebraic equations, in numerical -c methods for nonlinear algebraic equations, edited by -c p. rabinowitz, gordon and breach, london. -c -c *** history *** -c -c john dennis designed much of this routine, starting with -c ideas in (2). roy welsch suggested the model switching strategy. -c david gay and stephen peters cast this subroutine into a more -c portable form (winter 1977), and david gay cast it into its -c present form (fall 1978). -c -c *** general *** -c -c this subroutine was written in connection with research -c supported by the national science foundation under grants -c mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, and -c mcs-7906671. -c -c------------------------ external quantities ------------------------ -c -c *** no external functions and subroutines *** -c -c *** intrinsic functions *** -c/+ - double precision dabs, dmax1 -c/ -c *** no common blocks *** -c -c-------------------------- local variables -------------------------- -c - logical goodx - integer i, nfc - double precision emax, emaxs, gts, rfac1, xmax - double precision half, one, onep2, two, zero -c -c *** subscripts for iv and v *** -c - integer afctol, decfac, dstnrm, dstsav, dst0, f, fdif, flstgd, f0, - 1 gtslst, gtstep, incfac, irc, lmaxs, mlstgd, model, nfcall, - 2 nfgcal, nreduc, plstgd, preduc, radfac, radinc, rdfcmn, - 3 rdfcmx, reldx, restor, rfctol, sctol, stage, stglim, - 4 stppar, switch, toobig, tuner1, tuner2, tuner3, xctol, - 5 xftol, xirc -c -c *** data initializations *** -c -c/6 -c data half/0.5d+0/, one/1.d+0/, onep2/1.2d+0/, two/2.d+0/, -c 1 zero/0.d+0/ -c/7 - parameter (half=0.5d+0, one=1.d+0, onep2=1.2d+0, two=2.d+0, - 1 zero=0.d+0) -c/ -c -c/6 -c data irc/29/, mlstgd/32/, model/5/, nfcall/6/, nfgcal/7/, -c 1 radinc/8/, restor/9/, stage/10/, stglim/11/, switch/12/, -c 2 toobig/2/, xirc/13/ -c/7 - parameter (irc=29, mlstgd=32, model=5, nfcall=6, nfgcal=7, - 1 radinc=8, restor=9, stage=10, stglim=11, switch=12, - 2 toobig=2, xirc=13) -c/ -c/6 -c data afctol/31/, decfac/22/, dstnrm/2/, dst0/3/, dstsav/18/, -c 1 f/10/, fdif/11/, flstgd/12/, f0/13/, gtslst/14/, gtstep/4/, -c 2 incfac/23/, lmaxs/36/, nreduc/6/, plstgd/15/, preduc/7/, -c 3 radfac/16/, rdfcmn/24/, rdfcmx/25/, reldx/17/, rfctol/32/, -c 4 sctol/37/, stppar/5/, tuner1/26/, tuner2/27/, tuner3/28/, -c 5 xctol/33/, xftol/34/ -c/7 - parameter (afctol=31, decfac=22, dstnrm=2, dst0=3, dstsav=18, - 1 f=10, fdif=11, flstgd=12, f0=13, gtslst=14, gtstep=4, - 2 incfac=23, lmaxs=36, nreduc=6, plstgd=15, preduc=7, - 3 radfac=16, rdfcmn=24, rdfcmx=25, reldx=17, rfctol=32, - 4 sctol=37, stppar=5, tuner1=26, tuner2=27, tuner3=28, - 5 xctol=33, xftol=34) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - nfc = iv(nfcall) - iv(switch) = 0 - iv(restor) = 0 - rfac1 = one - goodx = .true. - i = iv(irc) - if (i .ge. 1 .and. i .le. 12) - 1 go to (20,30,10,10,40,280,220,220,220,220,220,170), i - iv(irc) = 13 - go to 999 -c -c *** initialize for new iteration *** -c - 10 iv(stage) = 1 - iv(radinc) = 0 - v(flstgd) = v(f0) - if (iv(toobig) .eq. 0) go to 110 - iv(stage) = -1 - iv(xirc) = i - go to 60 -c -c *** step was recomputed with new model or smaller radius *** -c *** first decide which *** -c - 20 if (iv(model) .ne. iv(mlstgd)) go to 30 -c *** old model retained, smaller radius tried *** -c *** do not consider any more new models this iteration *** - iv(stage) = iv(stglim) - iv(radinc) = -1 - go to 110 -c -c *** a new model is being tried. decide whether to keep it. *** -c - 30 iv(stage) = iv(stage) + 1 -c -c *** now we add the possibiltiy that step was recomputed with *** -c *** the same model, perhaps because of an oversized step. *** -c - 40 if (iv(stage) .gt. 0) go to 50 -c -c *** step was recomputed because it was too big. *** -c - if (iv(toobig) .ne. 0) go to 60 -c -c *** restore iv(stage) and pick up where we left off. *** -c - iv(stage) = -iv(stage) - i = iv(xirc) - go to (20, 30, 110, 110, 70), i -c - 50 if (iv(toobig) .eq. 0) go to 70 -c -c *** handle oversize step *** -c - if (iv(radinc) .gt. 0) go to 80 - iv(stage) = -iv(stage) - iv(xirc) = iv(irc) -c - 60 v(radfac) = v(decfac) - iv(radinc) = iv(radinc) - 1 - iv(irc) = 5 - iv(restor) = 1 - go to 999 -c - 70 if (v(f) .lt. v(flstgd)) go to 110 -c -c *** the new step is a loser. restore old model. *** -c - if (iv(model) .eq. iv(mlstgd)) go to 80 - iv(model) = iv(mlstgd) - iv(switch) = 1 -c -c *** restore step, etc. only if a previous step decreased v(f). -c - 80 if (v(flstgd) .ge. v(f0)) go to 110 - iv(restor) = 1 - v(f) = v(flstgd) - v(preduc) = v(plstgd) - v(gtstep) = v(gtslst) - if (iv(switch) .eq. 0) rfac1 = v(dstnrm) / v(dstsav) - v(dstnrm) = v(dstsav) - nfc = iv(nfgcal) - goodx = .false. -c - 110 v(fdif) = v(f0) - v(f) - if (v(fdif) .gt. v(tuner2) * v(preduc)) go to 140 - if(iv(radinc).gt.0) go to 140 -c -c *** no (or only a trivial) function decrease -c *** -- so try new model or smaller radius -c - if (v(f) .lt. v(f0)) go to 120 - iv(mlstgd) = iv(model) - v(flstgd) = v(f) - v(f) = v(f0) - iv(restor) = 1 - go to 130 - 120 iv(nfgcal) = nfc - 130 iv(irc) = 1 - if (iv(stage) .lt. iv(stglim)) go to 160 - iv(irc) = 5 - iv(radinc) = iv(radinc) - 1 - go to 160 -c -c *** nontrivial function decrease achieved *** -c - 140 iv(nfgcal) = nfc - rfac1 = one - v(dstsav) = v(dstnrm) - if (v(fdif) .gt. v(preduc)*v(tuner1)) go to 190 -c -c *** decrease was much less than predicted -- either change models -c *** or accept step with decreased radius. -c - if (iv(stage) .ge. iv(stglim)) go to 150 -c *** consider switching models *** - iv(irc) = 2 - go to 160 -c -c *** accept step with decreased radius *** -c - 150 iv(irc) = 4 -c -c *** set v(radfac) to fletcher*s decrease factor *** -c - 160 iv(xirc) = iv(irc) - emax = v(gtstep) + v(fdif) - v(radfac) = half * rfac1 - if (emax .lt. v(gtstep)) v(radfac) = rfac1 * dmax1(v(rdfcmn), - 1 half * v(gtstep)/emax) -c -c *** do false convergence test *** -c - 170 if (v(reldx) .le. v(xftol)) go to 180 - iv(irc) = iv(xirc) - if (v(f) .lt. v(f0)) go to 200 - go to 230 -c - 180 iv(irc) = 12 - go to 240 -c -c *** handle good function decrease *** -c - 190 if (v(fdif) .lt. (-v(tuner3) * v(gtstep))) go to 210 -c -c *** increasing radius looks worthwhile. see if we just -c *** recomputed step with a decreased radius or restored step -c *** after recomputing it with a larger radius. -c - if (iv(radinc) .lt. 0) go to 210 - if (iv(restor) .eq. 1) go to 210 -c -c *** we did not. try a longer step unless this was a newton -c *** step. -c - v(radfac) = v(rdfcmx) - gts = v(gtstep) - if (v(fdif) .lt. (half/v(radfac) - one) * gts) - 1 v(radfac) = dmax1(v(incfac), half*gts/(gts + v(fdif))) - iv(irc) = 4 - if (v(stppar) .eq. zero) go to 230 - if (v(dst0) .ge. zero .and. (v(dst0) .lt. two*v(dstnrm) - 1 .or. v(nreduc) .lt. onep2*v(fdif))) go to 230 -c *** step was not a newton step. recompute it with -c *** a larger radius. - iv(irc) = 5 - iv(radinc) = iv(radinc) + 1 -c -c *** save values corresponding to good step *** -c - 200 v(flstgd) = v(f) - iv(mlstgd) = iv(model) - if (iv(restor) .ne. 1) iv(restor) = 2 - v(dstsav) = v(dstnrm) - iv(nfgcal) = nfc - v(plstgd) = v(preduc) - v(gtslst) = v(gtstep) - go to 230 -c -c *** accept step with radius unchanged *** -c - 210 v(radfac) = one - iv(irc) = 3 - go to 230 -c -c *** come here for a restart after convergence *** -c - 220 iv(irc) = iv(xirc) - if (v(dstsav) .ge. zero) go to 240 - iv(irc) = 12 - go to 240 -c -c *** perform convergence tests *** -c - 230 iv(xirc) = iv(irc) - 240 if (iv(restor) .eq. 1 .and. v(flstgd) .lt. v(f0)) iv(restor) = 3 - if (half * v(fdif) .gt. v(preduc)) go to 999 - emax = v(rfctol) * dabs(v(f0)) - emaxs = v(sctol) * dabs(v(f0)) - if (v(dstnrm) .gt. v(lmaxs) .and. v(preduc) .le. emaxs) - 1 iv(irc) = 11 - if (v(dst0) .lt. zero) go to 250 - i = 0 - if ((v(nreduc) .gt. zero .and. v(nreduc) .le. emax) .or. - 1 (v(nreduc) .eq. zero. and. v(preduc) .eq. zero)) i = 2 - if (v(stppar) .eq. zero .and. v(reldx) .le. v(xctol) - 1 .and. goodx) i = i + 1 - if (i .gt. 0) iv(irc) = i + 6 -c -c *** consider recomputing step of length v(lmaxs) for singular -c *** convergence test. -c - 250 if (iv(irc) .gt. 5 .and. iv(irc) .ne. 12) go to 999 - if (v(dstnrm) .gt. v(lmaxs)) go to 260 - if (v(preduc) .ge. emaxs) go to 999 - if (v(dst0) .le. zero) go to 270 - if (half * v(dst0) .le. v(lmaxs)) go to 999 - go to 270 - 260 if (half * v(dstnrm) .le. v(lmaxs)) go to 999 - xmax = v(lmaxs) / v(dstnrm) - if (xmax * (two - xmax) * v(preduc) .ge. emaxs) go to 999 - 270 if (v(nreduc) .lt. zero) go to 290 -c -c *** recompute v(preduc) for use in singular convergence test *** -c - v(gtslst) = v(gtstep) - v(dstsav) = v(dstnrm) - if (iv(irc) .eq. 12) v(dstsav) = -v(dstsav) - v(plstgd) = v(preduc) - i = iv(restor) - iv(restor) = 2 - if (i .eq. 3) iv(restor) = 0 - iv(irc) = 6 - go to 999 -c -c *** perform singular convergence test with recomputed v(preduc) *** -c - 280 v(gtstep) = v(gtslst) - v(dstnrm) = dabs(v(dstsav)) - iv(irc) = iv(xirc) - if (v(dstsav) .le. zero) iv(irc) = 12 - v(nreduc) = -v(preduc) - v(preduc) = v(plstgd) - iv(restor) = 3 - 290 if (-v(nreduc) .le. v(sctol) * dabs(v(f0))) iv(irc) = 11 -c - 999 return -c -c *** last card of assst follows *** - end - subroutine deflt(alg, iv, liv, lv, v) -c -c *** supply ***sol (version 2.3) default values to iv and v *** -c -c *** alg = 1 means regression constants. -c *** alg = 2 means general unconstrained optimization constants. -c - integer liv, l - integer alg, iv(liv) - double precision v(lv) -c - external imdcon, vdflt - integer imdcon -c imdcon... returns machine-dependent integer constants. -c vdflt.... provides default values to v. -c - integer miv, m - integer miniv(2), minv(2) -c -c *** subscripts for iv *** -c - integer algsav, covprt, covreq, dtype, hc, ierr, inith, inits, - 1 ipivot, ivneed, lastiv, lastv, lmat, mxfcal, mxiter, - 2 nfcov, ngcov, nvdflt, outlev, parprt, parsav, perm, - 3 prunit, qrtyp, rdreq, rmat, solprt, statpr, vneed, - 4 vsave, x0prt -c -c *** iv subscript values *** -c -c/6 -c data algsav/51/, covprt/14/, covreq/15/, dtype/16/, hc/71/, -c 1 ierr/75/, inith/25/, inits/25/, ipivot/76/, ivneed/3/, -c 2 lastiv/44/, lastv/45/, lmat/42/, mxfcal/17/, mxiter/18/, -c 3 nfcov/52/, ngcov/53/, nvdflt/50/, outlev/19/, parprt/20/, -c 4 parsav/49/, perm/58/, prunit/21/, qrtyp/80/, rdreq/57/, -c 5 rmat/78/, solprt/22/, statpr/23/, vneed/4/, vsave/60/, -c 6 x0prt/24/ -c/7 - parameter (algsav=51, covprt=14, covreq=15, dtype=16, hc=71, - 1 ierr=75, inith=25, inits=25, ipivot=76, ivneed=3, - 2 lastiv=44, lastv=45, lmat=42, mxfcal=17, mxiter=18, - 3 nfcov=52, ngcov=53, nvdflt=50, outlev=19, parprt=20, - 4 parsav=49, perm=58, prunit=21, qrtyp=80, rdreq=57, - 5 rmat=78, solprt=22, statpr=23, vneed=4, vsave=60, - 6 x0prt=24) -c/ - data miniv(1)/80/, miniv(2)/59/, minv(1)/98/, minv(2)/71/ -c -c------------------------------- body -------------------------------- -c - if (alg .lt. 1 .or. alg .gt. 2) go to 40 - miv = miniv(alg) - if (liv .lt. miv) go to 20 - mv = minv(alg) - if (lv .lt. mv) go to 30 - call vdflt(alg, lv, v) - iv(1) = 12 - iv(algsav) = alg - iv(ivneed) = 0 - iv(lastiv) = miv - iv(lastv) = mv - iv(lmat) = mv + 1 - iv(mxfcal) = 200 - iv(mxiter) = 150 - iv(outlev) = 1 - iv(parprt) = 1 - iv(perm) = miv + 1 - iv(prunit) = imdcon(1) - iv(solprt) = 1 - iv(statpr) = 1 - iv(vneed) = 0 - iv(x0prt) = 1 -c - if (alg .ge. 2) go to 10 -c -c *** regression values -c - iv(covprt) = 3 - iv(covreq) = 1 - iv(dtype) = 1 - iv(hc) = 0 - iv(ierr) = 0 - iv(inits) = 0 - iv(ipivot) = 0 - iv(nvdflt) = 32 - iv(parsav) = 67 - iv(qrtyp) = 1 - iv(rdreq) = 3 - iv(rmat) = 0 - iv(vsave) = 58 - go to 999 -c -c *** general optimization values -c - 10 iv(dtype) = 0 - iv(inith) = 1 - iv(nfcov) = 0 - iv(ngcov) = 0 - iv(nvdflt) = 25 - iv(parsav) = 47 - go to 999 -c - 20 iv(1) = 15 - go to 999 -c - 30 iv(1) = 16 - go to 999 -c - 40 iv(1) = 67 -c - 999 return -c *** last card of deflt follows *** - end - double precision function dotprd(p, x, y) -c -c *** return the inner product of the p-vectors x and y. *** -c - integer p - double precision x(p), y(p) -c - integer i - double precision one, sqteta, t, zero -c/+ - double precision dmax1, dabs -c/ - external rmdcon - double precision rmdcon -c -c *** rmdcon(2) returns a machine-dependent constant, sqteta, which -c *** is slightly larger than the smallest positive number that -c *** can be squared without underflowing. -c -c/6 -c data one/1.d+0/, sqteta/0.d+0/, zero/0.d+0/ -c/7 - parameter (one=1.d+0, zero=0.d+0) - data sqteta/0.d+0/ -c/ -c - dotprd = zero - if (p .le. 0) go to 999 -crc if (sqteta .eq. zero) sqteta = rmdcon(2) - do 20 i = 1, p -crc t = dmax1(dabs(x(i)), dabs(y(i))) -crc if (t .gt. one) go to 10 -crc if (t .lt. sqteta) go to 20 -crc t = (x(i)/sqteta)*y(i) -crc if (dabs(t) .lt. sqteta) go to 20 - 10 dotprd = dotprd + x(i)*y(i) - 20 continue -c - 999 return -c *** last card of dotprd follows *** - end - subroutine itsum(d, g, iv, liv, lv, p, v, x) -c -c *** print iteration summary for ***sol (version 2.3) *** -c -c *** parameter declarations *** -c - integer liv, lv, p - integer iv(liv) - double precision d(p), g(p), v(lv), x(p) -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** local variables *** -c - integer alg, i, iv1, m, nf, ng, ol, pu -c/6 -c real model1(6), model2(6) -c/7 - character*4 model1(6), model2(6) -c/ - double precision nreldf, oldf, preldf, reldf, zero -c -c *** intrinsic functions *** -c/+ - integer iabs - double precision dabs, dmax1 -c/ -c *** no external functions or subroutines *** -c -c *** subscripts for iv and v *** -c - integer algsav, dstnrm, f, fdif, f0, needhd, nfcall, nfcov, ngcov, - 1 ngcall, niter, nreduc, outlev, preduc, prntit, prunit, - 2 reldx, solprt, statpr, stppar, sused, x0prt -c -c *** iv subscript values *** -c -c/6 -c data algsav/51/, needhd/36/, nfcall/6/, nfcov/52/, ngcall/30/, -c 1 ngcov/53/, niter/31/, outlev/19/, prntit/39/, prunit/21/, -c 2 solprt/22/, statpr/23/, sused/64/, x0prt/24/ -c/7 - parameter (algsav=51, needhd=36, nfcall=6, nfcov=52, ngcall=30, - 1 ngcov=53, niter=31, outlev=19, prntit=39, prunit=21, - 2 solprt=22, statpr=23, sused=64, x0prt=24) -c/ -c -c *** v subscript values *** -c -c/6 -c data dstnrm/2/, f/10/, f0/13/, fdif/11/, nreduc/6/, preduc/7/, -c 1 reldx/17/, stppar/5/ -c/7 - parameter (dstnrm=2, f=10, f0=13, fdif=11, nreduc=6, preduc=7, - 1 reldx=17, stppar=5) -c/ -c -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c/6 -c data model1(1)/4h /, model1(2)/4h /, model1(3)/4h /, -c 1 model1(4)/4h /, model1(5)/4h g /, model1(6)/4h s /, -c 2 model2(1)/4h g /, model2(2)/4h s /, model2(3)/4hg-s /, -c 3 model2(4)/4hs-g /, model2(5)/4h-s-g/, model2(6)/4h-g-s/ -c/7 - data model1/' ',' ',' ',' ',' g ',' s '/, - 1 model2/' g ',' s ','g-s ','s-g ','-s-g','-g-s'/ -c/ -c -c------------------------------- body -------------------------------- -c - pu = iv(prunit) - if (pu .eq. 0) go to 999 - iv1 = iv(1) - if (iv1 .gt. 62) iv1 = iv1 - 51 - ol = iv(outlev) - alg = iv(algsav) - if (iv1 .lt. 2 .or. iv1 .gt. 15) go to 370 - if (iv1 .ge. 12) go to 120 - if (iv1 .eq. 2 .and. iv(niter) .eq. 0) go to 390 - if (ol .eq. 0) go to 120 - if (iv1 .ge. 10 .and. iv(prntit) .eq. 0) go to 120 - if (iv1 .gt. 2) go to 10 - iv(prntit) = iv(prntit) + 1 - if (iv(prntit) .lt. iabs(ol)) go to 999 - 10 nf = iv(nfcall) - iabs(iv(nfcov)) - iv(prntit) = 0 - reldf = zero - preldf = zero - oldf = dmax1(dabs(v(f0)), dabs(v(f))) - if (oldf .le. zero) go to 20 - reldf = v(fdif) / oldf - preldf = v(preduc) / oldf - 20 if (ol .gt. 0) go to 60 -c -c *** print short summary line *** -c - if (iv(needhd) .eq. 1 .and. alg .eq. 1) write(pu,30) - 30 format(/10h it nf,6x,1hf,7x,5hreldf,3x,6hpreldf,3x,5hreldx, - 1 2x,13hmodel stppar) - if (iv(needhd) .eq. 1 .and. alg .eq. 2) write(pu,40) - 40 format(/11h it nf,7x,1hf,8x,5hreldf,4x,6hpreldf,4x,5hreldx, - 1 3x,6hstppar) - iv(needhd) = 0 - if (alg .eq. 2) go to 50 - m = iv(sused) - write(pu,100) iv(niter), nf, v(f), reldf, preldf, v(reldx), - 1 model1(m), model2(m), v(stppar) - go to 120 -c - 50 write(pu,110) iv(niter), nf, v(f), reldf, preldf, v(reldx), - 1 v(stppar) - go to 120 -c -c *** print long summary line *** -c - 60 if (iv(needhd) .eq. 1 .and. alg .eq. 1) write(pu,70) - 70 format(/11h it nf,6x,1hf,7x,5hreldf,3x,6hpreldf,3x,5hreldx, - 1 2x,13hmodel stppar,2x,6hd*step,2x,7hnpreldf) - if (iv(needhd) .eq. 1 .and. alg .eq. 2) write(pu,80) - 80 format(/11h it nf,7x,1hf,8x,5hreldf,4x,6hpreldf,4x,5hreldx, - 1 3x,6hstppar,3x,6hd*step,3x,7hnpreldf) - iv(needhd) = 0 - nreldf = zero - if (oldf .gt. zero) nreldf = v(nreduc) / oldf - if (alg .eq. 2) go to 90 - m = iv(sused) - write(pu,100) iv(niter), nf, v(f), reldf, preldf, v(reldx), - 1 model1(m), model2(m), v(stppar), v(dstnrm), nreldf - go to 120 -c - 90 write(pu,110) iv(niter), nf, v(f), reldf, preldf, - 1 v(reldx), v(stppar), v(dstnrm), nreldf - 100 format(i6,i5,d10.3,2d9.2,d8.1,a3,a4,2d8.1,d9.2) - 110 format(i6,i5,d11.3,2d10.2,3d9.1,d10.2) -c - 120 if (iv(statpr) .lt. 0) go to 430 - go to (999, 999, 130, 150, 170, 190, 210, 230, 250, 270, 290, 310, - 1 330, 350, 520), iv1 -c - 130 write(pu,140) - 140 format(/26h ***** x-convergence *****) - go to 430 -c - 150 write(pu,160) - 160 format(/42h ***** relative function convergence *****) - go to 430 -c - 170 write(pu,180) - 180 format(/49h ***** x- and relative function convergence *****) - go to 430 -c - 190 write(pu,200) - 200 format(/42h ***** absolute function convergence *****) - go to 430 -c - 210 write(pu,220) - 220 format(/33h ***** singular convergence *****) - go to 430 -c - 230 write(pu,240) - 240 format(/30h ***** false convergence *****) - go to 430 -c - 250 write(pu,260) - 260 format(/38h ***** function evaluation limit *****) - go to 430 -c - 270 write(pu,280) - 280 format(/28h ***** iteration limit *****) - go to 430 -c - 290 write(pu,300) - 300 format(/18h ***** stopx *****) - go to 430 -c - 310 write(pu,320) - 320 format(/44h ***** initial f(x) cannot be computed *****) -c - go to 390 -c - 330 write(pu,340) - 340 format(/37h ***** bad parameters to assess *****) - go to 999 -c - 350 write(pu,360) - 360 format(/43h ***** gradient could not be computed *****) - if (iv(niter) .gt. 0) go to 480 - go to 390 -c - 370 write(pu,380) iv(1) - 380 format(/14h ***** iv(1) =,i5,6h *****) - go to 999 -c -c *** initial call on itsum *** -c - 390 if (iv(x0prt) .ne. 0) write(pu,400) (i, x(i), d(i), i = 1, p) - 400 format(/23h i initial x(i),8x,4hd(i)//(1x,i5,d17.6,d14.3)) -c *** the following are to avoid undefined variables when the -c *** function evaluation limit is 1... - v(dstnrm) = zero - v(fdif) = zero - v(nreduc) = zero - v(preduc) = zero - v(reldx) = zero - if (iv1 .ge. 12) go to 999 - iv(needhd) = 0 - iv(prntit) = 0 - if (ol .eq. 0) go to 999 - if (ol .lt. 0 .and. alg .eq. 1) write(pu,30) - if (ol .lt. 0 .and. alg .eq. 2) write(pu,40) - if (ol .gt. 0 .and. alg .eq. 1) write(pu,70) - if (ol .gt. 0 .and. alg .eq. 2) write(pu,80) - if (alg .eq. 1) write(pu,410) v(f) - if (alg .eq. 2) write(pu,420) v(f) - 410 format(/11h 0 1,d10.3) -c365 format(/11h 0 1,e11.3) - 420 format(/11h 0 1,d11.3) - go to 999 -c -c *** print various information requested on solution *** -c - 430 iv(needhd) = 1 - if (iv(statpr) .eq. 0) go to 480 - oldf = dmax1(dabs(v(f0)), dabs(v(f))) - preldf = zero - nreldf = zero - if (oldf .le. zero) go to 440 - preldf = v(preduc) / oldf - nreldf = v(nreduc) / oldf - 440 nf = iv(nfcall) - iv(nfcov) - ng = iv(ngcall) - iv(ngcov) - write(pu,450) v(f), v(reldx), nf, ng, preldf, nreldf - 450 format(/9h function,d17.6,8h reldx,d17.3/12h func. evals, - 1 i8,9x,11hgrad. evals,i8/7h preldf,d16.3,6x,7hnpreldf,d15.3) -c - if (iv(nfcov) .gt. 0) write(pu,460) iv(nfcov) - 460 format(/1x,i4,50h extra func. evals for covariance and diagnost - 1ics.) - if (iv(ngcov) .gt. 0) write(pu,470) iv(ngcov) - 470 format(1x,i4,50h extra grad. evals for covariance and diagnosti - 1cs.) -c - 480 if (iv(solprt) .eq. 0) go to 999 - iv(needhd) = 1 - write(pu,490) - 490 format(/22h i final x(i),8x,4hd(i),10x,4hg(i)/) - do 500 i = 1, p - write(pu,510) i, x(i), d(i), g(i) - 500 continue - 510 format(1x,i5,d16.6,2d14.3) - go to 999 -c - 520 write(pu,530) - 530 format(/24h inconsistent dimensions) - 999 return -c *** last card of itsum follows *** - end - subroutine litvmu(n, x, l, y) -c -c *** solve (l**t)*x = y, where l is an n x n lower triangular -c *** matrix stored compactly by rows. x and y may occupy the same -c *** storage. *** -c - integer n -cal double precision x(n), l(1), y(n) - double precision x(n), l(n*(n+1)/2), y(n) - integer i, ii, ij, im1, i0, j, np1 - double precision xi, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - do 10 i = 1, n - 10 x(i) = y(i) - np1 = n + 1 - i0 = n*(n+1)/2 - do 30 ii = 1, n - i = np1 - ii - xi = x(i)/l(i0) - x(i) = xi - if (i .le. 1) go to 999 - i0 = i0 - i - if (xi .eq. zero) go to 30 - im1 = i - 1 - do 20 j = 1, im1 - ij = i0 + j - x(j) = x(j) - xi*l(ij) - 20 continue - 30 continue - 999 return -c *** last card of litvmu follows *** - end - subroutine livmul(n, x, l, y) -c -c *** solve l*x = y, where l is an n x n lower triangular -c *** matrix stored compactly by rows. x and y may occupy the same -c *** storage. *** -c - integer n -cal double precision x(n), l(1), y(n) - double precision x(n), l(n*(n+1)/2), y(n) - external dotprd - double precision dotprd - integer i, j, k - double precision t, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - do 10 k = 1, n - if (y(k) .ne. zero) go to 20 - x(k) = zero - 10 continue - go to 999 - 20 j = k*(k+1)/2 - x(k) = y(k) / l(j) - if (k .ge. n) go to 999 - k = k + 1 - do 30 i = k, n - t = dotprd(i-1, l(j+1), x) - j = j + i - x(i) = (y(i) - t)/l(j) - 30 continue - 999 return -c *** last card of livmul follows *** - end - subroutine parck(alg, d, iv, liv, lv, n, v) -c -c *** check ***sol (version 2.3) parameters, print changed values *** -c -c *** alg = 1 for regression, alg = 2 for general unconstrained opt. -c - integer alg, liv, lv, n - integer iv(liv) - double precision d(n), v(lv) -c - external rmdcon, vcopy, vdflt - double precision rmdcon -c rmdcon -- returns machine-dependent constants. -c vcopy -- copies one vector to another. -c vdflt -- supplies default parameter values to v alone. -c/+ - integer max0 -c/ -c -c *** local variables *** -c - integer i, ii, iv1, j, k, l, m, miv1, miv2, ndfalt, parsv1, pu - integer ijmp, jlim(2), miniv(2), ndflt(2) -c/6 -c integer varnm(2), sh(2) -c real cngd(3), dflt(3), vn(2,34), which(3) -c/7 - character*1 varnm(2), sh(2) - character*4 cngd(3), dflt(3), vn(2,34), which(3) -c/ - double precision big, machep, tiny, vk, vm(34), vx(34), zero -c -c *** iv and v subscripts *** -c - integer algsav, dinit, dtype, dtype0, epslon, inits, ivneed, - 1 lastiv, lastv, lmat, nextiv, nextv, nvdflt, oldn, - 2 parprt, parsav, perm, prunit, vneed -c -c -c/6 -c data algsav/51/, dinit/38/, dtype/16/, dtype0/54/, epslon/19/, -c 1 inits/25/, ivneed/3/, lastiv/44/, lastv/45/, lmat/42/, -c 2 nextiv/46/, nextv/47/, nvdflt/50/, oldn/38/, parprt/20/, -c 3 parsav/49/, perm/58/, prunit/21/, vneed/4/ -c/7 - parameter (algsav=51, dinit=38, dtype=16, dtype0=54, epslon=19, - 1 inits=25, ivneed=3, lastiv=44, lastv=45, lmat=42, - 2 nextiv=46, nextv=47, nvdflt=50, oldn=38, parprt=20, - 3 parsav=49, perm=58, prunit=21, vneed=4) - save big, machep, tiny -c/ -c - data big/0.d+0/, machep/-1.d+0/, tiny/1.d+0/, zero/0.d+0/ -c/6 -c data vn(1,1),vn(2,1)/4hepsl,4hon../ -c data vn(1,2),vn(2,2)/4hphmn,4hfc../ -c data vn(1,3),vn(2,3)/4hphmx,4hfc../ -c data vn(1,4),vn(2,4)/4hdecf,4hac../ -c data vn(1,5),vn(2,5)/4hincf,4hac../ -c data vn(1,6),vn(2,6)/4hrdfc,4hmn../ -c data vn(1,7),vn(2,7)/4hrdfc,4hmx../ -c data vn(1,8),vn(2,8)/4htune,4hr1../ -c data vn(1,9),vn(2,9)/4htune,4hr2../ -c data vn(1,10),vn(2,10)/4htune,4hr3../ -c data vn(1,11),vn(2,11)/4htune,4hr4../ -c data vn(1,12),vn(2,12)/4htune,4hr5../ -c data vn(1,13),vn(2,13)/4hafct,4hol../ -c data vn(1,14),vn(2,14)/4hrfct,4hol../ -c data vn(1,15),vn(2,15)/4hxcto,4hl.../ -c data vn(1,16),vn(2,16)/4hxfto,4hl.../ -c data vn(1,17),vn(2,17)/4hlmax,4h0.../ -c data vn(1,18),vn(2,18)/4hlmax,4hs.../ -c data vn(1,19),vn(2,19)/4hscto,4hl.../ -c data vn(1,20),vn(2,20)/4hdini,4ht.../ -c data vn(1,21),vn(2,21)/4hdtin,4hit../ -c data vn(1,22),vn(2,22)/4hd0in,4hit../ -c data vn(1,23),vn(2,23)/4hdfac,4h..../ -c data vn(1,24),vn(2,24)/4hdltf,4hdc../ -c data vn(1,25),vn(2,25)/4hdltf,4hdj../ -c data vn(1,26),vn(2,26)/4hdelt,4ha0../ -c data vn(1,27),vn(2,27)/4hfuzz,4h..../ -c data vn(1,28),vn(2,28)/4hrlim,4hit../ -c data vn(1,29),vn(2,29)/4hcosm,4hin../ -c data vn(1,30),vn(2,30)/4hhube,4hrc../ -c data vn(1,31),vn(2,31)/4hrspt,4hol../ -c data vn(1,32),vn(2,32)/4hsigm,4hin../ -c data vn(1,33),vn(2,33)/4heta0,4h..../ -c data vn(1,34),vn(2,34)/4hbias,4h..../ -c/7 - data vn(1,1),vn(2,1)/'epsl','on..'/ - data vn(1,2),vn(2,2)/'phmn','fc..'/ - data vn(1,3),vn(2,3)/'phmx','fc..'/ - data vn(1,4),vn(2,4)/'decf','ac..'/ - data vn(1,5),vn(2,5)/'incf','ac..'/ - data vn(1,6),vn(2,6)/'rdfc','mn..'/ - data vn(1,7),vn(2,7)/'rdfc','mx..'/ - data vn(1,8),vn(2,8)/'tune','r1..'/ - data vn(1,9),vn(2,9)/'tune','r2..'/ - data vn(1,10),vn(2,10)/'tune','r3..'/ - data vn(1,11),vn(2,11)/'tune','r4..'/ - data vn(1,12),vn(2,12)/'tune','r5..'/ - data vn(1,13),vn(2,13)/'afct','ol..'/ - data vn(1,14),vn(2,14)/'rfct','ol..'/ - data vn(1,15),vn(2,15)/'xcto','l...'/ - data vn(1,16),vn(2,16)/'xfto','l...'/ - data vn(1,17),vn(2,17)/'lmax','0...'/ - data vn(1,18),vn(2,18)/'lmax','s...'/ - data vn(1,19),vn(2,19)/'scto','l...'/ - data vn(1,20),vn(2,20)/'dini','t...'/ - data vn(1,21),vn(2,21)/'dtin','it..'/ - data vn(1,22),vn(2,22)/'d0in','it..'/ - data vn(1,23),vn(2,23)/'dfac','....'/ - data vn(1,24),vn(2,24)/'dltf','dc..'/ - data vn(1,25),vn(2,25)/'dltf','dj..'/ - data vn(1,26),vn(2,26)/'delt','a0..'/ - data vn(1,27),vn(2,27)/'fuzz','....'/ - data vn(1,28),vn(2,28)/'rlim','it..'/ - data vn(1,29),vn(2,29)/'cosm','in..'/ - data vn(1,30),vn(2,30)/'hube','rc..'/ - data vn(1,31),vn(2,31)/'rspt','ol..'/ - data vn(1,32),vn(2,32)/'sigm','in..'/ - data vn(1,33),vn(2,33)/'eta0','....'/ - data vn(1,34),vn(2,34)/'bias','....'/ -c/ -c - data vm(1)/1.0d-3/, vm(2)/-0.99d+0/, vm(3)/1.0d-3/, vm(4)/1.0d-2/, - 1 vm(5)/1.2d+0/, vm(6)/1.d-2/, vm(7)/1.2d+0/, vm(8)/0.d+0/, - 2 vm(9)/0.d+0/, vm(10)/1.d-3/, vm(11)/-1.d+0/, vm(13)/0.d+0/, - 3 vm(15)/0.d+0/, vm(16)/0.d+0/, vm(19)/0.d+0/, vm(20)/-10.d+0/, - 4 vm(21)/0.d+0/, vm(22)/0.d+0/, vm(23)/0.d+0/, vm(27)/1.01d+0/, - 5 vm(28)/1.d+10/, vm(30)/0.d+0/, vm(31)/0.d+0/, vm(32)/0.d+0/, - 6 vm(34)/0.d+0/ - data vx(1)/0.9d+0/, vx(2)/-1.d-3/, vx(3)/1.d+1/, vx(4)/0.8d+0/, - 1 vx(5)/1.d+2/, vx(6)/0.8d+0/, vx(7)/1.d+2/, vx(8)/0.5d+0/, - 2 vx(9)/0.5d+0/, vx(10)/1.d+0/, vx(11)/1.d+0/, vx(14)/0.1d+0/, - 3 vx(15)/1.d+0/, vx(16)/1.d+0/, vx(19)/1.d+0/, vx(23)/1.d+0/, - 4 vx(24)/1.d+0/, vx(25)/1.d+0/, vx(26)/1.d+0/, vx(27)/1.d+10/, - 5 vx(29)/1.d+0/, vx(31)/1.d+0/, vx(32)/1.d+0/, vx(33)/1.d+0/, - 6 vx(34)/1.d+0/ -c -c/6 -c data varnm(1)/1hp/, varnm(2)/1hn/, sh(1)/1hs/, sh(2)/1hh/ -c data cngd(1),cngd(2),cngd(3)/4h---c,4hhang,4hed v/, -c 1 dflt(1),dflt(2),dflt(3)/4hnond,4hefau,4hlt v/ -c/7 - data varnm(1)/'p'/, varnm(2)/'n'/, sh(1)/'s'/, sh(2)/'h'/ - data cngd(1),cngd(2),cngd(3)/'---c','hang','ed v'/, - 1 dflt(1),dflt(2),dflt(3)/'nond','efau','lt v'/ -c/ - data ijmp/33/, jlim(1)/0/, jlim(2)/24/, ndflt(1)/32/, ndflt(2)/25/ - data miniv(1)/80/, miniv(2)/59/ -c -c............................... body ................................ -c - pu = 0 - if (prunit .le. liv) pu = iv(prunit) - if (alg .lt. 1 .or. alg .gt. 2) go to 340 - if (iv(1) .eq. 0) call deflt(alg, iv, liv, lv, v) - iv1 = iv(1) - if (iv1 .ne. 13 .and. iv1 .ne. 12) go to 10 - miv1 = miniv(alg) - if (perm .le. liv) miv1 = max0(miv1, iv(perm) - 1) - if (ivneed .le. liv) miv2 = miv1 + max0(iv(ivneed), 0) - if (lastiv .le. liv) iv(lastiv) = miv2 - if (liv .lt. miv1) go to 300 - iv(ivneed) = 0 - iv(lastv) = max0(iv(vneed), 0) + iv(lmat) - 1 - iv(vneed) = 0 - if (liv .lt. miv2) go to 300 - if (lv .lt. iv(lastv)) go to 320 - 10 if (alg .eq. iv(algsav)) go to 30 - if (pu .ne. 0) write(pu,20) alg, iv(algsav) - 20 format(/39h the first parameter to deflt should be,i3, - 1 12h rather than,i3) - iv(1) = 82 - go to 999 - 30 if (iv1 .lt. 12 .or. iv1 .gt. 14) go to 60 - if (n .ge. 1) go to 50 - iv(1) = 81 - if (pu .eq. 0) go to 999 - write(pu,40) varnm(alg), n - 40 format(/8h /// bad,a1,2h =,i5) - go to 999 - 50 if (iv1 .ne. 14) iv(nextiv) = iv(perm) - if (iv1 .ne. 14) iv(nextv) = iv(lmat) - if (iv1 .eq. 13) go to 999 - k = iv(parsav) - epslon - call vdflt(alg, lv-k, v(k+1)) - iv(dtype0) = 2 - alg - iv(oldn) = n - which(1) = dflt(1) - which(2) = dflt(2) - which(3) = dflt(3) - go to 110 - 60 if (n .eq. iv(oldn)) go to 80 - iv(1) = 17 - if (pu .eq. 0) go to 999 - write(pu,70) varnm(alg), iv(oldn), n - 70 format(/5h /// ,1a1,14h changed from ,i5,4h to ,i5) - go to 999 -c - 80 if (iv1 .le. 11 .and. iv1 .ge. 1) go to 100 - iv(1) = 80 - if (pu .ne. 0) write(pu,90) iv1 - 90 format(/13h /// iv(1) =,i5,28h should be between 0 and 14.) - go to 999 -c - 100 which(1) = cngd(1) - which(2) = cngd(2) - which(3) = cngd(3) -c - 110 if (iv1 .eq. 14) iv1 = 12 - if (big .gt. tiny) go to 120 - tiny = rmdcon(1) - machep = rmdcon(3) - big = rmdcon(6) - vm(12) = machep - vx(12) = big - vx(13) = big - vm(14) = machep - vm(17) = tiny - vx(17) = big - vm(18) = tiny - vx(18) = big - vx(20) = big - vx(21) = big - vx(22) = big - vm(24) = machep - vm(25) = machep - vm(26) = machep - vx(28) = rmdcon(5) - vm(29) = machep - vx(30) = big - vm(33) = machep - 120 m = 0 - i = 1 - j = jlim(alg) - k = epslon - ndfalt = ndflt(alg) - do 150 l = 1, ndfalt - vk = v(k) - if (vk .ge. vm(i) .and. vk .le. vx(i)) go to 140 - m = k - if (pu .ne. 0) write(pu,130) vn(1,i), vn(2,i), k, vk, - 1 vm(i), vx(i) - 130 format(/6h /// ,2a4,5h.. v(,i2,3h) =,d11.3,7h should, - 1 11h be between,d11.3,4h and,d11.3) - 140 k = k + 1 - i = i + 1 - if (i .eq. j) i = ijmp - 150 continue -c - if (iv(nvdflt) .eq. ndfalt) go to 170 - iv(1) = 51 - if (pu .eq. 0) go to 999 - write(pu,160) iv(nvdflt), ndfalt - 160 format(/13h iv(nvdflt) =,i5,13h rather than ,i5) - go to 999 - 170 if ((iv(dtype) .gt. 0 .or. v(dinit) .gt. zero) .and. iv1 .eq. 12) - 1 go to 200 - do 190 i = 1, n - if (d(i) .gt. zero) go to 190 - m = 18 - if (pu .ne. 0) write(pu,180) i, d(i) - 180 format(/8h /// d(,i3,3h) =,d11.3,19h should be positive) - 190 continue - 200 if (m .eq. 0) go to 210 - iv(1) = m - go to 999 -c - 210 if (pu .eq. 0 .or. iv(parprt) .eq. 0) go to 999 - if (iv1 .ne. 12 .or. iv(inits) .eq. alg-1) go to 230 - m = 1 - write(pu,220) sh(alg), iv(inits) - 220 format(/22h nondefault values..../5h init,a1,14h..... iv(25) =, - 1 i3) - 230 if (iv(dtype) .eq. iv(dtype0)) go to 250 - if (m .eq. 0) write(pu,260) which - m = 1 - write(pu,240) iv(dtype) - 240 format(20h dtype..... iv(16) =,i3) - 250 i = 1 - j = jlim(alg) - k = epslon - l = iv(parsav) - ndfalt = ndflt(alg) - do 290 ii = 1, ndfalt - if (v(k) .eq. v(l)) go to 280 - if (m .eq. 0) write(pu,260) which - 260 format(/1h ,3a4,9halues..../) - m = 1 - write(pu,270) vn(1,i), vn(2,i), k, v(k) - 270 format(1x,2a4,5h.. v(,i2,3h) =,d15.7) - 280 k = k + 1 - l = l + 1 - i = i + 1 - if (i .eq. j) i = ijmp - 290 continue -c - iv(dtype0) = iv(dtype) - parsv1 = iv(parsav) - call vcopy(iv(nvdflt), v(parsv1), v(epslon)) - go to 999 -c - 300 iv(1) = 15 - if (pu .eq. 0) go to 999 - write(pu,310) liv, miv2 - 310 format(/10h /// liv =,i5,17h must be at least,i5) - if (liv .lt. miv1) go to 999 - if (lv .lt. iv(lastv)) go to 320 - go to 999 -c - 320 iv(1) = 16 - if (pu .eq. 0) go to 999 - write(pu,330) lv, iv(lastv) - 330 format(/9h /// lv =,i5,17h must be at least,i5) - go to 999 -c - 340 iv(1) = 67 - if (pu .eq. 0) go to 999 - write(pu,350) alg - 350 format(/10h /// alg =,i5,15h must be 1 or 2) -c - 999 return -c *** last card of parck follows *** - end - double precision function reldst(p, d, x, x0) -c -c *** compute and return relative difference between x and x0 *** -c *** nl2sol version 2.2 *** -c - integer p - double precision d(p), x(p), x0(p) -c/+ - double precision dabs -c/ - integer i - double precision emax, t, xmax, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - emax = zero - xmax = zero - do 10 i = 1, p - t = dabs(d(i) * (x(i) - x0(i))) - if (emax .lt. t) emax = t - t = d(i) * (dabs(x(i)) + dabs(x0(i))) - if (xmax .lt. t) xmax = t - 10 continue - reldst = zero - if (xmax .gt. zero) reldst = emax / xmax - 999 return -c *** last card of reldst follows *** - end -c logical function stopx(idummy) -c *****parameters... -c integer idummy -c -c .................................................................. -c -c *****purpose... -c this function may serve as the stopx (asynchronous interruption) -c function for the nl2sol (nonlinear least-squares) package at -c those installations which do not wish to implement a -c dynamic stopx. -c -c *****algorithm notes... -c at installations where the nl2sol system is used -c interactively, this dummy stopx should be replaced by a -c function that returns .true. if and only if the interrupt -c (break) key has been pressed since the last call on stopx. -c -c .................................................................. -c -c stopx = .false. -c return -c end - subroutine vaxpy(p, w, a, x, y) -c -c *** set w = a*x + y -- w, x, y = p-vectors, a = scalar *** -c - integer p - double precision a, w(p), x(p), y(p) -c - integer i -c - do 10 i = 1, p - 10 w(i) = a*x(i) + y(i) - return - end - subroutine vcopy(p, y, x) -c -c *** set y = x, where x and y are p-vectors *** -c - integer p - double precision x(p), y(p) -c - integer i -c - do 10 i = 1, p - 10 y(i) = x(i) - return - end - subroutine vdflt(alg, lv, v) -c -c *** supply ***sol (version 2.3) default values to v *** -c -c *** alg = 1 means regression constants. -c *** alg = 2 means general unconstrained optimization constants. -c - integer alg, l - double precision v(lv) -c/+ - double precision dmax1 -c/ - external rmdcon - double precision rmdcon -c rmdcon... returns machine-dependent constants -c - double precision machep, mepcrt, one, sqteps, three -c -c *** subscripts for v *** -c - integer afctol, bias, cosmin, decfac, delta0, dfac, dinit, dltfdc, - 1 dltfdj, dtinit, d0init, epslon, eta0, fuzz, huberc, - 2 incfac, lmax0, lmaxs, phmnfc, phmxfc, rdfcmn, rdfcmx, - 3 rfctol, rlimit, rsptol, sctol, sigmin, tuner1, tuner2, - 4 tuner3, tuner4, tuner5, xctol, xftol -c -c/6 -c data one/1.d+0/, three/3.d+0/ -c/7 - parameter (one=1.d+0, three=3.d+0) -c/ -c -c *** v subscript values *** -c -c/6 -c data afctol/31/, bias/43/, cosmin/47/, decfac/22/, delta0/44/, -c 1 dfac/41/, dinit/38/, dltfdc/42/, dltfdj/43/, dtinit/39/, -c 2 d0init/40/, epslon/19/, eta0/42/, fuzz/45/, huberc/48/, -c 3 incfac/23/, lmax0/35/, lmaxs/36/, phmnfc/20/, phmxfc/21/, -c 4 rdfcmn/24/, rdfcmx/25/, rfctol/32/, rlimit/46/, rsptol/49/, -c 5 sctol/37/, sigmin/50/, tuner1/26/, tuner2/27/, tuner3/28/, -c 6 tuner4/29/, tuner5/30/, xctol/33/, xftol/34/ -c/7 - parameter (afctol=31, bias=43, cosmin=47, decfac=22, delta0=44, - 1 dfac=41, dinit=38, dltfdc=42, dltfdj=43, dtinit=39, - 2 d0init=40, epslon=19, eta0=42, fuzz=45, huberc=48, - 3 incfac=23, lmax0=35, lmaxs=36, phmnfc=20, phmxfc=21, - 4 rdfcmn=24, rdfcmx=25, rfctol=32, rlimit=46, rsptol=49, - 5 sctol=37, sigmin=50, tuner1=26, tuner2=27, tuner3=28, - 6 tuner4=29, tuner5=30, xctol=33, xftol=34) -c/ -c -c------------------------------- body -------------------------------- -c - machep = rmdcon(3) - v(afctol) = 1.d-20 - if (machep .gt. 1.d-10) v(afctol) = machep**2 - v(decfac) = 0.5d+0 - sqteps = rmdcon(4) - v(dfac) = 0.6d+0 - v(delta0) = sqteps - v(dtinit) = 1.d-6 - mepcrt = machep ** (one/three) - v(d0init) = 1.d+0 - v(epslon) = 0.1d+0 - v(incfac) = 2.d+0 - v(lmax0) = 1.d+0 - v(lmaxs) = 1.d+0 - v(phmnfc) = -0.1d+0 - v(phmxfc) = 0.1d+0 - v(rdfcmn) = 0.1d+0 - v(rdfcmx) = 4.d+0 - v(rfctol) = dmax1(1.d-10, mepcrt**2) - v(sctol) = v(rfctol) - v(tuner1) = 0.1d+0 - v(tuner2) = 1.d-4 - v(tuner3) = 0.75d+0 - v(tuner4) = 0.5d+0 - v(tuner5) = 0.75d+0 - v(xctol) = sqteps - v(xftol) = 1.d+2 * machep -c - if (alg .ge. 2) go to 10 -c -c *** regression values -c - v(cosmin) = dmax1(1.d-6, 1.d+2 * machep) - v(dinit) = 0.d+0 - v(dltfdc) = mepcrt - v(dltfdj) = sqteps - v(fuzz) = 1.5d+0 - v(huberc) = 0.7d+0 - v(rlimit) = rmdcon(5) - v(rsptol) = 1.d-3 - v(sigmin) = 1.d-4 - go to 999 -c -c *** general optimization values -c - 10 v(bias) = 0.8d+0 - v(dinit) = -1.0d+0 - v(eta0) = 1.0d+3 * machep -c - 999 return -c *** last card of vdflt follows *** - end - subroutine vscopy(p, y, s) -c -c *** set p-vector y to scalar s *** -c - integer p - double precision s, y(p) -c - integer i -c - do 10 i = 1, p - 10 y(i) = s - return - end - double precision function v2norm(p, x) -c -c *** return the 2-norm of the p-vector x, taking *** -c *** care to avoid the most likely underflows. *** -c - integer p - double precision x(p) -c - integer i, j - double precision one, r, scale, sqteta, t, xi, zero -c/+ - double precision dabs, dsqrt -c/ - external rmdcon - double precision rmdcon -c -c/6 -c data one/1.d+0/, zero/0.d+0/ -c/7 - parameter (one=1.d+0, zero=0.d+0) - save sqteta -c/ - data sqteta/0.d+0/ -c - if (p .gt. 0) go to 10 - v2norm = zero - go to 999 - 10 do 20 i = 1, p - if (x(i) .ne. zero) go to 30 - 20 continue - v2norm = zero - go to 999 -c - 30 scale = dabs(x(i)) - if (i .lt. p) go to 40 - v2norm = scale - go to 999 - 40 t = one - if (sqteta .eq. zero) sqteta = rmdcon(2) -c -c *** sqteta is (slightly larger than) the square root of the -c *** smallest positive floating point number on the machine. -c *** the tests involving sqteta are done to prevent underflows. -c - j = i + 1 - do 60 i = j, p - xi = dabs(x(i)) - if (xi .gt. scale) go to 50 - r = xi / scale - if (r .gt. sqteta) t = t + r*r - go to 60 - 50 r = scale / xi - if (r .le. sqteta) r = zero - t = one + t * r*r - scale = xi - 60 continue -c - v2norm = scale * dsqrt(t) - 999 return -c *** last card of v2norm follows *** - end - subroutine humsl(n, d, x, calcf, calcgh, iv, liv, lv, v, - 1 uiparm, urparm, ufparm) -c -c *** minimize general unconstrained objective function using *** -c *** (analytic) gradient and hessian provided by the caller. *** -c - integer liv, lv, n - integer iv(liv), uiparm(1) - double precision d(n), x(n), v(lv), urparm(1) -c dimension v(78 + n*(n+12)), uiparm(*), urparm(*) - external calcf, calcgh, ufparm -c -c------------------------------ discussion --------------------------- -c -c this routine is like sumsl, except that the subroutine para- -c meter calcg of sumsl (which computes the gradient of the objec- -c tive function) is replaced by the subroutine parameter calcgh, -c which computes both the gradient and (lower triangle of the) -c hessian of the objective function. the calling sequence is... -c call calcgh(n, x, nf, g, h, uiparm, urparm, ufparm) -c parameters n, x, nf, g, uiparm, urparm, and ufparm are the same -c as for sumsl, while h is an array of length n*(n+1)/2 in which -c calcgh must store the lower triangle of the hessian at x. start- -c ing at h(1), calcgh must store the hessian entries in the order -c (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ... -c the value printed (by itsum) in the column labelled stppar -c is the levenberg-marquardt used in computing the current step. -c zero means a full newton step. if the special case described in -c ref. 1 is detected, then stppar is negated. the value printed -c in the column labelled npreldf is zero if the current hessian -c is not positive definite. -c it sometimes proves worthwhile to let d be determined from the -c diagonal of the hessian matrix by setting iv(dtype) = 1 and -c v(dinit) = 0. the following iv and v components are relevant... -c -c iv(dtol)..... iv(59) gives the starting subscript in v of the dtol -c array used when d is updated. (iv(dtol) can be -c initialized by calling humsl with iv(1) = 13.) -c iv(dtype).... iv(16) tells how the scale vector d should be chosen. -c iv(dtype) .le. 0 means that d should not be updated, and -c iv(dtype) .ge. 1 means that d should be updated as -c described below with v(dfac). default = 0. -c v(dfac)..... v(41) and the dtol and d0 arrays (see v(dtinit) and -c v(d0init)) are used in updating the scale vector d when -c iv(dtype) .gt. 0. (d is initialized according to -c v(dinit), described in sumsl.) let -c d1(i) = max(sqrt(abs(h(i,i))), v(dfac)*d(i)), -c where h(i,i) is the i-th diagonal element of the current -c hessian. if iv(dtype) = 1, then d(i) is set to d1(i) -c unless d1(i) .lt. dtol(i), in which case d(i) is set to -c max(d0(i), dtol(i)). -c if iv(dtype) .ge. 2, then d is updated during the first -c iteration as for iv(dtype) = 1 (after any initialization -c due to v(dinit)) and is left unchanged thereafter. -c default = 0.6. -c v(dtinit)... v(39), if positive, is the value to which all components -c of the dtol array (see v(dfac)) are initialized. if -c v(dtinit) = 0, then it is assumed that the caller has -c stored dtol in v starting at v(iv(dtol)). -c default = 10**-6. -c v(d0init)... v(40), if positive, is the value to which all components -c of the d0 vector (see v(dfac)) are initialized. if -c v(dfac) = 0, then it is assumed that the caller has -c stored d0 in v starting at v(iv(dtol)+n). default = 1.0. -c -c *** reference *** -c -c 1. gay, d.m. (1981), computing optimal locally constrained steps, -c siam j. sci. statist. comput. 2, pp. 186-197. -c. -c *** general *** -c -c coded by david m. gay (winter 1980). revised sept. 1982. -c this subroutine was written in connection with research supported -c in part by the national science foundation under grants -c mcs-7600324 and mcs-7906671. -c -c---------------------------- declarations --------------------------- -c - external deflt, humit -c -c deflt... provides default input values for iv and v. -c humit... reverse-communication routine that does humsl algorithm. -c - integer g1, h1, iv1, lh, nf - double precision f -c -c *** subscripts for iv *** -c - integer g, h, nextv, nfcall, nfgcal, toobig, vneed -c -c/6 -c data nextv/47/, nfcall/6/, nfgcal/7/, g/28/, h/56/, toobig/2/, -c 1 vneed/4/ -c/7 - parameter (nextv=47, nfcall=6, nfgcal=7, g=28, h=56, toobig=2, - 1 vneed=4) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - lh = n * (n + 1) / 2 - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - if (iv(1) .eq. 12 .or. iv(1) .eq. 13) - 1 iv(vneed) = iv(vneed) + n*(n+3)/2 - iv1 = iv(1) - if (iv1 .eq. 14) go to 10 - if (iv1 .gt. 2 .and. iv1 .lt. 12) go to 10 - g1 = 1 - h1 = 1 - if (iv1 .eq. 12) iv(1) = 13 - go to 20 -c - 10 g1 = iv(g) - h1 = iv(h) -c - 20 call humit(d, f, v(g1), v(h1), iv, lh, liv, lv, n, v, x) - if (iv(1) - 2) 30, 40, 50 -c - 30 nf = iv(nfcall) - call calcf(n, x, nf, f, uiparm, urparm, ufparm) - if (nf .le. 0) iv(toobig) = 1 - go to 20 -c - 40 call calcgh(n, x, iv(nfgcal), v(g1), v(h1), uiparm, urparm, - 1 ufparm) - go to 20 -c - 50 if (iv(1) .ne. 14) go to 999 -c -c *** storage allocation -c - iv(g) = iv(nextv) - iv(h) = iv(g) + n - iv(nextv) = iv(h) + n*(n+1)/2 - if (iv1 .ne. 13) go to 10 -c - 999 return -c *** last card of humsl follows *** - end - subroutine humit(d, fx, g, h, iv, lh, liv, lv, n, v, x) -c -c *** carry out humsl (unconstrained minimization) iterations, using -c *** hessian matrix provided by the caller. -c -c *** parameter declarations *** -c - integer lh, liv, lv, n - integer iv(liv) - double precision d(n), fx, g(n), h(lh), v(lv), x(n) -c -c-------------------------- parameter usage -------------------------- -c -c d.... scale vector. -c fx... function value. -c g.... gradient vector. -c h.... lower triangle of the hessian, stored rowwise. -c iv... integer value array. -c lh... length of h = p*(p+1)/2. -c liv.. length of iv (at least 60). -c lv... length of v (at least 78 + n*(n+21)/2). -c n.... number of variables (components in x and g). -c v.... floating-point value array. -c x.... parameter vector. -c -c *** discussion *** -c -c parameters iv, n, v, and x are the same as the corresponding -c ones to humsl (which see), except that v can be shorter (since -c the part of v that humsl uses for storing g and h is not needed). -c moreover, compared with humsl, iv(1) may have the two additional -c output values 1 and 2, which are explained below, as is the use -c of iv(toobig) and iv(nfgcal). the value iv(g), which is an -c output value from humsl, is not referenced by humit or the -c subroutines it calls. -c -c iv(1) = 1 means the caller should set fx to f(x), the function value -c at x, and call humit again, having changed none of the -c other parameters. an exception occurs if f(x) cannot be -c computed (e.g. if overflow would occur), which may happen -c because of an oversized step. in this case the caller -c should set iv(toobig) = iv(2) to 1, which will cause -c humit to ignore fx and try a smaller step. the para- -c meter nf that humsl passes to calcf (for possible use by -c calcgh) is a copy of iv(nfcall) = iv(6). -c iv(1) = 2 means the caller should set g to g(x), the gradient of f at -c x, and h to the lower triangle of h(x), the hessian of f -c at x, and call humit again, having changed none of the -c other parameters except perhaps the scale vector d. -c the parameter nf that humsl passes to calcg is -c iv(nfgcal) = iv(7). if g(x) and h(x) cannot be evaluated, -c then the caller may set iv(nfgcal) to 0, in which case -c humit will return with iv(1) = 65. -c note -- humit overwrites h with the lower triangle -c of diag(d)**-1 * h(x) * diag(d)**-1. -c. -c *** general *** -c -c coded by david m. gay (winter 1980). revised sept. 1982. -c this subroutine was written in connection with research supported -c in part by the national science foundation under grants -c mcs-7600324 and mcs-7906671. -c -c (see sumsl and humsl for references.) -c -c+++++++++++++++++++++++++++ declarations ++++++++++++++++++++++++++++ -c -c *** local variables *** -c - integer dg1, dummy, i, j, k, l, lstgst, nn1o2, step1, - 1 temp1, w1, x01 - double precision t -c -c *** constants *** -c - double precision one, onep2, zero -c -c *** no intrinsic functions *** -c -c *** external functions and subroutines *** -c - external assst, deflt, dotprd, dupdu, gqtst, itsum, parck, - 1 reldst, slvmul, stopx, vaxpy, vcopy, vscopy, v2norm - logical stopx - double precision dotprd, reldst, v2norm -c -c assst.... assesses candidate step. -c deflt.... provides default iv and v input values. -c dotprd... returns inner product of two vectors. -c dupdu.... updates scale vector d. -c gqtst.... computes optimally locally constrained step. -c itsum.... prints iteration summary and info on initial and final x. -c parck.... checks validity of input iv and v values. -c reldst... computes v(reldx) = relative step size. -c slvmul... multiplies symmetric matrix times vector, given the lower -c triangle of the matrix. -c stopx.... returns .true. if the break key has been pressed. -c vaxpy.... computes scalar times one vector plus another. -c vcopy.... copies one vector to another. -c vscopy... sets all elements of a vector to a scalar. -c v2norm... returns the 2-norm of a vector. -c -c *** subscripts for iv and v *** -c - integer cnvcod, dg, dgnorm, dinit, dstnrm, dtinit, dtol, - 1 dtype, d0init, f, f0, fdif, gtstep, incfac, irc, kagqt, - 2 lmat, lmax0, lmaxs, mode, model, mxfcal, mxiter, nextv, - 3 nfcall, nfgcal, ngcall, niter, preduc, radfac, radinc, - 4 radius, rad0, reldx, restor, step, stglim, stlstg, stppar, - 5 toobig, tuner4, tuner5, vneed, w, xirc, x0 -c -c *** iv subscript values *** -c -c/6 -c data cnvcod/55/, dg/37/, dtol/59/, dtype/16/, irc/29/, kagqt/33/, -c 1 lmat/42/, mode/35/, model/5/, mxfcal/17/, mxiter/18/, -c 2 nextv/47/, nfcall/6/, nfgcal/7/, ngcall/30/, niter/31/, -c 3 radinc/8/, restor/9/, step/40/, stglim/11/, stlstg/41/, -c 4 toobig/2/, vneed/4/, w/34/, xirc/13/, x0/43/ -c/7 - parameter (cnvcod=55, dg=37, dtol=59, dtype=16, irc=29, kagqt=33, - 1 lmat=42, mode=35, model=5, mxfcal=17, mxiter=18, - 2 nextv=47, nfcall=6, nfgcal=7, ngcall=30, niter=31, - 3 radinc=8, restor=9, step=40, stglim=11, stlstg=41, - 4 toobig=2, vneed=4, w=34, xirc=13, x0=43) -c/ -c -c *** v subscript values *** -c -c/6 -c data dgnorm/1/, dinit/38/, dstnrm/2/, dtinit/39/, d0init/40/, -c 1 f/10/, f0/13/, fdif/11/, gtstep/4/, incfac/23/, lmax0/35/, -c 2 lmaxs/36/, preduc/7/, radfac/16/, radius/8/, rad0/9/, -c 3 reldx/17/, stppar/5/, tuner4/29/, tuner5/30/ -c/7 - parameter (dgnorm=1, dinit=38, dstnrm=2, dtinit=39, d0init=40, - 1 f=10, f0=13, fdif=11, gtstep=4, incfac=23, lmax0=35, - 2 lmaxs=36, preduc=7, radfac=16, radius=8, rad0=9, - 3 reldx=17, stppar=5, tuner4=29, tuner5=30) -c/ -c -c/6 -c data one/1.d+0/, onep2/1.2d+0/, zero/0.d+0/ -c/7 - parameter (one=1.d+0, onep2=1.2d+0, zero=0.d+0) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - i = iv(1) - if (i .eq. 1) go to 30 - if (i .eq. 2) go to 40 -c -c *** check validity of iv and v input values *** -c - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - if (iv(1) .eq. 12 .or. iv(1) .eq. 13) - 1 iv(vneed) = iv(vneed) + n*(n+21)/2 + 7 - call parck(2, d, iv, liv, lv, n, v) - i = iv(1) - 2 - if (i .gt. 12) go to 999 - nn1o2 = n * (n + 1) / 2 - if (lh .ge. nn1o2) go to (210,210,210,210,210,210,160,120,160, - 1 10,10,20), i - iv(1) = 66 - go to 350 -c -c *** storage allocation *** -c - 10 iv(dtol) = iv(lmat) + nn1o2 - iv(x0) = iv(dtol) + 2*n - iv(step) = iv(x0) + n - iv(stlstg) = iv(step) + n - iv(dg) = iv(stlstg) + n - iv(w) = iv(dg) + n - iv(nextv) = iv(w) + 4*n + 7 - if (iv(1) .ne. 13) go to 20 - iv(1) = 14 - go to 999 -c -c *** initialization *** -c - 20 iv(niter) = 0 - iv(nfcall) = 1 - iv(ngcall) = 1 - iv(nfgcal) = 1 - iv(mode) = -1 - iv(model) = 1 - iv(stglim) = 1 - iv(toobig) = 0 - iv(cnvcod) = 0 - iv(radinc) = 0 - v(rad0) = zero - v(stppar) = zero - if (v(dinit) .ge. zero) call vscopy(n, d, v(dinit)) - k = iv(dtol) - if (v(dtinit) .gt. zero) call vscopy(n, v(k), v(dtinit)) - k = k + n - if (v(d0init) .gt. zero) call vscopy(n, v(k), v(d0init)) - iv(1) = 1 - go to 999 -c - 30 v(f) = fx - if (iv(mode) .ge. 0) go to 210 - iv(1) = 2 - if (iv(toobig) .eq. 0) go to 999 - iv(1) = 63 - go to 350 -c -c *** make sure gradient could be computed *** -c - 40 if (iv(nfgcal) .ne. 0) go to 50 - iv(1) = 65 - go to 350 -c -c *** update the scale vector d *** -c - 50 dg1 = iv(dg) - if (iv(dtype) .le. 0) go to 70 - k = dg1 - j = 0 - do 60 i = 1, n - j = j + i - v(k) = h(j) - k = k + 1 - 60 continue - call dupdu(d, v(dg1), iv, liv, lv, n, v) -c -c *** compute scaled gradient and its norm *** -c - 70 dg1 = iv(dg) - k = dg1 - do 80 i = 1, n - v(k) = g(i) / d(i) - k = k + 1 - 80 continue - v(dgnorm) = v2norm(n, v(dg1)) -c -c *** compute scaled hessian *** -c - k = 1 - do 100 i = 1, n - t = one / d(i) - do 90 j = 1, i - h(k) = t * h(k) / d(j) - k = k + 1 - 90 continue - 100 continue -c - if (iv(cnvcod) .ne. 0) go to 340 - if (iv(mode) .eq. 0) go to 300 -c -c *** allow first step to have scaled 2-norm at most v(lmax0) *** -c - v(radius) = v(lmax0) -c - iv(mode) = 0 -c -c -c----------------------------- main loop ----------------------------- -c -c -c *** print iteration summary, check iteration limit *** -c - 110 call itsum(d, g, iv, liv, lv, n, v, x) - 120 k = iv(niter) - if (k .lt. iv(mxiter)) go to 130 - iv(1) = 10 - go to 350 -c - 130 iv(niter) = k + 1 -c -c *** initialize for start of next iteration *** -c - dg1 = iv(dg) - x01 = iv(x0) - v(f0) = v(f) - iv(irc) = 4 - iv(kagqt) = -1 -c -c *** copy x to x0 *** -c - call vcopy(n, v(x01), x) -c -c *** update radius *** -c - if (k .eq. 0) go to 150 - step1 = iv(step) - k = step1 - do 140 i = 1, n - v(k) = d(i) * v(k) - k = k + 1 - 140 continue - v(radius) = v(radfac) * v2norm(n, v(step1)) -c -c *** check stopx and function evaluation limit *** -c -C AL 4/30/95 - dummy=iv(nfcall) - 150 if (.not. stopx(dummy)) go to 170 - iv(1) = 11 - go to 180 -c -c *** come here when restarting after func. eval. limit or stopx. -c - 160 if (v(f) .ge. v(f0)) go to 170 - v(radfac) = one - k = iv(niter) - go to 130 -c - 170 if (iv(nfcall) .lt. iv(mxfcal)) go to 190 - iv(1) = 9 - 180 if (v(f) .ge. v(f0)) go to 350 -c -c *** in case of stopx or function evaluation limit with -c *** improved v(f), evaluate the gradient at x. -c - iv(cnvcod) = iv(1) - go to 290 -c -c. . . . . . . . . . . . . compute candidate step . . . . . . . . . . -c - 190 step1 = iv(step) - dg1 = iv(dg) - l = iv(lmat) - w1 = iv(w) - call gqtst(d, v(dg1), h, iv(kagqt), v(l), n, v(step1), v, v(w1)) - if (iv(irc) .eq. 6) go to 210 -c -c *** check whether evaluating f(x0 + step) looks worthwhile *** -c - if (v(dstnrm) .le. zero) go to 210 - if (iv(irc) .ne. 5) go to 200 - if (v(radfac) .le. one) go to 200 - if (v(preduc) .le. onep2 * v(fdif)) go to 210 -c -c *** compute f(x0 + step) *** -c - 200 x01 = iv(x0) - step1 = iv(step) - call vaxpy(n, x, one, v(step1), v(x01)) - iv(nfcall) = iv(nfcall) + 1 - iv(1) = 1 - iv(toobig) = 0 - go to 999 -c -c. . . . . . . . . . . . . assess candidate step . . . . . . . . . . . -c - 210 x01 = iv(x0) - v(reldx) = reldst(n, d, x, v(x01)) - call assst(iv, liv, lv, v) - step1 = iv(step) - lstgst = iv(stlstg) - if (iv(restor) .eq. 1) call vcopy(n, x, v(x01)) - if (iv(restor) .eq. 2) call vcopy(n, v(lstgst), v(step1)) - if (iv(restor) .ne. 3) go to 220 - call vcopy(n, v(step1), v(lstgst)) - call vaxpy(n, x, one, v(step1), v(x01)) - v(reldx) = reldst(n, d, x, v(x01)) -c - 220 k = iv(irc) - go to (230,260,260,260,230,240,250,250,250,250,250,250,330,300), k -c -c *** recompute step with new radius *** -c - 230 v(radius) = v(radfac) * v(dstnrm) - go to 150 -c -c *** compute step of length v(lmaxs) for singular convergence test. -c - 240 v(radius) = v(lmaxs) - go to 190 -c -c *** convergence or false convergence *** -c - 250 iv(cnvcod) = k - 4 - if (v(f) .ge. v(f0)) go to 340 - if (iv(xirc) .eq. 14) go to 340 - iv(xirc) = 14 -c -c. . . . . . . . . . . . process acceptable step . . . . . . . . . . . -c - 260 if (iv(irc) .ne. 3) go to 290 - temp1 = lstgst -c -c *** prepare for gradient tests *** -c *** set temp1 = hessian * step + g(x0) -c *** = diag(d) * (h * step + g(x0)) -c -c use x0 vector as temporary. - k = x01 - do 270 i = 1, n - v(k) = d(i) * v(step1) - k = k + 1 - step1 = step1 + 1 - 270 continue - call slvmul(n, v(temp1), h, v(x01)) - do 280 i = 1, n - v(temp1) = d(i) * v(temp1) + g(i) - temp1 = temp1 + 1 - 280 continue -c -c *** compute gradient and hessian *** -c - 290 iv(ngcall) = iv(ngcall) + 1 - iv(1) = 2 - go to 999 -c - 300 iv(1) = 2 - if (iv(irc) .ne. 3) go to 110 -c -c *** set v(radfac) by gradient tests *** -c - temp1 = iv(stlstg) - step1 = iv(step) -c -c *** set temp1 = diag(d)**-1 * (hessian*step + (g(x0)-g(x))) *** -c - k = temp1 - do 310 i = 1, n - v(k) = (v(k) - g(i)) / d(i) - k = k + 1 - 310 continue -c -c *** do gradient tests *** -c - if (v2norm(n, v(temp1)) .le. v(dgnorm) * v(tuner4)) go to 320 - if (dotprd(n, g, v(step1)) - 1 .ge. v(gtstep) * v(tuner5)) go to 110 - 320 v(radfac) = v(incfac) - go to 110 -c -c. . . . . . . . . . . . . . misc. details . . . . . . . . . . . . . . -c -c *** bad parameters to assess *** -c - 330 iv(1) = 64 - go to 350 -c -c *** print summary of final iteration and other requested items *** -c - 340 iv(1) = iv(cnvcod) - iv(cnvcod) = 0 - 350 call itsum(d, g, iv, liv, lv, n, v, x) -c - 999 return -c -c *** last card of humit follows *** - end - subroutine dupdu(d, hdiag, iv, liv, lv, n, v) -c -c *** update scale vector d for humsl *** -c -c *** parameter declarations *** -c - integer liv, lv, n - integer iv(liv) - double precision d(n), hdiag(n), v(lv) -c -c *** local variables *** -c - integer dtoli, d0i, i - double precision t, vdfac -c -c *** intrinsic functions *** -c/+ - double precision dabs, dmax1, dsqrt -c/ -c *** subscripts for iv and v *** -c - integer dfac, dtol, dtype, niter -c/6 -c data dfac/41/, dtol/59/, dtype/16/, niter/31/ -c/7 - parameter (dfac=41, dtol=59, dtype=16, niter=31) -c/ -c -c------------------------------- body -------------------------------- -c - i = iv(dtype) - if (i .eq. 1) go to 10 - if (iv(niter) .gt. 0) go to 999 -c - 10 dtoli = iv(dtol) - d0i = dtoli + n - vdfac = v(dfac) - do 20 i = 1, n - t = dmax1(dsqrt(dabs(hdiag(i))), vdfac*d(i)) - if (t .lt. v(dtoli)) t = dmax1(v(dtoli), v(d0i)) - d(i) = t - dtoli = dtoli + 1 - d0i = d0i + 1 - 20 continue -c - 999 return -c *** last card of dupdu follows *** - end - subroutine gqtst(d, dig, dihdi, ka, l, p, step, v, w) -c -c *** compute goldfeld-quandt-trotter step by more-hebden technique *** -c *** (nl2sol version 2.2), modified a la more and sorensen *** -c -c *** parameter declarations *** -c - integer ka, p -cal double precision d(p), dig(p), dihdi(1), l(1), v(21), step(p), -cal 1 w(1) - double precision d(p), dig(p), dihdi(p*(p+1)/2), l(p*(p+1)/2), - 1 v(21), step(p),w(4*p+7) -c dimension dihdi(p*(p+1)/2), l(p*(p+1)/2), w(4*p+7) -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** purpose *** -c -c given the (compactly stored) lower triangle of a scaled -c hessian (approximation) and a nonzero scaled gradient vector, -c this subroutine computes a goldfeld-quandt-trotter step of -c approximate length v(radius) by the more-hebden technique. in -c other words, step is computed to (approximately) minimize -c psi(step) = (g**t)*step + 0.5*(step**t)*h*step such that the -c 2-norm of d*step is at most (approximately) v(radius), where -c g is the gradient, h is the hessian, and d is a diagonal -c scale matrix whose diagonal is stored in the parameter d. -c (gqtst assumes dig = d**-1 * g and dihdi = d**-1 * h * d**-1.) -c -c *** parameter description *** -c -c d (in) = the scale vector, i.e. the diagonal of the scale -c matrix d mentioned above under purpose. -c dig (in) = the scaled gradient vector, d**-1 * g. if g = 0, then -c step = 0 and v(stppar) = 0 are returned. -c dihdi (in) = lower triangle of the scaled hessian (approximation), -c i.e., d**-1 * h * d**-1, stored compactly by rows., i.e., -c in the order (1,1), (2,1), (2,2), (3,1), (3,2), etc. -c ka (i/o) = the number of hebden iterations (so far) taken to deter- -c mine step. ka .lt. 0 on input means this is the first -c attempt to determine step (for the present dig and dihdi) -c -- ka is initialized to 0 in this case. output with -c ka = 0 (or v(stppar) = 0) means step = -(h**-1)*g. -c l (i/o) = workspace of length p*(p+1)/2 for cholesky factors. -c p (in) = number of parameters -- the hessian is a p x p matrix. -c step (i/o) = the step computed. -c v (i/o) contains various constants and variables described below. -c w (i/o) = workspace of length 4*p + 6. -c -c *** entries in v *** -c -c v(dgnorm) (i/o) = 2-norm of (d**-1)*g. -c v(dstnrm) (output) = 2-norm of d*step. -c v(dst0) (i/o) = 2-norm of d*(h**-1)*g (for pos. def. h only), or -c overestimate of smallest eigenvalue of (d**-1)*h*(d**-1). -c v(epslon) (in) = max. rel. error allowed for psi(step). for the -c step returned, psi(step) will exceed its optimal value -c by less than -v(epslon)*psi(step). suggested value = 0.1. -c v(gtstep) (out) = inner product between g and step. -c v(nreduc) (out) = psi(-(h**-1)*g) = psi(newton step) (for pos. def. -c h only -- v(nreduc) is set to zero otherwise). -c v(phmnfc) (in) = tol. (together with v(phmxfc)) for accepting step -c (more*s sigma). the error v(dstnrm) - v(radius) must lie -c between v(phmnfc)*v(radius) and v(phmxfc)*v(radius). -c v(phmxfc) (in) (see v(phmnfc).) -c suggested values -- v(phmnfc) = -0.25, v(phmxfc) = 0.5. -c v(preduc) (out) = psi(step) = predicted obj. func. reduction for step. -c v(radius) (in) = radius of current (scaled) trust region. -c v(rad0) (i/o) = value of v(radius) from previous call. -c v(stppar) (i/o) is normally the marquardt parameter, i.e. the alpha -c described below under algorithm notes. if h + alpha*d**2 -c (see algorithm notes) is (nearly) singular, however, -c then v(stppar) = -alpha. -c -c *** usage notes *** -c -c if it is desired to recompute step using a different value of -c v(radius), then this routine may be restarted by calling it -c with all parameters unchanged except v(radius). (this explains -c why step and w are listed as i/o). on an initial call (one with -c ka .lt. 0), step and w need not be initialized and only compo- -c nents v(epslon), v(stppar), v(phmnfc), v(phmxfc), v(radius), and -c v(rad0) of v must be initialized. -c -c *** algorithm notes *** -c -c the desired g-q-t step (ref. 2, 3, 4, 6) satisfies -c (h + alpha*d**2)*step = -g for some nonnegative alpha such that -c h + alpha*d**2 is positive semidefinite. alpha and step are -c computed by a scheme analogous to the one described in ref. 5. -c estimates of the smallest and largest eigenvalues of the hessian -c are obtained from the gerschgorin circle theorem enhanced by a -c simple form of the scaling described in ref. 7. cases in which -c h + alpha*d**2 is nearly (or exactly) singular are handled by -c the technique discussed in ref. 2. in these cases, a step of -c (exact) length v(radius) is returned for which psi(step) exceeds -c its optimal value by less than -v(epslon)*psi(step). the test -c suggested in ref. 6 for detecting the special case is performed -c once two matrix factorizations have been done -- doing so sooner -c seems to degrade the performance of optimization routines that -c call this routine. -c -c *** functions and subroutines called *** -c -c dotprd - returns inner product of two vectors. -c litvmu - applies inverse-transpose of compact lower triang. matrix. -c livmul - applies inverse of compact lower triang. matrix. -c lsqrt - finds cholesky factor (of compactly stored lower triang.). -c lsvmin - returns approx. to min. sing. value of lower triang. matrix. -c rmdcon - returns machine-dependent constants. -c v2norm - returns 2-norm of a vector. -c -c *** references *** -c -c 1. dennis, j.e., gay, d.m., and welsch, r.e. (1981), an adaptive -c nonlinear least-squares algorithm, acm trans. math. -c software, vol. 7, no. 3. -c 2. gay, d.m. (1981), computing optimal locally constrained steps, -c siam j. sci. statist. computing, vol. 2, no. 2, pp. -c 186-197. -c 3. goldfeld, s.m., quandt, r.e., and trotter, h.f. (1966), -c maximization by quadratic hill-climbing, econometrica 34, -c pp. 541-551. -c 4. hebden, m.d. (1973), an algorithm for minimization using exact -c second derivatives, report t.p. 515, theoretical physics -c div., a.e.r.e. harwell, oxon., england. -c 5. more, j.j. (1978), the levenberg-marquardt algorithm, implemen- -c tation and theory, pp.105-116 of springer lecture notes -c in mathematics no. 630, edited by g.a. watson, springer- -c verlag, berlin and new york. -c 6. more, j.j., and sorensen, d.c. (1981), computing a trust region -c step, technical report anl-81-83, argonne national lab. -c 7. varga, r.s. (1965), minimal gerschgorin sets, pacific j. math. 15, -c pp. 719-729. -c -c *** general *** -c -c coded by david m. gay. -c this subroutine was written in connection with research -c supported by the national science foundation under grants -c mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, and -c mcs-7906671. -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** local variables *** -c - logical restrt - integer dggdmx, diag, diag0, dstsav, emax, emin, i, im1, inc, irc, - 1 j, k, kalim, kamin, k1, lk0, phipin, q, q0, uk0, x - double precision alphak, aki, akk, delta, dst, eps, gtsta, lk, - 1 oldphi, phi, phimax, phimin, psifac, rad, radsq, - 2 root, si, sk, sw, t, twopsi, t1, t2, uk, wi -c -c *** constants *** - double precision big, dgxfac, epsfac, four, half, kappa, negone, - 1 one, p001, six, three, two, zero -c -c *** intrinsic functions *** -c/+ - double precision dabs, dmax1, dmin1, dsqrt -c/ -c *** external functions and subroutines *** -c - external dotprd, litvmu, livmul, lsqrt, lsvmin, rmdcon, v2norm - double precision dotprd, lsvmin, rmdcon, v2norm -c -c *** subscripts for v *** -c - integer dgnorm, dstnrm, dst0, epslon, gtstep, stppar, nreduc, - 1 phmnfc, phmxfc, preduc, radius, rad0 -c/6 -c data dgnorm/1/, dstnrm/2/, dst0/3/, epslon/19/, gtstep/4/, -c 1 nreduc/6/, phmnfc/20/, phmxfc/21/, preduc/7/, radius/8/, -c 2 rad0/9/, stppar/5/ -c/7 - parameter (dgnorm=1, dstnrm=2, dst0=3, epslon=19, gtstep=4, - 1 nreduc=6, phmnfc=20, phmxfc=21, preduc=7, radius=8, - 2 rad0=9, stppar=5) -c/ -c -c/6 -c data epsfac/50.0d+0/, four/4.0d+0/, half/0.5d+0/, -c 1 kappa/2.0d+0/, negone/-1.0d+0/, one/1.0d+0/, p001/1.0d-3/, -c 2 six/6.0d+0/, three/3.0d+0/, two/2.0d+0/, zero/0.0d+0/ -c/7 - parameter (epsfac=50.0d+0, four=4.0d+0, half=0.5d+0, - 1 kappa=2.0d+0, negone=-1.0d+0, one=1.0d+0, p001=1.0d-3, - 2 six=6.0d+0, three=3.0d+0, two=2.0d+0, zero=0.0d+0) - save dgxfac -c/ - data big/0.d+0/, dgxfac/0.d+0/ -c -c *** body *** -c -c *** store largest abs. entry in (d**-1)*h*(d**-1) at w(dggdmx). - dggdmx = p + 1 -c *** store gerschgorin over- and underestimates of the largest -c *** and smallest eigenvalues of (d**-1)*h*(d**-1) at w(emax) -c *** and w(emin) respectively. - emax = dggdmx + 1 - emin = emax + 1 -c *** for use in recomputing step, the final values of lk, uk, dst, -c *** and the inverse derivative of more*s phi at 0 (for pos. def. -c *** h) are stored in w(lk0), w(uk0), w(dstsav), and w(phipin) -c *** respectively. - lk0 = emin + 1 - phipin = lk0 + 1 - uk0 = phipin + 1 - dstsav = uk0 + 1 -c *** store diag of (d**-1)*h*(d**-1) in w(diag),...,w(diag0+p). - diag0 = dstsav - diag = diag0 + 1 -c *** store -d*step in w(q),...,w(q0+p). - q0 = diag0 + p - q = q0 + 1 -c *** allocate storage for scratch vector x *** - x = q + p - rad = v(radius) - radsq = rad**2 -c *** phitol = max. error allowed in dst = v(dstnrm) = 2-norm of -c *** d*step. - phimax = v(phmxfc) * rad - phimin = v(phmnfc) * rad - psifac = two * v(epslon) / (three * (four * (v(phmnfc) + one) * - 1 (kappa + one) + kappa + two) * rad**2) -c *** oldphi is used to detect limits of numerical accuracy. if -c *** we recompute step and it does not change, then we accept it. - oldphi = zero - eps = v(epslon) - irc = 0 - restrt = .false. - kalim = ka + 50 -c -c *** start or restart, depending on ka *** -c - if (ka .ge. 0) go to 290 -c -c *** fresh start *** -c - k = 0 - uk = negone - ka = 0 - kalim = 50 - v(dgnorm) = v2norm(p, dig) - v(nreduc) = zero - v(dst0) = zero - kamin = 3 - if (v(dgnorm) .eq. zero) kamin = 0 -c -c *** store diag(dihdi) in w(diag0+1),...,w(diag0+p) *** -c - j = 0 - do 10 i = 1, p - j = j + i - k1 = diag0 + i - w(k1) = dihdi(j) - 10 continue -c -c *** determine w(dggdmx), the largest element of dihdi *** -c - t1 = zero - j = p * (p + 1) / 2 - do 20 i = 1, j - t = dabs(dihdi(i)) - if (t1 .lt. t) t1 = t - 20 continue - w(dggdmx) = t1 -c -c *** try alpha = 0 *** -c - 30 call lsqrt(1, p, l, dihdi, irc) - if (irc .eq. 0) go to 50 -c *** indef. h -- underestimate smallest eigenvalue, use this -c *** estimate to initialize lower bound lk on alpha. - j = irc*(irc+1)/2 - t = l(j) - l(j) = one - do 40 i = 1, irc - 40 w(i) = zero - w(irc) = one - call litvmu(irc, w, l, w) - t1 = v2norm(irc, w) - lk = -t / t1 / t1 - v(dst0) = -lk - if (restrt) go to 210 - go to 70 -c -c *** positive definite h -- compute unmodified newton step. *** - 50 lk = zero - t = lsvmin(p, l, w(q), w(q)) - if (t .ge. one) go to 60 - if (big .le. zero) big = rmdcon(6) - if (v(dgnorm) .ge. t*t*big) go to 70 - 60 call livmul(p, w(q), l, dig) - gtsta = dotprd(p, w(q), w(q)) - v(nreduc) = half * gtsta - call litvmu(p, w(q), l, w(q)) - dst = v2norm(p, w(q)) - v(dst0) = dst - phi = dst - rad - if (phi .le. phimax) go to 260 - if (restrt) go to 210 -c -c *** prepare to compute gerschgorin estimates of largest (and -c *** smallest) eigenvalues. *** -c - 70 k = 0 - do 100 i = 1, p - wi = zero - if (i .eq. 1) go to 90 - im1 = i - 1 - do 80 j = 1, im1 - k = k + 1 - t = dabs(dihdi(k)) - wi = wi + t - w(j) = w(j) + t - 80 continue - 90 w(i) = wi - k = k + 1 - 100 continue -c -c *** (under-)estimate smallest eigenvalue of (d**-1)*h*(d**-1) *** -c - k = 1 - t1 = w(diag) - w(1) - if (p .le. 1) go to 120 - do 110 i = 2, p - j = diag0 + i - t = w(j) - w(i) - if (t .ge. t1) go to 110 - t1 = t - k = i - 110 continue -c - 120 sk = w(k) - j = diag0 + k - akk = w(j) - k1 = k*(k-1)/2 + 1 - inc = 1 - t = zero - do 150 i = 1, p - if (i .eq. k) go to 130 - aki = dabs(dihdi(k1)) - si = w(i) - j = diag0 + i - t1 = half * (akk - w(j) + si - aki) - t1 = t1 + dsqrt(t1*t1 + sk*aki) - if (t .lt. t1) t = t1 - if (i .lt. k) go to 140 - 130 inc = i - 140 k1 = k1 + inc - 150 continue -c - w(emin) = akk - t - uk = v(dgnorm)/rad - w(emin) - if (v(dgnorm) .eq. zero) uk = uk + p001 + p001*uk - if (uk .le. zero) uk = p001 -c -c *** compute gerschgorin (over-)estimate of largest eigenvalue *** -c - k = 1 - t1 = w(diag) + w(1) - if (p .le. 1) go to 170 - do 160 i = 2, p - j = diag0 + i - t = w(j) + w(i) - if (t .le. t1) go to 160 - t1 = t - k = i - 160 continue -c - 170 sk = w(k) - j = diag0 + k - akk = w(j) - k1 = k*(k-1)/2 + 1 - inc = 1 - t = zero - do 200 i = 1, p - if (i .eq. k) go to 180 - aki = dabs(dihdi(k1)) - si = w(i) - j = diag0 + i - t1 = half * (w(j) + si - aki - akk) - t1 = t1 + dsqrt(t1*t1 + sk*aki) - if (t .lt. t1) t = t1 - if (i .lt. k) go to 190 - 180 inc = i - 190 k1 = k1 + inc - 200 continue -c - w(emax) = akk + t - lk = dmax1(lk, v(dgnorm)/rad - w(emax)) -c -c *** alphak = current value of alpha (see alg. notes above). we -c *** use more*s scheme for initializing it. - alphak = dabs(v(stppar)) * v(rad0)/rad -c - if (irc .ne. 0) go to 210 -c -c *** compute l0 for positive definite h *** -c - call livmul(p, w, l, w(q)) - t = v2norm(p, w) - w(phipin) = dst / t / t - lk = dmax1(lk, phi*w(phipin)) -c -c *** safeguard alphak and add alphak*i to (d**-1)*h*(d**-1) *** -c - 210 ka = ka + 1 - if (-v(dst0) .ge. alphak .or. alphak .lt. lk .or. alphak .ge. uk) - 1 alphak = uk * dmax1(p001, dsqrt(lk/uk)) - if (alphak .le. zero) alphak = half * uk - if (alphak .le. zero) alphak = uk - k = 0 - do 220 i = 1, p - k = k + i - j = diag0 + i - dihdi(k) = w(j) + alphak - 220 continue -c -c *** try computing cholesky decomposition *** -c - call lsqrt(1, p, l, dihdi, irc) - if (irc .eq. 0) go to 240 -c -c *** (d**-1)*h*(d**-1) + alphak*i is indefinite -- overestimate -c *** smallest eigenvalue for use in updating lk *** -c - j = (irc*(irc+1))/2 - t = l(j) - l(j) = one - do 230 i = 1, irc - 230 w(i) = zero - w(irc) = one - call litvmu(irc, w, l, w) - t1 = v2norm(irc, w) - lk = alphak - t/t1/t1 - v(dst0) = -lk - go to 210 -c -c *** alphak makes (d**-1)*h*(d**-1) positive definite. -c *** compute q = -d*step, check for convergence. *** -c - 240 call livmul(p, w(q), l, dig) - gtsta = dotprd(p, w(q), w(q)) - call litvmu(p, w(q), l, w(q)) - dst = v2norm(p, w(q)) - phi = dst - rad - if (phi .le. phimax .and. phi .ge. phimin) go to 270 - if (phi .eq. oldphi) go to 270 - oldphi = phi - if (phi .lt. zero) go to 330 -c -c *** unacceptable alphak -- update lk, uk, alphak *** -c - 250 if (ka .ge. kalim) go to 270 -c *** the following dmin1 is necessary because of restarts *** - if (phi .lt. zero) uk = dmin1(uk, alphak) -c *** kamin = 0 only iff the gradient vanishes *** - if (kamin .eq. 0) go to 210 - call livmul(p, w, l, w(q)) - t1 = v2norm(p, w) - alphak = alphak + (phi/t1) * (dst/t1) * (dst/rad) - lk = dmax1(lk, alphak) - go to 210 -c -c *** acceptable step on first try *** -c - 260 alphak = zero -c -c *** successful step in general. compute step = -(d**-1)*q *** -c - 270 do 280 i = 1, p - j = q0 + i - step(i) = -w(j)/d(i) - 280 continue - v(gtstep) = -gtsta - v(preduc) = half * (dabs(alphak)*dst*dst + gtsta) - go to 410 -c -c -c *** restart with new radius *** -c - 290 if (v(dst0) .le. zero .or. v(dst0) - rad .gt. phimax) go to 310 -c -c *** prepare to return newton step *** -c - restrt = .true. - ka = ka + 1 - k = 0 - do 300 i = 1, p - k = k + i - j = diag0 + i - dihdi(k) = w(j) - 300 continue - uk = negone - go to 30 -c - 310 kamin = ka + 3 - if (v(dgnorm) .eq. zero) kamin = 0 - if (ka .eq. 0) go to 50 -c - dst = w(dstsav) - alphak = dabs(v(stppar)) - phi = dst - rad - t = v(dgnorm)/rad - uk = t - w(emin) - if (v(dgnorm) .eq. zero) uk = uk + p001 + p001*uk - if (uk .le. zero) uk = p001 - if (rad .gt. v(rad0)) go to 320 -c -c *** smaller radius *** - lk = zero - if (alphak .gt. zero) lk = w(lk0) - lk = dmax1(lk, t - w(emax)) - if (v(dst0) .gt. zero) lk = dmax1(lk, (v(dst0)-rad)*w(phipin)) - go to 250 -c -c *** bigger radius *** - 320 if (alphak .gt. zero) uk = dmin1(uk, w(uk0)) - lk = dmax1(zero, -v(dst0), t - w(emax)) - if (v(dst0) .gt. zero) lk = dmax1(lk, (v(dst0)-rad)*w(phipin)) - go to 250 -c -c *** decide whether to check for special case... in practice (from -c *** the standpoint of the calling optimization code) it seems best -c *** not to check until a few iterations have failed -- hence the -c *** test on kamin below. -c - 330 delta = alphak + dmin1(zero, v(dst0)) - twopsi = alphak*dst*dst + gtsta - if (ka .ge. kamin) go to 340 -c *** if the test in ref. 2 is satisfied, fall through to handle -c *** the special case (as soon as the more-sorensen test detects -c *** it). - if (delta .ge. psifac*twopsi) go to 370 -c -c *** check for the special case of h + alpha*d**2 (nearly) -c *** singular. use one step of inverse power method with start -c *** from lsvmin to obtain approximate eigenvector corresponding -c *** to smallest eigenvalue of (d**-1)*h*(d**-1). lsvmin returns -c *** x and w with l*w = x. -c - 340 t = lsvmin(p, l, w(x), w) -c -c *** normalize w *** - do 350 i = 1, p - 350 w(i) = t*w(i) -c *** complete current inv. power iter. -- replace w by (l**-t)*w. - call litvmu(p, w, l, w) - t2 = one/v2norm(p, w) - do 360 i = 1, p - 360 w(i) = t2*w(i) - t = t2 * t -c -c *** now w is the desired approximate (unit) eigenvector and -c *** t*x = ((d**-1)*h*(d**-1) + alphak*i)*w. -c - sw = dotprd(p, w(q), w) - t1 = (rad + dst) * (rad - dst) - root = dsqrt(sw*sw + t1) - if (sw .lt. zero) root = -root - si = t1 / (sw + root) -c -c *** the actual test for the special case... -c - if ((t2*si)**2 .le. eps*(dst**2 + alphak*radsq)) go to 380 -c -c *** update upper bound on smallest eigenvalue (when not positive) -c *** (as recommended by more and sorensen) and continue... -c - if (v(dst0) .le. zero) v(dst0) = dmin1(v(dst0), t2**2 - alphak) - lk = dmax1(lk, -v(dst0)) -c -c *** check whether we can hope to detect the special case in -c *** the available arithmetic. accept step as it is if not. -c -c *** if not yet available, obtain machine dependent value dgxfac. - 370 if (dgxfac .eq. zero) dgxfac = epsfac * rmdcon(3) -c - if (delta .gt. dgxfac*w(dggdmx)) go to 250 - go to 270 -c -c *** special case detected... negate alphak to indicate special case -c - 380 alphak = -alphak - v(preduc) = half * twopsi -c -c *** accept current step if adding si*w would lead to a -c *** further relative reduction in psi of less than v(epslon)/3. -c - t1 = zero - t = si*(alphak*sw - half*si*(alphak + t*dotprd(p,w(x),w))) - if (t .lt. eps*twopsi/six) go to 390 - v(preduc) = v(preduc) + t - dst = rad - t1 = -si - 390 do 400 i = 1, p - j = q0 + i - w(j) = t1*w(i) - w(j) - step(i) = w(j) / d(i) - 400 continue - v(gtstep) = dotprd(p, dig, w(q)) -c -c *** save values for use in a possible restart *** -c - 410 v(dstnrm) = dst - v(stppar) = alphak - w(lk0) = lk - w(uk0) = uk - v(rad0) = rad - w(dstsav) = dst -c -c *** restore diagonal of dihdi *** -c - j = 0 - do 420 i = 1, p - j = j + i - k = diag0 + i - dihdi(j) = w(k) - 420 continue -c - 999 return -c -c *** last card of gqtst follows *** - end - subroutine lsqrt(n1, n, l, a, irc) -c -c *** compute rows n1 through n of the cholesky factor l of -c *** a = l*(l**t), where l and the lower triangle of a are both -c *** stored compactly by rows (and may occupy the same storage). -c *** irc = 0 means all went well. irc = j means the leading -c *** principal j x j submatrix of a is not positive definite -- -c *** and l(j*(j+1)/2) contains the (nonpos.) reduced j-th diagonal. -c -c *** parameters *** -c - integer n1, n, irc -cal double precision l(1), a(1) - double precision l(n*(n+1)/2), a(n*(n+1)/2) -c dimension l(n*(n+1)/2), a(n*(n+1)/2) -c -c *** local variables *** -c - integer i, ij, ik, im1, i0, j, jk, jm1, j0, k - double precision t, td, zero -c -c *** intrinsic functions *** -c/+ - double precision dsqrt -c/ -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c -c *** body *** -c - i0 = n1 * (n1 - 1) / 2 - do 50 i = n1, n - td = zero - if (i .eq. 1) go to 40 - j0 = 0 - im1 = i - 1 - do 30 j = 1, im1 - t = zero - if (j .eq. 1) go to 20 - jm1 = j - 1 - do 10 k = 1, jm1 - ik = i0 + k - jk = j0 + k - t = t + l(ik)*l(jk) - 10 continue - 20 ij = i0 + j - j0 = j0 + j - t = (a(ij) - t) / l(j0) - l(ij) = t - td = td + t*t - 30 continue - 40 i0 = i0 + i - t = a(i0) - td - if (t .le. zero) go to 60 - l(i0) = dsqrt(t) - 50 continue -c - irc = 0 - go to 999 -c - 60 l(i0) = t - irc = i -c - 999 return -c -c *** last card of lsqrt *** - end - double precision function lsvmin(p, l, x, y) -c -c *** estimate smallest sing. value of packed lower triang. matrix l -c -c *** parameter declarations *** -c - integer p -cal double precision l(1), x(p), y(p) - double precision l(p*(p+1)/2), x(p), y(p) -c dimension l(p*(p+1)/2) -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** purpose *** -c -c this function returns a good over-estimate of the smallest -c singular value of the packed lower triangular matrix l. -c -c *** parameter description *** -c -c p (in) = the order of l. l is a p x p lower triangular matrix. -c l (in) = array holding the elements of l in row order, i.e. -c l(1,1), l(2,1), l(2,2), l(3,1), l(3,2), l(3,3), etc. -c x (out) if lsvmin returns a positive value, then x is a normalized -c approximate left singular vector corresponding to the -c smallest singular value. this approximation may be very -c crude. if lsvmin returns zero, then some components of x -c are zero and the rest retain their input values. -c y (out) if lsvmin returns a positive value, then y = (l**-1)*x is an -c unnormalized approximate right singular vector correspond- -c ing to the smallest singular value. this approximation -c may be crude. if lsvmin returns zero, then y retains its -c input value. the caller may pass the same vector for x -c and y (nonstandard fortran usage), in which case y over- -c writes x (for nonzero lsvmin returns). -c -c *** algorithm notes *** -c -c the algorithm is based on (1), with the additional provision that -c lsvmin = 0 is returned if the smallest diagonal element of l -c (in magnitude) is not more than the unit roundoff times the -c largest. the algorithm uses a random number generator proposed -c in (4), which passes the spectral test with flying colors -- see -c (2) and (3). -c -c *** subroutines and functions called *** -c -c v2norm - function, returns the 2-norm of a vector. -c -c *** references *** -c -c (1) cline, a., moler, c., stewart, g., and wilkinson, j.h.(1977), -c an estimate for the condition number of a matrix, report -c tm-310, applied math. div., argonne national laboratory. -c -c (2) hoaglin, d.c. (1976), theoretical properties of congruential -c random-number generators -- an empirical view, -c memorandum ns-340, dept. of statistics, harvard univ. -c -c (3) knuth, d.e. (1969), the art of computer programming, vol. 2 -c (seminumerical algorithms), addison-wesley, reading, mass. -c -c (4) smith, c.s. (1971), multiplicative pseudo-random number -c generators with prime modulus, j. assoc. comput. mach. 18, -c pp. 586-593. -c -c *** history *** -c -c designed and coded by david m. gay (winter 1977/summer 1978). -c -c *** general *** -c -c this subroutine was written in connection with research -c supported by the national science foundation under grants -c mcs-7600324, dcr75-10143, 76-14311dss, and mcs76-11989. -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** local variables *** -c - integer i, ii, ix, j, ji, jj, jjj, jm1, j0, pm1 - double precision b, sminus, splus, t, xminus, xplus -c -c *** constants *** -c - double precision half, one, r9973, zero -c -c *** intrinsic functions *** -c/+ - integer mod - real float - double precision dabs -c/ -c *** external functions and subroutines *** -c - external dotprd, v2norm, vaxpy - double precision dotprd, v2norm -c -c/6 -c data half/0.5d+0/, one/1.d+0/, r9973/9973.d+0/, zero/0.d+0/ -c/7 - parameter (half=0.5d+0, one=1.d+0, r9973=9973.d+0, zero=0.d+0) -c/ -c -c *** body *** -c - ix = 2 - pm1 = p - 1 -c -c *** first check whether to return lsvmin = 0 and initialize x *** -c - ii = 0 - j0 = p*pm1/2 - jj = j0 + p - if (l(jj) .eq. zero) go to 110 - ix = mod(3432*ix, 9973) - b = half*(one + float(ix)/r9973) - xplus = b / l(jj) - x(p) = xplus - if (p .le. 1) go to 60 - do 10 i = 1, pm1 - ii = ii + i - if (l(ii) .eq. zero) go to 110 - ji = j0 + i - x(i) = xplus * l(ji) - 10 continue -c -c *** solve (l**t)*x = b, where the components of b have randomly -c *** chosen magnitudes in (.5,1) with signs chosen to make x large. -c -c do j = p-1 to 1 by -1... - do 50 jjj = 1, pm1 - j = p - jjj -c *** determine x(j) in this iteration. note for i = 1,2,...,j -c *** that x(i) holds the current partial sum for row i. - ix = mod(3432*ix, 9973) - b = half*(one + float(ix)/r9973) - xplus = (b - x(j)) - xminus = (-b - x(j)) - splus = dabs(xplus) - sminus = dabs(xminus) - jm1 = j - 1 - j0 = j*jm1/2 - jj = j0 + j - xplus = xplus/l(jj) - xminus = xminus/l(jj) - if (jm1 .eq. 0) go to 30 - do 20 i = 1, jm1 - ji = j0 + i - splus = splus + dabs(x(i) + l(ji)*xplus) - sminus = sminus + dabs(x(i) + l(ji)*xminus) - 20 continue - 30 if (sminus .gt. splus) xplus = xminus - x(j) = xplus -c *** update partial sums *** - if (jm1 .gt. 0) call vaxpy(jm1, x, xplus, l(j0+1), x) - 50 continue -c -c *** normalize x *** -c - 60 t = one/v2norm(p, x) - do 70 i = 1, p - 70 x(i) = t*x(i) -c -c *** solve l*y = x and return lsvmin = 1/twonorm(y) *** -c - do 100 j = 1, p - jm1 = j - 1 - j0 = j*jm1/2 - jj = j0 + j - t = zero - if (jm1 .gt. 0) t = dotprd(jm1, l(j0+1), y) - y(j) = (x(j) - t) / l(jj) - 100 continue -c - lsvmin = one/v2norm(p, y) - go to 999 -c - 110 lsvmin = zero - 999 return -c *** last card of lsvmin follows *** - end - subroutine slvmul(p, y, s, x) -c -c *** set y = s * x, s = p x p symmetric matrix. *** -c *** lower triangle of s stored rowwise. *** -c -c *** parameter declarations *** -c - integer p -cal double precision s(1), x(p), y(p) - double precision s(p*(p+1)/2), x(p), y(p) -c dimension s(p*(p+1)/2) -c -c *** local variables *** -c - integer i, im1, j, k - double precision xi -c -c *** no intrinsic functions *** -c -c *** external function *** -c - external dotprd - double precision dotprd -c -c----------------------------------------------------------------------- -c - j = 1 - do 10 i = 1, p - y(i) = dotprd(i, s(j), x) - j = j + i - 10 continue -c - if (p .le. 1) go to 999 - j = 1 - do 40 i = 2, p - xi = x(i) - im1 = i - 1 - j = j + 1 - do 30 k = 1, im1 - y(k) = y(k) + s(j)*xi - j = j + 1 - 30 continue - 40 continue -c - 999 return -c *** last card of slvmul follows *** - end diff --git a/source/unres/src_MD_DFA/dfa.F b/source/unres/src_MD_DFA/dfa.F deleted file mode 100644 index 576910c..0000000 --- a/source/unres/src_MD_DFA/dfa.F +++ /dev/null @@ -1,3455 +0,0 @@ - subroutine init_dfa_vars - - include 'DIMENSIONS' - include 'COMMON.INTERACT' - include 'COMMON.DFA' - - integer ii - -C Number of restraints - idisnum = 0 - iphinum = 0 - ithenum = 0 - ineinum = 0 - - idislis = 0 - iphilis = 0 - ithelis = 0 - ineilis = 0 - jneilis = 0 - jneinum = 0 - kshell = 0 - fnei = 0 -C For beta - nca = 0 - icaidx = 0 - -C real variables -CC WEIGHTS for each min - sccdist = 0.0d0 - fdist = 0.0d0 - sccphi = 0.0d0 - sccthe = 0.0d0 - sccnei = 0.0d0 - fphi1 = 0.0d0 - fphi2 = 0.0d0 - fthe1 = 0.0d0 - fthe2 = 0.0d0 -C energies - edfatot = 0.0d0 - edfadis = 0.0d0 - edfaphi = 0.0d0 - edfathe = 0.0d0 - edfanei = 0.0d0 - edfabet = 0.0d0 -C weights for each E term -C these should be identical with - dis_inc = 0.0d0 - phi_inc = 0.0d0 - the_inc = 0.0d0 - nei_inc = 0.0d0 - beta_inc = 0.0d0 - wshet = 0.0d0 -C precalculate exp table! -c dfaexp = 0.0d0 -c do ii = 1, 15001 -c dfaexp(ii) = exp(-ii*0.001d0 + 0.0005d0) -c end do - - ishiftca=nnt-1 - ilastca=nct - - print *,'ishiftca=',ishiftca,'ilastca=',ilastca - - return - end - - - subroutine read_dfa_info -C -C read fragment informations -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DFA' - - -C NOTE THAT FILENAMES are FIXED, CURRENTLY!! -C THIS SHOULD BE MODIFIED!! - - character*320 buffer - integer iodfa - parameter(iodfa=89) - - integer i, j, nval - integer ica1, ica2,ica3,ica4,ica5 - integer ishell, inca, itmp,iitmp - double precision wtmp -C -C READ DISTANCE -C - open(iodfa, file = 'dist_dfa.dat', status = 'old', err=33) - goto 34 - 33 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - 34 continue - write(iout,'(a)') 'dist_dfa.dat is opened!' -C read title - read(iodfa, '(a)') buffer -C read number of restraints - read(iodfa, *) IDFADIS - read(iodfa, *) dis_inc - do i=1, idfadis - read(iodfa, '(i10,1x,i10,1x,i10)') ica1, ica2, nval - - idisnum(i)=nval - idislis(1,i)=ica1 - idislis(2,i)=ica2 - - do j=1, nval - read(iodfa,*) tmp - fdist(i,j) = tmp - enddo - - do j=1, nval - read(iodfa,*) tmp - sccdist(i,j) = tmp - enddo - - enddo - close(iodfa) - -C READ ANGLE RESTRAINTS -C PHI RESTRAINTS - open(iodfa, file='phi_dfa.dat',status='old',err=35) - goto 36 - 35 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - - 36 continue - write(iout,'(a)') 'phi_dfa.dat is opened!' - -C READ TITLE - read(iodfa, '(a)') buffer -C READ NUMBER OF RESTRAINTS - READ(iodfa, *) IDFAPHI - read(iodfa,*) phi_inc - do i=1, idfaphi - read(iodfa,'(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval - - iphinum(i)=nval - - iphilis(1,i)=ica1 - iphilis(2,i)=ica2 - iphilis(3,i)=ica3 - iphilis(4,i)=ica4 - iphilis(5,i)=ica5 - - do j=1, nval - read(iodfa,*) tmp1,tmp2 - fphi1(i,j) = tmp1 - fphi2(i,j) = tmp2 - enddo - - do j=1, nval - read(iodfa,*) tmp - sccphi(i,j) = tmp - enddo - - enddo - close(iodfa) - -C THETA RESTRAINTS - open(iodfa, file='theta_dfa.dat',status='old',err=41) - goto 42 - 41 write(iout,'(a)') 'Error opening dist_dfa.dat file' - stop - 42 continue - write(iout,'(a)') 'theta_dfa.dat is opened!' -C READ TITLE - read(iodfa, '(a)') buffer -C READ NUMBER OF RESTRAINTS - READ(iodfa, *) IDFATHE - read(iodfa,*) the_inc - - do i=1, idfathe - read(iodfa, '(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval - - ithenum(i)=nval - - ithelis(1,i)=ica1 - ithelis(2,i)=ica2 - ithelis(3,i)=ica3 - ithelis(4,i)=ica4 - ithelis(5,i)=ica5 - - do j=1, nval - read(iodfa,*) tmp1,tmp2 - fthe1(i,j) = tmp1 - fthe2(i,j) = tmp2 - enddo - - do j=1, nval - read(iodfa,*) tmp - sccthe(i,j) = tmp - enddo - - enddo - close(iodfa) -C END of READING ANGLE RESTRAINT! - -C NUMBER OF NEIGHBOR CAs - open(iodfa,file='nei_dfa.dat',status='old',err=37) - goto 38 - 37 write(iout,'(a)') 'Error opening nei_dfa.dat file' - stop - 38 continue - write(iout,'(a)') 'nei_dfa.dat is opened!' -C READ TITLE - read(iodfa, '(a)') buffer -C READ NUMBER OF RESTRAINTS - READ(iodfa, *) idfanei - read(iodfa,*) nei_inc - - do i=1, idfanei - read(iodfa,'(2(i10,1x),i10)')ica1,ishell,nval - - ineilis(i)=ica1 - kshell(i)=ishell - ineinum(i)=nval - - do j=1, nval - read(iodfa,*) inca - fnei(i,j) = inca -C write(*,*) 'READ NEI:',i,j,fnei(i,j) - enddo - - do j=1, nval - read(iodfa,*) tmp - sccnei(i,j) = tmp - enddo - - enddo - close(iodfa) -C END OF NEIGHBORING CA - -C READ BETA RESTRAINT - open(iodfa, file='beta_dfa.dat',status='old',err=39) - goto 40 - 39 write(iout,'(a)') 'Error opening beta_dfa.dat file' - stop - 40 continue - write(iout,'(a)') 'beta_dfa.dat is opened!' - - read(iodfa,'(a)') buffer - read(iodfa,*) itmp - read(iodfa,*) beta_inc - - do i=1,itmp - read(iodfa,*) ica1, iitmp - do j=1,itmp - read(iodfa,*) wtmp - wshet(i,j) = wtmp -c write(*,*) 'BETA:',i,j,wtmp,wshet(i,j) - enddo - enddo - - close(iodfa) -C END OF BETA RESTRAINT - - return - END - - subroutine edfad(edfadis) - - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - double precision edfadis - integer i, iatm1, iatm2,idiff - double precision ckk, sckk,dist,texp - double precision jix,jiy,jiz,ep,fp,scc - - edfadis=0 - gdfad=0.0d0 - - do i=1, idfadis - - iatm1=idislis(1,i)+ishiftca - iatm2=idislis(2,i)+ishiftca - idiff = abs(iatm1-iatm2) - - JIX=c(1,iatm2)-c(1,iatm1) - JIY=c(2,iatm2)-c(2,iatm1) - JIZ=c(3,iatm2)-c(3,iatm1) - DIST=SQRT(JIX*JIX+JIY*JIY+JIZ*JIZ) - - ckk=ck(idiff) - sckk=sck(idiff) - - scc = 0.0d0 - ep = 0.0d0 - fp = 0.0d0 - - do j=1,idisnum(i) - - dd = dist-fdist(i,j) - dtmp = dd*dd/ckk - if (dtmp.ge.15.0d0) then - texp = 0.0d0 - else -c texp = dfaexp( idint(dtmp*1000)+1 )/sckk - texp = exp(-dtmp)/sckk - endif - - ep=ep+sccdist(i,j)*texp - fp=fp+sccdist(i,j)*texp*dd*2.0d0/ckk - scc=scc+sccdist(i,j) -C write(*,'(2i8,6f12.5)') i, j, dist, -C & fdist(i,j), ep, fp, sccdist(i,j), scc - - enddo - - ep = -ep/scc - fp = fp/scc - - -c IF(ABS(EP).lt.1.0d-20)THEN -c EP=0.0D0 -c ENDIF -c IF (ABS(FP).lt.1.0d-20) THEN -c FP=0.0D0 -c ENDIF - - edfadis=edfadis+ep*dis_inc*wwdist - - gdfad(1,iatm1) = gdfad(1,iatm1)-jix/dist*fp*dis_inc*wwdist - gdfad(2,iatm1) = gdfad(2,iatm1)-jiy/dist*fp*dis_inc*wwdist - gdfad(3,iatm1) = gdfad(3,iatm1)-jiz/dist*fp*dis_inc*wwdist - - gdfad(1,iatm2) = gdfad(1,iatm2)+jix/dist*fp*dis_inc*wwdist - gdfad(2,iatm2) = gdfad(2,iatm2)+jiy/dist*fp*dis_inc*wwdist - gdfad(3,iatm2) = gdfad(3,iatm2)+jiz/dist*fp*dis_inc*wwdist - - enddo - - return - end - - subroutine edfat(edfator) -C DFA torsion angle - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - integer i,j,ii,iii - integer iatom(5) - double precision aphi(2),athe(2),tdx(5),tdy(5),tdz(5) - double precision cwidth, cwidth2 - PARAMETER(CWIDTH=0.1D0,CWIDTH2=0.2D0,PAI=3.14159265358979323846D0) - - edfator= 0.0d0 - enephi = 0.0d0 - enethe = 0.0d0 - gdfat(:,:) = 0.0d0 - -C START OF PHI ANGLE - do i=1, idfaphi - - aphi = 0.0d0 - do iii=1,5 - iatom(iii)=iphilis(iii,i)+ishiftca - enddo - -C ANGLE VECTOR CALCULTION - RIX=C(1,IATOM(2))-C(1,IATOM(1)) - RIY=C(2,IATOM(2))-C(2,IATOM(1)) - RIZ=C(3,IATOM(2))-C(3,IATOM(1)) - - RIPX=C(1,IATOM(3))-C(1,IATOM(2)) - RIPY=C(2,IATOM(3))-C(2,IATOM(2)) - RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) - - RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) - RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) - RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) - - RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) - RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) - RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) - - GIX=RIY*RIPZ-RIZ*RIPY - GIY=RIZ*RIPX-RIX*RIPZ - GIZ=RIX*RIPY-RIY*RIPX - - GIPX=RIPY*RIPPZ-RIPZ*RIPPY - GIPY=RIPZ*RIPPX-RIPX*RIPPZ - GIPZ=RIPX*RIPPY-RIPY*RIPPX - - CIPX=C(1,IATOM(3))-C(1,IATOM(1)) - CIPY=C(2,IATOM(3))-C(2,IATOM(1)) - CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) - - CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) - CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) - CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) - - CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) - CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) - CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) - - DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) - DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) - DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) - DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) - -C END OF ANGLE VECTOR CALCULTION - - TDOT=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ - APHI(1)=TDOT/(DGI*DRIPP) - TDOT=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z - APHI(2)=TDOT/(DGIP*DRIP3) - - ephi = 0.0d0 - tfphi1=0.0d0 - tfphi2=0.0d0 - scc=0.0d0 - - do j=1, iphinum(i) - DDPS1=APHI(1)-FPHI1(i,j) - DDPS2=APHI(2)-FPHI2(i,j) - - DTMP = (DDPS1**2+DDPS2**2)/CWIDTH2 - - if (dtmp.ge.15.0d0) then - ps_tmp = 0.0d0 - else -c ps_tmp = dfaexp(idint(dtmp*1000)+1) - ps_tmp = exp(-dtmp) - endif - - ephi=ephi+sccphi(i,j)*ps_tmp - - tfphi1=tfphi1+sccphi(i,j)*ddps1/cwidth*ps_tmp - tfphi2=tfphi2+sccphi(i,j)*ddps2/cwidth*ps_tmp - - scc=scc+sccphi(i,j) -C write(*,'(2i8,8f12.6)')i,j,aphi(1),fphi1(i,j), -C & aphi(2),fphi2(i,j),tfphi1,tfphi2,ephi,sccphi(i,j) - ENDDO - - ephi=-ephi/scc*phi_inc*wwangle - tfphi1=tfphi1/scc*phi_inc*wwangle - tfphi2=tfphi2/scc*phi_inc*wwangle - - IF (ABS(EPHI).LT.1d-20) THEN - EPHI=0.0D0 - ENDIF - IF (ABS(TFPHI1).LT.1d-20) THEN - TFPHI1=0.0D0 - ENDIF - IF (ABS(TFPHI2).LT.1d-20) THEN - TFPHI2=0.0D0 - ENDIF - -C FORCE DIRECTION CALCULATION - TDX(1:5)=0.0D0 - TDY(1:5)=0.0D0 - TDZ(1:5)=0.0D0 - - DM1=1.0d0/(DGI*DRIPP) - - GIRPP=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ - DM2=GIRPP/(DGI**3*DRIPP) - DM3=GIRPP/(DGI*DRIPP**3) - - DM4=1.0d0/(DGIP*DRIP3) - - GIRP3=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z - DM5=GIRP3/(DGIP**3*DRIP3) - DM6=GIRP3/(DGIP*DRIP3**3) -C FIRST ATOM BY PHI1 - TDX(1)=(RIPZ*RIPPY-RIPY*RIPPZ)*DM1 - & +( GIZ* RIPY- GIY* RIPZ)*DM2 - TDY(1)=(RIPX*RIPPZ-RIPZ*RIPPX)*DM1 - & +( GIX* RIPZ- GIZ* RIPX)*DM2 - TDZ(1)=(RIPY*RIPPX-RIPX*RIPPY)*DM1 - & +( GIY* RIPX- GIX* RIPY)*DM2 - TDX(1)=TDX(1)*TFPHI1 - TDY(1)=TDY(1)*TFPHI1 - TDZ(1)=TDZ(1)*TFPHI1 -C SECOND ATOM BY PHI1 - TDX(2)=(CIPY*RIPPZ-CIPZ*RIPPY)*DM1 - & -(CIPY*GIZ-CIPZ*GIY)*DM2 - TDY(2)=(CIPZ*RIPPX-CIPX*RIPPZ)*DM1 - & -(CIPZ*GIX-CIPX*GIZ)*DM2 - TDZ(2)=(CIPX*RIPPY-CIPY*RIPPX)*DM1 - & -(CIPX*GIY-CIPY*GIX)*DM2 - TDX(2)=TDX(2)*TFPHI1 - TDY(2)=TDY(2)*TFPHI1 - TDZ(2)=TDZ(2)*TFPHI1 -C SECOND ATOM BY PHI2 - TDX(2)=TDX(2)+ - & ((RIPPZ*RIP3Y-RIPPY*RIP3Z)*DM4 - & +( GIPZ*RIPPY- GIPY*RIPPZ)*DM5)*TFPHI2 - TDY(2)=TDY(2)+ - & ((RIPPX*RIP3Z-RIPPZ*RIP3X)*DM4 - & +( GIPX*RIPPZ- GIPZ*RIPPX)*DM5)*TFPHI2 - TDZ(2)=TDZ(2)+ - & ((RIPPY*RIP3X-RIPPX*RIP3Y)*DM4 - & +( GIPY*RIPPX- GIPX*RIPPY)*DM5)*TFPHI2 -C THIRD ATOM BY PHI1 - TDX(3)=(-GIX+RIPPY*RIZ-RIPPZ*RIY)*DM1 - & -(GIY*RIZ-RIY*GIZ)*DM2+RIPPX*DM3 - TDY(3)=(-GIY+RIPPZ*RIX-RIPPX*RIZ)*DM1 - & -(GIZ*RIX-RIZ*GIX)*DM2+RIPPY*DM3 - TDZ(3)=(-GIZ+RIPPX*RIY-RIPPY*RIX)*DM1 - & -(GIX*RIY-RIX*GIY)*DM2+RIPPZ*DM3 - TDX(3)=TDX(3)*TFPHI1 - TDY(3)=TDY(3)*TFPHI1 - TDZ(3)=TDZ(3)*TFPHI1 -C THIRD ATOM BY PHI2 - TDX(3)=TDX(3)+ - & ((CIPPY*RIP3Z-CIPPZ*RIP3Y)*DM4 - & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5)*TFPHI2 - TDY(3)=TDY(3)+ - & ((CIPPZ*RIP3X-CIPPX*RIP3Z)*DM4 - & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5)*TFPHI2 - TDZ(3)=TDZ(3)+ - & ((CIPPX*RIP3Y-CIPPY*RIP3X)*DM4 - & -(CIPPX*GIPY-CIPPY*GIPX)*DM5)*TFPHI2 -C FOURTH ATOM BY PHI1 - TDX(4)=(GIX*DM1-RIPPX*DM3)*TFPHI1 - TDY(4)=(GIY*DM1-RIPPY*DM3)*TFPHI1 - TDZ(4)=(GIZ*DM1-RIPPZ*DM3)*TFPHI1 -C FOURTH ATOM BY PHI2 - TDX(4)=TDX(4)+ - & ((-GIPX+RIP3Y*RIPZ-RIP3Z*RIPY)*DM4 - & -( GIPY*RIPZ-RIPY*GIPZ)*DM5 - & + RIP3X*DM6)*TFPHI2 - TDY(4)=TDY(4)+ - & ((-GIPY+RIP3Z*RIPX-RIP3X*RIPZ)*DM4 - & -( GIPZ*RIPX-RIPZ*GIPX)*DM5 - & + RIP3Y*DM6)*TFPHI2 - TDZ(4)=TDZ(4)+ - & ((-GIPZ+RIP3X*RIPY-RIP3Y*RIPX)*DM4 - & -( GIPX*RIPY-RIPX*GIPY)*DM5 - & + RIP3Z*DM6)*TFPHI2 -C FIFTH ATOM BY PHI2 - TDX(5)=(GIPX*DM4-RIP3X*DM6)*TFPHI2 - TDY(5)=(GIPY*DM4-RIP3Y*DM6)*TFPHI2 - TDZ(5)=(GIPZ*DM4-RIP3Z*DM6)*TFPHI2 -C END OF FORCE DIRECTION -c force calcuation - DO II=1,5 - gdfat(1,IATOM(II))=gdfat(1,IATOM(II))+TDX(II) - gdfat(2,IATOM(II))=gdfat(2,IATOM(II))+TDY(II) - gdfat(3,IATOM(II))=gdfat(3,IATOM(II))+TDZ(II) - ENDDO -c energy calculation - enephi = enephi + ephi -c end of single assignment statement - ENDDO -C END OF PHI RESTRAINT - -C START OF THETA ANGLE - do i=1, idfathe - - athe = 0.0d0 - do iii=1,5 - iatom(iii)=ithelis(iii,i)+ishiftca - enddo - - -C ANGLE VECTOR CALCULTION - RIX=C(1,IATOM(2))-C(1,IATOM(1)) - RIY=C(2,IATOM(2))-C(2,IATOM(1)) - RIZ=C(3,IATOM(2))-C(3,IATOM(1)) - - RIPX=C(1,IATOM(3))-C(1,IATOM(2)) - RIPY=C(2,IATOM(3))-C(2,IATOM(2)) - RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) - - RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) - RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) - RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) - - RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) - RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) - RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) - - GIX=RIY*RIPZ-RIZ*RIPY - GIY=RIZ*RIPX-RIX*RIPZ - GIZ=RIX*RIPY-RIY*RIPX - - GIPX=RIPY*RIPPZ-RIPZ*RIPPY - GIPY=RIPZ*RIPPX-RIPX*RIPPZ - GIPZ=RIPX*RIPPY-RIPY*RIPPX - - GIPPX=RIPPY*RIP3Z-RIPPZ*RIP3Y - GIPPY=RIPPZ*RIP3X-RIPPX*RIP3Z - GIPPZ=RIPPX*RIP3Y-RIPPY*RIP3X - - CIPX=C(1,IATOM(3))-C(1,IATOM(1)) - CIPY=C(2,IATOM(3))-C(2,IATOM(1)) - CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) - - CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) - CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) - CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) - - CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) - CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) - CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) - - DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) - DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) - DGIPP=SQRT(GIPPX*GIPPX+GIPPY*GIPPY+GIPPZ*GIPPZ) - DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) - DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) -C END OF ANGLE VECTOR CALCULTION - - TDOT=GIX*GIPX+GIY*GIPY+GIZ*GIPZ - ATHE(1)=TDOT/(DGI*DGIP) - TDOT=GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ - ATHE(2)=TDOT/(DGIP*DGIPP) - - ETHE=0.0D0 - TFTHE1=0.0D0 - TFTHE2=0.0D0 - SCC=0.0D0 - TH_TMP=0.0d0 - - do j=1,ithenum(i) - ddth1=athe(1)-fthe1(i,j) !cos(the1)-cos(the1_ref) - ddth2=athe(2)-fthe2(i,j) !cos(the2)-cos(the2_ref) - dtmp= (ddth1**2+ddth2**2)/cwidth2 - if ( dtmp .ge. 15.0d0) then - th_tmp = 0.0d0 - else -c th_tmp = dfaexp ( idint(dtmp*1000)+1 ) - th_tmp = exp(-dtmp) - end if - - ethe=ethe+sccthe(i,j)*th_tmp - - tfthe1=tfthe1+sccthe(i,j)*ddth1/cwidth*th_tmp !-dv/dcos(the1) - tfthe2=tfthe2+sccthe(i,j)*ddth2/cwidth*th_tmp !-dv/dcos(the2) - scc=scc+sccthe(i,j) -C write(*,'(2i8,8f12.6)')i,j,athe(1),fthe1(i,j), -C & athe(2),fthe2(i,j),tfthe1,tfthe2,ethe,sccthe(i,j) - enddo - - ethe=-ethe/scc*the_inc*wwangle - tfthe1=tfthe1/scc*the_inc*wwangle - tfthe2=tfthe2/scc*the_inc*wwangle - - IF (ABS(ETHE).LT.TENM20) THEN - ETHE=0.0D0 - ENDIF - IF (ABS(TFTHE1).LT.TENM20) THEN - TFTHE1=0.0D0 - ENDIF - IF (ABS(TFTHE2).LT.TENM20) THEN - TFTHE2=0.0D0 - ENDIF - - TDX(1:5)=0.0D0 - TDY(1:5)=0.0D0 - TDZ(1:5)=0.0D0 - - DM1=1.0d0/(DGI*DGIP) - DM2=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI**3*DGIP) - DM3=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI*DGIP**3) - - DM4=1.0d0/(DGIP*DGIPP) - DM5=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP**3*DGIPP) - DM6=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP*DGIPP**3) - -C FIRST ATOM BY THETA1 - TDX(1)=((RIPZ*GIPY-RIPY*GIPZ)*DM1 - & -(GIY*RIPZ-GIZ*RIPY)*DM2)*TFTHE1 - TDY(1)=((-RIPZ*GIPX+RIPX*GIPZ)*DM1 - & -(-GIX*RIPZ+GIZ*RIPX)*DM2)*TFTHE1 - TDZ(1)=((RIPY*GIPX-RIPX*GIPY)*DM1 - & -(GIX*RIPY-GIY*RIPX)*DM2)*TFTHE1 -C SECOND ATOM BY THETA1 - TDX(2)=((CIPY*GIPZ-CIPZ*GIPY-RIPPY*GIZ+RIPPZ*GIY)*DM1 - & -(CIPY*GIZ-CIPZ*GIY)*DM2 - & +(RIPPY*GIPZ-RIPPZ*GIPY)*DM3)*TFTHE1 - TDY(2)=((CIPZ*GIPX-CIPX*GIPZ-RIPPZ*GIX+RIPPX*GIZ)*DM1 - & -(CIPZ*GIX-CIPX*GIZ)*DM2 - & +(RIPPZ*GIPX-RIPPX*GIPZ)*DM3)*TFTHE1 - TDZ(2)=((CIPX*GIPY-CIPY*GIPX-RIPPX*GIY+RIPPY*GIX)*DM1 - & -(CIPX*GIY-CIPY*GIX)*DM2 - & +(RIPPX*GIPY-RIPPY*GIPX)*DM3)*TFTHE1 -C SECOND ATOM BY THETA2 - TDX(2)=TDX(2)+ - & ((RIPPZ*GIPPY-RIPPY*GIPPZ)*DM4 - & -(GIPY*RIPPZ-GIPZ*RIPPY)*DM5)*TFTHE2 - TDY(2)=TDY(2)+ - & ((-RIPPZ*GIPPX+RIPPX*GIPPZ)*DM4 - & -(-GIPX*RIPPZ+GIPZ*RIPPX)*DM5)*TFTHE2 - TDZ(2)=TDZ(2)+ - & ((RIPPY*GIPPX-RIPPX*GIPPY)*DM4 - & -(GIPX*RIPPY-GIPY*RIPPX)*DM5)*TFTHE2 -C THIRD ATOM BY THETA1 - TDX(3)=((GIPY*RIZ-GIPZ*RIY-GIY*CIPPZ+GIZ*CIPPY)*DM1 - & -(GIY*RIZ-GIZ*RIY)*DM2 - & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM3) *TFTHE1 - TDY(3)=((GIPZ*RIX-GIPX*RIZ-GIZ*CIPPX+GIX*CIPPZ)*DM1 - & -(GIZ*RIX-GIX*RIZ)*DM2 - & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM3) *TFTHE1 - TDZ(3)=((GIPX*RIY-GIPY*RIX-GIX*CIPPY+GIY*CIPPX)*DM1 - & -(GIX*RIY-GIY*RIX)*DM2 - & -(CIPPX*GIPY-CIPPY*GIPX)*DM3) *TFTHE1 -C THIRD ATOM BY THETA2 - TDX(3)=TDX(3)+ - & ((CIPPY*GIPPZ-CIPPZ*GIPPY-RIP3Y*GIPZ+RIP3Z*GIPY)*DM4 - & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5 - & +(RIP3Y*GIPpZ-RIP3Z*GIPpY)*DM6) *TFTHE2 - TDY(3)=TDY(3)+ - & ((CIPPZ*GIPPX-CIPPX*GIPPZ-RIP3Z*GIPX+RIP3X*GIPZ)*DM4 - & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5 - & +(RIP3Z*GIPpX-RIP3X*GIPpZ)*DM6) *TFTHE2 - TDZ(3)=TDZ(3)+ - & ((CIPPX*GIPPY-CIPPY*GIPPX-RIP3X*GIPY+RIP3Y*GIPX)*DM4 - & -(CIPPX*GIPY-CIPPY*GIPX)*DM5 - & +(RIP3X*GIPpY-RIP3Y*GIPpX)*DM6) *TFTHE2 -C FOURTH ATOM BY THETA1 - TDX(4)=-((GIZ*RIPY-GIY*RIPZ)*DM1 - & -(GIPZ*RIPY-GIPY*RIPZ)*DM3) *TFTHE1 - TDY(4)=-((GIX*RIPZ-GIZ*RIPX)*DM1 - & -(GIPX*RIPZ-GIPZ*RIPX)*DM3) *TFTHE1 - TDZ(4)=-((GIY*RIPX-GIX*RIPY)*DM1 - & -(GIPY*RIPX-GIPX*RIPY)*DM3) *TFTHE1 -C FOURTH ATOM BY THETA2 - TDX(4)=TDX(4)+ - & ((GIPPY*RIPZ-GIPPZ*RIPY-GIPY*CIP3Z+GIPZ*CIP3Y)*DM4 - & -(GIPY*RIPZ-GIPZ*RIPY)*DM5 - & -(CIP3Y*GIPPZ-CIP3Z*GIPPY)*DM6)*TFTHE2 - TDY(4)=TDY(4)+ - & ((GIPPZ*RIPX-GIPPX*RIPZ-GIPZ*CIP3X+GIPX*CIP3Z)*DM4 - & -(GIPZ*RIPX-GIPX*RIPZ)*DM5 - & -(CIP3Z*GIPPX-CIP3X*GIPPZ)*DM6)*TFTHE2 - TDZ(4)=TDZ(4)+ - & ((GIPPX*RIPY-GIPPY*RIPX-GIPX*CIP3Y+GIPY*CIP3X)*DM4 - & -(GIPX*RIPY-GIPY*RIPX)*DM5 - & -(CIP3X*GIPPY-CIP3Y*GIPPX)*DM6)*TFTHE2 -C FIFTH ATOM BY THETA2 - TDX(5)=-((GIPZ*RIPPY-GIPY*RIPPZ)*DM4 - & -(GIPPZ*RIPPY-GIPPY*RIPPZ)*DM6)*TFTHE2 - TDY(5)=-((GIPX*RIPPZ-GIPZ*RIPPX)*DM4 - & -(GIPPX*RIPPZ-GIPPZ*RIPPX)*DM6)*TFTHE2 - TDZ(5)=-((GIPY*RIPPX-GIPX*RIPPY)*DM4 - & -(GIPPY*RIPPX-GIPPX*RIPPY)*DM6)*TFTHE2 -C !! END OF FORCE DIRECTION!!!! - DO II=1,5 - gdfat(1,iatom(II))=gdfat(1,iatom(II))+TDX(II) - gdfat(2,iatom(II))=gdfat(2,iatom(II))+TDY(II) - gdfat(3,iatom(II))=gdfat(3,iatom(II))+TDZ(II) - ENDDO -C energy calculation - enethe = enethe + ethe - ENDDO - - edfator = enephi + enethe - - RETURN - END - - subroutine edfan(edfanei) -C DFA neighboring CA restraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - integer i,j,imin - integer kshnum, n1atom - - double precision enenei,tmp_n - double precision pai,hpai - double precision jix,jiy,jiz,ndiff,snorm_nei - double precision t2dx(maxres),t2dy(maxres),t2dz(maxres) - double precision dr,dr2,half,ntmp,dtmp - - parameter(dr=0.25d0,dr2=0.50d0,half=0.50d0) - parameter(pai=3.14159265358979323846D0) - parameter(hpai=1.5707963267948966D0) - parameter(snorm_nei=0.886226925452758D0) - - edfanei = 0.0d0 - enenei = 0.0d0 - gdfan = 0.0d0 - -c print*, 's1:', s1(:) -c print*, 's2:', s2(:) - - do i=1, idfanei - - kshnum=kshell(i) - n1atom=ineilis(i)+ishiftca -C write(*,*) 'kshnum,n1atom:', kshnum, n1atom - - tmp_n=0.0d0 - ftmp=0.0d0 - dnei=0.0d0 - dist=0.0d0 - t1dx=0.0d0 - t1dy=0.0d0 - t1dz=0.0d0 - t2dx=0.0d0 - t2dy=0.0d0 - t2dz=0.0d0 - - do j = ishiftca+1, ilastca - - if (n1atom.eq.j) cycle - - jix=c(1,j)-c(1,n1atom) - jiy=c(2,j)-c(2,n1atom) - jiz=c(3,j)-c(3,n1atom) - dist=sqrt(jix*jix+jiy*jiy+jiz*jiz) - -c write(*,*) n1atom, j, dist - - if(kshnum.ne.1)then - if (dist.lt.s1(kshnum).and. - & dist.gt.s2(kshnum-1)) then - - tmp_n=tmp_n+1.0d0 - -c write(*,*) 'case1:',tmp_n - - t1dx=t1dx+0.0d0 - t1dy=t1dy+0.0d0 - t1dz=t1dz+0.0d0 - t2dx(j)=0.0d0 - t2dy(j)=0.0d0 - t2dz(j)=0.0d0 - - elseif(dist.ge.s1(kshnum).and. - & dist.le.s2(kshnum)) then - - dnei=(dist-s1(kshnum))/dr2*pai - tmp_n=tmp_n + half*(1+cos(dnei)) -c write(*,*) 'case2:',tmp_n - ftmp=-pai*sin(dnei)/dr2/dist/2.0d0 -c center atom - t1dx=t1dx+jix*ftmp - t1dy=t1dy+jiy*ftmp - t1dz=t1dz+jiz*ftmp -c neighbor atoms - t2dx(j)=-jix*ftmp - t2dy(j)=-jiy*ftmp - t2dz(j)=-jiz*ftmp -c - elseif(dist.ge.s1(kshnum-1).and. - & dist.le.s2(kshnum-1)) then - dnei=(dist-s1(kshnum-1))/dr2*pai - tmp_n=tmp_n + 1.0d0 - half*(1+cos(dnei)) -c write(*,*) 'case3:',tmp_n - ftmp = hpai*sin(dnei)/dr2/dist -c center atom - t1dx=t1dx+jix*ftmp - t1dy=t1dy+jiy*ftmp - t1dz=t1dz+jiz*ftmp -c neighbor atoms - t2dx(j)=-jix*ftmp - t2dy(j)=-jiy*ftmp - t2dz(j)=-jiz*ftmp - - endif - - elseif(kshnum.eq.1) then - - if(dist.lt.s1(kshnum))then - - tmp_n=tmp_n+1.0d0 -c write(*,*) 'case4:',tmp_n - t1dx=t1dx+0.0d0 - t1dy=t1dy+0.0d0 - t1dz=t1dz+0.0d0 - t2dx(j)=0.0d0 - t2dy(j)=0.0d0 - t2dz(j)=0.0d0 - - elseif(dist.ge.s1(kshnum).and. - & dist.le.s2(kshnum))then - - dnei=(dist-s1(kshnum))/dr2*pai - tmp_n=tmp_n + half*(1+cos(dnei)) -c write(*,*) 'case5:',tmp_n - ftmp = -hpai*sin(dnei)/dr2/dist -c center atom - t1dx=t1dx+jix*ftmp - t1dy=t1dy+jiy*ftmp - t1dz=t1dz+jiz*ftmp -c neighbor atoms - t2dx(j)=-jix*ftmp - t2dy(j)=-jiy*ftmp - t2dz(j)=-jiz*ftmp - - endif - endif - enddo - - scc=0.0d0 - enei=0.0d0 - tmp_fnei=0.0d0 - ndiff=0.0d0 - - do imin=1,ineinum(i) - - ndiff = tmp_n-fnei(i,imin) - dtmp = ndiff*ndiff - - if (dtmp.ge.15.0d0) then - ntmp = 0.0d0 - else -c ntmp = dfaexp( idint(dtmp*1000) + 1 ) - ntmp = exp(-dtmp) - end if - - enei=enei+sccnei(i,imin)*ntmp - tmp_fnei=tmp_fnei- - & sccnei(i,imin)*ntmp*ndiff*2.0d0 - scc=scc+sccnei(i,imin) - -c write(*,'(a,1x,2i8,f12.7,i8,3f12.7)')'NEI:',i,imin,tmp_n, -c & fnei(i,imin),sccnei(i,imin),enei,scc - enddo - - enei=-enei/scc*snorm_nei*nei_inc*wwnei - tmp_fnei=tmp_fnei/scc*snorm_nei*nei_inc*wwnei - -c if (abs(enei).lt.1.0d-20)then -c enei=0.0d0 -c endif -c if (abs(tmp_fnei).lt.1.0d-20) then -c tmp_fnei=0.0d0 -c endif - -c force calculation - t1dx=t1dx*tmp_fnei - t1dy=t1dy*tmp_fnei - t1dz=t1dz*tmp_fnei - - do j=ishiftca+1,ilastca - t2dx(j)=t2dx(j)*tmp_fnei - t2dy(j)=t2dy(j)*tmp_fnei - t2dz(j)=t2dz(j)*tmp_fnei - enddo - - gdfan(1,n1atom)=gdfan(1,n1atom)+t1dx - gdfan(2,n1atom)=gdfan(2,n1atom)+t1dy - gdfan(3,n1atom)=gdfan(3,n1atom)+t1dz - - do j=ishiftca+1,ilastca - gdfan(1,j)=gdfan(1,j)+t2dx(j) - gdfan(2,j)=gdfan(2,j)+t2dy(j) - gdfan(3,j)=gdfan(3,j)+t2dz(j) - enddo -c energy calculation - - enenei=enenei+enei - - enddo - - edfanei=enenei - - return - end - - subroutine edfab(edfabeta) - - implicit real*8 (a-h,o-z) - - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.DFA' - - real*8 PAI - parameter(PAI=3.14159265358979323846D0) - parameter (maxca=800) -C sheet variables - real*8 bx(maxres),by(maxres),bz(maxres) - real*8 vbet(maxres,maxres) - real*8 shetfx(maxres),shetfy(maxres),shetfz(maxres) - real*8 shefx(maxres,12),shefy(maxres,12),shefz(maxres,12) - real*8 vbeta,vbetp,vbetm - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - & c00,s00,ulnex,dnex - real*8 dp45,dm45,w_beta - - real*8 cph(maxca),cth(maxca) - real*8 atx(maxca),aty(maxca),atz(maxca) - real*8 atmx(maxca),atmy(maxca),atmz(maxca) - real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) - real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) - real*8 sth(maxca) - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - - real*8 atxnum(maxca),atynum(maxca),atznum(maxca), - & astxnum(maxca),astynum(maxca),astznum(maxca), - & atmxnum(maxca),atmynum(maxca),atmznum(maxca), - & astmxnum(maxca),astmynum(maxca),astmznum(maxca), - & atmmxnum(maxca),atmmynum(maxca),atmmznum(maxca), - & astmmxnum(maxca),astmmynum(maxca),astmmznum(maxca), - & atm3xnum(maxca),atm3ynum(maxca),atm3znum(maxca), - & astm3xnum(maxca),astm3ynum(maxca),astm3znum(maxca), - & cth_orig(maxca),sth_orig(maxca) - - common /sheca/ bx,by,bz - common /shee/ vbeta,vbet,vbetp,vbetm - common /shetf/ shetfx,shetfy,shetfz - common /shef/ shefx, shefy, shefz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - & c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - - common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, - $ atmmz,atm3x,atm3y,atm3z - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - $ astmmz,astm3x,astm3y,astm3z - - common /coscos/ cph,cth - common /sinsin/ sth - -C End of sheet variables - - integer i,j - double precision enebet - - enebet=0.0d0 - bx=0.0d0;by=0.0d0;bz=0.0d0 - shetfx=0.0d0;shetfy=0.0d0;shetfz=0.0d0 - - gdfab=0.0d0 - - do i=ishiftca+1,ilastca - bx(i-ishiftca)=c(1,i) - by(i-ishiftca)=c(2,i) - bz(i-ishiftca)=c(3,i) - enddo - -c do i=1,ilastca-ishiftca -c read(99,*) bx(i),by(i),bz(i) -c enddo -c close(99) - - dca=0.25d0**2 - dshe=0.3d0**2 - ULHB=5.0D0 - ULDHB=5.0D0 - ULNEX=COS(60.0D0/180.0D0*PAI) - - DLHB=1.0D0 - DLDHB=1.0D0 - - DNEX=0.3D0**2 - - C00=COS((1.0D0+10.0D0/180.0D0)*PAI) - S00=SIN((1.0D0+10.0D0/180.0D0)*PAI) - - W_BETA=0.5D0 - DP45=W_BETA - DM45=W_BETA - -C END OF INITIALIZATION - - nca=ilastca-ishiftca - - call angvectors(nca) - call sheetforce(nca,wshet) - -c end of sheet energy and force - - do j=1,nca - shetfx(j)=shetfx(j)*beta_inc - shetfy(j)=shetfy(j)*beta_inc - shetfz(j)=shetfz(j)*beta_inc -c write(*,*)'SHETF:',shetfx(j),shetfy(j),shetfz(j) - enddo - - vbeta=vbeta*beta_inc - enebet=vbeta - edfabeta=enebet - - do j=1,nca - gdfab(1,j+ishiftca)=gdfab(1,j+ishiftca)-shetfx(j) - gdfab(2,j+ishiftca)=gdfab(2,j+ishiftca)-shetfy(j) - gdfab(3,j+ishiftca)=gdfab(3,j+ishiftca)-shetfz(j) - enddo - -#ifdef DEBUG1 - do j=1,nca - write(*,'(5x,i5,10x,3f10.5)') j,bx(j),by(j),bz(j) - enddo - - - gdfab=0 - dinc=0.001 - do j=1,nca - cth_orig(j)=cth(j) - sth_orig(j)=sth(j) - enddo - - do j=1,nca - - bx(j)=bx(j)+dinc - call angvectors(nca) - bx(j)=bx(j)-2*dinc - call angvectors(nca) - atxnum(j)=0.5*(cth(j)-cth_orig(j))/dinc - astxnum(j)=0.5*(sth(j)-sth_orig(j))/dinc - if (j.gt.1) then - atmxnum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc - astmxnum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc - endif - if (j.gt.2) then - atmmxnum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc - astmmxnum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc - endif - if (j.gt.3) then - atm3xnum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc - astm3xnum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc - endif - bx(j)=bx(j)+dinc - by(j)=by(j)+dinc - call angvectors(nca) - by(j)=by(j)-2*dinc - call angvectors(nca) - by(j)=by(j)+dinc - atynum(j)=0.5*(cth(j)-cth_orig(j))/dinc - astynum(j)=0.5*(sth(j)-sth_orig(j))/dinc - if (j.gt.1) then - atmynum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc - astmynum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc - endif - if (j.gt.2) then - atmmynum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc - astmmynum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc - endif - if (j.gt.3) then - atm3ynum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc - astm3ynum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc - endif - - bz(j)=bz(j)+dinc - call angvectors(nca) - bz(j)=bz(j)-2*dinc - call angvectors(nca) - bz(j)=bz(j)+dinc - - atznum(j)=0.5*(cth(j)-cth_orig(j))/dinc - astznum(j)=0.5*(sth(j)-sth_orig(j))/dinc - if (j.gt.1) then - atmznum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc - astmznum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc - endif - if (j.gt.2) then - atmmznum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc - astmmznum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc - endif - if (j.gt.3) then - atm3znum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc - astm3znum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc - endif - - enddo - - do i=1,nca - write (*,'(2i5,a2,6f10.5)') - & i,1,"x",atxnum(i),atx(i),atxnum(i)/atx(i), - & astxnum(i),astx(i),astxnum(i)/astx(i), - & i,1,"y",atynum(i),aty(i),atynum(i)/aty(i), - & astynum(i),asty(i),astynum(i)/asty(i), - & i,1,"z",atznum(i),atz(i),atznum(i)/atz(i), - & astznum(i),astz(i),astznum(i)/astz(i), - & i,2,"x",atmxnum(i),atmx(i),atmxnum(i)/atmx(i), - & astmxnum(i),astmx(i),astmxnum(i)/astmx(i), - & i,2,"y",atmynum(i),atmy(i),atmynum(i)/atmy(i), - & astmynum(i),astmy(i),astmynum(i)/astmy(i), - & i,2,"z",atmznum(i),atmz(i),atmznum(i)/atmz(i), - & astmznum(i),astmz(i),astmznum(i)/astmz(i), - & i,3,"x",atmmxnum(i),atmmx(i),atmmxnum(i)/atmmx(i), - & astmmxnum(i),astmmx(i),astmmxnum(i)/astmmx(i), - & i,3,"y",atmmynum(i),atmmy(i),atmmynum(i)/atmmy(i), - & astmmynum(i),astmmy(i),astmmynum(i)/astmmy(i), - & i,3,"z",atmmznum(i),atmmz(i),atmmznum(i)/atmmz(i), - & astmmznum(i),astmmz(i),astmmznum(i)/astmmz(i), - & i,4,"x",atm3xnum(i),atm3x(i),atm3xnum(i)/atm3x(i), - & astm3xnum(i),astm3x(i),astm3xnum(i)/astm3x(i), - & i,4,"y",atm3ynum(i),atm3y(i),atm3ynum(i)/atm3y(i), - & astm3ynum(i),astm3y(i),astm3ynum(i)/astm3y(i), - & i,4,"z",atm3znum(i),atm3z(i),atm3znum(i)/atm3z(i), - & astm3znum(i),astm3z(i),astm3znum(i)/astm3z(i), - & i,0," ",cth_orig(i),sth_orig(i) - enddo - - - gdfab=0 - dinc=0.001 - - do j=1,nca - - bx(j)=bx(j)+dinc - call angvectors(nca) - call sheetforce(nca,wshet) - vbeta1=vbeta*beta_inc - bx(j)=bx(j)-2*dinc - call angvectors(nca) - call sheetforce(nca,wshet) - vbeta2=vbeta*beta_inc - gdfab(1,j)=(vbeta2-vbeta1)/dinc/2 - bx(j)=bx(j)+dinc - - by(j)=by(j)+dinc - call angvectors(nca) - call sheetforce(nca,wshet) - vbeta1=vbeta*beta_inc - by(j)=by(j)-2*dinc - call angvectors(nca) - call sheetforce(nca,wshet) - vbeta2=vbeta*beta_inc - gdfab(2,j)=(vbeta2-vbeta1)/dinc/2 - by(j)=by(j)+dinc - - bz(j)=bz(j)+dinc - call angvectors(nca) - call sheetforce(nca,wshet) - vbeta1=vbeta*beta_inc - bz(j)=bz(j)-2*dinc - call angvectors(nca) - call sheetforce(nca,wshet) - vbeta2=vbeta*beta_inc - gdfab(3,j)=(vbeta2-vbeta1)/dinc/2 - bz(j)=bz(j)+dinc - - - enddo - - - call angvectors(nca) - call sheetforce(nca,wshet) - do j=1,nca - shetfx(j)=shetfx(j)*beta_inc - shetfy(j)=shetfy(j)*beta_inc - shetfz(j)=shetfz(j)*beta_inc - enddo - - - write(*,*) 'xyz analytical and numerical gradient' - do j=1,nca - write(*,'(5x,i5,10x,6f10.5)') j,-shetfx(j),-shetfy(j),-shetfz(j) - & ,(-gdfab(i,j),i=1,3) - enddo - - do j=1,nca - write(*,'(5x,i5,10x,3f10.2)') j,shetfx(j)/gdfab(1,j), - & shetfy(j)/gdfab(2,j), - & shetfz(j)/gdfab(3,j) - enddo - - stop -#endif - - return - end -C------------------------------------------------------------------------------- - subroutine angvectors(nca) -c implicit real*4(a-h,o-z) - implicit none - integer nca - integer maxca - parameter(maxca=800) - real*8 pai,zero - parameter(PAI=3.14159265358979323846D0,zero=0.0d0) - - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 apx(maxca),apy(maxca),apz(maxca) - real*8 apmx(maxca),apmy(maxca),apmz(maxca) - real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) - real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) - real*8 atx(maxca),aty(maxca),atz(maxca) - real*8 atmx(maxca),atmy(maxca),atmz(maxca) - real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) - real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - real*8 sth(maxca) - real*8 cph(maxca),cth(maxca) - real*8 ulcos(maxca) - real*8 p,c - integer i, ip, ipp, ip3, j - real*8 rx(maxca, maxca), ry(maxca, maxca), rz(maxca, maxca) - real*8 rix, riy, riz, ripx, ripy, ripz, rippx, rippy, rippz - real*8 gix, giy, giz, gipx, gipy, gipz, gippx, gippy, gippz - real*8 cix, ciy, ciz, cipx, cipy, cipz - real*8 gpcrp_x, gpcrp_y, gpcrp_z, d_gpcrp, gpcrp__g - real*8 d10, d11, d12, d13, d20, d21, d22, d23, d24 - real*8 d30, d31, d32, d33, d34, d35, d40, d41, d42, d43 - real*8 d_gcr, d_gcr3, d_gmcrim,d_gmcrim3,dgmmcrimm,d_gmmcrimm3 - real*8 dg, dg3, dg30, dgm, dgm3, dgmm, dgmm3, dgp, dri - real*8 dri3, drim, drim3, drimm, drip, dripp, g3gmm, g3rim - real*8 g3x, g3y, g3z, d_gmmcrimm, g3rim_,gcr__gm - real*8 gcr_x,gcr_y,gcr_z,ggm,ggp,gmcrim__gmm - real*8 gmcrim_x,gmcrim_y,gmcrim_z,gmmcrimm__gmmm - real*8 gmmcrimm_x,gmmcrimm_y,gmmcrimm_z,gmmgm,gmmr - real*8 gmmx,gmmy,gmmz,gmrp,gmx,gmy,gmz,gpx,gpy,gpz - real*8 grpp,gx,gy,gz - real*8 rim3x,rim3y,rim3z,rimmx,rimmy,rimmz,rimx,rimy,rimz - real*8 sd10,sd11,sd20,sd21,sd22,sd30,sd31,sd32,sd40,sd41 - integer inb,nmax,iselect - - common /sheca/ bx,by,bz - common /difvec/ rx, ry, rz - common /ulang/ ulcos - common /phys1/ inb,nmax,iselect - common /phys4/ p,c - common /kyori2/ dis - common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, - & apmmz,apm3x,apm3y,apm3z - common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, - & atmmz,atm3x,atm3y,atm3z - common /coscos/ cph,cth - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - & astmmz,astm3x,astm3y,astm3z - common /sinsin/ sth -C------------------------------------------------------------------------------- -c write(*,*) 'inside angvectors' -C initialize - p=0.1d0 - c=1.0d0 - inb=nca - cph=zero; cth=zero; sth=zero - apx=zero;apy=zero;apz=zero;apmx=zero;apmy=zero;apmz=zero - apmmx=zero;apmmy=zero;apmmz=zero;apm3x=zero;apm3y=zero;apm3z=zero - atx=zero;aty=zero;atz=zero;atmx=zero;atmy=zero;atmz=zero - atmmx=zero;atmmy=zero;atmmz=zero;atm3x=zero;atm3y=zero;atm3z=zero - astx=zero;asty=zero;astz=zero;astmx=zero;astmy=zero;astmz=zero - astmmx=zero;astmmy=zero;astmmz=zero;astm3x=zero;astm3y=zero - astm3z=zero -C end of initialize -C r[x,y,z] calc and distance calculation - rx=zero;ry=zero;rz=zero - - do i=1,inb - do j=1,inb - rx(i,j)=bx(j)-bx(i) - ry(i,j)=by(j)-by(i) - rz(i,j)=bz(j)-bz(i) - dis(i,j)=sqrt(rx(i,j)**2+ry(i,j)**2+rz(i,j)**2) -c write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) -c write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) -c write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) -c write(*,*) 'dis(i,j):',i,j,dis(i,j) - enddo - enddo -c end of r[x,y,z] calc -C cos calc - do i=1,inb-2 - ip=i+1 - ipp=i+2 - - if(dis(i,ip).ge.1.0e-8.and.dis(ip,ipp).ge.1.0e-8) then - ulcos(i)=rx(i,ip)*rx(ip,ipp)+ry(i,ip)*ry(ip,ipp) - $ +rz(i,ip)*rz(ip,ipp) - ulcos(i)=ulcos(i)/(dis(i,ip)*dis(ip,ipp)) - endif - enddo -c end of virtual bond angle -c write(*,*) 'inside angvectors1' -crc do i=1,inb-3 - do i=1,inb - ip=i+1 - ipp=i+2 - ip3=i+3 - rix=bx(ip)-bx(i) - riy=by(ip)-by(i) - riz=bz(ip)-bz(i) - ripx=bx(ipp)-bx(ip) - ripy=by(ipp)-by(ip) - ripz=bz(ipp)-bz(ip) - rippx=bx(ip3)-bx(ipp) - rippy=by(ip3)-by(ipp) - rippz=bz(ip3)-bz(ipp) - - gx=riy*ripz-riz*ripy - gy=riz*ripx-rix*ripz - gz=rix*ripy-riy*ripx - gpx=ripy*rippz-ripz*rippy - gpy=ripz*rippx-ripx*rippz - gpz=ripx*rippy-ripy*rippx - gpcrp_x=gpy*ripz-gpz*ripy - gpcrp_y=gpz*ripx-gpx*ripz - gpcrp_z=gpx*ripy-gpy*ripx - d_gpcrp=sqrt(gpcrp_x**2+gpcrp_y**2+gpcrp_z**2) - gpcrp__g=gx*gpy*ripz+gpx*ripy*gz+ripx*gpz*gy - & -gz*gpy*ripx-gpz*ripy*gx-ripz*gpx*gy - - if(i.ge.2) then - rimx=bx(i)-bx(i-1) - rimy=by(i)-by(i-1) - rimz=bz(i)-bz(i-1) - gmx=rimy*riz-rimz*riy - gmy=rimz*rix-rimx*riz - gmz=rimx*riy-rimy*rix - dgm=sqrt(gmx**2+gmy**2+gmz**2) - dgm3=dgm**3 - ggm=gmx*gx+gmy*gy+gmz*gz - gmrp=gmx*ripx+gmy*ripy+gmz*ripz - drim=dis(i-1,i) - drim3=drim**3 - gcr_x=gy*riz-gz*riy - gcr_y=gz*rix-gx*riz - gcr_z=gx*riy-gy*rix - d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) - d_gcr3=d_gcr**3 - gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy - & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy - endif -c write(*,*) 'inside angvectors2' - if(i.ge.3) then - rimmx=bx(i-1)-bx(i-2) - rimmy=by(i-1)-by(i-2) - rimmz=bz(i-1)-bz(i-2) - drimm=dis(i-2,i-1) - gmmx=rimmy*rimz-rimmz*rimy - gmmy=rimmz*rimx-rimmx*rimz - gmmz=rimmx*rimy-rimmy*rimx - dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) - dgmm3=dgmm**3 - gmmgm=gmmx*gmx+gmmy*gmy+gmmz*gmz - gmmr=gmmx*rix+gmmy*riy+gmmz*riz - gmcrim_x=gmy*rimz-gmz*rimy - gmcrim_y=gmz*rimx-gmx*rimz - gmcrim_z=gmx*rimy-gmy*rimx - d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) - d_gmcrim3=d_gmcrim**3 - gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy - & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy - endif - - if(i.ge.4) then - rim3x=bx(i-2)-bx(i-3) - rim3y=by(i-2)-by(i-3) - rim3z=bz(i-2)-bz(i-3) - g3x=rim3y*rimmz-rim3z*rimmy - g3y=rim3z*rimmx-rim3x*rimmz - g3z=rim3x*rimmy-rim3y*rimmx - dg30=sqrt(g3x**2+g3y**2+g3z**2) - g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz - g3rim_=g3x*rimx+g3y*rimy+g3z*rimz -cc********************************************************************** - gmmcrimm_x=gmmy*rimmz-gmmz*rimmy - gmmcrimm_y=gmmz*rimmx-gmmx*rimmz - gmmcrimm_z=gmmx*rimmy-gmmy*rimmx - d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) - d_gmmcrimm3=d_gmmcrimm**3 - gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y - & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y - endif - - dri=dis(i,i+1) - drip=dis(i+1,i+2) - dripp=dis(i+2,i+3) - dri3=dri**3 - dg=sqrt(gx**2+gy**2+gz**2) - dgp=sqrt(gpx**2+gpy**2+gpz**2) - dg3=dg**3 - - ggp=gx*gpx+gy*gpy+gz*gpz - grpp=gx*rippx+gy*rippy+gz*rippz - - if(dg.gt.0.0D0.and.dripp.gt.0.0D0.and.dgp.gt.0.0D0 - & .and.d_gpcrp.gt.0.0D0) then - cph(i)=grpp/dg/dripp - cth(i)=ggp/dg/dgp - sth(i)=gpcrp__g/d_gpcrp/dg - else -c - cph(i)=1.0D0 - cth(i)=1.0D0 - sth(i)=0.0D0 - endif - -c write(*,*) 'inside angvectors3' - - if(dgp.gt.0.0D0.and.dg3.gt.0.0D0 - & .and.dripp.gt.0.0D0.and.d_gpcrp.gt.0.0D0) then - d10=1.0D0/(dg*dgp) - d11=ggp/(dg3*dgp) - d12=1.0D0/(dg*dripp) - d13=grpp/(dg3*dripp) - sd10=1.0D0/(d_gpcrp*dg) - sd11=gpcrp__g/(d_gpcrp*dg3) - else - d10=0.0D0 - d11=0.0D0 - d12=0.0D0 - d13=0.0D0 - sd10=0.0D0 - sd11=0.0D0 - endif - - atx(i)=(ripz*gpy-ripy*gpz)*d10 - & -(gy*ripz-gz*ripy)*d11 - aty(i)=(ripx*gpz-ripz*gpx)*d10 - & -(gz*ripx-gx*ripz)*d11 - atz(i)=(ripy*gpx-ripx*gpy)*d10 - & -(gx*ripy-gy*ripx)*d11 - astx(i)=sd10*(-gpx*ripy**2+ripx*gpz*ripz - & +ripy*gpy*ripx-gpx*ripz**2) - & -sd11*(gy*ripz-gz*ripy) - asty(i)=sd10*(-gpy*ripz**2+gpx*ripy*ripx - & -gpy*ripx**2+gpz*ripy*ripz) - & -sd11*(-gx*ripz+gz*ripx) - astz(i)=sd10*(ripy*gpy*ripz-gpz*ripx**2 - & -gpz*ripy**2+ripz*gpx*ripx) - & -sd11*(gx*ripy-gy*ripx) - apx(i)=(ripz*rippy-ripy*rippz)*d12 - & -(gy*ripz-gz*ripy)*d13 - apy(i)=(ripx*rippz-ripz*rippx)*d12 - & -(gz*ripx-gx*ripz)*d13 - apz(i)=(ripy*rippx-ripx*rippy)*d12 - & -(gx*ripy-gy*ripx)*d13 - - if(i.ge.2) then - cix=bx(ip)-bx(i-1) - ciy=by(ip)-by(i-1) - ciz=bz(ip)-bz(i-1) - cipx=bx(ipp)-bx(i) - cipy=by(ipp)-by(i) - cipz=bz(ipp)-bz(i) - ripx=bx(ipp)-bx(ip) - ripy=by(ipp)-by(ip) - ripz=bz(ipp)-bz(ip) - if(dgm3.gt.0.0D0.and.dg3.gt.0.0D0.and.drip.gt.0.0D0 - & .and.d_gcr3.gt.0.0D0) then - d20=1.0D0/(dg*dgm) - d21=ggm/(dgm3*dg) - d22=ggm/(dgm*dg3) - d23=1.0D0/(dgm*drip) - d24=gmrp/(dgm3*drip) - sd20=1.0D0/(d_gcr*dgm) - sd21=gcr__gm/(d_gcr3*dgm) - sd22=gcr__gm/(d_gcr*dgm3) - else - d20=0.0D0 - d21=0.0D0 - d22=0.0D0 - d23=0.0D0 - d24=0.0D0 - sd20=0.0D0 - sd21=0.0D0 - sd22=0.0D0 - endif - atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 - & -(ciy*gmz-ciz*gmy)*d21 - & +(ripy*gz-ripz*gy)*d22 - atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 - & -(ciz*gmx-cix*gmz)*d21 - & +(ripz*gx-ripx*gz)*d22 - atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 - & -(cix*gmy-ciy*gmx)*d21 - & +(ripx*gy-ripy*gx)*d22 -cc********************************************************************** - astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy - & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix - & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) - & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) - & +gcr_z*(-ripz*rix+gy)) - & -sd22*(-gmy*ciz+gmz*ciy) - - astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix - & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz - & +riz*ripz*gmy) - & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) - & -gcr_z*(ripz*riy+gx)) - & -sd22*(gmx*ciz-gmz*cix) - - astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz - & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy - & -riz*gx*cix) - & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) - & +gcr_z*(ripy*riy+ripx*rix)) - & -sd22*(-gmx*ciy+gmy*cix) -cc********************************************************************** - apmx(i)=(ciy*ripz-ripy*ciz)*d23 - & -(ciy*gmz-ciz*gmy)*d24 - apmy(i)=(ciz*ripx-ripz*cix)*d23 - & -(ciz*gmx-cix*gmz)*d24 - apmz(i)=(cix*ripy-ripx*ciy)*d23 - & -(cix*gmy-ciy*gmx)*d24 - endif - - if(i.ge.3) then - if(dgm3.gt.0.0D0.and.dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 - & .and.d_gmcrim3.gt.0.0D0) then - d30=1.0D0/(dgm*dgmm) - d31=gmmgm/(dgm3*dgmm) - d32=gmmgm/(dgm*dgmm3) - d33=1.0D0/(dgmm*dri) - d34=gmmr/(dgmm3*dri) - d35=gmmr/(dgmm*dri3) - sd30=1.0D0/(d_gmcrim*dgmm) - sd31=gmcrim__gmm/(d_gmcrim3*dgmm) - sd32=gmcrim__gmm/(d_gmcrim*dgmm3) - else - d30=0.0D0 - d31=0.0D0 - d32=0.0D0 - d33=0.0D0 - d34=0.0D0 - d35=0.0D0 - sd30=0.0D0 - sd31=0.0D0 - sd32=0.0D0 - endif - -c write(*,*) 'inside angvectors4' - -cc********************************************************************** - atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 - & -(ciy*gmz-ciz*gmy)*d31 - & -(gmmy*rimmz-gmmz*rimmy)*d32 - atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 - & -(ciz*gmx-cix*gmz)*d31 - & -(gmmz*rimmx-gmmx*rimmz)*d32 - atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 - & -(cix*gmy-ciy*gmx)*d31 - & -(gmmx*rimmy-gmmy*rimmx)*d32 -cc********************************************************************** - astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy - & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz - & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy - & -ciy*rimy*gmmx-rimz*gmx*rimmz) - & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) - & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) - & -sd32*(gmmy*rimmz-rimmy*gmmz) - - astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz - & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy - & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx - & +gmz*rimy*rimmz-rimz*ciz*gmmy) - & -sd31*(gmcrim_x*(cix*rimy-gmz) - & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) - & -sd32*(-gmmx*rimmz+rimmx*gmmz) - - astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz - & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx - & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy - & +rimz*ciy*gmmy+rimz*gmx*rimmx) - & -sd31*(gmcrim_x*(cix*rimz+gmy) - & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) - & -sd32*(gmmx*rimmy-rimmx*gmmy) -c********************************************************************** - apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 - & -(gmmy*rimmz-gmmz*rimmy)*d34 - & +rix*d35 - apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 - & -(gmmz*rimmx-gmmx*rimmz)*d34 - & +riy*d35 - apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 - & -(gmmx*rimmy-gmmy*rimmx)*d34 - & +riz*d35 - endif - - if(i.ge.4) then - if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 - & .and.drim3.gt.0.0D0 - & .and.d_gmmcrimm3.gt.0.0D0) then - d40=1.0D0/(dg30*dgmm) - d41=g3gmm/(dg30*dgmm3) - d42=1.0D0/(dg30*drim) - d43=g3rim_/(dg30*drim3) - sd40=1.0D0/(dg30*d_gmmcrimm) - sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) - else - d40=0.0D0 - d41=0.0D0 - d42=0.0D0 - d43=0.0D0 - sd40=0.0D0 - sd41=0.0D0 - endif - atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 - & -(gmmy*rimmz-gmmz*rimmy)*d41 - atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 - & -(gmmz*rimmx-gmmx*rimmz)*d41 - atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 - & -(gmmx*rimmy-gmmy*rimmx)*d41 -cc********************************************************************** - astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y - & -g3z*rimmz*rimmx+rimmy**2*g3x) - & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) - & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) - - astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y - & -rimmx*rimmy*g3x+rimmz**2*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmy - & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmy) - -c & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) - - astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z - & +g3z*rimmx**2-rimmz*rimmy*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz - & +gmmcrimm_z*(rimmy**2+rimmx**2)) -c********************************************************************** - apm3x(i)=g3x*d42-rimx*d43 - apm3y(i)=g3y*d42-rimy*d43 - apm3z(i)=g3z*d42-rimz*d43 - endif - enddo -c******************************************************************************* - -c write(*,*) 'inside angvectors5' - -c do i=inb-2,inb - do i=1,0 - rimx=bx(i)-bx(i-1) - rimy=by(i)-by(i-1) - rimz=bz(i)-bz(i-1) - rimmx=bx(i-1)-bx(i-2) - rimmy=by(i-1)-by(i-2) - rimmz=bz(i-1)-bz(i-2) - rim3x=bx(i-2)-bx(i-3) - rim3y=by(i-2)-by(i-3) - rim3z=bz(i-2)-bz(i-3) - gmmx=rimmy*rimz-rimmz*rimy - gmmy=rimmz*rimx-rimmx*rimz - gmmz=rimmx*rimy-rimmy*rimx - g3x=rim3y*rimmz-rim3z*rimmy - g3y=rim3z*rimmx-rim3x*rimmz - g3z=rim3x*rimmy-rim3y*rimmx - - dg30=sqrt(g3x**2+g3y**2+g3z**2) - g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz - dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) - dgmm3=dgmm**3 - drim=dis(i-1,i) - drimm=dis(i-2,i-1) - drim3=drim**3 - g3rim_=g3x*rimx+g3y*rimy+g3z*rimz -cc********************************************************************** - gmmcrimm_x=gmmy*rimmz-gmmz*rimmy - gmmcrimm_y=gmmz*rimmx-gmmx*rimmz - gmmcrimm_z=gmmx*rimmy-gmmy*rimmx - d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) - d_gmmcrimm3=d_gmmcrimm**3 - gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y - & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y - - if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 - & .and.drim3.gt.0.0D0 - & .and.d_gmmcrimm3.gt.0.0D0) then - d40=1.0D0/(dg30*dgmm) - d41=g3gmm/(dg30*dgmm3) - d42=1.0D0/(dg30*drim) - d43=g3rim_/(dg30*drim3) - sd40=1.0D0/(dg30*d_gmmcrimm) - sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) - else - d40=0.0D0 - d41=0.0D0 - d42=0.0D0 - d43=0.0D0 - sd40=0.0D0 - sd41=0.0D0 - endif - atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 - & -(gmmy*rimmz-gmmz*rimmy)*d41 - atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 - & -(gmmz*rimmx-gmmx*rimmz)*d41 - atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 - & -(gmmx*rimmy-gmmy*rimmx)*d41 -cc********************************************************************** - astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y - & -g3z*rimmz*rimmx+rimmy**2*g3x) - & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) - & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) - - astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y - & -rimmx*rimmy*g3x+rimmz**2*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmy - & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) - - astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z - & +g3z*rimmx**2-rimmz*rimmy*g3y) - & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz - & +gmmcrimm_z*(rimmy**2+rimmx**2)) -cc********************************************************************** - apm3x(i)=g3x*d42-rimx*d43 - apm3y(i)=g3y*d42-rimy*d43 - apm3z(i)=g3z*d42-rimz*d43 - - if(i.le.inb-1) then - ip=i+1 - rix=bx(ip)-bx(i) - riy=by(ip)-by(i) - riz=bz(ip)-bz(i) - cix=bx(ip)-bx(i-1) - ciy=by(ip)-by(i-1) - ciz=bz(ip)-bz(i-1) - gmx=rimy*riz-rimz*riy - gmy=rimz*rix-rimx*riz - gmz=rimx*riy-rimy*rix - dgm=sqrt(gmx**2+gmy**2+gmz**2) - dgm3=dgm**3 - dri=dis(i,i+1) - dri3=dri**3 - gmmgm=gmmx*gmx+gmmy*gmy+gmmz+gmz - gmmr=gmmx*rix+gmmy*riy+gmmz*riz - gmcrim_x=gmy*rimz-gmz*rimy - gmcrim_y=gmz*rimx-gmx*rimz - gmcrim_z=gmx*rimy-gmy*rimx - d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) - d_gmcrim3=d_gmcrim**3 - gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy - & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy - - if(dgm3.gt.0.0D0.and. - & dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 - & .and.d_gmcrim3.gt.0.0D0) then - d30=1.0D0/(dgm*dgmm) - d31=gmmgm/(dgm3*dgmm) - d32=gmmgm/(dgm*dgmm3) - d33=1.0D0/(dgmm*dri) - d34=gmmr/(dgmm3*dri) - d35=gmmr/(dgmm*dri3) - sd30=1.0D0/(d_gmcrim*dgmm) - sd31=gmcrim__gmm/(d_gmcrim3*dgmm) - sd32=gmcrim__gmm/(d_gmcrim*dgmm3) - - else - d30=0.0D0 - d31=0.0D0 - d32=0.0D0 - d33=0.0D0 - d34=0.0D0 - d35=0.0D0 - sd30=0.0D0 - sd31=0.0D0 - sd32=0.0D0 - endif -cc********************************************************************** - atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 - & -(ciy*gmz-ciz*gmy)*d31 - & -(gmmy*rimmz-gmmz*rimmy)*d32 - atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 - & -(ciz*gmx-cix*gmz)*d31 - & -(gmmz*rimmx-gmmx*rimmz)*d32 - atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 - & -(cix*gmy-ciy*gmx)*d31 - & -(gmmx*rimmy-gmmy*rimmx)*d32 -cc********************************************************************** - astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy - & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz - & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy - & -ciy*rimy*gmmx-rimz*gmx*rimmz) - & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) - & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) - & -sd32*(gmmy*rimmz-rimmy*gmmz) - - astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz - & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy - & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx - & +gmz*rimy*rimmz-rimz*ciz*gmmy) - & -sd31*(gmcrim_x*(cix*rimy-gmz) - & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) - & -sd32*(-gmmx*rimmz+rimmx*gmmz) - - astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz - & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx - & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy - & +rimz*ciy*gmmy+rimz*gmx*rimmx) - & -sd31*(gmcrim_x*(cix*rimz+gmy) - & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) - & -sd32*(gmmx*rimmy-rimmx*gmmy) -cc********************************************************************** - apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 - & -(gmmy*rimmz-gmmz*rimmy)*d34 - & +rix*d35 - apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 - & -(gmmz*rimmx-gmmx*rimmz)*d34 - & +riy*d35 - apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 - & -(gmmx*rimmy-gmmy*rimmx)*d34 - & +riz*d35 - endif - -c write(*,*) 'inside angvectors6' - - if(i.eq.inb-2) then - ipp=i+2 - ripx=bx(ipp)-bx(ip) - ripy=by(ipp)-by(ip) - ripz=bz(ipp)-bz(ip) - cipx=bx(ipp)-bx(i) - cipy=by(ipp)-by(i) - cipz=bz(ipp)-bz(i) - gx=riy*ripz-riz*ripy - gy=riz*ripx-rix*ripz - gz=rix*ripy-riy*ripx - ggm=gmx*gx+gmy*gy+gmz*gz - gmrp=gmx*ripx+gmy*ripy+gmz*ripz - dg=sqrt(gx**2+gy**2+gz**2) - dg3=dg**3 - drip=dis(i+1,i+2) - gcr_x=gy*riz-gz*riy - gcr_y=gz*rix-gx*riz - gcr_z=gx*riy-gy*rix - d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) - d_gcr3=d_gcr**3 - gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy - & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy - if(dgm3.gt.0.0D0.and. - & dg3.gt.0.0D0.and.drip.gt.0.0D0.and.d_gcr3.gt.0.0D0 - & ) then - d20=1.0D0/(dg*dgm) - d21=ggm/(dgm3*dg) - d22=ggm/(dgm*dg3) - d23=1.0D0/(dgm*drip) - d24=gmrp/(dgm3*drip) - sd20=1.0D0/(d_gcr*dgm) - sd21=gcr__gm/(d_gcr3*dgm) - sd22=gcr__gm/(d_gcr*dgm3) - else - d20=0.0D0 - d21=0.0D0 - d22=0.0D0 - d23=0.0D0 - d24=0.0D0 - sd20=0.0D0 - sd21=0.0D0 - sd22=0.0D0 - endif - atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 - & -(ciy*gmz-ciz*gmy)*d21 - & +(ripy*gz-ripz*gy)*d22 - atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 - & -(ciz*gmx-cix*gmz)*d21 - & +(ripz*gx-ripx*gz)*d22 - atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 - & -(cix*gmy-ciy*gmx)*d21 - & +(ripx*gy-ripy*gx)*d22 -cc********************************************************************** - astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy - & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix - & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) - & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) - & +gcr_z*(-ripz*rix+gy)) - & -sd22*(-gmy*ciz+gmz*ciy) - - astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix - & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz - & +riz*ripz*gmy) - & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) - & -gcr_z*(ripz*riy+gx)) - & -sd22*(gmx*ciz-gmz*cix) - - astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz - & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy - & -riz*gx*cix) - & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) - & +gcr_z*(ripy*riy+ripx*rix)) - & -sd22*(-gmx*ciy+gmy*cix) -cc********************************************************************** -c - apmx(i)=(ciy*ripz-ripy*ciz)*d23 - & -(ciy*gmz-ciz*gmy)*d24 - apmy(i)=(ciz*ripx-ripz*cix)*d23 - & -(ciz*gmx-cix*gmz)*d24 - apmz(i)=(cix*ripy-ripx*ciy)*d23 - & -(cix*gmy-ciy*gmx)*d24 - - endif - enddo - - return - end -c END of angvectors -c------------------------------------------------------------------------------- -C--------------------------------------------------------------------------------- - subroutine sheetforce(nca,wshet) - implicit none -C JYLEE -c this should be matched with dfa.fcm - integer maxca - parameter(maxca=800) -cc********************************************************************** - integer nca - integer i,k - integer inb,nmax,iselect - -c real*8 dfaexp(15001) - - real*8 vbeta,vbetp,vbetm - real*8 shefx(maxca,12) - real*8 shefy(maxca,12),shefz(maxca,12) - real*8 shetfx(maxca),shetfy(maxca),shetfz(maxca) - real*8 vbet(maxca,maxca) - real*8 wshet(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - - common /sheca/ bx,by,bz - common /phys1/ inb,nmax,iselect - common /shef/ shefx,shefy,shefz - common /shee/ vbeta,vbet,vbetp,vbetm - common /shetf/ shetfx,shetfy,shetfz - - inb=nca - do i=1,inb - shetfx(i)=0.0D0 - shetfy(i)=0.0D0 - shetfz(i)=0.0D0 - enddo - - do k=1,12 - do i=1,inb - shefx(i,k)=0.0D0 - shefy(i,k)=0.0D0 - shefz(i,k)=0.0D0 - enddo - enddo - - call sheetene(nca,wshet) - call sheetforce1 - - 887 format(a,1x,i6,3x,f12.8) - 888 format(a,1x,i4,1x,i4,3x,f12.8) - 889 format(a,1x,i4,3x,f12.8) - !write(2,*) 'coord : ' - do i=1,inb - !write(2,887) 'bx:',i,bx(i) - !write(2,887) 'by:',i,by(i) - !write(2,887) 'bz:',i,bz(i) - enddo - !write(2,*) 'After sheetforce1' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce5 - - !write(2,*) 'After sheetforce5' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce6 - - !write(2,*) 'After sheetforce6' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce11 - - !write(2,*) 'After sheetforce11' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - call sheetforce12 - - !write(2,*) 'After sheetforce12' - do i=1,inb - do k=1,12 - !write(2,888) 'shefx :',i,k,shefx(i,k) - !write(2,888) 'shefy :',i,k,shefy(i,k) - !write(2,888) 'shefz :',i,k,shefz(i,k) - enddo - enddo - - do i=1,inb - do k=1,12 - shetfx(i)=shetfx(i)+shefx(i,k) - shetfy(i)=shetfy(i)+shefy(i,k) - shetfz(i)=shetfz(i)+shefz(i,k) - enddo - enddo - !write(2,*) 'Beta Finished' - do i=1,inb - !write(2,889) 'shetfx : ',i,shetfx(i) - !write(2,889) 'shetfy : ',i,shetfy(i) - !write(2,889) 'shetfz : ',i,shetfz(i) - enddo - - return - end -C end sheetforce -c------------------------------------------------------------------------------- - subroutine sheetene(nca,wshet) - implicit none - integer maxca - parameter(maxca=800) -cc****************************************************************************** - -c real*8 dfaexp(15001) - real*8 dtmp1, dtmp2, dtmp3 - - real*8 vbet(maxca,maxca) - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 cph(maxca),cth(maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 ulcos(maxca) -cc********************************************************************** - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - real*8 sth(maxca) - real*8 wshet(maxca,maxca) - real*8 dp45, dm45, w_beta - real*8 c00, s00, ulnex, dnex, dca,dlhb,ulhb,dshe,dldhb,uldhb - integer nca - integer i,ip,ipp,j,jp,jpp,inb,nmax,iselect - real*8 uum, uup - real*8 vbeta,vbetp,vbetm,y,y1,y2,yshe1,yshe2,yy1,yy2 - - common /sheca/ bx,by,bz - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /coscos/ cph,cth - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - & c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shee/ vbeta,vbet,vbetp,vbetm - common /ulang/ ulcos -cc********************************************************************** - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - & astmmz,astm3x,astm3y,astm3z - common /sinsin/ sth - - real*8 r_pair_mat(maxca,maxca) -ci integer istrand(maxca,maxca) -ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) -ci common /shetest/ istrand,istrand_p,istrand_m - common /beta_p/ r_pair_mat -C------------------------------------------------------------------------------- - r_pair_mat = 0.0d0 - do i=1,inb - do j=1,inb - r_pair_mat(i,j)=wshet(i,j) -c write(*,*) 'r_pair_mat :',i,j,r_pair_mat(i,j) - enddo - enddo -c stop -c - vbeta=0.0D0 - vbetp=0.0D0 - vbetm=0.0D0 - - do i=1,inb-7 - do j=i+4,inb-3 - ip=i+1 - ipp=i+2 - jp=j+1 - jpp=j+2 -cc********************************************************************** - y1=(cth(i)*c00+sth(i)*s00-1.0D0)**2 - & +(cth(j)*c00+sth(j)*s00-1.0D0)**2 - y1=-0.5d0*y1/dca - y2=(ulcos(i)-ulnex)**2+(ulcos(ip)-ulnex)**2 - & +(ulcos(j)-ulnex)**2+(ulcos(jp)-ulnex)**2 - y2=-0.5d0*y2/dnex - -cdebug y2=0 - - y=y1+y2 - -ci if(y.ge.-4) then -ci istrand(i,j)=1 -ci else -ci istrand(i,j)=0 -ci endif - -ci if(istrand(i,j).eq.1) then - - yy1=-0.5d0*(dis(ip,jp)-ulhb)**2/dlhb - yy2=-0.5d0*(dis(ipp,jpp)-ulhb)**2/dlhb - - - pin1(i,j)=(rx(ip,jp)*rx(ip,ipp)+ry(ip,jp)*ry(ip,ipp) - $ +rz(ip,jp)*rz(ip,ipp))/(dis(ip,jp)*dis(ip,ipp)) - pin2(i,j)=(rx(ip,jp)*rx(jp,jpp)+ry(ip,jp)*ry(jp,jpp) - $ +rz(ip,jp)*rz(jp,jpp))/(dis(ip,jp)*dis(jp,jpp)) - pin3(i,j)=(rx(ipp,jpp)*rx(ip,ipp)+ry(ipp,jpp)*ry(ip,ipp) - $ +rz(ipp,jpp)*rz(ip,ipp))/(dis(ipp,jpp)*dis(ip,ipp)) - pin4(i,j)=(rx(ipp,jpp)*rx(jp,jpp)+ry(ipp,jpp)*ry(jp,jpp) - $ +rz(ipp,jpp)*rz(jp,jpp))/(dis(ipp,jpp)*dis(jp,jpp)) - - yshe1=pin1(i,j)**2+pin2(i,j)**2 - yshe1=-0.5d0*yshe1/dshe - yshe2=pin3(i,j)**2+pin4(i,j)**2 - yshe2=-0.5d0*yshe2/dshe - -ci if((yshe1+yshe2).ge.-4) then -ci istrand_p(i,j)=1 -ci else -ci istrand_p(i,j)=0 -ci endif - - -C write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) -C write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) -C write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) -C write(*,*) 'dis(i,j):',i,j,dis(i,j) -C write(*,*) 'rx(ip,jp):',ip,jp,bx(ip),bx(jp),rx(ip,jp) -C write(*,*) 'rx(ip,ipp):',ip,ipp,bx(ip),bx(ipp),rx(ip,ipp) -C write(*,*) 'pin1:',pin1(i,j) -C write(*,*) 'pin2:',pin2(i,j) -C write(*,*) 'pin3:',pin3(i,j) -C write(*,*) 'pin4:',pin4(i,j) - -C write(*,*) 'y:',y -C write(*,*) 'yy1:',yy1 -C write(*,*) 'yy2:',yy2 -C write(*,*) 'yshe1:',yshe1 -C write(*,*) 'yshe2:',yshe2 -c - -ci if (istrand_p(i,j).eq.1) then - -cd yy1=0 -cd yy2=0 -cd yshe1=0 -cd yshe2=0 - dtmp1 = y+yy1+yshe1 - dtmp2 = y+yy2+yshe2 - dtmp3 = y+yy1+yy2+yshe1+yshe2 - -C write(*,*)'1', i,j,dtmp1,dtmp2,dtmp3 -C write(*,*)'2', y,yy1,yy2 -C write(*,*)'3', yshe1,yshe2 - -cc if (dtmp3.le.-35.0d0) then -c vbetap(i,j)=-dp45*exp(dtmp3) -cc vbetap(i,j)=0.0d0 -cc else -c vbetap(i,j)=-dp45*dfaexp(idint(-dtmp3*1000)+1) - vbetap(i,j)=-dp45*exp(dtmp3) -cc end if - -cc if (dtmp1.le.-35.0d0) then -c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1) -cc vbetap1(i,j)=0.0d0 -cc else -c vbetap1(i,j)=-r_pair_mat(i+1,j+1) -c $ *dfaexp(idint(-dtmp1*1000)+1) - vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1) -cc end if - -cc if (dtmp2.le.-35.0d0) then -C vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2) -cc vbetap2(i,j)=0.0d0 -cc else -c vbetap2(i,j)=-r_pair_mat(i+2,j+2) -c $ *dfaexp(idint(-dtmp2*1000)+1) - vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2) -cc end if - -c vbetap(i,j)=-dp45*exp(y+yy1+yy2+yshe1+yshe2) -c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(y+yy1+yshe1) -c vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(y+yy2+yshe2) - -! write(*,*) 'r_pair_mat>',i+1,j+1,r_pair_mat(i+1,j+1) -! write(*,*) 'r_pair_mat>',i+2,j+2,r_pair_mat(i+2,j+2) - -ci elseif (istrand_p(i,j).eq.0)then -ci vbetap(i,j)=0 -ci vbetap1(i,j)=0 -ci vbetap2(i,j)=0 -ci endif - - yy1=-0.5d0*(dis(ip,jpp)-ulhb)**2/dlhb - yy2=-0.5d0*(dis(ipp,jp)-ulhb)**2/dlhb - - pina1(i,j)=(rx(ip,jpp)*rx(ip,ipp)+ry(ip,jpp)*ry(ip,ipp) - $ +rz(ip,jpp)*rz(ip,ipp))/(dis(ip,jpp)*dis(ip,ipp)) - pina2(i,j)=(rx(ip,jpp)*rx(jp,jpp)+ry(ip,jpp)*ry(jp,jpp) - $ +rz(ip,jpp)*rz(jp,jpp))/(dis(ip,jpp)*dis(jp,jpp)) - pina3(i,j)=(rx(jp,ipp)*rx(ip,ipp)+ry(jp,ipp)*ry(ip,ipp) - $ +rz(jp,ipp)*rz(ip,ipp))/(dis(jp,ipp)*dis(ip,ipp)) - pina4(i,j)=(rx(jp,ipp)*rx(jp,jpp)+ry(jp,ipp)*ry(jp,jpp) - $ +rz(jp,ipp)*rz(jp,jpp))/(dis(jp,ipp)*dis(jp,jpp)) - - yshe1=pina1(i,j)**2+pina2(i,j)**2 - yshe1=-0.5d0*yshe1/dshe - yshe2=pina3(i,j)**2+pina4(i,j)**2 - yshe2=-0.5d0*yshe2/dshe - -ci if((yshe1+yshe2).ge.-4) then -ci istrand_m(i,j)=1 -ci else -ci istrand_m(i,j)=0 -ci endif - - -C write(*,*) 'pina1:',pina1(i,j) -C write(*,*) 'pina2:',pina2(i,j) -C write(*,*) 'pina3:',pina3(i,j) -C write(*,*) 'pina4:',pina4(i,j) -C write(*,*) 'yshe1:',yshe1 -C write(*,*) 'yshe2:',yshe2 -C write(*,*) 'dshe:',dshe - -ci if (istrand_m(i,j).eq.1) then - -cd yy1=0 -cd yy2=0 -cd yshe1=0 -cd yshe2=0 - - dtmp3=y+yy1+yy2+yshe1+yshe2 - dtmp1=y+yy1+yshe1 - dtmp2=y+yy2+yshe2 - -cc if(dtmp3 .le. -35.0d0) then -c vbetam(i,j)=-dm45*exp(dtmp3) -cc vbetam(i,j)=0.0d0 -cc else -c vbetam(i,j)=-dm45*dfaexp(idint(-dtmp3*1000)+1) - vbetam(i,j)=-dm45*exp(dtmp3) -cc end if - -cc if(dtmp1 .le. -35.0d0) then -c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1) -cc vbetam1(i,j)=0.0d0 -cc else -c vbetam1(i,j)=-r_pair_mat(i+1,j+2) -c $ *dfaexp(idint(-dtmp1*1000)+1) - vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1) -cc end if - -cc if(dtmp2.le.-35.0d0) then -c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2) -cc vbetam2(i,j)=0.0d0 -cc else -c vbetam2(i,j)=-r_pair_mat(i+2,j+1) -c $ *dfaexp(idint(-dtmp2*1000)+1) - vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2) -cc end if - -ci elseif (istrand_m(i,j).eq.0)then -ci vbetam(i,j)=0 -ci vbetam1(i,j)=0 -ci vbetam2(i,j)=0 -ci endif - - -c vbetam(i,j)=-dm45*exp(y+yy1+yy2+yshe1+yshe2) -c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(y+yy1+yshe1) -c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(y+yy2+yshe2) - -! write(*,*) 'r_pair_mat>',i+1,j+2,r_pair_mat(i+1,j+2) -! write(*,*) 'r_pair_mat>',i+2,j+1,r_pair_mat(i+2,j+1) - - uup = vbetap(i,j)+vbetap1(i,j)+vbetap2(i,j) - uum = vbetam(i,j)+vbetam1(i,j)+vbetam2(i,j) - -c write(*,*) 'uup,uum:', uup, uum - -c uup=vbetap1(i,j)+vbetap2(i,j) -c uum=vbetam1(i,j)+vbetam2(i,j) - - vbet(i,j)=uup+uum - vbetp=vbetp+uup - vbetm=vbetm+uum - vbeta=vbeta+vbet(i,j) - -ci elseif(istrand(i,j).eq.0)then -ci vbet(i,j)=0 -ci endif - -c write(*,*) 'uup,uum:',uup,uum -c write(*,*) 'vbetap(i,j):',vbetap(i,j) -c write(*,*) 'vbetap1(i,j):',vbetap1(i,j) -c write(*,*) 'vbetap2(i,j):',vbetap2(i,j) -c write(*,*) 'vbetam(i,j):',vbetam(i,j) -c write(*,*) 'vbetam1(i,j):',vbetam1(i,j) -c write(*,*) 'vbetam2(i,j):',vbetam2(i,j) -c write(*,*) 'uup:',uup -c write(*,*) 'uum:',uum -c write(*,*) 'vbetp:',vbetp -c write(*,*) 'vbetm:',vbetm -c write(*,*) 'vbet(i,j):',vbet(i,j) -c stop - - enddo - enddo - -! do i=1,inb-7 -! do j=i+4,inb-3 -! write(*,*) 'I,J:', i,j -! write(*,*) 'vbetap(i,j):',vbetap(i,j) -! write(*,*) 'vbetap1(i,j):',vbetap1(i,j) -! write(*,*) 'vbetap2(i,j):',vbetap2(i,j) -! write(*,*) 'vbetam(i,j):',vbetam(i,j) -! write(*,*) 'vbetam1(i,j):',vbetam1(i,j) -! write(*,*) 'vbetam2(i,j):',vbetam2(i,j) -! write(*,*) 'vbet(i,j):',vbet(i,j) -! enddo -! enddo - - return - end -c------------------------------------------------------------------------------- - subroutine sheetforce1 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbet(maxca,maxca) - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 cph(maxca),cth(maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12) - real*8 shefy(maxca,12),shefz(maxca,12) - real*8 atx(maxca),aty(maxca),atz(maxca) - real*8 atmx(maxca),atmy(maxca),atmz(maxca) - real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) - real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) - real*8 apx(maxca),apy(maxca),apz(maxca) - real*8 apmx(maxca),apmy(maxca),apmz(maxca) - real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) - real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) - real*8 ulcos(maxca) - real*8 astx(maxca),asty(maxca),astz(maxca) - real*8 astmx(maxca),astmy(maxca),astmz(maxca) - real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) - real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) - real*8 sth(maxca) - real*8 w_beta,dp45, dm45 - real*8 vbeta, vbetp, vbetm - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect - - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /coscos/ cph,cth - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, - $ atmmz,atm3x,atm3y,atm3z - common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, - $ apmmz,apm3x,apm3y,apm3z - common /shef/ shefx,shefy,shefz - common /shee/ vbeta,vbet,vbetp,vbetm - common /ulang/ ulcos -c c********************************************************************** - common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, - $ astmmz,astm3x,astm3y,astm3z - common /sinsin/ sth -C-------------------------------------------------------------------------------- -c local variables - integer i,j,im3,imm,im,ip,ipp,jm,jmm,jm3,jp,jpp - real*8 c1,v1,cc1,dmm,dmm__,fx,fy,fz,c2,v2,dmm1 - real*8 c3,v3,cc2,cc3,dmm3,dmm3__,c4,v4,c7,v7,cc7,c8,v8,cc8 - real*8 c9,v9,cc9,dmm9,dmm9__,c10,v10,dmm2,dmm1__,dmm2_1,dmm2_2 - real*8 dmm7,dmm8,dmm7__,dmm8_1,dmm8_2 -C-------------------------------------------------------------------------------- - do i=4,inb-4 - im3=i-3 - imm=i-2 - im=i-1 - c1=(cth(im3)*c00+sth(im3)*s00-1)/dca - v1=0.0D0 - do j=i+1,inb-3 - v1=v1+vbet(im3,j) - enddo - cc1=(ulcos(imm)-ulnex)/dnex - dmm=cc1/(dis(imm,im)*dis(im,i)) - dmm__=cc1*ulcos(imm)/dis(im,i)**2 - fx=rx(imm,im)*dmm-rx(im,i)*dmm__ - fy=ry(imm,im)*dmm-ry(im,i)*dmm__ - fz=rz(imm,im)*dmm-rz(im,i)*dmm__ -cd fx=0 -cd fy=0 -cd fz=0 - fx=fx+(atm3x(i)*c00+astm3x(i)*s00)*c1 - fy=fy+(atm3y(i)*c00+astm3y(i)*s00)*c1 - fz=fz+(atm3z(i)*c00+astm3z(i)*s00)*c1 - shefx(i,1)=fx*v1 - shefy(i,1)=fy*v1 - shefz(i,1)=fz*v1 - enddo - - do i=3,inb-5 - imm=i-2 - im=i-1 - ip=i+1 - c2=(cth(imm)*c00+sth(imm)*s00-1)/dca - v2=0.0D0 - do j=i+2,inb-3 - v2=v2+vbet(imm,j) - enddo - cc1=(ulcos(imm)-ulnex)/dnex - cc2=(ulcos(im)-ulnex)/dnex - dmm1=cc1/(dis(imm,im)*dis(im,i)) - dmm2=cc2/(dis(im,i)*dis(i,ip)) - dmm1__=cc1*ulcos(imm)/dis(im,i)**2 - dmm2_1=cc2*ulcos(im)/dis(im,i)**2 - dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 -cc********************************************************************** - fx=rx(imm,im)*dmm1-rx(im,i)*dmm1__+rx(i,ip)*dmm2-rx(im,i)*dmm2 - $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2 - fy=ry(imm,im)*dmm1-ry(im,i)*dmm1__+ry(i,ip)*dmm2-ry(im,i)*dmm2 - $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2 - fz=rz(imm,im)*dmm1-rz(im,i)*dmm1__+rz(i,ip)*dmm2-rz(im,i)*dmm2 - $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2 -cd fx=0 -cd fy=0 -cd fz=0 - fx=fx+(atmmx(i)*c00+astmmx(i)*s00)*c2 - fy=fy+(atmmy(i)*c00+astmmy(i)*s00)*c2 - fz=fz+(atmmz(i)*c00+astmmz(i)*s00)*c2 - shefx(i,2)=fx*v2 - shefy(i,2)=fy*v2 - shefz(i,2)=fz*v2 - enddo - do i=2,inb-6 - im=i-1 - ip=i+1 - ipp=i+2 - c3=(cth(im)*c00+sth(im)*s00-1)/dca - v3=0.0D0 - do j=i+3,inb-3 - v3=v3+vbet(im,j) - enddo - cc2=(ulcos(im)-ulnex)/dnex - cc3=(ulcos(i)-ulnex)/dnex - dmm2=cc2/(dis(im,i)*dis(i,ip)) - dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) - dmm2_1=cc2*ulcos(im)/dis(im,i)**2 - dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 - dmm3__=cc3*ulcos(i)/dis(i,ip)**2 - fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm2-rx(im,i)*dmm2 - $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2+rx(i,ip)*dmm3__ - fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm2-ry(im,i)*dmm2 - $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2+ry(i,ip)*dmm3__ - fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm2-rz(im,i)*dmm2 - $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2+rz(i,ip)*dmm3__ -cd fx=0 -cd fy=0 -cd fz=0 - fx=fx+(atmx(i)*c00+astmx(i)*s00)*c3 - fy=fy+(atmy(i)*c00+astmy(i)*s00)*c3 - fz=fz+(atmz(i)*c00+astmz(i)*s00)*c3 - shefx(i,3)=fx*v3 - shefy(i,3)=fy*v3 - shefz(i,3)=fz*v3 - enddo - do i=1,inb-7 - ip=i+1 - ipp=i+2 - c4=(cth(i)*c00+sth(i)*s00-1)/dca - v4=0.0D0 - do j=i+4,inb-3 - v4=v4+vbet(i,j) - enddo - cc3=(ulcos(i)-ulnex)/dnex - dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) - dmm3__=cc3*ulcos(i)/dis(i,ip)**2 - fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm3__ - fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm3__ - fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm3__ -cd fx=0 -cd fy=0 -cd fz=0 - fx=fx+(atx(i)*c00+astx(i)*s00)*c4 - fy=fy+(aty(i)*c00+asty(i)*s00)*c4 - fz=fz+(atz(i)*c00+astz(i)*s00)*c4 - shefx(i,4)=fx*v4 - shefy(i,4)=fy*v4 - shefz(i,4)=fz*v4 - enddo - do j=8,inb - jm3=j-3 - jmm=j-2 - jm=j-1 - c7=(cth(jm3)*c00+sth(jm3)*s00-1)/dca - v7=0.0D0 - do i=1,j-7 - v7=v7+vbet(i,jm3) - enddo - cc7=(ulcos(jmm)-ulnex)/dnex - dmm=cc7/(dis(jmm,jm)*dis(jm,j)) - dmm__=cc7*ulcos(jmm)/dis(jm,j)**2 - fx=rx(jmm,jm)*dmm-rx(jm,j)*dmm__ - fy=ry(jmm,jm)*dmm-ry(jm,j)*dmm__ - fz=rz(jmm,jm)*dmm-rz(jm,j)*dmm__ -cd fx=0 -cd fy=0 -cd fz=0 - fx=fx+(atm3x(j)*c00+astm3x(j)*s00)*c7 - fy=fy+(atm3y(j)*c00+astm3y(j)*s00)*c7 - fz=fz+(atm3z(j)*c00+astm3z(j)*s00)*c7 - shefx(j,7)=fx*v7 - shefy(j,7)=fy*v7 - shefz(j,7)=fz*v7 - enddo - do j=7,inb-1 - jm=j-1 - jmm=j-2 - jp=j+1 - c8=(cth(jmm)*c00+sth(jmm)*s00-1)/dca - v8=0.0D0 - do i=1,j-6 - v8=v8+vbet(i,jmm) - enddo - cc7=(ulcos(jmm)-ulnex)/dnex - cc8=(ulcos(jm)-ulnex)/dnex - dmm7=cc7/(dis(jmm,jm)*dis(jm,j)) - dmm8=cc8/(dis(jm,j)*dis(j,jp)) - dmm7__=cc7*ulcos(jmm)/dis(jm,j)**2 - dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 - dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 - fx=rx(jmm,jm)*dmm7+rx(j,jp)*dmm8-rx(jm,j)*dmm8 - $ -rx(jm,j)*dmm7__-rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2 - fy=ry(jmm,jm)*dmm7+ry(j,jp)*dmm8-ry(jm,j)*dmm8 - $ -ry(jm,j)*dmm7__-ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2 - fz=rz(jmm,jm)*dmm7+rz(j,jp)*dmm8-rz(jm,j)*dmm8 - $ -rz(jm,j)*dmm7__-rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2 -cd fx=0 -cd fy=0 -cd fz=0 - fx=fx+(atmmx(j)*c00+astmmx(j)*s00)*c8 - fy=fy+(atmmy(j)*c00+astmmy(j)*s00)*c8 - fz=fz+(atmmz(j)*c00+astmmz(j)*s00)*c8 - shefx(j,8)=fx*v8 - shefy(j,8)=fy*v8 - shefz(j,8)=fz*v8 - enddo - - do j=6,inb-2 - jm=j-1 - jp=j+1 - jpp=j+2 - c9=(cth(jm)*c00+sth(jm)*s00-1)/dca - v9=0.0D0 - do i=1,j-5 - v9=v9+vbet(i,jm) - enddo - cc8=(ulcos(jm)-ulnex)/dnex - cc9=(ulcos(j)-ulnex)/dnex - dmm8=cc8/(dis(jm,j)*dis(j,jp)) - dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) - dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 - dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 - dmm9__=cc9*ulcos(j)/dis(j,jp)**2 - fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm8-rx(jm,j)*dmm8 - $ -rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2+rx(j,jp)*dmm9__ - fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm8-ry(jm,j)*dmm8 - $ -ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2+ry(j,jp)*dmm9__ - fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm8-rz(jm,j)*dmm8 - $ -rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2+rz(j,jp)*dmm9__ -cd fx=0 -cd fy=0 -cd fz=0 - fx=fx+(atmx(j)*c00+astmx(j)*s00)*c9 - fy=fy+(atmy(j)*c00+astmy(j)*s00)*c9 - fz=fz+(atmz(j)*c00+astmz(j)*s00)*c9 - shefx(j,9)=fx*v9 - shefy(j,9)=fy*v9 - shefz(j,9)=fz*v9 - enddo - - do j=5,inb-3 - jp=j+1 - jpp=j+2 - c10=(cth(j)*c00+sth(j)*s00-1)/dca - v10=0.0D0 - do i=1,j-4 - v10=v10+vbet(i,j) - enddo - cc9=(ulcos(j)-ulnex)/dnex - dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) - dmm9__=cc9*ulcos(j)/dis(j,jp)**2 - fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm9__ - fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm9__ - fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm9__ -cd fx=0 -cd fy=0 -cd fz=0 - fx=fx+(atx(j)*c00+astx(j)*s00)*c10 - fy=fy+(aty(j)*c00+asty(j)*s00)*c10 - fz=fz+(atz(j)*c00+astz(j)*s00)*c10 - shefx(j,10)=fx*v10 - shefy(j,10)=fy*v10 - shefz(j,10)=fz*v10 - enddo - - return - end -c---------------------------------------------------------------------------- - subroutine sheetforce5 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -ci integer istrand(maxca,maxca) -ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) -ci common /shetest/ istrand,istrand_p,istrand_m -c******************************************************************************** -c local variables - integer i,imm,im,jp,jpp,j - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z - real*8 y66x,y66y,y66z,yy6,yyy4,yyy5a,yyy5b - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b -c******************************************************************************** - do i=3,inb-5 - imm=i-2 - im=i-1 - do j=i+2,inb-3 - jp=j+1 - jpp=j+2 - -ci if(istrand(imm,j).eq.1 -ci & .and.(istrand_p(imm,j)+istrand_m(imm,j)).ge.1) then - - - yy1=-(dis(i,jpp)-ulhb)/dlhb - y1x=rx(jpp,i)/dis(i,jpp) - y1y=ry(jpp,i)/dis(i,jpp) - y1z=rz(jpp,i)/dis(i,jpp) - y11x=yy1*y1x - y11y=yy1*y1y - y11z=yy1*y1z - - yy33=1.0D0/(dis(im,jp)*dis(im,i)) - yyy3=pin1(imm,j)/(dis(im,i)**2) - yy3=-pin1(imm,j)/dshe - y3x=(yy33*rx(im,jp)-yyy3*rx(im,i))*yy3 - y3y=(yy33*ry(im,jp)-yyy3*ry(im,i))*yy3 - y3z=(yy33*rz(im,jp)-yyy3*rz(im,i))*yy3 - - yy44=1.0D0/(dis(i,jpp)*dis(im,i)) - yyy4a=pin3(imm,j)/(dis(i,jpp)**2) - yyy4b=pin3(imm,j)/(dis(im,i)**2) - yy4=-pin3(imm,j)/dshe - y4x=(yy44*(rx(i,jpp)-rx(im,i))+yyy4a*rx(i,jpp) - $ -yyy4b*rx(im,i))*yy4 - y4y=(yy44*(ry(i,jpp)-ry(im,i))+yyy4a*ry(i,jpp) - $ -yyy4b*ry(im,i))*yy4 - y4z=(yy44*(rz(i,jpp)-rz(im,i))+yyy4a*rz(i,jpp) - $ -yyy4b*rz(im,i))*yy4 - - - yy55=1.0D0/(dis(i,jpp)*dis(jp,jpp)) - yyy5=pin4(imm,j)/(dis(i,jpp)**2) - yy5=-pin4(imm,j)/dshe - y5x=(-yy55*rx(jp,jpp)+yyy5*rx(i,jpp))*yy5 - y5y=(-yy55*ry(jp,jpp)+yyy5*ry(i,jpp))*yy5 - y5z=(-yy55*rz(jp,jpp)+yyy5*rz(i,jpp))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y3x - sy1=y3y - sz1=y3z - sx2=y11x+y4x+y5x - sy2=y11y+y4y+y5y - sz2=y11z+y4z+y5z - - shefx(i,5)=shefx(i,5)-sx*vbetap(imm,j) - $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) - shefy(i,5)=shefy(i,5)-sy*vbetap(imm,j) - $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) - shefz(i,5)=shefz(i,5)-sz*vbetap(imm,j) - $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) - -! shefx(i,5)=shefx(i,5) -! $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) -! shefy(i,5)=shefy(i,5) -! $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) -! shefz(i,5)=shefz(i,5) -! $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) - - yy6=-(dis(i,jp)-uldhb)/dldhb - y6x=rx(jp,i)/dis(i,jp) - y6y=ry(jp,i)/dis(i,jp) - y6z=rz(jp,i)/dis(i,jp) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(im,jpp)*dis(im,i)) - yyy8=pina1(imm,j)/(dis(im,i)**2) - yy8=-pina1(imm,j)/dshe - y8x=(yy88*rx(im,jpp)-yyy8*rx(im,i))*yy8 - y8y=(yy88*ry(im,jpp)-yyy8*ry(im,i))*yy8 - y8z=(yy88*rz(im,jpp)-yyy8*rz(im,i))*yy8 - - yy99=1.0D0/(dis(jp,i)*dis(im,i)) - yyy9a=pina3(imm,j)/(dis(jp,i)**2) - yyy9b=pina3(imm,j)/(dis(im,i)**2) - yy9=-pina3(imm,j)/dshe - y9x=(yy99*(rx(jp,i)+rx(im,i))-yyy9a*rx(jp,i) - $ -yyy9b*rx(im,i))*yy9 - y9y=(yy99*(ry(jp,i)+ry(im,i))-yyy9a*ry(jp,i) - $ -yyy9b*ry(im,i))*yy9 - y9z=(yy99*(rz(jp,i)+rz(im,i))-yyy9a*rz(jp,i) - $ -yyy9b*rz(im,i))*yy9 - - yy1010=1.0D0/(dis(jp,i)*dis(jp,jpp)) - yyy10=pina4(imm,j)/(dis(jp,i)**2) - yy10=-pina4(imm,j)/dshe - y10x=(yy1010*rx(jp,jpp)-yyy10*rx(jp,i))*yy10 - y10y=(yy1010*ry(jp,jpp)-yyy10*ry(jp,i))*yy10 - y10z=(yy1010*rz(jp,jpp)-yyy10*rz(jp,i))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y8x - sy1=y8y - sz1=y8z - sx2=y66x+y9x+y10x - sy2=y66y+y9y+y10y - sz2=y66z+y9z+y10z - - shefx(i,5)=shefx(i,5)-sx*vbetam(imm,j) - $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) - shefy(i,5)=shefy(i,5)-sy*vbetam(imm,j) - $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) - shefz(i,5)=shefz(i,5)-sz*vbetam(imm,j) - $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) - -! shefx(i,5)=shefx(i,5) -! $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) -! shefy(i,5)=shefy(i,5) -! $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) -! shefz(i,5)=shefz(i,5) -! $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) - -ci endif - - enddo - enddo - - return - end -c--------------------------------------------------------------------------c - subroutine sheetforce6 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -ci integer istrand(maxca,maxca) -ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) -ci common /shetest/ istrand,istrand_p,istrand_m -cc********************************************************************** -C local variables - integer i,imm,im,jp,jpp,j,ip - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b,yyy4 - real*8 yyy3a,yyy3b,y66z,yy6,yyy5a,yyy5b -C******************************************************************************** - do i=2,inb-6 - ip=i+1 - im=i-1 - do j=i+3,inb-3 - jp=j+1 - jpp=j+2 - -ci if(istrand(im,j).eq.1 -ci & .and.(istrand_p(im,j)+istrand_m(im,j)).ge.1) then - - - yy1=-(dis(i,jp)-ulhb)/dlhb - y1x=rx(jp,i)/dis(i,jp) - y1y=ry(jp,i)/dis(i,jp) - y1z=rz(jp,i)/dis(i,jp) - y11x=yy1*y1x - y11y=yy1*y1y - y11z=yy1*y1z - - yy33=1.0D0/(dis(i,jp)*dis(i,ip)) - yyy3a=pin1(im,j)/(dis(i,jp)**2) - yyy3b=pin1(im,j)/(dis(i,ip)**2) - yy3=-pin1(im,j)/dshe - y3x=(-yy33*(rx(i,ip)+rx(i,jp))+yyy3a*rx(i,jp) - $ +yyy3b*rx(i,ip))*yy3 - y3y=(-yy33*(ry(i,ip)+ry(i,jp))+yyy3a*ry(i,jp) - $ +yyy3b*ry(i,ip))*yy3 - y3z=(-yy33*(rz(i,ip)+rz(i,jp))+yyy3a*rz(i,jp) - $ +yyy3b*rz(i,ip))*yy3 - - yy44=1.0D0/(dis(i,jp)*dis(jp,jpp)) - yyy4=pin2(im,j)/(dis(i,jp)**2) - yy4=-pin2(im,j)/dshe - y4x=(-yy44*rx(jp,jpp)+yyy4*rx(i,jp))*yy4 - y4y=(-yy44*ry(jp,jpp)+yyy4*ry(i,jp))*yy4 - y4z=(-yy44*rz(jp,jpp)+yyy4*rz(i,jp))*yy4 - - yy55=1.0D0/(dis(ip,jpp)*dis(i,ip)) - yyy5=pin3(im,j)/(dis(i,ip)**2) - yy5=-pin3(im,j)/dshe - y5x=(-yy55*rx(ip,jpp)+yyy5*rx(i,ip))*yy5 - y5y=(-yy55*ry(ip,jpp)+yyy5*ry(i,ip))*yy5 - y5z=(-yy55*rz(ip,jpp)+yyy5*rz(i,ip))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y11x+y3x+y4x - sy1=y11y+y3y+y4y - sz1=y11z+y3z+y4z - sx2=y5x - sy2=y5y - sz2=y5z - - shefx(i,6)=shefx(i,6)-sx*vbetap(im,j) - $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) - shefy(i,6)=shefy(i,6)-sy*vbetap(im,j) - $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) - shefz(i,6)=shefz(i,6)-sz*vbetap(im,j) - $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) -! shefx(i,6)=shefx(i,6) -! $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) -! shefy(i,6)=shefy(i,6) -! $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) -! shefz(i,6)=shefz(i,6) -! $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) - - yy6=-(dis(jpp,i)-uldhb)/dldhb - y6x=rx(jpp,i)/dis(jpp,i) - y6y=ry(jpp,i)/dis(jpp,i) - y6z=rz(jpp,i)/dis(jpp,i) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(i,jpp)*dis(i,ip)) - yyy8a=pina1(im,j)/(dis(i,jpp)**2) - yyy8b=pina1(im,j)/(dis(i,ip)**2) - yy8=-pina1(im,j)/dshe - y8x=(-yy88*(rx(i,jpp)+rx(i,ip))+yyy8a*rx(i,jpp) - $ +yyy8b*rx(i,ip))*yy8 - y8y=(-yy88*(ry(i,jpp)+ry(i,ip))+yyy8a*ry(i,jpp) - $ +yyy8b*ry(i,ip))*yy8 - y8z=(-yy88*(rz(i,jpp)+rz(i,ip))+yyy8a*rz(i,jpp) - $ +yyy8b*rz(i,ip))*yy8 - - yy99=1.0D0/(dis(i,jpp)*dis(jp,jpp)) - yyy9=pina2(im,j)/(dis(i,jpp)**2) - yy9=-pina2(im,j)/dshe - y9x=(-yy99*rx(jp,jpp)+yyy9*rx(i,jpp))*yy9 - y9y=(-yy99*ry(jp,jpp)+yyy9*ry(i,jpp))*yy9 - y9z=(-yy99*rz(jp,jpp)+yyy9*rz(i,jpp))*yy9 - - yy1010=1.0D0/(dis(jp,ip)*dis(i,ip)) - yyy10=pina3(im,j)/(dis(i,ip)**2) - yy10=-pina3(im,j)/dshe - y10x=(-yy1010*rx(jp,ip)+yyy10*rx(i,ip))*yy10 - y10y=(-yy1010*ry(jp,ip)+yyy10*ry(i,ip))*yy10 - y10z=(-yy1010*rz(jp,ip)+yyy10*rz(i,ip))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y66x+y8x+y9x - sy1=y66y+y8y+y9y - sz1=y66z+y8z+y9z - sx2=y10x - sy2=y10y - sz2=y10z - - shefx(i,6)=shefx(i,6)-sx*vbetam(im,j) - $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) - shefy(i,6)=shefy(i,6)-sy*vbetam(im,j) - $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) - shefz(i,6)=shefz(i,6)-sz*vbetam(im,j) - $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) - -! shefx(i,6)=shefx(i,6) -! $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) -! shefy(i,6)=shefy(i,6) -! $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) -! shefz(i,6)=shefz(i,6) -! $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) - -ci endif - - enddo - enddo - - return - end -c----------------------------------------------------------------------- - subroutine sheetforce11 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -ci integer istrand(maxca,maxca) -ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) -ci common /shetest/ istrand,istrand_p,istrand_m -C******************************************************************************** -C local variables - integer j,jm,jmm,ip,i,ipp - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy4,yyy5a,yyy5b,yy6 - real*8 yyy9a,yyy9b,y5z,y66z,y9z,yyy8 -C******************************************************************************** - - do j=7,inb-1 - jm=j-1 - jmm=j-2 - do i=1,j-6 - ip=i+1 - ipp=i+2 - -ci if(istrand(i,jmm).eq.1 -ci & .and.(istrand_p(i,jmm)+istrand_m(i,jmm)).ge.1) then - - - yy1=-(dis(ipp,j)-ulhb)/dlhb - y1x=rx(ipp,j)/dis(ipp,j) - y1y=ry(ipp,j)/dis(ipp,j) - y1z=rz(ipp,j)/dis(ipp,j) - y11x=yy1*y1x - y11y=yy1*y1y - y11z=yy1*y1z - - yy33=1.0D0/(dis(ip,jm)*dis(jm,j)) - yyy3=pin2(i,jmm)/(dis(jm,j)**2) - yy3=-pin2(i,jmm)/dshe - y3x=(yy33*rx(ip,jm)-yyy3*rx(jm,j))*yy3 - y3y=(yy33*ry(ip,jm)-yyy3*ry(jm,j))*yy3 - y3z=(yy33*rz(ip,jm)-yyy3*rz(jm,j))*yy3 - - yy44=1.0D0/(dis(ipp,j)*dis(ip,ipp)) - yyy4=pin3(i,jmm)/(dis(ipp,j)**2) - yy4=-pin3(i,jmm)/dshe - y4x=(yy44*rx(ip,ipp)-yyy4*rx(ipp,j))*yy4 - y4y=(yy44*ry(ip,ipp)-yyy4*ry(ipp,j))*yy4 - y4z=(yy44*rz(ip,ipp)-yyy4*rz(ipp,j))*yy4 - - yy55=1.0D0/(dis(ipp,j)*dis(jm,j)) - yyy5a=pin4(i,jmm)/(dis(ipp,j)**2) - yyy5b=pin4(i,jmm)/(dis(jm,j)**2) - yy5=-pin4(i,jmm)/dshe - y5x=(yy55*(rx(jm,j)+rx(ipp,j))-yyy5a*rx(ipp,j) - $ -yyy5b*rx(jm,j))*yy5 - y5y=(yy55*(ry(jm,j)+ry(ipp,j))-yyy5a*ry(ipp,j) - $ -yyy5b*ry(jm,j))*yy5 - y5z=(yy55*(rz(jm,j)+rz(ipp,j))-yyy5a*rz(ipp,j) - $ -yyy5b*rz(jm,j))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y3x - sy1=y3y - sz1=y3z - sx2=y11x+y4x+y5x - sy2=y11y+y4y+y5y - sz2=y11z+y4z+y5z - - shefx(j,11)=shefx(j,11)-sx*vbetap(i,jmm) - $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) - shefy(j,11)=shefy(j,11)-sy*vbetap(i,jmm) - $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) - shefz(j,11)=shefz(j,11)-sz*vbetap(i,jmm) - $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) - -! shefx(j,11)=shefx(j,11) -! $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) -! shefy(j,11)=shefy(j,11) -! $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) -! shefz(j,11)=shefz(j,11) -! $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) - - yy6=-(dis(ip,j)-uldhb)/dldhb - y6x=rx(ip,j)/dis(ip,j) - y6y=ry(ip,j)/dis(ip,j) - y6z=rz(ip,j)/dis(ip,j) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(ip,j)*dis(ip,ipp)) - yyy8=pina1(i,jmm)/(dis(ip,j)**2) - yy8=-pina1(i,jmm)/dshe - y8x=(yy88*rx(ip,ipp)-yyy8*rx(ip,j))*yy8 - y8y=(yy88*ry(ip,ipp)-yyy8*ry(ip,j))*yy8 - y8z=(yy88*rz(ip,ipp)-yyy8*rz(ip,j))*yy8 - - yy99=1.0D0/(dis(ip,j)*dis(jm,j)) - yyy9a=pina2(i,jmm)/(dis(ip,j)**2) - yyy9b=pina2(i,jmm)/(dis(jm,j)**2) - yy9=-pina2(i,jmm)/dshe - y9x=(yy99*(rx(jm,j)+rx(ip,j))-yyy9a*rx(ip,j) - $ -yyy9b*rx(jm,j))*yy9 - y9y=(yy99*(ry(jm,j)+ry(ip,j))-yyy9a*ry(ip,j) - $ -yyy9b*ry(jm,j))*yy9 - y9z=(yy99*(rz(jm,j)+rz(ip,j))-yyy9a*rz(ip,j) - $ -yyy9b*rz(jm,j))*yy9 - - yy1010=1.0D0/(dis(jm,ipp)*dis(jm,j)) - yyy10=pina4(i,jmm)/(dis(jm,j)**2) - yy10=-pina4(i,jmm)/dshe - y10x=(yy1010*rx(jm,ipp)-yyy10*rx(jm,j))*yy10 - y10y=(yy1010*ry(jm,ipp)-yyy10*ry(jm,j))*yy10 - y10z=(yy1010*rz(jm,ipp)-yyy10*rz(jm,j))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y66x+y8x+y9x - sy1=y66y+y8y+y9y - sz1=y66z+y8z+y9z - sx2=y10x - sy2=y10y - sz2=y10z - - shefx(j,11)=shefx(j,11)-sx*vbetam(i,jmm) - $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) - shefy(j,11)=shefy(j,11)-sy*vbetam(i,jmm) - $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) - shefz(j,11)=shefz(j,11)-sz*vbetam(i,jmm) - $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) - -! shefx(j,11)=shefx(j,11) -! $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) -! shefy(j,11)=shefy(j,11) -! $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) -! shefz(j,11)=shefz(j,11) -! $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) - -ci endif - - enddo - enddo - - return - end -c----------------------------------------------------------------------- - subroutine sheetforce12 - implicit none - integer maxca - parameter(maxca=800) -cc********************************************************************** - real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) - real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) - real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) - real*8 pin1(maxca,maxca),pin2(maxca,maxca) - real*8 pin3(maxca,maxca),pin4(maxca,maxca) - real*8 pina1(maxca,maxca),pina2(maxca,maxca) - real*8 pina3(maxca,maxca),pina4(maxca,maxca) - real*8 rx(maxca,maxca) - real*8 ry(maxca,maxca),rz(maxca,maxca) - real*8 bx(maxca),by(maxca),bz(maxca) - real*8 dis(maxca,maxca) - real*8 shefx(maxca,12),shefy(maxca,12) - real*8 shefz(maxca,12) - real*8 dp45,dm45,w_beta - real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - integer inb,nmax,iselect -cc********************************************************************** - common /phys1/ inb,nmax,iselect - common /kyori2/ dis - common /difvec/ rx,ry,rz - common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, - $ c00,s00,ulnex,dnex - common /sheconst/ dp45,dm45,w_beta - common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 - common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 - common /shef/ shefx,shefy,shefz -ci integer istrand(maxca,maxca) -ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) -ci common /shetest/ istrand,istrand_p,istrand_m -cc********************************************************************** -C local variables - integer j,jm,jmm,ip,i,ipp,jp - real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z - real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z - real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y,y66z - real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z - real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy10a,yyy10b,yy6,yyy8 -!c*************************************************************************c - do j=6,inb-2 - jp=j+1 - jm=j-1 - do i=1,j-5 - ip=i+1 - ipp=i+2 - -ci if(istrand(i,jm).eq.1 -ci & .and.(istrand_p(i,jm)+istrand_m(i,jm)).ge.1) then - - - yy1=-(dis(ip,j)-ulhb)/dlhb - y1x=rx(ip,j)/dis(ip,j) - y1y=ry(ip,j)/dis(ip,j) - y1z=rz(ip,j)/dis(ip,j) - y11x=y1x*yy1 - y11y=y1y*yy1 - y11z=y1z*yy1 - - yy33=1.0D0/(dis(ip,j)*dis(ip,ipp)) - yyy3=pin1(i,jm)/(dis(ip,j)**2) - yy3=-pin1(i,jm)/dshe - y3x=(yy33*rx(ip,ipp)-yyy3*rx(ip,j))*yy3 - y3y=(yy33*ry(ip,ipp)-yyy3*ry(ip,j))*yy3 - y3z=(yy33*rz(ip,ipp)-yyy3*rz(ip,j))*yy3 - yy44=1.0D0/(dis(ip,j)*dis(j,jp)) - - yyy4a=pin2(i,jm)/(dis(ip,j)**2) - yyy4b=pin2(i,jm)/(dis(j,jp)**2) - yy4=-pin2(i,jm)/dshe - y4x=(yy44*(rx(j,jp)-rx(ip,j))-yyy4a*rx(ip,j) - $ +yyy4b*rx(j,jp))*yy4 - y4y=(yy44*(ry(j,jp)-ry(ip,j))-yyy4a*ry(ip,j) - $ +yyy4b*ry(j,jp))*yy4 - y4z=(yy44*(rz(j,jp)-rz(ip,j))-yyy4a*rz(ip,j) - $ +yyy4b*rz(j,jp))*yy4 - - yy55=1.0D0/(dis(ipp,jp)*dis(j,jp)) - yyy5=pin4(i,jm)/(dis(j,jp)**2) - yy5=-pin4(i,jm)/dshe - y5x=(-yy55*rx(ipp,jp)+yyy5*rx(j,jp))*yy5 - y5y=(-yy55*ry(ipp,jp)+yyy5*ry(j,jp))*yy5 - y5z=(-yy55*rz(ipp,jp)+yyy5*rz(j,jp))*yy5 - - sx=y11x+y3x+y4x+y5x - sy=y11y+y3y+y4y+y5y - sz=y11z+y3z+y4z+y5z - - sx1=y11x+y3x+y4x - sy1=y11y+y3y+y4y - sz1=y11z+y3z+y4z - sx2=y5x - sy2=y5y - sz2=y5z - - shefx(j,12)=shefx(j,12)-sx*vbetap(i,jm) - $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) - shefy(j,12)=shefy(j,12)-sy*vbetap(i,jm) - $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) - shefz(j,12)=shefz(j,12)-sz*vbetap(i,jm) - $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) - -! shefx(j,12)=shefx(j,12) -! $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) -! shefy(j,12)=shefy(j,12) -! $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) -! shefz(j,12)=shefz(j,12) -! $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) - - yy6=-(dis(ipp,j)-uldhb)/dldhb - y6x=rx(ipp,j)/dis(ipp,j) - y6y=ry(ipp,j)/dis(ipp,j) - y6z=rz(ipp,j)/dis(ipp,j) - y66x=yy6*y6x - y66y=yy6*y6y - y66z=yy6*y6z - - yy88=1.0D0/(dis(ip,jp)*dis(j,jp)) - yyy8=pina2(i,jm)/(dis(j,jp)**2) - yy8=-pina2(i,jm)/dshe - y8x=(-yy88*rx(ip,jp)+yyy8*rx(j,jp))*yy8 - y8y=(-yy88*ry(ip,jp)+yyy8*ry(j,jp))*yy8 - y8z=(-yy88*rz(ip,jp)+yyy8*rz(j,jp))*yy8 - - yy99=1.0D0/(dis(j,ipp)*dis(ip,ipp)) - yyy9=pina3(i,jm)/(dis(j,ipp)**2) - yy9=-pina3(i,jm)/dshe - y9x=(-yy99*rx(ip,ipp)+yyy9*rx(j,ipp))*yy9 - y9y=(-yy99*ry(ip,ipp)+yyy9*ry(j,ipp))*yy9 - y9z=(-yy99*rz(ip,ipp)+yyy9*rz(j,ipp))*yy9 - - yy1010=1.0D0/(dis(j,ipp)*dis(j,jp)) - yyy10a=pina4(i,jm)/(dis(j,ipp)**2) - yyy10b=pina4(i,jm)/(dis(j,jp)**2) - yy10=-pina4(i,jm)/dshe - y10x=(-yy1010*(rx(j,ipp)+rx(j,jp))+yyy10a*rx(j,ipp) - $ +yyy10b*rx(j,jp))*yy10 - y10y=(-yy1010*(ry(j,ipp)+ry(j,jp))+yyy10a*ry(j,ipp) - $ +yyy10b*ry(j,jp))*yy10 - y10z=(-yy1010*(rz(j,ipp)+rz(j,jp))+yyy10a*rz(j,ipp) - $ +yyy10b*rz(j,jp))*yy10 - - sx=y66x+y8x+y9x+y10x - sy=y66y+y8y+y9y+y10y - sz=y66z+y8z+y9z+y10z - - sx1=y8x - sy1=y8y - sz1=y8z - sx2=y66x+y9x+y10x - sy2=y66y+y9y+y10y - sz2=y66z+y9z+y10z - - shefx(j,12)=shefx(j,12)-sx*vbetam(i,jm) - $ -sx1*vbetam1(i,jm)-sx2*vbetam2(i,jm) - shefy(j,12)=shefy(j,12)-sy*vbetam(i,jm) - $ -sy1*vbetam1(i,jm)-sy2*vbetam2(i,jm) - shefz(j,12)=shefz(j,12)-sz*vbetam(i,jm) - $ -sz1*vbetam1(i,jm)-sz2*vbetam2(i,jm) - -ci endif - - ENDDO - ENDDO - - RETURN - END -C=============================================================================== diff --git a/source/unres/src_MD_DFA/dihed_cons.F b/source/unres/src_MD_DFA/dihed_cons.F deleted file mode 100644 index e45405f..0000000 --- a/source/unres/src_MD_DFA/dihed_cons.F +++ /dev/null @@ -1,185 +0,0 @@ - subroutine secstrp2dihc - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.BOUNDS' - include 'COMMON.CHAIN' - include 'COMMON.TORCNSTR' - include 'COMMON.IOUNITS' - character*1 secstruc(maxres) - COMMON/SECONDARYS/secstruc - character*80 line - logical errflag - external ilen - -cdr call getenv_loc('SECPREDFIL',secpred) - lenpre=ilen(prefix) - secpred=prefix(:lenpre)//'.spred' - -#if defined(WINIFL) || defined(WINPGI) - open(isecpred,file=secpred,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open(isecpred,file=secpred,status='old',action='read') -#elif (defined G77) - open(isecpred,file=secpred,status='old') -#else - open(isecpred,file=secpred,status='old',action='read') -#endif -C read secondary structure prediction from JPRED here! -! read(isecpred,'(A80)',err=100,end=100) line -! read(line,'(f10.3)',err=110) ftors - read(isecpred,'(f10.3)',err=110) ftors - - write (iout,*) 'FTORS factor =',ftors -! initialize secstruc to any - do i=1,nres - secstruc(i) ='-' - enddo - ndih_constr=0 - ndih_nconstr=0 - - call read_secstr_pred(isecpred,iout,errflag) - if (errflag) then - write(iout,*)'There is a problem with the list of secondary-', - & 'structure prediction' - goto 100 - endif -C 8/13/98 Set limits to generating the dihedral angles - do i=1,nres - phibound(1,i)=-pi - phibound(2,i)=pi - enddo - - ii=0 - do i=1,nres - if ( secstruc(i) .eq. 'H') then -C Helix restraints for this residue - ii=ii+1 - idih_constr(ii)=i - phi0(ii) = 45.0D0*deg2rad - drange(ii)= 5.0D0*deg2rad - phibound(1,i) = phi0(ii)-drange(ii) - phibound(2,i) = phi0(ii)+drange(ii) - else if (secstruc(i) .eq. 'E') then -C strand restraints for this residue - ii=ii+1 - idih_constr(ii)=i - phi0(ii) = 180.0D0*deg2rad - drange(ii)= 5.0D0*deg2rad - phibound(1,i) = phi0(ii)-drange(ii) - phibound(2,i) = phi0(ii)+drange(ii) - else -C no restraints for this residue - ndih_nconstr=ndih_nconstr+1 - idih_nconstr(ndih_nconstr)=i - endif - enddo - ndih_constr=ii - return -100 continue - write(iout,'(A30,A80)')'Error reading file SECPRED',secpred - return - 110 continue - write(iout,'(A20)')'Error reading FTORS' - return - end - - subroutine read_secstr_pred(jin,jout,errors) - - implicit real*8 (a-h,o-z) - INCLUDE 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - character*1 secstruc(maxres) - COMMON/SECONDARYS/secstruc - EXTERNAL ILEN - character*80 line,line1,ucase - logical errflag,errors,blankline - - errors=.false. - read (jin,'(a)') line - write (jout,'(2a)') '> ',line(1:78) - line1=ucase(line) -C Remember that we number full residues starting from 2, then, iseq=1 and iseq=nres -C correspond to the end-groups. ADD to the secondary structure prediction "-" for the -C end-groups in the input file "*.spred" - - iseq=1 - do while (index(line1,'$END').eq.0) -* Override commented lines. - ipos=1 - blankline=.false. - do while (.not.blankline) - line1=' ' - call mykey(line,line1,ipos,blankline,errflag) - if (errflag) write (jout,'(2a)') - & 'Error when reading sequence in line: ',line - errors=errors .or. errflag - if (.not. blankline .and. .not. errflag) then - ipos1=2 - iend=ilen(line1) - if (iseq.le.maxres) then - if (line1(1:1).eq.'-' ) then - secstruc(iseq)=line1(1:1) - else if ( ( ucase(line1(1:1)).eq.'E' ) .or. - & ( ucase(line1(1:1)).eq.'H' ) ) then - secstruc(iseq)=ucase(line1(1:1)) - else - errors=.true. - write (jout,1010) line1(1:1), iseq - goto 80 - endif - else - errors=.true. - write (jout,1000) iseq,maxres - goto 80 - endif - do while (ipos1.le.iend) - - iseq=iseq+1 - il=1 - ipos1=ipos1+1 - if (iseq.le.maxres) then - if (line1(ipos1-1:ipos1-1).eq.'-' ) then - secstruc(iseq)=line1(ipos1-1:ipos1-1) - else if((ucase(line1(ipos1-1:ipos1-1)).eq.'E').or. - & (ucase(line1(ipos1-1:ipos1-1)).eq.'H') ) then - secstruc(iseq)=ucase(line1(ipos1-1:ipos1-1)) - else - errors=.true. - write (jout,1010) line1(ipos1-1:ipos1-1), iseq - goto 80 - endif - else - errors=.true. - write (jout,1000) iseq,maxres - goto 80 - endif - enddo - iseq=iseq+1 - endif - enddo - read (jin,'(a)') line - write (jout,'(2a)') '> ',line(1:78) - line1=ucase(line) - enddo - -cd write (jout,'(10a8)') (sequence(i),i=1,iseq-1) - -cd check whether the found length of the chain is correct. - length_of_chain=iseq-1 - if (length_of_chain .ne. nres) then -! errors=.true. - write (jout,'(a,i4,a,i4,a)') - & 'Error: the number of labels specified in $SEC_STRUC_PRED (' - & ,length_of_chain,') does not match with the number of residues (' - & ,nres,').' - endif - 80 continue - - 1000 format('Error - the number of residues (',i4, - & ') has exceeded maximum (',i4,').') - 1010 format ('Error - unrecognized secondary structure label',a4, - & ' in position',i4) - return - end diff --git a/source/unres/src_MD_DFA/djacob.f b/source/unres/src_MD_DFA/djacob.f deleted file mode 100644 index e3f46bc..0000000 --- a/source/unres/src_MD_DFA/djacob.f +++ /dev/null @@ -1,107 +0,0 @@ - SUBROUTINE DJACOB(N,NMAX,MAXJAC,E,A,C,AII) - IMPLICIT REAL*8 (A-H,O-Z) -C THE JACOBI DIAGONALIZATION PROCEDURE - COMMON INP,IOUT,IPN - DIMENSION A(NMAX,N),C(NMAX,N),AII(150),AJJ(150) - SIN45 = .70710678 - COS45 = .70710678 - S45SQ = 0.50 - C45SQ = 0.50 -C UNIT EIGENVECTOR MATRIX - DO 70 I = 1,N - DO 7 J = I,N - A(J,I)=A(I,J) - C(I,J) = 0.0 - 7 C(J,I) = 0.0 - 70 C(I,I) = 1.0 -C DETERMINATION OF SEARCH ARGUMENT, TEST - AMAX = 0.0 - DO 1 I = 1,N - DO 1 J = 1,I - TEMPA=DABS(A(I,J)) - IF (AMAX-TEMPA) 2,1,1 - 2 AMAX = TEMPA - 1 CONTINUE - TEST = AMAX*E -C SEARCH FOR LARGEST OFF DIAGONAL ELEMENT - DO 72 IJAC=1,MAXJAC - AIJMAX = 0.0 - DO 3 I = 2,N - LIM = I-1 - DO 3 J = 1,LIM - TAIJ=DABS(A(I,J)) - IF (AIJMAX-TAIJ) 4,3,3 - 4 AIJMAX = TAIJ - IPIV = I - JPIV = J - 3 CONTINUE - IF(AIJMAX-TEST)300,300,5 -C PARAMETERS FOR ROTATION - 5 TAII = A(IPIV,IPIV) - TAJJ = A(JPIV,JPIV) - TAIJ = A(IPIV,JPIV) - TMT = TAII-TAJJ - IF(DABS(TMT/TAIJ)-1.0D-12) 60,60,6 - 60 IF(TAIJ) 10,10,11 - 6 ZAMMA=TAIJ/(2.0*TMT) - 90 IF(DABS(ZAMMA)-0.38268)8,8,9 - 9 IF(ZAMMA)10,10,11 - 10 SINT = -SIN45 - GO TO 12 - 11 SINT = SIN45 - 12 COST = COS45 - SINSQ = S45SQ - COSSQ = C45SQ - GO TO 120 - 8 GAMSQ=ZAMMA*ZAMMA - SINT=2.0*ZAMMA/(1.0+GAMSQ) - COST = (1.0-GAMSQ)/(1.0+GAMSQ) - SINSQ=SINT*SINT - COSSQ=COST*COST -C ROTATION - 120 DO 13 K = 1,N - TAIK = A(IPIV,K) - TAJK = A(JPIV,K) - A(IPIV,K) = TAIK*COST+TAJK*SINT - A(JPIV,K) = TAJK*COST-TAIK*SINT - TCIK = C(IPIV,K) - TCJK = C(JPIV,K) - C(IPIV,K) = TCIK*COST+TCJK*SINT - 13 C(JPIV,K) = TCJK*COST-TCIK*SINT - A(IPIV,IPIV) = TAII*COSSQ+TAJJ*SINSQ+2.0*TAIJ*SINT*COST - A(JPIV,JPIV) = TAII*SINSQ+TAJJ*COSSQ-2.0*TAIJ*SINT*COST - A(IPIV,JPIV) = TAIJ*(COSSQ-SINSQ)-SINT*COST*TMT - A(JPIV,IPIV) = A(IPIV,JPIV) - DO 30 K = 1,N - A(K,IPIV) = A(IPIV,K) - 30 A(K,JPIV) = A(JPIV,K) - 72 CONTINUE - WRITE (IOUT,1000) AIJMAX - 1000 FORMAT (/1X,'NONCONVERGENT JACOBI. LARGEST OFF-DIAGONAL ELE', - 1 'MENT = ',1PE14.7) -C ARRANGEMENT OF EIGENVALUES IN ASCENDING ORDER - 300 DO 14 I=1,N - 14 AJJ(I)=A(I,I) - LT=N+1 - DO15 L=1,N - LT=LT-1 - AIIMIN=1.0E+30 - DO16 I=1,N - IF(AJJ(I)-AIIMIN)17,16,16 - 17 AIIMIN=AJJ(I) - IT=I - 16 CONTINUE - IN=L - AII(IN)=AIIMIN - AJJ(IT)=1.0E+30 - DO15 K=1,N - 15 A(IN,K)=C(IT,K) - DO 18 I=1,N - IF(A(I,1))19,22,22 - 19 T=-1.0 - GO TO 91 - 22 T=1.0 - 91 DO 18 J=1,N - 18 C(J,I)=T*A(I,J) - RETURN - END diff --git a/source/unres/src_MD_DFA/econstr_local.F b/source/unres/src_MD_DFA/econstr_local.F deleted file mode 100644 index f11acfb..0000000 --- a/source/unres/src_MD_DFA/econstr_local.F +++ /dev/null @@ -1,91 +0,0 @@ - subroutine Econstr_back -c MD with umbrella_sampling using Wolyne's distance measure as a constraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - Uconst_back=0.0d0 - do i=1,nres - dutheta(i)=0.0d0 - dugamma(i)=0.0d0 - do j=1,3 - duscdiff(j,i)=0.0d0 - duscdiffx(j,i)=0.0d0 - enddo - enddo - do i=1,nfrag_back - ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) -c -c Deviations from theta angles -c - utheta_i=0.0d0 - do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) - dtheta_i=theta(j)-thetaref(j) - utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i - dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) - enddo - utheta(i)=utheta_i/(ii-1) -c -c Deviations from gamma angles -c - ugamma_i=0.0d0 - do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset) - dgamma_i=pinorm(phi(j)-phiref(j)) -c write (iout,*) j,phi(j),phi(j)-phiref(j) - ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i - dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2) -c write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3) - enddo - ugamma(i)=ugamma_i/(ii-2) -c -c Deviations from local SC geometry -c - uscdiff(i)=0.0d0 - do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 - dxx=xxtab(j)-xxref(j) - dyy=yytab(j)-yyref(j) - dzz=zztab(j)-zzref(j) - uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz - do k=1,3 - duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* - & (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ - & (ii-1) - duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* - & (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ - & (ii-1) - duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* - & (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) - & /(ii-1) - enddo -c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), -c & xxref(j),yyref(j),zzref(j) - enddo - uscdiff(i)=0.5d0*uscdiff(i)/(ii-1) -c write (iout,*) i," uscdiff",uscdiff(i) -c -c Put together deviations from local geometry -c - Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ - & wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i) -c write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i), -c & " uconst_back",uconst_back - utheta(i)=dsqrt(utheta(i)) - ugamma(i)=dsqrt(ugamma(i)) - uscdiff(i)=dsqrt(uscdiff(i)) - enddo - return - end diff --git a/source/unres/src_MD_DFA/eigen.f b/source/unres/src_MD_DFA/eigen.f deleted file mode 100644 index e4088ee..0000000 --- a/source/unres/src_MD_DFA/eigen.f +++ /dev/null @@ -1,2351 +0,0 @@ -C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS -C 31 MAR 94 - MWS - ADD A VARIABLE TO END OF MACHSW COMMON -C 26 JUN 93 - MWS - ETRED3: ADD RETURN FOR SPECIAL CASE N=1 -C 4 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR -C 30 AUG 91 - MWS - JACDIA: LIMIT ITERATIONS, USE EPSLON IN TEST. -C 14 JUL 91 - MWS - JACOBI DIAGONALIZATION ALLOWS FOR LDVEC.NE.N -C 29 JAN 91 - TLW - GLDIAG: CHANGED COMMON DIAGSW TO MACHSW -C 29 OCT 90 - STE - FIX JACDIA UNDEFINED VARIABLE BUG -C 14 SEP 90 - MK - NEW JACOBI DIAGONALIZATION (KDIAG=3) -C 27 MAR 88 - MWS - ALLOW FOR VECTOR ROUTINE IN GLDIAG -C 11 AUG 87 - MWS - SANITIZE CONSTANTS IN EQLRAT -C 15 FEB 87 - STE - FIX EINVIT SUB-MATRIX LOOP LIMIT -C SCRATCH ARRAYS ARE N*8 REAL AND N INTEGER -C 8 DEC 86 - STE - USE PERF INDEX FROM ESTPI1 TO JUDGE EINVIT FAILURE -C 30 NOV 86 - STE - DELETE LIGENB, MAKE EVVRSP DEFAULT -C (GIVEIS FAILS ON CRAY FOR BENCHMC AND BENCHCI) -C 7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS -C 11 OCT 85 - STE - LIGENB,TQL2: USE DROT,DSWAP; TINVTB: SCALE VECTOR -C BEFORE NORMALIZING; GENERIC FUNCTIONS -C 24 FEB 84 - STE - INITIALIZE INDEX ARRAY FOR LIGENB IN GLDIAG -C 1 DEC 83 - STE - CHANGE MACHEP FROM 2**-54 TO 2**-50 -C 28 SEP 82 - MWS - CONVERT TO IBM -C -C*MODULE EIGEN *DECK EINVIT - SUBROUTINE EINVIT(NM,N,D,E,E2,M,W,IND,Z,IERR,RV1,RV2,RV3,RV4,RV6) -C* -C* AUTHORS- -C* THIS IS A MODIFICATION OF TINVIT FROM EISPACK EDITION 3 -C* DATED AUGUST 1983. -C* TINVIT IS A TRANSLATION OF THE INVERSE ITERATION TECHNIQUE -C* IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. -C* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). -C* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) -C* -C* PURPOSE - -C* THIS ROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL -C* SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES. -C* -C* METHOD - -C* INVERSE ITERATION. -C* -C* ON ENTRY - -C* NM - INTEGER -C* MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C* ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -C* DIMENSION STATEMENT. -C* N - INTEGER -C* D - W.P. REAL (N) -C* CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. -C* E - W.P. REAL (N) -C* CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -C* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. -C* E2 - W.P. REAL (N) -C* CONTAINS THE SQUARES OF CORRESPONDING ELEMENTS OF E, -C* WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. -C* E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN -C* THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE -C* SUM OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST -C* CONTAIN 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, -C* OR 2.0 IF THE EIGENVALUES ARE IN DESCENDING ORDER. -C* IF TQLRAT, BISECT, TRIDIB, OR IMTQLV -C* HAS BEEN USED TO FIND THE EIGENVALUES, THEIR -C* OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE. -C* M - INTEGER -C* THE NUMBER OF SPECIFIED EIGENVECTORS. -C* W - W.P. REAL (M) -C* CONTAINS THE M EIGENVALUES IN ASCENDING -C* OR DESCENDING ORDER. -C* IND - INTEGER (M) -C* CONTAINS IN FIRST M POSITIONS THE SUBMATRIX INDICES -C* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- -C* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX -C* FROM THE TOP, 2 FOR THOSE BELONGING TO THE SECOND -C* SUBMATRIX, ETC. -C* IERR - INTEGER (LOGICAL UNIT NUMBER) -C* LOGICAL UNIT FOR ERROR MESSAGES -C* -C* ON EXIT - -C* ALL INPUT ARRAYS ARE UNALTERED. -C* Z - W.P. REAL (NM,M) -C* CONTAINS THE ASSOCIATED SET OF ORTHONORMAL -C* EIGENVECTORS. ANY VECTOR WHICH WHICH FAILS TO CONVERGE -C* IS LEFT AS IS (BUT NORMALIZED) WHEN ITERATING STOPPED. -C* IERR - INTEGER -C* SET TO -C* ZERO FOR NORMAL RETURN, -C* -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH -C* EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS. -C* (ONLY LAST FAILURE TO CONVERGE IS REPORTED) -C* -C* RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. -C* -C* RV1 - W.P. REAL (N) -C* DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION -C* RV2 - W.P. REAL (N) -C* SUPER(1)-DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION -C* RV3 - W.P. REAL (N) -C* SUPER(2)-DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION -C* RV4 - W.P. REAL (N) -C* ELEMENTS DEFINING L IN LU DECOMPOSITION -C* RV6 - W.P. REAL (N) -C* APPROXIMATE EIGENVECTOR -C* -C* DIFFERENCES FROM EISPACK 3 - -C* EPS3 IS SCALED BY EPSCAL (ENHANCES CONVERGENCE, BUT -C* LOWERS ACCURACY)! -C* ONE MORE ITERATION (MINIMUM 2) IS PERFORMED AFTER CONVERGENCE -C* (ENHANCES ACCURACY)! -C* REPLACE LOOP WITH PYTHAG WITH SINGLE CALL TO DNRM2! -C* IF NOT CONVERGED, USE PERFORMANCE INDEX TO DECIDE ON ERROR -C* VALUE SETTING, BUT DO NOT STOP! -C* L.U. FOR ERROR MESSAGES PASSED THROUGH IERR -C* USE PARAMETER STATEMENTS AND GENERIC INTRINSIC FUNCTIONS -C* USE LEVEL 1 BLAS -C* USE IF-THEN-ELSE TO CLARIFY LOGIC -C* LOOP OVER SUBSPACES MADE INTO DO LOOP. -C* LOOP OVER INVERSE ITERATIONS MADE INTO DO LOOP -C* ZERO ONLY REQUIRED PORTIONS OF OUTPUT VECTOR -C* -C* NOTE - -C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -C* -C - LOGICAL CONVGD,GOPARR,DSKWRK,MASWRK -C - INTEGER GROUP,I,IERR,ITS,J,JJ,M,N,NM,P,Q,R,S,SUBMAT,TAG - INTEGER IND(M) -C - DOUBLE PRECISION D(N),E(N),E2(N),W(M),Z(NM,M) - DOUBLE PRECISION RV1(N),RV2(N),RV3(N),RV4(N),RV6(N) - DOUBLE PRECISION ANORM,EPS2,EPS3,EPS4,NORM,ORDER,RHO,U,UK,V - DOUBLE PRECISION X0,X1,XU - DOUBLE PRECISION EPSCAL,GRPTOL,HUNDRD,ONE,TEN,ZERO - DOUBLE PRECISION EPSLON, ESTPI1, DASUM, DDOT, DNRM2 -C - COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK -C - PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00, GRPTOL = 0.001D+00) - PARAMETER (EPSCAL = 0.5D+00, HUNDRD = 100.0D+00, TEN = 10.0D+00) -C - 001 FORMAT(' EIGENVECTOR ROUTINE EINVIT DID NOT CONVERGE FOR VECTOR' - * ,I5,'. NORM =',1P,E10.2,' PERFORMANCE INDEX =',E10.2/ - * ' (AN ERROR HALT WILL OCCUR IF THE PI IS GREATER THAN 100)') -C -C----------------------------------------------------------------------- -C - LUEMSG = IERR - IERR = 0 - X0 = ZERO - UK = ZERO - NORM = ZERO - EPS2 = ZERO - EPS3 = ZERO - EPS4 = ZERO - GROUP = 0 - TAG = 0 - ORDER = ONE - E2(1) - Q = 0 - DO 930 SUBMAT = 1, N - P = Q + 1 -C -C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX .......... -C - DO 120 Q = P, N-1 - IF (E2(Q+1) .EQ. ZERO) GO TO 140 - 120 CONTINUE - Q = N -C -C .......... FIND VECTORS BY INVERSE ITERATION .......... -C - 140 CONTINUE - TAG = TAG + 1 - ANORM = ZERO - S = 0 -C - DO 920 R = 1, M - IF (IND(R) .NE. TAG) GO TO 920 - ITS = 1 - X1 = W(R) - IF (S .NE. 0) GO TO 510 -C -C .......... CHECK FOR ISOLATED ROOT .......... -C - XU = ONE - IF (P .EQ. Q) THEN - RV6(P) = ONE - CONVGD = .TRUE. - GO TO 860 -C - END IF - NORM = ABS(D(P)) - DO 500 I = P+1, Q - NORM = MAX( NORM, ABS(D(I)) + ABS(E(I)) ) - 500 CONTINUE -C -C .......... EPS2 IS THE CRITERION FOR GROUPING, -C EPS3 REPLACES ZERO PIVOTS AND EQUAL -C ROOTS ARE MODIFIED BY EPS3, -C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ......... -C - EPS2 = GRPTOL * NORM - EPS3 = EPSCAL * EPSLON(NORM) - UK = Q - P + 1 - EPS4 = UK * EPS3 - UK = EPS4 / SQRT(UK) - S = P - GROUP = 0 - GO TO 520 -C -C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... -C - 510 IF (ABS(X1-X0) .GE. EPS2) THEN -C -C ROOTS ARE SEPERATE -C - GROUP = 0 - ELSE -C -C ROOTS ARE CLOSE -C - GROUP = GROUP + 1 - IF (ORDER * (X1 - X0) .LE. EPS3) X1 = X0 + ORDER * EPS3 - END IF -C -C .......... ELIMINATION WITH INTERCHANGES AND -C INITIALIZATION OF VECTOR .......... -C - 520 CONTINUE -C - U = D(P) - X1 - V = E(P+1) - RV6(P) = UK - DO 550 I = P+1, Q - RV6(I) = UK - IF (ABS(E(I)) .GT. ABS(U)) THEN -C -C EXCHANGE ROWS BEFORE ELIMINATION -C -C *** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF -C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ....... -C - XU = U / E(I) - RV4(I) = XU - RV1(I-1) = E(I) - RV2(I-1) = D(I) - X1 - RV3(I-1) = E(I+1) - U = V - XU * RV2(I-1) - V = -XU * RV3(I-1) -C - ELSE -C -C STRAIGHT ELIMINATION -C - XU = E(I) / U - RV4(I) = XU - RV1(I-1) = U - RV2(I-1) = V - RV3(I-1) = ZERO - U = D(I) - X1 - XU * V - V = E(I+1) - END IF - 550 CONTINUE -C - IF (ABS(U) .LE. EPS3) U = EPS3 - RV1(Q) = U - RV2(Q) = ZERO - RV3(Q) = ZERO -C -C DO INVERSE ITERATIONS -C - CONVGD = .FALSE. - DO 800 ITS = 1, 5 - IF (ITS .EQ. 1) GO TO 600 -C -C .......... FORWARD SUBSTITUTION .......... -C - IF (NORM .EQ. ZERO) THEN - RV6(S) = EPS4 - S = S + 1 - IF (S .GT. Q) S = P - ELSE - XU = EPS4 / NORM - CALL DSCAL (Q-P+1, XU, RV6(P), 1) - END IF -C -C ... ELIMINATION OPERATIONS ON NEXT VECTOR -C - DO 590 I = P+1, Q - U = RV6(I) -C -C IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE -C WAS PERFORMED EARLIER IN THE -C TRIANGULARIZATION PROCESS .......... -C - IF (RV1(I-1) .EQ. E(I)) THEN - U = RV6(I-1) - RV6(I-1) = RV6(I) - ELSE - U = RV6(I) - END IF - RV6(I) = U - RV4(I) * RV6(I-1) - 590 CONTINUE - 600 CONTINUE -C -C .......... BACK SUBSTITUTION -C - RV6(Q) = RV6(Q) / RV1(Q) - V = U - U = RV6(Q) - NORM = ABS(U) - DO 620 I = Q-1, P, -1 - RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) - V = U - U = RV6(I) - NORM = NORM + ABS(U) - 620 CONTINUE - IF (GROUP .EQ. 0) GO TO 700 -C -C ....... ORTHOGONALIZE WITH RESPECT TO PREVIOUS -C MEMBERS OF GROUP .......... -C - J = R - DO 680 JJ = 1, GROUP - 630 J = J - 1 - IF (IND(J) .NE. TAG) GO TO 630 - CALL DAXPY(Q-P+1, -DDOT(Q-P+1,RV6(P),1,Z(P,J),1), - * Z(P,J),1,RV6(P),1) - 680 CONTINUE - NORM = DASUM(Q-P+1, RV6(P), 1) - 700 CONTINUE -C - IF (CONVGD) GO TO 840 - IF (NORM .GE. ONE) CONVGD = .TRUE. - 800 CONTINUE -C -C .......... NORMALIZE SO THAT SUM OF SQUARES IS -C 1 AND EXPAND TO FULL ORDER .......... -C - 840 CONTINUE -C - XU = ONE / DNRM2(Q-P+1,RV6(P),1) -C - 860 CONTINUE - DO 870 I = 1, P-1 - Z(I,R) = ZERO - 870 CONTINUE - DO 890 I = P,Q - Z(I,R) = RV6(I) * XU - 890 CONTINUE - DO 900 I = Q+1, N - Z(I,R) = ZERO - 900 CONTINUE -C - IF (.NOT.CONVGD) THEN - RHO = ESTPI1(Q-P+1,X1,D(P),E(P),Z(P,R),ANORM) - IF (RHO .GE. TEN .AND. LUEMSG .GT. 0 .AND. MASWRK) - * WRITE(LUEMSG,001) R,NORM,RHO -C -C *** SET ERROR -- NON-CONVERGED EIGENVECTOR .......... -C - IF (RHO .GT. HUNDRD) IERR = -R - END IF -C - X0 = X1 - 920 CONTINUE -C - IF (Q .EQ. N) GO TO 940 - 930 CONTINUE - 940 CONTINUE - RETURN - END -C*MODULE EIGEN *DECK ELAUM - SUBROUTINE ELAU(HINV,L,D,A,E) -C - DOUBLE PRECISION A(*) - DOUBLE PRECISION D(L) - DOUBLE PRECISION E(L) - DOUBLE PRECISION F - DOUBLE PRECISION G - DOUBLE PRECISION HALF - DOUBLE PRECISION HH - DOUBLE PRECISION HINV - DOUBLE PRECISION ZERO -C - PARAMETER (ZERO = 0.0D+00, HALF = 0.5D+00) -C - JL = L - E(1) = A(1) * D(1) - JK = 2 - DO 210 J = 2, JL - F = D(J) - G = ZERO - JM1 = J - 1 -C - DO 200 K = 1, JM1 - G = G + A(JK) * D(K) - E(K) = E(K) + A(JK) * F - JK = JK + 1 - 200 CONTINUE -C - E(J) = G + A(JK) * F - JK = JK + 1 - 210 CONTINUE -C -C .......... FORM P .......... -C - F = ZERO - DO 245 J = 1, L - E(J) = E(J) * HINV - F = F + E(J) * D(J) - 245 CONTINUE -C -C .......... FORM Q .......... -C - HH = F * HALF * HINV - DO 250 J = 1, L - 250 E(J) = E(J) - HH * D(J) -C - RETURN - END -C*MODULE EIGEN *DECK EPSLON - DOUBLE PRECISION FUNCTION EPSLON (X) -C* -C* AUTHORS - -C* THIS ROUTINE WAS TAKEN FROM EISPACK EDITION 3 DATED 4/6/83 -C* THIS VERSION IS BY S. T. ELBERT, AMES LABORATORY-USDOE NOV 1986 -C* -C* PURPOSE - -C* ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. -C* -C* ON ENTRY - -C* X - WORKING PRECISION REAL -C* VALUES TO FIND EPSLON FOR -C* -C* ON EXIT - -C* EPSLON - WORKING PRECISION REAL -C* SMALLEST POSITIVE VALUE SUCH THAT X+EPSLON .NE. ZERO -C* -C* QUALIFICATIONS - -C* THIS ROUTINE SHOULD PERFORM PROPERLY ON ALL SYSTEMS -C* SATISFYING THE FOLLOWING TWO ASSUMPTIONS, -C* 1. THE BASE USED IN REPRESENTING FLOATING POINT -C* NUMBERS IS NOT A POWER OF THREE. -C* 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO -C* THE ACCURACY USED IN FLOATING POINT VARIABLES -C* THAT ARE STORED IN MEMORY. -C* THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO -C* FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING -C* ASSUMPTION 2. -C* UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, -C* A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, -C* B HAS A ZERO FOR ITS LAST BIT OR DIGIT, -C* C IS NOT EXACTLY EQUAL TO ONE, -C* EPS MEASURES THE SEPARATION OF 1.0 FROM -C* THE NEXT LARGER FLOATING POINT NUMBER. -C* THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED -C* ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD. -C* -C* DIFFERENCES FROM EISPACK 3 - -C* USE IS MADE OF PARAMETER STATEMENTS AND INTRINSIC FUNCTIONS -C* --NO EXECUTEABLE CODE CHANGES-- -C* -C* NOTE - -C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -C - DOUBLE PRECISION A,B,C,EPS,X - DOUBLE PRECISION ZERO, ONE, THREE, FOUR -C - PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, THREE=3.0D+00, FOUR=4.0D+00) -C -C----------------------------------------------------------------------- -C - A = FOUR/THREE - 10 B = A - ONE - C = B + B + B - EPS = ABS(C - ONE) - IF (EPS .EQ. ZERO) GO TO 10 - EPSLON = EPS*ABS(X) - RETURN - END -C*MODULE EIGEN *DECK EQLRAT - SUBROUTINE EQLRAT(N,DIAG,E,E2IN,D,IND,IERR,E2) -C* -C* AUTHORS - -C* THIS IS A MODIFICATION OF ROUTINE EQLRAT FROM EISPACK EDITION 3 -C* DATED AUGUST 1983. -C* TQLRAT IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, -C* ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. -C* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) -C* -C* PURPOSE - -C* THIS ROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC -C* TRIDIAGONAL MATRIX -C* -C* METHOD - -C* RATIONAL QL -C* -C* ON ENTRY - -C* N - INTEGER -C* THE ORDER OF THE MATRIX. -C* D - W.P. REAL (N) -C* CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. -C* E2 - W.P. REAL (N) -C* CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF -C* THE INPUT MATRIX IN ITS LAST N-1 POSITIONS. -C* E2(1) IS ARBITRARY. -C* -C* ON EXIT - -C* D - W.P. REAL (N) -C* CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN -C* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND -C* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE -C* THE SMALLEST EIGENVALUES. -C* E2 - W.P. REAL (N) -C* DESTROYED. -C* IERR - INTEGER -C* SET TO -C* ZERO FOR NORMAL RETURN, -C* J IF THE J-TH EIGENVALUE HAS NOT BEEN -C* DETERMINED AFTER 30 ITERATIONS. -C* -C* DIFFERENCES FROM EISPACK 3 - -C* G=G+B INSTEAD OF IF(G.EQ.0) G=B ; B=B/4 -C* F77 BACKWARD LOOPS INSTEAD OF F66 CONSTRUCT -C* GENERIC INTRINSIC FUNCTIONS -C* ARRARY IND ADDED FOR USE BY EINVIT -C* -C* NOTE - -C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -C - INTEGER I,J,L,M,N,II,L1,IERR - INTEGER IND(N) -C - DOUBLE PRECISION D(N),E(N),E2(N),DIAG(N),E2IN(N) - DOUBLE PRECISION B,C,F,G,H,P,R,S,T,EPSLON - DOUBLE PRECISION SCALE,ZERO,ONE -C - PARAMETER (ZERO = 0.0D+00, SCALE= 1.0D+00/64.0D+00, ONE = 1.0D+00) -C -C----------------------------------------------------------------------- - IERR = 0 - D(1)=DIAG(1) - IND(1) = 1 - K = 0 - ITAG = 0 - IF (N .EQ. 1) GO TO 1001 -C - DO 100 I = 2, N - D(I)=DIAG(I) - 100 E2(I-1) = E2IN(I) -C - F = ZERO - T = ZERO - B = EPSLON(ONE) - C = B *B - B = B * SCALE - E2(N) = ZERO -C - DO 290 L = 1, N - H = ABS(D(L)) + ABS(E(L)) - IF (T .GE. H) GO TO 105 - T = H - B = EPSLON(T) - C = B * B - B = B * SCALE - 105 CONTINUE -C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... - M = L - 1 - 110 M = M + 1 - IF (E2(M) .GT. C) GO TO 110 -C .......... E2(N) IS ALWAYS ZERO, SO THERE IS AN EXIT -C FROM THE LOOP .......... -C - IF (M .LE. K) GO TO 125 - IF (M .NE. N) E2IN(M+1) = ZERO - K = M - ITAG = ITAG + 1 - 125 CONTINUE - IF (M .EQ. L) GO TO 210 -C -C ITERATE -C - DO 205 J = 1, 30 -C .......... FORM SHIFT .......... - L1 = L + 1 - S = SQRT(E2(L)) - G = D(L) - P = (D(L1) - G) / (2.0D+00 * S) - R = SQRT(P*P+1.0D+00) - D(L) = S / (P + SIGN(R,P)) - H = G - D(L) -C - DO 140 I = L1, N - 140 D(I) = D(I) - H -C - F = F + H -C .......... RATIONAL QL TRANSFORMATION .......... - G = D(M) + B - H = G - S = ZERO - DO 200 I = M-1,L,-1 - P = G * H - R = P + E2(I) - E2(I+1) = S * R - S = E2(I) / R - D(I+1) = H + S * (H + D(I)) - G = D(I) - E2(I) / G + B - H = G * P / R - 200 CONTINUE -C - E2(L) = S * G - D(L) = H -C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST - IF (H .EQ. ZERO) GO TO 210 - IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210 - E2(L) = H * E2(L) - IF (E2(L) .EQ. ZERO) GO TO 210 - 205 CONTINUE -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS .......... - IERR = L - GO TO 1001 -C -C CONVERGED -C - 210 P = D(L) + F -C .......... ORDER EIGENVALUES .......... - I = 1 - IF (L .EQ. 1) GO TO 250 - IF (P .LT. D(1)) GO TO 230 - I = L -C .......... LOOP TO FIND ORDERED POSITION - 220 I = I - 1 - IF (P .LT. D(I)) GO TO 220 -C - I = I + 1 - IF (I .EQ. L) GO TO 250 - 230 CONTINUE - DO 240 II = L, I+1, -1 - D(II) = D(II-1) - IND(II) = IND(II-1) - 240 CONTINUE -C - 250 CONTINUE - D(I) = P - IND(I) = ITAG - 290 CONTINUE -C - 1001 RETURN - END -C*MODULE EIGEN *DECK ESTPI1 - DOUBLE PRECISION FUNCTION ESTPI1 (N,EVAL,D,E,X,ANORM) -C* -C* AUTHOR - -C* STEPHEN T. ELBERT (AMES LABORATORY-USDOE) DATE: 5 DEC 1986 -C* -C* PURPOSE - -C* EVALUATE SYMMETRIC TRIDIAGONAL MATRIX PERFORMANCE INDEX -C* * * * * * -C* FOR 1 EIGENVECTOR -C* * -C* -C* METHOD - -C* THIS ROUTINE FORMS THE 1-NORM OF THE RESIDUAL MATRIX A*X-X*EVAL -C* WHERE A IS A SYMMETRIC TRIDIAGONAL MATRIX STORED -C* IN THE DIAGONAL (D) AND SUB-DIAGONAL (E) VECTORS, EVAL IS THE -C* EIGENVALUE OF AN EIGENVECTOR OF A, NAMELY X. -C* THIS NORM IS SCALED BY MACHINE ACCURACY FOR THE PROBLEM SIZE. -C* ALL NORMS APPEARING IN THE COMMENTS BELOW ARE 1-NORMS. -C* -C* ON ENTRY - -C* N - INTEGER -C* THE ORDER OF THE MATRIX A. -C* EVAL - W.P. REAL -C* THE EIGENVALUE CORRESPONDING TO VECTOR X. -C* D - W.P. REAL (N) -C* THE DIAGONAL VECTOR OF A. -C* E - W.P. REAL (N) -C* THE SUB-DIAGONAL VECTOR OF A. -C* X - W.P. REAL (N) -C* AN EIGENVECTOR OF A. -C* ANORM - W.P. REAL -C* THE NORM OF A IF IT HAS BEEN PREVIOUSLY COMPUTED. -C* -C* ON EXIT - -C* ANORM - W.P. REAL -C* THE NORM OF A, COMPUTED IF INITIALLY ZERO. -C* ESTPI1 - W.P. REAL -C* !!A*X-X*EVAL!! / (EPSLON(10*N)*!!A!!*!!X!!); -C* WHERE EPSLON(X) IS THE SMALLEST NUMBER SUCH THAT -C* X + EPSLON(X) .NE. X -C* -C* ESTPI1 .LT. 1 == SATISFACTORY PERFORMANCE -C* .GE. 1 AND .LE. 100 == MARGINAL PERFORMANCE -C* .GT. 100 == POOR PERFORMANCE -C* (SEE LECT. NOTES IN COMP. SCI. VOL.6 PP 124-125) -C - DOUBLE PRECISION ANORM,EVAL,RNORM,SIZE,XNORM - DOUBLE PRECISION D(N), E(N), X(N) - DOUBLE PRECISION EPSLON, ONE, ZERO -C - PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00) -C -C----------------------------------------------------------------------- -C - ESTPI1 = ZERO - IF( N .LE. 1 ) RETURN - SIZE = 10 * N - IF (ANORM .EQ. ZERO) THEN -C -C COMPUTE NORM OF A -C - ANORM = MAX( ABS(D(1)) + ABS(E(2)) - * ,ABS(D(N)) + ABS(E(N))) - DO 110 I = 2, N-1 - ANORM = MAX( ANORM, ABS(E(I))+ABS(D(I))+ABS(E(I+1))) - 110 CONTINUE - IF(ANORM .EQ. ZERO) ANORM = ONE - END IF -C -C COMPUTE NORMS OF RESIDUAL AND EIGENVECTOR -C - XNORM = ABS(X(1)) + ABS(X(N)) - RNORM = ABS( (D(1)-EVAL)*X(1) + E(2)*X(2)) - * +ABS( (D(N)-EVAL)*X(N) + E(N)*X(N-1)) - DO 120 I = 2, N-1 - XNORM = XNORM + ABS(X(I)) - RNORM = RNORM + ABS(E(I)*X(I-1) + (D(I)-EVAL)*X(I) - * + E(I+1)*X(I+1)) - 120 CONTINUE -C - ESTPI1 = RNORM / (EPSLON(SIZE)*ANORM*XNORM) - RETURN - END -C*MODULE EIGEN *DECK ETRBK3 - SUBROUTINE ETRBK3(NM,N,NV,A,M,Z) -C* -C* AUTHORS- -C* THIS IS A MODIFICATION OF ROUTINE TRBAK3 FROM EISPACK EDITION 3 -C* DATED AUGUST 1983. -C* EISPACK TRBAK3 IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, -C* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -C* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) -C* -C* PURPOSE - -C* THIS ROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC -C* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING -C* SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY ETRED3. -C* -C* METHOD - -C* THE CALCULATION IS CARRIED OUT BY FORMING THE MATRIX PRODUCT -C* Q*Z -C* WHERE Q IS A PRODUCT OF THE ORTHOGONAL SYMMETRIC MATRICES -C* Q = PROD(I)[1 - U(I)*.TRANSPOSE.U(I)*H(I)] -C* U IS THE AUGMENTED SUB-DIAGONAL ROWS OF A AND -C* Z IS THE SET OF EIGENVECTORS OF THE TRIDIAGONAL -C* MATRIX F WHICH WAS FORMED FROM THE ORIGINAL SYMMETRIC -C* MATRIX C BY THE SIMILARITY TRANSFORMATION -C* F = Q(TRANSPOSE) C Q -C* NOTE THAT ETRBK3 PRESERVES VECTOR EUCLIDEAN NORMS. -C* -C* -C* COMPLEXITY - -C* M*N**2 -C* -C* ON ENTRY- -C* NM - INTEGER -C* MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C* ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -C* DIMENSION STATEMENT. -C* N - INTEGER -C* THE ORDER OF THE MATRIX A. -C* NV - INTEGER -C* MUST BE SET TO THE DIMENSION OF THE ARRAY A AS -C* DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT. -C* A - W.P. REAL (NV) -C* CONTAINS INFORMATION ABOUT THE ORTHOGONAL -C* TRANSFORMATIONS USED IN THE REDUCTION BY ETRED3 IN -C* ITS FIRST NV = N*(N+1)/2 POSITIONS. -C* M - INTEGER -C* THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. -C* Z - W.P REAL (NM,M) -C* CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED -C* IN ITS FIRST M COLUMNS. -C* -C* ON EXIT- -C* Z - W.P. REAL (NM,M) -C* CONTAINS THE TRANSFORMED EIGENVECTORS -C* IN ITS FIRST M COLUMNS. -C* -C* DIFFERENCES WITH EISPACK 3 - -C* THE TWO INNER LOOPS ARE REPLACED BY DDOT AND DAXPY. -C* MULTIPLICATION USED INSTEAD OF DIVISION TO FIND S. -C* OUTER LOOP RANGE CHANGED FROM 2,N TO 3,N. -C* ADDRESS POINTERS FOR A SIMPLIFIED. -C* -C* NOTE - -C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -C - INTEGER I,II,IM1,IZ,J,M,N,NM,NV -C - DOUBLE PRECISION A(NV),Z(NM,M) - DOUBLE PRECISION H,S,DDOT,ZERO -C - PARAMETER (ZERO = 0.0D+00) -C -C----------------------------------------------------------------------- -C - IF (M .EQ. 0) RETURN - IF (N .LE. 2) RETURN -C - II=3 - DO 140 I = 3, N - IZ=II+1 - II=II+I - H = A(II) - IF (H .EQ. ZERO) GO TO 140 - IM1 = I - 1 - DO 130 J = 1, M - S = -( DDOT(IM1,A(IZ),1,Z(1,J),1) * H) * H - CALL DAXPY(IM1,S,A(IZ),1,Z(1,J),1) - 130 CONTINUE - 140 CONTINUE - RETURN - END -C*MODULE EIGEN *DECK ETRED3 - SUBROUTINE ETRED3(N,NV,A,D,E,E2) -C* -C* AUTHORS - -C* THIS IS A MODIFICATION OF ROUTINE TRED3 FROM EISPACK EDITION 3 -C* DATED AUGUST 1983. -C* EISPACK TRED3 IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, -C* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -C* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C* THIS VERSION IS BY S. T. ELBERT, AMES LABORATORY-USDOE JUN 1986 -C* -C* PURPOSE - -C* THIS ROUTINE REDUCES A REAL SYMMETRIC (PACKED) MATRIX, STORED -C* AS A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX -C* USING ORTHOGONAL SIMILARITY TRANSFORMATIONS, PRESERVING THE -C* INFORMATION ABOUT THE TRANSFORMATIONS IN A. -C* -C* METHOD - -C* THE TRIDIAGONAL REDUCTION IS PERFORMED IN THE FOLLOWING WAY. -C* STARTING WITH J=N, THE ELEMENTS IN THE J-TH ROW TO THE -C* LEFT OF THE DIAGONAL ARE FIRST SCALED, TO AVOID POSSIBLE -C* UNDERFLOW IN THE TRANSFORMATION THAT MIGHT RESULT IN SEVERE -C* DEPARTURE FROM ORTHOGONALITY. THE SUM OF SQUARES SIGMA OF -C* THESE SCALED ELEMENTS IS NEXT FORMED. THEN, A VECTOR U AND -C* A SCALAR -C* H = U(TRANSPOSE) * U / 2 -C* DEFINE A REFLECTION OPERATOR -C* P = I - U * U(TRANSPOSE) / H -C* WHICH IS ORTHOGONAL AND SYMMETRIC AND FOR WHICH THE -C* SIMILIARITY TRANSFORMATION PAP ELIMINATES THE ELEMENTS IN -C* THE J-TH ROW OF A TO THE LEFT OF THE SUBDIAGONAL AND THE -C* SYMMETRICAL ELEMENTS IN THE J-TH COLUMN. -C* -C* THE NON-ZERO COMPONENTS OF U ARE THE ELEMENTS OF THE J-TH -C* ROW TO THE LEFT OF THE DIAGONAL WITH THE LAST OF THEM -C* AUGMENTED BY THE SQUARE ROOT OF SIGMA PREFIXED BY THE SIGN -C* OF THE SUBDIAGONAL ELEMENT. BY STORING THE TRANSFORMED SUB- -C* DIAGONAL ELEMENT IN E(J) AND NOT OVERWRITING THE ROW -C* ELEMENTS ELIMINATED IN THE TRANSFORMATION, FULL INFORMATION -C* ABOUT P IS SAVE FOR LATER USE IN ETRBK3. -C* -C* THE TRANSFORMATION SETS E2(J) EQUAL TO SIGMA AND E(J) -C* EQUAL TO THE SQUARE ROOT OF SIGMA PREFIXED BY THE SIGN -C* OF THE REPLACED SUBDIAGONAL ELEMENT. -C* -C* THE ABOVE STEPS ARE REPEATED ON FURTHER ROWS OF THE -C* TRANSFORMED A IN REVERSE ORDER UNTIL A IS REDUCED TO TRI- -C* DIAGONAL FORM, THAT IS, REPEATED FOR J = N-1,N-2,...,3. -C* -C* COMPLEXITY - -C* 2/3 N**3 -C* -C* ON ENTRY- -C* N - INTEGER -C* THE ORDER OF THE MATRIX. -C* NV - INTEGER -C* MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A -C* AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT -C* A - W.P. REAL (NV) -C* CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC -C* INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL -C* ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. -C* -C* ON EXIT- -C* A - W.P. REAL (NV) -C* CONTAINS INFORMATION ABOUT THE ORTHOGONAL -C* TRANSFORMATIONS USED IN THE REDUCTION. -C* D - W.P. REAL (N) -C* CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL -C* MATRIX. -C* E - W.P. REAL (N) -C* CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL -C* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO -C* E2 - W.P. REAL (N) -C* CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF -C* E. MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. -C* -C* DIFFERENCES FROM EISPACK 3 - -C* OUTER LOOP CHANGED FROM II=1,N TO I=N,3,-1 -C* PARAMETER STATEMENT AND GENERIC INTRINSIC FUNCTIONS USED -C* SCALE.NE.0 TEST NOW SPOTS TRI-DIAGONAL FORM -C* VALUES LESS THAN EPSLON CLEARED TO ZERO -C* USE BLAS(1) -C* U NOT COPIED TO D, LEFT IN A -C* E2 COMPUTED FROM E -C* INNER LOOPS SPLIT INTO ROUTINES ELAU AND FREDA -C* INVERSE OF H STORED INSTEAD OF H -C* -C* NOTE - -C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO -C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. -C - INTEGER I,IIA,IZ0,L,N,NV -C - DOUBLE PRECISION A(NV),D(N),E(N),E2(N) - DOUBLE PRECISION AIIMAX,F,G,H,HROOT,SCALE,SCALEI - DOUBLE PRECISION DASUM, DNRM2 - DOUBLE PRECISION ONE, ZERO -C - PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00) -C -C----------------------------------------------------------------------- -C - IF (N .LE. 2) GO TO 310 - IZ0 = (N*N+N)/2 - AIIMAX = ABS(A(IZ0)) - DO 300 I = N, 3, -1 - L = I - 1 - IIA = IZ0 - IZ0 = IZ0 - I - AIIMAX = MAX(AIIMAX, ABS(A(IIA))) - SCALE = DASUM (L, A(IZ0+1), 1) - IF(SCALE .EQ. ABS(A(IIA-1)) .OR. AIIMAX+SCALE .EQ. AIIMAX) THEN -C -C THIS ROW IS ALREADY IN TRI-DIAGONAL FORM -C - D(I) = A(IIA) - IF (AIIMAX+D(I) .EQ. AIIMAX) D(I) = ZERO - E(I) = A(IIA-1) - IF (AIIMAX+E(I) .EQ. AIIMAX) E(I) = ZERO - E2(I) = E(I)*E(I) - A(IIA) = ZERO - GO TO 300 -C - END IF -C - SCALEI = ONE / SCALE - CALL DSCAL(L,SCALEI,A(IZ0+1),1) - HROOT = DNRM2(L,A(IZ0+1),1) -C - F = A(IZ0+L) - G = -SIGN(HROOT,F) - E(I) = SCALE * G - E2(I) = E(I)*E(I) - H = HROOT*HROOT - F * G - A(IZ0+L) = F - G - D(I) = A(IIA) - A(IIA) = ONE / SQRT(H) -C .......... FORM P THEN Q IN E(1:L) .......... - CALL ELAU(ONE/H,L,A(IZ0+1),A,E) -C .......... FORM REDUCED A .......... - CALL FREDA(L,A(IZ0+1),A,E) -C - 300 CONTINUE - 310 CONTINUE - E(1) = ZERO - E2(1)= ZERO - D(1) = A(1) - IF(N.EQ.1) RETURN -C - E(2) = A(2) - E2(2)= A(2)*A(2) - D(2) = A(3) - RETURN - END -C*MODULE EIGEN *DECK EVVRSP - SUBROUTINE EVVRSP(MSGFL,N,NVECT,LENA,NV,A,B,IND,ROOT, - * VECT,IORDER,IERR) -C* -C* AUTHOR: S. T. ELBERT, AMES LABORATORY-USDOE, JUNE 1985 -C* -C* PURPOSE - -C* FINDS (ALL) EIGENVALUES AND (SOME OR ALL) EIGENVECTORS -C* * * * -C* OF A REAL SYMMETRIC PACKED MATRIX. -C* * * * -C* -C* METHOD - -C* THE METHOD AS PRESENTED IN THIS ROUTINE CONSISTS OF FOUR STEPS: -C* FIRST, THE INPUT MATRIX IS REDUCED TO TRIDIAGONAL FORM BY THE -C* HOUSEHOLDER TECHNIQUE (ORTHOGONAL SIMILARITY TRANSFORMATIONS). -C* SECOND, THE ROOTS ARE LOCATED USING THE RATIONAL QL METHOD. -C* THIRD, THE VECTORS OF THE TRIDIAGONAL FORM ARE EVALUATED BY THE -C* INVERSE ITERATION TECHNIQUE. VECTORS FOR DEGENERATE OR NEAR- -C* DEGENERATE ROOTS ARE FORCED TO BE ORTHOGONAL. -C* FOURTH, THE TRIDIAGONAL VECTORS ARE ROTATED TO VECTORS OF THE -C* ORIGINAL ARRAY. -C* -C* THESE ROUTINES ARE MODIFICATIONS OF THE EISPACK 3 -C* ROUTINES TRED3, TQLRAT, TINVIT AND TRBAK3 -C* -C* FOR FURTHER DETAILS, SEE EISPACK USERS GUIDE, B. T. SMITH -C* ET AL, SPRINGER-VERLAG, LECTURE NOTES IN COMPUTER SCIENCE, -C* VOL. 6, 2-ND EDITION, 1976. ANOTHER GOOD REFERENCE IS -C* THE SYMMETRIC EIGENVALUE PROBLEM BY B. N. PARLETT -C* PUBLISHED BY PRENTICE-HALL, INC., ENGLEWOOD CLIFFS, N.J. (1980) -C* -C* ON ENTRY - -C* MSGFL - INTEGER (LOGICAL UNIT NO.) -C* FILE WHERE ERROR MESSAGES WILL BE PRINTED. -C* IF MSGFL IS 0, ERROR MESSAGES WILL BE PRINTED ON LU 6. -C* IF MSGFL IS NEGATIVE, NO ERROR MESSAGES PRINTED. -C* N - INTEGER -C* ORDER OF MATRIX A. -C* NVECT - INTEGER -C* NUMBER OF VECTORS DESIRED. 0 .LE. NVECT .LE. N. -C* LENA - INTEGER -C* DIMENSION OF A IN CALLING ROUTINE. MUST NOT BE LESS -C* THAN (N*N+N)/2. -C* NV - INTEGER -C* ROW DIMENSION OF VECT IN CALLING ROUTINE. N .LE. NV. -C* A - WORKING PRECISION REAL (LENA) -C* INPUT MATRIX, ROWS OF THE LOWER TRIANGLE PACKED INTO -C* LINEAR ARRAY OF DIMENSION N*(N+1)/2. THE PACKED ORDER -C* IS A(1,1), A(2,1), A(2,2), A(3,1), A(3,2), ... -C* B - WORKING PRECISION REAL (N,8) -C* SCRATCH ARRAY, 8*N ELEMENTS -C* IND - INTEGER (N) -C* SCRATCH ARRAY OF LENGTH N. -C* IORDER - INTEGER -C* ROOT ORDERING FLAG. -C* = 0, ROOTS WILL BE PUT IN ASCENDING ORDER. -C* = 2, ROOTS WILL BE PUT IN DESCENDING ORDER. -C* -C* ON EXIT - -C* A - DESTORYED. NOW HOLDS REFLECTION OPERATORS. -C* ROOT - WORKING PRECISION REAL (N) -C* ALL EIGENVALUES IN ASCENDING OR DESCENDING ORDER. -C* IF IORDER = 0, ROOT(1) .LE. ... .LE. ROOT(N) -C* IF IORDER = 2, ROOT(1) .GE. ... .GE. ROOT(N) -C* VECT - WORKING PRECISION REAL (NV,NVECT) -C* EIGENVECTORS FOR ROOT(1), ..., ROOT(NVECT). -C* IERR - INTEGER -C* = 0 IF NO ERROR DETECTED, -C* = K IF ITERATION FOR K-TH EIGENVALUE FAILED, -C* = -K IF ITERATION FOR K-TH EIGENVECTOR FAILED. -C* (FAILURES SHOULD BE VERY RARE. CONTACT C. MOLER.) -C* -C - LOGICAL GOPARR,DSKWRK,MASWRK -C - DOUBLE PRECISION A(LENA) - DOUBLE PRECISION B(N,8) - DOUBLE PRECISION ROOT(N) - DOUBLE PRECISION T - DOUBLE PRECISION VECT(NV,*) -C - INTEGER IND(N) -C - COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK -C - 900 FORMAT(26H0*** EVVRSP PARAMETERS ***/ - + 14H *** N = ,I8,4H ***/ - + 14H *** NVECT = ,I8,4H ***/ - + 14H *** LENA = ,I8,4H ***/ - + 14H *** NV = ,I8,4H ***/ - + 14H *** IORDER = ,I8,4H ***/ - + 14H *** IERR = ,I8,4H ***) - 901 FORMAT(37H VALUE OF LENA IS LESS THAN (N*N+N)/2) - 902 FORMAT(39H EQLRAT HAS FAILED TO CONVERGE FOR ROOT,I5) - 903 FORMAT(18H NV IS LESS THAN N) - 904 FORMAT(41H EINVIT HAS FAILED TO CONVERGE FOR VECTOR,I5) - 905 FORMAT(51H VALUE OF IORDER MUST BE 0 (SMALLEST ROOT FIRST) OR - * ,23H 2 (LARGEST ROOT FIRST)) - 906 FORMAT(' VALUE OF N IS LESS THAN OR EQUAL ZERO') -C -C----------------------------------------------------------------------- -C - LMSGFL=MSGFL - IF (MSGFL .EQ. 0) LMSGFL=6 - IERR = N - 1 - IF (N .LE. 0) GO TO 800 - IERR = N + 1 - IF ( (N*N+N)/2 .GT. LENA) GO TO 810 -C -C REDUCE REAL SYMMETRIC MATRIX A TO TRIDIAGONAL FORM -C - CALL ETRED3(N,LENA,A,B(1,1),B(1,2),B(1,3)) -C -C FIND ALL EIGENVALUES OF TRIDIAGONAL MATRIX -C - CALL EQLRAT(N,B(1,1),B(1,2),B(1,3),ROOT,IND,IERR,B(1,4)) - IF (IERR .NE. 0) GO TO 820 -C -C CHECK THE DESIRED ORDER OF THE EIGENVALUES -C - B(1,3) = IORDER - IF (IORDER .EQ. 0) GO TO 300 - IF (IORDER .NE. 2) GO TO 850 -C -C ORDER ROOTS IN DESCENDING ORDER (LARGEST FIRST)... -C TURN ROOT AND IND ARRAYS END FOR END -C - DO 210 I = 1, N/2 - J = N+1-I - T = ROOT(I) - ROOT(I) = ROOT(J) - ROOT(J) = T - L = IND(I) - IND(I) = IND(J) - IND(J) = L - 210 CONTINUE -C -C FIND I AND J MARKING THE START AND END OF A SEQUENCE -C OF DEGENERATE ROOTS -C - I=0 - 220 CONTINUE - I = I+1 - IF (I .GT. N) GO TO 300 - DO 230 J=I,N - IF (ROOT(J) .NE. ROOT(I)) GO TO 240 - 230 CONTINUE - J = N+1 - 240 CONTINUE - J = J-1 - IF (J .EQ. I) GO TO 220 -C -C TURN AROUND IND BETWEEN I AND J -C - JSV = J - KLIM = (J-I+1)/2 - DO 250 K=1,KLIM - L = IND(J) - IND(J) = IND(I) - IND(I) = L - I = I+1 - J = J-1 - 250 CONTINUE - I = JSV - GO TO 220 -C - 300 CONTINUE -C - IF (NVECT .LE. 0) RETURN - IF (NV .LT. N) GO TO 830 -C -C FIND EIGENVECTORS OF TRI-DIAGONAL MATRIX VIA INVERSE ITERATION -C - IERR = LMSGFL - CALL EINVIT(NV,N,B(1,1),B(1,2),B(1,3),NVECT,ROOT,IND, - + VECT,IERR,B(1,4),B(1,5),B(1,6),B(1,7),B(1,8)) - IF (IERR .NE. 0) GO TO 840 -C -C FIND EIGENVECTORS OF SYMMETRIC MATRIX VIA BACK TRANSFORMATION -C - 400 CONTINUE - CALL ETRBK3(NV,N,LENA,A,NVECT,VECT) - RETURN -C -C ERROR MESSAGE SECTION -C - 800 IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,906) - GO TO 890 -C - 810 IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,901) - GO TO 890 -C - 820 IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,902) IERR - GO TO 890 -C - 830 IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,903) - GO TO 890 -C - 840 CONTINUE - IF ((LMSGFL .GT. 0).AND.MASWRK) WRITE(LMSGFL,904) -IERR - GO TO 400 -C - 850 IERR=-1 - IF (LMSGFL .LT. 0) RETURN - IF (MASWRK) WRITE(LMSGFL,905) - GO TO 890 -C - 890 CONTINUE - IF (MASWRK) WRITE(LMSGFL,900) N,NVECT,LENA,NV,IORDER,IERR - RETURN - END -C*MODULE EIGEN *DECK FREDA - SUBROUTINE FREDA(L,D,A,E) -C - DOUBLE PRECISION A(*) - DOUBLE PRECISION D(L) - DOUBLE PRECISION E(L) - DOUBLE PRECISION F - DOUBLE PRECISION G -C - JK = 1 -C -C .......... FORM REDUCED A .......... -C - DO 280 J = 1, L - F = D(J) - G = E(J) -C - DO 260 K = 1, J - A(JK) = A(JK) - F * E(K) - G * D(K) - JK = JK + 1 - 260 CONTINUE -C - 280 CONTINUE - RETURN - END -C*MODULE EIGEN *DECK GIVEIS - SUBROUTINE GIVEIS(N,NVECT,NV,A,B,INDB,ROOT,VECT,IERR) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION A(*),B(N,8),INDB(N),ROOT(N),VECT(NV,NVECT) -C -C EISPACK-BASED SUBSTITUTE FOR QCPE ROUTINE GIVENS. -C FINDS ALL EIGENVALUES AND SOME EIGENVECTORS OF A REAL SYMMETRIC -C MATRIX. AUTHOR.. C. MOLER AND D. SPANGLER, N.R.C.C., 4/1/79. -C -C INPUT.. -C N = ORDER OF MATRIX . -C NVECT = NUMBER OF VECTORS DESIRED. 0 .LE. NVECT .LE. N . -C NV = LEADING DIMENSION OF VECT . -C A = INPUT MATRIX, COLUMNS OF THE UPPER TRIANGLE PACKED INTO -C LINEAR ARRAY OF DIMENSION N*(N+1)/2 . -C B = SCRATCH ARRAY, 8*N ELEMENTS (NOTE THIS IS MORE THAN -C PREVIOUS VERSIONS OF GIVENS.) -C IND = INDEX ARRAY OF N ELEMENTS -C -C OUTPUT.. -C A DESTROYED . -C ROOT = ALL EIGENVALUES, ROOT(1) .LE. ... .LE. ROOT(N) . -C (FOR OTHER ORDERINGS, SEE BELOW.) -C VECT = EIGENVECTORS FOR ROOT(1),..., ROOT(NVECT) . -C IERR = 0 IF NO ERROR DETECTED, -C = K IF ITERATION FOR K-TH EIGENVALUE FAILED, -C = -K IF ITERATION FOR K-TH EIGENVECTOR FAILED. -C (FAILURES SHOULD BE VERY RARE. CONTACT MOLER.) -C -C CALLS MODIFIED EISPACK ROUTINES TRED3B, IMTQLV, TINVTB, AND -C TRBK3B. THE ROUTINES TRED3B, TINVTB, AND TRBK3B. -C THE ORIGINAL EISPACK ROUTINES TRED3, TINVIT, AND TRBAK3 -C WERE MODIFIED BY THE INTRODUCTION OF TWO ROUTINES FROM THE -C BLAS LIBRARY - DDOT AND DAXPY. -C -C IF TINVIT FAILS TO CONVERGE, TQL2 IS CALLED -C -C SEE EISPACK USERS GUIDE, B. T. SMITH ET AL, SPRINGER-VERLAG -C LECTURE NOTES IN COMPUTER SCIENCE, VOL. 6, 2-ND EDITION, 1976 . -C NOTE THAT IMTQLV AND TINVTB HAVE INTERNAL MACHINE -C DEPENDENT CONSTANTS. -C - DATA ONE, ZERO /1.0D+00, 0.0D+00/ - CALL TRED3B(N,(N*N+N)/2,A,B(1,1),B(1,2),B(1,3)) - CALL IMTQLV(N,B(1,1),B(1,2),B(1,3),ROOT,INDB,IERR,B(1,4)) - IF (IERR .NE. 0) RETURN -C -C TO REORDER ROOTS... -C K = N/2 -C B(1,3) = 2.0D+00 -C DO 50 I = 1, K -C J = N+1-I -C T = ROOT(I) -C ROOT(I) = ROOT(J) -C ROOT(J) = T -C 50 CONTINUE -C - IF (NVECT .LE. 0) RETURN - CALL TINVTB(NV,N,B(1,1),B(1,2),B(1,3),NVECT,ROOT,INDB,VECT,IERR, - + B(1,4),B(1,5),B(1,6),B(1,7),B(1,8)) - IF (IERR .EQ. 0) GO TO 160 -C -C IF INVERSE ITERATION GIVES AN ERROR IN DETERMINING THE -C EIGENVECTORS, TRY THE QL ALGORITHM IF ALL THE EIGENVECTORS -C ARE DESIRED. -C - IF (NVECT .NE. N) RETURN - DO 120 I = 1, NVECT - DO 100 J = 1, N - VECT(I,J) = ZERO - 100 CONTINUE - VECT(I,I) = ONE - 120 CONTINUE - CALL TQL2 (NV,N,B(1,1),B(1,2),VECT,IERR) - DO 140 I = 1, NVECT - ROOT(I) = B(I,1) - 140 CONTINUE - IF (IERR .NE. 0) RETURN - 160 CALL TRBK3B(NV,N,(N*N+N)/2,A,NVECT,VECT) - RETURN - END -C*MODULE EIGEN *DECK GLDIAG - SUBROUTINE GLDIAG(LDVECT,NVECT,N,H,WRK,EIG,VECTOR,IERR,IWRK) -C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) -C - LOGICAL GOPARR,DSKWRK,MASWRK -C - DIMENSION H(*),WRK(N,8),EIG(N),VECTOR(LDVECT,NVECT),IWRK(N) -C - COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) - COMMON /MACHSW/ KDIAG,ICORFL,IXDR - COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK -C -C ----- GENERAL ROUTINE TO DIAGONALIZE A SYMMETRIC MATRIX ----- -C IF KDIAG = 0, USE A ROUTINE FROM THE VECTOR LIBRARY, -C IF AVAILABLE (SEE THE SUBROUTINE 'GLDIAG' -C IN VECTOR.SRC), OR EVVRSP OTHERWISE -C = 1, USE EVVRSP -C = 2, USE GIVEIS -C = 3, USE JACOBI -C -C N = DIMENSION (ORDER) OF MATRIX TO BE SOLVED -C LDVECT = LEADING DIMENSION OF VECTOR -C NVECT = NUMBER OF VECTORS DESIRED -C H = MATRIX TO BE DIAGONALIZED -C WRK = N*8 W.P. REAL WORDS OF SCRATCH SPACE -C EIG = EIGENVECTORS (OUTPUT) -C VECTOR = EIGENVECTORS (OUTPUT) -C IERR = ERROR FLAG (OUTPUT) -C IWRK = N INTEGER WORDS OF SCRATCH SPACE -C - IERR = 0 -C -C ----- USE STEVE ELBERT'S ROUTINE ----- -C - IF(KDIAG.LE.1 .OR. KDIAG.GT.3) THEN - LENH = (N*N+N)/2 - KORDER =0 - CALL EVVRSP(IW,N,NVECT,LENH,LDVECT,H,WRK,IWRK,EIG,VECTOR - * ,KORDER,IERR) - END IF -C -C ----- USE MODIFIED EISPAK ROUTINE ----- -C - IF(KDIAG.EQ.2) - * CALL GIVEIS(N,NVECT,LDVECT,H,WRK,IWRK,EIG,VECTOR,IERR) -C -C ----- USE JACOBI ROTATION ROUTINE ----- -C - IF(KDIAG.EQ.3) THEN - IF(NVECT.EQ.N) THEN - CALL JACDG(H,VECTOR,EIG,IWRK,WRK,LDVECT,N) - ELSE - IF (MASWRK) WRITE(IW,9000) N,NVECT,LDVECT - CALL ABRT - END IF - END IF - RETURN -C - 9000 FORMAT(1X,'IN -GLDIAG-, N,NVECT,LDVECT=',3I8/ - * 1X,'THE JACOBI CODE CANNOT COPE WITH N.NE.NVECT!'/ - * 1X,'SO THIS RUN DOES NOT PERMIT KDIAG=3.') - END -C*MODULE EIGEN *DECK IMTQLV - SUBROUTINE IMTQLV(N,D,E,E2,W,IND,IERR,RV1) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER TAG - DOUBLE PRECISION MACHEP - DIMENSION D(N),E(N),E2(N),W(N),RV1(N),IND(N) -C -C THIS ROUTINE IS A VARIANT OF IMTQL1 WHICH IS A TRANSLATION OF -C ALGOL PROCEDURE IMTQL1, NUM. MATH. 12, 377-383(1968) BY MARTIN AND -C WILKINSON, AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). -C -C THIS ROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL -C MATRIX BY THE IMPLICIT QL METHOD AND ASSOCIATES WITH THEM -C THEIR CORRESPONDING SUBMATRIX INDICES. -C -C ON INPUT- -C -C N IS THE ORDER OF THE MATRIX, -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, -C -C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, -C -C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. -C E2(1) IS ARBITRARY. -C -C ON OUTPUT- -C -C D AND E ARE UNALTERED, -C -C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED -C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE -C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. -C E2(1) IS ALSO SET TO ZERO, -C -C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN -C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND -C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE -C THE SMALLEST EIGENVALUES, -C -C IND CONTAINS THE SUBMATRIX INDICES ASSOCIATED WITH THE -C CORRESPONDING EIGENVALUES IN W -- 1 FOR EIGENVALUES -C BELONGING TO THE FIRST SUBMATRIX FROM THE TOP, -C 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC., -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C J IF THE J-TH EIGENVALUE HAS NOT BEEN -C DETERMINED AFTER 30 ITERATIONS, -C -C RV1 IS A TEMPORARY STORAGE ARRAY. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C -C ------------------------------------------------------------------ -C -C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING -C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. -C -C ********** - MACHEP = 2.0D+00**(-50) -C - IERR = 0 - K = 0 - TAG = 0 -C - DO 100 I = 1, N - W(I) = D(I) - IF (I .NE. 1) RV1(I-1) = E(I) - 100 CONTINUE -C - E2(1) = 0.0D+00 - RV1(N) = 0.0D+00 -C - DO 360 L = 1, N - J = 0 -C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** - 120 DO 140 M = L, N - IF (M .EQ. N) GO TO 160 - IF (ABS(RV1(M)) .LE. MACHEP * (ABS(W(M)) + ABS(W(M+1)))) GO TO - + 160 -C ********** GUARD AGAINST UNDERFLOWED ELEMENT OF E2 ********** - IF (E2(M+1) .EQ. 0.0D+00) GO TO 180 - 140 CONTINUE -C - 160 IF (M .LE. K) GO TO 200 - IF (M .NE. N) E2(M+1) = 0.0D+00 - 180 K = M - TAG = TAG + 1 - 200 P = W(L) - IF (M .EQ. L) GO TO 280 - IF (J .EQ. 30) GO TO 380 - J = J + 1 -C ********** FORM SHIFT ********** - G = (W(L+1) - P) / (2.0D+00 * RV1(L)) - R = SQRT(G*G+1.0D+00) - G = W(M) - P + RV1(L) / (G + SIGN(R,G)) - S = 1.0D+00 - C = 1.0D+00 - P = 0.0D+00 - MML = M - L -C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** - DO 260 II = 1, MML - I = M - II - F = S * RV1(I) - B = C * RV1(I) - IF (ABS(F) .LT. ABS(G)) GO TO 220 - C = G / F - R = SQRT(C*C+1.0D+00) - RV1(I+1) = F * R - S = 1.0D+00 / R - C = C * S - GO TO 240 - 220 S = F / G - R = SQRT(S*S+1.0D+00) - RV1(I+1) = G * R - C = 1.0D+00 / R - S = S * C - 240 G = W(I+1) - P - R = (W(I) - G) * S + 2.0D+00 * C * B - P = S * R - W(I+1) = G + P - G = C * R - B - 260 CONTINUE -C - W(L) = W(L) - P - RV1(L) = G - RV1(M) = 0.0D+00 - GO TO 120 -C ********** ORDER EIGENVALUES ********** - 280 IF (L .EQ. 1) GO TO 320 -C ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** - DO 300 II = 2, L - I = L + 2 - II - IF (P .GE. W(I-1)) GO TO 340 - W(I) = W(I-1) - IND(I) = IND(I-1) - 300 CONTINUE -C - 320 I = 1 - 340 W(I) = P - IND(I) = TAG - 360 CONTINUE -C - GO TO 400 -C ********** SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS ********** - 380 IERR = L - 400 RETURN -C ********** LAST CARD OF IMTQLV ********** - END -C*MODULE EIGEN *DECK JACDG - SUBROUTINE JACDG(A,VEC,EIG,JBIG,BIG,LDVEC,N) -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) -C - DIMENSION A(*),VEC(LDVEC,N),EIG(N),JBIG(N),BIG(N) -C - PARAMETER (ONE=1.0D+00) -C -C ----- JACOBI DIAGONALIZATION OF SYMMETRIC MATRIX ----- -C SYMMETRIC MATRIX -A- OF DIMENSION -N- IS DESTROYED ON EXIT. -C ALL EIGENVECTORS ARE FOUND, SO -VEC- MUST BE SQUARE, -C UNLESS SOMEONE TAKES THE TROUBLE TO LOOK AT -NMAX- BELOW. -C -BIG- AND -JBIG- ARE SCRATCH WORK ARRAYS. -C - CALL VCLR(VEC,1,LDVEC*N) - DO 20 I = 1,N - VEC(I,I) = ONE - 20 CONTINUE -C - NB1 = N - NB2 = (NB1*NB1+NB1)/2 - NMIN = 1 - NMAX = NB1 -C - CALL JACDIA(A,VEC,NB1,NB2,LDVEC,NMIN,NMAX,BIG,JBIG) -C - DO 30 I=1,N - EIG(I) = A((I*I+I)/2) - 30 CONTINUE -C - CALL JACORD(VEC,EIG,NB1,LDVEC) - RETURN - END -C*MODULE EIGEN *DECK JACDIA - SUBROUTINE JACDIA(F,VEC,NB1,NB2,LDVEC,NMIN,NMAX,BIG,JBIG) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL GOPARR,DSKWRK,MASWRK - DIMENSION F(NB2),VEC(LDVEC,NB1),BIG(NB1),JBIG(NB1) -C - COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK -C - PARAMETER (ROOT2=0.707106781186548D+00 ) - PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, D1050=1.05D+00, - * D1500=1.5D+00, D3875=3.875D+00, - * D0500=0.5D+00, D1375=1.375D+00, D0250=0.25D+00 ) - PARAMETER (C2=1.0D-12, C3=4.0D-16, - * C4=2.0D-16, C5=8.0D-09, C6=3.0D-06 ) -C -C F IS THE MATRIX TO BE DIAGONALIZED, F IS STORED TRIANGULAR -C VEC IS THE ARRAY OF EIGENVECTORS, DIMENSION NB1*NB1 -C BIG AND JBIG ARE TEMPORARY SCRATCH AREAS OF DIMENSION NB1 -C THE ROTATIONS AMONG THE FIRST NMIN BASIS FUNCTIONS ARE NOT -C ACCOUNTED FOR. -C THE ROTATIONS AMONG THE LAST NB1-NMAX BASIS FUNCTIONS ARE NOT -C ACCOUNTED FOR. -C - IEAA=0 - IEAB=0 - TT=ZERO - EPS = 64.0D+00*EPSLON(ONE) -C -C LOOP OVER COLUMNS (K) OF TRIANGULAR MATRIX TO DETERMINE -C LARGEST OFF-DIAGONAL ELEMENTS IN ROW(I). -C - DO 20 I=1,NB1 - BIG(I)=ZERO - JBIG(I)=0 - IF(I.LT.NMIN .OR. I.EQ.1) GO TO 20 - II = (I*I-I)/2 - J=MIN(I-1,NMAX) - DO 10 K=1,J - IF(ABS(BIG(I)).GE.ABS(F(II+K))) GO TO 10 - BIG(I)=F(II+K) - JBIG(I)=K - 10 CONTINUE - 20 CONTINUE -C -C ----- 2X2 JACOBI ITERATIONS BEGIN HERE ----- -C - MAXIT=MAX(NB2*20,500) - ITER=0 - 30 CONTINUE - ITER=ITER+1 -C -C FIND SMALLEST DIAGONAL ELEMENT -C - SD=D1050 - JJ=0 - DO 40 J=1,NB1 - JJ=JJ+J - SD= MIN(SD,ABS(F(JJ))) - 40 CONTINUE - TEST = MAX(EPS, C2*MAX(SD,C6)) -C -C FIND LARGEST OFF-DIAGONAL ELEMENT -C - T=ZERO - I1=MAX(2,NMIN) - IB = I1 - DO 50 I=I1,NB1 - IF(T.GE.ABS(BIG(I))) GO TO 50 - T= ABS(BIG(I)) - IB=I - 50 CONTINUE -C -C TEST FOR CONVERGENCE, THEN DETERMINE ROTATION. -C - IF(T.LT.TEST) RETURN -C ****** -C - IF(ITER.GT.MAXIT) THEN - IF (MASWRK) THEN - WRITE(6,*) 'JACOBI DIAGONALIZATION FAILS, DIMENSION=',NB1 - WRITE(6,9020) ITER,T,TEST,SD - ENDIF - CALL ABRT - STOP - END IF -C - IA=JBIG(IB) - IAA=IA*(IA-1)/2 - IBB=IB*(IB-1)/2 - DIF=F(IAA+IA)-F(IBB+IB) - IF(ABS(DIF).GT.C3*T) GO TO 70 - SX=ROOT2 - CX=ROOT2 - GO TO 110 - 70 T2X2=BIG(IB)/DIF - T2X25=T2X2*T2X2 - IF(T2X25 . GT . C4) GO TO 80 - CX=ONE - SX=T2X2 - GO TO 110 - 80 IF(T2X25 . GT . C5) GO TO 90 - SX=T2X2*(ONE-D1500*T2X25) - CX=ONE-D0500*T2X25 - GO TO 110 - 90 IF(T2X25 . GT . C6) GO TO 100 - CX=ONE+T2X25*(T2X25*D1375 - D0500) - SX= T2X2*(ONE + T2X25*(T2X25*D3875 - D1500)) - GO TO 110 - 100 T=D0250 / SQRT(D0250 + T2X25) - CX= SQRT(D0500 + T) - SX= SIGN( SQRT(D0500 - T),T2X2) - 110 IEAR=IAA+1 - IEBR=IBB+1 -C - DO 230 IR=1,NB1 - T=F(IEAR)*SX - F(IEAR)=F(IEAR)*CX+F(IEBR)*SX - F(IEBR)=T-F(IEBR)*CX - IF(IR-IA) 220,120,130 - 120 TT=F(IEBR) - IEAA=IEAR - IEAB=IEBR - F(IEBR)=BIG(IB) - IEAR=IEAR+IR-1 - IF(JBIG(IR)) 200,220,200 - 130 T=F(IEAR) - IT=IA - IEAR=IEAR+IR-1 - IF(IR-IB) 180,150,160 - 150 F(IEAA)=F(IEAA)*CX+F(IEAB)*SX - F(IEAB)=TT*CX+F(IEBR)*SX - F(IEBR)=TT*SX-F(IEBR)*CX - IEBR=IEBR+IR-1 - GO TO 200 - 160 IF( ABS(T) . GE . ABS(F(IEBR))) GO TO 170 - IF(IB.GT.NMAX) GO TO 170 - T=F(IEBR) - IT=IB - 170 IEBR=IEBR+IR-1 - 180 IF( ABS(T) . LT . ABS(BIG(IR))) GO TO 190 - BIG(IR) = T - JBIG(IR) = IT - GO TO 220 - 190 IF(IA . NE . JBIG(IR) . AND . IB . NE . JBIG(IR)) GO TO 220 - 200 KQ=IEAR-IR-IA+1 - BIG(IR)=ZERO - IR1=MIN(IR-1,NMAX) - DO 210 I=1,IR1 - K=KQ+I - IF(ABS(BIG(IR)) . GE . ABS(F(K))) GO TO 210 - BIG(IR) = F(K) - JBIG(IR)=I - 210 CONTINUE - 220 IEAR=IEAR+1 - 230 IEBR=IEBR+1 -C - DO 240 I=1,NB1 - T1=VEC(I,IA)*CX + VEC(I,IB)*SX - T2=VEC(I,IA)*SX - VEC(I,IB)*CX - VEC(I,IA)=T1 - VEC(I,IB)=T2 - 240 CONTINUE - GO TO 30 -C - 9020 FORMAT(1X,'ITER=',I6,' T,TEST,SD=',1P,3E20.10) - END -C*MODULE EIGEN *DECK JACORD - SUBROUTINE JACORD(VEC,EIG,N,LDVEC) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION VEC(LDVEC,N),EIG(N) -C -C ---- SORT EIGENDATA INTO ASCENDING ORDER ----- -C - DO 290 I = 1, N - JJ = I - DO 270 J = I, N - IF (EIG(J) .LT. EIG(JJ)) JJ = J - 270 CONTINUE - IF (JJ .EQ. I) GO TO 290 - T = EIG(JJ) - EIG(JJ) = EIG(I) - EIG(I) = T - DO 280 J = 1, N - T = VEC(J,JJ) - VEC(J,JJ) = VEC(J,I) - VEC(J,I) = T - 280 CONTINUE - 290 CONTINUE - RETURN - END -C*MODULE EIGEN *DECK TINVTB - SUBROUTINE TINVTB(NM,N,D,E,E2,M,W,IND,Z, - * IERR,RV1,RV2,RV3,RV4,RV6) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION D(N),E(N),E2(N),W(M),Z(NM,M), - * RV1(N),RV2(N),RV3(N),RV4(N),RV6(N),IND(M) - DOUBLE PRECISION MACHEP,NORM - INTEGER P,Q,R,S,TAG,GROUP -C ------------------------------------------------------------------ -C -C THIS ROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH- -C NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). -C -C THIS ROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL -C SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, -C USING INVERSE ITERATION. -C -C ON INPUT- -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -C DIMENSION STATEMENT, -C -C N IS THE ORDER OF THE MATRIX, -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, -C -C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, -C -C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E, -C WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. -C E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN -C THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM -C OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN -C 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0 -C IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT, -C TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES, -C THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE, -C -C M IS THE NUMBER OF SPECIFIED EIGENVALUES, -C -C W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER, -C -C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES -C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- -C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM -C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC. -C -C ON OUTPUT- -C -C ALL INPUT ARRAYS ARE UNALTERED, -C -C Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. -C ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO, -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH -C EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS, -C -C RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C -C ------------------------------------------------------------------ -C -C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING -C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. -C -C ********** - MACHEP = 2.0D+00**(-50) -C - IERR = 0 - IF (M .EQ. 0) GO TO 680 - TAG = 0 - ORDER = 1.0D+00 - E2(1) - XU = 0.0D+00 - UK = 0.0D+00 - X0 = 0.0D+00 - U = 0.0D+00 - EPS2 = 0.0D+00 - EPS3 = 0.0D+00 - EPS4 = 0.0D+00 - GROUP = 0 - Q = 0 -C ********** ESTABLISH AND PROCESS NEXT SUBMATRIX ********** - 100 P = Q + 1 - IP = P + 1 -C - DO 120 Q = P, N - IF (Q .EQ. N) GO TO 140 - IF (E2(Q+1) .EQ. 0.0D+00) GO TO 140 - 120 CONTINUE -C ********** FIND VECTORS BY INVERSE ITERATION ********** - 140 TAG = TAG + 1 - IQMP = Q - P + 1 - S = 0 -C - DO 660 R = 1, M - IF (IND(R) .NE. TAG) GO TO 660 - ITS = 1 - X1 = W(R) - IF (S .NE. 0) GO TO 220 -C ********** CHECK FOR ISOLATED ROOT ********** - XU = 1.0D+00 - IF (P .NE. Q) GO TO 160 - RV6(P) = 1.0D+00 - GO TO 600 - 160 NORM = ABS(D(P)) -C - DO 180 I = IP, Q - 180 NORM = NORM + ABS(D(I)) + ABS(E(I)) -C ********** EPS2 IS THE CRITERION FOR GROUPING, -C EPS3 REPLACES ZERO PIVOTS AND EQUAL -C ROOTS ARE MODIFIED BY EPS3, -C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ********** - EPS2 = 1.0D-03 * NORM - EPS3 = MACHEP * NORM - UK = IQMP - EPS4 = UK * EPS3 - UK = EPS4 / SQRT(UK) - S = P - 200 GROUP = 0 - GO TO 240 -C ********** LOOK FOR CLOSE OR COINCIDENT ROOTS ********** - 220 IF (ABS(X1-X0) .GE. EPS2) GO TO 200 - GROUP = GROUP + 1 - IF (ORDER * (X1 - X0) .LE. 0.0D+00) X1 = X0 + ORDER * EPS3 -C ********** ELIMINATION WITH INTERCHANGES AND -C INITIALIZATION OF VECTOR ********** - 240 V = 0.0D+00 -C - DO 300 I = P, Q - RV6(I) = UK - IF (I .EQ. P) GO TO 280 - IF (ABS(E(I)) .LT. ABS(U)) GO TO 260 -C ********** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF -C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ********** - XU = U / E(I) - RV4(I) = XU - RV1(I-1) = E(I) - RV2(I-1) = D(I) - X1 - RV3(I-1) = 0.0D+00 - IF (I .NE. Q) RV3(I-1) = E(I+1) - U = V - XU * RV2(I-1) - V = -XU * RV3(I-1) - GO TO 300 - 260 XU = E(I) / U - RV4(I) = XU - RV1(I-1) = U - RV2(I-1) = V - RV3(I-1) = 0.0D+00 - 280 U = D(I) - X1 - XU * V - IF (I .NE. Q) V = E(I+1) - 300 CONTINUE -C - IF (U .EQ. 0.0D+00) U = EPS3 - RV1(Q) = U - RV2(Q) = 0.0D+00 - RV3(Q) = 0.0D+00 -C ********** BACK SUBSTITUTION -C FOR I=Q STEP -1 UNTIL P DO -- ********** - 320 DO 340 II = P, Q - I = P + Q - II - RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) - V = U - U = RV6(I) - 340 CONTINUE -C ********** ORTHOGONALIZE WITH RESPECT TO PREVIOUS -C MEMBERS OF GROUP ********** - IF (GROUP .EQ. 0) GO TO 400 - J = R -C - DO 380 JJ = 1, GROUP - 360 J = J - 1 - IF (IND(J) .NE. TAG) GO TO 360 - XU = DDOT(IQMP,RV6(P),1,Z(P,J),1) -C - CALL DAXPY(IQMP,-XU,Z(P,J),1,RV6(P),1) -C - 380 CONTINUE -C - 400 NORM = 0.0D+00 -C - DO 420 I = P, Q - 420 NORM = NORM + ABS(RV6(I)) -C - IF (NORM .GE. 1.0D+00) GO TO 560 -C ********** FORWARD SUBSTITUTION ********** - IF (ITS .EQ. 5) GO TO 540 - IF (NORM .NE. 0.0D+00) GO TO 440 - RV6(S) = EPS4 - S = S + 1 - IF (S .GT. Q) S = P - GO TO 480 - 440 XU = EPS4 / NORM -C - DO 460 I = P, Q - 460 RV6(I) = RV6(I) * XU -C ********** ELIMINATION OPERATIONS ON NEXT VECTOR -C ITERATE ********** - 480 DO 520 I = IP, Q - U = RV6(I) -C ********** IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE -C WAS PERFORMED EARLIER IN THE -C TRIANGULARIZATION PROCESS ********** - IF (RV1(I-1) .NE. E(I)) GO TO 500 - U = RV6(I-1) - RV6(I-1) = RV6(I) - 500 RV6(I) = U - RV4(I) * RV6(I-1) - 520 CONTINUE -C - ITS = ITS + 1 - GO TO 320 -C ********** SET ERROR -- NON-CONVERGED EIGENVECTOR ********** - 540 IERR = -R - XU = 0.0D+00 - GO TO 600 -C ********** NORMALIZE SO THAT SUM OF SQUARES IS -C 1 AND EXPAND TO FULL ORDER ********** - 560 U = 0.0D+00 -C - DO 580 I = P, Q - RV6(I) = RV6(I) / NORM - 580 U = U + RV6(I)**2 -C - XU = 1.0D+00 / SQRT(U) -C - 600 DO 620 I = 1, N - 620 Z(I,R) = 0.0D+00 -C - DO 640 I = P, Q - 640 Z(I,R) = RV6(I) * XU -C - X0 = X1 - 660 CONTINUE -C - IF (Q .LT. N) GO TO 100 - 680 RETURN -C ********** LAST CARD OF TINVIT ********** - END -C*MODULE EIGEN *DECK TQL2 -C -C ------------------------------------------------------------------ -C - SUBROUTINE TQL2(NM,N,D,E,Z,IERR) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DOUBLE PRECISION MACHEP - DIMENSION D(N),E(N),Z(NM,N) -C -C THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, -C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND -C WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). -C -C THIS ROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS -C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. -C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO -C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS -C FULL MATRIX TO TRIDIAGONAL FORM. -C -C ON INPUT- -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -C DIMENSION STATEMENT, -C -C N IS THE ORDER OF THE MATRIX, -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, -C -C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, -C -C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE -C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS -C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN -C THE IDENTITY MATRIX. -C -C ON OUTPUT- -C -C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN -C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT -C UNORDERED FOR INDICES 1,2,...,IERR-1, -C -C E HAS BEEN DESTROYED, -C -C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC -C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, -C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED -C EIGENVALUES, -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C J IF THE J-TH EIGENVALUE HAS NOT BEEN -C DETERMINED AFTER 30 ITERATIONS. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C -C ------------------------------------------------------------------ -C -C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING -C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. -C -C ********** - MACHEP = 2.0D+00**(-50) -C - IERR = 0 - IF (N .EQ. 1) GO TO 400 -C - DO 100 I = 2, N - 100 E(I-1) = E(I) -C - F = 0.0D+00 - B = 0.0D+00 - E(N) = 0.0D+00 -C - DO 300 L = 1, N - J = 0 - H = MACHEP * (ABS(D(L)) + ABS(E(L))) - IF (B .LT. H) B = H -C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** - DO 120 M = L, N - IF (ABS(E(M)) .LE. B) GO TO 140 -C ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT -C THROUGH THE BOTTOM OF THE LOOP ********** - 120 CONTINUE -C - 140 IF (M .EQ. L) GO TO 280 - 160 IF (J .EQ. 30) GO TO 380 - J = J + 1 -C ********** FORM SHIFT ********** - L1 = L + 1 - G = D(L) - P = (D(L1) - G) / (2.0D+00 * E(L)) - R = SQRT(P*P+1.0D+00) - D(L) = E(L) / (P + SIGN(R,P)) - H = G - D(L) -C - DO 180 I = L1, N - 180 D(I) = D(I) - H -C - F = F + H -C ********** QL TRANSFORMATION ********** - P = D(M) - C = 1.0D+00 - S = 0.0D+00 - MML = M - L -C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** - DO 260 II = 1, MML - I = M - II - G = C * E(I) - H = C * P - IF (ABS(P) .LT. ABS(E(I))) GO TO 200 - C = E(I) / P - R = SQRT(C*C+1.0D+00) - E(I+1) = S * P * R - S = C / R - C = 1.0D+00 / R - GO TO 220 - 200 C = P / E(I) - R = SQRT(C*C+1.0D+00) - E(I+1) = S * E(I) * R - S = 1.0D+00 / R - C = C * S - 220 P = C * D(I) - S * G - D(I+1) = H + S * (C * G + S * D(I)) -C ********** FORM VECTOR ********** - CALL DROT(N,Z(1,I+1),1,Z(1,I),1,C,S) -C - 260 CONTINUE -C - E(L) = S * P - D(L) = C * P - IF (ABS(E(L)) .GT. B) GO TO 160 - 280 D(L) = D(L) + F - 300 CONTINUE -C ********** ORDER EIGENVALUES AND EIGENVECTORS ********** - DO 360 II = 2, N - I = II - 1 - K = I - P = D(I) -C - DO 320 J = II, N - IF (D(J) .GE. P) GO TO 320 - K = J - P = D(J) - 320 CONTINUE -C - IF (K .EQ. I) GO TO 360 - D(K) = D(I) - D(I) = P -C - CALL DSWAP(N,Z(1,I),1,Z(1,K),1) -C - 360 CONTINUE -C - GO TO 400 -C ********** SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS ********** - 380 IERR = L - 400 RETURN -C ********** LAST CARD OF TQL2 ********** - END -C*MODULE EIGEN *DECK TRBK3B -C -C ------------------------------------------------------------------ -C - SUBROUTINE TRBK3B(NM,N,NV,A,M,Z) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION A(NV),Z(NM,M) -C -C THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, -C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C THIS ROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC -C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING -C SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED3B. -C -C ON INPUT- -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE -C DIMENSION STATEMENT, -C -C N IS THE ORDER OF THE MATRIX, -C -C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A -C AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT, -C -C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS -C USED IN THE REDUCTION BY TRED3B IN ITS FIRST -C N*(N+1)/2 POSITIONS, -C -C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED, -C -C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED -C IN ITS FIRST M COLUMNS. -C -C ON OUTPUT- -C -C Z CONTAINS THE TRANSFORMED EIGENVECTORS -C IN ITS FIRST M COLUMNS. -C -C NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C -C ------------------------------------------------------------------ -C - IF (M .EQ. 0) GO TO 140 - IF (N .EQ. 1) GO TO 140 -C - DO 120 I = 2, N - L = I - 1 - IZ = (I * L) / 2 - IK = IZ + I - H = A(IK) - IF (H .EQ. 0.0D+00) GO TO 120 -C - DO 100 J = 1, M - S = -DDOT(L,A(IZ+1),1,Z(1,J),1) -C -C ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** - S = (S / H) / H -C - CALL DAXPY(L,S,A(IZ+1),1,Z(1,J),1) -C - 100 CONTINUE -C - 120 CONTINUE -C - 140 RETURN -C ********** LAST CARD OF TRBAK3 ********** - END -C*MODULE EIGEN *DECK TRED3B -C -C ------------------------------------------------------------------ -C - SUBROUTINE TRED3B(N,NV,A,D,E,E2) - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION A(NV),D(N),E(N),E2(N) -C -C THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, -C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C THIS ROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS -C A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX -C USING ORTHOGONAL SIMILARITY TRANSFORMATIONS. -C -C ON INPUT- -C -C N IS THE ORDER OF THE MATRIX, -C -C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A -C AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT, -C -C A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC -C INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL -C ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. -C -C ON OUTPUT- -C -C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL -C TRANSFORMATIONS USED IN THE REDUCTION, -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX, -C -C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL -C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO, -C -C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. -C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, -C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY -C -C ------------------------------------------------------------------ -C -C ********** FOR I=N STEP -1 UNTIL 1 DO -- ********** - DO 300 II = 1, N - I = N + 1 - II - L = I - 1 - IZ = (I * L) / 2 - H = 0.0D+00 - SCALE = 0.0D+00 - IF (L .LT. 1) GO TO 120 -C ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) ********** - DO 100 K = 1, L - IZ = IZ + 1 - D(K) = A(IZ) - SCALE = SCALE + ABS(D(K)) - 100 CONTINUE -C - IF (SCALE .NE. 0.0D+00) GO TO 140 - 120 E(I) = 0.0D+00 - E2(I) = 0.0D+00 - GO TO 280 -C - 140 DO 160 K = 1, L - D(K) = D(K) / SCALE - H = H + D(K) * D(K) - 160 CONTINUE -C - E2(I) = SCALE * SCALE * H - F = D(L) - G = -SIGN(SQRT(H),F) - E(I) = SCALE * G - H = H - F * G - D(L) = F - G - A(IZ) = SCALE * D(L) - IF (L .EQ. 1) GO TO 280 - F = 0.0D+00 -C - JK = 1 - DO 220 J = 1, L - JM1 = J - 1 - DT = D(J) - G = 0.0D+00 -C ********** FORM ELEMENT OF A*U ********** - IF (JM1 .EQ. 0) GO TO 200 - DO 180 K = 1, JM1 - E(K) = E(K) + DT * A(JK) - G = G + D(K) * A(JK) - JK = JK + 1 - 180 CONTINUE - 200 E(J) = G + A(JK) * DT - JK = JK + 1 -C ********** FORM ELEMENT OF P ********** - 220 CONTINUE - F = 0.0D+00 - DO 240 J = 1, L - E(J) = E(J) / H - F = F + E(J) * D(J) - 240 CONTINUE -C - HH = F / (H + H) - JK = 0 -C ********** FORM REDUCED A ********** - DO 260 J = 1, L - F = D(J) - G = E(J) - HH * F - E(J) = G -C - DO 260 K = 1, J - JK = JK + 1 - A(JK) = A(JK) - F * E(K) - G * D(K) - 260 CONTINUE -C - 280 D(I) = A(IZ+1) - A(IZ+1) = SCALE * SQRT(H) - 300 CONTINUE -C - RETURN -C ********** LAST CARD OF TRED3 ********** - END diff --git a/source/unres/src_MD_DFA/elecont.f b/source/unres/src_MD_DFA/elecont.f deleted file mode 100644 index e9ed067..0000000 --- a/source/unres/src_MD_DFA/elecont.f +++ /dev/null @@ -1,509 +0,0 @@ - subroutine elecont(lprint,ncont,icont) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.FFIELD' - include 'COMMON.NAMES' - logical lprint - double precision elpp_6(2,2),elpp_3(2,2),ael6_(2,2),ael3_(2,2) - double precision app_(2,2),bpp_(2,2),rpp_(2,2) - integer ncont,icont(2,maxcont) - double precision econt(maxcont) -* -* Load the constants of peptide bond - peptide bond interactions. -* Type 1 - ordinary peptide bond, type 2 - alkylated peptide bond (e.g. -* proline) - determined by averaging ECEPP energy. -* -* as of 7/06/91. -* -c data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ - data rpp_ / 4.5088d0, 4.5395d0, 4.5395d0, 4.4846d0/ - data elpp_6 /-0.2379d0,-0.2056d0,-0.2056d0,-0.0610d0/ - data elpp_3 / 0.0503d0, 0.0000d0, 0.0000d0, 0.0692d0/ - data elcutoff /-0.3d0/,elecutoff_14 /-0.5d0/ - if (lprint) write (iout,'(a)') - & "Constants of electrostatic interaction energy expression." - do i=1,2 - do j=1,2 - rri=rpp_(i,j)**6 - app_(i,j)=epp(i,j)*rri*rri - bpp_(i,j)=-2.0*epp(i,j)*rri - ael6_(i,j)=elpp_6(i,j)*4.2**6 - ael3_(i,j)=elpp_3(i,j)*4.2**3 - if (lprint) - & write (iout,'(2i2,4e15.4)') i,j,app_(i,j),bpp_(i,j),ael6_(i,j), - & ael3_(i,j) - enddo - enddo - ncont=0 - ees=0.0 - evdw=0.0 - do 1 i=nnt,nct-2 - xi=c(1,i) - yi=c(2,i) - zi=c(3,i) - dxi=c(1,i+1)-c(1,i) - dyi=c(2,i+1)-c(2,i) - dzi=c(3,i+1)-c(3,i) - xmedi=xi+0.5*dxi - ymedi=yi+0.5*dyi - zmedi=zi+0.5*dzi - do 4 j=i+2,nct-1 - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - if (iteli.eq.2 .and. itelj.eq.2) goto 4 - aaa=app_(iteli,itelj) - bbb=bpp_(iteli,itelj) - ael6_i=ael6_(iteli,itelj) - ael3_i=ael3_(iteli,itelj) - dxj=c(1,j+1)-c(1,j) - dyj=c(2,j+1)-c(2,j) - dzj=c(3,j+1)-c(3,j) - xj=c(1,j)+0.5*dxj-xmedi - yj=c(2,j)+0.5*dyj-ymedi - zj=c(3,j)+0.5*dzj-zmedi - rrmij=1.0/(xj*xj+yj*yj+zj*zj) - rmij=sqrt(rrmij) - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - vrmij=vblinv*rmij - cosa=(dxi*dxj+dyi*dyj+dzi*dzj)*vblinv2 - cosb=(xj*dxi+yj*dyi+zj*dzi)*vrmij - cosg=(xj*dxj+yj*dyj+zj*dzj)*vrmij - fac=cosa-3.0*cosb*cosg - ev1=aaa*r6ij*r6ij - ev2=bbb*r6ij - fac3=ael6_i*r6ij - fac4=ael3_i*r3ij - evdwij=ev1+ev2 - el1=fac3*(4.0+fac*fac-3.0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - eesij=el1+el2 - if (j.gt.i+2 .and. eesij.le.elcutoff .or. - & j.eq.i+2 .and. eesij.le.elecutoff_14) then - ncont=ncont+1 - icont(1,ncont)=i - icont(2,ncont)=j - econt(ncont)=eesij - endif - ees=ees+eesij - evdw=evdw+evdwij - 4 continue - 1 continue - if (lprint) then - write (iout,*) 'Total average electrostatic energy: ',ees - write (iout,*) 'VDW energy between peptide-group centers: ',evdw - write (iout,*) - write (iout,*) 'Electrostatic contacts before pruning: ' - do i=1,ncont - i1=icont(1,i) - i2=icont(2,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4,f10.5)') - & i,restyp(it1),i1,restyp(it2),i2,econt(i) - enddo - endif -c For given residues keep only the contacts with the greatest energy. - i=0 - do while (i.lt.ncont) - i=i+1 - ene=econt(i) - ic1=icont(1,i) - ic2=icont(2,i) - j=i - do while (j.lt.ncont) - j=j+1 - if (ic1.eq.icont(1,j).and.iabs(icont(2,j)-ic2).le.2 .or. - & ic2.eq.icont(2,j).and.iabs(icont(1,j)-ic1).le.2) then -c write (iout,*) "i",i," j",j," ic1",ic1," ic2",ic2, -c & " jc1",icont(1,j)," jc2",icont(2,j)," ncont",ncont - if (econt(j).lt.ene .and. icont(2,j).ne.icont(1,j)+2) then - if (ic1.eq.icont(1,j)) then - do k=1,ncont - if (k.ne.i .and. k.ne.j .and. icont(2,k).eq.icont(2,j) - & .and. iabs(icont(1,k)-ic1).le.2 .and. - & econt(k).lt.econt(j) ) goto 21 - enddo - else if (ic2.eq.icont(2,j) ) then - do k=1,ncont - if (k.ne.i .and. k.ne.j .and. icont(1,k).eq.icont(1,j) - & .and. iabs(icont(2,k)-ic2).le.2 .and. - & econt(k).lt.econt(j) ) goto 21 - enddo - endif -c Remove ith contact - do k=i+1,ncont - icont(1,k-1)=icont(1,k) - icont(2,k-1)=icont(2,k) - econt(k-1)=econt(k) - enddo - i=i-1 - ncont=ncont-1 -c write (iout,*) "ncont",ncont -c do k=1,ncont -c write (iout,*) icont(1,k),icont(2,k) -c enddo - goto 20 - else if (econt(j).gt.ene .and. ic2.ne.ic1+2) - & then - if (ic1.eq.icont(1,j)) then - do k=1,ncont - if (k.ne.i .and. k.ne.j .and. icont(2,k).eq.ic2 - & .and. iabs(icont(1,k)-icont(1,j)).le.2 .and. - & econt(k).lt.econt(i) ) goto 21 - enddo - else if (ic2.eq.icont(2,j) ) then - do k=1,ncont - if (k.ne.i .and. k.ne.j .and. icont(1,k).eq.ic1 - & .and. iabs(icont(2,k)-icont(2,j)).le.2 .and. - & econt(k).lt.econt(i) ) goto 21 - enddo - endif -c Remove jth contact - do k=j+1,ncont - icont(1,k-1)=icont(1,k) - icont(2,k-1)=icont(2,k) - econt(k-1)=econt(k) - enddo - ncont=ncont-1 -c write (iout,*) "ncont",ncont -c do k=1,ncont -c write (iout,*) icont(1,k),icont(2,k) -c enddo - j=j-1 - endif - endif - 21 continue - enddo - 20 continue - enddo - if (lprint) then - write (iout,*) - write (iout,*) 'Electrostatic contacts after pruning: ' - do i=1,ncont - i1=icont(1,i) - i2=icont(2,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4,f10.5)') - & i,restyp(it1),i1,restyp(it2),i2,econt(i) - enddo - endif - return - end -c-------------------------------------------- - subroutine secondary2(lprint) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.CONTROL' - integer ncont,icont(2,maxcont),isec(maxres,4),nsec(maxres) - logical lprint,not_done,freeres - double precision p1,p2 - external freeres - - if(.not.dccart) call chainbuild -cd call write_pdb(99,'sec structure',0d0) - ncont=0 - nbfrag=0 - nhfrag=0 - do i=1,nres - isec(i,1)=0 - isec(i,2)=0 - nsec(i)=0 - enddo - - call elecont(lprint,ncont,icont) - -c finding parallel beta -cd write (iout,*) '------- looking for parallel beta -----------' - nbeta=0 - nstrand=0 - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if(j1-i1.gt.5 .and. freeres(i1,j1,nsec,isec)) then - ii1=i1 - jj1=j1 -cd write (iout,*) i1,j1 - not_done=.true. - do while (not_done) - i1=i1+1 - j1=j1+1 - do j=1,ncont - if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j) .and. - & freeres(i1,j1,nsec,isec)) goto 5 - enddo - not_done=.false. - 5 continue -cd write (iout,*) i1,j1,not_done - enddo - j1=j1-1 - i1=i1-1 - if (i1-ii1.gt.1) then - ii1=max0(ii1-1,1) - jj1=max0(jj1-1,1) - nbeta=nbeta+1 - if(lprint)write(iout,'(a,i3,4i4)')'parallel beta', - & nbeta,ii1,i1,jj1,j1 - - nbfrag=nbfrag+1 - bfrag(1,nbfrag)=ii1+1 - bfrag(2,nbfrag)=i1+1 - bfrag(3,nbfrag)=jj1+1 - bfrag(4,nbfrag)=min0(j1+1,nres) - - do ij=ii1,i1 - nsec(ij)=nsec(ij)+1 - isec(ij,nsec(ij))=nbeta - enddo - do ij=jj1,j1 - nsec(ij)=nsec(ij)+1 - isec(ij,nsec(ij))=nbeta - enddo - - if(lprint) then - nstrand=nstrand+1 - if (nbeta.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-1,"..",i1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-1,"..",i1-1,"'" - endif - nstrand=nstrand+1 - if (nbeta.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",jj1-1,"..",j1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",jj1-1,"..",j1-1,"'" - endif - write(12,'(a8,4i4)') - & "SetNeigh",ii1-1,i1-1,jj1-1,j1-1 - endif - endif - endif - enddo - -c finding alpha or 310 helix - - nhelix=0 - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - p1=phi(i1+2)*rad2deg - p2=0.0 - if (j1+2.le.nres) p2=phi(j1+2)*rad2deg - - - if (j1.eq.i1+3 .and. - & ((p1.ge.10.and.p1.le.80).or.i1.le.2).and. - & ((p2.ge.10.and.p2.le.80).or.j1.le.2.or.j1.ge.nres-3) )then -cd if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,p1,p2 -co if (j1.eq.i1+4) write (iout,*) "found 1-5 ",i1,j1,p1,p2 - ii1=i1 - jj1=j1 - if (nsec(ii1).eq.0) then - not_done=.true. - else - not_done=.false. - endif - do while (not_done) - i1=i1+1 - j1=j1+1 - do j=1,ncont - if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10 - enddo - not_done=.false. - 10 continue - p1=phi(i1+2)*rad2deg - p2=phi(j1+2)*rad2deg - if (p1.lt.10.or.p1.gt.80.or.p2.lt.10.or.p2.gt.80) - & not_done=.false. -cd write (iout,*) i1,j1,not_done,p1,p2 - enddo - j1=j1+1 - if (j1-ii1.gt.5) then - nhelix=nhelix+1 -cd write (iout,*)'helix',nhelix,ii1,j1 - - nhfrag=nhfrag+1 - hfrag(1,nhfrag)=ii1 - hfrag(2,nhfrag)=j1 - - do ij=ii1,j1 - nsec(ij)=-1 - enddo - if (lprint) then - write (iout,'(a,i3,2i4)') "Helix",nhelix,ii1-1,j1-1 - if (nhelix.le.9) then - write(12,'(a17,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'helix",nhelix, - & "' 'num = ",ii1-1,"..",j1-2,"'" - else - write(12,'(a17,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'helix",nhelix, - & "' 'num = ",ii1-1,"..",j1-2,"'" - endif - endif - endif - endif - enddo - - if (nhelix.gt.0.and.lprint) then - write(12,'(a26,$)') "DefPropRes 'helix' 'helix1" - do i=2,nhelix - if (nhelix.le.9) then - write(12,'(a8,i1,$)') " | helix",i - else - write(12,'(a8,i2,$)') " | helix",i - endif - enddo - write(12,'(a1)') "'" - endif - - -c finding antiparallel beta -cd write (iout,*) '--------- looking for antiparallel beta ---------' - - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if (freeres(i1,j1,nsec,isec)) then - ii1=i1 - jj1=j1 -cd write (iout,*) i1,j1 - - not_done=.true. - do while (not_done) - i1=i1+1 - j1=j1-1 - do j=1,ncont - if (i1.eq.icont(1,j).and.j1.eq.icont(2,j) .and. - & freeres(i1,j1,nsec,isec)) goto 6 - enddo - not_done=.false. - 6 continue -cd write (iout,*) i1,j1,not_done - enddo - i1=i1-1 - j1=j1+1 - if (i1-ii1.gt.1) then - - nbfrag=nbfrag+1 - bfrag(1,nbfrag)=ii1 - bfrag(2,nbfrag)=min0(i1+1,nres) - bfrag(3,nbfrag)=min0(jj1+1,nres) - bfrag(4,nbfrag)=j1 - - nbeta=nbeta+1 - iii1=max0(ii1-1,1) - do ij=iii1,i1 - nsec(ij)=nsec(ij)+1 - if (nsec(ij).le.2) then - isec(ij,nsec(ij))=nbeta - endif - enddo - jjj1=max0(j1-1,1) - do ij=jjj1,jj1 - nsec(ij)=nsec(ij)+1 - if (nsec(ij).le.2 .and. nsec(ij).gt.0) then - isec(ij,nsec(ij))=nbeta - endif - enddo - - - if (lprint) then - write (iout,'(a,i3,4i4)')'antiparallel beta', - & nbeta,ii1-1,i1,jj1,j1-1 - nstrand=nstrand+1 - if (nstrand.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-2,"..",i1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-2,"..",i1-1,"'" - endif - nstrand=nstrand+1 - if (nstrand.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",j1-2,"..",jj1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",j1-2,"..",jj1-1,"'" - endif - write(12,'(a8,4i4)') - & "SetNeigh",ii1-2,i1-1,jj1-1,j1-2 - endif - endif - endif - enddo - - if (nstrand.gt.0.and.lprint) then - write(12,'(a27,$)') "DefPropRes 'sheet' 'strand1" - do i=2,nstrand - if (i.le.9) then - write(12,'(a9,i1,$)') " | strand",i - else - write(12,'(a9,i2,$)') " | strand",i - endif - enddo - write(12,'(a1)') "'" - endif - - - - if (lprint) then - write(12,'(a37)') "DefPropRes 'coil' '! (helix | sheet)'" - write(12,'(a20)') "XMacStand ribbon.mac" - - - write(iout,*) 'UNRES seq:' - do j=1,nbfrag - write(iout,*) 'beta ',(bfrag(i,j),i=1,4) - enddo - - do j=1,nhfrag - write(iout,*) 'helix ',(hfrag(i,j),i=1,2) - enddo - endif - - return - end -c------------------------------------------------- - logical function freeres(i,j,nsec,isec) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - integer isec(maxres,4),nsec(maxres) - freeres=.false. - - if (nsec(i).lt.0.or.nsec(j).lt.0) return - if (nsec(i).gt.1.or.nsec(j).gt.1) return - do k=1,nsec(i) - do l=1,nsec(j) - if (isec(i,k).eq.isec(j,l)) return - enddo - enddo - freeres=.true. - return - end - diff --git a/source/unres/src_MD_DFA/energy_p_new-sep_barrier.F b/source/unres/src_MD_DFA/energy_p_new-sep_barrier.F deleted file mode 100644 index c89aee2..0000000 --- a/source/unres/src_MD_DFA/energy_p_new-sep_barrier.F +++ /dev/null @@ -1,2322 +0,0 @@ -C----------------------------------------------------------------------- - double precision function sscale(r) - double precision r,gamm - include "COMMON.SPLITELE" - if(r.lt.r_cut-rlamb) then - sscale=1.0d0 - else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then - gamm=(r-(r_cut-rlamb))/rlamb - sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) - else - sscale=0d0 - endif - return - end -C----------------------------------------------------------------------- - subroutine elj_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJ potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) -cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -cd & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rij=xj*xj+yj*yj+zj*zj - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) - if (sss.lt.1.0d0) then - rrij=1.0D0/rij - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 - evdw=evdw+(1.0d0-sss)*evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij)*(1.0d0-sss) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time, the factor of EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C----------------------------------------------------------------------- - subroutine elj_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJ potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C Change 12/1/95 - num_conti=0 -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) -cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -cd & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi -C Change 12/1/95 to calculate four-body interactions - rij=xj*xj+yj*yj+zj*zj - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) - if (sss.gt.0.0d0) then - rrij=1.0D0/rij - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 - evdw=evdw+sss*evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij)*sss - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time, the factor of EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C----------------------------------------------------------------------------- - subroutine eljk_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJK potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - dimension gg(3) - logical scheck -c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - r_inv_ij=dsqrt(rrij) - rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) - if (sss.lt.1.0d0) then - r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) - fac=r_shift_inv**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e_augm+e1+e2 -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, -cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+(1.0d0-sss)*evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) - fac=fac*(1.0d0-sss) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo - return - end -C----------------------------------------------------------------------------- - subroutine eljk_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJK potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - dimension gg(3) - logical scheck -c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - r_inv_ij=dsqrt(rrij) - rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) - if (sss.gt.0.0d0) then - r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) - fac=r_shift_inv**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e_augm+e1+e2 -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, -cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+sss*evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) - fac=fac*sss - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo - return - end -C----------------------------------------------------------------------------- - subroutine ebp_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Berne-Pechukas potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - common /srutu/ icall -c double precision rrsave(maxdim) - logical lprn - evdw=0.0D0 -c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 -c if (icall.eq.0) then -c lprn=.true. -c else - lprn=.false. -c endif - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -C Calculate the angle-dependent terms of energy & contributions to derivatives. - call sc_angular -C Calculate whole angle-dependent part of epsilon and contributions -C to its derivatives - fac=(rrij*sigsq)**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),15(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & epsi,sigm,chi1,chi2,chip1,chip2, -cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), -cd & om1,om2,om12,1.0D0/dsqrt(rrij), -cd & evdwij - endif -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij) - sigder=fac/sigsq - fac=rrij*fac -C Calculate radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate the angular part of the gradient and sum add the contributions -C to the appropriate components of the Cartesian gradient. - call sc_grad_scale(1.0d0-sss) - endif - enddo ! j - enddo ! iint - enddo ! i -c stop - return - end -C----------------------------------------------------------------------------- - subroutine ebp_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Berne-Pechukas potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - common /srutu/ icall -c double precision rrsave(maxdim) - logical lprn - evdw=0.0D0 -c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 -c if (icall.eq.0) then -c lprn=.true. -c else - lprn=.false. -c endif - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -C Calculate the angle-dependent terms of energy & contributions to derivatives. - call sc_angular -C Calculate whole angle-dependent part of epsilon and contributions -C to its derivatives - fac=(rrij*sigsq)**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*sss - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),15(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & epsi,sigm,chi1,chi2,chip1,chip2, -cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), -cd & om1,om2,om12,1.0D0/dsqrt(rrij), -cd & evdwij - endif -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij) - sigder=fac/sigsq - fac=rrij*fac -C Calculate radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate the angular part of the gradient and sum add the contributions -C to the appropriate components of the Cartesian gradient. - call sc_grad_scale(sss) - endif - enddo ! j - enddo ! iint - enddo ! i -c stop - return - end -C----------------------------------------------------------------------------- - subroutine egb_long(evdw,evdw_p,evdw_m) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - include 'COMMON.CONTROL' - logical lprn -ccccc energy_dec=.false. -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - evdw_p=0.0D0 - evdw_m=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.false. - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) -c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) -c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, -c & 1.0d0/vbld(j+nres) -c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij -c for diagnostics; uncomment -c rij_shift=1.2*sig0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 -cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt -c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, -c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 - evdwij=evdwij*eps2rt*eps3rt -#ifdef TSCSC - if (bb(itypi,itypj).gt.0) then - evdw_p=evdw_p+evdwij*(1.0d0-sss) - else - evdw_m=evdw_m+evdwij*(1.0d0-sss) - endif -#else - evdw=evdw+evdwij*(1.0d0-sss) -#endif - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij - -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -c fac=0.0d0 -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. -#ifdef TSCSC - if (bb(itypi,itypj).gt.0) then - call sc_grad_scale_T(1.0d0-sss) - else - call sc_grad_scale(1.0d0-sss) - endif -#else - call sc_grad_scale(1.0d0-sss) -#endif - endif - enddo ! j - enddo ! iint - enddo ! i -c write (iout,*) "Number of loop steps in EGB:",ind -cccc energy_dec=.false. - return - end -C----------------------------------------------------------------------------- - subroutine egb_short(evdw,evdw_p,evdw_m) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - include 'COMMON.CONTROL' - logical lprn - evdw=0.0D0 - evdw_p=0.0D0 - evdw_m=0.0D0 -ccccc energy_dec=.false. -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.false. - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) -c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) -c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, -c & 1.0d0/vbld(j+nres) -c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij -c for diagnostics; uncomment -c rij_shift=1.2*sig0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 -cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt -c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, -c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 - evdwij=evdwij*eps2rt*eps3rt -#ifdef TSCSC - if (bb(itypi,itypj).gt.0) then - evdw_p=evdw_p+evdwij*sss - else - evdw_m=evdw_m+evdwij*sss - endif -#else - evdw=evdw+evdwij*sss -#endif - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij - -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -c fac=0.0d0 -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. -#ifdef TSCSC - if (bb(itypi,itypj).gt.0) then - call sc_grad_scale_T(sss) - else - call sc_grad_scale(sss) - endif -#else - call sc_grad_scale(sss) -#endif - endif - enddo ! j - enddo ! iint - enddo ! i -c write (iout,*) "Number of loop steps in EGB:",ind -cccc energy_dec=.false. - return - end -C----------------------------------------------------------------------------- - subroutine egbv_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne-Vorobjev potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - common /srutu/ icall - logical lprn - evdw=0.0D0 -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.true. - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - sig0ij=sigma(itypi,itypj) - r0ij=r0(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+r0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+(evdwij+e_augm)*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0), - & chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij+e_augm - endif -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac-2*expon*rrij*e_augm -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad_scale(1.0d0-sss) - endif - enddo ! j - enddo ! iint - enddo ! i - end -C----------------------------------------------------------------------------- - subroutine egbv_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne-Vorobjev potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - common /srutu/ icall - logical lprn - evdw=0.0D0 -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.true. - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(j+nres) - sig0ij=sigma(itypi,itypj) - r0ij=r0(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+r0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+(evdwij+e_augm)*sss - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0), - & chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij+e_augm - endif -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac-2*expon*rrij*e_augm -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad_scale(sss) - endif - enddo ! j - enddo ! iint - enddo ! i - end -C---------------------------------------------------------------------------- - subroutine sc_grad_scale(scalfac) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.CALC' - include 'COMMON.IOUNITS' - double precision dcosom1(3),dcosom2(3) - double precision scalfac - eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 - eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 - eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 - & -2.0D0*alf12*eps3der+sigder*sigsq_om12 -c diagnostics only -c eom1=0.0d0 -c eom2=0.0d0 -c eom12=evdwij*eps1_om12 -c end diagnostics -c write (iout,*) "eps2der",eps2der," eps3der",eps3der, -c & " sigder",sigder -c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 -c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - do k=1,3 - gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac - enddo -c write (iout,*) "gg",(gg(k),k=1,3) - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac - gvdwx(k,j)=gvdwx(k,j)+gg(k) - & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac -c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) -c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv -c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) -c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - enddo -C -C Calculate the components of the gradient in DC and X -C - do l=1,3 - gvdwc(l,i)=gvdwc(l,i)-gg(l) - gvdwc(l,j)=gvdwc(l,j)+gg(l) - enddo - return - end -C---------------------------------------------------------------------------- - subroutine sc_grad_scale_T(scalfac) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.CALC' - include 'COMMON.IOUNITS' - double precision dcosom1(3),dcosom2(3) - double precision scalfac - eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 - eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 - eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 - & -2.0D0*alf12*eps3der+sigder*sigsq_om12 -c diagnostics only -c eom1=0.0d0 -c eom2=0.0d0 -c eom12=evdwij*eps1_om12 -c end diagnostics -c write (iout,*) "eps2der",eps2der," eps3der",eps3der, -c & " sigder",sigder -c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 -c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - do k=1,3 - gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac - enddo -c write (iout,*) "gg",(gg(k),k=1,3) - do k=1,3 - gvdwxT(k,i)=gvdwxT(k,i)-gg(k) - & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac - gvdwxT(k,j)=gvdwxT(k,j)+gg(k) - & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac -c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) -c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv -c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) -c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - enddo -C -C Calculate the components of the gradient in DC and X -C - do l=1,3 - gvdwcT(l,i)=gvdwcT(l,i)-gg(l) - gvdwcT(l,j)=gvdwcT(l,j)+gg(l) - enddo - return - end - -C-------------------------------------------------------------------------- - subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) -C -C This subroutine calculates the average interaction energy and its gradient -C in the virtual-bond vectors between non-adjacent peptide groups, based on -C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. -C The potential depends both on the distance of peptide-group centers and on -C the orientation of the CA-CA virtual bonds. -C - implicit real*8 (a-h,o-z) -#ifdef MPI - include 'mpif.h' -#endif - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - include 'COMMON.TIME1' - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), - & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) - double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), - & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) - common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, - & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, - & num_conti,j1,j2 -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - double precision scal_el /1.0d0/ -#else - double precision scal_el /0.5d0/ -#endif -C 12/13/98 -C 13-go grudnia roku pamietnego... - double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, - & 0.0d0,1.0d0,0.0d0, - & 0.0d0,0.0d0,1.0d0/ -cd write(iout,*) 'In EELEC' -cd do i=1,nloctyp -cd write(iout,*) 'Type',i -cd write(iout,*) 'B1',B1(:,i) -cd write(iout,*) 'B2',B2(:,i) -cd write(iout,*) 'CC',CC(:,:,i) -cd write(iout,*) 'DD',DD(:,:,i) -cd write(iout,*) 'EE',EE(:,:,i) -cd enddo -cd call check_vecgrad -cd stop - if (icheckgrad.eq.1) then - do i=1,nres-1 - fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) - do k=1,3 - dc_norm(k,i)=dc(k,i)*fac - enddo -c write (iout,*) 'i',i,' fac',fac - enddo - endif - if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. - & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then -c call vec_and_deriv -#ifdef TIMING - time01=MPI_Wtime() -#endif - call set_matrices -#ifdef TIMING - time_mat=time_mat+MPI_Wtime()-time01 -#endif - endif -cd do i=1,nres-1 -cd write (iout,*) 'i=',i -cd do k=1,3 -cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) -cd enddo -cd do k=1,3 -cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') -cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) -cd enddo -cd enddo - t_eelecij=0.0d0 - ees=0.0D0 - evdw1=0.0D0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 - ind=0 - do i=1,nres - num_cont_hb(i)=0 - enddo -cd print '(a)','Enter EELEC' -cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e - do i=1,nres - gel_loc_loc(i)=0.0d0 - gcorr_loc(i)=0.0d0 - enddo -c -c -c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms -C -C Loop over i,i+2 and i,i+3 pairs of the peptide groups -C - do i=iturn3_start,iturn3_end - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 - call eelecij_scale(i,i+2,ees,evdw1,eel_loc) - if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) - num_cont_hb(i)=num_conti - enddo - do i=iturn4_start,iturn4_end - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=num_cont_hb(i) - call eelecij_scale(i,i+3,ees,evdw1,eel_loc) - if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4) - num_cont_hb(i)=num_conti - enddo ! i -c -c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 -c - do i=iatel_s,iatel_e - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi -c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) - num_conti=num_cont_hb(i) - do j=ielstart(i),ielend(i) - call eelecij_scale(i,j,ees,evdw1,eel_loc) - enddo ! j - num_cont_hb(i)=num_conti - enddo ! i -c write (iout,*) "Number of loop steps in EELEC:",ind -cd do i=1,nres -cd write (iout,'(i3,3f10.5,5x,3f10.5)') -cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) -cd enddo -c 12/7/99 Adam eello_turn3 will be considered as a separate energy term -ccc eel_loc=eel_loc+eello_turn3 -cd print *,"Processor",fg_rank," t_eelecij",t_eelecij - return - end -C------------------------------------------------------------------------------- - subroutine eelecij_scale(i,j,ees,evdw1,eel_loc) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - include 'COMMON.TIME1' - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), - & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) - double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), - & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) - common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, - & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, - & num_conti,j1,j2 -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - double precision scal_el /1.0d0/ -#else - double precision scal_el /0.5d0/ -#endif -C 12/13/98 -C 13-go grudnia roku pamietnego... - double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, - & 0.0d0,1.0d0,0.0d0, - & 0.0d0,0.0d0,1.0d0/ -c time00=MPI_Wtime() -cd write (iout,*) "eelecij",i,j - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - aaa=app(iteli,itelj) - bbb=bpp(iteli,itelj) - ael6i=ael6(iteli,itelj) - ael3i=ael3(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - rmij=1.0D0/rij -c For extracting the short-range part of Evdwpp - sss=sscale(rij/rpp(iteli,itelj)) - - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj - cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij - cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij - fac=cosa-3.0D0*cosb*cosg - ev1=aaa*r6ij*r6ij -c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - fac3=ael6i*r6ij - fac4=ael3i*r3ij - evdwij=ev1+ev2 - el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - eesij=el1+el2 -C 12/26/95 - for the evaluation of multi-body H-bonding interactions - ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) - ees=ees+eesij - evdw1=evdw1+evdwij*(1.0d0-sss) -cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, -cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, -cd & xmedi,ymedi,zmedi,xj,yj,zj - - if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss - write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij - endif - -C -C Calculate contributions to the Cartesian gradient. -C -#ifdef SPLITELE - facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss) - facel=-3*rrmij*(el1+eesij) - fac1=fac - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=facel*xj - ggg(2)=facel*yj - ggg(3)=facel*zj -c do k=1,3 -c ghalf=0.5D0*ggg(k) -c gelc(k,i)=gelc(k,i)+ghalf -c gelc(k,j)=gelc(k,j)+ghalf -c enddo -c 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gelc_long(k,j)=gelc_long(k,j)+ggg(k) - gelc_long(k,i)=gelc_long(k,i)-ggg(k) - enddo -* -* Loop over residues i+1 thru j-1. -* -cgrad do k=i+1,j-1 -cgrad do l=1,3 -cgrad gelc(l,k)=gelc(l,k)+ggg(l) -cgrad enddo -cgrad enddo - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj -c do k=1,3 -c ghalf=0.5D0*ggg(k) -c gvdwpp(k,i)=gvdwpp(k,i)+ghalf -c gvdwpp(k,j)=gvdwpp(k,j)+ghalf -c enddo -c 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo -* -* Loop over residues i+1 thru j-1. -* -cgrad do k=i+1,j-1 -cgrad do l=1,3 -cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) -cgrad enddo -cgrad enddo -#else - facvdw=ev1+evdwij*(1.0d0-sss) - facel=el1+eesij - fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=fac*xj - ggg(2)=fac*yj - ggg(3)=fac*zj -c do k=1,3 -c ghalf=0.5D0*ggg(k) -c gelc(k,i)=gelc(k,i)+ghalf -c gelc(k,j)=gelc(k,j)+ghalf -c enddo -c 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gelc_long(k,j)=gelc(k,j)+ggg(k) - gelc_long(k,i)=gelc(k,i)-ggg(k) - enddo -* -* Loop over residues i+1 thru j-1. -* -cgrad do k=i+1,j-1 -cgrad do l=1,3 -cgrad gelc(l,k)=gelc(l,k)+ggg(l) -cgrad enddo -cgrad enddo -c 9/28/08 AL Gradient compotents will be summed only at the end - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo -#endif -* -* Angular part -* - ecosa=2.0D0*fac3*fac1+fac4 - fac4=-3.0D0*fac4 - fac3=-6.0D0*fac3 - ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) - ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo -cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), -cd & (dcosg(k),k=1,3) - do k=1,3 - ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) - enddo -c do k=1,3 -c ghalf=0.5D0*ggg(k) -c gelc(k,i)=gelc(k,i)+ghalf -c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) -c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) -c gelc(k,j)=gelc(k,j)+ghalf -c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) -c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) -c enddo -cgrad do k=i+1,j-1 -cgrad do l=1,3 -cgrad gelc(l,k)=gelc(l,k)+ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gelc(k,i)=gelc(k,i) - & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gelc(k,j)=gelc(k,j) - & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gelc_long(k,j)=gelc_long(k,j)+ggg(k) - gelc_long(k,i)=gelc_long(k,i)-ggg(k) - enddo - IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 - & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -C -C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction -C energy of a peptide unit is assumed in the form of a second-order -C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. -C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms -C are computed for EVERY pair of non-contiguous peptide groups. -C - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - kkk=0 - do k=1,2 - do l=1,2 - kkk=kkk+1 - muij(kkk)=mu(k,i)*mu(l,j) - enddo - enddo -cd write (iout,*) 'EELEC: i',i,' j',j -cd write (iout,*) 'j',j,' j1',j1,' j2',j2 -cd write(iout,*) 'muij',muij - ury=scalar(uy(1,i),erij) - urz=scalar(uz(1,i),erij) - vry=scalar(uy(1,j),erij) - vrz=scalar(uz(1,j),erij) - a22=scalar(uy(1,i),uy(1,j))-3*ury*vry - a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz - a32=scalar(uz(1,i),uy(1,j))-3*urz*vry - a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz - fac=dsqrt(-ael6i)*r3ij - a22=a22*fac - a23=a23*fac - a32=a32*fac - a33=a33*fac -cd write (iout,'(4i5,4f10.5)') -cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 -cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij -cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i), -cd & uy(:,j),uz(:,j) -cd write (iout,'(4f10.5)') -cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)), -cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j)) -cd write (iout,'(4f10.5)') ury,urz,vry,vrz -cd write (iout,'(9f10.5/)') -cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij -C Derivatives of the elements of A in virtual-bond vectors - call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) - do k=1,3 - uryg(k,1)=scalar(erder(1,k),uy(1,i)) - uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) - uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) - urzg(k,1)=scalar(erder(1,k),uz(1,i)) - urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) - urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) - vryg(k,1)=scalar(erder(1,k),uy(1,j)) - vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) - vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) - vrzg(k,1)=scalar(erder(1,k),uz(1,j)) - vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) - vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) - enddo -C Compute radial contributions to the gradient - facr=-3.0d0*rrmij - a22der=a22*facr - a23der=a23*facr - a32der=a32*facr - a33der=a33*facr - agg(1,1)=a22der*xj - agg(2,1)=a22der*yj - agg(3,1)=a22der*zj - agg(1,2)=a23der*xj - agg(2,2)=a23der*yj - agg(3,2)=a23der*zj - agg(1,3)=a32der*xj - agg(2,3)=a32der*yj - agg(3,3)=a32der*zj - agg(1,4)=a33der*xj - agg(2,4)=a33der*yj - agg(3,4)=a33der*zj -C Add the contributions coming from er - fac3=-3.0d0*fac - do k=1,3 - agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) - agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) - agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) - agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) - enddo - do k=1,3 -C Derivatives in DC(i) -cgrad ghalf1=0.5d0*agg(k,1) -cgrad ghalf2=0.5d0*agg(k,2) -cgrad ghalf3=0.5d0*agg(k,3) -cgrad ghalf4=0.5d0*agg(k,4) - aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) - & -3.0d0*uryg(k,2)*vry)!+ghalf1 - aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) - & -3.0d0*uryg(k,2)*vrz)!+ghalf2 - aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) - & -3.0d0*urzg(k,2)*vry)!+ghalf3 - aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) - & -3.0d0*urzg(k,2)*vrz)!+ghalf4 -C Derivatives in DC(i+1) - aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) - & -3.0d0*uryg(k,3)*vry)!+agg(k,1) - aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) - & -3.0d0*uryg(k,3)*vrz)!+agg(k,2) - aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) - & -3.0d0*urzg(k,3)*vry)!+agg(k,3) - aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) - & -3.0d0*urzg(k,3)*vrz)!+agg(k,4) -C Derivatives in DC(j) - aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) - & -3.0d0*vryg(k,2)*ury)!+ghalf1 - aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) - & -3.0d0*vrzg(k,2)*ury)!+ghalf2 - aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) - & -3.0d0*vryg(k,2)*urz)!+ghalf3 - aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) - & -3.0d0*vrzg(k,2)*urz)!+ghalf4 -C Derivatives in DC(j+1) or DC(nres-1) - aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) - & -3.0d0*vryg(k,3)*ury) - aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) - & -3.0d0*vrzg(k,3)*ury) - aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) - & -3.0d0*vryg(k,3)*urz) - aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) - & -3.0d0*vrzg(k,3)*urz) -cgrad if (j.eq.nres-1 .and. i.lt.j-2) then -cgrad do l=1,4 -cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l) -cgrad enddo -cgrad endif - enddo - acipa(1,1)=a22 - acipa(1,2)=a23 - acipa(2,1)=a32 - acipa(2,2)=a33 - a22=-a22 - a23=-a23 - do l=1,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - if (j.lt.nres-1) then - a22=-a22 - a32=-a32 - do l=1,3,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - else - a22=-a22 - a23=-a23 - a32=-a32 - a33=-a33 - do l=1,4 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - endif - ENDIF ! WCORR - IF (wel_loc.gt.0.0d0) THEN -C Contribution to the local-electrostatic energy coming from the i-j pair - eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) - & +a33*muij(4) -cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'eelloc',i,j,eel_loc_ij - - eel_loc=eel_loc+eel_loc_ij -C Partial derivatives in virtual-bond dihedral angles gamma - if (i.gt.1) - & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ - & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) - & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j) - gel_loc_loc(j-1)=gel_loc_loc(j-1)+ - & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) - & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j) -C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) - do l=1,3 - ggg(l)=agg(l,1)*muij(1)+ - & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4) - gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) - gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) -cgrad ghalf=0.5d0*ggg(l) -cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf -cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf - enddo -cgrad do k=i+1,j2 -cgrad do l=1,3 -cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l) -cgrad enddo -cgrad enddo -C Remaining derivatives of eello - do l=1,3 - gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ - & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4) - gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ - & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) - gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ - & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) - gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ - & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) - enddo - ENDIF -C Change 12/26/95 to calculate four-body contributions to H-bonding energy -c if (j.gt.i+1 .and. num_conti.le.maxconts) then - if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 - & .and. num_conti.le.maxconts) then -c write (iout,*) i,j," entered corr" -C -C Calculate the contact function. The ith column of the array JCONT will -C contain the numbers of atoms that make contacts with the atom I (of numbers -C greater than I). The arrays FACONT and GACONT will contain the values of -C the contact function and its derivative. -c r0ij=1.02D0*rpp(iteli,itelj) -c r0ij=1.11D0*rpp(iteli,itelj) - r0ij=2.20D0*rpp(iteli,itelj) -c r0ij=1.55D0*rpp(iteli,itelj) - call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) - if (fcont.gt.0.0D0) then - num_conti=num_conti+1 - if (num_conti.gt.maxconts) then - write (iout,*) 'WARNING - max. # of contacts exceeded;', - & ' will skip next contacts for this conf.' - else - jcont_hb(num_conti,i)=j -cd write (iout,*) "i",i," j",j," num_conti",num_conti, -cd & " jcont_hb",jcont_hb(num_conti,i) - IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. - & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el -C terms. - d_cont(num_conti,i)=rij -cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij -C --- Electrostatic-interaction matrix --- - a_chuj(1,1,num_conti,i)=a22 - a_chuj(1,2,num_conti,i)=a23 - a_chuj(2,1,num_conti,i)=a32 - a_chuj(2,2,num_conti,i)=a33 -C --- Gradient of rij - do kkk=1,3 - grij_hb_cont(kkk,num_conti,i)=erij(kkk) - enddo - kkll=0 - do k=1,2 - do l=1,2 - kkll=kkll+1 - do m=1,3 - a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll) - a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll) - a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll) - a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll) - a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll) - enddo - enddo - enddo - ENDIF - IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN -C Calculate contact energies - cosa4=4.0D0*cosa - wij=cosa-3.0D0*cosb*cosg - cosbg1=cosb+cosg - cosbg2=cosb-cosg -c fac3=dsqrt(-ael6i)/r0ij**3 - fac3=dsqrt(-ael6i)*r3ij -c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) - ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 - if (ees0tmp.gt.0) then - ees0pij=dsqrt(ees0tmp) - else - ees0pij=0 - endif -c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) - ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 - if (ees0tmp.gt.0) then - ees0mij=dsqrt(ees0tmp) - else - ees0mij=0 - endif -c ees0mij=0.0D0 - ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) - ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) -C Diagnostics. Comment out or remove after debugging! -c ees0p(num_conti,i)=0.5D0*fac3*ees0pij -c ees0m(num_conti,i)=0.5D0*fac3*ees0mij -c ees0m(num_conti,i)=0.0D0 -C End diagnostics. -c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, -c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont -C Angular derivatives of the contact function - ees0pij1=fac3/ees0pij - ees0mij1=fac3/ees0mij - fac3p=-3.0D0*fac3*rrmij - ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) - ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) -c ees0mij1=0.0D0 - ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) - ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) - ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) - ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) - ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) - ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) - ecosap=ecosa1+ecosa2 - ecosbp=ecosb1+ecosb2 - ecosgp=ecosg1+ecosg2 - ecosam=ecosa1-ecosa2 - ecosbm=ecosb1-ecosb2 - ecosgm=ecosg1-ecosg2 -C Diagnostics -c ecosap=ecosa1 -c ecosbp=ecosb1 -c ecosgp=ecosg1 -c ecosam=0.0D0 -c ecosbm=0.0D0 -c ecosgm=0.0D0 -C End diagnostics - facont_hb(num_conti,i)=fcont - fprimcont=fprimcont/rij -cd facont_hb(num_conti,i)=1.0D0 -C Following line is for diagnostics. -cd fprimcont=0.0D0 - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo - do k=1,3 - gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) - gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) - enddo - gggp(1)=gggp(1)+ees0pijp*xj - gggp(2)=gggp(2)+ees0pijp*yj - gggp(3)=gggp(3)+ees0pijp*zj - gggm(1)=gggm(1)+ees0mijp*xj - gggm(2)=gggm(2)+ees0mijp*yj - gggm(3)=gggm(3)+ees0mijp*zj -C Derivatives due to the contact function - gacont_hbr(1,num_conti,i)=fprimcont*xj - gacont_hbr(2,num_conti,i)=fprimcont*yj - gacont_hbr(3,num_conti,i)=fprimcont*zj - do k=1,3 -c -c 10/24/08 cgrad and ! comments indicate the parts of the code removed -c following the change of gradient-summation algorithm. -c -cgrad ghalfp=0.5D0*gggp(k) -cgrad ghalfm=0.5D0*gggm(k) - gacontp_hb1(k,num_conti,i)=!ghalfp - & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontp_hb2(k,num_conti,i)=!ghalfp - & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontp_hb3(k,num_conti,i)=gggp(k) - gacontm_hb1(k,num_conti,i)=!ghalfm - & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontm_hb2(k,num_conti,i)=!ghalfm - & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontm_hb3(k,num_conti,i)=gggm(k) - enddo - ENDIF ! wcorr - endif ! num_conti.le.maxconts - endif ! fcont.gt.0 - endif ! j.gt.i+1 - if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then - do k=1,4 - do l=1,3 - ghalf=0.5d0*agg(l,k) - aggi(l,k)=aggi(l,k)+ghalf - aggi1(l,k)=aggi1(l,k)+agg(l,k) - aggj(l,k)=aggj(l,k)+ghalf - enddo - enddo - if (j.eq.nres-1 .and. i.lt.j-2) then - do k=1,4 - do l=1,3 - aggj1(l,k)=aggj1(l,k)+agg(l,k) - enddo - enddo - endif - endif -c t_eelecij=t_eelecij+MPI_Wtime()-time00 - return - end -C----------------------------------------------------------------------- - subroutine evdwpp_short(evdw1) -C -C Compute Evdwpp -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - dimension ggg(3) -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions -#ifdef MOMENT - double precision scal_el /1.0d0/ -#else - double precision scal_el /0.5d0/ -#endif - evdw1=0.0D0 -c write (iout,*) "iatel_s_vdw",iatel_s_vdw, -c & " iatel_e_vdw",iatel_e_vdw - call flush(iout) - do i=iatel_s_vdw,iatel_e_vdw - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 -c write (iout,*) 'i',i,' ielstart',ielstart_vdw(i), -c & ' ielend',ielend_vdw(i) - call flush(iout) - do j=ielstart_vdw(i),ielend_vdw(i) - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - aaa=app(iteli,itelj) - bbb=bpp(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - sss=sscale(rij/rpp(iteli,itelj)) - if (sss.gt.0.0d0) then - rmij=1.0D0/rij - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - ev1=aaa*r6ij*r6ij -c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - evdwij=ev1+ev2 - if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss - endif - evdw1=evdw1+evdwij*sss -C -C Calculate contributions to the Cartesian gradient. -C - facvdw=-6*rrmij*(ev1+evdwij)*sss - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo - endif - enddo ! j - enddo ! i - return - end -C----------------------------------------------------------------------------- - subroutine escp_long(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - - sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - - if (sss.lt.1.0d0) then - - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss) - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij*(1.0d0-sss) - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw2',i,j,evdwij -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij*(1.0d0-sss) - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -C Uncomment following three lines for SC-p interactions -c do k=1,3 -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -c enddo -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - endif - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time the factor EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C----------------------------------------------------------------------------- - subroutine escp_short(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - - sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - - if (sss.gt.0.0d0) then - - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+(e1+e2)*sss - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij*sss - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw2',i,j,evdwij -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij*sss - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -C Uncomment following three lines for SC-p interactions -c do k=1,3 -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -c enddo -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - endif - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time the factor EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end diff --git a/source/unres/src_MD_DFA/energy_p_new_barrier.F b/source/unres/src_MD_DFA/energy_p_new_barrier.F deleted file mode 100644 index e9e769a..0000000 --- a/source/unres/src_MD_DFA/energy_p_new_barrier.F +++ /dev/null @@ -1,9253 +0,0 @@ - subroutine etotal(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.LOCAL' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' -#ifdef MPI -c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, -c & " nfgtasks",nfgtasks - if (nfgtasks.gt.1) then -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR) -c print *,"Processor",myrank," BROADCAST iorder" -C FG master sets up the WEIGHTS_ array which will be broadcast to the -C FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor - weights_(22)=wsct -C FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -C FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - wsct=weights(22) - endif - time_Bcast=time_Bcast+MPI_Wtime()-time00 - time_Bcastw=time_Bcastw+MPI_Wtime()-time00 -c call chainbuild_cart - endif -c print *,'Processor',myrank,' calling etotal ipot=',ipot -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#else -c if (modecalc.eq.12.or.modecalc.eq.14) then -c call int_from_cart1(.false.) -c endif -#endif -#ifdef TIMING -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif -#endif -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105,106) ipot -C Lennard-Jones potential. - 101 call elj(evdw,evdw_p,evdw_m) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk(evdw,evdw_p,evdw_m) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp(evdw,evdw_p,evdw_m) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb(evdw,evdw_p,evdw_m) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv(evdw,evdw_p,evdw_m) - goto 107 -C Soft-sphere potential - 106 call e_softsphere(evdw) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 continue - -C BARTEK for dfa test! - if (wdfa_dist.gt.0) call edfad(edfadis) -c print*, 'edfad is finished!', edfadis - if (wdfa_tor.gt.0) call edfat(edfator) -c print*, 'edfat is finished!', edfator - if (wdfa_nei.gt.0) call edfan(edfanei) -c print*, 'edfan is finished!', edfanei - if (wdfa_beta.gt.0) call edfab(edfabet) -c print*, 'edfab is finished!', edfabet -c print *,"Processor",myrank," computed USCSC" -#ifdef TIMING -#ifdef MPI - time01=MPI_Wtime() -#else - time00=tcpu() -#endif -#endif - call vec_and_deriv -#ifdef TIMING -#ifdef MPI - time_vec=time_vec+MPI_Wtime()-time01 -#else - time_vec=time_vec+tcpu()-time01 -#endif -#endif -c print *,"Processor",myrank," left VEC_AND_DERIV" - if (ipot.lt.6) then -#ifdef SPLITELE - if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#else - if (welec.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#endif - call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) - else - ees=0.0d0 - evdw1=0.0d0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 - endif - else -c write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, - & eello_turn4) - endif -c print *,"Processor",myrank," computed UELEC" -C -C Calculate excluded-volume interaction energy between peptide groups -C and side chains. -C - if (ipot.lt.6) then - if(wscp.gt.0d0) then - call escp(evdw2,evdw2_14) - else - evdw2=0 - evdw2_14=0 - endif - else -c write (iout,*) "Soft-sphere SCP potential" - call escp_soft_sphere(evdw2,evdw2_14) - endif -c -c Calculate the bond-stretching energy -c - call ebond(estr) -C -C Calculate the disulfide-bridge and other energy and the contributions -C from other distance constraints. -cd print *,'Calling EHPB' - call edis(ehpb) -cd print *,'EHPB exitted succesfully.' -C -C Calculate the virtual-bond-angle energy. -C - if (wang.gt.0d0) then - call ebend(ebe) - else - ebe=0 - endif -c print *,"Processor",myrank," computed UB" -C -C Calculate the SC local energy. -C - call esc(escloc) -c print *,"Processor",myrank," computed USC" -C -C Calculate the virtual-bond torsional energy. -C -cd print *,'nterm=',nterm - if (wtor.gt.0) then - call etor(etors,edihcnstr) - else - etors=0 - edihcnstr=0 - endif -c print *,"Processor",myrank," computed Utor" -C -C 6/23/01 Calculate double-torsional energy -C - if (wtor_d.gt.0) then - call etor_d(etors_d) - else - etors_d=0 - endif -c print *,"Processor",myrank," computed Utord" -C -C 21/5/07 Calculate local sicdechain correlation energy -C - if (wsccor.gt.0.0d0) then - call eback_sc_corr(esccor) - else - esccor=0.0d0 - endif -c print *,"Processor",myrank," computed Usccorr" -C -C 12/1/95 Multi-body terms -C - n_corr=0 - n_corr1=0 - if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 - & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then - call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1, -cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -cd write (iout,*) "multibody_hb ecorr",ecorr - endif -c print *,"Processor",myrank," computed Ucorr" -C -C If performing constraint dynamics, call the constraint energy -C after the equilibration time - if(usampl.and.totT.gt.eq_time) then - call EconstrQ - call Econstr_back - else - Uconst=0.0d0 - Uconst_back=0.0d0 - endif -#ifdef TIMING -#ifdef MPI - time_enecalc=time_enecalc+MPI_Wtime()-time00 -#else - time_enecalc=time_enecalc+tcpu()-time00 -#endif -#endif -c print *,"Processor",myrank," computed Uconstr" -#ifdef TIMING -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif -#endif -c -C Sum the energies -C - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(19)=edihcnstr - energia(17)=estr - energia(20)=Uconst+Uconst_back - energia(21)=esccor - energia(22)=evdw_p - energia(23)=evdw_m - energia(24)=edfadis - energia(25)=edfator - energia(26)=edfanei - energia(27)=edfabet -c print *," Processor",myrank," calls SUM_ENERGY" - call sum_energy(energia,.true.) -c print *," Processor",myrank," left SUM_ENERGY" -#ifdef TIMING -#ifdef MPI - time_sumene=time_sumene+MPI_Wtime()-time00 -#else - time_sumene=time_sumene+tcpu()-time00 -#endif -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sum_energy(energia,reduce) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene),enebuff(0:n_ene+1) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - logical reduce -#ifdef MPI - if (nfgtasks.gt.1 .and. reduce) then -#ifdef DEBUG - write (iout,*) "energies before REDUCE" - call enerprint(energia) - call flush(iout) -#endif - do i=0,n_ene - enebuff(i)=energia(i) - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_e=time_barrier_e+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(enebuff(0),energia(0),n_ene+1, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) -#ifdef DEBUG - write (iout,*) "energies after REDUCE" - call enerprint(energia) - call flush(iout) -#endif - time_Reduce=time_Reduce+MPI_Wtime()-time00 - endif - if (fg_rank.eq.0) then -#endif -#ifdef TSCSC - evdw=energia(22)+wsct*energia(23) -#else - evdw=energia(1) -#endif -#ifdef SCP14 - evdw2=energia(2)+energia(18) - evdw2_14=energia(18) -#else - evdw2=energia(2) -#endif -#ifdef SPLITELE - ees=energia(3) - evdw1=energia(16) -#else - ees=energia(3) - evdw1=0.0d0 -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eturn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) - edfadis=energia(24) - edfator=energia(25) - edfanei=energia(26) - edfabet=energia(27) -#ifdef SPLITELE - etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor - & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei - & +wdfa_beta*edfabet -#else - etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor - & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei - & +wdfa_beta*edfabet -#endif - energia(0)=etot -c detecting NaNQ -#ifdef ISNAN -#ifdef AIX - if (isnan(etot).ne.0) energia(0)=1.0d+99 -#else - if (isnan(etot)) energia(0)=1.0d+99 -#endif -#else - i=0 -#ifdef WINPGI - idumm=proc_proc(etot,i) -#else - call proc_proc(etot,i) -#endif - if(i.eq.1)energia(0)=1.0d+99 -#endif -#ifdef MPI - endif -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sum_gradient - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include 'mpif.h' -#endif - double precision gradbufc(3,maxres),gradbufx(3,maxres), - & glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres) - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - include 'COMMON.MAXGRAD' - include 'COMMON.SCCOR' -#ifdef TIMING -#ifdef MPI - time01=MPI_Wtime() -#else - time01=tcpu() -#endif -#endif -#ifdef DEBUG - write (iout,*) "sum_gradient gvdwc, gvdwx" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)') - & i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3), - & (gvdwcT(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef MPI -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (nfgtasks.gt.1 .and. fg_rank.eq.0) - & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif -C -C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient -C in virtual-bond-vector coordinates -C -#ifdef DEBUG -c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" -c do i=1,nres-1 -c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') -c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) -c enddo -c write (iout,*) "gel_loc_tur3 gel_loc_turn4" -c do i=1,nres-1 -c write (iout,'(i5,3f10.5,2x,f10.5)') -c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) -c enddo - write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3), - & g_corr5_loc(i) - enddo - call flush(iout) -#endif -#ifdef SPLITELE -#ifdef TSCSC - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i)+ - & wdfa_dist*gdfad(j,i)+ - & wdfa_tor*gdfat(j,i)+ - & wdfa_nei*gdfan(j,i)+ - & wdfa_beta*gdfab(j,i) - enddo - enddo -#else - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i)+ - & wdfa_dist*gdfad(j,i)+ - & wdfa_tor*gdfat(j,i)+ - & wdfa_nei*gdfan(j,i)+ - & wdfa_beta*gdfab(j,i) - enddo - enddo -#endif -#else - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+ - & wbond*gradb(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i)+ - & wdfa_dist*gdfad(j,i)+ - & wdfa_tor*gdfat(j,i)+ - & wdfa_nei*gdfan(j,i)+ - & wdfa_beta*gdfab(j,i) - enddo - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -#ifdef DEBUG - write (iout,*) "gradbufc before allreduce" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - do i=1,nres - do j=1,3 - gradbufc_sum(j,i)=gradbufc(j,i) - enddo - enddo -c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, -c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) -c time_reduce=time_reduce+MPI_Wtime()-time00 -#ifdef DEBUG -c write (iout,*) "gradbufc_sum after allreduce" -c do i=1,nres -c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) -c enddo -c call flush(iout) -#endif -#ifdef TIMING -c time_allreduce=time_allreduce+MPI_Wtime()-time00 -#endif - do i=nnt,nres - do k=1,3 - gradbufc(k,i)=0.0d0 - enddo - enddo -#ifdef DEBUG - write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end - write (iout,*) (i," jgrad_start",jgrad_start(i), - & " jgrad_end ",jgrad_end(i), - & i=igrad_start,igrad_end) -#endif -c -c Obsolete and inefficient code; we can make the effort O(n) and, therefore, -c do not parallelize this part. -c -c do i=igrad_start,igrad_end -c do j=jgrad_start(i),jgrad_end(i) -c do k=1,3 -c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) -c enddo -c enddo -c enddo - do j=1,3 - gradbufc(j,nres-1)=gradbufc_sum(j,nres) - enddo - do i=nres-2,nnt,-1 - do j=1,3 - gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) - enddo - enddo -#ifdef DEBUG - write (iout,*) "gradbufc after summing" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - else -#endif -#ifdef DEBUG - write (iout,*) "gradbufc" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - do i=1,nres - do j=1,3 - gradbufc_sum(j,i)=gradbufc(j,i) - gradbufc(j,i)=0.0d0 - enddo - enddo - do j=1,3 - gradbufc(j,nres-1)=gradbufc_sum(j,nres) - enddo - do i=nres-2,nnt,-1 - do j=1,3 - gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) - enddo - enddo -c do i=nnt,nres-1 -c do k=1,3 -c gradbufc(k,i)=0.0d0 -c enddo -c do j=i+1,nres -c do k=1,3 -c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) -c enddo -c enddo -c enddo -#ifdef DEBUG - write (iout,*) "gradbufc after summing" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef MPI - endif -#endif - do k=1,3 - gradbufc(k,nres)=0.0d0 - enddo - do i=1,nct - do j=1,3 -#ifdef SPLITELE - gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ - & wel_loc*gel_loc(j,i)+ - & 0.5d0*(wscp*gvdwc_scpp(j,i)+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i))+ - & wbond*gradb(j,i)+ - & wcorr*gradcorr(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) -#else - gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ - & wel_loc*gel_loc(j,i)+ - & 0.5d0*(wscp*gvdwc_scpp(j,i)+ - & welec*gelc_long(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i))+ - & wbond*gradb(j,i)+ - & wcorr*gradcorr(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) -#endif -#ifdef TSCSC - gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+ - & wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*gsccorx(j,i) - & +wscloc*gsclocx(j,i) -#else - gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*gsccorx(j,i) - & +wscloc*gsclocx(j,i) -#endif - enddo - enddo -#ifdef DEBUG - write (iout,*) "gloc before adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) - & +wcorr5*g_corr5_loc(i) - & +wcorr6*g_corr6_loc(i) - & +wturn4*gel_loc_turn4(i) - & +wturn3*gel_loc_turn3(i) - & +wturn6*gel_loc_turn6(i) - & +wel_loc*gel_loc_loc(i) - & +wsccor*gsccor_loc(i) - enddo -#ifdef DEBUG - write (iout,*) "gloc after adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - do j=1,3 - do i=1,nres - gradbufc(j,i)=gradc(j,i,icg) - gradbufx(j,i)=gradx(j,i,icg) - enddo - enddo - do i=1,4*nres - glocbuf(i)=gloc(i,icg) - enddo -#ifdef DEBUG - write (iout,*) "gloc_sc before reduce" - do i=1,nres - do j=1,3 - write (iout,*) i,j,gloc_sc(j,i,icg) - enddo - enddo -#endif - do i=1,nres - do j=1,3 - gloc_scbuf(j,i)=gloc_sc(j,i,icg) - enddo - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_g=time_barrier_g+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -#ifdef DEBUG - write (iout,*) "gloc_sc after reduce" - do i=1,nres - do j=1,3 - write (iout,*) i,j,gloc_sc(j,i,icg) - enddo - enddo -#endif -#ifdef DEBUG - write (iout,*) "gloc after reduce" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - endif -#endif - if (gnorm_check) then -c -c Compute the maximum elements of the gradient -c - gvdwc_max=0.0d0 - gvdwc_scp_max=0.0d0 - gelc_max=0.0d0 - gvdwpp_max=0.0d0 - gradb_max=0.0d0 - ghpbc_max=0.0d0 - gradcorr_max=0.0d0 - gel_loc_max=0.0d0 - gcorr3_turn_max=0.0d0 - gcorr4_turn_max=0.0d0 - gradcorr5_max=0.0d0 - gradcorr6_max=0.0d0 - gcorr6_turn_max=0.0d0 - gsccorc_max=0.0d0 - gscloc_max=0.0d0 - gvdwx_max=0.0d0 - gradx_scp_max=0.0d0 - ghpbx_max=0.0d0 - gradxorr_max=0.0d0 - gsccorx_max=0.0d0 - gsclocx_max=0.0d0 - do i=1,nct - gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) - if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm -#ifdef TSCSC - gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i))) - if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm -#endif - gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i))) - if (gvdwc_scp_norm.gt.gvdwc_scp_max) - & gvdwc_scp_max=gvdwc_scp_norm - gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i))) - if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm - gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i))) - if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm - gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i))) - if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm - ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i))) - if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm - gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i))) - if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm - gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i))) - if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm - gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i), - & gcorr3_turn(1,i))) - if (gcorr3_turn_norm.gt.gcorr3_turn_max) - & gcorr3_turn_max=gcorr3_turn_norm - gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i), - & gcorr4_turn(1,i))) - if (gcorr4_turn_norm.gt.gcorr4_turn_max) - & gcorr4_turn_max=gcorr4_turn_norm - gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i))) - if (gradcorr5_norm.gt.gradcorr5_max) - & gradcorr5_max=gradcorr5_norm - gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i))) - if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm - gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i), - & gcorr6_turn(1,i))) - if (gcorr6_turn_norm.gt.gcorr6_turn_max) - & gcorr6_turn_max=gcorr6_turn_norm - gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) - if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm - gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) - if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm - gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) - if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm -#ifdef TSCSC - gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i))) - if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm -#endif - gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i))) - if (gradx_scp_norm.gt.gradx_scp_max) - & gradx_scp_max=gradx_scp_norm - ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i))) - if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm - gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i))) - if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm - gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i))) - if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm - gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i))) - if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm - enddo - if (gradout) then -#ifdef AIX - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif - write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max, - & gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max - close(istat) - if (gvdwc_max.gt.1.0d4) then - write (iout,*) "gvdwc gvdwx gradb gradbx" - do i=nnt,nct - write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i), - & gradb(j,i),gradbx(j,i),j=1,3) - enddo - call pdbout(0.0d0,'cipiszcze',iout) - call flush(iout) - endif - endif - endif -#ifdef DEBUG - write (iout,*) "gradc gradx gloc" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) - enddo -#endif -#ifdef TIMING -#ifdef MPI - time_sumgradient=time_sumgradient+MPI_Wtime()-time01 -#else - time_sumgradient=time_sumgradient+tcpu()-time01 -#endif -#endif - return - end -c------------------------------------------------------------------------------- - subroutine rescale_weights(t_bath) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - double precision kfac /2.4d0/ - double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/ -c facT=temp0/t_bath -c facT=2*temp0/(t_bath+temp0) - if (rescale_mode.eq.0) then - facT=1.0d0 - facT2=1.0d0 - facT3=1.0d0 - facT4=1.0d0 - facT5=1.0d0 - else if (rescale_mode.eq.1) then - facT=kfac/(kfac-1.0d0+t_bath/temp0) - facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) - facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) - facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) - facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) - else if (rescale_mode.eq.2) then - x=t_bath/temp0 - x2=x*x - x3=x2*x - x4=x3*x - x5=x4*x - facT=licznik/dlog(dexp(x)+dexp(-x)) - facT2=licznik/dlog(dexp(x2)+dexp(-x2)) - facT3=licznik/dlog(dexp(x3)+dexp(-x3)) - facT4=licznik/dlog(dexp(x4)+dexp(-x4)) - facT5=licznik/dlog(dexp(x5)+dexp(-x5)) - else - write (iout,*) "Wrong RESCALE_MODE",rescale_mode - write (*,*) "Wrong RESCALE_MODE",rescale_mode -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) -#endif - stop 555 - endif - welec=weights(3)*fact - wcorr=weights(4)*fact3 - wcorr5=weights(5)*fact4 - wcorr6=weights(6)*fact5 - wel_loc=weights(7)*fact2 - wturn3=weights(8)*fact2 - wturn4=weights(9)*fact3 - wturn6=weights(10)*fact5 - wtor=weights(13)*fact - wtor_d=weights(14)*fact2 - wsccor=weights(21)*fact -#ifdef TSCSC -c wsct=t_bath/temp0 - wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0 -#endif - return - end -C------------------------------------------------------------------------ - subroutine enerprint(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.MD' - double precision energia(0:n_ene) - etot=energia(0) -#ifdef TSCSC - evdw=energia(22)+wsct*energia(23) -#else - evdw=energia(1) -#endif - evdw2=energia(2) -#ifdef SCP14 - evdw2=energia(2)+energia(18) -#else - evdw2=energia(2) -#endif - ees=energia(3) -#ifdef SPLITELE - evdw1=energia(16) -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eello_turn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -C Bartek - edfadis = energia(24) - edfator = energia(25) - edfanei = energia(26) - edfabet = energia(27) -#ifdef SPLITELE - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor, - & edihcnstr,ebr*nss, - & Uconst,edfadis,edfator,edfanei,edfabet,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ - & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ - & 'EHPB= ',1pE16.6,' WEIGHT=',1pE16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST= ',1pE16.6,' (Constraint energy)'/ - & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/ - & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/ - & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/ - & 'EDFAB= ',1pE16.6,' (DFA Beta energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#else - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr, - & ebr*nss, - & Uconst,edfadis,edfator,edfanei,edfabet,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST=',1pE16.6,' (Constraint energy)'/ - & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/ - & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/ - & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/ - & 'EDFAB= ',1pE16.6,' (DFA Beta energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#endif - return - end -C----------------------------------------------------------------------- - subroutine elj(evdw,evdw_p,evdw_m) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJ potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C Change 12/1/95 - num_conti=0 -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) -cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -cd & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi -C Change 12/1/95 to calculate four-body interactions - rij=xj*xj+yj*yj+zj*zj - rrij=1.0D0/rij -c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) -#ifdef TSCSC - if (bb(itypi,itypj).gt.0) then - evdw_p=evdw_p+evdwij - else - evdw_m=evdw_m+evdwij - endif -#else - evdw=evdw+evdwij -#endif -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -#ifdef TSCSC - if (bb(itypi,itypj).gt.0.0d0) then - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - else - do k=1,3 - gvdwxT(k,i)=gvdwxT(k,i)-gg(k) - gvdwxT(k,j)=gvdwxT(k,j)+gg(k) - gvdwcT(k,i)=gvdwcT(k,i)-gg(k) - gvdwcT(k,j)=gvdwcT(k,j)+gg(k) - enddo - endif -#else - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo -#endif -cgrad do k=i,j-1 -cgrad do l=1,3 -cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) -cgrad enddo -cgrad enddo -C -C 12/1/95, revised on 5/20/97 -C -C Calculate the contact function. The ith column of the array JCONT will -C contain the numbers of atoms that make contacts with the atom I (of numbers -C greater than I). The arrays FACONT and GACONT will contain the values of -C the contact function and its derivative. -C -C Uncomment next line, if the correlation interactions include EVDW explicitly. -c if (j.gt.i+1 .and. evdwij.le.0.0D0) then -C Uncomment next line, if the correlation interactions are contact function only - if (j.gt.i+1.and. eps0ij.gt.0.0D0) then - rij=dsqrt(rij) - sigij=sigma(itypi,itypj) - r0ij=rs0(itypi,itypj) -C -C Check whether the SC's are not too far to make a contact. -C - rcut=1.5d0*r0ij - call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) -C Add a new contact, if the SC's are close enough, but not too close (ri' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - return - end -C----------------------------------------------------------------------------- - subroutine escp(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+e1+e2 - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw2',i,j,evdwij -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -cgrad if (j.lt.i) then -cd write (iout,*) 'ji' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time the factor EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C-------------------------------------------------------------------------- - subroutine edis(ehpb) -C -C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - dimension ggg(3) - ehpb=0.0D0 -cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr -cd write(iout,*)'link_start=',link_start,' link_end=',link_end - if (link_end.eq.0) return - do i=link_start,link_end -C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a -C CA-CA distance used in regularization of structure. - ii=ihpb(i) - jj=jhpb(i) -C iii and jjj point to the residues for which the distance is assigned. - if (ii.gt.nres) then - iii=ii-nres - jjj=jj-nres - else - iii=ii - jjj=jj - endif -c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, -c & dhpb(i),dhpb1(i),forcon(i) -C 24/11/03 AL: SS bridges handled separately because of introducing a specific -C distance and angle dependent SS bond potential. - if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then - call ssbond_ene(iii,jjj,eij) - ehpb=ehpb+2*eij -cd write (iout,*) "eij",eij - else if (ii.gt.nres .and. jj.gt.nres) then -c Restraints from contact prediction - dd=dist(ii,jj) - if (dhpb1(i).gt.0.0d0) then - ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd -c write (iout,*) "beta nmr", -c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - else - dd=dist(ii,jj) - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -c write (iout,*) "beta reg",dd,waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd - endif - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - do k=1,3 - ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) - ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) - enddo - else -C Calculate the distance between the two points and its difference from the -C target distance. - dd=dist(ii,jj) - if (dhpb1(i).gt.0.0d0) then - ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd -c write (iout,*) "alph nmr", -c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - else - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -c write (iout,*) "alpha reg",dd,waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd - endif -cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, -cd & ' waga=',waga,' fac=',fac - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo -cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) -C If this is a SC-SC distance, we need to calculate the contributions to the -C Cartesian gradient in the SC vectors (ghpbx). - if (iii.lt.ii) then - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - endif -cgrad do j=iii,jjj-1 -cgrad do k=1,3 -cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k) -cgrad enddo -cgrad enddo - do k=1,3 - ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) - ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) - enddo - endif - enddo - ehpb=0.5D0*ehpb - return - end -C-------------------------------------------------------------------------- - subroutine ssbond_ene(i,j,eij) -C -C Calculate the distance and angle dependent SS-bond potential energy -C using a free-energy function derived based on RHF/6-31G** ab initio -C calculations of diethyl disulfide. -C -C A. Liwo and U. Kozlowska, 11/24/03 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - double precision erij(3),dcosom1(3),dcosom2(3),gg(3) - itypi=itype(i) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(nres+i) - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(nres+j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - erij(1)=xj*rij - erij(2)=yj*rij - erij(3)=zj*rij - om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) - om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) - om12=dxi*dxj+dyi*dyj+dzi*dzj - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - rij=1.0d0/rij - deltad=rij-d0cm - deltat1=1.0d0-om1 - deltat2=1.0d0+om2 - deltat12=om2-om1+2.0d0 - cosphi=om12-om1*om2 - eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) - & +akct*deltad*deltat12 - & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi -c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, -c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, -c & " deltat12",deltat12," eij",eij - ed=2*akcm*deltad+akct*deltat12 - pom1=akct*deltad - pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi - eom1=-2*akth*deltat1-pom1-om2*pom2 - eom2= 2*akth*deltat2+pom1-om1*pom2 - eom12=pom2 - do k=1,3 - ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) - ghpbx(k,i)=ghpbx(k,i)-ggk - & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv - ghpbx(k,j)=ghpbx(k,j)+ggk - & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - ghpbc(k,i)=ghpbc(k,i)-ggk - ghpbc(k,j)=ghpbc(k,j)+ggk - enddo -C -C Calculate the components of the gradient in DC and X -C -cgrad do k=i,j-1 -cgrad do l=1,3 -cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l) -cgrad enddo -cgrad enddo - return - end -C-------------------------------------------------------------------------- - subroutine ebond(estr) -c -c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - double precision u(3),ud(3) - estr=0.0d0 - do i=ibondp_start,ibondp_end - diff = vbld(i)-vbldp0 -c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff - estr=estr+diff*diff - do j=1,3 - gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) - enddo -c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) - enddo - estr=0.5d0*AKP*estr -c -c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included -c - do i=ibond_start,ibond_end - iti=itype(i) - if (iti.ne.10) then - nbi=nbondterm(iti) - if (nbi.eq.1) then - diff=vbld(i+nres)-vbldsc0(1,iti) -c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, -c & AKSC(1,iti),AKSC(1,iti)*diff*diff - estr=estr+0.5d0*AKSC(1,iti)*diff*diff - do j=1,3 - gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) - enddo - else - do j=1,nbi - diff=vbld(i+nres)-vbldsc0(j,iti) - ud(j)=aksc(j,iti)*diff - u(j)=abond0(j,iti)+0.5d0*ud(j)*diff - enddo - uprod=u(1) - do j=2,nbi - uprod=uprod*u(j) - enddo - usum=0.0d0 - usumsqder=0.0d0 - do j=1,nbi - uprod1=1.0d0 - uprod2=1.0d0 - do k=1,nbi - if (k.ne.j) then - uprod1=uprod1*u(k) - uprod2=uprod2*u(k)*u(k) - endif - enddo - usum=usum+uprod1 - usumsqder=usumsqder+ud(j)*uprod2 - enddo - estr=estr+uprod/usum - do j=1,3 - gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) - enddo - endif - endif - enddo - return - end -#ifdef CRYST_THETA -C-------------------------------------------------------------------------- - subroutine ebend(etheta) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - double precision y(2),z(2) - delta=0.02d0*pi -c time11=dexp(-2*time) -c time12=1.0d0 - etheta=0.0D0 -c write (*,'(a,i2)') 'EBEND ICG=',icg - do i=ithet_start,ithet_end -C Zero the energy function and its derivative at 0 or pi. - call splinthet(theta(i),0.5d0*delta,ss,ssd) - it=itype(i-1) - if (i.gt.3) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - y(1)=dcos(phii) - y(2)=dsin(phii) - else - y(1)=0.0D0 - y(2)=0.0D0 - endif - if (i.lt.nres) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) - z(1)=cos(phii1) -#else - phii1=phi(i+1) - z(1)=dcos(phii1) -#endif - z(2)=dsin(phii1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif -C Calculate the "mean" value of theta from the part of the distribution -C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). -C In following comments this theta will be referred to as t_c. - thet_pred_mean=0.0d0 - do k=1,2 - athetk=athet(k,it) - bthetk=bthet(k,it) - thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) - enddo - dthett=thet_pred_mean*ssd - thet_pred_mean=thet_pred_mean*ss+a0thet(it) -C Derivatives of the "mean" values in gamma1 and gamma2. - dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss - dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss - if (theta(i).gt.pi-delta) then - call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, - & E_tc0) - call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) - call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, - & E_theta) - call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else if (theta(i).lt.delta) then - call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) - call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, - & E_theta) - call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) - call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else - call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, - & E_theta,E_tc) - endif - etheta=etheta+ethetai - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'ebend',i,ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 - gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) - enddo -C Ufff.... We've done all this!!! - return - end -C--------------------------------------------------------------------------- - subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, - & E_tc) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it -C Calculate the contributions to both Gaussian lobes. -C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) -C The "polynomial part" of the "standard deviation" of this part of -C the distribution. - sig=polthet(3,it) - do j=2,0,-1 - sig=sig*thet_pred_mean+polthet(j,it) - enddo -C Derivative of the "interior part" of the "standard deviation of the" -C gamma-dependent Gaussian lobe in t_c. - sigtc=3*polthet(3,it) - do j=2,1,-1 - sigtc=sigtc*thet_pred_mean+j*polthet(j,it) - enddo - sigtc=sig*sigtc -C Set the parameters of both Gaussian lobes of the distribution. -C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) - fac=sig*sig+sigc0(it) - sigcsq=fac+fac - sigc=1.0D0/sigcsq -C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c - sigsqtc=-4.0D0*sigcsq*sigtc -c print *,i,sig,sigtc,sigsqtc -C Following variable (sigtc) is d[sigma(t_c)]/dt_c - sigtc=-sigtc/(fac*fac) -C Following variable is sigma(t_c)**(-2) - sigcsq=sigcsq*sigcsq - sig0i=sig0(it) - sig0inv=1.0D0/sig0i**2 - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i - term1=-0.5D0*sigcsq*delthec*delthec - term2=-0.5D0*sig0inv*delthe0*delthe0 -C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and -C NaNs in taking the logarithm. We extract the largest exponent which is added -C to the energy (this being the log of the distribution) at the end of energy -C term evaluation for this virtual-bond angle. - if (term1.gt.term2) then - termm=term1 - term2=dexp(term2-termm) - term1=1.0d0 - else - termm=term2 - term1=dexp(term1-termm) - term2=1.0d0 - endif -C The ratio between the gamma-independent and gamma-dependent lobes of -C the distribution is a Gaussian function of thet_pred_mean too. - diffak=gthet(2,it)-thet_pred_mean - ratak=diffak/gthet(3,it)**2 - ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) -C Let's differentiate it in thet_pred_mean NOW. - aktc=ak*ratak -C Now put together the distribution terms to make complete distribution. - termexp=term1+ak*term2 - termpre=sigc+ak*sig0i -C Contribution of the bending energy from this theta is just the -log of -C the sum of the contributions from the two lobes and the pre-exponential -C factor. Simple enough, isn't it? - ethetai=(-dlog(termexp)-termm+dlog(termpre)) -C NOW the derivatives!!! -C 6/6/97 Take into account the deformation. - E_theta=(delthec*sigcsq*term1 - & +ak*delthe0*sig0inv*term2)/termexp - E_tc=((sigtc+aktc*sig0i)/termpre - & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ - & aktc*term2)/termexp) - return - end -c----------------------------------------------------------------------------- - subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i -C "Thank you" to MAPLE (probably spared one day of hand-differentiation). - t3 = thetai-thet_pred_mean - t6 = t3**2 - t9 = term1 - t12 = t3*sigcsq - t14 = t12+t6*sigsqtc - t16 = 1.0d0 - t21 = thetai-theta0i - t23 = t21**2 - t26 = term2 - t27 = t21*t26 - t32 = termexp - t40 = t32**2 - E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 - & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 - & *(-t12*t9-ak*sig0inv*t27) - return - end -#else -C-------------------------------------------------------------------------- - subroutine ebend(etheta) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C ab initio-derived potentials from -c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), - & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), - & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), - & sinph1ph2(maxdouble,maxdouble) - logical lprn /.false./, lprn1 /.false./ - etheta=0.0D0 - do i=ithet_start,ithet_end - dethetai=0.0d0 - dephii=0.0d0 - dephii1=0.0d0 - theti2=0.5d0*theta(i) - ityp2=ithetyp(itype(i-1)) - do k=1,nntheterm - coskt(k)=dcos(k*theti2) - sinkt(k)=dsin(k*theti2) - enddo - if (i.gt.3) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - ityp1=ithetyp(itype(i-2)) - do k=1,nsingle - cosph1(k)=dcos(k*phii) - sinph1(k)=dsin(k*phii) - enddo - else - phii=0.0d0 - ityp1=nthetyp+1 - do k=1,nsingle - cosph1(k)=0.0d0 - sinph1(k)=0.0d0 - enddo - endif - if (i.lt.nres) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) -#else - phii1=phi(i+1) -#endif - ityp3=ithetyp(itype(i)) - do k=1,nsingle - cosph2(k)=dcos(k*phii1) - sinph2(k)=dsin(k*phii1) - enddo - else - phii1=0.0d0 - ityp3=nthetyp+1 - do k=1,nsingle - cosph2(k)=0.0d0 - sinph2(k)=0.0d0 - enddo - endif - ethetai=aa0thet(ityp1,ityp2,ityp3) - do k=1,ndouble - do l=1,k-1 - ccl=cosph1(l)*cosph2(k-l) - ssl=sinph1(l)*sinph2(k-l) - scl=sinph1(l)*cosph2(k-l) - csl=cosph1(l)*sinph2(k-l) - cosph1ph2(l,k)=ccl-ssl - cosph1ph2(k,l)=ccl+ssl - sinph1ph2(l,k)=scl+csl - sinph1ph2(k,l)=scl-csl - enddo - enddo - if (lprn) then - write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, - & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 - write (iout,*) "coskt and sinkt" - do k=1,nntheterm - write (iout,*) k,coskt(k),sinkt(k) - enddo - endif - do k=1,ntheterm - ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k) - dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3) - & *coskt(k) - if (lprn) - & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), - & " ethetai",ethetai - enddo - if (lprn) then - write (iout,*) "cosph and sinph" - do k=1,nsingle - write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) - enddo - write (iout,*) "cosph1ph2 and sinph2ph2" - do k=2,ndouble - do l=1,k-1 - write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), - & sinph1ph2(l,k),sinph1ph2(k,l) - enddo - enddo - write(iout,*) "ethetai",ethetai - endif - do m=1,ntheterm2 - do k=1,nsingle - aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k) - & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k) - & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k) - & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*aux*coskt(m) - dephii=dephii+k*sinkt(m)*( - & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)- - & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) - dephii1=dephii1+k*sinkt(m)*( - & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- - & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) - if (lprn) - & write (iout,*) "m",m," k",k," bbthet", - & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", - & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", - & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", - & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai - enddo - enddo - if (lprn) - & write(iout,*) "ethetai",ethetai - do m=1,ntheterm3 - do k=2,ndouble - do l=1,k-1 - aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*coskt(m)*aux - dephii=dephii+l*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)- - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - dephii1=dephii1+(k-l)*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)- - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - if (lprn) then - write (iout,*) "m",m," k",k," l",l," ffthet", - & ffthet(l,k,m,ityp1,ityp2,ityp3), - & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", - & ggthet(l,k,m,ityp1,ityp2,ityp3), - & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai - write (iout,*) cosph1ph2(l,k)*sinkt(m), - & cosph1ph2(k,l)*sinkt(m), - & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) - endif - enddo - enddo - enddo -10 continue - if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') - & i,theta(i)*rad2deg,phii*rad2deg, - & phii1*rad2deg,ethetai - etheta=etheta+ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 - gloc(nphi+i-2,icg)=wang*dethetai - enddo - return - end -#endif -#ifdef CRYST_SC -c----------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), - & ddersc0(3),ddummy(3),xtemp(3),temp(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 -c write (iout,'(a)') 'ESC' - do i=loc_start,loc_end - it=itype(i) - if (it.eq.10) goto 1 - nlobit=nlob(it) -c print *,'i=',i,' it=',it,' nlobit=',nlobit -c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad - theti=theta(i+1)-pipol - x(1)=dtan(theti) - x(2)=alph(i) - x(3)=omeg(i) - - if (x(2).gt.pi-delta) then - xtemp(1)=x(1) - xtemp(2)=pi-delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=pi - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=pi-delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=pi - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - call splinthet(x(2),0.5d0*delta,ss,ssd) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c escloci=esclocbi -c write (iout,*) escloci - else if (x(2).lt.delta) then - xtemp(1)=x(1) - xtemp(2)=delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=0.0d0 - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=0.0d0 - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - call splinthet(x(2),0.5d0*delta,ss,ssd) - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c write (iout,*) escloci - else - call enesc(x,escloci,dersc,ddummy,.false.) - endif - - escloc=escloc+escloci - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'escloc',i,escloci -c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc - - gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ - & wscloc*dersc(1) - gloc(ialph(i,1),icg)=wscloc*dersc(2) - gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) - 1 continue - enddo - return - end -C--------------------------------------------------------------------------- - subroutine enesc(x,escloci,dersc,ddersc,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) - double precision contr(maxlob,-1:1) - logical mixed -c write (iout,*) 'it=',it,' nlobit=',nlobit - escloc_i=0.0D0 - do j=1,3 - dersc(j)=0.0D0 - if (mixed) ddersc(j)=0.0d0 - enddo - x3=x(3) - -C Because of periodicity of the dependence of the SC energy in omega we have -C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). -C To avoid underflows, first compute & store the exponents. - - do iii=-1,1 - - x(3)=x3+iii*dwapi - - do j=1,nlobit - do k=1,3 - z(k)=x(k)-censc(k,j,it) - enddo - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j,iii)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j,iii)*z(k) - enddo - contr(j,iii)=expfac - enddo ! j - - enddo ! iii - - x(3)=x3 -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1,-1) - do iii=-1,1 - do j=1,nlobit - if (emin.gt.contr(j,iii)) emin=contr(j,iii) - enddo - enddo - emin=0.5D0*emin -cd print *,'it=',it,' emin=',emin - -C Compute the contribution to SC energy and derivatives - do iii=-1,1 - - do j=1,nlobit -#ifdef OSF - adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin - if(adexp.ne.adexp) adexp=1.0 - expfac=dexp(adexp) -#else - expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin) -#endif -cd print *,'j=',j,' expfac=',expfac - escloc_i=escloc_i+expfac - do k=1,3 - dersc(k)=dersc(k)+Ax(k,j,iii)*expfac - enddo - if (mixed) then - do k=1,3,2 - ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) - & +gaussc(k,2,j,it))*expfac - enddo - endif - enddo - - enddo ! iii - - dersc(1)=dersc(1)/cos(theti)**2 - ddersc(1)=ddersc(1)/cos(theti)**2 - ddersc(3)=ddersc(3) - - escloci=-(dlog(escloc_i)-emin) - do j=1,3 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) then - do j=1,3,2 - ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) - enddo - endif - return - end -C------------------------------------------------------------------------------ - subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob),dersc(3) - double precision contr(maxlob) - logical mixed - - escloc_i=0.0D0 - - do j=1,3 - dersc(j)=0.0D0 - enddo - - do j=1,nlobit - do k=1,2 - z(k)=x(k)-censc(k,j,it) - enddo - z(3)=dwapi - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j)*z(k) - enddo - contr(j)=expfac - enddo ! j - -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1) - do j=1,nlobit - if (emin.gt.contr(j)) emin=contr(j) - enddo - emin=0.5D0*emin - -C Compute the contribution to SC energy and derivatives - - dersc12=0.0d0 - do j=1,nlobit - expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin) - escloc_i=escloc_i+expfac - do k=1,2 - dersc(k)=dersc(k)+Ax(k,j)*expfac - enddo - if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) - & +gaussc(1,2,j,it))*expfac - dersc(3)=0.0d0 - enddo - - dersc(1)=dersc(1)/cos(theti)**2 - dersc12=dersc12/cos(theti)**2 - escloci=-(dlog(escloc_i)-emin) - do j=1,2 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) - return - end -#else -c---------------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA derived from AM1 all-atom calculations. -C added by Urszula Kozlowska. 07/11/2007 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.SCROT' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - include 'COMMON.VECTORS' - double precision x_prime(3),y_prime(3),z_prime(3) - & , sumene,dsc_i,dp2_i,x(65), - & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, - & de_dxx,de_dyy,de_dzz,de_dt - double precision s1_t,s1_6_t,s2_t,s2_6_t - double precision - & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), - & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), - & dt_dCi(3),dt_dCi1(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 - do i=loc_start,loc_end - costtab(i+1) =dcos(theta(i+1)) - sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) - cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) - sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) - cosfac2=0.5d0/(1.0d0+costtab(i+1)) - cosfac=dsqrt(cosfac2) - sinfac2=0.5d0/(1.0d0-costtab(i+1)) - sinfac=dsqrt(sinfac2) - it=itype(i) - if (it.eq.10) goto 1 -c -C Compute the axes of tghe local cartesian coordinates system; store in -c x_prime, y_prime and z_prime -c - do j=1,3 - x_prime(j) = 0.00 - y_prime(j) = 0.00 - z_prime(j) = 0.00 - enddo -C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), -C & dc_norm(3,i+nres) - do j = 1,3 - x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac - y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac - enddo - do j = 1,3 - z_prime(j) = -uz(j,i-1) - enddo -c write (2,*) "i",i -c write (2,*) "x_prime",(x_prime(j),j=1,3) -c write (2,*) "y_prime",(y_prime(j),j=1,3) -c write (2,*) "z_prime",(z_prime(j),j=1,3) -c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), -c & " xy",scalar(x_prime(1),y_prime(1)), -c & " xz",scalar(x_prime(1),z_prime(1)), -c & " yy",scalar(y_prime(1),y_prime(1)), -c & " yz",scalar(y_prime(1),z_prime(1)), -c & " zz",scalar(z_prime(1),z_prime(1)) -c -C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), -C to local coordinate system. Store in xx, yy, zz. -c - xx=0.0d0 - yy=0.0d0 - zz=0.0d0 - do j = 1,3 - xx = xx + x_prime(j)*dc_norm(j,i+nres) - yy = yy + y_prime(j)*dc_norm(j,i+nres) - zz = zz + z_prime(j)*dc_norm(j,i+nres) - enddo - - xxtab(i)=xx - yytab(i)=yy - zztab(i)=zz -C -C Compute the energy of the ith side cbain -C -c write (2,*) "xx",xx," yy",yy," zz",zz - it=itype(i) - do j = 1,65 - x(j) = sc_parmin(j,it) - enddo -#ifdef CHECK_COORD -Cc diagnostics - remove later - xx1 = dcos(alph(2)) - yy1 = dsin(alph(2))*dcos(omeg(2)) - zz1 = -dsin(alph(2))*dsin(omeg(2)) - write(2,'(3f8.1,3f9.3,1x,3f9.3)') - & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, - & xx1,yy1,zz1 -C," --- ", xx_w,yy_w,zz_w -c end diagnostics -#endif - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) - & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) -c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, -c & sumene4, -c & dscp1,dscp2,sumene -c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - escloc = escloc + sumene -c write (2,*) "i",i," escloc",sumene,escloc -#ifdef DEBUG -C -C This section to check the numerical derivatives of the energy of ith side -C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert -C #define DEBUG in the code to turn it on. -C - write (2,*) "sumene =",sumene - aincr=1.0d-7 - xxsave=xx - xx=xx+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dxx_num=(sumenep-sumene)/aincr - xx=xxsave - write (2,*) "xx+ sumene from enesc=",sumenep - yysave=yy - yy=yy+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dyy_num=(sumenep-sumene)/aincr - yy=yysave - write (2,*) "yy+ sumene from enesc=",sumenep - zzsave=zz - zz=zz+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dzz_num=(sumenep-sumene)/aincr - zz=zzsave - write (2,*) "zz+ sumene from enesc=",sumenep - costsave=cost2tab(i+1) - sintsave=sint2tab(i+1) - cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) - sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dt_num=(sumenep-sumene)/aincr - write (2,*) " t+ sumene from enesc=",sumenep - cost2tab(i+1)=costsave - sint2tab(i+1)=sintsave -C End of diagnostics section. -#endif -C -C Compute the gradient of esc -C - pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 - pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 - pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 - pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 - pom_dx=dsc_i*dp2_i*cost2tab(i+1) - pom_dy=dsc_i*dp2_i*sint2tab(i+1) - pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) - pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) - pom1=(sumene3*sint2tab(i+1)+sumene1) - & *(pom_s1/dscp1+pom_s16*dscp1**4) - pom2=(sumene4*cost2tab(i+1)+sumene2) - & *(pom_s2/dscp2+pom_s26*dscp2**4) - sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy - sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 - & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) - & +x(40)*yy*zz - sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy - sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 - & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) - & +x(60)*yy*zz - de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) - & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) - & +(pom1+pom2)*pom_dx -#ifdef DEBUG - write(2,*), "de_dxx = ", de_dxx,de_dxx_num -#endif -C - sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz - sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 - & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) - & +x(40)*xx*zz - sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz - sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz - & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz - & +x(59)*zz**2 +x(60)*xx*zz - de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) - & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) - & +(pom1-pom2)*pom_dy -#ifdef DEBUG - write(2,*), "de_dyy = ", de_dyy,de_dyy_num -#endif -C - de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy - & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx - & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) - & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) - & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 - & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy - & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) - & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) -#ifdef DEBUG - write(2,*), "de_dzz = ", de_dzz,de_dzz_num -#endif -C - de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) - & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) - & +pom1*pom_dt1+pom2*pom_dt2 -#ifdef DEBUG - write(2,*), "de_dt = ", de_dt,de_dt_num -#endif -c -C - cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) - cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) - cosfac2xx=cosfac2*xx - sinfac2yy=sinfac2*yy - do k = 1,3 - dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* - & vbld_inv(i+1) - dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* - & vbld_inv(i) - pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) - pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) -c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, -c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) -c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), -c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) - dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx - dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx - dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy - dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy - dZZ_Ci1(k)=0.0d0 - dZZ_Ci(k)=0.0d0 - do j=1,3 - dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres) - dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres) - enddo - - dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) - dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) - dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) -c - dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) - dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) - enddo - - do k=1,3 - dXX_Ctab(k,i)=dXX_Ci(k) - dXX_C1tab(k,i)=dXX_Ci1(k) - dYY_Ctab(k,i)=dYY_Ci(k) - dYY_C1tab(k,i)=dYY_Ci1(k) - dZZ_Ctab(k,i)=dZZ_Ci(k) - dZZ_C1tab(k,i)=dZZ_Ci1(k) - dXX_XYZtab(k,i)=dXX_XYZ(k) - dYY_XYZtab(k,i)=dYY_XYZ(k) - dZZ_XYZtab(k,i)=dZZ_XYZ(k) - enddo - - do k = 1,3 -c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", -c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) -c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", -c & dyy_ci(k)," dzz_ci",dzz_ci(k) -c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", -c & dt_dci(k) -c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", -c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) - gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) - & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) - gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) - & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) - gsclocx(k,i)= de_dxx*dxx_XYZ(k) - & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) - enddo -c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), -c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) - -C to check gradient call subroutine check_grad - - 1 continue - enddo - return - end -c------------------------------------------------------------------------------ - double precision function enesc(x,xx,yy,zz,cost2,sint2) - implicit none - double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2, - & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6 - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2+yy*sint2)) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2-yy*sint2)) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) - & + (sumene4*cost2 +sumene2)*(s2+s2_6) - enesc=sumene - return - end -#endif -c------------------------------------------------------------------------------ - subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) -C -C This procedure calculates two-body contact function g(rij) and its derivative: -C -C eps0ij ! x < -1 -C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 -C 0 ! x > 1 -C -C where x=(rij-r0ij)/delta -C -C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy -C - implicit none - double precision rij,r0ij,eps0ij,fcont,fprimcont - double precision x,x2,x4,delta -c delta=0.02D0*r0ij -c delta=0.2D0*r0ij - x=(rij-r0ij)/delta - if (x.lt.-1.0D0) then - fcont=eps0ij - fprimcont=0.0D0 - else if (x.le.1.0D0) then - x2=x*x - x4=x2*x2 - fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) - fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta - else - fcont=0.0D0 - fprimcont=0.0D0 - endif - return - end -c------------------------------------------------------------------------------ - subroutine splinthet(theti,delta,ss,ssder) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - thetup=pi-delta - thetlow=delta - if (theti.gt.pipol) then - call gcont(theti,thetup,1.0d0,delta,ss,ssder) - else - call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) - ssder=-ssder - endif - return - end -c------------------------------------------------------------------------------ - subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) - implicit none - double precision x,x0,delta,f0,f1,fprim0,f,fprim - double precision ksi,ksi2,ksi3,a1,a2,a3 - a1=fprim0*delta/(f1-f0) - a2=3.0d0-2.0d0*a1 - a3=a1-2.0d0 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) - fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) - return - end -c------------------------------------------------------------------------------ - subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) - implicit none - double precision x,x0,delta,f0x,f1x,fprim0x,fx - double precision ksi,ksi2,ksi3,a1,a2,a3 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - a1=fprim0x*delta - a2=3*(f1x-f0x)-2*fprim0x*delta - a3=fprim0x*delta-2*(f1x-f0x) - fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 - return - end -C----------------------------------------------------------------------------- -#ifdef CRYST_TOR -C----------------------------------------------------------------------------- - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - etors_ii=0.0D0 - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -C Proline-Proline pair is a special case... - if (itori.eq.3 .and. itori1.eq.3) then - if (phii.gt.-dwapi3) then - cosphi=dcos(3*phii) - fac=1.0D0/(1.0D0-cosphi) - etorsi=v1(1,3,3)*fac - etorsi=etorsi+etorsi - etors=etors+etorsi-v1(1,3,3) - if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) - gloci=gloci-3*fac*etorsi*dsin(3*phii) - endif - do j=1,3 - v1ij=v1(j+1,itori,itori1) - v2ij=v2(j+1,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ - & v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - else - do j=1,nterm_old - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ - & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - endif - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'etor',i,etors_ii - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci - write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 - do i=1,ndih_constr - itori=idih_constr(i) - phii=phi(itori) - difi=phii-phi0(i) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - endif -! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, -! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -! write (iout,*) 'edihcnstr',edihcnstr - return - end -c------------------------------------------------------------------------------ - subroutine etor_d(etors_d) - etors_d=0.0d0 - return - end -c---------------------------------------------------------------------------- -#else - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - etors_ii=0.0D0 - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -C Regular cosine and sine terms - do j=1,nterm(itori,itori1) - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi - if (energy_dec) etors_ii=etors_ii+ - & v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo -C Lorentz terms -C v1 -C E = SUM ----------------------------------- - v1 -C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 -C - cosphi=dcos(0.5d0*phii) - sinphi=dsin(0.5d0*phii) - do j=1,nlor(itori,itori1) - vl1ij=vlor1(j,itori,itori1) - vl2ij=vlor2(j,itori,itori1) - vl3ij=vlor3(j,itori,itori1) - pom=vl2ij*cosphi+vl3ij*sinphi - pom1=1.0d0/(pom*pom+1.0d0) - etors=etors+vl1ij*pom1 - if (energy_dec) etors_ii=etors_ii+ - & vl1ij*pom1 - pom=-pom*pom1*pom1 - gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom - enddo -C Subtract the constant term - etors=etors-v0(itori,itori1) - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'etor',i,etors_ii-v0(itori,itori1) - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 -c do i=1,ndih_constr - do i=idihconstr_start,idihconstr_end - itori=idih_constr(i) - phii=phi(itori) - difi=pinorm(phii-phi0(i)) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else - difi=0.0 - endif -c write (iout,*) "gloci", gloc(i-3,icg) -cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, -cd & rad2deg*phi0(i), rad2deg*drange(i), -cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -cd write (iout,*) 'edihcnstr',edihcnstr - return - end -c---------------------------------------------------------------------------- - subroutine etor_d(etors_d) -C 6/23/01 Compute double torsional energy - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors_d=0.0D0 - do i=iphid_start,iphid_end - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - itori2=itortyp(itype(i)) - phii=phi(i) - phii1=phi(i+1) - gloci1=0.0D0 - gloci2=0.0D0 - do j=1,ntermd_1(itori,itori1,itori2) - v1cij=v1c(1,j,itori,itori1,itori2) - v1sij=v1s(1,j,itori,itori1,itori2) - v2cij=v1c(2,j,itori,itori1,itori2) - v2sij=v1s(2,j,itori,itori1,itori2) - cosphi1=dcos(j*phii) - sinphi1=dsin(j*phii) - cosphi2=dcos(j*phii1) - sinphi2=dsin(j*phii1) - etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ - & v2cij*cosphi2+v2sij*sinphi2 - gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) - gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) - enddo - do k=2,ntermd_2(itori,itori1,itori2) - do l=1,k-1 - v1cdij = v2c(k,l,itori,itori1,itori2) - v2cdij = v2c(l,k,itori,itori1,itori2) - v1sdij = v2s(k,l,itori,itori1,itori2) - v2sdij = v2s(l,k,itori,itori1,itori2) - cosphi1p2=dcos(l*phii+(k-l)*phii1) - cosphi1m2=dcos(l*phii-(k-l)*phii1) - sinphi1p2=dsin(l*phii+(k-l)*phii1) - sinphi1m2=dsin(l*phii-(k-l)*phii1) - etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ - & v1sdij*sinphi1p2+v2sdij*sinphi1m2 - gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) - gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) - enddo - enddo - gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 - gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 -c write (iout,*) "gloci", gloc(i-3,icg) - enddo - return - end -#endif -c------------------------------------------------------------------------------ - subroutine eback_sc_corr(esccor) -c 7/21/2007 Correlations between the backbone-local and side-chain-local -c conformational states; temporarily implemented as differences -c between UNRES torsional potentials (dependent on three types of -c residues) and the torsional potentials dependent on all 20 types -c of residues computed from AM1 energy surfaces of terminally-blocked -c amino-acid residues. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.SCCOR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. -c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor - esccor=0.0D0 - do i=itau_start,itau_end - esccor_ii=0.0D0 - isccori=isccortyp(itype(i-2)) - isccori1=isccortyp(itype(i-1)) - phii=phi(i) -cccc Added 9 May 2012 -cc Tauangle is torsional engle depending on the value of first digit -c(see comment below) -cc Omicron is flat angle depending on the value of first digit -c(see comment below) - - - do intertyp=1,3 !intertyp -cc Added 09 May 2012 (Adasko) -cc Intertyp means interaction type of backbone mainchain correlation: -c 1 = SC...Ca...Ca...Ca -c 2 = Ca...Ca...Ca...SC -c 3 = SC...Ca...Ca...SCi - gloci=0.0D0 - if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. - & (itype(i-1).eq.10).or.(itype(i-2).eq.21).or. - & (itype(i-1).eq.21))) - & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) - & .or.(itype(i-2).eq.21))) - & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. - & (itype(i-1).eq.21)))) cycle - if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle - if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21)) - & cycle - do j=1,nterm_sccor(isccori,isccori1) - v1ij=v1sccor(j,intertyp,isccori,isccori1) - v2ij=v2sccor(j,intertyp,isccori,isccori1) - cosphi=dcos(j*tauangle(intertyp,i)) - sinphi=dsin(j*tauangle(intertyp,i)) - esccor=esccor+v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci -c write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi -c &gloc_sc(intertyp,i-3,icg) - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1sccor(j,intertyp,itori,itori1),j=1,6) - & ,(v2sccor(j,intertyp,itori,itori1),j=1,6) - gsccor_loc(i-3)=gsccor_loc(i-3)+gloci - enddo !intertyp - enddo -c do i=1,nres -c write (iout,*) "W@T@F", gloc_sc(1,i,icg),gloc(i,icg) -c enddo - return - end -c---------------------------------------------------------------------------- - subroutine multibody(ecorr) -C This subroutine calculates multi-body contributions to energy following -C the idea of Skolnick et al. If side chains I and J make a contact and -C at the same time side chains I+1 and J+1 make a contact, an extra -C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - -C Set lprn=.true. for debugging - lprn=.false. - - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(i2,20(1x,i2,f10.5))') - & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) - enddo - endif - ecorr=0.0D0 - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo - do i=nnt,nct-2 - - DO ISHIFT = 3,4 - - i1=i+ishift - num_conti=num_cont(i) - num_conti1=num_cont(i1) - do jj=1,num_conti - j=jcont(jj,i) - do kk=1,num_conti1 - j1=jcont(kk,i1) - if (j1.eq.j+ishift .or. j1.eq.j-ishift) then -cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, -cd & ' ishift=',ishift -C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) - endif ! j1==j+-ishift - enddo ! kk - enddo ! jj - - ENDDO ! ISHIFT - - enddo ! i - return - end -c------------------------------------------------------------------------------ - double precision function esccorr(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont(jj,i) - ekl=facont(kk,k) -cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl -C Calculate the multi-body contribution to energy. -C Calculate multi-body contributions to the gradient. -cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), -cd & k,l,(gacont(m,kk,k),m=1,3) - do m=1,3 - gx(m) =ekl*gacont(m,jj,i) - gx1(m)=eij*gacont(m,kk,k) - gradxorr(m,i)=gradxorr(m,i)-gx(m) - gradxorr(m,j)=gradxorr(m,j)+gx(m) - gradxorr(m,k)=gradxorr(m,k)-gx1(m) - gradxorr(m,l)=gradxorr(m,l)+gx1(m) - enddo - do m=i,j-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) - enddo - enddo - do m=k,l-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) - enddo - enddo - esccorr=-eij*ekl - return - end -c------------------------------------------------------------------------------ - subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPI - include "mpif.h" - parameter (max_cont=maxconts) - parameter (max_dim=26) - integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer status(MPI_STATUS_SIZE),req(maxconts*2), - & status_array(MPI_STATUS_SIZE,maxconts*2) -#endif - include 'COMMON.SETUP' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.LOCAL' - double precision gx(3),gx1(3),time00 - logical lprn,ldone - -C Set lprn=.true. for debugging - lprn=.false. -#ifdef MPI - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values before RECEIVE:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", -c & ntask_cont_to -C Make the list of contacts to send to send to other procesors -c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end -c call flush(iout) - do i=iturn3_start,iturn3_end -c write (iout,*) "make contact list turn3",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact(i,i+2,iturn3_sent_local(1,i)) - enddo - do i=iturn4_start,iturn4_end -c write (iout,*) "make contact list turn4",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact(i,i+3,iturn4_sent_local(1,i)) - enddo - do ii=1,nat_sent - i=iat_sent(ii) -c write (iout,*) "make contact list longrange",i,ii," num_cont", -c & num_cont_hb(i) - do j=1,num_cont_hb(i) - do k=1,4 - jjc=jcont_hb(j,i) - iproc=iint_sent_local(k,jjc,ii) -c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc - if (iproc.gt.0) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=i - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=facont_hb(j,i) - zapas(4,nn,iproc)=ees0p(j,i) - zapas(5,nn,iproc)=ees0m(j,i) - zapas(6,nn,iproc)=gacont_hbr(1,j,i) - zapas(7,nn,iproc)=gacont_hbr(2,j,i) - zapas(8,nn,iproc)=gacont_hbr(3,j,i) - zapas(9,nn,iproc)=gacontm_hb1(1,j,i) - zapas(10,nn,iproc)=gacontm_hb1(2,j,i) - zapas(11,nn,iproc)=gacontm_hb1(3,j,i) - zapas(12,nn,iproc)=gacontp_hb1(1,j,i) - zapas(13,nn,iproc)=gacontp_hb1(2,j,i) - zapas(14,nn,iproc)=gacontp_hb1(3,j,i) - zapas(15,nn,iproc)=gacontm_hb2(1,j,i) - zapas(16,nn,iproc)=gacontm_hb2(2,j,i) - zapas(17,nn,iproc)=gacontm_hb2(3,j,i) - zapas(18,nn,iproc)=gacontp_hb2(1,j,i) - zapas(19,nn,iproc)=gacontp_hb2(2,j,i) - zapas(20,nn,iproc)=gacontp_hb2(3,j,i) - zapas(21,nn,iproc)=gacontm_hb3(1,j,i) - zapas(22,nn,iproc)=gacontm_hb3(2,j,i) - zapas(23,nn,iproc)=gacontm_hb3(3,j,i) - zapas(24,nn,iproc)=gacontp_hb3(1,j,i) - zapas(25,nn,iproc)=gacontp_hb3(2,j,i) - zapas(26,nn,iproc)=gacontp_hb3(3,j,i) - endif - enddo - enddo - enddo - if (lprn) then - write (iout,*) - & "Numbers of contacts to be sent to other processors", - & (ncont_sent(i),i=1,ntask_cont_to) - write (iout,*) "Contacts sent" - do ii=1,ntask_cont_to - nn=ncont_sent(ii) - iproc=itask_cont_to(ii) - write (iout,*) nn," contacts to processor",iproc, - & " of CONT_TO_COMM group" - do i=1,nn - write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) - enddo - enddo - call flush(iout) - endif - CorrelType=477 - CorrelID=fg_rank+1 - CorrelType1=478 - CorrelID1=nfgtasks+fg_rank+1 - ireq=0 -C Receive the numbers of needed contacts from other processors - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - ireq=ireq+1 - call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "IRECV ended" -c call flush(iout) -C Send the number of contacts needed by other processors - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - ireq=ireq+1 - call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "ISEND ended" -c write (iout,*) "number of requests (nn)",ireq - call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) -c write (iout,*) -c & "Numbers of contacts to be received from other processors", -c & (ncont_recv(i),i=1,ntask_cont_from) -c call flush(iout) -C Receive contacts - ireq=0 - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - nn=ncont_recv(ii) -c write (iout,*) "Receiving",nn," contacts from processor",iproc, -c & " of CONT_TO_COMM group" - call flush(iout) - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, - & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) - endif - enddo -C Send the contacts to processors that need them - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - nn=ncont_sent(ii) -c write (iout,*) nn," contacts to processor",iproc, -c & " of CONT_TO_COMM group" - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, - & iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) -c do i=1,nn -c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) -c enddo - endif - enddo -c write (iout,*) "number of requests (contacts)",ireq -c write (iout,*) "req",(req(i),i=1,4) -c call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) - do iii=1,ntask_cont_from - iproc=itask_cont_from(iii) - nn=ncont_recv(iii) - if (lprn) then - write (iout,*) "Received",nn," contacts from processor",iproc, - & " of CONT_FROM_COMM group" - call flush(iout) - do i=1,nn - write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5) - enddo - call flush(iout) - endif - do i=1,nn - ii=zapas_recv(1,i,iii) -c Flag the received contacts to prevent double-counting - jj=-zapas_recv(2,i,iii) -c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj -c call flush(iout) - nnn=num_cont_hb(ii)+1 - num_cont_hb(ii)=nnn - jcont_hb(nnn,ii)=jj - facont_hb(nnn,ii)=zapas_recv(3,i,iii) - ees0p(nnn,ii)=zapas_recv(4,i,iii) - ees0m(nnn,ii)=zapas_recv(5,i,iii) - gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii) - gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii) - gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii) - gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii) - gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii) - gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii) - gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii) - gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii) - gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii) - gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii) - gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii) - gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii) - gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii) - gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii) - gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii) - gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii) - gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii) - gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii) - gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii) - gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii) - gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii) - enddo - enddo - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 -C Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -C Calculate the local-electrostatic correlation terms - do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end) - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - jp=iabs(j) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) - jp1=iabs(j1) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 - & .or. j.lt.0 .and. j1.gt.0) .and. - & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then -C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) - n_corr=n_corr+1 - else if (j1.eq.j) then -C Contacts I-J and I-(J+1) occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) - endif - enddo ! kk - do kk=1,num_conti - j1=jcont_hb(kk,i) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if (j1.eq.j+1) then -C Contacts I-J and (I+1)-J occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) - endif ! j1==j+1 - enddo ! kk - enddo ! jj - enddo ! i - return - end -c------------------------------------------------------------------------------ - subroutine add_hb_contact(ii,jj,itask) - implicit real*8 (a-h,o-z) - include "DIMENSIONS" - include "COMMON.IOUNITS" - integer max_cont - integer max_dim - parameter (max_cont=maxconts) - parameter (max_dim=26) - include "COMMON.CONTACTS" - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer i,j,ii,jj,iproc,itask(4),nn -c write (iout,*) "itask",itask - do i=1,2 - iproc=itask(i) - if (iproc.gt.0) then - do j=1,num_cont_hb(ii) - jjc=jcont_hb(j,ii) -c write (iout,*) "i",ii," j",jj," jjc",jjc - if (jjc.eq.jj) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=ii - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=facont_hb(j,ii) - zapas(4,nn,iproc)=ees0p(j,ii) - zapas(5,nn,iproc)=ees0m(j,ii) - zapas(6,nn,iproc)=gacont_hbr(1,j,ii) - zapas(7,nn,iproc)=gacont_hbr(2,j,ii) - zapas(8,nn,iproc)=gacont_hbr(3,j,ii) - zapas(9,nn,iproc)=gacontm_hb1(1,j,ii) - zapas(10,nn,iproc)=gacontm_hb1(2,j,ii) - zapas(11,nn,iproc)=gacontm_hb1(3,j,ii) - zapas(12,nn,iproc)=gacontp_hb1(1,j,ii) - zapas(13,nn,iproc)=gacontp_hb1(2,j,ii) - zapas(14,nn,iproc)=gacontp_hb1(3,j,ii) - zapas(15,nn,iproc)=gacontm_hb2(1,j,ii) - zapas(16,nn,iproc)=gacontm_hb2(2,j,ii) - zapas(17,nn,iproc)=gacontm_hb2(3,j,ii) - zapas(18,nn,iproc)=gacontp_hb2(1,j,ii) - zapas(19,nn,iproc)=gacontp_hb2(2,j,ii) - zapas(20,nn,iproc)=gacontp_hb2(3,j,ii) - zapas(21,nn,iproc)=gacontm_hb3(1,j,ii) - zapas(22,nn,iproc)=gacontm_hb3(2,j,ii) - zapas(23,nn,iproc)=gacontm_hb3(3,j,ii) - zapas(24,nn,iproc)=gacontp_hb3(1,j,ii) - zapas(25,nn,iproc)=gacontp_hb3(2,j,ii) - zapas(26,nn,iproc)=gacontp_hb3(3,j,ii) - exit - endif - enddo - endif - enddo - return - end -c------------------------------------------------------------------------------ - subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, - & n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPI - include "mpif.h" - parameter (max_cont=maxconts) - parameter (max_dim=70) - integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer status(MPI_STATUS_SIZE),req(maxconts*2), - & status_array(MPI_STATUS_SIZE,maxconts*2) -#endif - include 'COMMON.SETUP' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.CONTROL' - double precision gx(3),gx1(3) - integer num_cont_hb_old(maxres) - logical lprn,ldone - double precision eello4,eello5,eelo6,eello_turn6 - external eello4,eello5,eello6,eello_turn6 -C Set lprn=.true. for debugging - lprn=.false. - eturn6=0.0d0 -#ifdef MPI - do i=1,nres - num_cont_hb_old(i)=num_cont_hb(i) - enddo - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values before RECEIVE:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", -c & ntask_cont_to -C Make the list of contacts to send to send to other procesors - do i=iturn3_start,iturn3_end -c write (iout,*) "make contact list turn3",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i)) - enddo - do i=iturn4_start,iturn4_end -c write (iout,*) "make contact list turn4",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i)) - enddo - do ii=1,nat_sent - i=iat_sent(ii) -c write (iout,*) "make contact list longrange",i,ii," num_cont", -c & num_cont_hb(i) - do j=1,num_cont_hb(i) - do k=1,4 - jjc=jcont_hb(j,i) - iproc=iint_sent_local(k,jjc,ii) -c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc - if (iproc.ne.0) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=i - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=d_cont(j,i) - ind=3 - do kk=1,3 - ind=ind+1 - zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i) - enddo - enddo - enddo - enddo - endif - enddo - enddo - enddo - if (lprn) then - write (iout,*) - & "Numbers of contacts to be sent to other processors", - & (ncont_sent(i),i=1,ntask_cont_to) - write (iout,*) "Contacts sent" - do ii=1,ntask_cont_to - nn=ncont_sent(ii) - iproc=itask_cont_to(ii) - write (iout,*) nn," contacts to processor",iproc, - & " of CONT_TO_COMM group" - do i=1,nn - write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10) - enddo - enddo - call flush(iout) - endif - CorrelType=477 - CorrelID=fg_rank+1 - CorrelType1=478 - CorrelID1=nfgtasks+fg_rank+1 - ireq=0 -C Receive the numbers of needed contacts from other processors - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - ireq=ireq+1 - call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "IRECV ended" -c call flush(iout) -C Send the number of contacts needed by other processors - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - ireq=ireq+1 - call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "ISEND ended" -c write (iout,*) "number of requests (nn)",ireq - call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) -c write (iout,*) -c & "Numbers of contacts to be received from other processors", -c & (ncont_recv(i),i=1,ntask_cont_from) -c call flush(iout) -C Receive contacts - ireq=0 - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - nn=ncont_recv(ii) -c write (iout,*) "Receiving",nn," contacts from processor",iproc, -c & " of CONT_TO_COMM group" - call flush(iout) - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, - & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) - endif - enddo -C Send the contacts to processors that need them - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - nn=ncont_sent(ii) -c write (iout,*) nn," contacts to processor",iproc, -c & " of CONT_TO_COMM group" - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, - & iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) -c do i=1,nn -c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) -c enddo - endif - enddo -c write (iout,*) "number of requests (contacts)",ireq -c write (iout,*) "req",(req(i),i=1,4) -c call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) - do iii=1,ntask_cont_from - iproc=itask_cont_from(iii) - nn=ncont_recv(iii) - if (lprn) then - write (iout,*) "Received",nn," contacts from processor",iproc, - & " of CONT_FROM_COMM group" - call flush(iout) - do i=1,nn - write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10) - enddo - call flush(iout) - endif - do i=1,nn - ii=zapas_recv(1,i,iii) -c Flag the received contacts to prevent double-counting - jj=-zapas_recv(2,i,iii) -c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj -c call flush(iout) - nnn=num_cont_hb(ii)+1 - num_cont_hb(ii)=nnn - jcont_hb(nnn,ii)=jj - d_cont(nnn,ii)=zapas_recv(3,i,iii) - ind=3 - do kk=1,3 - ind=ind+1 - grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii) - enddo - enddo - enddo - enddo - enddo - enddo - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,5f6.3))') - & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), - & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,5f6.3))') - & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), - & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 - ecorr5=0.0d0 - ecorr6=0.0d0 -C Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -C Calculate the dipole-dipole interaction energies - if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then - do i=iatel_s,iatel_e+1 - num_conti=num_cont_hb(i) - do jj=1,num_conti - j=jcont_hb(jj,i) -#ifdef MOMENT - call dipole(i,j,jj) -#endif - enddo - enddo - endif -C Calculate the local-electrostatic correlation terms -c write (iout,*) "gradcorr5 in eello5 before loop" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) -c write (iout,*) "corr loop i",i - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - jp=iabs(j) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) - jp1=iabs(j1) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk -c if (j1.eq.j+1 .or. j1.eq.j-1) then - if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 - & .or. j.lt.0 .and. j1.gt.0) .and. - & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then -C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -C The system gains extra energy. - n_corr=n_corr+1 - sqd1=dsqrt(d_cont(jj,i)) - sqd2=dsqrt(d_cont(kk,i1)) - sred_geom = sqd1*sqd2 - IF (sred_geom.lt.cutoff_corr) THEN - call gcont(sred_geom,r0_corr,1.0D0,delt_corr, - & ekont,fprimcont) -cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, -cd & ' jj=',jj,' kk=',kk - fac_prim1=0.5d0*sqd2/sqd1*fprimcont - fac_prim2=0.5d0*sqd1/sqd2*fprimcont - do l=1,3 - g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) - g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) - enddo - n_corr1=n_corr1+1 -cd write (iout,*) 'sred_geom=',sred_geom, -cd & ' ekont=',ekont,' fprim=',fprimcont, -cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 -cd write (iout,*) "g_contij",g_contij -cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) -cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) - call calc_eello(i,jp,i+1,jp1,jj,kk) - if (wcorr4.gt.0.0d0) - & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) - if (energy_dec.and.wcorr4.gt.0.0d0) - 1 write (iout,'(a6,4i5,0pf7.3)') - 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) -c write (iout,*) "gradcorr5 before eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - if (wcorr5.gt.0.0d0) - & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) -c write (iout,*) "gradcorr5 after eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - if (energy_dec.and.wcorr5.gt.0.0d0) - 1 write (iout,'(a6,4i5,0pf7.3)') - 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) -cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 -cd write(2,*)'ijkl',i,jp,i+1,jp1 - if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 - & .or. wturn6.eq.0.0d0))then -cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 - ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) - if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') - 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) -cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, -cd & 'ecorr6=',ecorr6 -cd write (iout,'(4e15.5)') sred_geom, -cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)), -cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)), -cd & dabs(eello6(i,jp,i+1,jp1,jj,kk)) - else if (wturn6.gt.0.0d0 - & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then -cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 - eturn6=eturn6+eello_turn6(i,jj,kk) - if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') - 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) -cd write (2,*) 'multibody_eello:eturn6',eturn6 - endif - ENDIF -1111 continue - endif - enddo ! kk - enddo ! jj - enddo ! i - do i=1,nres - num_cont_hb(i)=num_cont_hb_old(i) - enddo -c write (iout,*) "gradcorr5 in eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - return - end -c------------------------------------------------------------------------------ - subroutine add_hb_contact_eello(ii,jj,itask) - implicit real*8 (a-h,o-z) - include "DIMENSIONS" - include "COMMON.IOUNITS" - integer max_cont - integer max_dim - parameter (max_cont=maxconts) - parameter (max_dim=70) - include "COMMON.CONTACTS" - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer i,j,ii,jj,iproc,itask(4),nn -c write (iout,*) "itask",itask - do i=1,2 - iproc=itask(i) - if (iproc.gt.0) then - do j=1,num_cont_hb(ii) - jjc=jcont_hb(j,ii) -c write (iout,*) "send turns i",ii," j",jj," jjc",jjc - if (jjc.eq.jj) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=ii - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=d_cont(j,ii) - ind=3 - do kk=1,3 - ind=ind+1 - zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii) - enddo - enddo - enddo - enddo - exit - endif - enddo - endif - enddo - return - end -c------------------------------------------------------------------------------ - double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont_hb(jj,i) - ekl=facont_hb(kk,k) - ees0pij=ees0p(jj,i) - ees0pkl=ees0p(kk,k) - ees0mij=ees0m(jj,i) - ees0mkl=ees0m(kk,k) - ekont=eij*ekl - ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) -cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) -C Following 4 lines for diagnostics. -cd ees0pkl=0.0D0 -cd ees0pij=1.0D0 -cd ees0mkl=0.0D0 -cd ees0mij=1.0D0 -c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') -c & 'Contacts ',i,j, -c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l -c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, -c & 'gradcorr_long' -C Calculate the multi-body contribution to energy. -c ecorr=ecorr+ekont*ees -C Calculate multi-body contributions to the gradient. - coeffpees0pij=coeffp*ees0pij - coeffmees0mij=coeffm*ees0mij - coeffpees0pkl=coeffp*ees0pkl - coeffmees0mkl=coeffm*ees0mkl - do ll=1,3 -cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) - gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi - & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb1(ll,jj,i)) - gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi - & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb2(ll,jj,i)) -cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k) - gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk - & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ - & coeffmees0mij*gacontm_hb1(ll,kk,k)) - gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk - & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ - & coeffmees0mij*gacontm_hb2(ll,kk,k)) - gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- - & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb3(ll,jj,i)) - gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij - gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij - gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- - & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ - & coeffmees0mij*gacontm_hb3(ll,kk,k)) - gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl - gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl -c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl - enddo -c write (iout,*) -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ -cgrad & ees*ekl*gacont_hbr(ll,jj,i)- -cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ -cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ -cgrad & ees*eij*gacont_hbr(ll,kk,k)- -cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ -cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) -cgrad enddo -cgrad enddo -c write (iout,*) "ehbcorr",ekont*ees - ehbcorr=ekont*ees - return - end -#ifdef MOMENT -C--------------------------------------------------------------------------- - subroutine dipole(i,j,jj) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), - & auxmat(2,2) - iti1 = itortyp(itype(i+1)) - if (j.lt.nres-1) then - itj1 = itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - do iii=1,2 - dipi(iii,1)=Ub2(iii,i) - dipderi(iii)=Ub2der(iii,i) - dipi(iii,2)=b1(iii,iti1) - dipj(iii,1)=Ub2(iii,j) - dipderj(iii)=Ub2der(iii,j) - dipj(iii,2)=b1(iii,itj1) - enddo - kkk=0 - do iii=1,2 - call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) - do jjj=1,2 - kkk=kkk+1 - dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - do kkk=1,5 - do lll=1,3 - mmm=0 - do iii=1,2 - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), - & auxvec(1)) - do jjj=1,2 - mmm=mmm+1 - dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - enddo - enddo - call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) - call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) - do iii=1,2 - dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) - enddo - call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) - do iii=1,2 - dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) - enddo - return - end -#endif -C--------------------------------------------------------------------------- - subroutine calc_eello(i,j,k,l,jj,kk) -C -C This subroutine computes matrices and vectors needed to calculate -C the fourth-, fifth-, and sixth-order local-electrostatic terms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), - & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) - logical lprn - common /kutas/ lprn -cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, -cd & ' jj=',jj,' kk=',kk -cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return -cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) -cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) - aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) - enddo - enddo - call transpose2(aa1(1,1),aa1t(1,1)) - call transpose2(aa2(1,1),aa2t(1,1)) - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), - & aa1tder(1,1,lll,kkk)) - call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), - & aa2tder(1,1,lll,kkk)) - enddo - enddo - if (l.eq.j+1) then -C parallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itj=itortyp(itype(j)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -C A1 kernel(j+1) A2T -cd do iii=1,2 -cd write (iout,'(3f10.5,5x,3f10.5)') -cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) -cd enddo - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), - & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - lprn=.false. - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), - & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants -cd lprn=.false. -cd if (lprn) then -cd write (2,*) 'In calc_eello6' -cd do iii=1,2 -cd write (2,*) 'iii=',iii -cd do kkk=1,5 -cd write (2,*) 'kkk=',kkk -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) -cd enddo -cd enddo -cd enddo -cd endif - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A1T kernel(i+1) A2 - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) -C Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - else -C Antiparallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif -C A2 kernel(j-1)T A1T - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. - & j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), - & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), - & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A2T kernel(i+1)T A1 - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. - & j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. - & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) -C Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - endif - return - end -C--------------------------------------------------------------------------- - subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, - & KK,KKderg,AKA,AKAderg,AKAderx) - implicit none - integer nderg - logical transp - double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), - & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), - & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) - integer iii,kkk,lll - integer jjj,mmm - logical lprn - common /kutas/ lprn - call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) - do iii=1,nderg - call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, - & AKAderg(1,1,iii)) - enddo -cd if (lprn) write (2,*) 'In kernel' - do kkk=1,5 -cd if (lprn) write (2,*) 'kkk=',kkk - do lll=1,3 - call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), - & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) -cd if (lprn) then -cd write (2,*) 'lll=',lll -cd write (2,*) 'iii=1' -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) -cd enddo -cd endif - call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), - & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) -cd if (lprn) then -cd write (2,*) 'lll=',lll -cd write (2,*) 'iii=2' -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) -cd enddo -cd endif - enddo - enddo - return - end -C--------------------------------------------------------------------------- - double precision function eello4(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then -cd eello4=0.0d0 -cd return -cd endif -cd print *,'eello4:',i,j,k,l,jj,kk -cd write (2,*) 'i',i,' j',j,' k',k,' l',l -cd call checkint4(i,j,k,l,jj,kk,eel4_num) -cold eij=facont_hb(jj,i) -cold ekl=facont_hb(kk,k) -cold ekont=eij*ekl - eel4=-EAEA(1,1,1)-EAEA(2,2,1) -cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) - gcorr_loc(k-1)=gcorr_loc(k-1) - & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) - if (l.eq.j+1) then - gcorr_loc(l-1)=gcorr_loc(l-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - else - gcorr_loc(j-1)=gcorr_loc(j-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) - & -EAEAderx(2,2,lll,kkk,iii,1) -cd derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd gcorr_loc(l-1)=0.0d0 -cd gcorr_loc(j-1)=0.0d0 -cd gcorr_loc(k-1)=0.0d0 -cd eel4=1.0d0 -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l, -cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel4*g_contij(ll,1) -cgrad ggg2(ll)=eel4*g_contij(ll,2) - glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) - glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) -cgrad ghalf=0.5d0*ggg1(ll) - gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) - gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) - gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) - gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) - gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij - gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij -cgrad ghalf=0.5d0*ggg2(ll) - gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) - gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) - gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) - gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) - gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl - gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl - enddo -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,gcorr_loc(iii) -cd enddo - eello4=ekont*eel4 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello4',ekont*eel4 - return - end -C--------------------------------------------------------------------------- - double precision function eello5(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) - double precision ggg1(3),ggg2(3) -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel chains C -C C -C o o o o C -C /l\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j| o |l1 | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C Antiparallel chains C -C C -C o o o o C -C /j\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j1| o |l | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C o denotes a local interaction, vertical lines an electrostatic interaction. C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then -cd eello5=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - itk=itortyp(itype(k)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - eello5_1=0.0d0 - eello5_2=0.0d0 - eello5_3=0.0d0 - eello5_4=0.0d0 -cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, -cd & eel5_3_num,eel5_4_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l -cd goto 1111 -C Contribution from the graph I. -cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) -cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) -C Explicit gradient in virtual-dihedral angles. - if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - if (l.eq.j+1) then - if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - else - if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) - enddo - enddo - enddo -c goto 1112 -c1111 continue -C Contribution from graph II - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - if (l.eq.j+1) then - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - else - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) - enddo - enddo - enddo -cd goto 1112 -cd1111 continue - if (l.eq.j+1) then -cd goto 1110 -C Parallel orientation -C Contribution from graph III - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) - call transpose2(EUgder(1,1,l),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) - enddo - enddo - enddo -cd goto 1112 -C Contribution from graph IV -cd1110 continue - call transpose2(EE(1,1,itl),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) - enddo - enddo - enddo - else -C Antiparallel orientation -C Contribution from graph III -c goto 1110 - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) - call transpose2(EUgder(1,1,j),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) - enddo - enddo - enddo -cd goto 1112 -C Contribution from graph IV -1110 continue - call transpose2(EE(1,1,itj),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) - enddo - enddo - enddo - endif -1112 continue - eel5=eello5_1+eello5_2+eello5_3+eello5_4 -cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then -cd write (2,*) 'ijkl',i,j,k,l -cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, -cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 -cd endif -cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num -cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num -cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num -cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 -cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont -C 2/11/08 AL Gradients over DC's connecting interacting sites will be -C summed up outside the subrouine as for the other subroutines -C handling long-range interactions. The old code is commented out -C with "cgrad" to keep track of changes. - do ll=1,3 -cgrad ggg1(ll)=eel5*g_contij(ll,1) -cgrad ggg2(ll)=eel5*g_contij(ll,2) - gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) - gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) -c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') -c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), -c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), -c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont -c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') -c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), -c & gradcorr5ij, -c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl -cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) - gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) - gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) - gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) - gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij - gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij -cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) -cgrad ghalf=0.5d0*ggg2(ll) -cd ghalf=0.0d0 - gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) - gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) - gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) - gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) - gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl - gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -c1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr5_loc(iii) -cd enddo - eello5=ekont*eel5 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello5',ekont*eel5 - return - end -c-------------------------------------------------------------------------- - double precision function eello6(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - eello6_1=0.0d0 - eello6_2=0.0d0 - eello6_3=0.0d0 - eello6_4=0.0d0 - eello6_5=0.0d0 - eello6_6=0.0d0 -cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, -cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - if (l.eq.j+1) then - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(j,i,l,k,2,.false.) - eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) - eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) - else - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(l,k,j,i,2,.true.) - eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - if (wturn6.eq.0.0d0 .or. j.ne.i+4) then - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) - else - eello6_5=0.0d0 - endif - eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) - endif -C If turn contributions are considered, they will be handled separately. - eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 -cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num -cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num -cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num -cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num -cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num -cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num -cd goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel6*g_contij(ll,1) -cgrad ggg2(ll)=eel6*g_contij(ll,2) -cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) - gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) - gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) - gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) - gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) - gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) - gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij - gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij -cgrad ghalf=0.5d0*ggg2(ll) -cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) -cd ghalf=0.0d0 - gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) - gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) - gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) - gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) - gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl - gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr6_loc(iii) -cd enddo - eello6=ekont*eel6 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello6',ekont*eel6 - return - end -c-------------------------------------------------------------------------- - double precision function eello6_graph1(i,j,k,l,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) - logical swap - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C Parallel Antiparallel -C -C o o -C /l\ /j\ -C / \ / \ -C /| o | | o |\ -C \ j|/k\| / \ |/k\|l / -C \ / \ / \ / \ / -C o o o o -C i i -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - itk=itortyp(itype(k)) - s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) - vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 - eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) - if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) - & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) - & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) - & +scalar2(vv(1),Dtobr2der(1,i))) - call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) - vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) - if (l.eq.j+1) then - g_corr6_loc(l-1)=g_corr6_loc(l-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - endif - call transpose2(EUgCder(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) - & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) - & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) - do iii=1,2 - if (swap) then - ind=3-iii - else - ind=iii - endif - do kkk=1,5 - do lll=1,3 - s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) - & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) - vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) - & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) - derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph2(i,j,k,l,jj,kk,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - logical swap - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxvec2(2),auxmat1(2,2) - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C \ /l\ /j\ / C -C \ / \ / \ / C -C o| o | | o |o C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l -C AL 7/4/01 s1 would occur in the sixth-order moment, -C but not in a cluster cumulant -#ifdef MOMENT - s1=dip(1,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph2=-(s1+s2+s3+s4) -#else - eello6_graph2=-(s2+s3+s4) -#endif -c eello6_graph2=-s3 -C Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - s1=dipderg(1,jj,i)*dip(1,kk,k) -#endif - s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif -c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 - endif -C Derivatives in gamma(k-1) -#ifdef MOMENT - s1=dip(1,jj,i)*dipderg(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif -c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 -C Derivatives in gamma(j-1) or gamma(l-1) - if (j.gt.1) then -#ifdef MOMENT - s1=dipderg(3,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) - call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - if (swap) then - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 - endif -#endif - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) -c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 - endif -C Derivatives in gamma(l-1) or gamma(j-1) - if (l.gt.1) then -#ifdef MOMENT - s1=dip(1,jj,i)*dipderg(3,kk,k) -#endif - call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - if (swap) then - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 - else - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 - endif -#endif - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) -c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 - endif -C Cartesian derivatives. - if (lprn) then - write (2,*) 'In eello6_graph2' - do iii=1,2 - write (2,*) 'iii=',iii - do kkk=1,5 - write (2,*) 'kkk=',kkk - do jjj=1,2 - write (2,'(3(2f10.5),5x)') - & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) - enddo - enddo - enddo - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) - else - s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) - endif -#endif - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), - & auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), - & auxvec(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph3(i,j,k,l,jj,kk,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C j|/k\| / |/k\|l / C -C / \ / / \ / C -C / o / o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. - iti=itortyp(itype(i)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -#ifdef MOMENT - s1=dip(4,jj,i)*dip(4,kk,k) -#endif - call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, -cd & "sum",-(s2+s3+s4) -#ifdef MOMENT - eello6_graph3=-(s1+s2+s3+s4) -#else - eello6_graph3=-(s2+s3+s4) -#endif -c eello6_graph3=-s4 -C Derivatives in gamma(k-1) - call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) -C Derivatives in gamma(l-1) - call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) -C Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) - else - s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif -c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxmat1(2,2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o \ o \ C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. -cd write (2,*) 'eello_graph4: wturn6',wturn6 - iti=itortyp(itype(i)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - if (k.lt.nres-1) then - itk1=itortyp(itype(k+1)) - else - itk1=ntortyp+1 - endif - itl=itortyp(itype(l)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l -cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, -cd & ' itl',itl,' itl1',itl1 -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dip(3,kk,k) - else - s1=dip(2,jj,j)*dip(2,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph4=-(s1+s2+s3+s4) -#else - eello6_graph4=-(s2+s3+s4) -#endif -C Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - if (imat.eq.1) then - s1=dipderg(2,jj,i)*dip(3,kk,k) - else - s1=dipderg(4,jj,j)*dip(2,kk,l) - endif -#endif - s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -cd write (2,*) 'turn6 derivatives' -#ifdef MOMENT - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif - endif - endif -C Derivatives in gamma(k-1) -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderg(2,kk,k) - else - s1=dip(2,jj,j)*dipderg(4,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif - endif -C Derivatives in gamma(j-1) or gamma(l-1) - if (l.eq.j+1 .and. l.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) - else if (j.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then - gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) - endif - endif -C Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - if (imat.eq.1) then - s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) - else - s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) - endif - else - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) - else - s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) - endif - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), - & auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itj1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) - else - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itl1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) - endif - call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (swap) then - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s1+s2+s4) -#else - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s2+s4) -#endif - derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 - else -#ifdef MOMENT - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) -#else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) -#endif - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - else -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (l.eq.j+1) then - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - endif - endif - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello_turn6(i,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), - & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), - & ggg1(3),ggg2(3) - double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), - & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) -C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to -C the respective energy moment and not to the cluster cumulant. - s1=0.0d0 - s8=0.0d0 - s13=0.0d0 -c - eello_turn6=0.0d0 - j=i+4 - k=i+1 - l=i+3 - iti=itortyp(itype(i)) - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) -cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj -cd write (2,*) 'i',i,' k',k,' j',j,' l',l -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l -cd call checkint_turn6(i,jj,kk,eel_turn6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx_turn(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) -cd eello6_5=0.0d0 -cd write (2,*) 'eello6_5',eello6_5 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) - ss1=scalar2(Ub2(1,i+2),b1(1,itl)) - s1 = (auxmat(1,1)+auxmat(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) - s2 = scalar2(b1(1,itk),vtemp1(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atemp(1,1)) - call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) - call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) - s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) - s12 = scalar2(Ub2(1,i+2),vtemp3(1)) -#ifdef MOMENT - call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) - call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) - call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) - ss13 = scalar2(b1(1,itk),vtemp4(1)) - s13 = (gtemp(1,1)+gtemp(2,2))*ss13 -#endif -c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 -c s1=0.0d0 -c s2=0.0d0 -c s8=0.0d0 -c s12=0.0d0 -c s13=0.0d0 - eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) -C Derivatives in gamma(i+2) - s1d =0.0d0 - s8d =0.0d0 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 - call transpose2(AEAderg(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 - gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) -C Derivatives in gamma(i+3) -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d -#endif - call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) - s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) -#endif - s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) - & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) - & -0.5d0*ekont*(s2d+s12d) -#endif -C Derivatives in gamma(i+4) - call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -C s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) -#else - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) -#endif -C Derivatives in gamma(i+5) -#ifdef MOMENT - call transpose2(AEAderg(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) - & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) - & -0.5d0*ekont*(s2d+s12d) -#endif -C Cartesian derivatives - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), - & vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))* - & scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), - & auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) - & - 0.5d0*(s1d+s2d) -#else - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) - & - 0.5d0*s2d -#endif -#ifdef MOMENT - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) - & - 0.5d0*(s8d+s12d) -#else - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) - & - 0.5d0*s12d -#endif - enddo - enddo - enddo -#ifdef MOMENT - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), - & achuj_tempd(1,1)) - call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d=(gtempd(1,1)+gtempd(2,2))*ss13 - derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), - & vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d - derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d - enddo - enddo -#endif -cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', -cd & 16*eel_turn6_num -cd goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel_turn6*g_contij(ll,1) -cgrad ggg2(ll)=eel_turn6*g_contij(ll,2) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) - gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) - gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf - & +ekont*derx_turn(ll,2,1) - gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) - gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf - & +ekont*derx_turn(ll,4,1) - gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) - gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij - gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij -cgrad ghalf=0.5d0*ggg2(ll) -cd ghalf=0.0d0 - gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf - & +ekont*derx_turn(ll,2,2) - gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) - gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf - & +ekont*derx_turn(ll,4,2) - gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) - gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl - gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr6_loc(iii) -cd enddo - eello_turn6=ekont*eel_turn6 -cd write (2,*) 'ekont',ekont -cd write (2,*) 'eel_turn6',ekont*eel_turn6 - return - end - -C----------------------------------------------------------------------------- - double precision function scalar(u,v) -!DIR$ INLINEALWAYS scalar -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::scalar -#endif - implicit none - double precision u(3),v(3) -cd double precision sc -cd integer i -cd sc=0.0d0 -cd do i=1,3 -cd sc=sc+u(i)*v(i) -cd enddo -cd scalar=sc - - scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3) - return - end -crc------------------------------------------------- - SUBROUTINE MATVEC2(A1,V1,V2) -!DIR$ INLINEALWAYS MATVEC2 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2 -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),V1(2),V2(2) -c DO 1 I=1,2 -c VI=0.0 -c DO 3 K=1,2 -c 3 VI=VI+A1(I,K)*V1(K) -c Vaux(I)=VI -c 1 CONTINUE - - vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) - vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) - - v2(1)=vaux1 - v2(2)=vaux2 - END -C--------------------------------------- - SUBROUTINE MATMAT2(A1,A2,A3) -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2 -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),A2(2,2),A3(2,2) -c DIMENSION AI3(2,2) -c DO J=1,2 -c A3IJ=0.0 -c DO K=1,2 -c A3IJ=A3IJ+A1(I,K)*A2(K,J) -c enddo -c A3(I,J)=A3IJ -c enddo -c enddo - - ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) - ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) - ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) - ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) - - A3(1,1)=AI3_11 - A3(2,1)=AI3_21 - A3(1,2)=AI3_12 - A3(2,2)=AI3_22 - END - -c------------------------------------------------------------------------- - double precision function scalar2(u,v) -!DIR$ INLINEALWAYS scalar2 - implicit none - double precision u(2),v(2) - double precision sc - integer i - scalar2=u(1)*v(1)+u(2)*v(2) - return - end - -C----------------------------------------------------------------------------- - - subroutine transpose2(a,at) -!DIR$ INLINEALWAYS transpose2 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::transpose2 -#endif - implicit none - double precision a(2,2),at(2,2) - at(1,1)=a(1,1) - at(1,2)=a(2,1) - at(2,1)=a(1,2) - at(2,2)=a(2,2) - return - end -c-------------------------------------------------------------------------- - subroutine transpose(n,a,at) - implicit none - integer n,i,j - double precision a(n,n),at(n,n) - do i=1,n - do j=1,n - at(j,i)=a(i,j) - enddo - enddo - return - end -C--------------------------------------------------------------------------- - subroutine prodmat3(a1,a2,kk,transp,prod) -!DIR$ INLINEALWAYS prodmat3 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::prodmat3 -#endif - implicit none - integer i,j - double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) - logical transp -crc double precision auxmat(2,2),prod_(2,2) - - if (transp) then -crc call transpose2(kk(1,1),auxmat(1,1)) -crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) - - else -crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) - - endif -c call transpose2(a2(1,1),a2t(1,1)) - -crc print *,transp -crc print *,((prod_(i,j),i=1,2),j=1,2) -crc print *,((prod(i,j),i=1,2),j=1,2) - - return - end - diff --git a/source/unres/src_MD_DFA/energy_split-sep.F b/source/unres/src_MD_DFA/energy_split-sep.F deleted file mode 100644 index 81e4d81..0000000 --- a/source/unres/src_MD_DFA/energy_split-sep.F +++ /dev/null @@ -1,476 +0,0 @@ - subroutine etotal_long(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -c -c Compute the long-range slow-varying contributions to the energy -c -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.MD' -c write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot - if (modecalc.eq.12.or.modecalc.eq.14) then -#ifdef MPI -c if (fg_rank.eq.0) call int_from_cart1(.false.) -#else - call int_from_cart1(.false.) -#endif - endif -#ifdef MPI -c write(iout,*) "ETOTAL_LONG Processor",fg_rank, -c & " absolute rank",myrank," nfgtasks",nfgtasks - call flush(iout) - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR) -c write (iout,*) "Processor",myrank," BROADCAST iorder" -c call flush(iout) -C FG master sets up the WEIGHTS_ array which will be broadcast to the -C FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -C FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -C FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - endif - call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 - time_Bcastw=time_Bcastw+MPI_Wtime()-time00 -c call chainbuild_cart -c call int_from_cart1(.false.) - endif -c write (iout,*) 'Processor',myrank, -c & ' calling etotal_short ipot=',ipot -c call flush(iout) -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#endif -cd print *,'nnt=',nnt,' nct=',nct -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105,106) ipot -C Lennard-Jones potential. - 101 call elj_long(evdw) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk_long(evdw) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp_long(evdw) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb_long(evdw,evdw_p,evdw_m) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv_long(evdw) - goto 107 -C Soft-sphere potential - 106 call e_softsphere(evdw) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 continue - call vec_and_deriv - if (ipot.lt.6) then -#ifdef SPLITELE - if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#else - if (welec.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#endif - call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) - else - ees=0 - evdw1=0 - eel_loc=0 - eello_turn3=0 - eello_turn4=0 - endif - else -c write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, - & eello_turn4) - endif -C -C Calculate excluded-volume interaction energy between peptide groups -C and side chains. -C - if (ipot.lt.6) then - if(wscp.gt.0d0) then - call escp_long(evdw2,evdw2_14) - else - evdw2=0 - evdw2_14=0 - endif - else - call escp_soft_sphere(evdw2,evdw2_14) - endif -C -C 12/1/95 Multi-body terms -C - n_corr=0 - n_corr1=0 - if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 - & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then - call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -c write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1, -c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) - endif -C -C If performing constraint dynamics, call the constraint energy -C after the equilibration time - if(usampl.and.totT.gt.eq_time) then - call EconstrQ - call Econstr_back - else - Uconst=0.0d0 - Uconst_back=0.0d0 - endif -C -C Sum the energies -C - do i=1,n_ene - energia(i)=0.0d0 - enddo - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(20)=Uconst+Uconst_back - energia(22)=evdw_p - energia(23)=evdw_m - call sum_energy(energia,.true.) -c write (iout,*) "Exit ETOTAL_LONG" - call flush(iout) - return - end -c------------------------------------------------------------------------------ - subroutine etotal_short(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -c -c Compute the short-range fast-varying contributions to the energy -c -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - -c write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot -c call flush(iout) - if (modecalc.eq.12.or.modecalc.eq.14) then -#ifdef MPI - if (fg_rank.eq.0) call int_from_cart1(.false.) -#else - call int_from_cart1(.false.) -#endif - endif -#ifdef MPI -c write(iout,*) "ETOTAL_SHORT Processor",fg_rank, -c & " absolute rank",myrank," nfgtasks",nfgtasks -c call flush(iout) - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR) -c write (iout,*) "Processor",myrank," BROADCAST iorder" -c call flush(iout) -C FG master sets up the WEIGHTS_ array which will be broadcast to the -C FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -C FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -C FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - endif -c write (iout,*),"Processor",myrank," BROADCAST weights" - call MPI_Bcast(c(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST c" - call MPI_Bcast(dc(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST dc" - call MPI_Bcast(dc_norm(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST dc_norm" - call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST theta" - call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST phi" - call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST alph" - call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST omeg" - call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST vbld" - call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -c write (iout,*) "Processor",myrank," BROADCAST vbld_inv" - endif -c write (iout,*) 'Processor',myrank, -c & ' calling etotal_short ipot=',ipot -c call flush(iout) -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#endif -c call int_from_cart1(.false.) -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105,106) ipot -C Lennard-Jones potential. - 101 call elj_short(evdw) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk_short(evdw) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp_short(evdw) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb_short(evdw,evdw_p,evdw_m) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv_short(evdw) - goto 107 -C Soft-sphere potential - already dealt with in the long-range part - 106 evdw=0.0d0 -c 106 call e_softsphere_short(evdw) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 continue -c -c Calculate the short-range part of Evdwpp -c - call evdwpp_short(evdw1) -c -c Calculate the short-range part of ESCp -c - if (ipot.lt.6) then - call escp_short(evdw2,evdw2_14) - endif -c -c Calculate the bond-stretching energy -c - call ebond(estr) -C -C Calculate the disulfide-bridge and other energy and the contributions -C from other distance constraints. - call edis(ehpb) -C -C Calculate the virtual-bond-angle energy. -C - call ebend(ebe) -C -C Calculate the SC local energy. -C - call vec_and_deriv - call esc(escloc) -C -C Calculate the virtual-bond torsional energy. -C - call etor(etors,edihcnstr) -C -C 6/23/01 Calculate double-torsional energy -C - call etor_d(etors_d) -C -C 21/5/07 Calculate local sicdechain correlation energy -C - if (wsccor.gt.0.0d0) then - call eback_sc_corr(esccor) - else - esccor=0.0d0 - endif -C -C Put energy components into an array -C - do i=1,n_ene - energia(i)=0.0d0 - enddo - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(16)=evdw1 -#else - energia(3)=evdw1 -#endif - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(17)=estr - energia(19)=edihcnstr - energia(21)=esccor - energia(22)=evdw_p - energia(23)=evdw_m -c write (iout,*) "ETOTAL_SHORT before SUM_ENERGY" - call flush(iout) - call sum_energy(energia,.true.) -c write (iout,*) "Exit ETOTAL_SHORT" - call flush(iout) - return - end diff --git a/source/unres/src_MD_DFA/entmcm.F b/source/unres/src_MD_DFA/entmcm.F deleted file mode 100644 index 3c2dc5a..0000000 --- a/source/unres/src_MD_DFA/entmcm.F +++ /dev/null @@ -1,684 +0,0 @@ - subroutine entmcm -C Does modified entropic sampling in the space of minima. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPL - include 'COMMON.INFO' -#endif - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.THREAD' - include 'COMMON.NAMES' - logical accepted,not_done,over,ovrtim,error,lprint - integer MoveType,nbond - integer conf_comp - double precision RandOrPert - double precision varia(maxvar),elowest,ehighest,eold - double precision przes(3),obr(3,3) - double precision varold(maxvar) - logical non_conv - double precision energia(0:n_ene),energia_ave(0:n_ene) -C -cd write (iout,*) 'print_mc=',print_mc - WhatsUp=0 - maxtrial_iter=50 -c--------------------------------------------------------------------------- -C Initialize counters. -c--------------------------------------------------------------------------- -C Total number of generated confs. - ngen=0 -C Total number of moves. In general this won't be equal to the number of -C attempted moves, because we may want to reject some "bad" confs just by -C overlap check. - nmove=0 -C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... -C motions. - do i=1,nres - nbond_move(i)=0 - enddo -C Initialize total and accepted number of moves of various kind. - do i=0,MaxMoveType - moves(i)=0 - moves_acc(i)=0 - enddo -C Total number of energy evaluations. - neneval=0 - nfun=0 - indminn=-max_ene - indmaxx=max_ene - delte=0.5D0 - facee=1.0D0/(maxacc*delte) - conste=dlog(facee) -C Read entropy from previous simulations. - if (ent_read) then - read (ientin,*) indminn,indmaxx,emin,emax - print *,'indminn=',indminn,' indmaxx=',indmaxx,' emin=',emin, - & ' emax=',emax - do i=-max_ene,max_ene - entropy(i)=(emin+i*delte)*betbol - enddo - read (ientin,*) (ijunk,ejunk,entropy(i),i=indminn,indmaxx) - indmin=indminn - indmax=indmaxx - write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx, - & ' emin=',emin,' emax=',emax - write (iout,'(/a)') 'Initial entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - endif ! ent_read -C Read the pool of conformations - call read_pool -C---------------------------------------------------------------------------- -C Entropy-sampling simulations with continually updated entropy -C Loop thru simulations -C---------------------------------------------------------------------------- - DO ISWEEP=1,NSWEEP -C---------------------------------------------------------------------------- -C Take a conformation from the pool -C---------------------------------------------------------------------------- - if (npool.gt.0) then - ii=iran_num(1,npool) - do i=1,nvar - varia(i)=xpool(i,ii) - enddo - write (iout,*) 'Took conformation',ii,' from the pool energy=', - & epool(ii) - call var_to_geom(nvar,varia) -C Print internal coordinates of the initial conformation - call intout - else - call gen_rand_conf(1,*20) - endif -C---------------------------------------------------------------------------- -C Compute and print initial energies. -C---------------------------------------------------------------------------- - nsave=0 -#ifdef MPL - if (MyID.eq.MasterID) then - do i=1,nctasks - nsave_part(i)=0 - enddo - endif -#endif - Kwita=0 - WhatsUp=0 - write (iout,'(/80(1h*)/a,i2/80(1h*)/)') 'MCE iteration #',isweep - write (iout,'(/80(1h*)/a)') 'Initial energies:' - call chainbuild - call etotal(energia(0)) - etot = energia(0) - call enerprint(energia(0)) -C Minimize the energy of the first conformation. - if (minim) then - call geom_to_var(nvar,varia) - call minimize(etot,varia,iretcode,nfun) - call etotal(energia(0)) - etot = energia(0) - write (iout,'(/80(1h*)/a/80(1h*))') - & 'Results of the first energy minimization:' - call enerprint(energia(0)) - endif - if (refstr) then - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes, - & obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order:',co - write (istat,'(i5,11(1pe14.5))') 0, - & (energia(print_order(i)),i=1,nprint_ene),etot,rms,frac,co - else - write (istat,'(i5,9(1pe14.5))') 0, - & (energia(print_order(i)),i=1,nprint_ene),etot - endif - close(istat) - neneval=neneval+nfun+1 - if (.not. ent_read) then -C Initialize the entropy array - do i=-max_ene,max_ene - emin=etot -C Uncomment the line below for actual entropic sampling (start with uniform -C energy distribution). -c entropy(i)=0.0D0 -C Uncomment the line below for multicanonical sampling (start with Boltzmann -C distribution). - entropy(i)=(emin+i*delte)*betbol - enddo - emax=10000000.0D0 - emin=etot - write (iout,'(/a)') 'Initial entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - endif ! ent_read -#ifdef MPL - call recv_stop_sig(Kwita) - if (whatsup.eq.1) then - call send_stop_sig(-2) - not_done=.false. - else if (whatsup.le.-2) then - not_done=.false. - else if (whatsup.eq.2) then - not_done=.false. - else - not_done=.true. - endif -#else - not_done = (iretcode.ne.11) -#endif - write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Enter Monte Carlo procedure.' - close(igeom) - call briefout(0,etot) - do i=1,nvar - varold(i)=varia(i) - enddo - eold=etot - indeold=(eold-emin)/delte - deix=eold-(emin+indeold*delte) - dent=entropy(indeold+1)-entropy(indeold) -cd write (iout,*) 'indeold=',indeold,' deix=',deix,' dent=',dent -cd write (*,*) 'Processor',MyID,' indeold=',indeold,' deix=',deix, -cd & ' dent=',dent - sold=entropy(indeold)+(dent/delte)*deix - elowest=etot - write (iout,*) 'eold=',eold,' sold=',sold,' elowest=',etot - write (*,*) 'Processor',MyID,' eold=',eold,' sold=',sold, - & ' elowest=',etot - if (minim) call zapis(varia,etot) - nminima(1)=1.0D0 -C NACC is the counter for the accepted conformations of a given processor - nacc=0 -C NACC_TOT counts the total number of accepted conformations - nacc_tot=0 -#ifdef MPL - if (MyID.eq.MasterID) then - call receive_MCM_info - else - call send_MCM_info(2) - endif -#endif - do iene=indminn,indmaxx - nhist(iene)=0.0D0 - enddo - do i=2,maxsave - nminima(i)=0.0D0 - enddo -C Main loop. -c---------------------------------------------------------------------------- - elowest=1.0D10 - ehighest=-1.0D10 - it=0 - do while (not_done) - it=it+1 - if (print_mc.gt.0) write (iout,'(80(1h*)/20x,a,i7)') - & 'Beginning iteration #',it -C Initialize local counter. - ntrial=0 ! # of generated non-overlapping confs. - noverlap=0 ! # of overlapping confs. - accepted=.false. - do while (.not. accepted .and. WhatsUp.eq.0 .and. Kwita.eq.0) - ntrial=ntrial+1 -C Retrieve the angles of previously accepted conformation - do j=1,nvar - varia(j)=varold(j) - enddo -cd write (iout,'(a)') 'Old variables:' -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - call var_to_geom(nvar,varia) -C Rebuild the chain. - call chainbuild - MoveType=0 - nbond=0 - lprint=.true. -C Decide whether to generate a random conformation or perturb the old one - RandOrPert=ran_number(0.0D0,1.0D0) - if (RandOrPert.gt.RanFract) then - if (print_mc.gt.0) - & write (iout,'(a)') 'Perturbation-generated conformation.' - call perturb(error,lprint,MoveType,nbond,1.0D0) - if (error) goto 20 - if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then - write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=', - & MoveType,' returned from PERTURB.' - goto 20 - endif - call chainbuild - else - MoveType=0 - moves(0)=moves(0)+1 - nstart_grow=iran_num(3,nres) - if (print_mc.gt.0) - & write (iout,'(2a,i3)') 'Random-generated conformation', - & ' - chain regrown from residue',nstart_grow - call gen_rand_conf(nstart_grow,*30) - endif - call geom_to_var(nvar,varia) -cd write (iout,'(a)') 'New variables:' -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - ngen=ngen+1 - if (print_mc.gt.0) write (iout,'(a,i5,a,i10,a,i10)') - & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen - if (print_mc.gt.0) write (*,'(a,i5,a,i10,a,i10)') - & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen - call etotal(energia(0)) - etot = energia(0) -c call enerprint(energia(0)) -c write (iout,'(2(a,1pe14.5))') 'Etot=',Etot,' Elowest=',Elowest - if (etot-elowest.gt.overlap_cut) then - write (iout,'(a,i5,a,1pe14.5)') 'Iteration',it, - & ' Overlap detected in the current conf.; energy is',etot - neneval=neneval+1 - accepted=.false. - noverlap=noverlap+1 - if (noverlap.gt.maxoverlap) then - write (iout,'(a)') 'Too many overlapping confs.' - goto 20 - endif - else - if (minim) then - call minimize(etot,varia,iretcode,nfun) -cd write (iout,'(a)') 'Variables after minimization:' -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - call etotal(energia(0)) - etot = energia(0) - neneval=neneval+nfun+1 - endif - if (print_mc.gt.2) then - write (iout,'(a)') 'Total energies of trial conf:' - call enerprint(energia(0)) - else if (print_mc.eq.1) then - write (iout,'(a,i6,a,1pe16.6)') - & 'Trial conformation:',ngen,' energy:',etot - endif -C-------------------------------------------------------------------------- -C... Acceptance test -C-------------------------------------------------------------------------- - accepted=.false. - if (WhatsUp.eq.0) - & call accepting(etot,eold,scur,sold,varia,varold, - & accepted) - if (accepted) then - nacc=nacc+1 - nacc_tot=nacc_tot+1 - if (elowest.gt.etot) elowest=etot - if (ehighest.lt.etot) ehighest=etot - moves_acc(MoveType)=moves_acc(MoveType)+1 - if (MoveType.eq.1) then - nbond_acc(nbond)=nbond_acc(nbond)+1 - endif -C Check against conformation repetitions. - irep=conf_comp(varia,etot) -#if defined(AIX) || defined(PGI) - open (istat,file=statname,position='append') -#else - open (istat,file=statname,access='append') -#endif - if (refstr) then - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup, - & przes,obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - if (print_mc.gt.0) - & write (iout,'(a,f8.3,a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order:',co - if (print_stat) - & write (istat,'(i5,11(1pe14.5))') it, - & (energia(print_order(i)),i=1,nprint_ene),etot, - & rms,frac,co - elseif (print_stat) then - write (istat,'(i5,10(1pe14.5))') it, - & (energia(print_order(i)),i=1,nprint_ene),etot - endif - close(istat) - if (print_mc.gt.1) - & call statprint(nacc,nfun,iretcode,etot,elowest) -C Print internal coordinates. - if (print_int) call briefout(nacc,etot) -#ifdef MPL - if (MyID.ne.MasterID) then - call recv_stop_sig(Kwita) -cd print *,'Processor:',MyID,' STOP=',Kwita - if (irep.eq.0) then - call send_MCM_info(2) - else - call send_MCM_info(1) - endif - endif -#endif -C Store the accepted conf. and its energy. - eold=etot - sold=scur - do i=1,nvar - varold(i)=varia(i) - enddo - if (irep.eq.0) then - irep=nsave+1 -cd write (iout,*) 'Accepted conformation:' -cd write (iout,*) (rad2deg*varia(i),i=1,nphi) - if (minim) call zapis(varia,etot) - do i=1,n_ene - ener(i,nsave)=energia(i) - enddo - ener(n_ene+1,nsave)=etot - ener(n_ene+2,nsave)=frac - endif - nminima(irep)=nminima(irep)+1.0D0 -c print *,'irep=',irep,' nminima=',nminima(irep) -#ifdef MPL - if (Kwita.eq.0) call recv_stop_sig(kwita) -#endif - endif ! accepted - endif ! overlap -#ifdef MPL - if (MyID.eq.MasterID) then - call receive_MCM_info - if (nacc_tot.ge.maxacc) accepted=.true. - endif -#endif - if (ntrial.gt.maxtrial_iter .and. npool.gt.0) then -C Take a conformation from the pool - ii=iran_num(1,npool) - do i=1,nvar - varia(i)=xpool(i,ii) - enddo - write (iout,*) 'Iteration',it,' max. # of trials exceeded.' - write (iout,*) - & 'Take conformation',ii,' from the pool energy=',epool(ii) - if (print_mc.gt.2) - & write (iout,'(10f8.3)') (rad2deg*varia(i),i=1,nvar) - ntrial=0 - endif ! (ntrial.gt.maxtrial_iter .and. npool.gt.0) - 30 continue - enddo ! accepted -#ifdef MPL - if (MyID.eq.MasterID) then - call receive_MCM_info - endif - if (Kwita.eq.0) call recv_stop_sig(kwita) -#endif - if (ovrtim()) WhatsUp=-1 -cd write (iout,*) 'WhatsUp=',WhatsUp,' Kwita=',Kwita - not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) - & .and. (Kwita.eq.0) -cd write (iout,*) 'not_done=',not_done -#ifdef MPL - if (Kwita.lt.0) then - print *,'Processor',MyID, - & ' has received STOP signal =',Kwita,' in EntSamp.' -cd print *,'not_done=',not_done - if (Kwita.lt.-1) WhatsUp=Kwita - else if (nacc_tot.ge.maxacc) then - print *,'Processor',MyID,' calls send_stop_sig,', - & ' because a sufficient # of confs. have been collected.' -cd print *,'not_done=',not_done - call send_stop_sig(-1) - else if (WhatsUp.eq.-1) then - print *,'Processor',MyID, - & ' calls send_stop_sig because of timeout.' -cd print *,'not_done=',not_done - call send_stop_sig(-2) - endif -#endif - enddo ! not_done - -C----------------------------------------------------------------- -C... Construct energy histogram & update entropy -C----------------------------------------------------------------- - go to 21 - 20 WhatsUp=-3 -#ifdef MPL - write (iout,*) 'Processor',MyID, - & ' is broadcasting ERROR-STOP signal.' - write (*,*) 'Processor',MyID, - & ' is broadcasting ERROR-STOP signal.' - call send_stop_sig(-3) -#endif - 21 continue -#ifdef MPL - if (MyID.eq.MasterID) then -c call receive_MCM_results - call receive_energies -#endif - do i=1,nsave - if (esave(i).lt.elowest) elowest=esave(i) - if (esave(i).gt.ehighest) ehighest=esave(i) - enddo - write (iout,'(a,i10)') '# of accepted confs:',nacc_tot - write (iout,'(a,f10.5,a,f10.5)') 'Lowest energy:',elowest, - & ' Highest energy',ehighest - if (isweep.eq.1 .and. .not.ent_read) then - emin=elowest - emax=ehighest - write (iout,*) 'EMAX=',emax - indminn=0 - indmaxx=(ehighest-emin)/delte - indmin=indminn - indmax=indmaxx - do i=-max_ene,max_ene - entropy(i)=(emin+i*delte)*betbol - enddo - ent_read=.true. - else - indmin=(elowest-emin)/delte - indmax=(ehighest-emin)/delte - if (indmin.lt.indminn) indminn=indmin - if (indmax.gt.indmaxx) indmaxx=indmax - endif - write(iout,*)'indminn=',indminn,' indmaxx=',indmaxx -C Construct energy histogram - do i=1,nsave - inde=(esave(i)-emin)/delte - nhist(inde)=nhist(inde)+nminima(i) - enddo -C Update entropy (density of states) - do i=indmin,indmax - if (nhist(i).gt.0) then - entropy(i)=entropy(i)+dlog(nhist(i)+0.0D0) - endif - enddo -Cd do i=indmaxx+1 -Cd entropy(i)=1.0D+10 -Cd enddo - write (iout,'(/80(1h*)/a,i2/80(1h*)/)') - & 'End of macroiteration',isweep - write (iout,'(a,f10.5,a,f10.5)') 'Elowest=',elowest, - & ' Ehighest=',ehighest - write (iout,'(a)') 'Frequecies of minima' - do i=1,nsave - write (iout,'(i5,f5.0,f10.5)') i,nminima(i),esave(i) - enddo - write (iout,'(/a)') 'Energy histogram' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,nhist(i) - enddo - write (iout,'(/a)') 'Entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo -C----------------------------------------------------------------- -C... End of energy histogram construction -C----------------------------------------------------------------- -#ifdef MPL - entropy(-max_ene-4)=dfloat(indminn) - entropy(-max_ene-3)=dfloat(indmaxx) - entropy(-max_ene-2)=emin - entropy(-max_ene-1)=emax - call send_MCM_update -cd print *,entname,ientout - open (ientout,file=entname,status='unknown') - write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax - do i=indminn,indmaxx - write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) - enddo - close(ientout) - else - write (iout,'(a)') 'Frequecies of minima' - do i=1,nsave - write (iout,'(i5,f5.0,f10.5)') i,nminima(i),esave(i) - enddo -c call send_MCM_results - call send_energies - call receive_MCM_update - indminn=entropy(-max_ene-4) - indmaxx=entropy(-max_ene-3) - emin=entropy(-max_ene-2) - emax=entropy(-max_ene-1) - write (iout,*) 'Received from master:' - write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx, - & ' emin=',emin,' emax=',emax - write (iout,'(/a)') 'Entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - endif - if (WhatsUp.lt.-1) return -#else - if (ovrtim() .or. WhatsUp.lt.0) return -#endif - - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc,nfun,iretcode,etot,elowest) - write (iout,'(a)') - & 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) - write (iout,'(a,i10)') 'Number of chain regrowths:',nregrow - write (iout,'(a,i10)') 'Accepted chain regrowths:',nregrow_acc - -C--------------------------------------------------------------------------- - ENDDO ! ISWEEP -C--------------------------------------------------------------------------- - - runtime=tcpu() - - if (isweep.eq.nsweep .and. it.ge.maxacc) - &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' - return - end -c------------------------------------------------------------------------------ - subroutine accepting(ecur,eold,scur,sold,x,xold,accepted) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' -#ifdef MPL - include 'COMMON.INFO' -#endif - include 'COMMON.GEO' - double precision ecur,eold,xx,ran_number,bol - double precision x(maxvar),xold(maxvar) - double precision tole /1.0D-1/, tola /5.0D0/ - logical accepted -C Check if the conformation is similar. -cd write (iout,*) 'Enter ACCEPTING' -cd write (iout,*) 'Old PHI angles:' -cd write (iout,*) (rad2deg*xold(i),i=1,nphi) -cd write (iout,*) 'Current angles' -cd write (iout,*) (rad2deg*x(i),i=1,nphi) -cd ddif=dif_ang(nphi,x,xold) -cd write (iout,*) 'Angle norm:',ddif -cd write (iout,*) 'ecur=',ecur,' emax=',emax - if (ecur.gt.emax) then - accepted=.false. - if (print_mc.gt.0) - & write (iout,'(a)') 'Conformation rejected as too high in energy' - return - else if (dabs(ecur-eold).lt.tole .and. - & dif_ang(nphi,x,xold).lt.tola) then - accepted=.false. - if (print_mc.gt.0) - & write (iout,'(a)') 'Conformation rejected as too similar' - return - endif -C Else evaluate the entropy of the conf and compare it with that of the previous -C one. - indecur=(ecur-emin)/delte - if (iabs(indecur).gt.max_ene) then - write (iout,'(a,2i5)') - & 'Accepting: Index out of range:',indecur - scur=1000.0D0 - else if (indecur.eq.indmaxx) then - scur=entropy(indecur) - if (print_mc.gt.0) write (iout,*)'Energy boundary reached', - & indmaxx,indecur,entropy(indecur) - else - deix=ecur-(emin+indecur*delte) - dent=entropy(indecur+1)-entropy(indecur) - scur=entropy(indecur)+(dent/delte)*deix - endif -cd print *,'Processor',MyID,' ecur=',ecur,' indecur=',indecur, -cd & ' scur=',scur,' eold=',eold,' sold=',sold -cd print *,'deix=',deix,' dent=',dent,' delte=',delte - if (print_mc.gt.1) then - write(iout,*)'ecur=',ecur,' indecur=',indecur,' scur=',scur - write(iout,*)'eold=',eold,' sold=',sold - endif - if (scur.le.sold) then - accepted=.true. - else -C Else carry out acceptance test - xx=ran_number(0.0D0,1.0D0) - xxh=scur-sold - if (xxh.gt.50.0D0) then - bol=0.0D0 - else - bol=exp(-xxh) - endif - if (bol.gt.xx) then - accepted=.true. - if (print_mc.gt.0) write (iout,'(a)') - & 'Conformation accepted.' - else - accepted=.false. - if (print_mc.gt.0) write (iout,'(a)') - & 'Conformation rejected.' - endif - endif - return - end -c----------------------------------------------------------------------------- - subroutine read_pool - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.VAR' - double precision varia(maxvar) - print '(a)','Call READ_POOL' - do npool=1,max_pool - print *,'i=',i - read (intin,'(i5,f10.5)',end=10,err=10) iconf,epool(npool) - if (epool(npool).eq.0.0D0) goto 10 - call read_angles(intin,*10) - call geom_to_var(nvar,xpool(1,npool)) - enddo - goto 11 - 10 npool=npool-1 - 11 write (iout,'(a,i5)') 'Number of pool conformations:',npool - if (print_mc.gt.2) then - do i=1,npool - write (iout,'(a,i5,a,1pe14.5)') 'Pool conformation',i,' energy', - & epool(i) - write (iout,'(10f8.3)') (rad2deg*xpool(j,i),j=1,nvar) - enddo - endif ! (print_mc.gt.2) - return - end diff --git a/source/unres/src_MD_DFA/fitsq.f b/source/unres/src_MD_DFA/fitsq.f deleted file mode 100644 index 36cbd30..0000000 --- a/source/unres/src_MD_DFA/fitsq.f +++ /dev/null @@ -1,364 +0,0 @@ - subroutine fitsq(rms,x,y,nn,t,b,non_conv) - implicit real*8 (a-h,o-z) - include 'COMMON.IOUNITS' -c x and y are the vectors of coordinates (dimensioned (3,n)) of the two -c structures to be superimposed. nn is 3*n, where n is the number of -c points. t and b are respectively the translation vector and the -c rotation matrix that transforms the second set of coordinates to the -c frame of the first set. -c eta = machine-specific variable - - dimension x(3*nn),y(3*nn),t(3) - dimension b(3,3),q(3,3),r(3,3),v(3),xav(3),yav(3),e(3),c(3,3) - logical non_conv -c eta = z00100000 -c small=25.0*rmdcon(3) -c small=25.0*eta -c small=25.0*10.e-10 -c the following is a very lenient value for 'small' - small = 0.0001D0 - non_conv=.false. - fn=nn - do 10 i=1,3 - xav(i)=0.0D0 - yav(i)=0.0D0 - do 10 j=1,3 - 10 b(j,i)=0.0D0 - nc=0 -c - do 30 n=1,nn - do 20 i=1,3 -c write(iout,*)'x = ',x(nc+i),' y = ',y(nc+i) - xav(i)=xav(i)+x(nc+i)/fn - 20 yav(i)=yav(i)+y(nc+i)/fn - 30 nc=nc+3 -c - do i=1,3 - t(i)=yav(i)-xav(i) - enddo - - rms=0.0d0 - do n=1,nn - do i=1,3 - rms=rms+(y(3*(n-1)+i)-x(3*(n-1)+i)-t(i))**2 - enddo - enddo - rms=dabs(rms/fn) - -c write(iout,*)'xav = ',(xav(j),j=1,3) -c write(iout,*)'yav = ',(yav(j),j=1,3) -c write(iout,*)'t = ',(t(j),j=1,3) -c write(iout,*)'rms=',rms - if (rms.lt.small) return - - - nc=0 - rms=0.0D0 - do 50 n=1,nn - do 40 i=1,3 - rms=rms+((x(nc+i)-xav(i))**2+(y(nc+i)-yav(i))**2)/fn - do 40 j=1,3 - b(j,i)=b(j,i)+(x(nc+i)-xav(i))*(y(nc+j)-yav(j))/fn - 40 c(j,i)=b(j,i) - 50 nc=nc+3 - call sivade(b,q,r,d,non_conv) - sn3=dsign(1.0d0,d) - do 120 i=1,3 - do 120 j=1,3 - 120 b(j,i)=-q(j,1)*r(i,1)-q(j,2)*r(i,2)-sn3*q(j,3)*r(i,3) - call mvvad(b,xav,yav,t) - do 130 i=1,3 - do 130 j=1,3 - rms=rms+2.0*c(j,i)*b(j,i) - 130 b(j,i)=-b(j,i) - if (dabs(rms).gt.small) go to 140 -* write (6,301) - return - 140 if (rms.gt.0.0d0) go to 150 -c write (iout,303) rms - rms=0.0d0 -* stop -c 150 write (iout,302) dsqrt(rms) - 150 continue - return - 301 format (5x,'rms deviation negligible') - 302 format (5x,'rms deviation ',f14.6) - 303 format (//,5x,'negative ms deviation - ',f14.6) - end -c - subroutine sivade(x,q,r,dt,non_conv) - implicit real*8(a-h,o-z) -c computes q,e and r such that q(t)xr = diag(e) - dimension x(3,3),q(3,3),r(3,3),e(3) - dimension h(3,3),p(3,3),u(3,3),d(3) - logical non_conv -c eta = z00100000 -c write (2,*) "SIVADE" - nit = 0 - small=25.0*10.d-10 -c small=25.0*eta -c small=2.0*rmdcon(3) - xnrm=0.0d0 - do 20 i=1,3 - do 10 j=1,3 - xnrm=xnrm+x(j,i)*x(j,i) - u(j,i)=0.0d0 - r(j,i)=0.0d0 - 10 h(j,i)=0.0d0 - u(i,i)=1.0 - 20 r(i,i)=1.0 - xnrm=dsqrt(xnrm) - do 110 n=1,2 - xmax=0.0d0 - do 30 j=n,3 - 30 if (dabs(x(j,n)).gt.xmax) xmax=dabs(x(j,n)) - a=0.0d0 - do 40 j=n,3 - h(j,n)=x(j,n)/xmax - 40 a=a+h(j,n)*h(j,n) - a=dsqrt(a) - den=a*(a+dabs(h(n,n))) - d(n)=1.0/den - h(n,n)=h(n,n)+dsign(a,h(n,n)) - do 70 i=n,3 - s=0.0d0 - do 50 j=n,3 - 50 s=s+h(j,n)*x(j,i) - s=d(n)*s - do 60 j=n,3 - 60 x(j,i)=x(j,i)-s*h(j,n) - 70 continue - if (n.gt.1) go to 110 - xmax=dmax1(dabs(x(1,2)),dabs(x(1,3))) - h(2,3)=x(1,2)/xmax - h(3,3)=x(1,3)/xmax - a=dsqrt(h(2,3)*h(2,3)+h(3,3)*h(3,3)) - den=a*(a+dabs(h(2,3))) - d(3)=1.0/den - h(2,3)=h(2,3)+sign(a,h(2,3)) - do 100 i=1,3 - s=0.0d0 - do 80 j=2,3 - 80 s=s+h(j,3)*x(i,j) - s=d(3)*s - do 90 j=2,3 - 90 x(i,j)=x(i,j)-s*h(j,3) - 100 continue - 110 continue - do 130 i=1,3 - do 120 j=1,3 - 120 p(j,i)=-d(1)*h(j,1)*h(i,1) - 130 p(i,i)=1.0+p(i,i) - do 140 i=2,3 - do 140 j=2,3 - u(j,i)=u(j,i)-d(2)*h(j,2)*h(i,2) - 140 r(j,i)=r(j,i)-d(3)*h(j,3)*h(i,3) - call mmmul(p,u,q) - 150 np=1 - nq=1 - nit=nit+1 -c write (2,*) "nit",nit," e",(x(i,i),i=1,3) - if (nit.gt.10000) then - print '(a)','!!!! Over 10000 iterations in SIVADE!!!!!' - non_conv=.true. - return - endif - if (dabs(x(2,3)).gt.small*(dabs(x(2,2))+abs(x(3,3)))) go to 160 - x(2,3)=0.0d0 - nq=nq+1 - 160 if (dabs(x(1,2)).gt.small*(dabs(x(1,1))+dabs(x(2,2)))) go to 180 - x(1,2)=0.0d0 - if (x(2,3).ne.0.0d0) go to 170 - nq=nq+1 - go to 180 - 170 np=np+1 - 180 if (nq.eq.3) go to 310 - npq=4-np-nq -c write (2,*) "np",np," npq",npq - if (np.gt.npq) go to 230 - n0=0 - do 220 n=np,npq - nn=n+np-1 -c write (2,*) "nn",nn - if (dabs(x(nn,nn)).gt.small*xnrm) go to 220 - x(nn,nn)=0.0d0 - if (x(nn,nn+1).eq.0.0d0) go to 220 - n0=n0+1 -c write (2,*) "nn",nn - go to (190,210,220),nn - 190 do 200 j=2,3 - 200 call givns(x,q,1,j) - go to 220 - 210 call givns(x,q,2,3) - 220 continue -c write (2,*) "nn",nn," np",np," nq",nq," n0",n0 -c write (2,*) "x",(x(i,i),i=1,3) - if (n0.ne.0) go to 150 - 230 nn=3-nq - a=x(nn,nn)*x(nn,nn) - if (nn.gt.1) a=a+x(nn-1,nn)*x(nn-1,nn) - b=x(nn+1,nn+1)*x(nn+1,nn+1)+x(nn,nn+1)*x(nn,nn+1) - c=x(nn,nn)*x(nn,nn+1) - dd=0.5*(a-b) - xn2=c*c - rt=b-xn2/(dd+sign(dsqrt(dd*dd+xn2),dd)) - y=x(np,np)*x(np,np)-rt - z=x(np,np)*x(np,np+1) - do 300 n=np,nn -c write (2,*) "n",n," a",a," b",b," c",c," y",y," z",z - if (dabs(y).lt.dabs(z)) go to 240 - t=z/y - c=1.0/dsqrt(1.0d0+t*t) - s=c*t - go to 250 - 240 t=y/z - s=1.0/dsqrt(1.0d0+t*t) - c=s*t - 250 do 260 j=1,3 - v=x(j,n) - w=x(j,n+1) - x(j,n)=c*v+s*w - x(j,n+1)=-s*v+c*w - a=r(j,n) - b=r(j,n+1) - r(j,n)=c*a+s*b - 260 r(j,n+1)=-s*a+c*b - y=x(n,n) - z=x(n+1,n) - if (dabs(y).lt.dabs(z)) go to 270 - t=z/y - c=1.0/dsqrt(1.0+t*t) - s=c*t - go to 280 - 270 t=y/z - s=1.0/dsqrt(1.0+t*t) - c=s*t - 280 do 290 j=1,3 - v=x(n,j) - w=x(n+1,j) - a=q(j,n) - b=q(j,n+1) - x(n,j)=c*v+s*w - x(n+1,j)=-s*v+c*w - q(j,n)=c*a+s*b - 290 q(j,n+1)=-s*a+c*b - if (n.ge.nn) go to 300 - y=x(n,n+1) - z=x(n,n+2) - 300 continue - go to 150 - 310 do 320 i=1,3 - 320 e(i)=x(i,i) - nit=0 - 330 n0=0 - nit=nit+1 - if (nit.gt.10000) then - print '(a)','!!!! Over 10000 iterations in SIVADE!!!!!' - non_conv=.true. - return - endif -c write (2,*) "e",(e(i),i=1,3) - do 360 i=1,3 - if (e(i).ge.0.0d0) go to 350 - e(i)=-e(i) - do 340 j=1,3 - 340 q(j,i)=-q(j,i) - 350 if (i.eq.1) go to 360 - if (dabs(e(i)).lt.dabs(e(i-1))) go to 360 - call switch(i,1,q,r,e) - n0=n0+1 - 360 continue - if (n0.ne.0) go to 330 -c write (2,*) "e",(e(i),i=1,3) - if (dabs(e(3)).gt.small*xnrm) go to 370 - e(3)=0.0d0 - if (dabs(e(2)).gt.small*xnrm) go to 370 - e(2)=0.0d0 - 370 dt=det(q(1,1),q(1,2),q(1,3))*det(r(1,1),r(1,2),r(1,3)) -c write (2,*) "nit",nit -c write (2,501) (e(i),i=1,3) - return - 501 format (/,5x,'singular values - ',3e15.5) - end - subroutine givns(a,b,m,n) - implicit real*8 (a-h,o-z) - dimension a(3,3),b(3,3) - if (dabs(a(m,n)).lt.dabs(a(n,n))) go to 10 - t=a(n,n)/a(m,n) - s=1.0/dsqrt(1.0+t*t) - c=s*t - go to 20 - 10 t=a(m,n)/a(n,n) - c=1.0/dsqrt(1.0+t*t) - s=c*t - 20 do 30 j=1,3 - v=a(m,j) - w=a(n,j) - x=b(j,m) - y=b(j,n) - a(m,j)=c*v-s*w - a(n,j)=s*v+c*w - b(j,m)=c*x-s*y - 30 b(j,n)=s*x+c*y - return - end - subroutine switch(n,m,u,v,d) - implicit real*8 (a-h,o-z) - dimension u(3,3),v(3,3),d(3) - do 10 i=1,3 - tem=u(i,n) - u(i,n)=u(i,n-1) - u(i,n-1)=tem - if (m.eq.0) go to 10 - tem=v(i,n) - v(i,n)=v(i,n-1) - v(i,n-1)=tem - 10 continue - tem=d(n) - d(n)=d(n-1) - d(n-1)=tem - return - end - subroutine mvvad(b,xav,yav,t) - implicit real*8 (a-h,o-z) - dimension b(3,3),xav(3),yav(3),t(3) -c dimension a(3,3),b(3),c(3),d(3) -c do 10 j=1,3 -c d(j)=c(j) -c do 10 i=1,3 -c 10 d(j)=d(j)+a(j,i)*b(i) - do 10 j=1,3 - t(j)=yav(j) - do 10 i=1,3 - 10 t(j)=t(j)+b(j,i)*xav(i) - return - end - double precision function det (a,b,c) - implicit real*8 (a-h,o-z) - dimension a(3),b(3),c(3) - det=a(1)*(b(2)*c(3)-b(3)*c(2))+a(2)*(b(3)*c(1)-b(1)*c(3)) - 1 +a(3)*(b(1)*c(2)-b(2)*c(1)) - return - end - subroutine mmmul(a,b,c) - implicit real*8 (a-h,o-z) - dimension a(3,3),b(3,3),c(3,3) - do 10 i=1,3 - do 10 j=1,3 - c(i,j)=0.0d0 - do 10 k=1,3 - 10 c(i,j)=c(i,j)+a(i,k)*b(k,j) - return - end - subroutine matvec(uvec,tmat,pvec,nback) - implicit real*8 (a-h,o-z) - real*8 tmat(3,3),uvec(3,nback), pvec(3,nback) -c - do 2 j=1,nback - do 1 i=1,3 - uvec(i,j) = 0.0d0 - do 1 k=1,3 - 1 uvec(i,j)=uvec(i,j)+tmat(i,k)*pvec(k,j) - 2 continue - return - end diff --git a/source/unres/src_MD_DFA/gauss.f b/source/unres/src_MD_DFA/gauss.f deleted file mode 100644 index 7ba6e1d..0000000 --- a/source/unres/src_MD_DFA/gauss.f +++ /dev/null @@ -1,69 +0,0 @@ - subroutine gauss(RO,AP,MT,M,N,*) -c -c CALCULATES (RO**(-1))*AP BY GAUSS ELIMINATION -c RO IS A SQUARE MATRIX -c THE CALCULATED PRODUCT IS STORED IN AP -c ABNORMAL EXIT IF RO IS SINGULAR -c - integer MT, M, N, M1,I,J,IM, - & I1,MI,MI1 - double precision RO(MT,M),AP(MT,N),X,RM,PR, - & Y - if(M.ne.1)goto 10 - X=RO(1,1) - if(dabs(X).le.1.0D-13) return 1 - X=1.0/X - do 16 I=1,N -16 AP(1,I)=AP(1,I)*X - return -10 continue - M1=M-1 - DO1 I=1,M1 - IM=I - RM=DABS(RO(I,I)) - I1=I+1 - do 2 J=I1,M - if(DABS(RO(J,I)).LE.RM) goto 2 - RM=DABS(RO(J,I)) - IM=J -2 continue - If(IM.eq.I)goto 17 - do 3 J=1,N - PR=AP(I,J) - AP(I,J)=AP(IM,J) -3 AP(IM,J)=PR - do 4 J=I,M - PR=RO(I,J) - RO(I,J)=RO(IM,J) -4 RO(IM,J)=PR -17 X=RO(I,I) - if(dabs(X).le.1.0E-13) return 1 - X=1.0/X - do 5 J=1,N -5 AP(I,J)=X*AP(I,J) - do 6 J=I1,M -6 RO(I,J)=X*RO(I,J) - do 7 J=I1,M - Y=RO(J,I) - do 8 K=1,N -8 AP(J,K)=AP(J,K)-Y*AP(I,K) - do 9 K=I1,M -9 RO(J,K)=RO(J,K)-Y*RO(I,K) -7 continue -1 continue - X=RO(M,M) - if(dabs(X).le.1.0E-13) return 1 - X=1.0/X - do 11 J=1,N -11 AP(M,J)=X*AP(M,J) - do 12 I=1,M1 - MI=M-I - MI1=MI+1 - do 14 J=1,N - X=AP(MI,J) - do 15 K=MI1,M -15 X=X-AP(K,J)*RO(MI,K) -14 AP(MI,J)=X -12 continue - return - end diff --git a/source/unres/src_MD_DFA/gen_rand_conf.F b/source/unres/src_MD_DFA/gen_rand_conf.F deleted file mode 100644 index 6cc31ba..0000000 --- a/source/unres/src_MD_DFA/gen_rand_conf.F +++ /dev/null @@ -1,910 +0,0 @@ - subroutine gen_rand_conf(nstart,*) -C Generate random conformation or chain cut and regrowth. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.MCM' - include 'COMMON.GEO' - include 'COMMON.CONTROL' - logical overlap,back,fail -cd print *,' CG Processor',me,' maxgen=',maxgen - maxsi=100 -cd write (iout,*) 'Gen_Rand_conf: nstart=',nstart - if (nstart.lt.5) then - it1=itype(2) - phi(4)=gen_phi(4,itype(2),itype(3)) -c write(iout,*)'phi(4)=',rad2deg*phi(4) - if (nstart.lt.3) theta(3)=gen_theta(itype(2),pi,phi(4)) -c write(iout,*)'theta(3)=',rad2deg*theta(3) - if (it1.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(it1,theta(3),alph(2),omeg(2),fail) - nsi=nsi+1 - enddo - if (nsi.gt.maxsi) return1 - endif ! it1.ne.10 - call orig_frame - i=4 - nstart=4 - else - i=nstart - nstart=max0(i,4) - endif - - maxnit=0 - - nit=0 - niter=0 - back=.false. - do while (i.le.nres .and. niter.lt.maxgen) - if (i.lt.nstart) then - if(iprint.gt.1) then - write (iout,'(/80(1h*)/2a/80(1h*))') - & 'Generation procedure went down to ', - & 'chain beginning. Cannot continue...' - write (*,'(/80(1h*)/2a/80(1h*))') - & 'Generation procedure went down to ', - & 'chain beginning. Cannot continue...' - endif - return1 - endif - it1=itype(i-1) - it2=itype(i-2) - it=itype(i) -c print *,'Gen_Rand_Conf: i=',i,' it=',it,' it1=',it1,' it2=',it2, -c & ' nit=',nit,' niter=',niter,' maxgen=',maxgen - phi(i+1)=gen_phi(i+1,it1,it) - if (back) then - phi(i)=gen_phi(i+1,it2,it1) -c print *,'phi(',i,')=',phi(i) - theta(i-1)=gen_theta(it2,phi(i-1),phi(i)) - if (it2.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(it2,theta(i-1),alph(i-2),omeg(i-2),fail) - nsi=nsi+1 - enddo - if (nsi.gt.maxsi) return1 - endif - call locate_next_res(i-1) - endif - theta(i)=gen_theta(it1,phi(i),phi(i+1)) - if (it1.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(it1,theta(i),alph(i-1),omeg(i-1),fail) - nsi=nsi+1 - enddo - if (nsi.gt.maxsi) return1 - endif - call locate_next_res(i) - if (overlap(i-1)) then - if (nit.lt.maxnit) then - back=.true. - nit=nit+1 - else - nit=0 - if (i.gt.3) then - back=.true. - i=i-1 - else - write (iout,'(a)') - & 'Cannot generate non-overlaping conformation. Increase MAXNIT.' - write (*,'(a)') - & 'Cannot generate non-overlaping conformation. Increase MAXNIT.' - return1 - endif - endif - else - back=.false. - nit=0 - i=i+1 - endif - niter=niter+1 - enddo - if (niter.ge.maxgen) then - write (iout,'(a,2i5)') - & 'Too many trials in conformation generation',niter,maxgen - write (*,'(a,2i5)') - & 'Too many trials in conformation generation',niter,maxgen - return1 - endif - do j=1,3 - c(j,nres+1)=c(j,1) - c(j,nres+nres)=c(j,nres) - enddo - return - end -c------------------------------------------------------------------------- - logical function overlap(i) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - data redfac /0.5D0/ - overlap=.false. - iti=itype(i) - if (iti.gt.ntyp) return -C Check for SC-SC overlaps. -cd print *,'nnt=',nnt,' nct=',nct - do j=nnt,i-1 - itj=itype(j) - if (j.lt.i-1 .or. ipot.ne.4) then - rcomp=sigmaii(iti,itj) - else - rcomp=sigma(iti,itj) - endif -cd print *,'j=',j - if (dist(nres+i,nres+j).lt.redfac*rcomp) then - overlap=.true. -c print *,'overlap, SC-SC: i=',i,' j=',j, -c & ' dist=',dist(nres+i,nres+j),' rcomp=', -c & rcomp - return - endif - enddo -C Check for overlaps between the added peptide group and the preceding -C SCs. - iteli=itel(i) - do j=1,3 - c(j,maxres2+1)=0.5D0*(c(j,i)+c(j,i+1)) - enddo - do j=nnt,i-2 - itj=itype(j) -cd print *,'overlap, p-Sc: i=',i,' j=',j, -cd & ' dist=',dist(nres+j,maxres2+1) - if (dist(nres+j,maxres2+1).lt.4.0D0*redfac) then - overlap=.true. - return - endif - enddo -C Check for overlaps between the added side chain and the preceding peptide -C groups. - do j=1,nnt-2 - do k=1,3 - c(k,maxres2+1)=0.5D0*(c(k,j)+c(k,j+1)) - enddo -cd print *,'overlap, SC-p: i=',i,' j=',j, -cd & ' dist=',dist(nres+i,maxres2+1) - if (dist(nres+i,maxres2+1).lt.4.0D0*redfac) then - overlap=.true. - return - endif - enddo -C Check for p-p overlaps - do j=1,3 - c(j,maxres2+2)=0.5D0*(c(j,i)+c(j,i+1)) - enddo - do j=nnt,i-2 - itelj=itel(j) - do k=1,3 - c(k,maxres2+2)=0.5D0*(c(k,j)+c(k,j+1)) - enddo -cd print *,'overlap, p-p: i=',i,' j=',j, -cd & ' dist=',dist(maxres2+1,maxres2+2) - if(iteli.ne.0.and.itelj.ne.0)then - if (dist(maxres2+1,maxres2+2).lt.rpp(iteli,itelj)*redfac) then - overlap=.true. - return - endif - endif - enddo - return - end -c-------------------------------------------------------------------------- - double precision function gen_phi(i,it1,it2) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.BOUNDS' -c gen_phi=ran_number(-pi,pi) -C 8/13/98 Generate phi using pre-defined boundaries - gen_phi=ran_number(phibound(1,i),phibound(2,i)) - return - end -c--------------------------------------------------------------------------- - double precision function gen_theta(it,gama,gama1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - double precision y(2),z(2) - double precision theta_max,theta_min -c print *,'gen_theta: it=',it - theta_min=0.05D0*pi - theta_max=0.95D0*pi - if (dabs(gama).gt.dwapi) then - y(1)=dcos(gama) - y(2)=dsin(gama) - else - y(1)=0.0D0 - y(2)=0.0D0 - endif - if (dabs(gama1).gt.dwapi) then - z(1)=dcos(gama1) - z(2)=dsin(gama1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif - thet_pred_mean=a0thet(it) - do k=1,2 - thet_pred_mean=thet_pred_mean+athet(k,it)*y(k)+bthet(k,it)*z(k) - enddo - sig=polthet(3,it) - do j=2,0,-1 - sig=sig*thet_pred_mean+polthet(j,it) - enddo - sig=0.5D0/(sig*sig+sigc0(it)) - ak=dexp(gthet(1,it)- - &0.5D0*((gthet(2,it)-thet_pred_mean)/gthet(3,it))**2) -c print '(i5,5(1pe14.4))',it,(gthet(j,it),j=1,3) -c print '(5(1pe14.4))',thet_pred_mean,theta0(it),sig,sig0(it),ak - theta_temp=binorm(thet_pred_mean,theta0(it),sig,sig0(it),ak) - if (theta_temp.lt.theta_min) theta_temp=theta_min - if (theta_temp.gt.theta_max) theta_temp=theta_max - gen_theta=theta_temp -c print '(a)','Exiting GENTHETA.' - return - end -c------------------------------------------------------------------------- - subroutine gen_side(it,the,al,om,fail) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision MaxBoxLen /10.0D0/ - double precision Ap_inv(3,3),a(3,3),z(3,maxlob),W1(maxlob), - & sumW(0:maxlob),y(2),cm(2),eig(2),box(2,2),work(100),detAp(maxlob) - double precision eig_limit /1.0D-8/ - double precision Big /10.0D0/ - double precision vec(3,3) - logical lprint,fail,lcheck - lcheck=.false. - lprint=.false. - fail=.false. - if (the.eq.0.0D0 .or. the.eq.pi) then -#ifdef MPI - write (*,'(a,i4,a,i3,a,1pe14.5)') - & 'CG Processor:',me,' Error in GenSide: it=',it,' theta=',the -#else -cd write (iout,'(a,i3,a,1pe14.5)') -cd & 'Error in GenSide: it=',it,' theta=',the -#endif - fail=.true. - return - endif - tant=dtan(the-pipol) - nlobit=nlob(it) - if (lprint) then -#ifdef MPI - print '(a,i4,a)','CG Processor:',me,' Enter Gen_Side.' - write (iout,'(a,i4,a)') 'Processor:',me,' Enter Gen_Side.' -#endif - print *,'it=',it,' nlobit=',nlobit,' the=',the,' tant=',tant - write (iout,*) 'it=',it,' nlobit=',nlobit,' the=',the, - & ' tant=',tant - endif - do i=1,nlobit - zz1=tant-censc(1,i,it) - do k=1,3 - do l=1,3 - a(k,l)=gaussc(k,l,i,it) - enddo - enddo - detApi=a(2,2)*a(3,3)-a(2,3)**2 - Ap_inv(2,2)=a(3,3)/detApi - Ap_inv(2,3)=-a(2,3)/detApi - Ap_inv(3,2)=Ap_inv(2,3) - Ap_inv(3,3)=a(2,2)/detApi - if (lprint) then - write (*,'(/a,i2/)') 'Cluster #',i - write (*,'(3(1pe14.5),5x,1pe14.5)') - & ((a(l,k),l=1,3),censc(k,i,it),k=1,3) - write (iout,'(/a,i2/)') 'Cluster #',i - write (iout,'(3(1pe14.5),5x,1pe14.5)') - & ((a(l,k),l=1,3),censc(k,i,it),k=1,3) - endif - W1i=0.0D0 - do k=2,3 - do l=2,3 - W1i=W1i+a(k,1)*a(l,1)*Ap_inv(k,l) - enddo - enddo - W1i=a(1,1)-W1i - W1(i)=dexp(bsc(i,it)-0.5D0*W1i*zz1*zz1) -c if (lprint) write(*,'(a,3(1pe15.5)/)') -c & 'detAp, W1, anormi',detApi,W1i,anormi - do k=2,3 - zk=censc(k,i,it) - do l=2,3 - zk=zk+zz1*Ap_inv(k,l)*a(l,1) - enddo - z(k,i)=zk - enddo - detAp(i)=dsqrt(detApi) - enddo - - if (lprint) then - print *,'W1:',(w1(i),i=1,nlobit) - print *,'detAp:',(detAp(i),i=1,nlobit) - print *,'Z' - do i=1,nlobit - print '(i2,3f10.5)',i,(rad2deg*z(j,i),j=2,3) - enddo - write (iout,*) 'W1:',(w1(i),i=1,nlobit) - write (iout,*) 'detAp:',(detAp(i),i=1,nlobit) - write (iout,*) 'Z' - do i=1,nlobit - write (iout,'(i2,3f10.5)') i,(rad2deg*z(j,i),j=2,3) - enddo - endif - if (lcheck) then -C Writing the distribution just to check the procedure - fac=0.0D0 - dV=deg2rad**2*10.0D0 - sum=0.0D0 - sum1=0.0D0 - do i=1,nlobit - fac=fac+W1(i)/detAp(i) - enddo - fac=1.0D0/(2.0D0*fac*pi) -cd print *,it,'fac=',fac - do ial=90,180,2 - y(1)=deg2rad*ial - do iom=-180,180,5 - y(2)=deg2rad*iom - wart=0.0D0 - do i=1,nlobit - do j=2,3 - do k=2,3 - a(j-1,k-1)=gaussc(j,k,i,it) - enddo - enddo - y2=y(2) - - do iii=-1,1 - - y(2)=y2+iii*dwapi - - wykl=0.0D0 - do j=1,2 - do k=1,2 - wykl=wykl+a(j,k)*(y(j)-z(j+1,i))*(y(k)-z(k+1,i)) - enddo - enddo - wart=wart+W1(i)*dexp(-0.5D0*wykl) - - enddo - - y(2)=y2 - - enddo -c print *,'y',y(1),y(2),' fac=',fac - wart=fac*wart - write (20,'(2f10.3,1pd15.5)') y(1)*rad2deg,y(2)*rad2deg,wart - sum=sum+wart - sum1=sum1+1.0D0 - enddo - enddo -c print *,'it=',it,' sum=',sum*dV,' sum1=',sum1*dV - return - endif - -C Calculate the CM of the system -C - do i=1,nlobit - W1(i)=W1(i)/detAp(i) - enddo - sumW(0)=0.0D0 - do i=1,nlobit - sumW(i)=sumW(i-1)+W1(i) - enddo - cm(1)=z(2,1)*W1(1) - cm(2)=z(3,1)*W1(1) - do j=2,nlobit - cm(1)=cm(1)+z(2,j)*W1(j) - cm(2)=cm(2)+W1(j)*(z(3,1)+pinorm(z(3,j)-z(3,1))) - enddo - cm(1)=cm(1)/sumW(nlobit) - cm(2)=cm(2)/sumW(nlobit) - if (cm(1).gt.Big .or. cm(1).lt.-Big .or. - & cm(2).gt.Big .or. cm(2).lt.-Big) then -cd write (iout,'(a)') -cd & 'Unexpected error in GenSide - CM coordinates too large.' -cd write (iout,'(i5,2(1pe14.5))') it,cm(1),cm(2) -cd write (*,'(a)') -cd & 'Unexpected error in GenSide - CM coordinates too large.' -cd write (*,'(i5,2(1pe14.5))') it,cm(1),cm(2) - fail=.true. - return - endif -cd print *,'CM:',cm(1),cm(2) -C -C Find the largest search distance from CM -C - radmax=0.0D0 - do i=1,nlobit - do j=2,3 - do k=2,3 - a(j-1,k-1)=gaussc(j,k,i,it) - enddo - enddo -#ifdef NAG - call f02faf('N','U',2,a,3,eig,work,100,ifail) -#else - call djacob(2,3,10000,1.0d-10,a,vec,eig) -#endif -#ifdef MPI - if (lprint) then - print *,'*************** CG Processor',me - print *,'CM:',cm(1),cm(2) - write (iout,*) '*************** CG Processor',me - write (iout,*) 'CM:',cm(1),cm(2) - print '(A,8f10.5)','Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2) - write (iout,'(A,8f10.5)') - & 'Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2) - endif -#endif - if (eig(1).lt.eig_limit) then - write(iout,'(a)') - & 'From Mult_Norm: Eigenvalues of A are too small.' - write(*,'(a)') - & 'From Mult_Norm: Eigenvalues of A are too small.' - fail=.true. - return - endif - radius=0.0D0 -cd print *,'i=',i - do j=1,2 - radius=radius+pinorm(z(j+1,i)-cm(j))**2 - enddo - radius=dsqrt(radius)+3.0D0/dsqrt(eig(1)) - if (radius.gt.radmax) radmax=radius - enddo - if (radmax.gt.pi) radmax=pi -C -C Determine the boundaries of the search rectangle. -C - if (lprint) then - print '(a,4(1pe14.4))','W1: ',(W1(i),i=1,nlob(it) ) - print '(a,4(1pe14.4))','radmax: ',radmax - endif - box(1,1)=dmax1(cm(1)-radmax,0.0D0) - box(2,1)=dmin1(cm(1)+radmax,pi) - box(1,2)=cm(2)-radmax - box(2,2)=cm(2)+radmax - if (lprint) then -#ifdef MPI - print *,'CG Processor',me,' Array BOX:' -#else - print *,'Array BOX:' -#endif - print '(4(1pe14.4))',((box(k,j),k=1,2),j=1,2) - print '(a,4(1pe14.4))','sumW: ',(sumW(i),i=0,nlob(it) ) -#ifdef MPI - write (iout,*)'CG Processor',me,' Array BOX:' -#else - write (iout,*)'Array BOX:' -#endif - write(iout,'(4(1pe14.4))') ((box(k,j),k=1,2),j=1,2) - write(iout,'(a,4(1pe14.4))')'sumW: ',(sumW(i),i=0,nlob(it) ) - endif - if (box(1,2).lt.-MaxBoxLen .or. box(2,2).gt.MaxBoxLen) then -#ifdef MPI - write (iout,'(a,i4,a)') 'CG Processor:',me,': bad sampling box.' - write (*,'(a,i4,a)') 'CG Processor:',me,': bad sampling box.' -#else -c write (iout,'(a)') 'Bad sampling box.' -#endif - fail=.true. - return - endif - which_lobe=ran_number(0.0D0,sumW(nlobit)) -c print '(a,1pe14.4)','which_lobe=',which_lobe - do i=1,nlobit - if (sumW(i-1).le.which_lobe .and. sumW(i).ge.which_lobe) goto 1 - enddo - 1 ilob=i -c print *,'ilob=',ilob,' nlob=',nlob(it) - do i=2,3 - cm(i-1)=z(i,ilob) - do j=2,3 - a(i-1,j-1)=gaussc(i,j,ilob,it) - enddo - enddo -cd print '(a,i4,a)','CG Processor',me,' Calling MultNorm1.' - call mult_norm1(3,2,a,cm,box,y,fail) - if (fail) return - al=y(1) - om=pinorm(y(2)) -cd print *,'al=',al,' om=',om -cd stop - return - end -c--------------------------------------------------------------------------- - double precision function ran_number(x1,x2) -C Calculate a random real number from the range (x1,x2). - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - double precision x1,x2,fctor - data fctor /2147483647.0D0/ -#ifdef MPI - include "mpif.h" - include 'COMMON.SETUP' - ran_number=x1+(x2-x1)*prng_next(me) -#else - call vrnd(ix,1) - ran_number=x1+(x2-x1)*ix/fctor -#endif - return - end -c-------------------------------------------------------------------------- - integer function iran_num(n1,n2) -C Calculate a random integer number from the range (n1,n2). - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - integer n1,n2,ix - real fctor /2147483647.0/ -#ifdef MPI - include "mpif.h" - include 'COMMON.SETUP' - ix=n1+(n2-n1+1)*prng_next(me) - if (ix.lt.n1) ix=n1 - if (ix.gt.n2) ix=n2 - iran_num=ix -#else - call vrnd(ix,1) - ix=n1+(n2-n1+1)*(ix/fctor) - if (ix.gt.n2) ix=n2 - iran_num=ix -#endif - return - end -c-------------------------------------------------------------------------- - double precision function binorm(x1,x2,sigma1,sigma2,ak) - implicit real*8 (a-h,o-z) -c print '(a)','Enter BINORM.' - alowb=dmin1(x1-3.0D0*sigma1,x2-3.0D0*sigma2) - aupb=dmax1(x1+3.0D0*sigma1,x2+3.0D0*sigma2) - seg=sigma1/(sigma1+ak*sigma2) - alen=ran_number(0.0D0,1.0D0) - if (alen.lt.seg) then - binorm=anorm_distr(x1,sigma1,alowb,aupb) - else - binorm=anorm_distr(x2,sigma2,alowb,aupb) - endif -c print '(a)','Exiting BINORM.' - return - end -c----------------------------------------------------------------------- -c double precision function anorm_distr(x,sigma,alowb,aupb) -c implicit real*8 (a-h,o-z) -c print '(a)','Enter ANORM_DISTR.' -c 10 y=ran_number(alowb,aupb) -c expon=dexp(-0.5D0*((y-x)/sigma)**2) -c ran=ran_number(0.0D0,1.0D0) -c if (expon.lt.ran) goto 10 -c anorm_distr=y -c print '(a)','Exiting ANORM_DISTR.' -c return -c end -c----------------------------------------------------------------------- - double precision function anorm_distr(x,sigma,alowb,aupb) - implicit real*8 (a-h,o-z) -c to make a normally distributed deviate with zero mean and unit variance -c - integer iset - real fac,gset,rsq,v1,v2,ran1 - save iset,gset - data iset/0/ - if(iset.eq.0) then -1 v1=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0 - v2=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0 - rsq=v1**2+v2**2 - if(rsq.ge.1.d0.or.rsq.eq.0.0d0) goto 1 - fac=sqrt(-2.0d0*log(rsq)/rsq) - gset=v1*fac - gaussdev=v2*fac - iset=1 - else - gaussdev=gset - iset=0 - endif - anorm_distr=x+gaussdev*sigma - return - end -c------------------------------------------------------------------------ - subroutine mult_norm(lda,n,a,x,fail) -C -C Generate the vector X whose elements obey the multiple-normal distribution -C from exp(-0.5*X'AX). LDA is the leading dimension of the moment matrix A, -C n is the dimension of the problem. FAIL is set at .TRUE., if the smallest -C eigenvalue of the matrix A is close to 0. -C - implicit double precision (a-h,o-z) - double precision a(lda,n),x(n),eig(100),vec(3,3),work(100) - double precision eig_limit /1.0D-8/ - logical fail - fail=.false. -c print '(a)','Enter MULT_NORM.' -C -C Find the smallest eigenvalue of the matrix A. -C -c do i=1,n -c print '(8f10.5)',(a(i,j),j=1,n) -c enddo -#ifdef NAG - call f02faf('V','U',2,a,lda,eig,work,100,ifail) -#else - call djacob(2,lda,10000,1.0d-10,a,vec,eig) -#endif -c print '(8f10.5)',(eig(i),i=1,n) -C print '(a)' -c do i=1,n -c print '(8f10.5)',(a(i,j),j=1,n) -c enddo - if (eig(1).lt.eig_limit) then - print *,'From Mult_Norm: Eigenvalues of A are too small.' - fail=.true. - return - endif -C -C Generate points following the normal distributions along the principal -C axes of the moment matrix. Store in WORK. -C - do i=1,n - sigma=1.0D0/dsqrt(eig(i)) - alim=-3.0D0*sigma - work(i)=anorm_distr(0.0D0,sigma,-alim,alim) - enddo -C -C Transform the vector of normal variables back to the original basis. -C - do i=1,n - xi=0.0D0 - do j=1,n - xi=xi+a(i,j)*work(j) - enddo - x(i)=xi - enddo - return - end -c------------------------------------------------------------------------ - subroutine mult_norm1(lda,n,a,z,box,x,fail) -C -C Generate the vector X whose elements obey the multi-gaussian multi-dimensional -C distribution from sum_{i=1}^m W(i)exp[-0.5*X'(i)A(i)X(i)]. LDA is the -C leading dimension of the moment matrix A, n is the dimension of the -C distribution, nlob is the number of lobes. FAIL is set at .TRUE., if the -C smallest eigenvalue of the matrix A is close to 0. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - double precision a(lda,n),z(n),x(n),box(n,n) - double precision etmp - include 'COMMON.IOUNITS' -#ifdef MP - include 'COMMON.SETUP' -#endif - logical fail -C -C Generate points following the normal distributions along the principal -C axes of the moment matrix. Store in WORK. -C -cd print *,'CG Processor',me,' entered MultNorm1.' -cd print '(2(1pe14.4),3x,1pe14.4)',((a(i,j),j=1,2),z(i),i=1,2) -cd do i=1,n -cd print *,i,box(1,i),box(2,i) -cd enddo - istep = 0 - 10 istep = istep + 1 - if (istep.gt.10000) then -c write (iout,'(a,i4,2a)') 'CG Processor: ',me,': too many steps', -c & ' in MultNorm1.' -c write (*,'(a,i4,2a)') 'CG Processor: ',me,': too many steps', -c & ' in MultNorm1.' -c write (iout,*) 'box',box -c write (iout,*) 'a',a -c write (iout,*) 'z',z - fail=.true. - return - endif - do i=1,n - x(i)=ran_number(box(1,i),box(2,i)) - enddo - ww=0.0D0 - do i=1,n - xi=pinorm(x(i)-z(i)) - ww=ww+0.5D0*a(i,i)*xi*xi - do j=i+1,n - ww=ww+a(i,j)*xi*pinorm(x(j)-z(j)) - enddo - enddo - dec=ran_number(0.0D0,1.0D0) -c print *,(x(i),i=1,n),ww,dexp(-ww),dec -crc if (dec.gt.dexp(-ww)) goto 10 - if(-ww.lt.100) then - etmp=dexp(-ww) - else - return - endif - if (dec.gt.etmp) goto 10 -cd print *,'CG Processor',me,' exitting MultNorm1.' - return - end -c -crc-------------------------------------- - subroutine overlap_sc(scfail) -c Internal and cartesian coordinates must be consistent as input, -c and will be up-to-date on return. -c At the end of this procedure, scfail is true if there are -c overlapping residues left, or false otherwise (success) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.VAR' - include 'COMMON.SBRIDGE' - include 'COMMON.IOUNITS' - logical had_overlaps,fail,scfail - integer ioverlap(maxres),ioverlap_last - - had_overlaps=.false. - call overlap_sc_list(ioverlap,ioverlap_last) - if (ioverlap_last.gt.0) then - write (iout,*) '#OVERLAPing residues ',ioverlap_last - write (iout,'(20i4)') (ioverlap(k),k=1,ioverlap_last) - had_overlaps=.true. - endif - - maxsi=1000 - do k=1,1000 - if (ioverlap_last.eq.0) exit - - do ires=1,ioverlap_last - i=ioverlap(ires) - iti=itype(i) - if (iti.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(iti,theta(i+1),alph(i),omeg(i),fail) - nsi=nsi+1 - enddo - if(fail) goto 999 - endif - enddo - - call chainbuild - call overlap_sc_list(ioverlap,ioverlap_last) -c write (iout,*) 'Overlaping residues ',ioverlap_last, -c & (ioverlap(j),j=1,ioverlap_last) - enddo - - if (k.le.1000.and.ioverlap_last.eq.0) then - scfail=.false. - if (had_overlaps) then - write (iout,*) '#OVERLAPing all corrected after ',k, - & ' random generation' - endif - else - scfail=.true. - write (iout,*) '#OVERLAPing NOT all corrected ',ioverlap_last - write (iout,'(20i4)') (ioverlap(j),j=1,ioverlap_last) - endif - - return - - 999 continue - write (iout,'(a30,i5,a12,i4)') - & '#OVERLAP FAIL in gen_side after',maxsi, - & 'iter for RES',i - scfail=.true. - return - end - - subroutine overlap_sc_list(ioverlap,ioverlap_last) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.VAR' - include 'COMMON.CALC' - logical fail - integer ioverlap(maxres),ioverlap_last - data redfac /0.5D0/ - - ioverlap_last=0 -C Check for SC-SC overlaps and mark residues -c print *,'>>overlap_sc nnt=',nnt,' nct=',nct - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) - dsci_inv=dsc_inv(itypi) -c - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) - dscj_inv=dsc_inv(itypj) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - if (j.gt.i+1) then - rcomp=sigmaii(itypi,itypj) - else - rcomp=sigma(itypi,itypj) - endif -c print '(2(a3,2i3),a3,2f10.5)', -c & ' i=',i,iti,' j=',j,itj,' d=',dist(nres+i,nres+j) -c & ,rcomp - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij - -ct if ( 1.0/rij .lt. redfac*rcomp .or. -ct & rij_shift.le.0.0D0 ) then - if ( rij_shift.le.0.0D0 ) then -cd write (iout,'(a,i3,a,i3,a,f10.5,a,3f10.5)') -cd & 'overlap SC-SC: i=',i,' j=',j, -cd & ' dist=',dist(nres+i,nres+j),' rcomp=', -cd & rcomp,1.0/rij,rij_shift - ioverlap_last=ioverlap_last+1 - ioverlap(ioverlap_last)=i - do k=1,ioverlap_last-1 - if (ioverlap(k).eq.i) ioverlap_last=ioverlap_last-1 - enddo - ioverlap_last=ioverlap_last+1 - ioverlap(ioverlap_last)=j - do k=1,ioverlap_last-1 - if (ioverlap(k).eq.j) ioverlap_last=ioverlap_last-1 - enddo - endif - enddo - enddo - enddo - return - end diff --git a/source/unres/src_MD_DFA/geomout.F b/source/unres/src_MD_DFA/geomout.F deleted file mode 100644 index 69d7802..0000000 --- a/source/unres/src_MD_DFA/geomout.F +++ /dev/null @@ -1,491 +0,0 @@ - subroutine pdbout(etot,tytul,iunit) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' - include 'COMMON.MD' - character*50 tytul - dimension ica(maxres) - write (iunit,'(3a,1pe15.5)') 'REMARK ',tytul,' ENERGY ',etot -cmodel write (iunit,'(a5,i6)') 'MODEL',1 - if (nhfrag.gt.0) then - do j=1,nhfrag - iti=itype(hfrag(1,j)) - itj=itype(hfrag(2,j)) - if (j.lt.10) then - write (iunit,'(a5,i5,1x,a1,i1,2x,a3,i7,2x,a3,i7,i3,t76,i5)') - & 'HELIX',j,'H',j, - & restyp(iti),hfrag(1,j)-1, - & restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j) - else - write (iunit,'(a5,i5,1x,a1,i2,1x,a3,i7,2x,a3,i7,i3)') - & 'HELIX',j,'H',j, - & restyp(iti),hfrag(1,j)-1, - & restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j) - endif - enddo - endif - - if (nbfrag.gt.0) then - - do j=1,nbfrag - - iti=itype(bfrag(1,j)) - itj=itype(bfrag(2,j)-1) - - write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3)') - & 'SHEET',1,'B',j,2, - & restyp(iti),bfrag(1,j)-1, - & restyp(itj),bfrag(2,j)-2,0 - - if (bfrag(3,j).gt.bfrag(4,j)) then - - itk=itype(bfrag(3,j)) - itl=itype(bfrag(4,j)+1) - - write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3, - & 2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') - & 'SHEET',2,'B',j,2, - & restyp(itl),bfrag(4,j), - & restyp(itk),bfrag(3,j)-1,-1, - & "N",restyp(itk),bfrag(3,j)-1, - & "O",restyp(iti),bfrag(1,j)-1 - - else - - itk=itype(bfrag(3,j)) - itl=itype(bfrag(4,j)-1) - - - write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3, - & 2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') - & 'SHEET',2,'B',j,2, - & restyp(itk),bfrag(3,j)-1, - & restyp(itl),bfrag(4,j)-2,1, - & "N",restyp(itk),bfrag(3,j)-1, - & "O",restyp(iti),bfrag(1,j)-1 - - - - endif - - enddo - endif - - if (nss.gt.0) then - do i=1,nss - write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') - & 'SSBOND',i,'CYS',ihpb(i)-1-nres, - & 'CYS',jhpb(i)-1-nres - enddo - endif - - iatom=0 - do i=nnt,nct - ires=i-nnt+1 - iatom=iatom+1 - ica(i)=iatom - iti=itype(i) - write (iunit,10) iatom,restyp(iti),ires,(c(j,i),j=1,3),vtot(i) - if (iti.ne.10) then - iatom=iatom+1 - write (iunit,20) iatom,restyp(iti),ires,(c(j,nres+i),j=1,3), - & vtot(i+nres) - endif - enddo - write (iunit,'(a)') 'TER' - do i=nnt,nct-1 - if (itype(i).eq.10) then - write (iunit,30) ica(i),ica(i+1) - else - write (iunit,30) ica(i),ica(i+1),ica(i)+1 - endif - enddo - if (itype(nct).ne.10) then - write (iunit,30) ica(nct),ica(nct)+1 - endif - do i=1,nss - write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 - enddo - write (iunit,'(a6)') 'ENDMDL' - 10 FORMAT ('ATOM',I7,' CA ',A3,I6,4X,3F8.3,f15.3) - 20 FORMAT ('ATOM',I7,' CB ',A3,I6,4X,3F8.3,f15.3) - 30 FORMAT ('CONECT',8I5) - return - end -c------------------------------------------------------------------------------ - subroutine MOL2out(etot,tytul) -C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2 -C format. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - character*32 tytul,fd - character*3 zahl - character*6 res_num,pom,ucase -#ifdef AIX - call fdate_(fd) -#elif (defined CRAY) - call date(fd) -#else - call fdate(fd) -#endif - write (imol2,'(a)') '#' - write (imol2,'(a)') - & '# Creating user name: unres' - write (imol2,'(2a)') '# Creation time: ', - & fd - write (imol2,'(/a)') '\@MOLECULE' - write (imol2,'(a)') tytul - write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0 - write (imol2,'(a)') 'SMALL' - write (imol2,'(a)') 'USER_CHARGES' - write (imol2,'(a)') '\@ATOM' - do i=nnt,nct - write (zahl,'(i3)') i - pom=ucase(restyp(itype(i))) - res_num = pom(:3)//zahl(2:) - write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0 - enddo - write (imol2,'(a)') '\@BOND' - do i=nnt,nct-1 - write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1 - enddo - do i=1,nss - write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 - enddo - write (imol2,'(a)') '\@SUBSTRUCTURE' - do i=nnt,nct - write (zahl,'(i3)') i - pom = ucase(restyp(itype(i))) - res_num = pom(:3)//zahl(2:) - write (imol2,30) i-nnt+1,res_num,i-nnt+1,0 - enddo - 10 FORMAT (I7,' CA ',3F10.4,' C.3',I8,1X,A,F11.4,' ****') - 30 FORMAT (I7,1x,A,I14,' RESIDUE',I13,' **** ****') - return - end -c------------------------------------------------------------------------ - subroutine intout - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - write (iout,'(/a)') 'Geometry of the virtual chain.' - write (iout,'(7a)') ' Res ',' d',' Theta', - & ' Gamma',' Dsc',' Alpha',' Beta ' - do i=1,nres - iti=itype(i) - write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i), - & rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i), - & rad2deg*omeg(i) - enddo - return - end -c--------------------------------------------------------------------------- - subroutine briefout(it,ener) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.SBRIDGE' -c print '(a,i5)',intname,igeom -#if defined(AIX) || defined(PGI) - open (igeom,file=intname,position='append') -#else - open (igeom,file=intname,access='append') -#endif - IF (NSS.LE.9) THEN - WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS) - ELSE - WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9) - WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS) - ENDIF -c IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) - WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) - WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES) -c if (nvar.gt.nphi+ntheta) then - write (igeom,200) (rad2deg*alph(i),i=2,nres-1) - write (igeom,200) (rad2deg*omeg(i),i=2,nres-1) -c endif - close(igeom) - 180 format (I5,F12.3,I2,9(1X,2I3)) - 190 format (3X,11(1X,2I3)) - 200 format (8F10.4) - return - end -#ifdef WINIFL - subroutine fdate(fd) - character*32 fd - write(fd,'(32x)') - return - end -#endif -c---------------------------------------------------------------- -#ifdef NOXDR - subroutine cartout(time) -#else - subroutine cartoutx(time) -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' - include 'COMMON.MD' - double precision time -#if defined(AIX) || defined(PGI) - open(icart,file=cartname,position="append") -#else - open(icart,file=cartname,access="append") -#endif - write (icart,'(e15.8,2e15.5,f12.5,$)') time,potE,uconst,t_bath - write (icart,'(i4,$)') - & nss,(ihpb(j),jhpb(j),j=1,nss) - write (icart,'(i4,20f7.4)') nfrag+npair+3*nfrag_back, - & (qfrag(i),i=1,nfrag),(qpair(i),i=1,npair), - & (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back) - write (icart,'(8f10.5)') - & ((c(k,j),k=1,3),j=1,nres), - & ((c(k,j+nres),k=1,3),j=nnt,nct) - close(icart) - return - end -c----------------------------------------------------------------- -#ifndef NOXDR - subroutine cartout(time) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - include 'COMMON.SETUP' -#else - parameter (me=0) -#endif - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' - include 'COMMON.MD' - double precision time - integer iret,itmp - real xcoord(3,maxres2+2),prec - -#ifdef AIX - call xdrfopen_(ixdrf,cartname, "a", iret) - call xdrffloat_(ixdrf, real(time), iret) - call xdrffloat_(ixdrf, real(potE), iret) - call xdrffloat_(ixdrf, real(uconst), iret) - call xdrffloat_(ixdrf, real(uconst_back), iret) - call xdrffloat_(ixdrf, real(t_bath), iret) - call xdrfint_(ixdrf, nss, iret) - do j=1,nss - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) - enddo - call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret) - do i=1,nfrag - call xdrffloat_(ixdrf, real(qfrag(i)), iret) - enddo - do i=1,npair - call xdrffloat_(ixdrf, real(qpair(i)), iret) - enddo - do i=1,nfrag_back - call xdrffloat_(ixdrf, real(utheta(i)), iret) - call xdrffloat_(ixdrf, real(ugamma(i)), iret) - call xdrffloat_(ixdrf, real(uscdiff(i)), iret) - enddo -#else - call xdrfopen(ixdrf,cartname, "a", iret) - call xdrffloat(ixdrf, real(time), iret) - call xdrffloat(ixdrf, real(potE), iret) - call xdrffloat(ixdrf, real(uconst), iret) - call xdrffloat(ixdrf, real(uconst_back), iret) - call xdrffloat(ixdrf, real(t_bath), iret) - call xdrfint(ixdrf, nss, iret) - do j=1,nss - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - enddo - call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret) - do i=1,nfrag - call xdrffloat(ixdrf, real(qfrag(i)), iret) - enddo - do i=1,npair - call xdrffloat(ixdrf, real(qpair(i)), iret) - enddo - do i=1,nfrag_back - call xdrffloat(ixdrf, real(utheta(i)), iret) - call xdrffloat(ixdrf, real(ugamma(i)), iret) - call xdrffloat(ixdrf, real(uscdiff(i)), iret) - enddo -#endif - prec=10000.0 - do i=1,nres - do j=1,3 - xcoord(j,i)=c(j,i) - enddo - enddo - do i=nnt,nct - do j=1,3 - xcoord(j,nres+i-nnt+1)=c(j,i+nres) - enddo - enddo - - itmp=nres+nct-nnt+1 -#ifdef AIX - call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret) - call xdrfclose_(ixdrf, iret) -#else - call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) - call xdrfclose(ixdrf, iret) -#endif - return - end -#endif -c----------------------------------------------------------------- - subroutine statout(itime) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' - include 'COMMON.MD' - include 'COMMON.REMD' - include 'COMMON.SETUP' - integer itime - double precision energia(0:n_ene) - double precision gyrate - external gyrate - common /gucio/ cm - character*256 line1,line2 - character*4 format1,format2 - character*30 format -#ifdef AIX - if(itime.eq.0) then - open(istat,file=statname,position="append") - endif -#else -#ifdef PGI - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif -#endif - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.false.) - if(tnp .or. tnp1 .or. tnh) then - write (line1,'(i10,f15.2,3f12.3,f12.6,f7.2,4f6.3,3f12.3,i5,$)') - & itime,totT,EK,potE,totE,hhh, - & rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me - format1="a145" - else - write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)') - & itime,totT,EK,potE,totE, - & rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me - format1="a133" - endif - else - if(tnp .or. tnp1 .or. tnh) then - write (line1,'(i10,f15.2,7f12.3,f12.6,i5,$)') - & itime,totT,EK,potE,totE,hhh, - & amax,kinetic_T,t_bath,gyrate(),me - format1="a126" - else - write (line1,'(i10,f15.2,7f12.3,i5,$)') - & itime,totT,EK,potE,totE, - & amax,kinetic_T,t_bath,gyrate(),me - format1="a114" - endif - endif - if(usampl.and.totT.gt.eq_time) then - write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back, - & (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair), - & (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back) - write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair - & +21*nfrag_back - elseif(hremd.gt.0) then - write(line2,'(i5)') iset - format2="a005" - else - format2="a001" - line2=' ' - endif - if (print_compon) then - write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2, - & ",20f12.3)" - write (istat,format) line1,line2, - & (potEcomp(print_order(i)),i=1,nprint_ene) - else - write(format,'(a1,a4,a1,a4,a1)') "(",format1,",",format2,")" - write (istat,format) line1,line2 - endif -#if defined(AIX) - call flush(istat) -#else - close(istat) -#endif - return - end -c--------------------------------------------------------------- - double precision function gyrate() - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.INTERACT' - include 'COMMON.CHAIN' - double precision cen(3),rg - - do j=1,3 - cen(j)=0.0d0 - enddo - - do i=nnt,nct - do j=1,3 - cen(j)=cen(j)+c(j,i) - enddo - enddo - do j=1,3 - cen(j)=cen(j)/dble(nct-nnt+1) - enddo - rg = 0.0d0 - do i = nnt, nct - do j=1,3 - rg = rg + (c(j,i)-cen(j))**2 - enddo - end do - gyrate = sqrt(rg/dble(nct-nnt+1)) - return - end - diff --git a/source/unres/src_MD_DFA/gnmr1.f b/source/unres/src_MD_DFA/gnmr1.f deleted file mode 100644 index 905e746..0000000 --- a/source/unres/src_MD_DFA/gnmr1.f +++ /dev/null @@ -1,43 +0,0 @@ - double precision function gnmr1(y,ymin,ymax) - implicit none - double precision y,ymin,ymax - double precision wykl /4.0d0/ - if (y.lt.ymin) then - gnmr1=(ymin-y)**wykl/wykl - else if (y.gt.ymax) then - gnmr1=(y-ymax)**wykl/wykl - else - gnmr1=0.0d0 - endif - return - end -c------------------------------------------------------------------------------ - double precision function gnmr1prim(y,ymin,ymax) - implicit none - double precision y,ymin,ymax - double precision wykl /4.0d0/ - if (y.lt.ymin) then - gnmr1prim=-(ymin-y)**(wykl-1) - else if (y.gt.ymax) then - gnmr1prim=(y-ymax)**(wykl-1) - else - gnmr1prim=0.0d0 - endif - return - end -c------------------------------------------------------------------------------ - double precision function harmonic(y,ymax) - implicit none - double precision y,ymax - double precision wykl /2.0d0/ - harmonic=(y-ymax)**wykl - return - end -c------------------------------------------------------------------------------- - double precision function harmonicprim(y,ymax) - double precision y,ymin,ymax - double precision wykl /2.0d0/ - harmonicprim=(y-ymax)*wykl - return - end -c--------------------------------------------------------------------------------- diff --git a/source/unres/src_MD_DFA/gradient_p.F b/source/unres/src_MD_DFA/gradient_p.F deleted file mode 100644 index 7fec1e8..0000000 --- a/source/unres/src_MD_DFA/gradient_p.F +++ /dev/null @@ -1,421 +0,0 @@ - subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.SCCOR' - external ufparm - integer uiparm(1) - double precision urparm(1) - dimension x(maxvar),g(maxvar) -c -c This subroutine calculates total internal coordinate gradient. -c Depending on the number of function evaluations, either whole energy -c is evaluated beforehand, Cartesian coordinates and their derivatives in -c internal coordinates are reevaluated or only the cartesian-in-internal -c coordinate derivatives are evaluated. The subroutine was designed to work -c with SUMSL. -c -c - icg=mod(nf,2)+1 - -cd print *,'grad',nf,icg - if (nf-nfl+1) 20,30,40 - 20 call func(n,x,nf,f,uiparm,urparm,ufparm) -c write (iout,*) 'grad 20' - if (nf.eq.0) return - goto 40 - 30 call var_to_geom(n,x) - call chainbuild -c write (iout,*) 'grad 30' -C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartder -c write (iout,*) 'grad 40' -c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon -C -C Convert the Cartesian gradient into internal-coordinate gradient. -C - ind=0 - ind1=0 - do i=1,nres-2 - gthetai=0.0D0 - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 -c ind=indmat(i,j) -c print *,'GRAD: i=',i,' jc=',j,' ind=',ind - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - enddo - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - enddo - enddo - do j=i+1,nres-1 - ind1=ind1+1 -c ind1=indmat(i,j) -c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 - do k=1,3 - gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) - gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) - enddo - enddo - if (i.gt.1) g(i-1)=gphii - if (n.gt.nphi) g(nphi+i)=gthetai - enddo - if (n.le.nphi+ntheta) goto 10 - do i=2,nres-1 - if (itype(i).ne.10) then - galphai=0.0D0 - gomegai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ialph(i,1))=galphai - g(ialph(i,1)+nside)=gomegai - endif - enddo -C -C Add the components corresponding to local energy terms. -C - 10 continue - do i=1,nvar -cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) - g(i)=g(i)+gloc(i,icg) - enddo -C Uncomment following three lines for diagnostics. -cd call intout -cd call briefout(0,0.0d0) -cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) - return - end -C------------------------------------------------------------------------- - subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - external ufparm - integer uiparm(1) - double precision urparm(1) - dimension x(maxvar),g(maxvar) - - icg=mod(nf,2)+1 - if (nf-nfl+1) 20,30,40 - 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm) -c write (iout,*) 'grad 20' - if (nf.eq.0) return - goto 40 - 30 continue -#ifdef OSF -c Intercept NaNs in the coordinates -c write(iout,*) (var(i),i=1,nvar) - x_sum=0.D0 - do i=1,n - x_sum=x_sum+x(i) - enddo - if (x_sum.ne.x_sum) then - write(iout,*)" *** grad_restr : Found NaN in coordinates" - call flush(iout) - print *," *** grad_restr : Found NaN in coordinates" - return - endif -#endif - call var_to_geom_restr(n,x) - call chainbuild -C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartder -C -C Convert the Cartesian gradient into internal-coordinate gradient. -C - - ig=0 - ind=nres-2 - do i=2,nres-2 - IF (mask_phi(i+2).eq.1) THEN - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) - enddo - enddo - ig=ig+1 - g(ig)=gphii - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - - ind=0 - do i=1,nres-2 - IF (mask_theta(i+2).eq.1) THEN - ig=ig+1 - gthetai=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) - enddo - enddo - g(ig)=gthetai - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - galphai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - g(ig)=galphai - ENDIF - endif - enddo - - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - gomegai=0.0D0 - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ig)=gomegai - ENDIF - endif - enddo - -C -C Add the components corresponding to local energy terms. -C - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - endif - enddo - enddo - -cd do i=1,ig -cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) -cd enddo - return - end -C------------------------------------------------------------------------- - subroutine cartgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.SCCOR' -c -c This subrouting calculates total Cartesian coordinate gradient. -c The subroutine chainbuild_cart and energy MUST be called beforehand. -c -c do i=1,nres -c write (iout,*) "przed sum_grad", gloc_sc(1,i,icg),gloc(i,icg) -c enddo - -#ifdef TIMING - time00=MPI_Wtime() -#endif - icg=1 - call sum_gradient -#ifdef TIMING -#endif -c do i=1,nres -c write (iout,*) "checkgrad", gloc_sc(1,i,icg),gloc(i,icg) -c enddo -cd write (iout,*) "After sum_gradient" -cd do i=1,nres-1 -cd write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) -cd write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) -cd enddo -c If performing constraint dynamics, add the gradients of the constraint energy - if(usampl.and.totT.gt.eq_time) then - do i=1,nct - do j=1,3 - gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i) - gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i) - enddo - enddo - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+dugamma(i) - enddo - do i=1,nres-2 - gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i) - enddo - endif -#ifdef TIMING - time01=MPI_Wtime() -#endif - call intcartderiv -#ifdef TIMING - time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 -#endif -cd call checkintcartgrad -cd write(iout,*) 'calling int_to_cart' -cd write (iout,*) "gcart, gxcart, gloc before int_to_cart" - do i=1,nct - do j=1,3 - gcart(j,i)=gradc(j,i,icg) - gxcart(j,i)=gradx(j,i,icg) - enddo -cd write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3), -cd & (gxcart(j,i),j=1,3),gloc(i,icg) - enddo -#ifdef TIMING - time01=MPI_Wtime() -#endif - call int_to_cart -#ifdef TIMING - time_inttocart=time_inttocart+MPI_Wtime()-time01 -#endif -cd write (iout,*) "gcart and gxcart after int_to_cart" -cd do i=0,nres-1 -cd write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), -cd & (gxcart(j,i),j=1,3) -cd enddo -#ifdef TIMING - time_cartgrad=time_cartgrad+MPI_Wtime()-time00 -#endif - return - end -C------------------------------------------------------------------------- - subroutine zerograd - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.SCCOR' -C -C Initialize Cartesian-coordinate gradient -C - do i=1,nres - do j=1,3 - gvdwx(j,i)=0.0D0 - gvdwxT(j,i)=0.0D0 - gradx_scp(j,i)=0.0D0 - gvdwc(j,i)=0.0D0 - gvdwcT(j,i)=0.0D0 - gvdwc_scp(j,i)=0.0D0 - gvdwc_scpp(j,i)=0.0d0 - gelc (j,i)=0.0D0 - gelc_long(j,i)=0.0D0 - gradb(j,i)=0.0d0 - gradbx(j,i)=0.0d0 - gvdwpp(j,i)=0.0d0 - gel_loc(j,i)=0.0d0 - gel_loc_long(j,i)=0.0d0 - ghpbc(j,i)=0.0D0 - ghpbx(j,i)=0.0D0 - gcorr3_turn(j,i)=0.0d0 - gcorr4_turn(j,i)=0.0d0 - gradcorr(j,i)=0.0d0 - gradcorr_long(j,i)=0.0d0 - gradcorr5_long(j,i)=0.0d0 - gradcorr6_long(j,i)=0.0d0 - gcorr6_turn_long(j,i)=0.0d0 - gradcorr5(j,i)=0.0d0 - gradcorr6(j,i)=0.0d0 - gcorr6_turn(j,i)=0.0d0 - gsccorc(j,i)=0.0d0 - gsccorx(j,i)=0.0d0 - gradc(j,i,icg)=0.0d0 - gradx(j,i,icg)=0.0d0 - gscloc(j,i)=0.0d0 - gsclocx(j,i)=0.0d0 - do intertyp=1,3 - gloc_sc(intertyp,i,icg)=0.0d0 - enddo - enddo - enddo -C -C Initialize the gradient of local energy terms. -C - do i=1,4*nres - gloc(i,icg)=0.0D0 - enddo - do i=1,nres - gel_loc_loc(i)=0.0d0 - gcorr_loc(i)=0.0d0 - g_corr5_loc(i)=0.0d0 - g_corr6_loc(i)=0.0d0 - gel_loc_turn3(i)=0.0d0 - gel_loc_turn4(i)=0.0d0 - gel_loc_turn6(i)=0.0d0 - gsccor_loc(i)=0.0d0 - enddo -c initialize gcart and gxcart - do i=0,nres - do j=1,3 - gcart(j,i)=0.0d0 - gxcart(j,i)=0.0d0 - enddo - enddo - return - end -c------------------------------------------------------------------------- - double precision function fdum() - fdum=0.0D0 - return - end diff --git a/source/unres/src_MD_DFA/initialize_p.F b/source/unres/src_MD_DFA/initialize_p.F deleted file mode 100644 index 16ba578..0000000 --- a/source/unres/src_MD_DFA/initialize_p.F +++ /dev/null @@ -1,1394 +0,0 @@ - block data - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.MD' - data MovTypID - & /'pool','chain regrow','multi-bond','phi','theta','side chain', - & 'total'/ -c Conversion from poises to molecular unit and the gas constant - data cPoise /2.9361d0/, Rb /0.001986d0/ - end -c-------------------------------------------------------------------------- - subroutine initialize -C -C Define constants and zero out tables. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.MCM' - include 'COMMON.MINIM' - include 'COMMON.DERIV' - include 'COMMON.SPLITELE' -c Common blocks from the diagonalization routines - COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) - COMMON /MACHSW/ KDIAG,ICORFL,IXDR - logical mask_r -c real*8 text1 /'initial_i'/ - - mask_r=.false. -#ifndef ISNAN -c NaNQ initialization - i=-1 - arg=100.0d0 - rr=dacos(arg) -#ifdef WINPGI - idumm=proc_proc(rr,i) -#else - call proc_proc(rr,i) -#endif -#endif - - kdiag=0 - icorfl=0 - iw=2 -C -C The following is just to define auxiliary variables used in angle conversion -C - pi=4.0D0*datan(1.0D0) - dwapi=2.0D0*pi - dwapi3=dwapi/3.0D0 - pipol=0.5D0*pi - deg2rad=pi/180.0D0 - rad2deg=1.0D0/deg2rad - angmin=10.0D0*deg2rad -C -C Define I/O units. -C - inp= 1 - iout= 2 - ipdbin= 3 - ipdb= 7 - icart = 30 - imol2= 4 - igeom= 8 - intin= 9 - ithep= 11 - ithep_pdb=51 - irotam=12 - irotam_pdb=52 - itorp= 13 - itordp= 23 - ielep= 14 - isidep=15 - iscpp=25 - icbase=16 - ifourier=20 - istat= 17 - irest1=55 - irest2=56 - iifrag=57 - ientin=18 - ientout=19 - ibond = 28 - isccor = 29 -crc for write_rmsbank1 - izs1=21 -cdr include secondary structure prediction bias - isecpred=27 -C -C CSA I/O units (separated from others especially for Jooyoung) -C - icsa_rbank=30 - icsa_seed=31 - icsa_history=32 - icsa_bank=33 - icsa_bank1=34 - icsa_alpha=35 - icsa_alpha1=36 - icsa_bankt=37 - icsa_int=39 - icsa_bank_reminimized=38 - icsa_native_int=41 - icsa_in=40 -crc for ifc error 118 - icsa_pdb=42 -C -C Set default weights of the energy terms. -C - wlong=1.0D0 - welec=1.0D0 - wtor =1.0D0 - wang =1.0D0 - wscloc=1.0D0 - wstrain=1.0D0 -C -C Zero out tables. -C - print '(a,$)','Inside initialize' -c call memmon_print_usage() - do i=1,maxres2 - do j=1,3 - c(j,i)=0.0D0 - dc(j,i)=0.0D0 - enddo - enddo - do i=1,maxres - do j=1,3 - xloc(j,i)=0.0D0 - enddo - enddo - do i=1,ntyp - do j=1,ntyp - aa(i,j)=0.0D0 - bb(i,j)=0.0D0 - augm(i,j)=0.0D0 - sigma(i,j)=0.0D0 - r0(i,j)=0.0D0 - chi(i,j)=0.0D0 - enddo - do j=1,2 - bad(i,j)=0.0D0 - enddo - chip(i)=0.0D0 - alp(i)=0.0D0 - sigma0(i)=0.0D0 - sigii(i)=0.0D0 - rr0(i)=0.0D0 - a0thet(i)=0.0D0 - do j=1,2 - athet(j,i)=0.0D0 - bthet(j,i)=0.0D0 - enddo - do j=0,3 - polthet(j,i)=0.0D0 - enddo - do j=1,3 - gthet(j,i)=0.0D0 - enddo - theta0(i)=0.0D0 - sig0(i)=0.0D0 - sigc0(i)=0.0D0 - do j=1,maxlob - bsc(j,i)=0.0D0 - do k=1,3 - censc(k,j,i)=0.0D0 - enddo - do k=1,3 - do l=1,3 - gaussc(l,k,j,i)=0.0D0 - enddo - enddo - nlob(i)=0 - enddo - enddo - nlob(ntyp1)=0 - dsc(ntyp1)=0.0D0 - do i=1,maxtor - itortyp(i)=0 - do j=1,maxtor - do k=1,maxterm - v1(k,j,i)=0.0D0 - v2(k,j,i)=0.0D0 - enddo - enddo - enddo - do i=1,maxres - itype(i)=0 - itel(i)=0 - enddo -C Initialize the bridge arrays - ns=0 - nss=0 - nhpb=0 - do i=1,maxss - iss(i)=0 - enddo - do i=1,maxdim - dhpb(i)=0.0D0 - enddo - do i=1,maxres - ihpb(i)=0 - jhpb(i)=0 - enddo -C -C Initialize timing. -C - call set_timers -C -C Initialize variables used in minimization. -C -c maxfun=5000 -c maxit=2000 - maxfun=500 - maxit=200 - tolf=1.0D-2 - rtolf=5.0D-4 -C -C Initialize the variables responsible for the mode of gradient storage. -C - nfl=0 - icg=1 -C -C Initialize constants used to split the energy into long- and short-range -C components -C - r_cut=2.0d0 - rlamb=0.3d0 -#ifndef SPLITELE - nprint_ene=nprint_ene-1 -#endif - return - end -c------------------------------------------------------------------------- - block data nazwy - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - data restyp / - &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR', - &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/ - data onelet / - &'C','M','F','I','L','V','W','Y','A','G','T', - &'S','Q','N','E','D','H','R','K','P','X'/ - data potname /'LJ','LJK','BP','GB','GBV'/ - data ename / - & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ", - & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ", - & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ", - & "ESTR ","EVDW2_14 ","UCONST ", " ","ESCCOR"," "," ", - & "DFA DIS","DFA TOR","DFA NEI","DFA BET"/ - data wname / - & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", - & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD", - & "WSTRAIN","WVDWPP","WBOND","SCAL14"," "," ","WSCCOR", - & " "," ","WDFAD","WDFAT","WDFAN","WDFAB"/ - data nprint_ene /24/ - data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16, - & 21,24,25,26,27,0,0,0/ - end -c--------------------------------------------------------------------------- - subroutine init_int_table - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer blocklengths(15),displs(15) -#endif - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.SBRIDGE' - include 'COMMON.TORCNSTR' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.CONTACTS' - common /przechowalnia/ iturn3_start_all(0:max_fg_procs), - & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs), - & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs), - &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1), - & ielend_all(maxres,0:max_fg_procs-1), - & ntask_cont_from_all(0:max_fg_procs-1), - & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1), - & ntask_cont_to_all(0:max_fg_procs-1), - & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1) - integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP - logical scheck,lprint,flag -#ifdef MPI - integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs), - & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs) -C... Determine the numbers of start and end SC-SC interaction -C... to deal with by current processor. - do i=0,nfgtasks-1 - itask_cont_from(i)=fg_rank - itask_cont_to(i)=fg_rank - enddo - lprint=.false. - if (lprint) - &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct - n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss - call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde) - if (lprint) - & write (iout,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',MyRank, - & ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds, - & ' my_sc_inde',my_sc_inde - ind_sctint=0 - iatsc_s=0 - iatsc_e=0 -#endif -c lprint=.false. - do i=1,maxres - nint_gr(i)=0 - nscp_gr(i)=0 - do j=1,maxint_gr - istart(i,1)=0 - iend(i,1)=0 - ielstart(i)=0 - ielend(i)=0 - iscpstart(i,1)=0 - iscpend(i,1)=0 - enddo - enddo - ind_scint=0 - ind_scint_old=0 -cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', -cd & (ihpb(i),jhpb(i),i=1,nss) - do i=nnt,nct-1 - scheck=.false. - do ii=1,nss - if (ihpb(ii).eq.i+nres) then - scheck=.true. - jj=jhpb(ii)-nres - goto 10 - endif - enddo - 10 continue -cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj - if (scheck) then - if (jj.eq.i+1) then -#ifdef MPI -c write (iout,*) 'jj=i+1' - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12) -#else - nint_gr(i)=1 - istart(i,1)=i+2 - iend(i,1)=nct -#endif - else if (jj.eq.nct) then -#ifdef MPI -c write (iout,*) 'jj=nct' - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12) -#else - nint_gr(i)=1 - istart(i,1)=i+1 - iend(i,1)=nct-1 -#endif - else -#ifdef MPI - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12) - ii=nint_gr(i)+1 - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12) -#else - nint_gr(i)=2 - istart(i,1)=i+1 - iend(i,1)=jj-1 - istart(i,2)=jj+1 - iend(i,2)=nct -#endif - endif - else -#ifdef MPI - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12) -#else - nint_gr(i)=1 - istart(i,1)=i+1 - iend(i,1)=nct - ind_scint=ind_scint+nct-i -#endif - endif -#ifdef MPI - ind_scint_old=ind_scint -#endif - enddo - 12 continue -#ifndef MPI - iatsc_s=nnt - iatsc_e=nct-1 -#endif -#ifdef MPI - if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor, - & ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e -#endif - if (lprint) then - write (iout,'(a)') 'Interaction array:' - do i=iatsc_s,iatsc_e - write (iout,'(i3,2(2x,2i3))') - & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i)) - enddo - endif - ispp=4 -#ifdef MPI -C Now partition the electrostatic-interaction array - npept=nct-nnt - nele_int_tot=(npept-ispp)*(npept-ispp+1)/2 - call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde) - if (lprint) - & write (*,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',MyRank, - & ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds, - & ' my_ele_inde',my_ele_inde - iatel_s=0 - iatel_e=0 - ind_eleint=0 - ind_eleint_old=0 - do i=nnt,nct-3 - ijunk=0 - call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i, - & iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13) - enddo ! i - 13 continue - if (iatel_s.eq.0) iatel_s=1 - nele_int_tot_vdw=(npept-2)*(npept-2+1)/2 -c write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw - call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw) -c write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw, -c & " my_ele_inde_vdw",my_ele_inde_vdw - ind_eleint_vdw=0 - ind_eleint_vdw_old=0 - iatel_s_vdw=0 - iatel_e_vdw=0 - do i=nnt,nct-3 - ijunk=0 - call int_partition(ind_eleint_vdw,my_ele_inds_vdw, - & my_ele_inde_vdw,i, - & iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i), - & ielend_vdw(i),*15) -c write (iout,*) i," ielstart_vdw",ielstart_vdw(i), -c & " ielend_vdw",ielend_vdw(i) - enddo ! i - if (iatel_s_vdw.eq.0) iatel_s_vdw=1 - 15 continue -#else - iatel_s=nnt - iatel_e=nct-5 - do i=iatel_s,iatel_e - ielstart(i)=i+4 - ielend(i)=nct-1 - enddo - iatel_s_vdw=nnt - iatel_e_vdw=nct-3 - do i=iatel_s_vdw,iatel_e_vdw - ielstart_vdw(i)=i+2 - ielend_vdw(i)=nct-1 - enddo -#endif - if (lprint) then - write (*,'(a)') 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',MyRank - write (iout,*) 'Electrostatic interaction array:' - do i=iatel_s,iatel_e - write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i) - enddo - endif ! lprint -c iscp=3 - iscp=2 -C Partition the SC-p interaction array -#ifdef MPI - nscp_int_tot=(npept-iscp+1)*(npept-iscp+1) - call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde) - if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',myrank, - & ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds, - & ' my_scp_inde',my_scp_inde - iatscp_s=0 - iatscp_e=0 - ind_scpint=0 - ind_scpint_old=0 - do i=nnt,nct-1 - if (i.lt.nnt+iscp) then -cd write (iout,*) 'i.le.nnt+iscp' - call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, - & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1), - & iscpend(i,1),*14) - else if (i.gt.nct-iscp) then -cd write (iout,*) 'i.gt.nct-iscp' - call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, - & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), - & iscpend(i,1),*14) - else - call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, - & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), - & iscpend(i,1),*14) - ii=nscp_gr(i)+1 - call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, - & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii), - & iscpend(i,ii),*14) - endif - enddo ! i - 14 continue -#else - iatscp_s=nnt - iatscp_e=nct-1 - do i=nnt,nct-1 - if (i.lt.nnt+iscp) then - nscp_gr(i)=1 - iscpstart(i,1)=i+iscp - iscpend(i,1)=nct - elseif (i.gt.nct-iscp) then - nscp_gr(i)=1 - iscpstart(i,1)=nnt - iscpend(i,1)=i-iscp - else - nscp_gr(i)=2 - iscpstart(i,1)=nnt - iscpend(i,1)=i-iscp - iscpstart(i,2)=i+iscp - iscpend(i,2)=nct - endif - enddo ! i -#endif - if (lprint) then - write (iout,'(a)') 'SC-p interaction array:' - do i=iatscp_s,iatscp_e - write (iout,'(i3,2(2x,2i3))') - & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) - enddo - endif ! lprint -C Partition local interactions -#ifdef MPI - call int_bounds(nres-2,loc_start,loc_end) - loc_start=loc_start+1 - loc_end=loc_end+1 - call int_bounds(nres-2,ithet_start,ithet_end) - ithet_start=ithet_start+2 - ithet_end=ithet_end+2 - call int_bounds(nct-nnt-2,iturn3_start,iturn3_end) - iturn3_start=iturn3_start+nnt - iphi_start=iturn3_start+2 - iturn3_end=iturn3_end+nnt - iphi_end=iturn3_end+2 - iturn3_start=iturn3_start-1 - iturn3_end=iturn3_end-1 - call int_bounds(nres-3,itau_start,itau_end) - itau_start=itau_start+3 - itau_end=itau_end+3 - call int_bounds(nres-3,iphi1_start,iphi1_end) - iphi1_start=iphi1_start+3 - iphi1_end=iphi1_end+3 - call int_bounds(nct-nnt-3,iturn4_start,iturn4_end) - iturn4_start=iturn4_start+nnt - iphid_start=iturn4_start+2 - iturn4_end=iturn4_end+nnt - iphid_end=iturn4_end+2 - iturn4_start=iturn4_start-1 - iturn4_end=iturn4_end-1 - call int_bounds(nres-2,ibond_start,ibond_end) - ibond_start=ibond_start+1 - ibond_end=ibond_end+1 - call int_bounds(nct-nnt,ibondp_start,ibondp_end) - ibondp_start=ibondp_start+nnt - ibondp_end=ibondp_end+nnt - call int_bounds1(nres-1,ivec_start,ivec_end) - print *,"Processor",myrank,fg_rank,fg_rank1, - & " ivec_start",ivec_start," ivec_end",ivec_end - iset_start=loc_start+2 - iset_end=loc_end+2 - if (ndih_constr.eq.0) then - idihconstr_start=1 - idihconstr_end=0 - else - call int_bounds(ndih_constr,idihconstr_start,idihconstr_end) - endif - nsumgrad=(nres-nnt)*(nres-nnt+1)/2 - nlen=nres-nnt+1 - call int_bounds(nsumgrad,ngrad_start,ngrad_end) - igrad_start=((2*nlen+1) - & -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2 - jgrad_start(igrad_start)= - & ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2 - & +igrad_start - jgrad_end(igrad_start)=nres - igrad_end=((2*nlen+1) - & -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2 - if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1 - jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2 - & +igrad_end - do i=igrad_start+1,igrad_end-1 - jgrad_start(i)=i+1 - jgrad_end(i)=nres - enddo - if (lprint) then - write (*,*) 'Processor:',fg_rank,' CG group',kolor, - & ' absolute rank',myrank, - & ' loc_start',loc_start,' loc_end',loc_end, - & ' ithet_start',ithet_start,' ithet_end',ithet_end, - & ' iphi_start',iphi_start,' iphi_end',iphi_end, - & ' iphid_start',iphid_start,' iphid_end',iphid_end, - & ' ibond_start',ibond_start,' ibond_end',ibond_end, - & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end, - & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end, - & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end, - & ' ivec_start',ivec_start,' ivec_end',ivec_end, - & ' iset_start',iset_start,' iset_end',iset_end, - & ' idihconstr_start',idihconstr_start,' idihconstr_end', - & idihconstr_end - write (*,*) 'Processor:',fg_rank,myrank,' igrad_start', - & igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start, - & ' ngrad_end',ngrad_end - do i=igrad_start,igrad_end - write(*,*) 'Processor:',fg_rank,myrank,i, - & jgrad_start(i),jgrad_end(i) - enddo - endif - if (nfgtasks.gt.1) then - call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1, - & MPI_INTEGER,FG_COMM1,IERROR) - iaux=ivec_end-ivec_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1, - & MPI_INTEGER,FG_COMM1,IERROR) - call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=iset_end-iset_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=ibond_end-ibond_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=ithet_end-ithet_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=iphi_end-iphi_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=iphi1_end-iphi1_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - do i=0,maxprocs-1 - do j=1,maxres - ielstart_all(j,i)=0 - ielend_all(j,i)=0 - enddo - enddo - call MPI_Allgather(iturn3_start,1,MPI_INTEGER, - & iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iturn4_start,1,MPI_INTEGER, - & iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iturn3_end,1,MPI_INTEGER, - & iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iturn4_end,1,MPI_INTEGER, - & iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iatel_s,1,MPI_INTEGER, - & iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iatel_e,1,MPI_INTEGER, - & iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER, - & ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ielend(1),maxres,MPI_INTEGER, - & ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR) - if (lprint) then - write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks) - write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks) - write (iout,*) "iturn3_start_all", - & (iturn3_start_all(i),i=0,nfgtasks-1) - write (iout,*) "iturn3_end_all", - & (iturn3_end_all(i),i=0,nfgtasks-1) - write (iout,*) "iturn4_start_all", - & (iturn4_start_all(i),i=0,nfgtasks-1) - write (iout,*) "iturn4_end_all", - & (iturn4_end_all(i),i=0,nfgtasks-1) - write (iout,*) "The ielstart_all array" - do i=nnt,nct - write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1) - enddo - write (iout,*) "The ielend_all array" - do i=nnt,nct - write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1) - enddo - call flush(iout) - endif - ntask_cont_from=0 - ntask_cont_to=0 - itask_cont_from(0)=fg_rank - itask_cont_to(0)=fg_rank - flag=.false. - do ii=iturn3_start,iturn3_end - call add_int(ii,ii+2,iturn3_sent(1,ii), - & ntask_cont_to,itask_cont_to,flag) - enddo - do ii=iturn4_start,iturn4_end - call add_int(ii,ii+3,iturn4_sent(1,ii), - & ntask_cont_to,itask_cont_to,flag) - enddo - do ii=iturn3_start,iturn3_end - call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from) - enddo - do ii=iturn4_start,iturn4_end - call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from) - enddo - if (lprint) then - write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from, - & " ntask_cont_to",ntask_cont_to - write (iout,*) "itask_cont_from", - & (itask_cont_from(i),i=1,ntask_cont_from) - write (iout,*) "itask_cont_to", - & (itask_cont_to(i),i=1,ntask_cont_to) - call flush(iout) - endif -c write (iout,*) "Loop forward" -c call flush(iout) - do i=iatel_s,iatel_e -c write (iout,*) "from loop i=",i -c call flush(iout) - do j=ielstart(i),ielend(i) - call add_int_from(i,j,ntask_cont_from,itask_cont_from) - enddo - enddo -c write (iout,*) "Loop backward iatel_e-1",iatel_e-1, -c & " iatel_e",iatel_e -c call flush(iout) - nat_sent=0 - do i=iatel_s,iatel_e -c write (iout,*) "i",i," ielstart",ielstart(i), -c & " ielend",ielend(i) -c call flush(iout) - flag=.false. - do j=ielstart(i),ielend(i) - call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to, - & itask_cont_to,flag) - enddo - if (flag) then - nat_sent=nat_sent+1 - iat_sent(nat_sent)=i - endif - enddo - if (lprint) then - write (iout,*)"After longrange ntask_cont_from",ntask_cont_from, - & " ntask_cont_to",ntask_cont_to - write (iout,*) "itask_cont_from", - & (itask_cont_from(i),i=1,ntask_cont_from) - write (iout,*) "itask_cont_to", - & (itask_cont_to(i),i=1,ntask_cont_to) - call flush(iout) - write (iout,*) "iint_sent" - do i=1,nat_sent - ii=iat_sent(i) - write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4), - & j=ielstart(ii),ielend(ii)) - enddo - write (iout,*) "iturn3_sent iturn3_start",iturn3_start, - & " iturn3_end",iturn3_end - write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4), - & i=iturn3_start,iturn3_end) - write (iout,*) "iturn4_sent iturn4_start",iturn4_start, - & " iturn4_end",iturn4_end - write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4), - & i=iturn4_start,iturn4_end) - call flush(iout) - endif - call MPI_Gather(ntask_cont_from,1,MPI_INTEGER, - & ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR) -c write (iout,*) "Gather ntask_cont_from ended" -c call flush(iout) - call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER, - & itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king, - & FG_COMM,IERR) -c write (iout,*) "Gather itask_cont_from ended" -c call flush(iout) - call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all, - & 1,MPI_INTEGER,king,FG_COMM,IERR) -c write (iout,*) "Gather ntask_cont_to ended" -c call flush(iout) - call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER, - & itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR) -c write (iout,*) "Gather itask_cont_to ended" -c call flush(iout) - if (fg_rank.eq.king) then - write (iout,*)"Contact receive task map (proc, #tasks, tasks)" - do i=0,nfgtasks-1 - write (iout,'(20i4)') i,ntask_cont_from_all(i), - & (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i)) - enddo - write (iout,*) - call flush(iout) - write (iout,*) "Contact send task map (proc, #tasks, tasks)" - do i=0,nfgtasks-1 - write (iout,'(20i4)') i,ntask_cont_to_all(i), - & (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i)) - enddo - write (iout,*) - call flush(iout) -C Check if every send will have a matching receive - ncheck_to=0 - ncheck_from=0 - do i=0,nfgtasks-1 - ncheck_to=ncheck_to+ntask_cont_to_all(i) - ncheck_from=ncheck_from+ntask_cont_from_all(i) - enddo - write (iout,*) "Control sums",ncheck_from,ncheck_to - if (ncheck_from.ne.ncheck_to) then - write (iout,*) "Error: #receive differs from #send." - write (iout,*) "Terminating program...!" - call flush(iout) - flag=.false. - else - flag=.true. - do i=0,nfgtasks-1 - do j=1,ntask_cont_to_all(i) - ii=itask_cont_to_all(j,i) - do k=1,ntask_cont_from_all(ii) - if (itask_cont_from_all(k,ii).eq.i) then - if(lprint)write(iout,*)"Matching send/receive",i,ii - exit - endif - enddo - if (k.eq.ntask_cont_from_all(ii)+1) then - flag=.false. - write (iout,*) "Error: send by",j," to",ii, - & " would have no matching receive" - endif - enddo - enddo - endif - if (.not.flag) then - write (iout,*) "Unmatched sends; terminating program" - call flush(iout) - endif - endif - call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR) -c write (iout,*) "flag broadcast ended flag=",flag -c call flush(iout) - if (.not.flag) then - call MPI_Finalize(IERROR) - stop "Error in INIT_INT_TABLE: unmatched send/receive." - endif - call MPI_Comm_group(FG_COMM,fg_group,IERR) -c write (iout,*) "MPI_Comm_group ended" -c call flush(iout) - call MPI_Group_incl(fg_group,ntask_cont_from+1, - & itask_cont_from(0),CONT_FROM_GROUP,IERR) - call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0), - & CONT_TO_GROUP,IERR) - do i=1,nat_sent - ii=iat_sent(i) - iaux=4*(ielend(ii)-ielstart(ii)+1) - call MPI_Group_translate_ranks(fg_group,iaux, - & iint_sent(1,ielstart(ii),i),CONT_TO_GROUP, - & iint_sent_local(1,ielstart(ii),i),IERR ) -c write (iout,*) "Ranks translated i=",i -c call flush(iout) - enddo - iaux=4*(iturn3_end-iturn3_start+1) - call MPI_Group_translate_ranks(fg_group,iaux, - & iturn3_sent(1,iturn3_start),CONT_TO_GROUP, - & iturn3_sent_local(1,iturn3_start),IERR) - iaux=4*(iturn4_end-iturn4_start+1) - call MPI_Group_translate_ranks(fg_group,iaux, - & iturn4_sent(1,iturn4_start),CONT_TO_GROUP, - & iturn4_sent_local(1,iturn4_start),IERR) - if (lprint) then - write (iout,*) "iint_sent_local" - do i=1,nat_sent - ii=iat_sent(i) - write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4), - & j=ielstart(ii),ielend(ii)) - call flush(iout) - enddo - write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start, - & " iturn3_end",iturn3_end - write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4), - & i=iturn3_start,iturn3_end) - write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start, - & " iturn4_end",iturn4_end - write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4), - & i=iturn4_start,iturn4_end) - call flush(iout) - endif - call MPI_Group_free(fg_group,ierr) - call MPI_Group_free(cont_from_group,ierr) - call MPI_Group_free(cont_to_group,ierr) - call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR) - call MPI_Type_commit(MPI_UYZ,IERROR) - call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD, - & IERROR) - call MPI_Type_commit(MPI_UYZGRAD,IERROR) - call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR) - call MPI_Type_commit(MPI_MU,IERROR) - call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR) - call MPI_Type_commit(MPI_MAT1,IERROR) - call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR) - call MPI_Type_commit(MPI_MAT2,IERROR) - call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR) - call MPI_Type_commit(MPI_THET,IERROR) - call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR) - call MPI_Type_commit(MPI_GAM,IERROR) -#ifndef MATGATHER -c 9/22/08 Derived types to send matrices which appear in correlation terms - do i=0,nfgtasks-1 - if (ivec_count(i).eq.ivec_count(0)) then - lentyp(i)=0 - else - lentyp(i)=1 - endif - enddo - do ind_typ=lentyp(0),lentyp(nfgtasks-1) - if (ind_typ.eq.0) then - ichunk=ivec_count(0) - else - ichunk=ivec_count(1) - endif -c do i=1,4 -c blocklengths(i)=4 -c enddo -c displs(1)=0 -c do i=2,4 -c displs(i)=displs(i-1)+blocklengths(i-1)*maxres -c enddo -c do i=1,4 -c blocklengths(i)=blocklengths(i)*ichunk -c enddo -c write (iout,*) "blocklengths and displs" -c do i=1,4 -c write (iout,*) i,blocklengths(i),displs(i) -c enddo -c call flush(iout) -c call MPI_Type_indexed(4,blocklengths(1),displs(1), -c & MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR) -c call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR) -c write (iout,*) "MPI_ROTAT1",MPI_ROTAT1 -c do i=1,4 -c blocklengths(i)=2 -c enddo -c displs(1)=0 -c do i=2,4 -c displs(i)=displs(i-1)+blocklengths(i-1)*maxres -c enddo -c do i=1,4 -c blocklengths(i)=blocklengths(i)*ichunk -c enddo -c write (iout,*) "blocklengths and displs" -c do i=1,4 -c write (iout,*) i,blocklengths(i),displs(i) -c enddo -c call flush(iout) -c call MPI_Type_indexed(4,blocklengths(1),displs(1), -c & MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR) -c call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR) -c write (iout,*) "MPI_ROTAT2",MPI_ROTAT2 - do i=1,8 - blocklengths(i)=2 - enddo - displs(1)=0 - do i=2,8 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,15 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(8,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR) - call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR) - do i=1,8 - blocklengths(i)=4 - enddo - displs(1)=0 - do i=2,8 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,15 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(8,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR) - call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR) - do i=1,6 - blocklengths(i)=4 - enddo - displs(1)=0 - do i=2,6 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,6 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(6,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR) - call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR) - do i=1,2 - blocklengths(i)=8 - enddo - displs(1)=0 - do i=2,2 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,2 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(2,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR) - call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR) - do i=1,4 - blocklengths(i)=1 - enddo - displs(1)=0 - do i=2,4 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,4 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(4,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR) - call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR) - enddo -#endif - endif - iint_start=ivec_start+1 - iint_end=ivec_end+1 - do i=0,nfgtasks-1 - iint_count(i)=ivec_count(i) - iint_displ(i)=ivec_displ(i) - ivec_displ(i)=ivec_displ(i)-1 - iset_displ(i)=iset_displ(i)-1 - ithet_displ(i)=ithet_displ(i)-1 - iphi_displ(i)=iphi_displ(i)-1 - iphi1_displ(i)=iphi1_displ(i)-1 - ibond_displ(i)=ibond_displ(i)-1 - enddo - if (nfgtasks.gt.1 .and. fg_rank.eq.king - & .and. (me.eq.0 .or. out1file)) then - write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT" - do i=0,nfgtasks-1 - write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i), - & iset_count(i) - enddo - write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end, - & " iphi1_start",iphi1_start," iphi1_end",iphi1_end - write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL" - do i=0,nfgtasks-1 - write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i), - & iphi1_displ(i) - enddo - write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ', - & nele_int_tot,' electrostatic and ',nscp_int_tot, - & ' SC-p interactions','were distributed among',nfgtasks, - & ' fine-grain processors.' - endif -#else - loc_start=2 - loc_end=nres-1 - ithet_start=3 - ithet_end=nres - iturn3_start=nnt - iturn3_end=nct-3 - iturn4_start=nnt - iturn4_end=nct-4 - iphi_start=nnt+3 - iphi_end=nct - iphi1_start=4 - iphi1_end=nres - idihconstr_start=1 - idihconstr_end=ndih_constr - iphid_start=iphi_start - iphid_end=iphi_end-1 - itau_start=4 - itau_end=nres - ibond_start=2 - ibond_end=nres-1 - ibondp_start=nnt+1 - ibondp_end=nct - ivec_start=1 - ivec_end=nres-1 - iset_start=3 - iset_end=nres+1 - iint_start=2 - iint_end=nres-1 -#endif - return - end -#ifdef MPI -c--------------------------------------------------------------------------- - subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag) - implicit none - include "DIMENSIONS" - include "COMMON.INTERACT" - include "COMMON.SETUP" - include "COMMON.IOUNITS" - integer ii,jj,itask(4), - & ntask_cont_to,itask_cont_to(0:max_fg_procs-1) - logical flag - integer iturn3_start_all,iturn3_end_all,iturn4_start_all, - & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all - common /przechowalnia/ iturn3_start_all(0:max_fg_procs), - & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs), - & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs), - &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1), - & ielend_all(maxres,0:max_fg_procs-1) - integer iproc,isent,k,l -c Determines whether to send interaction ii,jj to other processors; a given -c interaction can be sent to at most 2 processors. -c Sets flag=.true. if interaction ii,jj needs to be sent to at least -c one processor, otherwise flag is unchanged from the input value. - isent=0 - itask(1)=fg_rank - itask(2)=fg_rank - itask(3)=fg_rank - itask(4)=fg_rank -c write (iout,*) "ii",ii," jj",jj -c Loop over processors to check if anybody could need interaction ii,jj - do iproc=0,fg_rank-1 -c Check if the interaction matches any turn3 at iproc - do k=iturn3_start_all(iproc),iturn3_end_all(iproc) - l=k+2 - if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1 - & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1) - & then -c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l -c call flush(iout) - flag=.true. - if (iproc.ne.itask(1).and.iproc.ne.itask(2) - & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then - isent=isent+1 - itask(isent)=iproc - call add_task(iproc,ntask_cont_to,itask_cont_to) - endif - endif - enddo -C Check if the interaction matches any turn4 at iproc - do k=iturn4_start_all(iproc),iturn4_end_all(iproc) - l=k+3 - if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1 - & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1) - & then -c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l -c call flush(iout) - flag=.true. - if (iproc.ne.itask(1).and.iproc.ne.itask(2) - & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then - isent=isent+1 - itask(isent)=iproc - call add_task(iproc,ntask_cont_to,itask_cont_to) - endif - endif - enddo - if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and. - & iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then - if (ielstart_all(ii-1,iproc).le.jj-1.and. - & ielend_all(ii-1,iproc).ge.jj-1) then - flag=.true. - if (iproc.ne.itask(1).and.iproc.ne.itask(2) - & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then - isent=isent+1 - itask(isent)=iproc - call add_task(iproc,ntask_cont_to,itask_cont_to) - endif - endif - if (ielstart_all(ii-1,iproc).le.jj+1.and. - & ielend_all(ii-1,iproc).ge.jj+1) then - flag=.true. - if (iproc.ne.itask(1).and.iproc.ne.itask(2) - & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then - isent=isent+1 - itask(isent)=iproc - call add_task(iproc,ntask_cont_to,itask_cont_to) - endif - endif - endif - enddo - return - end -c--------------------------------------------------------------------------- - subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from) - implicit none - include "DIMENSIONS" - include "COMMON.INTERACT" - include "COMMON.SETUP" - include "COMMON.IOUNITS" - integer ii,jj,itask(2),ntask_cont_from, - & itask_cont_from(0:max_fg_procs-1) - logical flag - integer iturn3_start_all,iturn3_end_all,iturn4_start_all, - & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all - common /przechowalnia/ iturn3_start_all(0:max_fg_procs), - & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs), - & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs), - &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1), - & ielend_all(maxres,0:max_fg_procs-1) - integer iproc,k,l - do iproc=fg_rank+1,nfgtasks-1 - do k=iturn3_start_all(iproc),iturn3_end_all(iproc) - l=k+2 - if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1 - & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1) - & then -c write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - enddo - do k=iturn4_start_all(iproc),iturn4_end_all(iproc) - l=k+3 - if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1 - & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1) - & then -c write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - enddo - if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then - if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc)) - & then - if (jj+1.ge.ielstart_all(ii+1,iproc).and. - & jj+1.le.ielend_all(ii+1,iproc)) then - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - if (jj-1.ge.ielstart_all(ii+1,iproc).and. - & jj-1.le.ielend_all(ii+1,iproc)) then - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - endif - if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc)) - & then - if (jj-1.ge.ielstart_all(ii-1,iproc).and. - & jj-1.le.ielend_all(ii-1,iproc)) then - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - if (jj+1.ge.ielstart_all(ii-1,iproc).and. - & jj+1.le.ielend_all(ii-1,iproc)) then - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - endif - endif - enddo - return - end -c--------------------------------------------------------------------------- - subroutine add_task(iproc,ntask_cont,itask_cont) - implicit none - include "DIMENSIONS" - integer iproc,ntask_cont,itask_cont(0:max_fg_procs-1) - integer ii - do ii=1,ntask_cont - if (itask_cont(ii).eq.iproc) return - enddo - ntask_cont=ntask_cont+1 - itask_cont(ntask_cont)=iproc - return - end -c--------------------------------------------------------------------------- - subroutine int_bounds(total_ints,lower_bound,upper_bound) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - integer total_ints,lower_bound,upper_bound - integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs) - nint=total_ints/nfgtasks - do i=1,nfgtasks - int4proc(i-1)=nint - enddo - nexcess=total_ints-nint*nfgtasks - do i=1,nexcess - int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1 - enddo - lower_bound=0 - do i=0,fg_rank-1 - lower_bound=lower_bound+int4proc(i) - enddo - upper_bound=lower_bound+int4proc(fg_rank) - lower_bound=lower_bound+1 - return - end -c--------------------------------------------------------------------------- - subroutine int_bounds1(total_ints,lower_bound,upper_bound) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - integer total_ints,lower_bound,upper_bound - integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs) - nint=total_ints/nfgtasks1 - do i=1,nfgtasks1 - int4proc(i-1)=nint - enddo - nexcess=total_ints-nint*nfgtasks1 - do i=1,nexcess - int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1 - enddo - lower_bound=0 - do i=0,fg_rank1-1 - lower_bound=lower_bound+int4proc(i) - enddo - upper_bound=lower_bound+int4proc(fg_rank1) - lower_bound=lower_bound+1 - return - end -c--------------------------------------------------------------------------- - subroutine int_partition(int_index,lower_index,upper_index,atom, - & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - integer int_index,lower_index,upper_index,atom,at_start,at_end, - & first_atom,last_atom,int_gr,jat_start,jat_end - logical lprn - lprn=.false. - if (lprn) write (iout,*) 'int_index=',int_index - int_index_old=int_index - int_index=int_index+last_atom-first_atom+1 - if (lprn) - & write (iout,*) 'int_index=',int_index, - & ' int_index_old',int_index_old, - & ' lower_index=',lower_index, - & ' upper_index=',upper_index, - & ' atom=',atom,' first_atom=',first_atom, - & ' last_atom=',last_atom - if (int_index.ge.lower_index) then - int_gr=int_gr+1 - if (at_start.eq.0) then - at_start=atom - jat_start=first_atom-1+lower_index-int_index_old - else - jat_start=first_atom - endif - if (lprn) write (iout,*) 'jat_start',jat_start - if (int_index.ge.upper_index) then - at_end=atom - jat_end=first_atom-1+upper_index-int_index_old - return1 - else - jat_end=last_atom - endif - if (lprn) write (iout,*) 'jat_end',jat_end - endif - return - end -#endif -c------------------------------------------------------------------------------ - subroutine hpb_partition - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SBRIDGE' - include 'COMMON.IOUNITS' - include 'COMMON.SETUP' - include 'COMMON.CONTROL' -c write(2,*)"hpb_partition: nhpb=",nhpb -#ifdef MPI - call int_bounds(nhpb,link_start,link_end) - if (.not. out1file) - & write (iout,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',MyRank, - & ' nhpb',nhpb,' link_start=',link_start, - & ' link_end',link_end -#else - link_start=1 - link_end=nhpb -#endif -c write(2,*)"hpb_partition: link_start=",nhpb," link_end=",link_end - return - end diff --git a/source/unres/src_MD_DFA/int_to_cart.f b/source/unres/src_MD_DFA/int_to_cart.f deleted file mode 100644 index 73e8384..0000000 --- a/source/unres/src_MD_DFA/int_to_cart.f +++ /dev/null @@ -1,278 +0,0 @@ - subroutine int_to_cart -c-------------------------------------------------------------- -c This subroutine converts the energy derivatives from internal -c coordinates to cartesian coordinates -c------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.SCCOR' -c calculating dE/ddc1 - if (nres.lt.3) goto 18 -c do i=1,nres -c c do intertyp=1,3 -c write (iout,*) "przed tosyjnymi",i,intertyp,gcart(intertyp,i) -c &,gloc_sc(1,i,icg),gloc(i,icg) -c enddo -c enddo - do j=1,3 - gcart(j,1)=gcart(j,1)+gloc(1,icg)*dphi(j,1,4) - & +gloc(nres-2,icg)*dtheta(j,1,3) - if(itype(2).ne.10) then - gcart(j,1)=gcart(j,1)+gloc(ialph(2,1),icg)*dalpha(j,1,2)+ - & gloc(ialph(2,1)+nside,icg)*domega(j,1,2) - endif - enddo -c Calculating the remainder of dE/ddc2 - do j=1,3 - gcart(j,2)=gcart(j,2)+gloc(1,icg)*dphi(j,2,4)+ - & gloc(nres-2,icg)*dtheta(j,2,3)+gloc(nres-1,icg)*dtheta(j,1,4) - if(itype(2).ne.10) then - gcart(j,2)=gcart(j,2)+gloc(ialph(2,1),icg)*dalpha(j,2,2)+ - & gloc(ialph(2,1)+nside,icg)*domega(j,2,2) - endif - if(itype(3).ne.10) then - gcart(j,2)=gcart(j,2)+gloc(ialph(3,1),icg)*dalpha(j,1,3)+ - & gloc(ialph(3,1)+nside,icg)*domega(j,1,3) - endif - if(nres.gt.4) then - gcart(j,2)=gcart(j,2)+gloc(2,icg)*dphi(j,1,5) - endif - enddo -c If there are only five residues - if(nres.eq.5) then - do j=1,3 - gcart(j,3)=gcart(j,3)+gloc(1,icg)*dphi(j,3,4)+gloc(2,icg)* - & dphi(j,2,5)+gloc(nres-1,icg)*dtheta(j,2,4)+gloc(nres,icg)* - & dtheta(j,1,5) - if(itype(3).ne.10) then - gcart(j,3)=gcart(j,3)+gloc(ialph(3,1),icg)* - & dalpha(j,2,3)+gloc(ialph(3,1)+nside,icg)*domega(j,2,3) - endif - if(itype(4).ne.10) then - gcart(j,3)=gcart(j,3)+gloc(ialph(4,1),icg)* - & dalpha(j,1,4)+gloc(ialph(4,1)+nside,icg)*domega(j,1,4) - endif - enddo - endif -c If there are more than five residues - if(nres.gt.5) then - do i=3,nres-3 - do j=1,3 - gcart(j,i)=gcart(j,i)+gloc(i-2,icg)*dphi(j,3,i+1) - & +gloc(i-1,icg)*dphi(j,2,i+2)+ - & gloc(i,icg)*dphi(j,1,i+3)+gloc(nres+i-4,icg)*dtheta(j,2,i+1)+ - & gloc(nres+i-3,icg)*dtheta(j,1,i+2) - if(itype(i).ne.10) then - gcart(j,i)=gcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,2,i)+ - & gloc(ialph(i,1)+nside,icg)*domega(j,2,i) - endif - if(itype(i+1).ne.10) then - gcart(j,i)=gcart(j,i)+gloc(ialph(i+1,1),icg)*dalpha(j,1,i+1) - & +gloc(ialph(i+1,1)+nside,icg)*domega(j,1,i+1) - endif - enddo - enddo - endif -c Setting dE/ddnres-2 - if(nres.gt.5) then - do j=1,3 - gcart(j,nres-2)=gcart(j,nres-2)+gloc(nres-4,icg)* - & dphi(j,3,nres-1)+gloc(nres-3,icg)*dphi(j,2,nres) - & +gloc(2*nres-6,icg)* - & dtheta(j,2,nres-1)+gloc(2*nres-5,icg)*dtheta(j,1,nres) - if(itype(nres-2).ne.10) then - gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-2,1),icg)* - & dalpha(j,2,nres-2)+gloc(ialph(nres-2,1)+nside,icg)* - & domega(j,2,nres-2) - endif - if(itype(nres-1).ne.10) then - gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-1,1),icg)* - & dalpha(j,1,nres-1)+gloc(ialph(nres-1,1)+nside,icg)* - & domega(j,1,nres-1) - endif - enddo - endif -c Settind dE/ddnres-1 - do j=1,3 - gcart(j,nres-1)=gcart(j,nres-1)+gloc(nres-3,icg)*dphi(j,3,nres)+ - & gloc(2*nres-5,icg)*dtheta(j,2,nres) - if(itype(nres-1).ne.10) then - gcart(j,nres-1)=gcart(j,nres-1)+gloc(ialph(nres-1,1),icg)* - & dalpha(j,2,nres-1)+gloc(ialph(nres-1,1)+nside,icg)* - & domega(j,2,nres-1) - endif - enddo -c The side-chain vector derivatives - do i=2,nres-1 - if(itype(i).ne.10) then - do j=1,3 - gxcart(j,i)=gxcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,3,i) - & +gloc(ialph(i,1)+nside,icg)*domega(j,3,i) - enddo - endif - enddo -c---------------------------------------------------------------------- -C INTERTYP=1 SC...Ca...Ca...Ca -C INTERTYP=2 Ca...Ca...Ca...SC -C INTERTYP=3 SC...Ca...Ca...SC -c calculating dE/ddc1 - 18 continue -c do i=1,nres -c gloc(i,icg)=0.0D0 -c write (iout,*) "poczotkoawy",i,gloc_sc(1,i,icg) -c enddo - if (nres.lt.2) return - if ((nres.lt.3).and.(itype(1).eq.10)) return - if ((itype(1).ne.10).and.(itype(1).ne.21)) then - do j=1,3 -cc Derviative was calculated for oposite vector of side chain therefore -c there is "-" sign before gloc_sc - gxcart(j,1)=gxcart(j,1)-gloc_sc(1,0,icg)* - & dtauangle(j,1,1,3) - gcart(j,1)=gcart(j,1)+gloc_sc(1,0,icg)* - & dtauangle(j,1,2,3) - if ((itype(2).ne.10).and.(itype(2).ne.21)) then - gxcart(j,1)= gxcart(j,1) - & -gloc_sc(3,0,icg)*dtauangle(j,3,1,3) - gcart(j,1)=gcart(j,1)+gloc_sc(3,0,icg)* - & dtauangle(j,3,2,3) - endif - enddo - endif - if ((nres.ge.3).and.(itype(3).ne.10).and.(itype(3).ne.21)) - & then - do j=1,3 - gcart(j,1)=gcart(j,1)+gloc_sc(2,1,icg)*dtauangle(j,2,1,4) - enddo - endif -c As potetnial DO NOT depend on omicron anlge their derivative is -c ommited -c & +gloc_sc(intertyp,nres-2,icg)*dtheta(j,1,3) - -c Calculating the remainder of dE/ddc2 - do j=1,3 - if((itype(2).ne.10).and.(itype(2).ne.21)) then - if (itype(1).ne.10) gxcart(j,2)=gxcart(j,2)+ - & gloc_sc(3,0,icg)*dtauangle(j,3,3,3) - if ((itype(3).ne.10).and.(nres.ge.3).and.(itype(3).ne.21)) then - gxcart(j,2)=gxcart(j,2)-gloc_sc(3,1,icg)*dtauangle(j,3,1,4) -cc the - above is due to different vector direction - gcart(j,2)=gcart(j,2)+gloc_sc(3,1,icg)*dtauangle(j,3,2,4) - endif - if (nres.gt.3) then - gxcart(j,2)=gxcart(j,2)-gloc_sc(1,1,icg)*dtauangle(j,1,1,4) -cc the - above is due to different vector direction - gcart(j,2)=gcart(j,2)+gloc_sc(1,1,icg)*dtauangle(j,1,2,4) -c write(iout,*) gloc_sc(1,1,icg),dtauangle(j,1,2,4),"gcart" -c write(iout,*) gloc_sc(1,1,icg),dtauangle(j,1,1,4),"gx" - endif - endif - if ((itype(1).ne.10).and.(itype(1).ne.21)) then - gcart(j,2)=gcart(j,2)+gloc_sc(1,0,icg)*dtauangle(j,1,3,3) -c write(iout,*) gloc_sc(1,0,icg),dtauangle(j,1,3,3) - endif - if ((itype(3).ne.10).and.(nres.ge.3)) then - gcart(j,2)=gcart(j,2)+gloc_sc(2,1,icg)*dtauangle(j,2,2,4) -c write(iout,*) gloc_sc(2,1,icg),dtauangle(j,2,2,4) - endif - if ((itype(4).ne.10).and.(nres.ge.4)) then - gcart(j,2)=gcart(j,2)+gloc_sc(2,2,icg)*dtauangle(j,2,1,5) -c write(iout,*) gloc_sc(2,2,icg),dtauangle(j,2,1,5) - endif - -c write(iout,*) gcart(j,2),itype(2),itype(1),itype(3), "gcart2" - enddo -c If there are more than five residues - if(nres.ge.5) then - do i=3,nres-2 - do j=1,3 -c write(iout,*) "before", gcart(j,i) - if (itype(i).ne.10) then - gxcart(j,i)=gxcart(j,i)+gloc_sc(2,i-2,icg) - & *dtauangle(j,2,3,i+1) - & -gloc_sc(1,i-1,icg)*dtauangle(j,1,1,i+2) - gcart(j,i)=gcart(j,i)+gloc_sc(1,i-1,icg) - & *dtauangle(j,1,2,i+2) -c write(iout,*) "new",j,i, -c & gcart(j,i),gloc_sc(1,i-1,icg),dtauangle(j,1,2,i+2) - - if (itype(i-1).ne.10) then - gxcart(j,i)=gxcart(j,i)+gloc_sc(3,i-2,icg) - &*dtauangle(j,3,3,i+1) - endif - if (itype(i+1).ne.10) then - gxcart(j,i)=gxcart(j,i)-gloc_sc(3,i-1,icg) - &*dtauangle(j,3,1,i+2) - gcart(j,i)=gcart(j,i)+gloc_sc(3,i-1,icg) - &*dtauangle(j,3,2,i+2) - endif - endif - if (itype(i-1).ne.10) then - gcart(j,i)=gcart(j,i)+gloc_sc(1,i-2,icg)* - & dtauangle(j,1,3,i+1) - endif - if (itype(i+1).ne.10) then - gcart(j,i)=gcart(j,i)+gloc_sc(2,i-1,icg)* - & dtauangle(j,2,2,i+2) -c write(iout,*) "numer",i,gloc_sc(2,i-1,icg), -c & dtauangle(j,2,2,i+2) - endif - if (itype(i+2).ne.10) then - gcart(j,i)=gcart(j,i)+gloc_sc(2,i,icg)* - & dtauangle(j,2,1,i+3) - endif - enddo - enddo - endif -c Setting dE/ddnres-1 - if(nres.ge.4) then - do j=1,3 - if ((itype(nres-1).ne.10).and.(itype(nres-1).ne.21)) then - gxcart(j,nres-1)=gxcart(j,nres-1)+gloc_sc(2,nres-3,icg) - & *dtauangle(j,2,3,nres) -c write (iout,*) "gxcart(nres-1)", gloc_sc(2,nres-3,icg), -c & dtauangle(j,2,3,nres), gxcart(j,nres-1) - if (itype(nres-2).ne.10) then - gxcart(j,nres-1)=gxcart(j,nres-1)+gloc_sc(3,nres-3,icg) - & *dtauangle(j,3,3,nres) - endif - if ((itype(nres).ne.10).and.(itype(nres).ne.21)) then - gxcart(j,nres-1)=gxcart(j,nres-1)-gloc_sc(3,nres-2,icg) - & *dtauangle(j,3,1,nres+1) - gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(3,nres-2,icg) - & *dtauangle(j,3,2,nres+1) - endif - endif - if ((itype(nres-2).ne.10).and.(itype(nres-2).ne.21)) then - gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(1,nres-3,icg)* - & dtauangle(j,1,3,nres) - endif - if ((itype(nres).ne.10).and.(itype(nres).ne.21)) then - gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(2,nres-2,icg)* - & dtauangle(j,2,2,nres+1) -c write (iout,*) "gcart(nres-1)", gloc_sc(2,nres-2,icg), -c & dtauangle(j,2,2,nres+1), itype(nres-1),itype(nres) - endif - enddo - endif -c Settind dE/ddnres - if ((nres.ge.3).and.(itype(nres).ne.10))then - do j=1,3 - gxcart(j,nres)=gxcart(j,nres)+gloc_sc(3,nres-2,icg) - & *dtauangle(j,3,3,nres+1)+gloc_sc(2,nres-2,icg) - & *dtauangle(j,2,3,nres+1) - enddo - endif -c The side-chain vector derivatives - return - end - - diff --git a/source/unres/src_MD_DFA/intcartderiv.F b/source/unres/src_MD_DFA/intcartderiv.F deleted file mode 100644 index c220540..0000000 --- a/source/unres/src_MD_DFA/intcartderiv.F +++ /dev/null @@ -1,725 +0,0 @@ - subroutine intcartderiv - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.LOCAL' - include 'COMMON.SCCOR' - double precision dcostheta(3,2,maxres), - & dcosphi(3,3,maxres),dsinphi(3,3,maxres), - & dcosalpha(3,3,maxres),dcosomega(3,3,maxres), - & dsinomega(3,3,maxres),vo1(3),vo2(3),vo3(3), - & dummy(3),vp1(3),vp2(3),vp3(3),vpp1(3),n(3) - -#if defined(MPI) && defined(PARINTDER) - if (nfgtasks.gt.1 .and. me.eq.king) - & call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - pi4 = 0.5d0*pipol - pi34 = 3*pi4 - -c write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end -c Derivatives of theta's -#if defined(MPI) && defined(PARINTDER) -c We need dtheta(:,:,i-1) to compute dphi(:,:,i) - do i=max0(ithet_start-1,3),ithet_end -#else - do i=3,nres -#endif - cost=dcos(theta(i)) - sint=sqrt(1-cost*cost) - do j=1,3 - dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/ - & vbld(i-1) - dtheta(j,1,i)=-1/sint*dcostheta(j,1,i) - dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/ - & vbld(i) - dtheta(j,2,i)=-1/sint*dcostheta(j,2,i) - enddo - enddo - -#if defined(MPI) && defined(PARINTDER) -c We need dtheta(:,:,i-1) to compute dphi(:,:,i) - do i=max0(ithet_start-1,3),ithet_end -#else - do i=3,nres -#endif - if ((itype(i-1).ne.10).and.(itype(i-1).ne.21)) then - cost1=dcos(omicron(1,i)) - sint1=sqrt(1-cost1*cost1) - cost2=dcos(omicron(2,i)) - sint2=sqrt(1-cost2*cost2) - do j=1,3 -CC Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1) - dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ - & cost1*dc_norm(j,i-2))/ - & vbld(i-1) - domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i) - dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) - & +cost1*(dc_norm(j,i-1+nres)))/ - & vbld(i-1+nres) - domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i) -CC Calculate derivative over second omicron Sci-1,Cai-1 Cai -CC Looks messy but better than if in loop - dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) - & +cost2*dc_norm(j,i-1))/ - & vbld(i) - domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i) - dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) - & +cost2*(-dc_norm(j,i-1+nres)))/ - & vbld(i-1+nres) -c write(iout,*) "vbld", i,itype(i),vbld(i-1+nres) - domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i) - enddo - endif - enddo - - - -c Derivatives of phi: -c If phi is 0 or 180 degrees, then the formulas -c have to be derived by power series expansion of the -c conventional formulas around 0 and 180. -#ifdef PARINTDER - do i=iphi1_start,iphi1_end -#else - do i=4,nres -#endif -c the conventional case - sint=dsin(theta(i)) - sint1=dsin(theta(i-1)) - sing=dsin(phi(i)) - cost=dcos(theta(i)) - cost1=dcos(theta(i-1)) - cosg=dcos(phi(i)) - scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -c Obtaining the gamma derivatives from sine derivative - if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. - & phi(i).gt.pi34.and.phi(i).le.pi.or. - & phi(i).gt.-pi.and.phi(i).le.-pi34) then - call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) - & -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2) - dphi(j,1,i)=cosg_inv*dsinphi(j,1,i) - dsinphi(j,2,i)= - & -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) - & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) - dphi(j,2,i)=cosg_inv*dsinphi(j,2,i) -c Bug fixed 3/24/05 (AL) - dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) - & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) -c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dphi(j,3,i)=cosg_inv*dsinphi(j,3,i) - enddo -c Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* - & dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* - & dc_norm(j,i-3))/vbld(i-2) - dphi(j,1,i)=-1/sing*dcosphi(j,1,i) - dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* - & dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* - & dcostheta(j,1,i) - dphi(j,2,i)=-1/sing*dcosphi(j,2,i) - dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* - & dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* - & dc_norm(j,i-1))/vbld(i) - dphi(j,3,i)=-1/sing*dcosphi(j,3,i) - enddo - endif - enddo - -Calculate derivative of Tauangle -#ifdef PARINTDER - do i=itau_start,itau_end -#else - do i=3,nres -#endif - if ((itype(i-2).eq.21).or.(itype(i-2).eq.10)) cycle -cc dtauangle(j,intertyp,dervityp,residue number) -cc INTERTYP=1 SC...Ca...Ca..Ca -c the conventional case - sint=dsin(theta(i)) - sint1=dsin(omicron(2,i-1)) - sing=dsin(tauangle(1,i)) - cost=dcos(theta(i)) - cost1=dcos(omicron(2,i-1)) - cosg=dcos(tauangle(1,i)) - do j=1,3 - dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres) -cc write(iout,*) dc_norm2(j,i-2+nres),"dcnorm" - enddo - scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -cc write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4 -c Obtaining the gamma derivatives from sine derivative - if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. - & tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. - & tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then - call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) - call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2) - call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) - &-(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) - & *vbld_inv(i-2+nres) - dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i) - dsintau(j,1,2,i)= - & -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) - & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) -c write(iout,*) "dsintau", dsintau(j,1,2,i) - dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i) -c Bug fixed 3/24/05 (AL) - dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) - & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) -c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i) - enddo -c Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* - & dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* - & (dc_norm2(j,i-2+nres)))/vbld(i-2+nres) - dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i) - dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* - & dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* - & dcostheta(j,1,i) - dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i) - dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* - & dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* - & dc_norm(j,i-1))/vbld(i) - dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i) -c write (iout,*) "else",i - enddo - endif -c do k=1,3 -c write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3) -c enddo - enddo -CC Second case Ca...Ca...Ca...SC -#ifdef PARINTDER - do i=itau_start,itau_end -#else - do i=4,nres -#endif - if ((itype(i-1).eq.21).or.(itype(i-1).eq.10)) cycle -c the conventional case - sint=dsin(omicron(1,i)) - sint1=dsin(theta(i-1)) - sing=dsin(tauangle(2,i)) - cost=dcos(omicron(1,i)) - cost1=dcos(theta(i-1)) - cosg=dcos(tauangle(2,i)) -c do j=1,3 -c dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres) -c enddo - scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -c Obtaining the gamma derivatives from sine derivative - if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. - & tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. - & tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then - call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) - & +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2) -c write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1), -c &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)" - dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i) - dsintau(j,2,2,i)= - & -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) - & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) -c write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1), -c & sing*ctgt*domicron(j,1,2,i), -c & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) - dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i) -c Bug fixed 3/24/05 (AL) - dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) - & +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres) -c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i) - enddo -c Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* - & dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* - & dc_norm(j,i-3))/vbld(i-2) - dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i) - dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* - & dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* - & dcosomicron(j,1,1,i) - dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i) - dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* - & dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* - & dc_norm(j,i-1+nres))/vbld(i-1+nres) - dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i) -c write(iout,*) i,j,"else", dtauangle(j,2,3,i) - enddo - endif - enddo - - -CCC third case SC...Ca...Ca...SC -#ifdef PARINTDER - - do i=itau_start,itau_end -#else - do i=3,nres -#endif -c the conventional case - if ((itype(i-1).eq.21).or.(itype(i-1).eq.10).or. - &(itype(i-2).eq.21).or.(itype(i-2).eq.10)) cycle - sint=dsin(omicron(1,i)) - sint1=dsin(omicron(2,i-1)) - sing=dsin(tauangle(3,i)) - cost=dcos(omicron(1,i)) - cost1=dcos(omicron(2,i-1)) - cosg=dcos(tauangle(3,i)) - do j=1,3 - dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres) -c dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres) - enddo - scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -c Obtaining the gamma derivatives from sine derivative - if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. - & tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. - & tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then - call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1) - call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2) - call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) - & -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) - & *vbld_inv(i-2+nres) - dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i) - dsintau(j,3,2,i)= - & -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) - & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) - dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i) -c Bug fixed 3/24/05 (AL) - dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) - & +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) - & *vbld_inv(i-1+nres) -c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i) - enddo -c Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* - & dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* - & dc_norm2(j,i-2+nres))/vbld(i-2+nres) - dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i) - dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* - & dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* - & dcosomicron(j,1,1,i) - dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i) - dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* - & dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* - & dc_norm(j,i-1+nres))/vbld(i-1+nres) - dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i) -c write(iout,*) "else",i - enddo - endif - enddo -#ifdef CRYST_SC -c Derivatives of side-chain angles alpha and omega -#if defined(MPI) && defined(PARINTDER) - do i=ibond_start,ibond_end -#else - do i=2,nres-1 -#endif - if(itype(i).ne.10) then - fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1)))) - fac6=fac5/vbld(i) - fac7=fac5*fac5 - fac8=fac5/vbld(i+1) - fac9=fac5/vbld(i+nres) - scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) - scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres)) - cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))*( - & scalar(dC_norm(1,i),dC_norm(1,i+nres)) - & -scalar(dC_norm(1,i-1),dC_norm(1,i+nres))) - sina=sqrt(1-cosa*cosa) - sino=dsin(omeg(i)) - do j=1,3 - dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- - & dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1) - dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i) - dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- - & scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1) - dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i) - dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- - & dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ - & vbld(i+nres)) - dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i) - enddo -c obtaining the derivatives of omega from sines - if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. - & omeg(i).gt.pi34.and.omeg(i).le.pi.or. - & omeg(i).gt.-pi.and.omeg(i).le.-pi34) then - fac15=dcos(theta(i+1))/(dsin(theta(i+1))* - & dsin(theta(i+1))) - fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i))) - fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i))) - call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1) - call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2) - call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3) - coso_inv=1.0d0/dcos(omeg(i)) - do j=1,3 - dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) - & +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)-( - & sino*dc_norm(j,i-1))/vbld(i) - domega(j,1,i)=coso_inv*dsinomega(j,1,i) - dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) - & +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) - & -sino*dc_norm(j,i)/vbld(i+1) - domega(j,2,i)=coso_inv*dsinomega(j,2,i) - dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- - & fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ - & vbld(i+nres) - domega(j,3,i)=coso_inv*dsinomega(j,3,i) - enddo - else -c obtaining the derivatives of omega from cosines - fac10=sqrt(0.5d0*(1-dcos(theta(i+1)))) - fac11=sqrt(0.5d0*(1+dcos(theta(i+1)))) - fac12=fac10*sina - fac13=fac12*fac12 - fac14=sina*sina - do j=1,3 - dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* - & dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ - & (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* - & fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13 - domega(j,1,i)=-1/sino*dcosomega(j,1,i) - dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* - & dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* - & dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ - & (scala2-fac11*cosa)*(0.25d0*sina/fac10* - & dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i) - & ))/fac13 - domega(j,2,i)=-1/sino*dcosomega(j,2,i) - dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- - & scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ - & (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14 - domega(j,3,i)=-1/sino*dcosomega(j,3,i) - enddo - endif - endif - enddo -#endif -#if defined(MPI) && defined(PARINTDER) - if (nfgtasks.gt.1) then -#ifdef DEBUG - write (iout,*) "Gather dtheta" -cd call flush(iout) -c write (iout,*) "dtheta before gather" -c do i=1,nres -c write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2) -c enddo -#endif - call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank), - & MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET, - & king,FG_COMM,IERROR) -#ifdef DEBUG -cd write (iout,*) "Gather dphi" -cd call flush(iout) - write (iout,*) "dphi before gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3) - enddo -#endif - call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank), - & MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM, - & king,FG_COMM,IERROR) -cd write (iout,*) "Gather dalpha" -cd call flush(iout) -#ifdef CRYST_SC - call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank), - & MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM, - & king,FG_COMM,IERROR) -cd write (iout,*) "Gather domega" -cd call flush(iout) - call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank), - & MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM, - & king,FG_COMM,IERROR) -#endif - endif -#endif -#ifdef DEBUG - write (iout,*) "dtheta after gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),j=1,2) - enddo - write (iout,*) "dphi after gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3) - enddo -#endif - return - end - - subroutine checkintcartgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.SETUP' - double precision dthetanum(3,2,maxres),dphinum(3,3,maxres) - & ,dalphanum(3,3,maxres), domeganum(3,3,maxres) - double precision theta_s(maxres),phi_s(maxres),alph_s(maxres), - & omeg_s(maxres),dc_norm_s(3) - double precision aincr /1.0d-5/ - - do i=1,nres - phi_s(i)=phi(i) - theta_s(i)=theta(i) - alph_s(i)=alph(i) - omeg_s(i)=omeg(i) - enddo -c Check theta gradient - write (iout,*) - & "Analytical (upper) and numerical (lower) gradient of theta" - write (iout,*) - do i=3,nres - do j=1,3 - dcji=dc(j,i-2) - dc(j,i-2)=dcji+aincr - call chainbuild_cart - call int_from_cart1(.false.) - dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr - dc(j,i-2)=dcji - dcji=dc(j,i-1) - dc(j,i-1)=dc(j,i-1)+aincr - call chainbuild_cart - dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr - dc(j,i-1)=dcji - enddo - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3), - & (dtheta(j,2,i),j=1,3) - write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3), - & (dthetanum(j,2,i),j=1,3) - write (iout,'(5x,3f10.5,5x,3f10.5)') - & (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3), - & (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3) - write (iout,*) - enddo -c Check gamma gradient - write (iout,*) - & "Analytical (upper) and numerical (lower) gradient of gamma" - do i=4,nres - do j=1,3 - dcji=dc(j,i-3) - dc(j,i-3)=dcji+aincr - call chainbuild_cart - dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr - dc(j,i-3)=dcji - dcji=dc(j,i-2) - dc(j,i-2)=dcji+aincr - call chainbuild_cart - dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr - dc(j,i-2)=dcji - dcji=dc(j,i-1) - dc(j,i-1)=dc(j,i-1)+aincr - call chainbuild_cart - dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr - dc(j,i-1)=dcji - enddo - write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3), - & (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3), - & (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') - & (dphinum(j,1,i)/dphi(j,1,i),j=1,3), - & (dphinum(j,2,i)/dphi(j,2,i),j=1,3), - & (dphinum(j,3,i)/dphi(j,3,i),j=1,3) - write (iout,*) - enddo -c Check alpha gradient - write (iout,*) - & "Analytical (upper) and numerical (lower) gradient of alpha" - do i=2,nres-1 - if(itype(i).ne.10) then - do j=1,3 - dcji=dc(j,i-1) - dc(j,i-1)=dcji+aincr - call chainbuild_cart - dalphanum(j,1,i)=(alph(i)-alph_s(i)) - & /aincr - dc(j,i-1)=dcji - dcji=dc(j,i) - dc(j,i)=dcji+aincr - call chainbuild_cart - dalphanum(j,2,i)=(alph(i)-alph_s(i)) - & /aincr - dc(j,i)=dcji - dcji=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+aincr - call chainbuild_cart - dalphanum(j,3,i)=(alph(i)-alph_s(i)) - & /aincr - dc(j,i+nres)=dcji - enddo - endif - write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3), - & (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3), - & (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') - & (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3), - & (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3), - & (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3) - write (iout,*) - enddo -c Check omega gradient - write (iout,*) - & "Analytical (upper) and numerical (lower) gradient of omega" - do i=2,nres-1 - if(itype(i).ne.10) then - do j=1,3 - dcji=dc(j,i-1) - dc(j,i-1)=dcji+aincr - call chainbuild_cart - domeganum(j,1,i)=(omeg(i)-omeg_s(i)) - & /aincr - dc(j,i-1)=dcji - dcji=dc(j,i) - dc(j,i)=dcji+aincr - call chainbuild_cart - domeganum(j,2,i)=(omeg(i)-omeg_s(i)) - & /aincr - dc(j,i)=dcji - dcji=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+aincr - call chainbuild_cart - domeganum(j,3,i)=(omeg(i)-omeg_s(i)) - & /aincr - dc(j,i+nres)=dcji - enddo - endif - write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3), - & (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3), - & (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') - & (domeganum(j,1,i)/domega(j,1,i),j=1,3), - & (domeganum(j,2,i)/domega(j,2,i),j=1,3), - & (domeganum(j,3,i)/domega(j,3,i),j=1,3) - write (iout,*) - enddo - return - end - - subroutine chainbuild_cart - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.TIME1' - include 'COMMON.IOUNITS' - -#ifdef MPI - if (nfgtasks.gt.1) then -c write (iout,*) "BCAST in chainbuild_cart" -c call flush(iout) -c Broadcast the order to build the chain and compute internal coordinates -c to the slaves. The slaves receive the order in ERGASTULUM. - time00=MPI_Wtime() -c write (iout,*) "CHAINBUILD_CART: DC before BCAST" -c do i=0,nres -c write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), -c & (dc(j,i+nres),j=1,3) -c enddo - if (fg_rank.eq.0) - & call MPI_Bcast(7,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_bcast7=time_bcast7+MPI_Wtime()-time00 - time01=MPI_Wtime() - call MPI_Bcast(dc(1,0),6*(nres+1),MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "CHAINBUILD_CART: DC after BCAST" -c do i=0,nres -c write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), -c & (dc(j,i+nres),j=1,3) -c enddo -c write (iout,*) "End BCAST in chainbuild_cart" -c call flush(iout) - time_bcast=time_bcast+MPI_Wtime()-time00 - time_bcastc=time_bcastc+MPI_Wtime()-time01 - endif -#endif - do j=1,3 - c(j,1)=dc(j,0) - enddo - do i=2,nres - do j=1,3 - c(j,i)=c(j,i-1)+dc(j,i-1) - enddo - enddo - do i=1,nres - do j=1,3 - c(j,i+nres)=c(j,i)+dc(j,i+nres) - enddo - enddo -c write (iout,*) "CHAINBUILD_CART" -c call cartprint - call int_from_cart1(.false.) - return - end diff --git a/source/unres/src_MD_DFA/intcor.f b/source/unres/src_MD_DFA/intcor.f deleted file mode 100644 index a3cd5d0..0000000 --- a/source/unres/src_MD_DFA/intcor.f +++ /dev/null @@ -1,91 +0,0 @@ -C -C------------------------------------------------------------------------------ -C - double precision function alpha(i1,i2,i3) -c -c Calculates the planar angle between atoms (i1), (i2), and (i3). -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - x12=c(1,i1)-c(1,i2) - x23=c(1,i3)-c(1,i2) - y12=c(2,i1)-c(2,i2) - y23=c(2,i3)-c(2,i2) - z12=c(3,i1)-c(3,i2) - z23=c(3,i3)-c(3,i2) - vnorm=dsqrt(x12*x12+y12*y12+z12*z12) - wnorm=dsqrt(x23*x23+y23*y23+z23*z23) - scalar=(x12*x23+y12*y23+z12*z23)/(vnorm*wnorm) - alpha=arcos(scalar) - return - end -C -C------------------------------------------------------------------------------ -C - double precision function beta(i1,i2,i3,i4) -c -c Calculates the dihedral angle between atoms (i1), (i2), (i3) and (i4) -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - x12=c(1,i1)-c(1,i2) - x23=c(1,i3)-c(1,i2) - x34=c(1,i4)-c(1,i3) - y12=c(2,i1)-c(2,i2) - y23=c(2,i3)-c(2,i2) - y34=c(2,i4)-c(2,i3) - z12=c(3,i1)-c(3,i2) - z23=c(3,i3)-c(3,i2) - z34=c(3,i4)-c(3,i3) -cd print '(2i3,3f10.5)',i1,i2,x12,y12,z12 -cd print '(2i3,3f10.5)',i2,i3,x23,y23,z23 -cd print '(2i3,3f10.5)',i3,i4,x34,y34,z34 - wx=-y23*z34+y34*z23 - wy=x23*z34-z23*x34 - wz=-x23*y34+y23*x34 - wnorm=dsqrt(wx*wx+wy*wy+wz*wz) - vx=y12*z23-z12*y23 - vy=-x12*z23+z12*x23 - vz=x12*y23-y12*x23 - vnorm=dsqrt(vx*vx+vy*vy+vz*vz) - if (vnorm.gt.1.0D-13 .and. wnorm.gt.1.0D-13) then - scalar=(vx*wx+vy*wy+vz*wz)/(vnorm*wnorm) - if (dabs(scalar).gt.1.0D0) - &scalar=0.99999999999999D0*scalar/dabs(scalar) - angle=dacos(scalar) -cd print '(2i4,10f7.3)',i2,i3,vx,vy,vz,wx,wy,wz,vnorm,wnorm, -cd &scalar,angle - else - angle=pi - endif -c if (angle.le.0.0D0) angle=pi+angle - tx=vy*wz-vz*wy - ty=-vx*wz+vz*wx - tz=vx*wy-vy*wx - scalar=tx*x23+ty*y23+tz*z23 - if (scalar.lt.0.0D0) angle=-angle - beta=angle - return - end -C -C------------------------------------------------------------------------------ -C - function dist(i1,i2) -c -c Calculates the distance between atoms (i1) and (i2). -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - x12=c(1,i1)-c(1,i2) - y12=c(2,i1)-c(2,i2) - z12=c(3,i1)-c(3,i2) - dist=dsqrt(x12*x12+y12*y12+z12*z12) - return - end -C diff --git a/source/unres/src_MD_DFA/intlocal.f b/source/unres/src_MD_DFA/intlocal.f deleted file mode 100644 index 2dbcc88..0000000 --- a/source/unres/src_MD_DFA/intlocal.f +++ /dev/null @@ -1,517 +0,0 @@ - subroutine integral(gamma1,gamma2,gamma3,gamma4,ity1,ity2,a1,a2, - & si1,si2,si3,si4,transp,q) - implicit none - integer ity1,ity2 - integer ilam1,ilam2,ilam3,ilam4,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4 - logical transp - double precision elocal,ele - double precision delta,delta2,sum,ene,sumene,boltz - double precision q,a1(2,2),a2(2,2),si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=20 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) gamma1,gamma2,ity1,ity2,a1,a2,si1,si2,si3,si4,transp - -cd do ilam1=-180,180,5 -cd do ilam2=-180,180,5 -cd lambda1=ilam1*conv+delta2 -cd lambda2=ilam2*conv+delta2 -cd write(2,'(2i5,2f10.5)') ilam1,ilam2,elocal(2,lambda1,lambda2), -cd & ele(lambda1,lambda2,a1,1.0d0,1.d00) -cd enddo -cd enddo -cd stop - - sum=0.0d0 - sumene=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 -cd write (2,*) ilam1,ilam2,ilam3,ilam4 -cd write (2,*) lambda1,lambda2,lambda3,lambda4 - ene= - & -elocal(ity1,lambda1,lambda2,.false.)* - & elocal(ity2,lambda3,lambda4,transp)* - & ele(si1*lambda1+gamma1,si3*lambda3+gamma3,a1)* - & ele(si2*lambda2+gamma2,si4*lambda4+gamma4,a2) -cd write (2,*) elocal(ity1,lambda1,gamma1-pi-lambda2), -cd & elocal(ity2,lambda3,gamma2-pi-lambda4), -cd & ele(lambda1,lambda2,a1,si1,si3), -cd & ele(lambda3,lambda4,a2,si2,si4) - sum=sum+ene - enddo - enddo - enddo - enddo - q=sum/(2*pi)**4*delta**4 - write (2,* )'sum',sum,' q',q - return - end -c--------------------------------------------------------------------------- - subroutine integral3(gamma1,gamma2,ity1,ity2,ity3,ity4, - & a1,koniec,q1,q2,q3,q4) - implicit none - integer ity1,ity2,ity3,ity4 - integer ilam1,ilam2,ilam3,ilam4,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,lambda1, - & lambda2,lambda3,lambda4 - logical koniec - double precision elocal,ele - double precision delta,delta2,sum1,sum2,sum3,sum4, - & ene1,ene2,ene3,ene4,boltz - double precision q1,q2,q3,q4,a1(2,2),a2(2,2) - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta - write(2,*) gamma1,gamma2,ity1,ity2,ity3,ity4,a1,koniec - -cd do ilam1=-180,180,5 -cd do ilam2=-180,180,5 -cd lambda1=ilam1*conv+delta2 -cd lambda2=ilam2*conv+delta2 -cd write(2,'(2i5,2f10.5)') ilam1,ilam2,elocal(2,lambda1,lambda2), -cd & ele(lambda1,lambda2,a1,1.0d0,1.d00) -cd enddo -cd enddo -cd stop - - sum1=0.0d0 - sum2=0.0d0 - sum3=0.0d0 - sum4=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 -cd write (2,*) ilam1,ilam2,ilam3,ilam4 -cd write (2,*) lambda1,lambda2,lambda3,lambda4 - if (.not.koniec) then - ene1= - & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)* - & elocal(ity3,lambda3,gamma2-pi-lambda4,.false.)* - & ele(lambda2,lambda4,a1) - else - ene1= - & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)* - & elocal(ity3,lambda3,lambda4,.false.)* - & ele(lambda2,-lambda4,a1) - endif - ene2= - & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)* - & elocal(ity4,lambda3,lambda4,.false.)* - & ele(lambda2,lambda3,a1) - if (.not.koniec) then - ene3= - & elocal(ity2,lambda1,lambda2,.false.)* - & elocal(ity3,lambda3,gamma2-pi-lambda4,.false.)* - & ele(lambda1,lambda4,a1) - else - ene3= - & elocal(ity2,lambda1,lambda2,.false.)* - & elocal(ity3,lambda3,lambda4,.false.)* - & ele(lambda1,-lambda4,a1) - endif - ene4= - & elocal(ity2,lambda1,lambda2,.false.)* - & elocal(ity4,lambda3,lambda4,.false.)* - & ele(lambda1,lambda3,a1) - sum1=sum1+ene1 - sum2=sum2+ene2 - sum3=sum3+ene3 - sum4=sum4+ene4 - enddo - enddo - enddo - enddo - q1=sum1/(2*pi)**4*delta**4 - q2=sum2/(2*pi)**4*delta**4 - q3=sum3/(2*pi)**4*delta**4 - q4=sum4/(2*pi)**4*delta**4 - write (2,* )'sum',sum1,sum2,sum3,sum4,' q',q1,q2,q3,q4 - return - end -c------------------------------------------------------------------------- - subroutine integral5(gamma1,gamma2,gamma3,gamma4,ity1,ity2,ity3, - & ity4,ity5,ity6,a1,a2,si1,si2,si3,si4,transp,ene1,ene2,ene3,ene4) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc5,eloc6,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,sum1,sum2,sum3,sum4, - & a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, -cd & ' gamma3=',gamma3,' gamma4=',gamma4 -cd write(2,*) ity1,ity2,ity3,ity4,ity5,ity6 -cd write(2,*) 'a1=',a1 -cd write(2,*) 'a2=',a2 -cd write(2,*) si1,si2,si3,si4,transp - - sum1=0.0d0 - sum2=0.0d0 - sum3=0.0d0 - sum4=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - do ilam5=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - lambda5=ilam5*conv+delta2 - if (transp) then - ele1=ele(lambda1,si4*lambda4,a1) - ele2=ele(lambda2,lambda3,a2) - else - ele1=ele(lambda1,lambda3,a1) - ele2=ele(lambda2,si4*lambda4,a2) - endif - eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.) - eloc5=elocal(ity5,lambda3,gamma4-pi-si4*lambda4,.false.) - pom=ele1*ele2*eloc2*eloc5 - if (si1.gt.0) then - eloc1=elocal(ity1,lambda5,gamma1-pi-lambda1,.false.) - sum1=sum1+pom*eloc1 - endif - eloc3=elocal(ity3,lambda2,lambda5,.false.) - sum2=sum2+pom*eloc3 - eloc4=elocal(ity4,lambda5,gamma3-pi-lambda3,.false.) - sum3=sum3+pom*eloc4 - if (si4.gt.0) then - eloc6=elocal(ity6,lambda4,lambda5,.false.) - sum4=sum4+pom*eloc6 - endif - enddo - enddo - enddo - enddo - enddo - pom=1.0d0/(2*pi)**5*delta**5 - ene1=sum1*pom - ene2=sum2*pom - ene3=sum3*pom - ene4=sum4*pom -c write (2,* )'sum',sum1,sum2,sum3,sum4,' q',ene1,ene2,ene3,ene4 - return - end -c------------------------------------------------------------------------- - subroutine integral_turn6(gamma1,gamma2,gamma3,gamma4,ity1,ity2, - & ity3,ity4,ity5,ity6,a1,a2,ene_turn6) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom,ene5 - double precision ene_turn6,sum5,a1(2,2),a2(2,2) - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta - write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, - & ' gamma3=',gamma3,' gamma4=',gamma4 - write(2,*) ity1,ity2,ity3,ity4,ity5,ity6 - write(2,*) 'a1=',a1 - write(2,*) 'a2=',a2 - - sum5=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - do ilam5=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - lambda5=ilam5*conv+delta2 - ele1=ele(lambda1,-lambda4,a1) - ele2=ele(lambda2,lambda3,a2) - eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.) - eloc5=elocal(ity5,lambda3,lambda4,.false.) - pom=ele1*ele2*eloc2*eloc5 - eloc3=elocal(ity3,lambda2,gamma3-pi-lambda5,.false.) - eloc4=elocal(ity4,lambda5,gamma4-pi-lambda3,.false.) - sum5=sum5+pom*eloc3*eloc4 - enddo - enddo - enddo - enddo - enddo - pom=-1.0d0/(2*pi)**5*delta**5 - ene_turn6=sum5*pom -c print *,'sum6',sum6,' ene6',ene6 - return - end -c------------------------------------------------------------------------- - subroutine integral6(gamma1,gamma2,gamma3,gamma4,ity1,ity2,ity3, - & ity4,ity5,ity6,a1,a2,si1,si2,si3,si4,transp,ene1,ene2,ene3,ene4, - & ene5,ene6) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3, - & sum4,sum5,sum6,a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, -cd & ' gamma3=',gamma3,' gamma4=',gamma4 -cd write(2,*) ity1,ity2,ity3,ity4,ity5,ity6 -cd write(2,*) 'a1=',a1 -cd write(2,*) 'a2=',a2 -cd write(2,*) si1,si2,si3,si4,transp - - sum1=0.0d0 - sum2=0.0d0 - sum3=0.0d0 - sum4=0.0d0 - sum5=0.0d0 - sum6=0.0d0 - eloc1=0.0d0 - eloc6=0.0d0 - eloc61=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - do ilam5=-180,179,iincr - do ilam6=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - lambda5=ilam5*conv+delta2 - lambda6=ilam6*conv+delta2 - if (transp) then - ele1=ele(lambda1,si4*lambda4,a1) - ele2=ele(lambda2,lambda3,a2) - else - ele1=ele(lambda1,lambda3,a1) - ele2=ele(lambda2,si4*lambda4,a2) - endif - eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.) - eloc5=elocal(ity5,lambda3,gamma4-pi-si4*lambda4,.false.) - pom=ele1*ele2*eloc2*eloc5 - if (si1.gt.0) then - eloc1=elocal(ity1,lambda5,gamma1-pi-lambda1,.false.) - endif - eloc3=elocal(ity3,lambda2,lambda6,.false.) - sum1=sum1+pom*eloc1*eloc3 - eloc4=elocal(ity4,lambda5,gamma3-pi-lambda3,.false.) - if (si4.gt.0) then - eloc6=elocal(ity6,lambda4,lambda6,.false.) - eloc61=elocal(ity6,lambda4,lambda5,.false.) - endif - sum2=sum2+pom*eloc4*eloc6 - eloc41=elocal(ity4,lambda6,gamma3-pi-lambda3,.false.) - sum3=sum3+pom*eloc1*eloc41 - sum4=sum4+pom*eloc1*eloc6 - sum5=sum5+pom*eloc3*eloc4 - sum6=sum6+pom*eloc3*eloc61 - enddo - enddo - enddo - enddo - enddo - enddo - pom=-1.0d0/(2*pi)**6*delta**6 - ene1=sum1*pom - ene2=sum2*pom - ene3=sum3*pom - ene4=sum4*pom - ene5=sum5*pom - ene6=sum6*pom -c print *,'sum6',sum6,' ene6',ene6 - return - end -c------------------------------------------------------------------------- - subroutine integral3a(gamma1,gamma2,ity1,ity2,a1,si1,ene1) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3, - & sum4,sum5,sum6,a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2 -cd write(2,*) ity1,ity2 -cd write(2,*) 'a1=',a1 -cd write(2,*) si1, - - sum1=0.0d0 - eloc1=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - ele1=ele(lambda1,si1*lambda3,a1) - eloc1=elocal(ity1,lambda1,gamma1-pi-lambda2,.false.) - if (si1.gt.0) then - eloc2=elocal(ity2,lambda2,gamma2-pi-lambda3,.false.) - else - eloc2=elocal(ity2,lambda2,lambda3,.false.) - endif - sum1=sum1+ele1*eloc1*eloc2 - enddo - enddo - enddo - pom=1.0d0/(2*pi)**3*delta**3 - ene1=sum1*pom - return - end -c------------------------------------------------------------------------- - subroutine integral4a(gamma1,gamma2,gamma3,ity1,ity2,ity3,a1,si1, - & ene1) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3, - & sum4,sum5,sum6,a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, -cd & ' gamma3=',gamma3 -cd write(2,*) ity1,ity2,ity3 -cd write(2,*) 'a1=',a1 -cd write(2,*) 'si1=',si1 - sum1=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - ele1=ele(lambda1,si1*lambda4,a1) - eloc1=elocal(ity1,lambda1,gamma1-pi-lambda2,.false.) - eloc2=elocal(ity2,lambda2,gamma2-pi-lambda3,.false.) - if (si1.gt.0) then - eloc3=elocal(ity3,lambda3,gamma3-pi-lambda4,.false.) - else - eloc3=elocal(ity3,lambda3,lambda4,.false.) - endif - sum1=sum1+ele1*eloc1*eloc2*eloc3 - enddo - enddo - enddo - enddo - pom=-1.0d0/(2*pi)**4*delta**4 - ene1=sum1*pom - return - end -c------------------------------------------------------------------------- - double precision function elocal(i,x,y,transp) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.TORSION' - integer i - double precision x,y,u(2),v(2),cu(2),dv(2),ev(2) - double precision scalar2 - logical transp - u(1)=dcos(x) - u(2)=dsin(x) - v(1)=dcos(y) - v(2)=dsin(y) - if (transp) then - call matvec2(cc(1,1,i),v,cu) - call matvec2(dd(1,1,i),u,dv) - call matvec2(ee(1,1,i),u,ev) - elocal=scalar2(b1(1,i),v)+scalar2(b2(1,i),u)+scalar2(cu,v)+ - & scalar2(dv,u)+scalar2(ev,v) - else - call matvec2(cc(1,1,i),u,cu) - call matvec2(dd(1,1,i),v,dv) - call matvec2(ee(1,1,i),v,ev) - elocal=scalar2(b1(1,i),u)+scalar2(b2(1,i),v)+scalar2(cu,u)+ - & scalar2(dv,v)+scalar2(ev,u) - endif - return - end -c------------------------------------------------------------------------- - double precision function ele(x,y,a) - implicit none - double precision x,y,a(2,2),si1,si2,u(2),v(2),av(2) - double precision scalar2 - u(1)=-cos(x) - u(2)= sin(x) - v(1)=-cos(y) - v(2)= sin(y) - call matvec2(a,v,av) - ele=scalar2(u,av) - return - end diff --git a/source/unres/src_MD_DFA/kinetic_lesyng.f b/source/unres/src_MD_DFA/kinetic_lesyng.f deleted file mode 100644 index 8535f5d..0000000 --- a/source/unres/src_MD_DFA/kinetic_lesyng.f +++ /dev/null @@ -1,104 +0,0 @@ - subroutine kinetic(KE_total) -c---------------------------------------------------------------- -c This subroutine calculates the total kinetic energy of the chain -c----------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - double precision KE_total - - integer i,j,k - double precision KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3), - & mag1,mag2,v(3) - - KEt_p=0.0d0 - KEt_sc=0.0d0 -c write (iout,*) "ISC",(isc(itype(i)),i=1,nres) -c The translational part for peptide virtual bonds - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct-1 -c write (iout,*) "Kinetic trp:",i,(incr(j),j=1,3) - do j=1,3 - v(j)=incr(j)+0.5d0*d_t(j,i) - enddo - vtot(i)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) - KEt_p=KEt_p+(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - enddo -c write(iout,*) 'KEt_p', KEt_p -c The translational part for the side chain virtual bond -c Only now we can initialize incr with zeros. It must be equal -c to the velocities of the first Calpha. - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct - iti=itype(i) - if (itype(i).eq.10) then - do j=1,3 - v(j)=incr(j) - enddo - else - do j=1,3 - v(j)=incr(j)+d_t(j,nres+i) - enddo - endif -c write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3) -c write (iout,*) "i",i," msc",msc(iti)," v",(v(j),j=1,3) - KEt_sc=KEt_sc+msc(iti)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) - vtot(i+nres)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - enddo -c goto 111 -c write(iout,*) 'KEt_sc', KEt_sc -c The part due to stretching and rotation of the peptide groups - KEr_p=0.0D0 - do i=nnt,nct-1 -c write (iout,*) "i",i -c write (iout,*) "i",i," mag1",mag1," mag2",mag2 - do j=1,3 - incr(j)=d_t(j,i) - enddo -c write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3) - KEr_p=KEr_p+(incr(1)*incr(1)+incr(2)*incr(2) - & +incr(3)*incr(3)) - enddo -c goto 111 -c write(iout,*) 'KEr_p', KEr_p -c The rotational part of the side chain virtual bond - KEr_sc=0.0D0 - do i=nnt,nct - iti=itype(i) - if (itype(i).ne.10) then - do j=1,3 - incr(j)=d_t(j,nres+i) - enddo -c write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3) - KEr_sc=KEr_sc+Isc(iti)*(incr(1)*incr(1)+incr(2)*incr(2)+ - & incr(3)*incr(3)) - endif - enddo -c The total kinetic energy - 111 continue -c write(iout,*) 'KEr_sc', KEr_sc - KE_total=0.5d0*(mp*KEt_p+KEt_sc+0.25d0*Ip*KEr_p+KEr_sc) -c write (iout,*) "KE_total",KE_total - return - end - - - - diff --git a/source/unres/src_MD_DFA/lagrangian_lesyng.F b/source/unres/src_MD_DFA/lagrangian_lesyng.F deleted file mode 100644 index 8a9163a..0000000 --- a/source/unres/src_MD_DFA/lagrangian_lesyng.F +++ /dev/null @@ -1,726 +0,0 @@ - subroutine lagrangian -c------------------------------------------------------------------------- -c This subroutine contains the total lagrangain from which the accelerations -c are obtained. For numerical gradient checking, the derivetive of the -c lagrangian in the velocities and coordinates are calculated seperately -c------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'COMMON.MUCA' - include 'COMMON.TIME1' - - integer i,j,ind - double precision zapas(MAXRES6),muca_factor - logical lprn /.false./ - common /cipiszcze/ itime - -#ifdef TIMING - time00=MPI_Wtime() -#endif - do j=1,3 - zapas(j)=-gcart(j,0) - enddo - ind=3 - if (lprn) then - write (iout,*) "Potential forces backbone" - endif - do i=nnt,nct-1 - if (lprn) write (iout,'(i5,3e15.5,5x,3e15.5)') - & i,(-gcart(j,i),j=1,3) - do j=1,3 - ind=ind+1 - zapas(ind)=-gcart(j,i) - enddo - enddo - if (lprn) write (iout,*) "Potential forces sidechain" - do i=nnt,nct - if (itype(i).ne.10) then - if (lprn) write (iout,'(i5,3e15.5,5x,3e15.5)') - & i,(-gcart(j,i),j=1,3) - do j=1,3 - ind=ind+1 - zapas(ind)=-gxcart(j,i) - enddo - endif - enddo - - call ginv_mult(zapas,d_a_work) - - do j=1,3 - d_a(j,0)=d_a_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - ind=ind+1 - d_a(j,i)=d_a_work(ind) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - ind=ind+1 - d_a(j,i+nres)=d_a_work(ind) - enddo - endif - enddo - - if(lmuca) then - imtime=imtime+1 - if(mucadyn.gt.0) call muca_update(potE) - factor=muca_factor(potE)*t_bath*Rb - -cd print *,'lmuca ',factor,potE - do j=1,3 - d_a(j,0)=d_a(j,0)*factor - enddo - do i=nnt,nct-1 - do j=1,3 - d_a(j,i)=d_a(j,i)*factor - enddo - enddo - do i=nnt,nct - do j=1,3 - d_a(j,i+nres)=d_a(j,i+nres)*factor - enddo - enddo - - endif - - if (lprn) then - write(iout,*) 'acceleration 3D' - write (iout,'(i3,3f10.5,3x,3f10.5)') 0,(d_a(j,0),j=1,3) - do i=nnt,nct-1 - write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3) - enddo - do i=nnt,nct - write (iout,'(i3,3f10.5,3x,3f10.5)') - & i+nres,(d_a(j,i+nres),j=1,3) - enddo - endif -#ifdef TIMING - time_lagrangian=time_lagrangian+MPI_Wtime()-time00 -#endif - return - end -c------------------------------------------------------------------ - subroutine setup_MD_matrices - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer ierror -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - integer i,j - logical lprn /.false./ - logical osob - double precision dtdi,massvec(maxres2),Gcopy(maxres2,maxres2), - & Ghalf(mmaxres2),sqreig(maxres2), invsqreig(maxres2), Gcopytmp, - & Gsqrptmp, Gsqrmtmp, Gvec2tmp,Gvectmp(maxres2,maxres2) - double precision work(8*maxres6) - integer iwork(maxres6) - common /przechowalnia/ Gcopy,Ghalf,invsqreig,Gvectmp -c -c Set up the matrix of the (dC,dX)-->(C,X) transformation (A), the -c inertia matrix (Gmat) and the inverse of the inertia matrix (Ginv) -c -c Determine the number of degrees of freedom (dimen) and the number of -c sites (dimen1) - dimen=(nct-nnt+1)+nside - dimen1=(nct-nnt)+(nct-nnt+1) - dimen3=dimen*3 -#ifdef MPI - if (nfgtasks.gt.1) then - time00=MPI_Wtime() - call MPI_Bcast(5,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 - call int_bounds(dimen,igmult_start,igmult_end) - igmult_start=igmult_start-1 - call MPI_Allgather(3*igmult_start,1,MPI_INTEGER, - & ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - my_ng_count=igmult_end-igmult_start - call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - write (iout,*) 'Processor:',fg_rank,' CG group',kolor, - & ' absolute rank',myrank,' igmult_start',igmult_start, - & ' igmult_end',igmult_end,' count',my_ng_count - write (iout,*) "ng_start",(ng_start(i),i=0,nfgtasks-1) - write (iout,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1) - call flush(iout) - else -#endif - igmult_start=1 - igmult_end=dimen - my_ng_count=dimen -#ifdef MPI - endif -#endif -c write (iout,*) "dimen",dimen," dimen1",dimen1," dimen3",dimen3 -c Zeroing out A and fricmat - do i=1,dimen - do j=1,dimen - A(i,j)=0.0D0 - enddo - enddo -c Diagonal elements of the dC part of A and the respective friction coefficients - ind=1 - ind1=0 - do i=nnt,nct-1 - ind=ind+1 - ind1=ind1+1 - coeff=0.25d0*IP - massvec(ind1)=mp - Gmat(ind,ind)=coeff - A(ind1,ind)=0.5d0 - enddo - -c Off-diagonal elements of the dC part of A - k=3 - do i=1,nct-nnt - do j=1,i - A(i,j)=1.0d0 - enddo - enddo -c Diagonal elements of the dX part of A and the respective friction coefficients - m=nct-nnt - m1=nct-nnt+1 - ind=0 - ind1=0 - do i=nnt,nct - ind=ind+1 - ii = ind+m - iti=itype(i) - massvec(ii)=msc(iti) - if (iti.ne.10) then - ind1=ind1+1 - ii1= ind1+m1 - A(ii,ii1)=1.0d0 - Gmat(ii1,ii1)=ISC(iti) - endif - enddo -c Off-diagonal elements of the dX part of A - ind=0 - k=nct-nnt - do i=nnt,nct - iti=itype(i) - ind=ind+1 - do j=nnt,i - ii = ind - jj = j-nnt+1 - A(k+ii,jj)=1.0d0 - enddo - enddo - if (lprn) then - write (iout,*) - write (iout,*) "Vector massvec" - do i=1,dimen1 - write (iout,*) i,massvec(i) - enddo - write (iout,'(//a)') "A" - call matout(dimen,dimen1,maxres2,maxres2,A) - endif - -c Calculate the G matrix (store in Gmat) - do k=1,dimen - do i=1,dimen - dtdi=0.0d0 - do j=1,dimen1 - dtdi=dtdi+A(j,k)*A(j,i)*massvec(j) - enddo - Gmat(k,i)=Gmat(k,i)+dtdi - enddo - enddo - - if (lprn) then - write (iout,'(//a)') "Gmat" - call matout(dimen,dimen,maxres2,maxres2,Gmat) - endif - do i=1,dimen - do j=1,dimen - Ginv(i,j)=0.0d0 - Gcopy(i,j)=Gmat(i,j) - enddo - Ginv(i,i)=1.0d0 - enddo -c Invert the G matrix - call MATINVERT(dimen,maxres2,Gcopy,Ginv,osob) - if (lprn) then - write (iout,'(//a)') "Ginv" - call matout(dimen,dimen,maxres2,maxres2,Ginv) - endif -#ifdef MPI - if (nfgtasks.gt.1) then - myginv_ng_count=maxres2*my_ng_count - call MPI_Allgather(maxres2*igmult_start,1,MPI_INTEGER, - & nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER, - & nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR) - if (lprn .and. (me.eq.king .or. .not. out1file) ) then - write (iout,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1) - write (iout,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1) - call flush(iout) - endif -c call MPI_Scatterv(ginv(1,1),nginv_counts(0), -c & nginv_start(0),MPI_DOUBLE_PRECISION,ginv, -c & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -c call MPI_Barrier(FG_COMM,IERR) - time00=MPI_Wtime() - call MPI_Scatterv(ginv(1,1),nginv_counts(0), - & nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1), - & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -#ifdef TIMING - time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00 -#endif - do i=1,dimen - do j=1,2*my_ng_count - ginv(j,i)=gcopy(i,j) - enddo - enddo -c write (iout,*) "Master's chunk of ginv" -c call MATOUT2(my_ng_count,dimen,maxres2,maxres2,ginv) - endif -#endif - if (osob) then - write (iout,*) "The G matrix is singular." - stop - endif -c Compute G**(-1/2) and G**(1/2) - ind=0 - do i=1,dimen - do j=1,i - ind=ind+1 - Ghalf(ind)=Gmat(i,j) - enddo - enddo - call gldiag(maxres2,dimen,dimen,Ghalf,work,Geigen,Gvec, - & ierr,iwork) - if (lprn) then - write (iout,'(//a)') - & "Eigenvectors and eigenvalues of the G matrix" - call eigout(dimen,dimen,maxres2,maxres2,Gvec,Geigen) - endif - - do i=1,dimen - sqreig(i)=dsqrt(Geigen(i)) - invsqreig(i)=1.d0/sqreig(i) - enddo - do i=1,dimen - do j=1,dimen - Gvectmp(i,j)=Gvec(j,i) - enddo - enddo - - do i=1,dimen - do j=1,dimen - Gsqrptmp=0.0d0 - Gsqrmtmp=0.0d0 - Gcopytmp=0.0d0 - do k=1,dimen -c Gvec2tmp=Gvec(i,k)*Gvec(j,k) - Gvec2tmp=Gvec(k,i)*Gvec(k,j) - Gsqrptmp=Gsqrptmp+Gvec2tmp*sqreig(k) - Gsqrmtmp=Gsqrmtmp+Gvec2tmp*invsqreig(k) - Gcopytmp=Gcopytmp+Gvec2tmp*Geigen(k) - enddo - Gsqrp(i,j)=Gsqrptmp - Gsqrm(i,j)=Gsqrmtmp - Gcopy(i,j)=Gcopytmp - enddo - enddo - - do i=1,dimen - do j=1,dimen - Gvec(i,j)=Gvectmp(j,i) - enddo - enddo - - if (lprn) then - write (iout,*) "Comparison of original and restored G" - do i=1,dimen - do j=1,dimen - write (iout,'(2i5,5f10.5)') i,j,Gmat(i,j),Gcopy(i,j), - & Gmat(i,j)-Gcopy(i,j),Gsqrp(i,j),Gsqrm(i,j) - enddo - enddo - endif - return - end -c------------------------------------------------------------------------------- - SUBROUTINE EIGOUT(NC,NR,LM2,LM3,A,B) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - double precision A(LM2,LM3),B(LM2) - KA=1 - KC=6 - 1 KB=MIN0(KC,NC) - WRITE(IOUT,600) (I,I=KA,KB) - WRITE(IOUT,601) (B(I),I=KA,KB) - WRITE(IOUT,602) - 2 N=0 - DO 3 I=1,NR - WRITE(IOUT,603) I,(A(I,J),J=KA,KB) - N=N+1 - IF(N.LT.10) GO TO 3 - WRITE(IOUT,602) - N=0 - 3 CONTINUE - 4 IF (KB.EQ.NC) RETURN - KA=KC+1 - KC=KC+6 - GO TO 1 - 600 FORMAT (// 9H ROOT NO.,I4,9I11) - 601 FORMAT (/5X,10(1PE11.4)) - 602 FORMAT (2H ) - 603 FORMAT (I5,10F11.5) - 604 FORMAT (1H1) - END -c------------------------------------------------------------------------------- - SUBROUTINE MATOUT(NC,NR,LM2,LM3,A) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - double precision A(LM2,LM3) - KA=1 - KC=6 - 1 KB=MIN0(KC,NC) - WRITE(IOUT,600) (I,I=KA,KB) - WRITE(IOUT,602) - 2 N=0 - DO 3 I=1,NR - WRITE(IOUT,603) I,(A(I,J),J=KA,KB) - N=N+1 - IF(N.LT.10) GO TO 3 - WRITE(IOUT,602) - N=0 - 3 CONTINUE - 4 IF (KB.EQ.NC) RETURN - KA=KC+1 - KC=KC+6 - GO TO 1 - 600 FORMAT (//5x,9I11) - 602 FORMAT (2H ) - 603 FORMAT (I5,10F11.3) - 604 FORMAT (1H1) - END -c------------------------------------------------------------------------------- - SUBROUTINE MATOUT1(NC,NR,LM2,LM3,A) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - double precision A(LM2,LM3) - KA=1 - KC=21 - 1 KB=MIN0(KC,NC) - WRITE(IOUT,600) (I,I=KA,KB) - WRITE(IOUT,602) - 2 N=0 - DO 3 I=1,NR - WRITE(IOUT,603) I,(A(I,J),J=KA,KB) - N=N+1 - IF(N.LT.3) GO TO 3 - WRITE(IOUT,602) - N=0 - 3 CONTINUE - 4 IF (KB.EQ.NC) RETURN - KA=KC+1 - KC=KC+21 - GO TO 1 - 600 FORMAT (//5x,7(3I5,2x)) - 602 FORMAT (2H ) - 603 FORMAT (I5,7(3F5.1,2x)) - 604 FORMAT (1H1) - END -c------------------------------------------------------------------------------- - SUBROUTINE MATOUT2(NC,NR,LM2,LM3,A) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - double precision A(LM2,LM3) - KA=1 - KC=12 - 1 KB=MIN0(KC,NC) - WRITE(IOUT,600) (I,I=KA,KB) - WRITE(IOUT,602) - 2 N=0 - DO 3 I=1,NR - WRITE(IOUT,603) I,(A(I,J),J=KA,KB) - N=N+1 - IF(N.LT.3) GO TO 3 - WRITE(IOUT,602) - N=0 - 3 CONTINUE - 4 IF (KB.EQ.NC) RETURN - KA=KC+1 - KC=KC+12 - GO TO 1 - 600 FORMAT (//5x,4(3I9,2x)) - 602 FORMAT (2H ) - 603 FORMAT (I5,4(3F9.3,2x)) - 604 FORMAT (1H1) - END -c--------------------------------------------------------------------------- - SUBROUTINE ginv_mult(z,d_a_tmp) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer ierr -#endif - include 'COMMON.SETUP' - include 'COMMON.TIME1' - include 'COMMON.MD' - double precision z(dimen3),d_a_tmp(dimen3),temp(maxres6),time00 - &time01 -#ifdef MPI - if (nfgtasks.gt.1) then - if (fg_rank.eq.0) then -c The matching BROADCAST for fg processors is called in ERGASTULUM - time00=MPI_Wtime() - call MPI_Bcast(4,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -c print *,"Processor",myrank," BROADCAST iorder in GINV_MULT" - endif -c write (2,*) "time00",time00 -c write (2,*) "Before Scatterv" -c call flush(2) -c write (2,*) "Whole z (for FG master)" -c do i=1,dimen -c write (2,*) i,z(i) -c enddo -c call MPI_Barrier(FG_COMM,IERROR) - time00=MPI_Wtime() - call MPI_Scatterv(z,ng_counts(0),ng_start(0), - & MPI_DOUBLE_PRECISION, - & z,3*my_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -c write (2,*) "My chunk of z" -c do i=1,3*my_ng_count -c write (2,*) i,z(i) -c enddo -c write (2,*) "After SCATTERV" -c call flush(2) -c write (2,*) "MPI_Wtime",MPI_Wtime() - time_scatter=time_scatter+MPI_Wtime()-time00 -#ifdef TIMING - time_scatter_ginvmult=time_scatter_ginvmult+MPI_Wtime()-time00 -#endif -c write (2,*) "time_scatter",time_scatter -c write (2,*) "dimen",dimen," dimen3",dimen3," my_ng_count", -c & my_ng_count -c call flush(2) - time01=MPI_Wtime() - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - temp(ind)=0.0d0 - do j=1,my_ng_count -c write (2,*) "k,i,j,ind",k,i,j,ind,(j-1)*3+k+1, -c & Ginv(i,j),z((j-1)*3+k+1), -c & Ginv(i,j)*z((j-1)*3+k+1) -c temp(ind)=temp(ind)+Ginv(i,j)*z((j-1)*3+k+1) - temp(ind)=temp(ind)+Ginv(j,i)*z((j-1)*3+k+1) - enddo - enddo - enddo - time_ginvmult=time_ginvmult+MPI_Wtime()-time01 -c write (2,*) "Before REDUCE" -c call flush(2) -c write (2,*) "z before reduce" -c do i=1,dimen -c write (2,*) i,temp(i) -c enddo - time00=MPI_Wtime() - call MPI_Reduce(temp(1),d_a_tmp(1),dimen3,MPI_DOUBLE_PRECISION, - & MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -c write (2,*) "After REDUCE" -c call flush(2) - else -#endif -#ifdef TIMING - time01=MPI_Wtime() -#endif - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - d_a_tmp(ind)=0.0d0 - do j=1,dimen -c write (2,*) "k,i,j,ind",k,i,j,ind,(j-1)*3+k+1 -c call flush(2) -c & Ginv(i,j),z((j-1)*3+k+1), -c & Ginv(i,j)*z((j-1)*3+k+1) - d_a_tmp(ind)=d_a_tmp(ind) - & +Ginv(j,i)*z((j-1)*3+k+1) -c d_a_tmp(ind)=d_a_tmp(ind) -c & +Ginv(i,j)*z((j-1)*3+k+1) - enddo - enddo - enddo -#ifdef TIMING - time_ginvmult=time_ginvmult+MPI_Wtime()-time01 -#endif -#ifdef MPI - endif -#endif - return - end -c--------------------------------------------------------------------------- -#ifdef GINV_MULT - SUBROUTINE ginv_mult_test(z,d_a_tmp) - include 'DIMENSIONS' - integer dimen -c include 'COMMON.MD' - double precision z(dimen),d_a_tmp(dimen) - double precision ztmp(dimen/3),dtmp(dimen/3) - -c do i=1,dimen -c d_a_tmp(i)=0.0d0 -c do j=1,dimen -c d_a_tmp(i)=d_a_tmp(i)+Ginv(i,j)*z(j) -c enddo -c enddo -c -c return - -!ibm* unroll(3) - do k=0,2 - do j=1,dimen/3 - ztmp(j)=z((j-1)*3+k+1) - enddo - - call alignx(16,ztmp(1)) - call alignx(16,dtmp(1)) - call alignx(16,Ginv(1,1)) - - do i=1,dimen/3 - dtmp(i)=0.0d0 - do j=1,dimen/3 - dtmp(i)=dtmp(i)+Ginv(i,j)*ztmp(j) - enddo - enddo - do i=1,dimen/3 - ind=(i-1)*3+k+1 - d_a_tmp(ind)=dtmp(i) - enddo - enddo - return - end -#endif -c--------------------------------------------------------------------------- - SUBROUTINE fricmat_mult(z,d_a_tmp) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer IERROR -#endif - include 'COMMON.MD' - include 'COMMON.IOUNITS' - include 'COMMON.SETUP' - include 'COMMON.TIME1' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - double precision z(dimen3),d_a_tmp(dimen3),temp(maxres6),time00 - &time01 -#ifdef MPI - if (nfgtasks.gt.1) then - if (fg_rank.eq.0) then -c The matching BROADCAST for fg processors is called in ERGASTULUM - time00=MPI_Wtime() - call MPI_Bcast(9,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -c print *,"Processor",myrank," BROADCAST iorder in FRICMAT_MULT" - endif -c call MPI_Barrier(FG_COMM,IERROR) - time00=MPI_Wtime() - call MPI_Scatterv(z,ng_counts(0),ng_start(0), - & MPI_DOUBLE_PRECISION, - & z,3*my_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -c write (2,*) "My chunk of z" -c do i=1,3*my_ng_count -c write (2,*) i,z(i) -c enddo - time_scatter=time_scatter+MPI_Wtime()-time00 -#ifdef TIMING - time_scatter_fmatmult=time_scatter_fmatmult+MPI_Wtime()-time00 -#endif - time01=MPI_Wtime() - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - temp(ind)=0.0d0 - do j=1,my_ng_count - temp(ind)=temp(ind)-fricmat(j,i)*z((j-1)*3+k+1) - enddo - enddo - enddo - time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01 -c write (2,*) "Before REDUCE" -c write (2,*) "d_a_tmp before reduce" -c do i=1,dimen3 -c write (2,*) i,temp(i) -c enddo -c call flush(2) - time00=MPI_Wtime() - call MPI_Reduce(temp(1),d_a_tmp(1),dimen3,MPI_DOUBLE_PRECISION, - & MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -c write (2,*) "After REDUCE" -c call flush(2) - else -#endif -#ifdef TIMING - time01=MPI_Wtime() -#endif - do k=0,2 - do i=1,dimen - ind=(i-1)*3+k+1 - d_a_tmp(ind)=0.0d0 - do j=1,dimen - d_a_tmp(ind)=d_a_tmp(ind) - & -fricmat(j,i)*z((j-1)*3+k+1) - enddo - enddo - enddo -#ifdef TIMING - time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01 -#endif -#ifdef MPI - endif -#endif -c write (iout,*) "Vector d_a" -c do i=1,dimen3 -c write (2,*) i,d_a_tmp(i) -c enddo - return - end diff --git a/source/unres/src_MD_DFA/local_move.f b/source/unres/src_MD_DFA/local_move.f deleted file mode 100644 index 7a7e125..0000000 --- a/source/unres/src_MD_DFA/local_move.f +++ /dev/null @@ -1,972 +0,0 @@ -c------------------------------------------------------------- - - subroutine local_move_init(debug) -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' ! Needed by COMMON.LOCAL - include 'COMMON.GEO' ! For pi, deg2rad - include 'COMMON.LOCAL' ! For vbl - include 'COMMON.LOCMOVE' - -c INPUT arguments - logical debug - - -c Determine wheter to do some debugging output - locmove_output=debug - -c Set the init_called flag to 1 - init_called=1 - -c The following are never changed - min_theta=60.D0*deg2rad ! (0,PI) - max_theta=175.D0*deg2rad ! (0,PI) - dmin2=vbl*vbl*2.*(1.-cos(min_theta)) - dmax2=vbl*vbl*2.*(1.-cos(max_theta)) - flag=1.0D300 - small=1.0D-5 - small2=0.5*small*small - -c Not really necessary... - a_n=0 - b_n=0 - res_n=0 - - return - end - -c------------------------------------------------------------- - - subroutine local_move(n_start, n_end, PHImin, PHImax) -c Perform a local move between residues m and n (inclusive) -c PHImin and PHImax [0,PI] determine the size of the move -c Works on whatever structure is in the variables theta and phi, -c sidechain variables are left untouched -c The final structure is NOT minimized, but both the cartesian -c variables c and the angles are up-to-date at the end (no further -c chainbuild is required) -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.MINIM' - include 'COMMON.SBRIDGE' - include 'COMMON.LOCMOVE' - -c External functions - integer move_res - external move_res - double precision ran_number - external ran_number - -c INPUT arguments - integer n_start, n_end ! First and last residues to move - double precision PHImin, PHImax ! min/max angles [0,PI] - -c Local variables - integer i,j - double precision min,max - integer iretcode - - -c Check if local_move_init was called. This assumes that it -c would not be 1 if not explicitely initialized - if (init_called.ne.1) then - write(6,*)' *** local_move_init not called!!!' - stop - endif - -c Quick check for crazy range - if (n_start.gt.n_end .or. n_start.lt.1 .or. n_end.gt.nres) then - write(6,'(a,i3,a,i3)') - + ' *** Cannot make local move between n_start = ', - + n_start,' and n_end = ',n_end - return - endif - -c Take care of end residues first... - if (n_start.eq.1) then -c Move residue 1 (completely random) - theta(3)=ran_number(min_theta,max_theta) - phi(4)=ran_number(-PI,PI) - i=2 - else - i=n_start - endif - if (n_end.eq.nres) then -c Move residue nres (completely random) - theta(nres)=ran_number(min_theta,max_theta) - phi(nres)=ran_number(-PI,PI) - j=nres-1 - else - j=n_end - endif - -c ...then go through all other residues one by one -c Start from the two extremes and converge - call chainbuild - do while (i.le.j) - min=PHImin - max=PHImax -c$$$c Move the first two residues by less than the others -c$$$ if (i-n_start.lt.3) then -c$$$ if (i-n_start.eq.0) then -c$$$ min=0.4*PHImin -c$$$ max=0.4*PHImax -c$$$ else if (i-n_start.eq.1) then -c$$$ min=0.8*PHImin -c$$$ max=0.8*PHImax -c$$$ else if (i-n_start.eq.2) then -c$$$ min=PHImin -c$$$ max=PHImax -c$$$ endif -c$$$ endif - -c The actual move, on residue i - iretcode=move_res(min,max,i) ! Discard iretcode - i=i+1 - - if (i.le.j) then - min=PHImin - max=PHImax -c$$$c Move the last two residues by less than the others -c$$$ if (n_end-j.lt.3) then -c$$$ if (n_end-j.eq.0) then -c$$$ min=0.4*PHImin -c$$$ max=0.4*PHImax -c$$$ else if (n_end-j.eq.1) then -c$$$ min=0.8*PHImin -c$$$ max=0.8*PHImax -c$$$ else if (n_end-j.eq.2) then -c$$$ min=PHImin -c$$$ max=PHImax -c$$$ endif -c$$$ endif - -c The actual move, on residue j - iretcode=move_res(min,max,j) ! Discard iretcode - j=j-1 - endif - enddo - - call int_from_cart(.false.,.false.) - - return - end - -c------------------------------------------------------------- - - subroutine output_tabs -c Prints out the contents of a_..., b_..., res_... - implicit none - -c Includes - include 'COMMON.GEO' - include 'COMMON.LOCMOVE' - -c Local variables - integer i,j - - - write(6,*)'a_...' - write(6,'(8f7.1)')(a_ang(i)*rad2deg,i=0,a_n-1) - write(6,'(8(2x,3l1,2x))')((a_tab(i,j),i=0,2),j=0,a_n-1) - - write(6,*)'b_...' - write(6,'(4f7.1)')(b_ang(i)*rad2deg,i=0,b_n-1) - write(6,'(4(2x,3l1,2x))')((b_tab(i,j),i=0,2),j=0,b_n-1) - - write(6,*)'res_...' - write(6,'(12f7.1)')(res_ang(i)*rad2deg,i=0,res_n-1) - write(6,'(12(2x,3l1,2x))')((res_tab(0,i,j),i=0,2),j=0,res_n-1) - write(6,'(12(2x,3l1,2x))')((res_tab(1,i,j),i=0,2),j=0,res_n-1) - write(6,'(12(2x,3l1,2x))')((res_tab(2,i,j),i=0,2),j=0,res_n-1) - - return - end - -c------------------------------------------------------------- - - subroutine angles2tab(PHImin,PHImax,n,ang,tab) -c Only uses angles if [0,PI] (but PHImin cannot be 0., -c and PHImax cannot be PI) - implicit none - -c Includes - include 'COMMON.GEO' - -c INPUT arguments - double precision PHImin,PHImax - -c OUTPUT arguments - integer n - double precision ang(0:3) - logical tab(0:2,0:3) - - - if (PHImin .eq. PHImax) then -c Special case with two 010's - n = 2; - ang(0) = -PHImin; - ang(1) = PHImin; - tab(0,0) = .false. - tab(2,0) = .false. - tab(0,1) = .false. - tab(2,1) = .false. - tab(1,0) = .true. - tab(1,1) = .true. - else if (PHImin .eq. PI) then -c Special case with one 010 - n = 1 - ang(0) = PI - tab(0,0) = .false. - tab(2,0) = .false. - tab(1,0) = .true. - else if (PHImax .eq. 0.) then -c Special case with one 010 - n = 1 - ang(0) = 0. - tab(0,0) = .false. - tab(2,0) = .false. - tab(1,0) = .true. - else -c Standard cases - n = 0 - if (PHImin .gt. 0.) then -c Start of range (011) - ang(n) = PHImin - tab(0,n) = .false. - tab(1,n) = .true. - tab(2,n) = .true. -c End of range (110) - ang(n+1) = -PHImin - tab(0,n+1) = .true. - tab(1,n+1) = .true. - tab(2,n+1) = .false. - n = n+2 - endif - if (PHImax .lt. PI) then -c Start of range (011) - ang(n) = -PHImax - tab(0,n) = .false. - tab(1,n) = .true. - tab(2,n) = .true. -c End of range (110) - ang(n+1) = PHImax - tab(0,n+1) = .true. - tab(1,n+1) = .true. - tab(2,n+1) = .false. - n = n+2 - endif - endif - - return - end - -c------------------------------------------------------------- - - subroutine minmax_angles(x,y,z,r,n,ang,tab) -c When solutions do not exist, assume all angles -c are acceptable - i.e., initial geometry must be correct - implicit none - -c Includes - include 'COMMON.GEO' - include 'COMMON.LOCMOVE' - -c Input arguments - double precision x,y,z,r - -c Output arguments - integer n - double precision ang(0:3) - logical tab(0:2,0:3) - -c Local variables - double precision num, denom, phi - double precision Kmin, Kmax - integer i - - - num = x*x + y*y + z*z - denom = x*x + y*y - n = 0 - if (denom .gt. 0.) then - phi = atan2(y,x) - denom = 2.*r*sqrt(denom) - num = num+r*r - Kmin = (num - dmin2)/denom - Kmax = (num - dmax2)/denom - -c Allowed values of K (else all angles are acceptable) -c -1 <= Kmin < 1 -c -1 < Kmax <= 1 - if (Kmin .gt. 1. .or. abs(Kmin-1.) .lt. small2) then - Kmin = -flag - else if (Kmin .lt. -1. .or. abs(Kmin+1.) .lt. small2) then - Kmin = PI - else - Kmin = acos(Kmin) - endif - - if (Kmax .lt. -1. .or. abs(Kmax+1.) .lt. small2) then - Kmax = flag - else if (Kmax .gt. 1. .or. abs(Kmax-1.) .lt. small2) then - Kmax = 0. - else - Kmax = acos(Kmax) - endif - - if (Kmax .lt. Kmin) Kmax = Kmin - - call angles2tab(Kmin, Kmax, n, ang, tab) - -c Add phi and check that angles are within range (-PI,PI] - do i=0,n-1 - ang(i) = ang(i)+phi - if (ang(i) .le. -PI) then - ang(i) = ang(i)+2.*PI - else if (ang(i) .gt. PI) then - ang(i) = ang(i)-2.*PI - endif - enddo - endif - - return - end - -c------------------------------------------------------------- - - subroutine construct_tab -c Take a_... and b_... values and produces the results res_... -c x_ang are assumed to be all different (diff > small) -c x_tab(1,i) must be 1 for all i (i.e., all x_ang are acceptable) - implicit none - -c Includes - include 'COMMON.LOCMOVE' - -c Local variables - integer n_max,i,j,index - logical done - double precision phi - - - n_max = a_n + b_n - if (n_max .eq. 0) then - res_n = 0 - return - endif - - do i=0,n_max-1 - do j=0,1 - res_tab(j,0,i) = .true. - res_tab(j,2,i) = .true. - res_tab(j,1,i) = .false. - enddo - enddo - - index = 0 - phi = -flag - done = .false. - do while (.not.done) - res_ang(index) = flag - -c Check a first... - do i=0,a_n-1 - if ((a_ang(i)-phi).gt.small .and. - + a_ang(i) .lt. res_ang(index)) then -c Found a lower angle - res_ang(index) = a_ang(i) -c Copy the values from a_tab into res_tab(0,,) - res_tab(0,0,index) = a_tab(0,i) - res_tab(0,1,index) = a_tab(1,i) - res_tab(0,2,index) = a_tab(2,i) -c Set default values for res_tab(1,,) - res_tab(1,0,index) = .true. - res_tab(1,1,index) = .false. - res_tab(1,2,index) = .true. - else if (abs(a_ang(i)-res_ang(index)).lt.small) then -c Found an equal angle (can only be equal to a b_ang) - res_tab(0,0,index) = a_tab(0,i) - res_tab(0,1,index) = a_tab(1,i) - res_tab(0,2,index) = a_tab(2,i) - endif - enddo -c ...then check b - do i=0,b_n-1 - if ((b_ang(i)-phi).gt.small .and. - + b_ang(i) .lt. res_ang(index)) then -c Found a lower angle - res_ang(index) = b_ang(i) -c Copy the values from b_tab into res_tab(1,,) - res_tab(1,0,index) = b_tab(0,i) - res_tab(1,1,index) = b_tab(1,i) - res_tab(1,2,index) = b_tab(2,i) -c Set default values for res_tab(0,,) - res_tab(0,0,index) = .true. - res_tab(0,1,index) = .false. - res_tab(0,2,index) = .true. - else if (abs(b_ang(i)-res_ang(index)).lt.small) then -c Found an equal angle (can only be equal to an a_ang) - res_tab(1,0,index) = b_tab(0,i) - res_tab(1,1,index) = b_tab(1,i) - res_tab(1,2,index) = b_tab(2,i) - endif - enddo - - if (res_ang(index) .eq. flag) then - res_n = index - done = .true. - else if (index .eq. n_max-1) then - res_n = n_max - done = .true. - else - phi = res_ang(index) ! Store previous angle - index = index+1 - endif - enddo - -c Fill the gaps -c First a... - index = 0 - if (a_n .gt. 0) then - do while (.not.res_tab(0,1,index)) - index=index+1 - enddo - done = res_tab(0,2,index) - do i=index+1,res_n-1 - if (res_tab(0,1,i)) then - done = res_tab(0,2,i) - else - res_tab(0,0,i) = done - res_tab(0,1,i) = done - res_tab(0,2,i) = done - endif - enddo - done = res_tab(0,0,index) - do i=index-1,0,-1 - if (res_tab(0,1,i)) then - done = res_tab(0,0,i) - else - res_tab(0,0,i) = done - res_tab(0,1,i) = done - res_tab(0,2,i) = done - endif - enddo - else - do i=0,res_n-1 - res_tab(0,0,i) = .true. - res_tab(0,1,i) = .true. - res_tab(0,2,i) = .true. - enddo - endif -c ...then b - index = 0 - if (b_n .gt. 0) then - do while (.not.res_tab(1,1,index)) - index=index+1 - enddo - done = res_tab(1,2,index) - do i=index+1,res_n-1 - if (res_tab(1,1,i)) then - done = res_tab(1,2,i) - else - res_tab(1,0,i) = done - res_tab(1,1,i) = done - res_tab(1,2,i) = done - endif - enddo - done = res_tab(1,0,index) - do i=index-1,0,-1 - if (res_tab(1,1,i)) then - done = res_tab(1,0,i) - else - res_tab(1,0,i) = done - res_tab(1,1,i) = done - res_tab(1,2,i) = done - endif - enddo - else - do i=0,res_n-1 - res_tab(1,0,i) = .true. - res_tab(1,1,i) = .true. - res_tab(1,2,i) = .true. - enddo - endif - -c Finally fill the last row with AND operation - do i=0,res_n-1 - do j=0,2 - res_tab(2,j,i) = (res_tab(0,j,i) .and. res_tab(1,j,i)) - enddo - enddo - - return - end - -c------------------------------------------------------------- - - subroutine construct_ranges(phi_n,phi_start,phi_end) -c Given the data in res_..., construct a table of -c min/max allowed angles - implicit none - -c Includes - include 'COMMON.GEO' - include 'COMMON.LOCMOVE' - -c Output arguments - integer phi_n - double precision phi_start(0:11),phi_end(0:11) - -c Local variables - logical done - integer index - - - if (res_n .eq. 0) then -c Any move is allowed - phi_n = 1 - phi_start(0) = -PI - phi_end(0) = PI - else - phi_n = 0 - index = 0 - done = .false. - do while (.not.done) -c Find start of range (01x) - done = .false. - do while (.not.done) - if (res_tab(2,0,index).or.(.not.res_tab(2,1,index))) then - index=index+1 - else - done = .true. - phi_start(phi_n) = res_ang(index) - endif - if (index .eq. res_n) done = .true. - enddo -c If a start was found (index < res_n), find the end of range (x10) -c It may not be found without wrapping around - if (index .lt. res_n) then - done = .false. - do while (.not.done) - if ((.not.res_tab(2,1,index)).or.res_tab(2,2,index)) then - index=index+1 - else - done = .true. - endif - if (index .eq. res_n) done = .true. - enddo - if (index .lt. res_n) then -c Found the end of the range - phi_end(phi_n) = res_ang(index) - phi_n=phi_n+1 - index=index+1 - if (index .eq. res_n) then - done = .true. - else - done = .false. - endif - else -c Need to wrap around - done = .true. - phi_end(phi_n) = flag - endif - endif - enddo -c Take care of the last one if need to wrap around - if (phi_end(phi_n) .eq. flag) then - index = 0 - do while ((.not.res_tab(2,1,index)).or.res_tab(2,2,index)) - index=index+1 - enddo - phi_end(phi_n) = res_ang(index) + 2.*PI - phi_n=phi_n+1 - endif - endif - - return - end - -c------------------------------------------------------------- - - subroutine fix_no_moves(phi) - implicit none - -c Includes - include 'COMMON.GEO' - include 'COMMON.LOCMOVE' - -c Output arguments - double precision phi - -c Local variables - integer index - double precision diff,temp - - -c Look for first 01x in gammas (there MUST be at least one) - diff = flag - index = 0 - do while (res_tab(1,0,index) .or. (.not.res_tab(1,1,index))) - index=index+1 - enddo - if (res_ang(index) .le. 0.D0) then ! Make sure it's from PHImax -c Try to increase PHImax - if (index .gt. 0) then - phi = res_ang(index-1) - diff = abs(res_ang(index) - res_ang(index-1)) - endif -c Look for last (corresponding) x10 - index = res_n - 1 - do while ((.not.res_tab(1,1,index)) .or. res_tab(1,2,index)) - index=index-1 - enddo - if (index .lt. res_n-1) then - temp = abs(res_ang(index) - res_ang(index+1)) - if (temp .lt. diff) then - phi = res_ang(index+1) - diff = temp - endif - endif - endif - -c If increasing PHImax didn't work, decreasing PHImin -c will (with one exception) -c Look for first x10 (there MUST be at least one) - index = 0 - do while ((.not.res_tab(1,1,index)) .or. res_tab(1,2,index)) - index=index+1 - enddo - if (res_ang(index) .lt. 0.D0) then ! Make sure it's from PHImin -c Try to decrease PHImin - if (index .lt. res_n-1) then - temp = abs(res_ang(index) - res_ang(index+1)) - if (res_ang(index+1) .le. 0.D0 .and. temp .lt. diff) then - phi = res_ang(index+1) - diff = temp - endif - endif -c Look for last (corresponding) 01x - index = res_n - 1 - do while (res_tab(1,0,index) .or. (.not.res_tab(1,1,index))) - index=index-1 - enddo - if (index .gt. 0) then - temp = abs(res_ang(index) - res_ang(index-1)) - if (res_ang(index-1) .ge. 0.D0 .and. temp .lt. diff) then - phi = res_ang(index-1) - diff = temp - endif - endif - endif - -c If it still didn't work, it must be PHImax == 0. or PHImin == PI - if (diff .eq. flag) then - index = 0 - if (res_tab(index,1,0) .or. (.not.res_tab(index,1,1)) .or. - + res_tab(index,1,2)) index = res_n - 1 -c This MUST work at this point - if (index .eq. 0) then - phi = res_ang(1) - else - phi = res_ang(index - 1) - endif - endif - - return - end - -c------------------------------------------------------------- - - integer function move_res(PHImin,PHImax,i_move) -c Moves residue i_move (in array c), leaving everything else fixed -c Starting geometry is not checked, it should be correct! -c R(,i_move) is the only residue that will move, but must have -c 1 < i_move < nres (i.e., cannot move ends) -c Whether any output is done is controlled by locmove_output -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.LOCMOVE' - -c External functions - double precision ran_number - external ran_number - -c Input arguments - double precision PHImin,PHImax - integer i_move - -c RETURN VALUES: -c 0: move successfull -c 1: Dmin or Dmax had to be modified -c 2: move failed - check your input geometry - - -c Local variables - double precision X(0:2),Y(0:2),Z(0:2),Orig(0:2) - double precision P(0:2) - logical no_moves,done - integer index,i,j - double precision phi,temp,radius - double precision phi_start(0:11), phi_end(0:11) - integer phi_n - -c Set up the coordinate system - do i=0,2 - Orig(i)=0.5*(c(i+1,i_move-1)+c(i+1,i_move+1)) ! Position of origin - enddo - - do i=0,2 - Z(i)=c(i+1,i_move+1)-c(i+1,i_move-1) - enddo - temp=sqrt(Z(0)*Z(0)+Z(1)*Z(1)+Z(2)*Z(2)) - do i=0,2 - Z(i)=Z(i)/temp - enddo - - do i=0,2 - X(i)=c(i+1,i_move)-Orig(i) - enddo -c radius is the radius of the circle on which c(,i_move) can move - radius=sqrt(X(0)*X(0)+X(1)*X(1)+X(2)*X(2)) - do i=0,2 - X(i)=X(i)/radius - enddo - - Y(0)=Z(1)*X(2)-X(1)*Z(2) - Y(1)=X(0)*Z(2)-Z(0)*X(2) - Y(2)=Z(0)*X(1)-X(0)*Z(1) - -c Calculate min, max angles coming from dmin, dmax to c(,i_move-2) - if (i_move.gt.2) then - do i=0,2 - P(i)=c(i+1,i_move-2)-Orig(i) - enddo - call minmax_angles(P(0)*X(0)+P(1)*X(1)+P(2)*X(2), - + P(0)*Y(0)+P(1)*Y(1)+P(2)*Y(2), - + P(0)*Z(0)+P(1)*Z(1)+P(2)*Z(2), - + radius,a_n,a_ang,a_tab) - else - a_n=0 - endif - -c Calculate min, max angles coming from dmin, dmax to c(,i_move+2) - if (i_move.lt.nres-2) then - do i=0,2 - P(i)=c(i+1,i_move+2)-Orig(i) - enddo - call minmax_angles(P(0)*X(0)+P(1)*X(1)+P(2)*X(2), - + P(0)*Y(0)+P(1)*Y(1)+P(2)*Y(2), - + P(0)*Z(0)+P(1)*Z(1)+P(2)*Z(2), - + radius,b_n,b_ang,b_tab) - else - b_n=0 - endif - -c Construct the resulting table for alpha and beta - call construct_tab() - - if (locmove_output) then - print *,'ALPHAS & BETAS TABLE' - call output_tabs() - endif - -c Check that there is at least one possible move - no_moves = .true. - if (res_n .eq. 0) then - no_moves = .false. - else - index = 0 - do while ((index .lt. res_n) .and. no_moves) - if (res_tab(2,1,index)) no_moves = .false. - index=index+1 - enddo - endif - if (no_moves) then - if (locmove_output) print *,' *** Cannot move anywhere' - move_res=2 - return - endif - -c Transfer res_... into a_... - a_n = 0 - do i=0,res_n-1 - if ( (res_tab(2,0,i).neqv.res_tab(2,1,i)) .or. - + (res_tab(2,0,i).neqv.res_tab(2,2,i)) ) then - a_ang(a_n) = res_ang(i) - do j=0,2 - a_tab(j,a_n) = res_tab(2,j,i) - enddo - a_n=a_n+1 - endif - enddo - -c Check that the PHI's are within [0,PI] - if (PHImin .lt. 0. .or. abs(PHImin) .lt. small) PHImin = -flag - if (PHImin .gt. PI .or. abs(PHImin-PI) .lt. small) PHImin = PI - if (PHImax .gt. PI .or. abs(PHImax-PI) .lt. small) PHImax = flag - if (PHImax .lt. 0. .or. abs(PHImax) .lt. small) PHImax = 0. - if (PHImax .lt. PHImin) PHImax = PHImin -c Calculate min and max angles coming from PHImin and PHImax, -c and put them in b_... - call angles2tab(PHImin, PHImax, b_n, b_ang, b_tab) -c Construct the final table - call construct_tab() - - if (locmove_output) then - print *,'FINAL TABLE' - call output_tabs() - endif - -c Check that there is at least one possible move - no_moves = .true. - if (res_n .eq. 0) then - no_moves = .false. - else - index = 0 - do while ((index .lt. res_n) .and. no_moves) - if (res_tab(2,1,index)) no_moves = .false. - index=index+1 - enddo - endif - - if (no_moves) then -c Take care of the case where no solution exists... - call fix_no_moves(phi) - if (locmove_output) then - print *,' *** Had to modify PHImin or PHImax' - print *,'phi: ',phi*rad2deg - endif - move_res=1 - else -c ...or calculate the solution -c Construct phi_start/phi_end arrays - call construct_ranges(phi_n, phi_start, phi_end) -c Choose random angle phi in allowed range(s) - temp = 0. - do i=0,phi_n-1 - temp = temp + phi_end(i) - phi_start(i) - enddo - phi = ran_number(phi_start(0),phi_start(0)+temp) - index = 0 - done = .false. - do while (.not.done) - if (phi .lt. phi_end(index)) then - done = .true. - else - index=index+1 - endif - if (index .eq. phi_n) then - done = .true. - else if (.not.done) then - phi = phi + phi_start(index) - phi_end(index-1) - endif - enddo - if (index.eq.phi_n) phi=phi_end(phi_n-1) ! Fix numerical errors - if (phi .gt. PI) phi = phi-2.*PI - - if (locmove_output) then - print *,'ALLOWED RANGE(S)' - do i=0,phi_n-1 - print *,phi_start(i)*rad2deg,phi_end(i)*rad2deg - enddo - print *,'phi: ',phi*rad2deg - endif - move_res=0 - endif - -c Re-use radius as temp variable - temp=radius*cos(phi) - radius=radius*sin(phi) - do i=0,2 - c(i+1,i_move)=Orig(i)+temp*X(i)+radius*Y(i) - enddo - - return - end - -c------------------------------------------------------------- - - subroutine loc_test -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.LOCMOVE' - -c External functions - integer move_res - external move_res - -c Local variables - integer i,j - integer phi_n - double precision phi_start(0:11),phi_end(0:11) - double precision phi - double precision R(0:2,0:5) - - locmove_output=.true. - -c call angles2tab(30.*deg2rad,70.*deg2rad,a_n,a_ang,a_tab) -c call angles2tab(80.*deg2rad,130.*deg2rad,b_n,b_ang,b_tab) -c call minmax_angles(0.D0,3.8D0,0.D0,3.8D0,b_n,b_ang,b_tab) -c call construct_tab -c call output_tabs - -c call construct_ranges(phi_n,phi_start,phi_end) -c do i=0,phi_n-1 -c print *,phi_start(i)*rad2deg,phi_end(i)*rad2deg -c enddo - -c call fix_no_moves(phi) -c print *,'NO MOVES FOUND, BEST PHI IS',phi*rad2deg - - R(0,0)=0.D0 - R(1,0)=0.D0 - R(2,0)=0.D0 - R(0,1)=0.D0 - R(1,1)=-cos(28.D0*deg2rad) - R(2,1)=-0.5D0-sin(28.D0*deg2rad) - R(0,2)=0.D0 - R(1,2)=0.D0 - R(2,2)=-0.5D0 - R(0,3)=cos(30.D0*deg2rad) - R(1,3)=0.D0 - R(2,3)=0.D0 - R(0,4)=0.D0 - R(1,4)=0.D0 - R(2,4)=0.5D0 - R(0,5)=0.D0 - R(1,5)=cos(26.D0*deg2rad) - R(2,5)=0.5D0+sin(26.D0*deg2rad) - do i=1,5 - do j=0,2 - R(j,i)=vbl*R(j,i) - enddo - enddo -c i=move_res(R(0,1),0.D0*deg2rad,180.D0*deg2rad) - imov=nnt - i=move_res(0.D0*deg2rad,180.D0*deg2rad,imov) - print *,'RETURNED ',i - print *,(R(i,3)/vbl,i=0,2) - - return - end - -c------------------------------------------------------------- diff --git a/source/unres/src_MD_DFA/map.f b/source/unres/src_MD_DFA/map.f deleted file mode 100644 index 9dbe64e..0000000 --- a/source/unres/src_MD_DFA/map.f +++ /dev/null @@ -1,90 +0,0 @@ - subroutine map - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MAP' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.CONTROL' - include 'COMMON.TORCNSTR' - double precision energia(0:n_ene) - character*5 angid(4) /'PHI','THETA','ALPHA','OMEGA'/ - double precision ang_list(10) - double precision g(maxvar),x(maxvar) - integer nn(10) - write (iout,'(a,i3,a)')'Energy map constructed in the following ', - & nmap,' groups of variables:' - do i=1,nmap - write (iout,'(2a,i3,a,i3)') angid(kang(i)),' of residues ', - & res1(i),' to ',res2(i) - enddo - nmax=nstep(1) - do i=2,nmap - if (nmax.lt.nstep(i)) nmax=nstep(i) - enddo - ntot=nmax**nmap - iii=0 - write (istat,'(1h#,a14,29a15)') (" ",k=1,nmap), - & (ename(print_order(k)),k=1,nprint_ene),"ETOT","GNORM" - do i=0,ntot-1 - ii=i - do j=1,nmap - nn(j)=mod(ii,nmax)+1 - ii=ii/nmax - enddo - do j=1,nmap - if (nn(j).gt.nstep(j)) goto 10 - enddo - iii=iii+1 -Cd write (iout,*) i,iii,(nn(j),j=1,nmap) - do j=1,nmap - ang_list(j)=ang_from(j) - & +(nn(j)-1)*(ang_to(j)-ang_from(j))/nstep(j) - do k=res1(j),res2(j) - goto (1,2,3,4), kang(j) - 1 phi(k)=deg2rad*ang_list(j) - if (minim) phi0(k-res1(j)+1)=deg2rad*ang_list(j) - goto 5 - 2 theta(k)=deg2rad*ang_list(j) - goto 5 - 3 alph(k)=deg2rad*ang_list(j) - goto 5 - 4 omeg(k)=deg2rad*ang_list(j) - 5 continue - enddo ! k - enddo ! j - call chainbuild - call int_from_cart1(.false.) - if (minim) then - call geom_to_var(nvar,x) - call minimize(etot,x,iretcode,nfun) - print *,'SUMSL return code is',iretcode,' eval ',nfun -c call intout - else - call zerograd - call geom_to_var(nvar,x) - endif - call etotal(energia(0)) - etot = energia(0) - nf=1 - nfl=3 - call gradient(nvar,x,nf,g,uiparm,urparm,fdum) - gnorm=0.0d0 - do k=1,nvar - gnorm=gnorm+g(k)**2 - enddo - etot=energia(0) - - gnorm=dsqrt(gnorm) -c write (iout,'(6(1pe15.5))') (ang_list(k),k=1,nmap),etot,gnorm - write (istat,'(30e15.5)') (ang_list(k),k=1,nmap), - & (energia(print_order(ii)),ii=1,nprint_ene),etot,gnorm -c write (iout,*) 'POINT',I,' ANGLES:',(ang_list(k),k=1,nmap) -c call intout -c call enerprint(energia) - 10 continue - enddo ! i - return - end diff --git a/source/unres/src_MD_DFA/matmult.f b/source/unres/src_MD_DFA/matmult.f deleted file mode 100644 index e9257cf..0000000 --- a/source/unres/src_MD_DFA/matmult.f +++ /dev/null @@ -1,18 +0,0 @@ - SUBROUTINE MATMULT(A1,A2,A3) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(3,3),A2(3,3),A3(3,3) - DIMENSION AI3(3,3) - DO 1 I=1,3 - DO 2 J=1,3 - A3IJ=0.0 - DO 3 K=1,3 - 3 A3IJ=A3IJ+A1(I,K)*A2(K,J) - AI3(I,J)=A3IJ - 2 CONTINUE - 1 CONTINUE - DO 4 I=1,3 - DO 4 J=1,3 - 4 A3(I,J)=AI3(I,J) - RETURN - END diff --git a/source/unres/src_MD_DFA/mc.F b/source/unres/src_MD_DFA/mc.F deleted file mode 100644 index 0f39d48..0000000 --- a/source/unres/src_MD_DFA/mc.F +++ /dev/null @@ -1,819 +0,0 @@ - subroutine monte_carlo -C Does Boltzmann and entropic sampling without energy minimization - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPL - include 'COMMON.INFO' -#endif - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.THREAD' - include 'COMMON.NAMES' - logical accepted,not_done,over,ovrtim,error,lprint - integer MoveType,nbond,nbins - integer conf_comp - double precision RandOrPert - double precision varia(maxvar),elowest,elowest1, - & ehighest,ehighest1,eold - double precision przes(3),obr(3,3) - double precision varold(maxvar) - logical non_conv - integer moves1(-1:MaxMoveType+1,0:MaxProcs-1), - & moves_acc1(-1:MaxMoveType+1,0:MaxProcs-1) -#ifdef MPL - double precision etot_temp,etot_all(0:MaxProcs) - external d_vadd,d_vmin,d_vmax - double precision entropy1(-max_ene:max_ene), - & nhist1(-max_ene:max_ene) - integer nbond_move1(maxres*(MaxProcs+1)), - & nbond_acc1(maxres*(MaxProcs+1)),itemp(2) -#endif - double precision var_lowest(maxvar) - double precision energia(0:n_ene),energia_ave(0:n_ene) -C - write(iout,'(a,i8,2x,a,f10.5)') - & 'pool_read_freq=',pool_read_freq,' pool_fraction=',pool_fraction - open (istat,file=statname) - WhatsUp=0 - indminn=-max_ene - indmaxx=max_ene - facee=1.0D0/(maxacc*delte) -C Number of bins in energy histogram - nbins=e_up/delte-1 - write (iout,*) 'NBINS=',nbins - conste=dlog(facee) -C Read entropy from previous simulations. - if (ent_read) then - read (ientin,*) indminn,indmaxx,emin,emax - print *,'indminn=',indminn,' indmaxx=',indmaxx,' emin=',emin, - & ' emax=',emax - do i=-max_ene,max_ene - entropy(i)=0.0D0 - enddo - read (ientin,*) (ijunk,ejunk,entropy(i),i=indminn,indmaxx) - indmin=indminn - indmax=indmaxx - write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx, - & ' emin=',emin,' emax=',emax - write (iout,'(/a)') 'Initial entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - endif ! ent_read -C Read the pool of conformations - call read_pool - elowest=1.0D+10 - ehighest=-1.0D+10 -C---------------------------------------------------------------------------- -C Entropy-sampling simulations with continually updated entropy; -C set NSWEEP=1 for Boltzmann sampling. -C Loop thru simulations -C---------------------------------------------------------------------------- - DO ISWEEP=1,NSWEEP -C -C Initialize the IFINISH array. -C -#ifdef MPL - do i=1,nctasks - ifinish(i)=0 - enddo -#endif -c--------------------------------------------------------------------------- -C Initialize counters. -c--------------------------------------------------------------------------- -C Total number of generated confs. - ngen=0 -C Total number of moves. In general this won't be equal to the number of -C attempted moves, because we may want to reject some "bad" confs just by -C overlap check. - nmove=0 -C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... -C motions. - do i=1,nres - nbond_move(i)=0 - nbond_acc(i)=0 - enddo -C Initialize total and accepted number of moves of various kind. - do i=-1,MaxMoveType - moves(i)=0 - moves_acc(i)=0 - enddo -C Total number of energy evaluations. - neneval=0 - nfun=0 -C---------------------------------------------------------------------------- -C Take a conformation from the pool -C---------------------------------------------------------------------------- - rewind(istat) - write (iout,*) 'emin=',emin,' emax=',emax - if (npool.gt.0) then - ii=iran_num(1,npool) - do i=1,nvar - varia(i)=xpool(i,ii) - enddo - write (iout,*) 'Took conformation',ii,' from the pool energy=', - & epool(ii) - call var_to_geom(nvar,varia) -C Print internal coordinates of the initial conformation - call intout - else if (isweep.gt.1) then - if (eold.lt.emax) then - do i=1,nvar - varia(i)=varold(i) - enddo - else - do i=1,nvar - varia(i)=var_lowest(i) - enddo - endif - call var_to_geom(nvar,varia) - endif -C---------------------------------------------------------------------------- -C Compute and print initial energies. -C---------------------------------------------------------------------------- - nsave=0 - Kwita=0 - WhatsUp=0 - write (iout,'(/80(1h*)/a,i2/80(1h*)/)') 'MCE iteration #',isweep - write (iout,'(/80(1h*)/a)') 'Initial energies:' - call chainbuild - call geom_to_var(nvar,varia) - call etotal(energia(0)) - etot = energia(0) - call enerprint(energia(0)) - if (refstr) then - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes, - & obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order',co - write (istat,'(i10,16(1pe14.5))') 0, - & (energia(print_order(i)),i=1,nprint_ene), - & etot,rms,frac,co - else - write (istat,'(i10,14(1pe14.5))') 0, - & (energia(print_order(i)),i=1,nprint_ene),etot - endif -c close(istat) - neneval=neneval+1 - if (.not. ent_read) then -C Initialize the entropy array -#ifdef MPL -C Collect total energies from other processors. - etot_temp=etot - etot_all(0)=etot - call mp_gather(etot_temp,etot_all,8,MasterID,cgGroupID) - if (MyID.eq.MasterID) then -C Get the lowest and the highest energy. - print *,'MASTER: etot_temp: ',(etot_all(i),i=0,nprocs-1), - & ' emin=',emin,' emax=',emax - emin=1.0D10 - emax=-1.0D10 - do i=0,nprocs - if (emin.gt.etot_all(i)) emin=etot_all(i) - if (emax.lt.etot_all(i)) emax=etot_all(i) - enddo - emax=emin+e_up - endif ! MyID.eq.MasterID - etot_all(1)=emin - etot_all(2)=emax - print *,'Processor',MyID,' calls MP_BCAST to send/recv etot_all' - call mp_bcast(etot_all(1),16,MasterID,cgGroupID) - print *,'Processor',MyID,' MP_BCAST to send/recv etot_all ended' - if (MyID.ne.MasterID) then - print *,'Processor:',MyID,etot_all(1),etot_all(2), - & etot_all(1),etot_all(2) - emin=etot_all(1) - emax=etot_all(2) - endif ! MyID.ne.MasterID - write (iout,*) 'After MP_GATHER etot_temp=', - & etot_temp,' emin=',emin -#else - emin=etot - emax=emin+e_up - indminn=0 - indmin=0 -#endif - IF (MULTICAN) THEN -C Multicanonical sampling - start from Boltzmann distribution - do i=-max_ene,max_ene - entropy(i)=(emin+i*delte)*betbol - enddo - ELSE -C Entropic sampling - start from uniform distribution of the density of states - do i=-max_ene,max_ene - entropy(i)=0.0D0 - enddo - ENDIF ! MULTICAN - write (iout,'(/a)') 'Initial entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - if (isweep.eq.1) then - emax=emin+e_up - indminn=0 - indmin=0 - indmaxx=indminn+nbins - indmax=indmaxx - endif ! isweep.eq.1 - endif ! .not. ent_read -#ifdef MPL - call recv_stop_sig(Kwita) - if (whatsup.eq.1) then - call send_stop_sig(-2) - not_done=.false. - else if (whatsup.le.-2) then - not_done=.false. - else if (whatsup.eq.2) then - not_done=.false. - else - not_done=.true. - endif -#else - not_done=.true. -#endif - write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Enter Monte Carlo procedure.' - close(igeom) - call briefout(0,etot) - do i=1,nvar - varold(i)=varia(i) - enddo - eold=etot - call entropia(eold,sold,indeold) -C NACC is the counter for the accepted conformations of a given processor - nacc=0 -C NACC_TOT counts the total number of accepted conformations - nacc_tot=0 -C Main loop. -c---------------------------------------------------------------------------- -C Zero out average energies - do i=0,n_ene - energia_ave(i)=0.0d0 - enddo -C Initialize energy histogram - do i=-max_ene,max_ene - nhist(i)=0.0D0 - enddo ! i -C Zero out iteration counter. - it=0 - do j=1,nvar - varold(j)=varia(j) - enddo -C Begin MC iteration loop. - do while (not_done) - it=it+1 -C Initialize local counter. - ntrial=0 ! # of generated non-overlapping confs. - noverlap=0 ! # of overlapping confs. - accepted=.false. - do while (.not. accepted .and. WhatsUp.eq.0 .and. Kwita.eq.0) - ntrial=ntrial+1 -C Retrieve the angles of previously accepted conformation - do j=1,nvar - varia(j)=varold(j) - enddo - call var_to_geom(nvar,varia) -C Rebuild the chain. - call chainbuild - MoveType=0 - nbond=0 - lprint=.true. -C Decide whether to take a conformation from the pool or generate/perturb one -C randomly - from_pool=ran_number(0.0D0,1.0D0) - if (npool.gt.0 .and. from_pool.lt.pool_fraction) then -C Throw a dice to choose the conformation from the pool - ii=iran_num(1,npool) - do i=1,nvar - varia(i)=xpool(i,ii) - enddo - call var_to_geom(nvar,varia) - call chainbuild -cd call intout -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a,i3,a,f10.5)') - & 'Try conformation',ii,' from the pool energy=',epool(ii) - MoveType=-1 - moves(-1)=moves(-1)+1 - else -C Decide whether to generate a random conformation or perturb the old one - RandOrPert=ran_number(0.0D0,1.0D0) - if (RandOrPert.gt.RanFract) then - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a)') 'Perturbation-generated conformation.' - call perturb(error,lprint,MoveType,nbond,0.1D0) - if (error) goto 20 - if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then - write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=', - & MoveType,' returned from PERTURB.' - goto 20 - endif - call chainbuild - else - MoveType=0 - moves(0)=moves(0)+1 - nstart_grow=iran_num(3,nres) - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(2a,i3)') 'Random-generated conformation', - & ' - chain regrown from residue',nstart_grow - call gen_rand_conf(nstart_grow,*30) - endif - call geom_to_var(nvar,varia) - endif ! pool -Cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - ngen=ngen+1 - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a,i5,a,i10,a,i10)') - & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (*,'(a,i5,a,i10,a,i10)') - & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen - call etotal(energia(0)) - etot = energia(0) - neneval=neneval+1 -cd call enerprint(energia(0)) -cd write(iout,*)'it=',it,' etot=',etot - if (etot-elowest.gt.overlap_cut) then - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a,i5,a,1pe14.5)') 'Iteration',it, - & ' Overlap detected in the current conf.; energy is',etot - accepted=.false. - noverlap=noverlap+1 - if (noverlap.gt.maxoverlap) then - write (iout,'(a)') 'Too many overlapping confs.' - goto 20 - endif - else -C-------------------------------------------------------------------------- -C... Acceptance test -C-------------------------------------------------------------------------- - accepted=.false. - if (WhatsUp.eq.0) - & call accept_mc(it,etot,eold,scur,sold,varia,varold,accepted) - if (accepted) then - nacc=nacc+1 - nacc_tot=nacc_tot+1 - if (elowest.gt.etot) then - elowest=etot - do i=1,nvar - var_lowest(i)=varia(i) - enddo - endif - if (ehighest.lt.etot) ehighest=etot - moves_acc(MoveType)=moves_acc(MoveType)+1 - if (MoveType.eq.1) then - nbond_acc(nbond)=nbond_acc(nbond)+1 - endif -C Compare with reference structure. - if (refstr) then - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup), - & nsup,przes,obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - endif ! refstr -C -C Periodically save average energies and confs. -C - do i=0,n_ene - energia_ave(i)=energia_ave(i)+energia(i) - enddo - moves(MaxMoveType+1)=nmove - moves_acc(MaxMoveType+1)=nacc - IF ((it/save_frequency)*save_frequency.eq.it) THEN - do i=0,n_ene - energia_ave(i)=energia_ave(i)/save_frequency - enddo - etot_ave=energia_ave(0) -C#ifdef AIX -C open (istat,file=statname,position='append') -C#else -C open (istat,file=statname,access='append') -Cendif - if (print_mc.gt.0) - & write (iout,'(80(1h*)/20x,a,i20)') - & 'Iteration #',it - if (refstr .and. print_mc.gt.0) then - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order:',co - endif - if (print_stat) then - if (refstr) then - write (istat,'(i10,10(1pe14.5))') it, - & (energia_ave(print_order(i)),i=1,nprint_ene), - & etot_ave,rms_ave,frac_ave - else - write (istat,'(i10,10(1pe14.5))') it, - & (energia_ave(print_order(i)),i=1,nprint_ene), - & etot_ave - endif - endif -c close(istat) - if (print_mc.gt.0) - & call statprint(nacc,nfun,iretcode,etot,elowest) -C Print internal coordinates. - if (print_int) call briefout(nacc,etot) - do i=0,n_ene - energia_ave(i)=0.0d0 - enddo - ENDIF ! ( (it/save_frequency)*save_frequency.eq.it) -C Update histogram - inde=icialosc((etot-emin)/delte) - nhist(inde)=nhist(inde)+1.0D0 -#ifdef MPL - if ( (it/message_frequency)*message_frequency.eq.it - & .and. (MyID.ne.MasterID) ) then - call recv_stop_sig(Kwita) - call send_MCM_info(message_frequency) - endif -#endif -C Store the accepted conf. and its energy. - eold=etot - sold=scur - do i=1,nvar - varold(i)=varia(i) - enddo -#ifdef MPL - if (Kwita.eq.0) call recv_stop_sig(kwita) -#endif - endif ! accepted - endif ! overlap -#ifdef MPL - if (MyID.eq.MasterID .and. - & (it/message_frequency)*message_frequency.eq.it) then - call receive_MC_info - if (nacc_tot.ge.maxacc) accepted=.true. - endif -#endif -C if ((ntrial.gt.maxtrial_iter -C & .or. (it/pool_read_freq)*pool_read_freq.eq.it) -C & .and. npool.gt.0) then -C Take a conformation from the pool -C ii=iran_num(1,npool) -C do i=1,nvar -C varold(i)=xpool(i,ii) -C enddo -C if (ntrial.gt.maxtrial_iter) -C & write (iout,*) 'Iteration',it,' max. # of trials exceeded.' -C write (iout,*) -C & 'Take conformation',ii,' from the pool energy=',epool(ii) -C if (print_mc.gt.2) -C & write (iout,'(10f8.3)') (rad2deg*varold(i),i=1,nvar) -C ntrial=0 -C eold=epool(ii) -C call entropia(eold,sold,indeold) -C accepted=.true. -C endif ! (ntrial.gt.maxtrial_iter .and. npool.gt.0) - 30 continue - enddo ! accepted -#ifdef MPL - if (MyID.eq.MasterID .and. - & (it/message_frequency)*message_frequency.eq.it) then - call receive_MC_info - endif - if (Kwita.eq.0) call recv_stop_sig(kwita) -#endif - if (ovrtim()) WhatsUp=-1 -cd write (iout,*) 'WhatsUp=',WhatsUp,' Kwita=',Kwita - not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) - & .and. (Kwita.eq.0) -cd write (iout,*) 'not_done=',not_done -#ifdef MPL - if (Kwita.lt.0) then - print *,'Processor',MyID, - & ' has received STOP signal =',Kwita,' in EntSamp.' -cd print *,'not_done=',not_done - if (Kwita.lt.-1) WhatsUp=Kwita - if (MyID.ne.MasterID) call send_MCM_info(-1) - else if (nacc_tot.ge.maxacc) then - print *,'Processor',MyID,' calls send_stop_sig,', - & ' because a sufficient # of confs. have been collected.' -cd print *,'not_done=',not_done - call send_stop_sig(-1) - if (MyID.ne.MasterID) call send_MCM_info(-1) - else if (WhatsUp.eq.-1) then - print *,'Processor',MyID, - & ' calls send_stop_sig because of timeout.' -cd print *,'not_done=',not_done - call send_stop_sig(-2) - if (MyID.ne.MasterID) call send_MCM_info(-1) - endif -#endif - enddo ! not_done - -C----------------------------------------------------------------- -C... Construct energy histogram & update entropy -C----------------------------------------------------------------- - go to 21 - 20 WhatsUp=-3 -#ifdef MPL - write (iout,*) 'Processor',MyID, - & ' is broadcasting ERROR-STOP signal.' - write (*,*) 'Processor',MyID, - & ' is broadcasting ERROR-STOP signal.' - call send_stop_sig(-3) - if (MyID.ne.MasterID) call send_MCM_info(-1) -#endif - 21 continue - write (iout,'(/a)') 'Energy histogram' - do i=-100,100 - write (iout,'(i5,2f20.5)') i,emin+i*delte,nhist(i) - enddo -#ifdef MPL -C Wait until every processor has sent complete MC info. - if (MyID.eq.MasterID) then - not_done=.true. - do while (not_done) -C write (*,*) 'The IFINISH array:' -C write (*,*) (ifinish(i),i=1,nctasks) - not_done=.false. - do i=2,nctasks - not_done=not_done.or.(ifinish(i).ge.0) - enddo - if (not_done) call receive_MC_info - enddo - endif -C Make collective histogram from the work of all processors. - msglen=(2*max_ene+1)*8 - print *, - & 'Processor',MyID,' calls MP_REDUCE to send/receive histograms', - & ' msglen=',msglen - call mp_reduce(nhist,nhist1,msglen,MasterID,d_vadd, - & cgGroupID) - print *,'Processor',MyID,' MP_REDUCE accomplished for histogr.' - do i=-max_ene,max_ene - nhist(i)=nhist1(i) - enddo -C Collect min. and max. energy - print *, - &'Processor',MyID,' calls MP_REDUCE to send/receive energy borders' - call mp_reduce(elowest,elowest1,8,MasterID,d_vmin,cgGroupID) - call mp_reduce(ehighest,ehighest1,8,MasterID,d_vmax,cgGroupID) - print *,'Processor',MyID,' MP_REDUCE accomplished for energies.' - IF (MyID.eq.MasterID) THEN - elowest=elowest1 - ehighest=ehighest1 -#endif - write (iout,'(a,i10)') '# of accepted confs:',nacc_tot - write (iout,'(a,f10.5,a,f10.5)') 'Lowest energy:',elowest, - & ' Highest energy',ehighest - indmin=icialosc((elowest-emin)/delte) - imdmax=icialosc((ehighest-emin)/delte) - if (indmin.lt.indminn) then - emax=emin+indmin*delte+e_up - indmaxx=indmin+nbins - indminn=indmin - endif - if (.not.ent_read) ent_read=.true. - write(iout,*)'indminn=',indminn,' indmaxx=',indmaxx -C Update entropy (density of states) - do i=indmin,indmax - if (nhist(i).gt.0) then - entropy(i)=entropy(i)+dlog(nhist(i)+0.0D0) - endif - enddo - write (iout,'(/80(1h*)/a,i2/80(1h*)/)') - & 'End of macroiteration',isweep - write (iout,'(a,f10.5,a,f10.5)') 'Elowest=',elowest, - & ' Ehighest=',ehighest - write (iout,'(/a)') 'Energy histogram' - do i=indminn,indmaxx - write (iout,'(i5,2f20.5)') i,emin+i*delte,nhist(i) - enddo - write (iout,'(/a)') 'Entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f20.5)') i,emin+i*delte,entropy(i) - enddo -C----------------------------------------------------------------- -C... End of energy histogram construction -C----------------------------------------------------------------- -#ifdef MPL - ELSE - if (.not. ent_read) ent_read=.true. - ENDIF ! MyID .eq. MaterID - if (MyID.eq.MasterID) then - itemp(1)=indminn - itemp(2)=indmaxx - endif - print *,'before mp_bcast processor',MyID,' indminn=',indminn, - & ' indmaxx=',indmaxx,' itemp=',itemp(1),itemp(2) - call mp_bcast(itemp(1),8,MasterID,cgGroupID) - call mp_bcast(emax,8,MasterID,cgGroupID) - print *,'after mp_bcast processor',MyID,' indminn=',indminn, - & ' indmaxx=',indmaxx,' itemp=',itemp(1),itemp(2) - if (MyID .ne. MasterID) then - indminn=itemp(1) - indmaxx=itemp(2) - endif - msglen=(indmaxx-indminn+1)*8 - print *,'processor',MyID,' calling mp_bcast msglen=',msglen, - & ' indminn=',indminn,' indmaxx=',indmaxx,' isweep=',isweep - call mp_bcast(entropy(indminn),msglen,MasterID,cgGroupID) - IF(MyID.eq.MasterID .and. .not. ovrtim() .and. WhatsUp.ge.0)THEN - open (ientout,file=entname,status='unknown') - write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax - do i=indminn,indmaxx - write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) - enddo - close(ientout) - ELSE - write (iout,*) 'Received from master:' - write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx, - & ' emin=',emin,' emax=',emax - write (iout,'(/a)') 'Entropy' - do i=indminn,indmaxx - write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) - enddo - ENDIF ! MyID.eq.MasterID - print *,'Processor',MyID,' calls MP_GATHER' - call mp_gather(nbond_move,nbond_move1,4*Nbm,MasterID, - & cgGroupID) - call mp_gather(nbond_acc,nbond_acc1,4*Nbm,MasterID, - & cgGroupID) - print *,'Processor',MyID,' MP_GATHER call accomplished' - if (MyID.eq.MasterID) then - - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc_tot,nfun,iretcode,etot,elowest) - write (iout,'(a)') - & 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(8i10)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(8i10)') (nbond_acc(i),i=1,Nbm) - - write (iout,'(a)') - & 'Statistics of multi-bond moves of respective processors:' - do iproc=1,Nprocs-1 - do i=1,Nbm - ind=iproc*nbm+i - nbond_move(i)=nbond_move(i)+nbond_move1(ind) - nbond_acc(i)=nbond_acc(i)+nbond_acc1(ind) - enddo - enddo - do iproc=0,NProcs-1 - write (iout,*) 'Processor',iproc,' nbond_move:', - & (nbond_move1(iproc*nbm+i),i=1,Nbm), - & ' nbond_acc:',(nbond_acc1(iproc*nbm+i),i=1,Nbm) - enddo - endif - call mp_gather(moves,moves1,4*(MaxMoveType+3),MasterID, - & cgGroupID) - call mp_gather(moves_acc,moves_acc1,4*(MaxMoveType+3), - & MasterID,cgGroupID) - if (MyID.eq.MasterID) then - do iproc=1,Nprocs-1 - do i=-1,MaxMoveType+1 - moves(i)=moves(i)+moves1(i,iproc) - moves_acc(i)=moves_acc(i)+moves_acc1(i,iproc) - enddo - enddo - nmove=0 - do i=0,MaxMoveType+1 - nmove=nmove+moves(i) - enddo - do iproc=0,NProcs-1 - write (iout,*) 'Processor',iproc,' moves', - & (moves1(i,iproc),i=0,MaxMoveType+1), - & ' moves_acc:',(moves_acc1(i,iproc),i=0,MaxMoveType+1) - enddo - endif -#else - open (ientout,file=entname,status='unknown') - write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax - do i=indminn,indmaxx - write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) - enddo - close(ientout) -#endif - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc_tot,nfun,iretcode,etot,elowest) - write (iout,'(a)') - & 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(8i10)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(8i10)') (nbond_acc(i),i=1,Nbm) - if (ovrtim() .or. WhatsUp.lt.0) return - -C--------------------------------------------------------------------------- - ENDDO ! ISWEEP -C--------------------------------------------------------------------------- - - runtime=tcpu() - - if (isweep.eq.nsweep .and. it.ge.maxacc) - &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' - return - end -c------------------------------------------------------------------------------ - subroutine accept_mc(it,ecur,eold,scur,sold,x,xold,accepted) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' -#ifdef MPL - include 'COMMON.INFO' -#endif - include 'COMMON.GEO' - double precision ecur,eold,xx,ran_number,bol - double precision x(maxvar),xold(maxvar) - logical accepted -C Check if the conformation is similar. -cd write (iout,*) 'Enter ACCEPTING' -cd write (iout,*) 'Old PHI angles:' -cd write (iout,*) (rad2deg*xold(i),i=1,nphi) -cd write (iout,*) 'Current angles' -cd write (iout,*) (rad2deg*x(i),i=1,nphi) -cd ddif=dif_ang(nphi,x,xold) -cd write (iout,*) 'Angle norm:',ddif -cd write (iout,*) 'ecur=',ecur,' emax=',emax - if (ecur.gt.emax) then - accepted=.false. - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a)') 'Conformation rejected as too high in energy' - return - endif -C Else evaluate the entropy of the conf and compare it with that of the previous -C one. - call entropia(ecur,scur,indecur) -cd print *,'Processor',MyID,' ecur=',ecur,' indecur=',indecur, -cd & ' scur=',scur,' eold=',eold,' sold=',sold -cd print *,'deix=',deix,' dent=',dent,' delte=',delte - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) then - write(iout,*)'it=',it,'ecur=',ecur,' indecur=',indecur, - & ' scur=',scur - write(iout,*)'eold=',eold,' sold=',sold - endif - if (scur.le.sold) then - accepted=.true. - else -C Else carry out acceptance test - xx=ran_number(0.0D0,1.0D0) - xxh=scur-sold - if (xxh.gt.50.0D0) then - bol=0.0D0 - else - bol=exp(-xxh) - endif - if (bol.gt.xx) then - accepted=.true. - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a)') 'Conformation accepted.' - else - accepted=.false. - if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) - & write (iout,'(a)') 'Conformation rejected.' - endif - endif - return - end -c-------------------------------------------------------------------------- - integer function icialosc(x) - double precision x - if (x.lt.0.0D0) then - icialosc=dint(x)-1 - else - icialosc=dint(x) - endif - return - end -c-------------------------------------------------------------------------- - subroutine entropia(ecur,scur,indecur) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.IOUNITS' - double precision ecur,scur - integer indecur - indecur=icialosc((ecur-emin)/delte) - if (iabs(indecur).gt.max_ene) then - if ((it/print_freq)*it.eq.it) write (iout,'(a,2i5)') - & 'Accepting: Index out of range:',indecur - scur=1000.0D0 - else if (indecur.ge.indmaxx) then - scur=entropy(indecur) - if (print_mc.gt.0 .and. (it/print_freq)*it.eq.it) - & write (iout,*)'Energy boundary reached', - & indmaxx,indecur,entropy(indecur) - else - deix=ecur-(emin+indecur*delte) - dent=entropy(indecur+1)-entropy(indecur) - scur=entropy(indecur)+(dent/delte)*deix - endif - return - end diff --git a/source/unres/src_MD_DFA/mcm.F b/source/unres/src_MD_DFA/mcm.F deleted file mode 100644 index d9ca9ad..0000000 --- a/source/unres/src_MD_DFA/mcm.F +++ /dev/null @@ -1,1481 +0,0 @@ - subroutine mcm_setup - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.MCM' - include 'COMMON.CONTROL' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.VAR' -C -C Set up variables used in MC/MCM. -C - write (iout,'(80(1h*)/20x,a/80(1h*))') 'MCM control parameters:' - write (iout,'(5(a,i7))') 'Maxacc:',maxacc,' MaxTrial:',MaxTrial, - & ' MaxRepm:',MaxRepm,' MaxGen:',MaxGen,' MaxOverlap:',MaxOverlap - write (iout,'(4(a,f8.1)/2(a,i3))') - & 'Tmin:',Tmin,' Tmax:',Tmax,' TstepH:',TstepH, - & ' TstepC:',TstepC,'NstepH:',NstepH,' NstepC:',NstepC - if (nwindow.gt.0) then - write (iout,'(a)') 'Perturbation windows:' - do i=1,nwindow - i1=winstart(i) - i2=winend(i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(a,i3,a,i3,a,i3)') restyp(it1),i1,restyp(it2),i2, - & ' length',winlen(i) - enddo - endif -C Rbolt=8.3143D-3*2.388459D-01 kcal/(mol*K) - RBol=1.9858D-3 -C Number of "end bonds". - koniecl=0 -c koniecl=nphi - print *,'koniecl=',koniecl - write (iout,'(a)') 'Probabilities of move types:' - write (*,'(a)') 'Probabilities of move types:' - do i=1,MaxMoveType - write (iout,'(a,f10.5)') MovTypID(i), - & sumpro_type(i)-sumpro_type(i-1) - write (*,'(a,f10.5)') MovTypID(i), - & sumpro_type(i)-sumpro_type(i-1) - enddo - write (iout,*) -C Maximum length of N-bond segment to be moved -c nbm=nres-1-(2*koniecl-1) - if (nwindow.gt.0) then - maxwinlen=winlen(1) - do i=2,nwindow - if (winlen(i).gt.maxwinlen) maxwinlen=winlen(i) - enddo - nbm=min0(maxwinlen,6) - write (iout,'(a,i3,a,i3)') 'Nbm=',Nbm,' Maxwinlen=',Maxwinlen - else - nbm=min0(6,nres-2) - endif - sumpro_bond(0)=0.0D0 - sumpro_bond(1)=0.0D0 - do i=2,nbm - sumpro_bond(i)=sumpro_bond(i-1)+1.0D0/dfloat(i) - enddo - write (iout,'(a)') 'The SumPro_Bond array:' - write (iout,'(8f10.5)') (sumpro_bond(i),i=1,nbm) - write (*,'(a)') 'The SumPro_Bond array:' - write (*,'(8f10.5)') (sumpro_bond(i),i=1,nbm) -C Maximum number of side chains moved simultaneously -c print *,'nnt=',nnt,' nct=',nct - ngly=0 - do i=nnt,nct - if (itype(i).eq.10) ngly=ngly+1 - enddo - mmm=nct-nnt-ngly+1 - if (mmm.gt.0) then - MaxSideMove=min0((nct-nnt+1)/2,mmm) - endif -c print *,'MaxSideMove=',MaxSideMove -C Max. number of generated confs (not used at present). - maxgen=10000 -C Set initial temperature - Tcur=Tmin - betbol=1.0D0/(Rbol*Tcur) - write (iout,'(a,f8.1,a,f10.5)') 'Initial temperature:',Tcur, - & ' BetBol:',betbol - write (iout,*) 'RanFract=',ranfract - return - end -c------------------------------------------------------------------------------ -#ifndef MPI - subroutine do_mcm(i_orig) -C Monte-Carlo-with-Minimization calculations - serial code. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.MCM' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.CACHE' -crc include 'COMMON.DEFORM' -crc include 'COMMON.DEFORM1' - include 'COMMON.NAMES' - logical accepted,over,ovrtim,error,lprint,not_done,my_conf, - & enelower,non_conv - integer MoveType,nbond,conf_comp - integer ifeed(max_cache) - double precision varia(maxvar),varold(maxvar),elowest,eold, - & przes(3),obr(3,3) - double precision energia(0:n_ene) - double precision coord1(maxres,3) - -C--------------------------------------------------------------------------- -C Initialize counters. -C--------------------------------------------------------------------------- -C Total number of generated confs. - ngen=0 -C Total number of moves. In general this won't be equal to the number of -C attempted moves, because we may want to reject some "bad" confs just by -C overlap check. - nmove=0 -C Total number of temperature jumps. - ntherm=0 -C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... -C motions. - ncache=0 - do i=1,nres - nbond_move(i)=0 - enddo -C Initialize total and accepted number of moves of various kind. - do i=0,MaxMoveType - moves(i)=0 - moves_acc(i)=0 - enddo -C Total number of energy evaluations. - neneval=0 - nfun=0 - nsave=0 - - write (iout,*) 'RanFract=',RanFract - - WhatsUp=0 - Kwita=0 - -c---------------------------------------------------------------------------- -C Compute and print initial energies. -c---------------------------------------------------------------------------- - call intout - write (iout,'(/80(1h*)/a)') 'Initial energies:' - call chainbuild - nf=0 - - call etotal(energia(0)) - etot = energia(0) -C Minimize the energy of the first conformation. - if (minim) then - call geom_to_var(nvar,varia) -! write (iout,*) 'The VARIA array' -! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) - call minimize(etot,varia,iretcode,nfun) - call var_to_geom(nvar,varia) - call chainbuild - write (iout,*) 'etot from MINIMIZE:',etot -! write (iout,*) 'Tha VARIA array' -! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) - - call etotal(energia(0)) - etot=energia(0) - call enerprint(energia(0)) - endif - if (refstr) then - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes, - & obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order:',co - if (print_stat) - & write (istat,'(i5,17(1pe14.5))') 0, - & (energia(print_order(i)),i=1,nprint_ene), - & etot,rms,frac,co - else - if (print_stat) write (istat,'(i5,16(1pe14.5))') 0, - & (energia(print_order(i)),i=1,nprint_ene),etot - endif - if (print_stat) close(istat) - neneval=neneval+nfun+1 - write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Enter Monte Carlo procedure.' - if (print_int) then - close(igeom) - call briefout(0,etot) - endif - eold=etot - do i=1,nvar - varold(i)=varia(i) - enddo - elowest=etot - call zapis(varia,etot) - nacc=0 ! total # of accepted confs of the current processor. - nacc_tot=0 ! total # of accepted confs of all processors. - - not_done = (iretcode.ne.11) - -C---------------------------------------------------------------------------- -C Main loop. -c---------------------------------------------------------------------------- - it=0 - nout=0 - do while (not_done) - it=it+1 - write (iout,'(80(1h*)/20x,a,i7)') - & 'Beginning iteration #',it -C Initialize local counter. - ntrial=0 ! # of generated non-overlapping confs. - accepted=.false. - do while (.not. accepted) - -C Retrieve the angles of previously accepted conformation - noverlap=0 ! # of overlapping confs. - do j=1,nvar - varia(j)=varold(j) - enddo - call var_to_geom(nvar,varia) -C Rebuild the chain. - call chainbuild -C Heat up the system, if necessary. - call heat(over) -C If temperature cannot be further increased, stop. - if (over) goto 20 - MoveType=0 - nbond=0 - lprint=.true. -cd write (iout,'(a)') 'Old variables:' -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) -C Decide whether to generate a random conformation or perturb the old one - RandOrPert=ran_number(0.0D0,1.0D0) - if (RandOrPert.gt.RanFract) then - if (print_mc.gt.0) - & write (iout,'(a)') 'Perturbation-generated conformation.' - call perturb(error,lprint,MoveType,nbond,1.0D0) - if (error) goto 20 - if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then - write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=', - & MoveType,' returned from PERTURB.' - goto 20 - endif - call chainbuild - else - MoveType=0 - moves(0)=moves(0)+1 - nstart_grow=iran_num(3,nres) - if (print_mc.gt.0) - & write (iout,'(2a,i3)') 'Random-generated conformation', - & ' - chain regrown from residue',nstart_grow - call gen_rand_conf(nstart_grow,*30) - endif - call geom_to_var(nvar,varia) -cd write (iout,'(a)') 'New variables:' -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - ngen=ngen+1 - - call etotal(energia(0)) - etot=energia(0) -c call enerprint(energia(0)) -c write (iout,'(2(a,1pe14.5))') 'Etot=',Etot,' Elowest=',Elowest - if (etot-elowest.gt.overlap_cut) then - if(iprint.gt.1.or.etot.lt.1d20) - & write (iout,'(a,1pe14.5)') - & 'Overlap detected in the current conf.; energy is',etot - neneval=neneval+1 - accepted=.false. - noverlap=noverlap+1 - if (noverlap.gt.maxoverlap) then - write (iout,'(a)') 'Too many overlapping confs.' - goto 20 - endif - else - if (minim) then - call minimize(etot,varia,iretcode,nfun) -cd write (iout,*) 'etot from MINIMIZE:',etot -cd write (iout,'(a)') 'Variables after minimization:' -cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) - - call etotal(energia(0)) - etot = energia(0) - neneval=neneval+nfun+2 - endif -c call enerprint(energia(0)) - write (iout,'(a,i6,a,1pe16.6)') 'Conformation:',ngen, - & ' energy:',etot -C-------------------------------------------------------------------------- -C... Do Metropolis test -C-------------------------------------------------------------------------- - accepted=.false. - my_conf=.false. - - if (WhatsUp.eq.0 .and. Kwita.eq.0) then - call metropolis(nvar,varia,varold,etot,eold,accepted, - & my_conf,EneLower) - endif - write (iout,*) 'My_Conf=',My_Conf,' EneLower=',EneLower - if (accepted) then - - nacc=nacc+1 - nacc_tot=nacc_tot+1 - if (elowest.gt.etot) elowest=etot - moves_acc(MoveType)=moves_acc(MoveType)+1 - if (MoveType.eq.1) then - nbond_acc(nbond)=nbond_acc(nbond)+1 - endif -C Check against conformation repetitions. - irepet=conf_comp(varia,etot) - if (print_stat) then -#if defined(AIX) || defined(PGI) - open (istat,file=statname,position='append') -#else - open (istat,file=statname,access='append') -#endif - endif - call statprint(nacc,nfun,iretcode,etot,elowest) - if (refstr) then - call var_to_geom(nvar,varia) - call chainbuild - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup), - & nsup,przes,obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order',co - endif ! refstr - if (My_Conf) then - nout=nout+1 - write (iout,*) 'Writing new conformation',nout - if (refstr) then - write (istat,'(i5,16(1pe14.5))') nout, - & (energia(print_order(i)),i=1,nprint_ene), - & etot,rms,frac - else - if (print_stat) - & write (istat,'(i5,17(1pe14.5))') nout, - & (energia(print_order(i)),i=1,nprint_ene),etot - endif ! refstr - if (print_stat) close(istat) -C Print internal coordinates. - if (print_int) call briefout(nout,etot) -C Accumulate the newly accepted conf in the coord1 array, if it is different -C from all confs that are already there. - call compare_s1(n_thr,max_thread2,etot,varia,ii, - & enetb1,coord1,rms_deform,.true.,iprint) - write (iout,*) 'After compare_ss: n_thr=',n_thr - if (ii.eq.1 .or. ii.eq.3) then - write (iout,'(8f10.4)') - & (rad2deg*coord1(i,n_thr),i=1,nvar) - endif - else - write (iout,*) 'Conformation from cache, not written.' - endif ! My_Conf - - if (nrepm.gt.maxrepm) then - write (iout,'(a)') 'Too many conformation repetitions.' - goto 20 - endif -C Store the accepted conf. and its energy. - eold=etot - do i=1,nvar - varold(i)=varia(i) - enddo - if (irepet.eq.0) call zapis(varia,etot) -C Lower the temperature, if necessary. - call cool - - else - - ntrial=ntrial+1 - endif ! accepted - endif ! overlap - - 30 continue - enddo ! accepted -C Check for time limit. - if (ovrtim()) WhatsUp=-1 - not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) - & .and. (Kwita.eq.0) - - enddo ! not_done - goto 21 - 20 WhatsUp=-3 - - 21 continue - runtime=tcpu() - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc,nfun,iretcode,etot,elowest) - write (iout,'(a)') - & 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) - if (it.ge.maxacc) - &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' - - return - end -#endif -#ifdef MPI -c------------------------------------------------------------------------------ - subroutine do_mcm(i_orig) -C Monte-Carlo-with-Minimization calculations - parallel code. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.MCM' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.INFO' - include 'COMMON.CACHE' -crc include 'COMMON.DEFORM' -crc include 'COMMON.DEFORM1' -crc include 'COMMON.DEFORM2' - include 'COMMON.MINIM' - include 'COMMON.NAMES' - logical accepted,over,ovrtim,error,lprint,not_done,similar, - & enelower,non_conv,flag,finish - integer MoveType,nbond,conf_comp - double precision varia(maxvar),varold(maxvar),elowest,eold, - & x1(maxvar), varold1(maxvar), przes(3),obr(3,3) - integer iparentx(max_threadss2) - integer iparentx1(max_threadss2) - integer imtasks(150),imtasks_n - double precision energia(0:n_ene) - - print *,'Master entered DO_MCM' - nodenum = nprocs - - finish=.false. - imtasks_n=0 - do i=1,nodenum-1 - imtasks(i)=0 - enddo -C--------------------------------------------------------------------------- -C Initialize counters. -C--------------------------------------------------------------------------- -C Total number of generated confs. - ngen=0 -C Total number of moves. In general this won`t be equal to the number of -C attempted moves, because we may want to reject some "bad" confs just by -C overlap check. - nmove=0 -C Total number of temperature jumps. - ntherm=0 -C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... -C motions. - ncache=0 - do i=1,nres - nbond_move(i)=0 - enddo -C Initialize total and accepted number of moves of various kind. - do i=0,MaxMoveType - moves(i)=0 - moves_acc(i)=0 - enddo -C Total number of energy evaluations. - neneval=0 - nfun=0 - nsave=0 -c write (iout,*) 'RanFract=',RanFract - WhatsUp=0 - Kwita=0 -c---------------------------------------------------------------------------- -C Compute and print initial energies. -c---------------------------------------------------------------------------- - call intout - write (iout,'(/80(1h*)/a)') 'Initial energies:' - call chainbuild - nf=0 - call etotal(energia(0)) - etot = energia(0) - call enerprint(energia(0)) -C Request energy computation from slave processors. - call geom_to_var(nvar,varia) -! write (iout,*) 'The VARIA array' -! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) - call minimize(etot,varia,iretcode,nfun) - call var_to_geom(nvar,varia) - call chainbuild - write (iout,*) 'etot from MINIMIZE:',etot -! write (iout,*) 'Tha VARIA array' -! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) - neneval=0 - eneglobal=1.0d99 - if (print_mc .gt. 0) write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Enter Monte Carlo procedure.' - if (print_mc .gt. 0) write (iout,'(i5,1pe14.5)' ) i_orig,etot - eold=etot - do i=1,nvar - varold(i)=varia(i) - enddo - elowest=etot - call zapis(varia,etot) -c diagnostics - call var_to_geom(nvar,varia) - call chainbuild - call etotal(energia(0)) - if (print_mc.gt.0) write (iout,*) 'Initial energy:',etot -c end diagnostics - nacc=0 ! total # of accepted confs of the current processor. - nacc_tot=0 ! total # of accepted confs of all processors. - not_done=.true. -C---------------------------------------------------------------------------- -C Main loop. -c---------------------------------------------------------------------------- - it=0 - nout=0 - LOOP1:do while (not_done) - it=it+1 - if (print_mc.gt.0) write (iout,'(80(1h*)/20x,a,i7)') - & 'Beginning iteration #',it -C Initialize local counter. - ntrial=0 ! # of generated non-overlapping confs. - noverlap=0 ! # of overlapping confs. - accepted=.false. - LOOP2:do while (.not. accepted) - - LOOP3:do while (imtasks_n.lt.nodenum-1.and..not.finish) - do i=1,nodenum-1 - if(imtasks(i).eq.0) then - is=i - exit - endif - enddo -C Retrieve the angles of previously accepted conformation - do j=1,nvar - varia(j)=varold(j) - enddo - call var_to_geom(nvar,varia) -C Rebuild the chain. - call chainbuild -C Heat up the system, if necessary. - call heat(over) -C If temperature cannot be further increased, stop. - if (over) then - finish=.true. - endif - MoveType=0 - nbond=0 -c write (iout,'(a)') 'Old variables:' -c write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) -C Decide whether to generate a random conformation or perturb the old one - RandOrPert=ran_number(0.0D0,1.0D0) - if (RandOrPert.gt.RanFract) then - if (print_mc.gt.0) - & write (iout,'(a)') 'Perturbation-generated conformation.' - call perturb(error,lprint,MoveType,nbond,1.0D0) -c print *,'after perturb',error,finish - if (error) finish = .true. - if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then - write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=', - & MoveType,' returned from PERTURB.' - finish=.true. - write (*,'(/a,i7,a/)') 'Error - unknown MoveType=', - & MoveType,' returned from PERTURB.' - endif - call chainbuild - else - MoveType=0 - moves(0)=moves(0)+1 - nstart_grow=iran_num(3,nres) - if (print_mc.gt.0) - & write (iout,'(2a,i3)') 'Random-generated conformation', - & ' - chain regrown from residue',nstart_grow - call gen_rand_conf(nstart_grow,*30) - endif - call geom_to_var(nvar,varia) - ngen=ngen+1 -c print *,'finish=',finish - if (etot-elowest.gt.overlap_cut) then - if (print_mc.gt.1) write (iout,'(a,1pe14.5)') - & 'Overlap detected in the current conf.; energy is',etot - if(iprint.gt.1.or.etot.lt.1d19) print *, - & 'Overlap detected in the current conf.; energy is',etot - neneval=neneval+1 - accepted=.false. - noverlap=noverlap+1 - if (noverlap.gt.maxoverlap) then - write (iout,*) 'Too many overlapping confs.', - & ' etot, elowest, overlap_cut', etot, elowest, overlap_cut - finish=.true. - endif - else if (.not. finish) then -C Distribute tasks to processors -c print *,'Master sending order' - call MPI_SEND(12, 1, MPI_INTEGER, is, tag, - & CG_COMM, ierr) -c write (iout,*) '12: tag=',tag -c print *,'Master sent order to processor',is - call MPI_SEND(it, 1, MPI_INTEGER, is, tag, - & CG_COMM, ierr) -c write (iout,*) 'it: tag=',tag - call MPI_SEND(eold, 1, MPI_DOUBLE_PRECISION, is, tag, - & CG_COMM, ierr) -c write (iout,*) 'eold: tag=',tag - call MPI_SEND(varia(1), nvar, MPI_DOUBLE_PRECISION, - & is, tag, - & CG_COMM, ierr) -c write (iout,*) 'varia: tag=',tag - call MPI_SEND(varold(1), nvar, MPI_DOUBLE_PRECISION, - & is, tag, - & CG_COMM, ierr) -c write (iout,*) 'varold: tag=',tag -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - imtasks(is)=1 - imtasks_n=imtasks_n+1 -C End distribution - endif ! overlap - enddo LOOP3 - - flag = .false. - LOOP_RECV:do while(.not.flag) - do is=1, nodenum-1 - call MPI_IPROBE(is,tag,CG_COMM,flag,status,ierr) - if(flag) then - call MPI_RECV(iitt, 1, MPI_INTEGER, is, tag, - & CG_COMM, status, ierr) - call MPI_RECV(eold1, 1, MPI_DOUBLE_PRECISION, is, tag, - & CG_COMM, status, ierr) - call MPI_RECV(etot, 1, MPI_DOUBLE_PRECISION, is, tag, - & CG_COMM, status, ierr) - call MPI_RECV(varia(1), nvar, MPI_DOUBLE_PRECISION,is,tag, - & CG_COMM, status, ierr) - call MPI_RECV(varold1(1), nvar, MPI_DOUBLE_PRECISION, is, - & tag, CG_COMM, status, ierr) - call MPI_RECV(ii_grnum_d, 1, MPI_INTEGER, is, tag, - & CG_COMM, status, ierr) - call MPI_RECV(ii_ennum_d, 1, MPI_INTEGER, is, tag, - & CG_COMM, status, ierr) - call MPI_RECV(ii_hesnum_d, 1, MPI_INTEGER, is, tag, - & CG_COMM, status, ierr) - i_grnum_d=i_grnum_d+ii_grnum_d - i_ennum_d=i_ennum_d+ii_ennum_d - neneval = neneval+ii_ennum_d - i_hesnum_d=i_hesnum_d+ii_hesnum_d - i_minimiz=i_minimiz+1 - imtasks(is)=0 - imtasks_n=imtasks_n-1 - exit - endif - enddo - enddo LOOP_RECV - - if(print_mc.gt.0) write (iout,'(a,i6,a,i6,a,i6,a,1pe16.6)') - & 'From Worker #',is,' iitt',iitt, - & ' Conformation:',ngen,' energy:',etot -C-------------------------------------------------------------------------- -C... Do Metropolis test -C-------------------------------------------------------------------------- - call metropolis(nvar,varia,varold1,etot,eold1,accepted, - & similar,EneLower) - if(iitt.ne.it.and..not.similar) then - call metropolis(nvar,varia,varold,etot,eold,accepted, - & similar,EneLower) - accepted=enelower - endif - if(etot.lt.eneglobal)eneglobal=etot -c if(mod(it,100).eq.0) - write(iout,*)'CHUJOJEB ',neneval,eneglobal - if (accepted) then -C Write the accepted conformation. - nout=nout+1 - if (refstr) then - call var_to_geom(nvar,varia) - call chainbuild - call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup), - & nsup,przes,obr,non_conv) - rms=dsqrt(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - write (iout,'(a,f8.3,a,f8.3,a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100,' contact order:',co - endif ! refstr - if (print_mc.gt.0) - & write (iout,*) 'Writing new conformation',nout - if (print_stat) then - call var_to_geom(nvar,varia) -#if defined(AIX) || defined(PGI) - open (istat,file=statname,position='append') -#else - open (istat,file=statname,access='append') -#endif - if (refstr) then - write (istat,'(i5,16(1pe14.5))') nout, - & (energia(print_order(i)),i=1,nprint_ene), - & etot,rms,frac - else - write (istat,'(i5,16(1pe14.5))') nout, - & (energia(print_order(i)),i=1,nprint_ene),etot - endif ! refstr - close(istat) - endif ! print_stat -C Print internal coordinates. - if (print_int) call briefout(nout,etot) - nacc=nacc+1 - nacc_tot=nacc_tot+1 - if (elowest.gt.etot) elowest=etot - moves_acc(MoveType)=moves_acc(MoveType)+1 - if (MoveType.eq.1) then - nbond_acc(nbond)=nbond_acc(nbond)+1 - endif -C Check against conformation repetitions. - irepet=conf_comp(varia,etot) - if (nrepm.gt.maxrepm) then - if (print_mc.gt.0) - & write (iout,'(a)') 'Too many conformation repetitions.' - finish=.true. - endif -C Store the accepted conf. and its energy. - eold=etot - do i=1,nvar - varold(i)=varia(i) - enddo - if (irepet.eq.0) call zapis(varia,etot) -C Lower the temperature, if necessary. - call cool - else - ntrial=ntrial+1 - endif ! accepted - 30 continue - if(finish.and.imtasks_n.eq.0)exit LOOP2 - enddo LOOP2 ! accepted -C Check for time limit. - not_done = (it.lt.max_mcm_it) .and. (nacc_tot.lt.maxacc) - if(.not.not_done .or. finish) then - if(imtasks_n.gt.0) then - not_done=.true. - else - not_done=.false. - endif - finish=.true. - endif - enddo LOOP1 ! not_done - runtime=tcpu() - if (print_mc.gt.0) then - write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' - call statprint(nacc,nfun,iretcode,etot,elowest) - write (iout,'(a)') - & 'Statistics of multiple-bond motions. Total motions:' - write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) - write (iout,'(a)') 'Accepted motions:' - write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) - if (it.ge.maxacc) - &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' - endif -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - do is=1,nodenum-1 - call MPI_SEND(999, 1, MPI_INTEGER, is, tag, - & CG_COMM, ierr) - enddo - return - end -c------------------------------------------------------------------------------ - subroutine execute_slave(nodeinfo,iprint) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.TIME1' - include 'COMMON.IOUNITS' -crc include 'COMMON.DEFORM' -crc include 'COMMON.DEFORM1' -crc include 'COMMON.DEFORM2' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.INFO' - include 'COMMON.MINIM' - character*10 nodeinfo - double precision x(maxvar),x1(maxvar) - nodeinfo='chujwdupe' -c print *,'Processor:',MyID,' Entering execute_slave' - tag=0 -c call MPI_SEND(nodeinfo, 10, MPI_CHARACTER, 0, tag, -c & CG_COMM, ierr) - -1001 call MPI_RECV(i_switch, 1, MPI_INTEGER, 0, tag, - & CG_COMM, status, ierr) -c write(iout,*)'12: tag=',tag - if(iprint.ge.2)print *, MyID,' recv order ',i_switch - if (i_switch.eq.12) then - i_grnum_d=0 - i_ennum_d=0 - i_hesnum_d=0 - call MPI_RECV(iitt, 1, MPI_INTEGER, 0, tag, - & CG_COMM, status, ierr) -c write(iout,*)'12: tag=',tag - call MPI_RECV(ener, 1, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, status, ierr) -c write(iout,*)'ener: tag=',tag - call MPI_RECV(x(1), nvar, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, status, ierr) -c write(iout,*)'x: tag=',tag - call MPI_RECV(x1(1), nvar, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, status, ierr) -c write(iout,*)'x1: tag=',tag -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif -c print *,'calling minimize' - call minimize(energyx,x,iretcode,nfun) - if(iprint.gt.0) - & write(iout,100)'minimized energy = ',energyx, - & ' # funeval:',nfun,' iret ',iretcode - write(*,100)'minimized energy = ',energyx, - & ' # funeval:',nfun,' iret ',iretcode - 100 format(a20,f10.5,a12,i5,a6,i2) - if(iretcode.eq.10) then - do iminrep=2,3 - if(iprint.gt.1) - & write(iout,*)' ... not converged - trying again ',iminrep - call minimize(energyx,x,iretcode,nfun) - if(iprint.gt.1) - & write(iout,*)'minimized energy = ',energyx, - & ' # funeval:',nfun,' iret ',iretcode - if(iretcode.ne.10)go to 812 - enddo - if(iretcode.eq.10) then - if(iprint.gt.1) - & write(iout,*)' ... not converged again - giving up' - go to 812 - endif - endif -812 continue -c print *,'Sending results' - call MPI_SEND(iitt, 1, MPI_INTEGER, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(ener, 1, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(energyx, 1, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(x(1), nvar, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(x1(1), nvar, MPI_DOUBLE_PRECISION, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(i_grnum_d, 1, MPI_INTEGER, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(nfun, 1, MPI_INTEGER, 0, tag, - & CG_COMM, ierr) - call MPI_SEND(i_hesnum_d, 1, MPI_INTEGER, 0, tag, - & CG_COMM, ierr) -c print *,'End sending' - go to 1001 - endif - - return - end -#endif -c------------------------------------------------------------------------------ - subroutine statprint(it,nfun,iretcode,etot,elowest) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'COMMON.MCM' - if (minim) then - write (iout, - & '(80(1h*)/a,i5,a,1pe14.5,a,1pe14.5/a,i3,a,i10,a,i5,a,i5)') - & 'Finished iteration #',it,' energy is',etot, - & ' lowest energy:',elowest, - & 'SUMSL return code:',iretcode, - & ' # of energy evaluations:',neneval, - & '# of temperature jumps:',ntherm, - & ' # of minima repetitions:',nrepm - else - write (iout,'(80(1h*)/a,i8,a,1pe14.5,a,1pe14.5)') - & 'Finished iteration #',it,' energy is',etot, - & ' lowest energy:',elowest - endif - write (iout,'(/4a)') - & 'Kind of move ',' total',' accepted', - & ' fraction' - write (iout,'(58(1h-))') - do i=-1,MaxMoveType - if (moves(i).eq.0) then - fr_mov_i=0.0d0 - else - fr_mov_i=dfloat(moves_acc(i))/dfloat(moves(i)) - endif - write(iout,'(a,2i15,f10.5)')MovTypID(i),moves(i),moves_acc(i), - & fr_mov_i - enddo - write (iout,'(a,2i15,f10.5)') 'total ',nmove,nacc_tot, - & dfloat(nacc_tot)/dfloat(nmove) - write (iout,'(58(1h-))') - write (iout,'(a,1pe12.4)') 'Elapsed time:',tcpu() - return - end -c------------------------------------------------------------------------------ - subroutine heat(over) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - logical over -C Check if there`s a need to increase temperature. - if (ntrial.gt.maxtrial) then - if (NstepH.gt.0) then - if (dabs(Tcur-TMax).lt.1.0D-7) then - if (print_mc.gt.0) - & write (iout,'(/80(1h*)/a,f8.3,a/80(1h*))') - & 'Upper limit of temperature reached. Terminating.' - over=.true. - Tcur=Tmin - else - Tcur=Tcur*TstepH - if (Tcur.gt.Tmax) Tcur=Tmax - betbol=1.0D0/(Rbol*Tcur) - if (print_mc.gt.0) - & write (iout,'(/80(1h*)/a,f8.3,a,f10.5/80(1h*))') - & 'System heated up to ',Tcur,' K; BetBol:',betbol - ntherm=ntherm+1 - ntrial=0 - over=.false. - endif - else - if (print_mc.gt.0) - & write (iout,'(a)') - & 'Maximum number of trials in a single MCM iteration exceeded.' - over=.true. - Tcur=Tmin - endif - else - over=.false. - endif - return - end -c------------------------------------------------------------------------------ - subroutine cool - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - if (nstepC.gt.0 .and. dabs(Tcur-Tmin).gt.1.0D-7) then - Tcur=Tcur/TstepC - if (Tcur.lt.Tmin) Tcur=Tmin - betbol=1.0D0/(Rbol*Tcur) - if (print_mc.gt.0) - & write (iout,'(/80(1h*)/a,f8.3,a,f10.5/80(1h*))') - & 'System cooled down up to ',Tcur,' K; BetBol:',betbol - endif - return - end -C--------------------------------------------------------------------------- - subroutine zapis(varia,etot) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MP - include 'mpif.h' - include 'COMMON.INFO' -#endif - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - integer itemp(maxsave) - double precision varia(maxvar) - logical lprint - lprint=.false. - if (lprint) then - write (iout,'(a,i5,a,i5)') 'Enter ZAPIS NSave=',Nsave, - & ' MaxSave=',MaxSave - write (iout,'(a)') 'Current energy and conformation:' - write (iout,'(1pe14.5)') etot - write (iout,'(10f8.3)') (rad2deg*varia(i),i=1,nvar) - endif -C Shift the contents of the esave and varsave arrays if filled up. - call add2cache(maxvar,maxsave,nsave,nvar,MyID,itemp, - & etot,varia,esave,varsave) - if (lprint) then - write (iout,'(a)') 'Energies and the VarSave array.' - do i=1,nsave - write (iout,'(i5,1pe14.5)') i,esave(i) - write (iout,'(10f8.3)') (rad2deg*varsave(j,i),j=1,nvar) - enddo - endif - return - end -C--------------------------------------------------------------------------- - subroutine perturb(error,lprint,MoveType,nbond,max_phi) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (MMaxSideMove=100) - include 'COMMON.MCM' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' -crc include 'COMMON.DEFORM1' - logical error,lprint,fail - integer MoveType,nbond,end_select,ind_side(MMaxSideMove) - double precision max_phi - double precision psi,gen_psi - external iran_num - integer iran_num - integer ifour - data ifour /4/ - error=.false. - lprint=.false. -C Perturb the conformation according to a randomly selected move. - call SelectMove(MoveType) -c write (iout,*) 'MoveType=',MoveType - itrial=0 - goto (100,200,300,400,500) MoveType -C------------------------------------------------------------------------------ -C Backbone N-bond move. -C Select the number of bonds (length of the segment to perturb). - 100 continue - if (itrial.gt.1000) then - write (iout,'(a)') 'Too many attempts at multiple-bond move.' - error=.true. - return - endif - bond_prob=ran_number(0.0D0,sumpro_bond(nbm)) -c print *,'sumpro_bond(nbm)=',sumpro_bond(nbm), -c & ' Bond_prob=',Bond_Prob - do i=1,nbm-1 -c print *,i,Bond_Prob,sumpro_bond(i),sumpro_bond(i+1) - if (bond_prob.ge.sumpro_bond(i) .and. - & bond_prob.le.sumpro_bond(i+1)) then - nbond=i+1 - goto 10 - endif - enddo - write (iout,'(2a)') 'In PERTURB: Error - number of bonds', - & ' to move out of range.' - error=.true. - return - 10 continue - if (nwindow.gt.0) then -C Select the first residue to perturb - iwindow=iran_num(1,nwindow) - print *,'iwindow=',iwindow - iiwin=1 - do while (winlen(iwindow).lt.nbond) - iwindow=iran_num(1,nwindow) - iiwin=iiwin+1 - if (iiwin.gt.1000) then - write (iout,'(a)') 'Cannot select moveable residues.' - error=.true. - return - endif - enddo - nstart=iran_num(winstart(iwindow),winend(iwindow)) - else - nstart = iran_num(koniecl+2,nres-nbond-koniecl) -cd print *,'nres=',nres,' nbond=',nbond,' koniecl=',koniecl, -cd & ' nstart=',nstart - endif - psi = gen_psi() - if (psi.eq.0.0) then - error=.true. - return - endif - if (print_mc.gt.1) write (iout,'(a,i4,a,i4,a,f8.3)') - & 'PERTURB: nbond=',nbond,' nstart=',nstart,' psi=',psi*rad2deg -cd print *,'nstart=',nstart - call bond_move(nbond,nstart,psi,.false.,error) - if (error) then - write (iout,'(2a)') - & 'Could not define reference system in bond_move, ', - & 'choosing ahother segment.' - itrial=itrial+1 - goto 100 - endif - nbond_move(nbond)=nbond_move(nbond)+1 - moves(1)=moves(1)+1 - nmove=nmove+1 - return -C------------------------------------------------------------------------------ -C Backbone endmove. Perturb a SINGLE angle of a residue close to the end of -C the chain. - 200 continue - lprint=.true. -c end_select=iran_num(1,2*koniecl) -c if (end_select.gt.koniecl) then -c end_select=nphi-(end_select-koniecl) -c else -c end_select=koniecl+3 -c endif -c if (nwindow.gt.0) then -c iwin=iran_num(1,nwindow) -c i1=max0(4,winstart(iwin)) -c i2=min0(winend(imin)+2,nres) -c end_select=iran_num(i1,i2) -c else -c iselect = iran_num(1,nmov_var) -c jj = 0 -c do i=1,nphi -c if (isearch_tab(i).eq.1) jj = jj+1 -c if (jj.eq.iselect) then -c end_select=i+3 -c exit -c endif -c enddo -c endif - end_select = iran_num(4,nres) - psi=max_phi*gen_psi() - if (psi.eq.0.0D0) then - error=.true. - return - endif - phi(end_select)=pinorm(phi(end_select)+psi) - if (print_mc.gt.1) write (iout,'(a,i4,a,f8.3,a,f8.3)') - & 'End angle',end_select,' moved by ',psi*rad2deg,' new angle:', - & phi(end_select)*rad2deg -c if (end_select.gt.3) -c & theta(end_select-1)=gen_theta(itype(end_select-2), -c & phi(end_select-1),phi(end_select)) -c if (end_select.lt.nres) -c & theta(end_select)=gen_theta(itype(end_select-1), -c & phi(end_select),phi(end_select+1)) -cd print *,'nres=',nres,' end_select=',end_select -cd print *,'theta',end_select-1,theta(end_select-1) -cd print *,'theta',end_select,theta(end_select) - moves(2)=moves(2)+1 - nmove=nmove+1 - lprint=.false. - return -C------------------------------------------------------------------------------ -C Side chain move. -C Select the number of SCs to perturb. - 300 isctry=0 - 301 nside_move=iran_num(1,MaxSideMove) -c print *,'nside_move=',nside_move,' MaxSideMove',MaxSideMove -C Select the indices. - do i=1,nside_move - icount=0 - 111 inds=iran_num(nnt,nct) - icount=icount+1 - if (icount.gt.1000) then - write (iout,'(a)')'Error - cannot select side chains to move.' - error=.true. - return - endif - if (itype(inds).eq.10) goto 111 - do j=1,i-1 - if (inds.eq.ind_side(j)) goto 111 - enddo - do j=1,i-1 - if (inds.lt.ind_side(j)) then - indx=j - goto 112 - endif - enddo - indx=i - 112 do j=i,indx+1,-1 - ind_side(j)=ind_side(j-1) - enddo - 113 ind_side(indx)=inds - enddo -C Carry out perturbation. - do i=1,nside_move - ii=ind_side(i) - iti=itype(ii) - call gen_side(iti,theta(ii+1),alph(ii),omeg(ii),fail) - if (fail) then - isctry=isctry+1 - if (isctry.gt.1000) then - write (iout,'(a)') 'Too many errors in SC generation.' - error=.true. - return - endif - goto 301 - endif - if (print_mc.gt.1) write (iout,'(2a,i4,a,2f8.3)') - & 'Side chain ',restyp(iti),ii,' moved to ', - & alph(ii)*rad2deg,omeg(ii)*rad2deg - enddo - moves(3)=moves(3)+1 - nmove=nmove+1 - return -C------------------------------------------------------------------------------ -C THETA move - 400 end_select=iran_num(3,nres) - theta_new=gen_theta(itype(end_select),phi(end_select), - & phi(end_select+1)) - if (print_mc.gt.1) write (iout,'(a,i3,a,f8.3,a,f8.3)') - & 'Theta ',end_select,' moved from',theta(end_select)*rad2deg, - & ' to ',theta_new*rad2deg - theta(end_select)=theta_new - moves(4)=moves(4)+1 - nmove=nmove+1 - return -C------------------------------------------------------------------------------ -C Error returned from SelectMove. - 500 error=.true. - return - end -C------------------------------------------------------------------------------ - subroutine SelectMove(MoveType) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - what_move=ran_number(0.0D0,sumpro_type(MaxMoveType)) - do i=1,MaxMoveType - if (what_move.ge.sumpro_type(i-1).and. - & what_move.lt.sumpro_type(i)) then - MoveType=i - return - endif - enddo - write (iout,'(a)') - & 'Fatal error in SelectMoveType: cannot select move.' - MoveType=MaxMoveType+1 - return - end -c---------------------------------------------------------------------------- - double precision function gen_psi() - implicit none - integer i - double precision x,ran_number - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - x=0.0D0 - do i=1,100 - x=ran_number(-pi,pi) - if (dabs(x).gt.angmin) then - gen_psi=x - return - endif - enddo - write (iout,'(a)')'From Gen_Psi: Cannot generate angle increment.' - gen_psi=0.0D0 - return - end -c---------------------------------------------------------------------------- - subroutine metropolis(n,xcur,xold,ecur,eold,accepted,similar, - & enelower) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' -crc include 'COMMON.DEFORM' - double precision ecur,eold,xx,ran_number,bol - double precision xcur(n),xold(n) - double precision ecut1 ,ecut2 ,tola - logical accepted,similar,not_done,enelower - logical lprn - data ecut1 /-1.0D-5/,ecut2 /5.0D-3/,tola/5.0D0/ -! ecut1=-5*enedif -! ecut2=50*enedif -! tola=5.0d0 -C Set lprn=.true. for debugging. - lprn=.false. - if (lprn) - &write(iout,*)'enedif',enedif,' ecut1',ecut1,' ecut2',ecut2 - similar=.false. - enelower=.false. - accepted=.false. -C Check if the conformation is similar. - difene=ecur-eold - reldife=difene/dmax1(dabs(eold),dabs(ecur),1.0D0) - if (lprn) then - write (iout,*) 'Metropolis' - write(iout,*)'ecur,eold,difene,reldife',ecur,eold,difene,reldife - endif -C If energy went down remarkably, we accept the new conformation -C unconditionally. -cjp if (reldife.lt.ecut1) then - if (difene.lt.ecut1) then - accepted=.true. - EneLower=.true. - if (lprn) write (iout,'(a)') - & 'Conformation accepted, because energy has lowered remarkably.' -! elseif (reldife.lt.ecut2 .and. dif_ang(nphi,xcur,xold).lt.tola) -cjp elseif (reldife.lt.ecut2) - elseif (difene.lt.ecut2) - & then -C Reject the conf. if energy has changed insignificantly and there is not -C much change in conformation. - if (lprn) - & write (iout,'(2a)') 'Conformation rejected, because it is', - & ' similar to the preceding one.' - accepted=.false. - similar=.true. - else -C Else carry out Metropolis test. - EneLower=.false. - xx=ran_number(0.0D0,1.0D0) - xxh=betbol*difene - if (lprn) - & write (iout,*) 'betbol=',betbol,' difene=',difene,' xxh=',xxh - if (xxh.gt.50.0D0) then - bol=0.0D0 - else - bol=exp(-xxh) - endif - if (lprn) write (iout,*) 'bol=',bol,' xx=',xx - if (bol.gt.xx) then - accepted=.true. - if (lprn) write (iout,'(a)') - & 'Conformation accepted, because it passed Metropolis test.' - else - accepted=.false. - if (lprn) write (iout,'(a)') - & 'Conformation rejected, because it did not pass Metropolis test.' - endif - endif -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - return - end -c------------------------------------------------------------------------------ - integer function conf_comp(x,ene) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - double precision etol , angtol - double precision x(maxvar) - double precision dif_ang,difa - data etol /0.1D0/, angtol /20.0D0/ - do ii=nsave,1,-1 -c write (iout,*) 'ii=',ii,'ene=',ene,esave(ii),dabs(ene-esave(ii)) - if (dabs(ene-esave(ii)).lt.etol) then - difa=dif_ang(nphi,x,varsave(1,ii)) -c do i=1,nphi -c write(iout,'(i3,3f8.3)')i,rad2deg*x(i), -c & rad2deg*varsave(i,ii) -c enddo -c write(iout,*) 'ii=',ii,' difa=',difa,' angtol=',angtol - if (difa.le.angtol) then - if (print_mc.gt.0) then - write (iout,'(a,i5,2(a,1pe15.4))') - & 'Current conformation matches #',ii, - & ' in the store array ene=',ene,' esave=',esave(ii) -c write (*,'(a,i5,a)') 'Current conformation matches #',ii, -c & ' in the store array.' - endif ! print_mc.gt.0 - if (print_mc.gt.1) then - do i=1,nphi - write(iout,'(i3,3f8.3)')i,rad2deg*x(i), - & rad2deg*varsave(i,ii) - enddo - endif ! print_mc.gt.1 - nrepm=nrepm+1 - conf_comp=ii - return - endif - endif - enddo - conf_comp=0 - return - end -C---------------------------------------------------------------------------- - double precision function dif_ang(n,x,y) - implicit none - integer i,n - double precision x(n),y(n) - double precision w,wa,dif,difa - double precision pinorm - include 'COMMON.GEO' - wa=0.0D0 - difa=0.0D0 - do i=1,n - dif=dabs(pinorm(y(i)-x(i))) - if (dabs(dif-dwapi).lt.dif) dif=dabs(dif-dwapi) - w=1.0D0-(2.0D0*(i-1)/(n-1)-1.0D0)**2+1.0D0/n - wa=wa+w - difa=difa+dif*dif*w - enddo - dif_ang=rad2deg*dsqrt(difa/wa) - return - end -c-------------------------------------------------------------------------- - subroutine add2cache(n1,n2,ncache,nvar,SourceID,CachSrc, - & ecur,xcur,ecache,xcache) - implicit none - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - integer n1,n2,ncache,nvar,SourceID,CachSrc(n2) - integer i,ii,j - double precision ecur,xcur(nvar),ecache(n2),xcache(n1,n2) -cd write (iout,*) 'Enter ADD2CACHE ncache=',ncache ,' ecur',ecur -cd write (iout,'(10f8.3)') (rad2deg*xcur(i),i=1,nvar) -cd write (iout,*) 'Old CACHE array:' -cd do i=1,ncache -cd write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) -cd write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) -cd enddo - - i=ncache - do while (i.gt.0 .and. ecur.lt.ecache(i)) - i=i-1 - enddo - i=i+1 -cd write (iout,*) 'i=',i,' ncache=',ncache - if (ncache.eq.n2) then - write (iout,*) 'Cache dimension exceeded',ncache,n2 - write (iout,*) 'Highest-energy conformation will be removed.' - ncache=ncache-1 - endif - do ii=ncache,i,-1 - ecache(ii+1)=ecache(ii) - CachSrc(ii+1)=CachSrc(ii) - do j=1,nvar - xcache(j,ii+1)=xcache(j,ii) - enddo - enddo - ecache(i)=ecur - CachSrc(i)=SourceID - do j=1,nvar - xcache(j,i)=xcur(j) - enddo - ncache=ncache+1 -cd write (iout,*) 'New CACHE array:' -cd do i=1,ncache -cd write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) -cd write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) -cd enddo - return - end -c-------------------------------------------------------------------------- - subroutine rm_from_cache(i,n1,n2,ncache,nvar,CachSrc,ecache, - & xcache) - implicit none - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - integer n1,n2,ncache,nvar,CachSrc(n2) - integer i,ii,j - double precision ecache(n2),xcache(n1,n2) - -cd write (iout,*) 'Enter RM_FROM_CACHE' -cd write (iout,*) 'Old CACHE array:' -cd do ii=1,ncache -cd write (iout,*)'i=',ii,' ecache=',ecache(ii),' CachSrc',CachSrc(ii) -cd write (iout,'(10f8.3)') (rad2deg*xcache(j,ii),j=1,nvar) -cd enddo - - do ii=i+1,ncache - ecache(ii-1)=ecache(ii) - CachSrc(ii-1)=CachSrc(ii) - do j=1,nvar - xcache(j,ii-1)=xcache(j,ii) - enddo - enddo - ncache=ncache-1 -cd write (iout,*) 'New CACHE array:' -cd do i=1,ncache -cd write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) -cd write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) -cd enddo - return - end diff --git a/source/unres/src_MD_DFA/minim_mcmf.F b/source/unres/src_MD_DFA/minim_mcmf.F deleted file mode 100644 index beb3d4c..0000000 --- a/source/unres/src_MD_DFA/minim_mcmf.F +++ /dev/null @@ -1,121 +0,0 @@ -#ifdef MPI - subroutine minim_mcmf - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.MINIM' - include 'mpif.h' - external func,gradient,fdum - real ran1,ran2,ran3 - include 'COMMON.SETUP' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - dimension muster(mpi_status_size) - dimension var(maxvar),erg(mxch*(mxch+1)/2+1) - double precision d(maxvar),v(1:lv+1),garbage(maxvar) - dimension indx(6) - dimension iv(liv) - dimension idum(1),rdum(1) - double precision przes(3),obrot(3,3) - logical non_conv - data rad /1.745329252d-2/ - common /przechowalnia/ v - - ichuj=0 - 10 continue - ichuj = ichuj + 1 - call mpi_recv(indx,6,mpi_integer,king,idint,CG_COMM, - * muster,ierr) - if (indx(1).eq.0) return -c print *, 'worker ',me,' received order ',n,ichuj - call mpi_recv(var,nvar,mpi_double_precision, - * king,idreal,CG_COMM,muster,ierr) - call mpi_recv(ene0,1,mpi_double_precision, - * king,idreal,CG_COMM,muster,ierr) -c print *, 'worker ',me,' var read ' - - - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit -c iv(21)=iout - iv(21)=0 -* 1 means to print out result - iv(22)=0 -* 1 means to print out summary stats - iv(23)=0 -* 1 means to print initial x and d - iv(24)=0 -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo -c minimize energy - - call func(nvar,var,nf,eee,idum,rdum,fdum) - if(eee.gt.1.0d18) then -c print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' -c print *,' energy before SUMSL =',eee -c print *,' aborting local minimization' - iv(1)=-1 - v(10)=eee - nf=1 - go to 201 - endif - - call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum) -c find which conformation was returned from sumsl - nf=iv(7)+1 - 201 continue -c total # of ftn evaluations (for iwf=0, it includes all minimizations). - indx(4)=nf - indx(5)=iv(1) - eee=v(10) - - call mpi_send(indx,6,mpi_integer,king,idint,CG_COMM, - * ierr) -c print '(a5,i3,15f10.5)', 'ENEX0',indx(1),v(10) - call mpi_send(var,nvar,mpi_double_precision, - * king,idreal,CG_COMM,ierr) - call mpi_send(eee,1,mpi_double_precision,king,idreal, - * CG_COMM,ierr) - call mpi_send(ene0,1,mpi_double_precision,king,idreal, - * CG_COMM,ierr) - go to 10 - - return - end -#endif diff --git a/source/unres/src_MD_DFA/minimize_p.F b/source/unres/src_MD_DFA/minimize_p.F deleted file mode 100644 index c7922c7..0000000 --- a/source/unres/src_MD_DFA/minimize_p.F +++ /dev/null @@ -1,641 +0,0 @@ - subroutine minimize(etot,x,iretcode,nfun) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) -********************************************************************* -* OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * -* the calling subprogram. * -* when d(i)=1.0, then v(35) is the length of the initial step, * -* calculated in the usual pythagorean way. * -* absolute convergence occurs when the function is within v(31) of * -* zero. unless you know the minimum value in advance, abs convg * -* is probably not useful. * -* relative convergence is when the model predicts that the function * -* will decrease by less than v(32)*abs(fun). * -********************************************************************* - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.MINIM' - common /srutu/ icall - dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) - double precision energia(0:n_ene) - external func,gradient,fdum - external func_restr,grad_restr - logical not_done,change,reduce -c common /przechowalnia/ v - - icall = 1 - - NOT_DONE=.TRUE. - -c DO WHILE (NOT_DONE) - - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit - iv(21)=0 - if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout -* 1 means to print out result - iv(22)=print_min_res -* 1 means to print out summary stats - iv(23)=print_min_stat -* 1 means to print initial x and d - iv(24)=print_min_ini -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -c v(25)=4.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo -cd print *,'Calling SUMSL' -c call var_to_geom(nvar,x) -c call chainbuild -c call etotal(energia(0)) -c etot = energia(0) - IF (mask_r) THEN - call x2xx(x,xx,nvar_restr) - call sumsl(nvar_restr,d,xx,func_restr,grad_restr, - & iv,liv,lv,v,idum,rdum,fdum) - call xx2x(x,xx) - ELSE - call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) - ENDIF - etot=v(10) - iretcode=iv(1) -cd print *,'Exit SUMSL; return code:',iretcode,' energy:',etot -cd write (iout,'(/a,i4/)') 'SUMSL return code:',iv(1) -c call intout -c change=reduce(x) - call var_to_geom(nvar,x) -c if (change) then -c write (iout,'(a)') 'Reduction worked, minimizing again...' -c else -c not_done=.false. -c endif - call chainbuild -c call etotal(energia(0)) -c etot=energia(0) -c call enerprint(energia(0)) - nfun=iv(6) - -c write (*,*) 'Processor',MyID,' leaves MINIMIZE.' - -c ENDDO ! NOT_DONE - - return - end -#ifdef MPI -c---------------------------------------------------------------------------- - subroutine ergastulum - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SETUP' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.TIME1' - double precision z(maxres6),d_a_tmp(maxres6) - double precision edum(0:n_ene),time_order(0:10) - double precision Gcopy(maxres2,maxres2) - common /przechowalnia/ Gcopy - integer icall /0/ -C Workers wait for variables and NF, and NFL from the boss - iorder=0 - do while (iorder.ge.0) -c write (*,*) 'Processor',fg_rank,' CG group',kolor, -c & ' receives order from Master' - time00=MPI_Wtime() - call MPI_Bcast(iorder,1,MPI_INTEGER,king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 - if (icall.gt.4 .and. iorder.ge.0) - & time_order(iorder)=time_order(iorder)+MPI_Wtime()-time00 - icall=icall+1 -c write (*,*) -c & 'Processor',fg_rank,' completed receive MPI_BCAST order',iorder - if (iorder.eq.0) then - call zerograd - call etotal(edum) -c write (2,*) "After etotal" -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - else if (iorder.eq.2) then - call zerograd - call etotal_short(edum) -c write (2,*) "After etotal_short" -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - else if (iorder.eq.3) then - call zerograd - call etotal_long(edum) -c write (2,*) "After etotal_long" -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - else if (iorder.eq.1) then - call sum_gradient -c write (2,*) "After sum_gradient" -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - else if (iorder.eq.4) then - call ginv_mult(z,d_a_tmp) - else if (iorder.eq.5) then -c Setup MD things for a slave - dimen=(nct-nnt+1)+nside - dimen1=(nct-nnt)+(nct-nnt+1) - dimen3=dimen*3 -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - call int_bounds(dimen,igmult_start,igmult_end) - igmult_start=igmult_start-1 - call MPI_Allgather(3*igmult_start,1,MPI_INTEGER, - & ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - my_ng_count=igmult_end-igmult_start - call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1, - & MPI_INTEGER,FG_COMM,IERROR) -c write (2,*) "ng_start",(ng_start(i),i=0,nfgtasks-1) -c write (2,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1) - myginv_ng_count=maxres2*my_ng_count -c write (2,*) "igmult_start",igmult_start," igmult_end", -c & igmult_end," my_ng_count",my_ng_count -c call flush(2) - call MPI_Allgather(maxres2*igmult_start,1,MPI_INTEGER, - & nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER, - & nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR) -c write (2,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1) -c write (2,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1) -c call flush(2) -c call MPI_Barrier(FG_COMM,IERROR) - time00=MPI_Wtime() - call MPI_Scatterv(ginv(1,1),nginv_counts(0), - & nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1), - & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -#ifdef TIMING - time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00 -#endif - do i=1,dimen - do j=1,2*my_ng_count - ginv(j,i)=gcopy(i,j) - enddo - enddo -c write (2,*) "dimen",dimen," dimen3",dimen3 -c write (2,*) "End MD setup" -c call flush(2) -c write (iout,*) "My chunk of ginv_block" -c call MATOUT2(my_ng_count,dimen3,maxres2,maxers2,ginv_block) - else if (iorder.eq.6) then - call int_from_cart1(.false.) - else if (iorder.eq.7) then - call chainbuild_cart - else if (iorder.eq.8) then - call intcartderiv - else if (iorder.eq.9) then - call fricmat_mult(z,d_a_tmp) - else if (iorder.eq.10) then - call setup_fricmat - endif - enddo - write (*,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',myrank,' leves ERGASTULUM.' - write(*,*)'Processor',fg_rank,' wait times for respective orders', - & (' order[',i,']',time_order(i),i=0,10) - return - end -#endif -************************************************************************ - subroutine func(n,x,nf,f,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - common /chuju/ jjj - double precision energia(0:n_ene) - integer jjj - double precision ufparm - external ufparm - integer uiparm(1) - real*8 urparm(1) - dimension x(maxvar) -c if (jjj.gt.0) then -c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -c endif - nfl=nf - icg=mod(nf,2)+1 -cd print *,'func',nf,nfl,icg - call var_to_geom(n,x) - call zerograd - call chainbuild -cd write (iout,*) 'ETOTAL called from FUNC' - call etotal(energia(0)) - call sum_gradient - f=energia(0) -c if (jjj.gt.0) then -c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -c write (iout,*) 'f=',etot -c jjj=0 -c endif - return - end -************************************************************************ - subroutine func_restr(n,x,nf,f,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - common /chuju/ jjj - double precision energia(0:n_ene) - integer jjj - double precision ufparm - external ufparm - integer uiparm(1) - real*8 urparm(1) - dimension x(maxvar) -c if (jjj.gt.0) then -c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -c endif - nfl=nf - icg=mod(nf,2)+1 - call var_to_geom_restr(n,x) - call zerograd - call chainbuild -cd write (iout,*) 'ETOTAL called from FUNC' - call etotal(energia(0)) - call sum_gradient - f=energia(0) -c if (jjj.gt.0) then -c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -c write (iout,*) 'f=',etot -c jjj=0 -c endif - return - end -c------------------------------------------------------- - subroutine x2xx(x,xx,n) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - double precision xx(maxvar),x(maxvar) - - do i=1,nvar - varall(i)=x(i) - enddo - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - xx(ig)=x(igall) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - xx(ig)=x(igall) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - xx(ig)=x(igall) - endif - endif - enddo - enddo - - n=ig - - return - end - - subroutine xx2x(x,xx) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - double precision xx(maxvar),x(maxvar) - - do i=1,nvar - x(i)=varall(i) - enddo - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - x(igall)=xx(ig) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - x(igall)=xx(ig) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - x(igall)=xx(ig) - endif - endif - enddo - enddo - - return - end - -c---------------------------------------------------------- - subroutine minim_dc(etot,iretcode,nfun) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.MINIM' - include 'COMMON.CHAIN' - dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) -c common /przechowalnia/ v - - double precision energia(0:n_ene) - external func_dc,grad_dc,fdum - logical not_done,change,reduce - double precision g(maxvar),f1 - - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit - iv(21)=0 - if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout -* 1 means to print out result - iv(22)=print_min_res -* 1 means to print out summary stats - iv(23)=print_min_stat -* 1 means to print initial x and d - iv(24)=print_min_ini -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -c v(25)=4.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,6*nres - d(i)=1.0D-1 - enddo - - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - x(k)=dc(j,i) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - x(k)=dc(j,i+nres) - enddo - endif - enddo - - call sumsl(k,d,x,func_dc,grad_dc,iv,liv,lv,v,idum,rdum,fdum) - - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - dc(j,i)=x(k) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - dc(j,i+nres)=x(k) - enddo - endif - enddo - call chainbuild_cart - -cd call zerograd -cd nf=0 -cd call func_dc(k,x,nf,f,idum,rdum,fdum) -cd call grad_dc(k,x,nf,g,idum,rdum,fdum) -cd -cd do i=1,k -cd x(i)=x(i)+1.0D-5 -cd call func_dc(k,x,nf,f1,idum,rdum,fdum) -cd x(i)=x(i)-1.0D-5 -cd print '(i5,2f15.5)',i,g(i),(f1-f)/1.0D-5 -cd enddo - - etot=v(10) - iretcode=iv(1) - nfun=iv(6) - return - end - - subroutine func_dc(n,x,nf,f,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - double precision energia(0:n_ene) - double precision ufparm - external ufparm - integer uiparm(1) - real*8 urparm(1) - dimension x(maxvar) - nfl=nf -cbad icg=mod(nf,2)+1 - icg=1 - - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - dc(j,i)=x(k) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - dc(j,i+nres)=x(k) - enddo - endif - enddo - call chainbuild_cart - - call zerograd - call etotal(energia(0)) - f=energia(0) - -cd print *,'func_dc ',nf,nfl,f - - return - end - - subroutine grad_dc(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.MD' - include 'COMMON.IOUNITS' - external ufparm - integer uiparm(1),k - double precision urparm(1) - dimension x(maxvar),g(maxvar) -c -c -c -cbad icg=mod(nf,2)+1 - icg=1 -cd print *,'grad_dc ',nf,nfl,nf-nfl+1,icg - if (nf-nfl+1) 20,30,40 - 20 call func_dc(n,x,nf,f,uiparm,urparm,ufparm) -cd print *,20 - if (nf.eq.0) return - goto 40 - 30 continue -cd print *,30 - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - dc(j,i)=x(k) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - dc(j,i+nres)=x(k) - enddo - endif - enddo - call chainbuild_cart - -C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartgrad -cd print *,40 - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - g(k)=gcart(j,i) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - g(k)=gxcart(j,i) - enddo - endif - enddo - - return - end diff --git a/source/unres/src_MD_DFA/misc.f b/source/unres/src_MD_DFA/misc.f deleted file mode 100644 index e189839..0000000 --- a/source/unres/src_MD_DFA/misc.f +++ /dev/null @@ -1,203 +0,0 @@ -C $Date: 1994/10/12 17:24:21 $ -C $Revision: 2.5 $ -C -C -C - logical function find_arg(ipos,line,errflag) - parameter (maxlen=80) - character*80 line - character*1 empty /' '/,equal /'='/ - logical errflag -* This function returns .TRUE., if an argument follows keyword keywd; if so -* IPOS will point to the first non-blank character of the argument. Returns -* .FALSE., if no argument follows the keyword; in this case IPOS points -* to the first non-blank character of the next keyword. - do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) - ipos=ipos+1 - enddo - errflag=.false. - if (line(ipos:ipos).eq.equal) then - find_arg=.true. - ipos=ipos+1 - do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) - ipos=ipos+1 - enddo - if (ipos.gt.maxlen) errflag=.true. - else - find_arg=.false. - endif - return - end - logical function find_group(iunit,jout,key1) - character*(*) key1 - character*80 karta,ucase - integer ilen - external ilen - logical lcom - rewind (iunit) - karta=' ' - ll=ilen(key1) - do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta)) - read (iunit,'(a)',end=10) karta - enddo - write (jout,'(2a)') '> ',karta(1:78) - find_group=.true. - return - 10 find_group=.false. - return - end - logical function iblnk(charc) - character*1 charc - integer n - n = ichar(charc) - iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq. ' ') - return - end - integer function ilen(string) - character*(*) string - logical iblnk - - ilen = len(string) -1 if ( ilen .gt. 0 ) then - if ( iblnk( string(ilen:ilen) ) ) then - ilen = ilen - 1 - goto 1 - endif - endif - return - end - integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset) - character*16 keywd,keywdset(1:nkey,0:nkey) - character*16 ucase - do i=1,narg - if (ucase(keywd).eq.keywdset(i,ikey)) then -* Match found - in_keywd_set=i - return - endif - enddo -* No match to the allowed set of keywords if this point is reached. - in_keywd_set=0 - return - end - character*(*) function lcase(string) - integer i, k, idiff - character*(*) string - character*1 c - character*40 chtmp -c - i = len(lcase) - k = len(string) - if (i .lt. k) then - k = i - if (string(k+1:) .ne. ' ') then - chtmp = string - endif - endif - idiff = ichar('a') - ichar('A') - lcase = string - do 99 i = 1, k - c = string(i:i) - if (lge(c,'A') .and. lle(c,'Z')) then - lcase(i:i) = char(ichar(c) + idiff) - endif - 99 continue - return - end - logical function lcom(ipos,karta) - character*80 karta - character koment(2) /'!','#'/ - lcom=.false. - do i=1,2 - if (karta(ipos:ipos).eq.koment(i)) lcom=.true. - enddo - return - end - logical function lower_case(ch) - character*(*) ch - lower_case=(ch.ge.'a' .and. ch.le.'z') - return - end - subroutine mykey(line,keywd,ipos,blankline,errflag) -* This subroutine seeks a non-empty substring keywd in the string LINE. -* The substring begins with the first character different from blank and -* "=" encountered right to the pointer IPOS (inclusively) and terminates -* at the character left to the first blank or "=". When the subroutine is -* exited, the pointer IPOS is moved to the position of the terminator in LINE. -* The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains -* only separators or the maximum length of the data line (80) has been reached. -* The logical variable ERRFLAG is set at .TRUE. if the string -* consists only from a "=". - parameter (maxlen=80) - character*1 empty /' '/,equal /'='/,comma /','/ - character*(*) keywd - character*80 line - logical blankline,errflag,lcom - errflag=.false. - do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen)) - ipos=ipos+1 - enddo - if (ipos.gt.maxlen .or. lcom(ipos,line) ) then -* At this point the rest of the input line turned out to contain only blanks -* or to be commented out. - blankline=.true. - return - endif - blankline=.false. - istart=ipos -* Checks whether the current char is a separator. - do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal - & .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen) - ipos=ipos+1 - enddo - iend=ipos-1 -* Error flag set to .true., if the length of the keyword was found less than 1. - if (iend.lt.istart) then - errflag=.true. - return - endif - keywd=line(istart:iend) - return - end - subroutine numstr(inum,numm) - character*10 huj /'0123456789'/ - character*(*) numm - inumm=inum - inum1=inumm/10 - inum2=inumm-10*inum1 - inumm=inum1 - numm(3:3)=huj(inum2+1:inum2+1) - inum1=inumm/10 - inum2=inumm-10*inum1 - inumm=inum1 - numm(2:2)=huj(inum2+1:inum2+1) - inum1=inumm/10 - inum2=inumm-10*inum1 - inumm=inum1 - numm(1:1)=huj(inum2+1:inum2+1) - return - end - character*(*) function ucase(string) - integer i, k, idiff - character*(*) string - character*1 c - character*40 chtmp -c - i = len(ucase) - k = len(string) - if (i .lt. k) then - k = i - if (string(k+1:) .ne. ' ') then - chtmp = string - endif - endif - idiff = ichar('a') - ichar('A') - ucase = string - do 99 i = 1, k - c = string(i:i) - if (lge(c,'a') .and. lle(c,'z')) then - ucase(i:i) = char(ichar(c) - idiff) - endif - 99 continue - return - end diff --git a/source/unres/src_MD_DFA/moments.f b/source/unres/src_MD_DFA/moments.f deleted file mode 100644 index 5adbf21..0000000 --- a/source/unres/src_MD_DFA/moments.f +++ /dev/null @@ -1,328 +0,0 @@ - subroutine inertia_tensor -c Calculating the intertia tensor for the entire protein in order to -c remove the perpendicular components of velocity matrix which cause -c the molecule to rotate. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - - double precision Im(3,3),Imcp(3,3),cm(3),pr(3),M_SC, - & eigvec(3,3),Id(3,3),eigval(3),L(3),vp(3),vrot(3), - & vpp(3,0:MAXRES),vs_p(3),pr1(3,3), - & pr2(3,3),pp(3),incr(3),v(3),mag,mag2 - common /gucio/ cm - integer iti,inres - do i=1,3 - do j=1,3 - Im(i,j)=0.0d0 - pr1(i,j)=0.0d0 - pr2(i,j)=0.0d0 - enddo - L(i)=0.0d0 - cm(i)=0.0d0 - vrot(i)=0.0d0 - enddo -c calculating the center of the mass of the protein - do i=nnt,nct-1 - do j=1,3 - cm(j)=cm(j)+c(j,i)+0.5d0*dc(j,i) - enddo - enddo - do j=1,3 - cm(j)=mp*cm(j) - enddo - M_SC=0.0d0 - do i=nnt,nct - iti=itype(i) - M_SC=M_SC+msc(iti) - inres=i+nres - do j=1,3 - cm(j)=cm(j)+msc(iti)*c(j,inres) - enddo - enddo - do j=1,3 - cm(j)=cm(j)/(M_SC+(nct-nnt)*mp) - enddo - - do i=nnt,nct-1 - do j=1,3 - pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) - enddo - Im(1,1)=Im(1,1)+mp*(pr(2)*pr(2)+pr(3)*pr(3)) - Im(1,2)=Im(1,2)-mp*pr(1)*pr(2) - Im(1,3)=Im(1,3)-mp*pr(1)*pr(3) - Im(2,3)=Im(2,3)-mp*pr(2)*pr(3) - Im(2,2)=Im(2,2)+mp*(pr(3)*pr(3)+pr(1)*pr(1)) - Im(3,3)=Im(3,3)+mp*(pr(1)*pr(1)+pr(2)*pr(2)) - enddo - - do i=nnt,nct - iti=itype(i) - inres=i+nres - do j=1,3 - pr(j)=c(j,inres)-cm(j) - enddo - Im(1,1)=Im(1,1)+msc(iti)*(pr(2)*pr(2)+pr(3)*pr(3)) - Im(1,2)=Im(1,2)-msc(iti)*pr(1)*pr(2) - Im(1,3)=Im(1,3)-msc(iti)*pr(1)*pr(3) - Im(2,3)=Im(2,3)-msc(iti)*pr(2)*pr(3) - Im(2,2)=Im(2,2)+msc(iti)*(pr(3)*pr(3)+pr(1)*pr(1)) - Im(3,3)=Im(3,3)+msc(iti)*(pr(1)*pr(1)+pr(2)*pr(2)) - enddo - - do i=nnt,nct-1 - Im(1,1)=Im(1,1)+Ip*(1-dc_norm(1,i)*dc_norm(1,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(1,2)=Im(1,2)+Ip*(-dc_norm(1,i)*dc_norm(2,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(1,3)=Im(1,3)+Ip*(-dc_norm(1,i)*dc_norm(3,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(2,3)=Im(2,3)+Ip*(-dc_norm(2,i)*dc_norm(3,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(2,2)=Im(2,2)+Ip*(1-dc_norm(2,i)*dc_norm(2,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(3,3)=Im(3,3)+Ip*(1-dc_norm(3,i)*dc_norm(3,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - enddo - - - do i=nnt,nct - if (itype(i).ne.10) then - iti=itype(i) - inres=i+nres - Im(1,1)=Im(1,1)+Isc(iti)*(1-dc_norm(1,inres)* - & dc_norm(1,inres))*vbld(inres)*vbld(inres) - Im(1,2)=Im(1,2)-Isc(iti)*(dc_norm(1,inres)* - & dc_norm(2,inres))*vbld(inres)*vbld(inres) - Im(1,3)=Im(1,3)-Isc(iti)*(dc_norm(1,inres)* - & dc_norm(3,inres))*vbld(inres)*vbld(inres) - Im(2,3)=Im(2,3)-Isc(iti)*(dc_norm(2,inres)* - & dc_norm(3,inres))*vbld(inres)*vbld(inres) - Im(2,2)=Im(2,2)+Isc(iti)*(1-dc_norm(2,inres)* - & dc_norm(2,inres))*vbld(inres)*vbld(inres) - Im(3,3)=Im(3,3)+Isc(iti)*(1-dc_norm(3,inres)* - & dc_norm(3,inres))*vbld(inres)*vbld(inres) - endif - enddo - - call angmom(cm,L) -c write(iout,*) "The angular momentum before adjustment:" -c write(iout,*) (L(j),j=1,3) - - Im(2,1)=Im(1,2) - Im(3,1)=Im(1,3) - Im(3,2)=Im(2,3) - -c Copying the Im matrix for the djacob subroutine - do i=1,3 - do j=1,3 - Imcp(i,j)=Im(i,j) - Id(i,j)=0.0d0 - enddo - enddo - -c Finding the eigenvectors and eignvalues of the inertia tensor - call djacob(3,3,10000,1.0d-10,Imcp,eigvec,eigval) -c write (iout,*) "Eigenvalues & Eigenvectors" -c write (iout,'(5x,3f10.5)') (eigval(i),i=1,3) -c write (iout,*) -c do i=1,3 -c write (iout,'(i5,3f10.5)') i,(eigvec(i,j),j=1,3) -c enddo -c Constructing the diagonalized matrix - do i=1,3 - if (dabs(eigval(i)).gt.1.0d-15) then - Id(i,i)=1.0d0/eigval(i) - else - Id(i,i)=0.0d0 - endif - enddo - do i=1,3 - do j=1,3 - Imcp(i,j)=eigvec(j,i) - enddo - enddo - do i=1,3 - do j=1,3 - do k=1,3 - pr1(i,j)=pr1(i,j)+Id(i,k)*Imcp(k,j) - enddo - enddo - enddo - do i=1,3 - do j=1,3 - do k=1,3 - pr2(i,j)=pr2(i,j)+eigvec(i,k)*pr1(k,j) - enddo - enddo - enddo -c Calculating the total rotational velocity of the molecule - do i=1,3 - do j=1,3 - vrot(i)=vrot(i)+pr2(i,j)*L(j) - enddo - enddo -c Resetting the velocities - do i=nnt,nct-1 - call vecpr(vrot(1),dc(1,i),vp) - do j=1,3 - d_t(j,i)=d_t(j,i)-vp(j) - enddo - enddo - do i=nnt,nct - if(itype(i).ne.10) then - inres=i+nres - call vecpr(vrot(1),dc(1,inres),vp) - do j=1,3 - d_t(j,inres)=d_t(j,inres)-vp(j) - enddo - endif - enddo - call angmom(cm,L) -c write(iout,*) "The angular momentum after adjustment:" -c write(iout,*) (L(j),j=1,3) - return - end -c---------------------------------------------------------------------------- - subroutine angmom(cm,L) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - - double precision L(3),cm(3),pr(3),vp(3),vrot(3),incr(3),v(3), - & pp(3) - integer iti,inres -c Calculate the angular momentum - do j=1,3 - L(j)=0.0d0 - enddo - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct-1 - do j=1,3 - pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) - enddo - do j=1,3 - v(j)=incr(j)+0.5d0*d_t(j,i) - enddo - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - call vecpr(pr(1),v(1),vp) - do j=1,3 - L(j)=L(j)+mp*vp(j) - enddo - do j=1,3 - pr(j)=0.5d0*dc(j,i) - pp(j)=0.5d0*d_t(j,i) - enddo - call vecpr(pr(1),pp(1),vp) - do j=1,3 - L(j)=L(j)+Ip*vp(j) - enddo - enddo - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct - iti=itype(i) - inres=i+nres - do j=1,3 - pr(j)=c(j,inres)-cm(j) - enddo - if (itype(i).ne.10) then - do j=1,3 - v(j)=incr(j)+d_t(j,inres) - enddo - else - do j=1,3 - v(j)=incr(j) - enddo - endif - call vecpr(pr(1),v(1),vp) -c write (iout,*) "i",i," iti",iti," pr",(pr(j),j=1,3), -c & " v",(v(j),j=1,3)," vp",(vp(j),j=1,3) - do j=1,3 - L(j)=L(j)+msc(iti)*vp(j) - enddo -c write (iout,*) "L",(l(j),j=1,3) - if (itype(i).ne.10) then - do j=1,3 - v(j)=incr(j)+d_t(j,inres) - enddo - call vecpr(dc(1,inres),d_t(1,inres),vp) - do j=1,3 - L(j)=L(j)+Isc(iti)*vp(j) - enddo - endif - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - enddo - return - end -c------------------------------------------------------------------------------ - subroutine vcm_vel(vcm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - double precision vcm(3),vv(3),summas,amas - do j=1,3 - vcm(j)=0.0d0 - vv(j)=d_t(j,0) - enddo - summas=0.0d0 - do i=nnt,nct - if (i.lt.nct) then - summas=summas+mp - do j=1,3 - vcm(j)=vcm(j)+mp*(vv(j)+0.5d0*d_t(j,i)) - enddo - endif - amas=msc(itype(i)) - summas=summas+amas - if (itype(i).ne.10) then - do j=1,3 - vcm(j)=vcm(j)+amas*(vv(j)+d_t(j,i+nres)) - enddo - else - do j=1,3 - vcm(j)=vcm(j)+amas*vv(j) - enddo - endif - do j=1,3 - vv(j)=vv(j)+d_t(j,i) - enddo - enddo -c write (iout,*) "vcm",(vcm(j),j=1,3)," summas",summas - do j=1,3 - vcm(j)=vcm(j)/summas - enddo - return - end diff --git a/source/unres/src_MD_DFA/muca_md.f b/source/unres/src_MD_DFA/muca_md.f deleted file mode 100644 index c10a6a7..0000000 --- a/source/unres/src_MD_DFA/muca_md.f +++ /dev/null @@ -1,334 +0,0 @@ - subroutine muca_delta(remd_t_bath,remd_ene,i,iex,delta) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.MD' - double precision remd_t_bath(maxprocs) - double precision remd_ene(maxprocs) - double precision muca_ene - double precision betai,betaiex,delta - - betai=1.0/(Rb*remd_t_bath(i)) - betaiex=1.0/(Rb*remd_t_bath(iex)) - - delta=betai*(muca_ene(remd_ene(iex),i,remd_t_bath)- - & muca_ene(remd_ene(i),i,remd_t_bath)) - & -betaiex*(muca_ene(remd_ene(iex),iex,remd_t_bath)- - & muca_ene(remd_ene(i),iex,remd_t_bath)) - - return - end - - double precision function muca_ene(energy,i,remd_t_bath) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.MD' - double precision y,yp,energy - double precision remd_t_bath(maxprocs) - integer i - - if (energy.lt.elowi(i)) then - call splint(emuca,nemuca,nemuca2,nmuca,elowi(i),y,yp) - muca_ene=remd_t_bath(i)*Rb*(yp*(energy-elowi(i))+y) - elseif (energy.gt.ehighi(i)) then - call splint(emuca,nemuca,nemuca2,nmuca,ehighi(i),y,yp) - muca_ene=remd_t_bath(i)*Rb*(yp*(energy-ehighi(i))+y) - else - call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) - muca_ene=remd_t_bath(i)*Rb*y - endif - return - end - - subroutine read_muca - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.CONTROL' - include 'COMMON.MD' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision yp1,ypn,yp,x,muca_factor,y,muca_ene - imtime=0 - do i=1,4*maxres - hist(i)=0 - enddo - if (modecalc.eq.14.and..not.remd_tlist) then - print *,"MUCAREMD works only with TLIST" - stop - endif - open(89,file='muca.input') - read(89,*) - read(89,*) - if (modecalc.eq.14) then - read(89,*) (elowi(i),ehighi(i),i=1,nrep) - if (remd_mlist) then - k=0 - do i=1,nrep - do j=1,remd_m(i) - i2rep(k)=i - k=k+1 - enddo - enddo - elow=elowi(i2rep(me)) - ehigh=ehighi(i2rep(me)) - elowi(me+1)=elow - ehighi(me+1)=ehigh - else - elow=elowi(me+1) - ehigh=ehighi(me+1) - endif - else - read(89,*) elow,ehigh - elowi(1)=elow - ehighi(1)=ehigh - endif - i=0 - do while(.true.) - i=i+1 - read(89,*,end=100) emuca(i),nemuca(i) -cd nemuca(i)=nemuca(i)*remd_t(me+1)*Rb - enddo - 100 continue - nmuca=i-1 - hbin=emuca(nmuca)-emuca(nmuca-1) - write (iout,*) 'hbin',hbin - write (iout,*) me,'elow,ehigh',elow,ehigh - yp1=0 - ypn=0 - call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) - factor_min=0.0d0 - factor_min=muca_factor(ehigh) - call print_muca - return - end - - - subroutine print_muca - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.CONTROL' - include 'COMMON.MD' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision yp1,ypn,yp,x,muca_factor,y,muca_ene - double precision dummy(maxprocs) - - if (remd_mlist) then - k=0 - do i=1,nrep - do j=1,remd_m(i) - i2rep(k)=i - k=k+1 - enddo - enddo - endif - - do i=1,nmuca -c print *,'nemuca ',emuca(i),nemuca(i) - do j=0,4 - x=emuca(i)+hbin/5*j - if (modecalc.eq.14) then - if (remd_mlist) then - yp=muca_factor(x)*remd_t(i2rep(me))*Rb - dummy(me+1)=remd_t(i2rep(me)) - y=muca_ene(x,me+1,dummy) - else - yp=muca_factor(x)*remd_t(me+1)*Rb - y=muca_ene(x,me+1,remd_t) - endif - write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime, - & 'muca factor ',x,yp,' muca ene',y - else - yp=muca_factor(x)*t_bath*Rb - dummy(1)=t_bath - y=muca_ene(x,1,dummy) - write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime, - & 'muca factor ',x,yp,' muca ene',y - endif - enddo - enddo - if(mucadyn.gt.0) then - do i=1,nmuca - write(iout,'(a13,i8,2f12.5)') 'nemuca after ', - & imtime,emuca(i),nemuca(i) - enddo - endif - return - end - - subroutine muca_update(energy) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.CONTROL' - include 'COMMON.MD' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energy - double precision yp1,ypn - integer k - logical lnotend - - k=int((energy-emuca(1))/hbin)+1 - - IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN - if(energy.ge.ehigh) - & write (iout,*) 'MUCA reject',energy,emuca(k) - if(energy.ge.ehigh.and.(energy-ehigh).lt.hbin) then - write (iout,*) 'MUCA ehigh',energy,emuca(k) - do i=k,nmuca - hist(i)=hist(i)+1 - enddo - endif - if(k.gt.0.and.energy.lt.ehigh) hist(k)=hist(k)+1 - ELSE - if(k.gt.0.and.k.lt.4*maxres) hist(k)=hist(k)+1 - ENDIF - if(mod(imtime,mucadyn).eq.0) then - - do i=1,nmuca - IF(muca_smooth.eq.2.or.muca_smooth.eq.3) THEN - nemuca(i)=nemuca(i)+dlog(hist(i)+1) - ELSE - if (hist(i).gt.0) hist(i)=dlog(hist(i)) - nemuca(i)=nemuca(i)+hist(i) - ENDIF - hist(i)=0 - write(iout,'(a24,i8,2f12.5)')'nemuca before smoothing ', - & imtime,emuca(i),nemuca(i) - enddo - - - lnotend=.true. - ismooth=0 - ist=2 - ien=nmuca-1 - IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN -c lnotend=.false. -c do i=1,nmuca-1 -c do j=i+1,nmuca -c if(nemuca(j).lt.nemuca(i)) lnotend=.true. -c enddo -c enddo - do while(lnotend) - ismooth=ismooth+1 - write (iout,*) 'MUCA update smoothing',ist,ien - do i=ist,ien - nemuca(i)=(nemuca(i-1)+nemuca(i)+nemuca(i+1))/3 - enddo - lnotend=.false. - ist=0 - ien=0 - do i=1,nmuca-1 - do j=i+1,nmuca - if(nemuca(j).lt.nemuca(i)) then - lnotend=.true. - if(ist.eq.0) ist=i-1 - if(ien.lt.j+1) ien=j+1 - endif - enddo - enddo - enddo - ENDIF - - write (iout,*) 'MUCA update ',imtime,' smooth= ',ismooth - yp1=0 - ypn=0 - call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) - call print_muca - - endif - return - end - - double precision function muca_factor(energy) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - double precision y,yp,energy - - if (energy.lt.elow) then - call splint(emuca,nemuca,nemuca2,nmuca,elow,y,yp) - elseif (energy.gt.ehigh) then - call splint(emuca,nemuca,nemuca2,nmuca,ehigh,y,yp) - else - call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) - endif - - if(yp.ge.factor_min) then - muca_factor=yp - else - muca_factor=factor_min - endif -cd print *,'energy, muca_factor',energy,muca_factor - return - end - - - SUBROUTINE spline(x,y,n,yp1,ypn,y2) - INTEGER n,NMAX - REAL*8 yp1,ypn,x(n),y(n),y2(n) - PARAMETER (NMAX=500) - INTEGER i,k - REAL*8 p,qn,sig,un,u(NMAX) - if (yp1.gt..99e30) then - y2(1)=0. - u(1)=0. - else - y2(1)=-0.5 - u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) - endif - do i=2,n-1 - sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) - p=sig*y2(i-1)+2. - y2(i)=(sig-1.)/p - u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) - * /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p - enddo - if (ypn.gt..99e30) then - qn=0. - un=0. - else - qn=0.5 - un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) - endif - y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) - do k=n-1,1,-1 - y2(k)=y2(k)*y2(k+1)+u(k) - enddo - return - END - - - SUBROUTINE splint(xa,ya,y2a,n,x,y,yp) - INTEGER n - REAL*8 x,y,xa(n),y2a(n),ya(n),yp - INTEGER k,khi,klo - REAL*8 a,b,h - klo=1 - khi=n - 1 if (khi-klo.gt.1) then - k=(khi+klo)/2 - if (xa(k).gt.x) then - khi=k - else - klo=k - endif - goto 1 - endif - h=xa(khi)-xa(klo) - if (h.eq.0.) pause 'bad xa input in splint' - a=(xa(khi)-x)/h - b=(x-xa(klo))/h - y=a*ya(klo)+b*ya(khi)+ - * ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6. - yp=-ya(klo)/h+ya(khi)/h-3*(a**2)*y2a(klo)*h/6. - + +(3*(b**2)-1)*y2a(khi)*h/6. - return - END diff --git a/source/unres/src_MD_DFA/parmread.F b/source/unres/src_MD_DFA/parmread.F deleted file mode 100644 index 4ab807d..0000000 --- a/source/unres/src_MD_DFA/parmread.F +++ /dev/null @@ -1,1036 +0,0 @@ - subroutine parmread -C -C Read the parameters of the probability distributions of the virtual-bond -C valence angles and the side chains and energy parameters. -C -C Important! Energy-term weights ARE NOT read here; they are read from the -C main input file instead, because NO defaults have yet been set for these -C parameters. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" - integer IERROR -#endif - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.SCCOR' - include 'COMMON.SCROT' - include 'COMMON.FFIELD' - include 'COMMON.NAMES' - include 'COMMON.SBRIDGE' - include 'COMMON.MD' - include 'COMMON.SETUP' - character*1 t1,t2,t3 - character*1 onelett(4) /"G","A","P","D"/ - logical lprint,LaTeX - dimension blower(3,3,maxlob) - dimension b(13) - character*3 lancuch,ucase -C -C For printing parameters after they are read set the following in the UNRES -C C-shell script: -C -C setenv PRINT_PARM YES -C -C To print parameters in LaTeX format rather than as ASCII tables: -C -C setenv LATEX YES -C - call getenv_loc("PRINT_PARM",lancuch) - lprint = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") - call getenv_loc("LATEX",lancuch) - LaTeX = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") -C - dwa16=2.0d0**(1.0d0/6.0d0) - itypro=20 -C Assign virtual-bond length - vbl=3.8D0 - vblinv=1.0D0/vbl - vblinv2=vblinv*vblinv -c -c Read the virtual-bond parameters, masses, and moments of inertia -c and Stokes' radii of the peptide group and side chains -c -#ifdef CRYST_BOND - read (ibond,*) vbldp0,akp,mp,ip,pstok - do i=1,ntyp - nbondterm(i)=1 - read (ibond,*) vbldsc0(1,i),aksc(1,i),msc(i),isc(i),restok(i) - dsc(i) = vbldsc0(1,i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - enddo -#else - read (ibond,*) junk,vbldp0,akp,rjunk,mp,ip,pstok - do i=1,ntyp - read (ibond,*) nbondterm(i),(vbldsc0(j,i),aksc(j,i),abond0(j,i), - & j=1,nbondterm(i)),msc(i),isc(i),restok(i) - dsc(i) = vbldsc0(1,i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - enddo -#endif - if (lprint) then - write(iout,'(/a/)')"Dynamic constants of the interaction sites:" - write (iout,'(a10,a3,6a10)') 'Type','N','VBL','K','A0','mass', - & 'inertia','Pstok' - write(iout,'(a10,i3,6f10.5)') "p",1,vbldp0,akp,0.0d0,mp,ip,pstok - do i=1,ntyp - write (iout,'(a10,i3,6f10.5)') restyp(i),nbondterm(i), - & vbldsc0(1,i),aksc(1,i),abond0(1,i),msc(i),isc(i),restok(i) - do j=2,nbondterm(i) - write (iout,'(13x,3f10.5)') - & vbldsc0(j,i),aksc(j,i),abond0(j,i) - enddo - enddo - endif -#ifdef CRYST_THETA -C -C Read the parameters of the probability distribution/energy expression -C of the virtual-bond valence angles theta -C - do i=1,ntyp - read (ithep,*,err=111,end=111) a0thet(i),(athet(j,i),j=1,2), - & (bthet(j,i),j=1,2) - read (ithep,*,err=111,end=111) (polthet(j,i),j=0,3) - read (ithep,*,err=111,end=111) (gthet(j,i),j=1,3) - read (ithep,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) - sigc0(i)=sigc0(i)**2 - enddo - close (ithep) - if (lprint) then - if (.not.LaTeX) then - write (iout,'(a)') - & 'Parameters of the virtual-bond valence angles:' - write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:', - & ' ATHETA0 ',' A1 ',' A2 ', - & ' B1 ',' B2 ' - do i=1,ntyp - write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, - & a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the expression for sigma(theta_c):', - & ' ALPH0 ',' ALPH1 ',' ALPH2 ', - & ' ALPH3 ',' SIGMA0C ' - do i=1,ntyp - write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, - & (polthet(j,i),j=0,3),sigc0(i) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the second gaussian:', - & ' THETA0 ',' SIGMA0 ',' G1 ', - & ' G2 ',' G3 ' - do i=1,ntyp - write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i), - & sig0(i),(gthet(j,i),j=1,3) - enddo - else - write (iout,'(a)') - & 'Parameters of the virtual-bond valence angles:' - write (iout,'(/a/9x,5a/79(1h-))') - & 'Coefficients of expansion', - & ' theta0 ',' a1*10^2 ',' a2*10^2 ', - & ' b1*10^1 ',' b2*10^1 ' - do i=1,ntyp - write(iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i), - & a0thet(i),(100*athet(j,i),j=1,2),(10*bthet(j,i),j=1,2) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the expression for sigma(theta_c):', - & ' alpha0 ',' alph1 ',' alph2 ', - & ' alhp3 ',' sigma0c ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(1pe12.3,1h&))') restyp(i), - & (polthet(j,i),j=0,3),sigc0(i) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the second gaussian:', - & ' theta0 ',' sigma0*10^2 ',' G1*10^-1', - & ' G2 ',' G3*10^1 ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),theta0(i), - & 100*sig0(i),gthet(1,i)*0.1D0,gthet(2,i),gthet(3,i)*10.0D0 - enddo - endif - endif -#else -C -C Read the parameters of Utheta determined from ab initio surfaces -C Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -C - read (ithep,*,err=111,end=111) nthetyp,ntheterm,ntheterm2, - & ntheterm3,nsingle,ndouble - nntheterm=max0(ntheterm,ntheterm2,ntheterm3) - read (ithep,*,err=111,end=111) (ithetyp(i),i=1,ntyp1) - do i=1,maxthetyp - do j=1,maxthetyp - do k=1,maxthetyp - aa0thet(i,j,k)=0.0d0 - do l=1,ntheterm - aathet(l,i,j,k)=0.0d0 - enddo - do l=1,ntheterm2 - do m=1,nsingle - bbthet(m,l,i,j,k)=0.0d0 - ccthet(m,l,i,j,k)=0.0d0 - ddthet(m,l,i,j,k)=0.0d0 - eethet(m,l,i,j,k)=0.0d0 - enddo - enddo - do l=1,ntheterm3 - do m=1,ndouble - do mm=1,ndouble - ffthet(mm,m,l,i,j,k)=0.0d0 - ggthet(mm,m,l,i,j,k)=0.0d0 - enddo - enddo - enddo - enddo - enddo - enddo - do i=1,nthetyp - do j=1,nthetyp - do k=1,nthetyp - read (ithep,'(3a)',end=111,err=111) res1,res2,res3 - read (ithep,*,end=111,err=111) aa0thet(i,j,k) - read (ithep,*,end=111,err=111)(aathet(l,i,j,k),l=1,ntheterm) - read (ithep,*,end=111,err=111) - & ((bbthet(lll,ll,i,j,k),lll=1,nsingle), - & (ccthet(lll,ll,i,j,k),lll=1,nsingle), - & (ddthet(lll,ll,i,j,k),lll=1,nsingle), - & (eethet(lll,ll,i,j,k),lll=1,nsingle),ll=1,ntheterm2) - read (ithep,*,end=111,err=111) - & (((ffthet(llll,lll,ll,i,j,k),ffthet(lll,llll,ll,i,j,k), - & ggthet(llll,lll,ll,i,j,k),ggthet(lll,llll,ll,i,j,k), - & llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) - enddo - enddo - enddo -C -C For dummy ends assign glycine-type coefficients of theta-only terms; the -C coefficients of theta-and-gamma-dependent terms are zero. -C - do i=1,nthetyp - do j=1,nthetyp - do l=1,ntheterm - aathet(l,i,j,nthetyp+1)=aathet(l,i,j,1) - aathet(l,nthetyp+1,i,j)=aathet(l,1,i,j) - enddo - aa0thet(i,j,nthetyp+1)=aa0thet(i,j,1) - aa0thet(nthetyp+1,i,j)=aa0thet(1,i,j) - enddo - do l=1,ntheterm - aathet(l,nthetyp+1,i,nthetyp+1)=aathet(l,1,i,1) - enddo - aa0thet(nthetyp+1,i,nthetyp+1)=aa0thet(1,i,1) - enddo -C -C Control printout of the coefficients of virtual-bond-angle potentials -C - if (lprint) then - write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' - do i=1,nthetyp+1 - do j=1,nthetyp+1 - do k=1,nthetyp+1 - write (iout,'(//4a)') - & 'Type ',onelett(i),onelett(j),onelett(k) - write (iout,'(//a,10x,a)') " l","a[l]" - write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k) - write (iout,'(i2,1pe15.5)') - & (l,aathet(l,i,j,k),l=1,ntheterm) - do l=1,ntheterm2 - write (iout,'(//2h m,4(9x,a,3h[m,,i1,1h]))') - & "b",l,"c",l,"d",l,"e",l - do m=1,nsingle - write (iout,'(i2,4(1pe15.5))') m, - & bbthet(m,l,i,j,k),ccthet(m,l,i,j,k), - & ddthet(m,l,i,j,k),eethet(m,l,i,j,k) - enddo - enddo - do l=1,ntheterm3 - write (iout,'(//3hm,n,4(6x,a,5h[m,n,,i1,1h]))') - & "f+",l,"f-",l,"g+",l,"g-",l - do m=2,ndouble - do n=1,m-1 - write (iout,'(i1,1x,i1,4(1pe15.5))') n,m, - & ffthet(n,m,l,i,j,k),ffthet(m,n,l,i,j,k), - & ggthet(n,m,l,i,j,k),ggthet(m,n,l,i,j,k) - enddo - enddo - enddo - enddo - enddo - enddo - call flush(iout) - endif - write (2,*) "Start reading THETA_PDB" - do i=1,ntyp - read (ithep_pdb,*,err=111,end=111) a0thet(i),(athet(j,i),j=1,2), - & (bthet(j,i),j=1,2) - read (ithep_pdb,*,err=111,end=111) (polthet(j,i),j=0,3) - read (ithep_pdb,*,err=111,end=111) (gthet(j,i),j=1,3) - read (ithep_pdb,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) - sigc0(i)=sigc0(i)**2 - enddo - write (2,*) "End reading THETA_PDB" - close (ithep_pdb) -#endif - close(ithep) -#ifdef CRYST_SC -C -C Read the parameters of the probability distribution/energy expression -C of the side chains. -C - do i=1,ntyp - read (irotam,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - if (i.ne.10) then - do j=1,nlob(i) - do k=1,3 - do l=1,3 - blower(l,k,j)=0.0D0 - enddo - enddo - enddo - bsc(1,i)=0.0D0 - read(irotam,*,end=112,err=112)(censc(k,1,i),k=1,3), - & ((blower(k,l,1),l=1,k),k=1,3) - do j=2,nlob(i) - read (irotam,*,end=112,err=112) bsc(j,i) - read (irotam,*,end=112,err=112) (censc(k,j,i),k=1,3), - & ((blower(k,l,j),l=1,k),k=1,3) - enddo - do j=1,nlob(i) - do k=1,3 - do l=1,k - akl=0.0D0 - do m=1,3 - akl=akl+blower(k,m,j)*blower(l,m,j) - enddo - gaussc(k,l,j,i)=akl - gaussc(l,k,j,i)=akl - enddo - enddo - enddo - endif - enddo - close (irotam) - if (lprint) then - write (iout,'(/a)') 'Parameters of side-chain local geometry' - do i=1,ntyp - nlobi=nlob(i) - if (nlobi.gt.0) then - if (LaTeX) then - write (iout,'(/3a,i2,a,f8.3)') 'Residue type: ',restyp(i), - & ' # of gaussian lobes:',nlobi,' dsc:',dsc(i) - write (iout,'(1h&,a,3(2h&&,f8.3,2h&&))') - & 'log h',(bsc(j,i),j=1,nlobi) - write (iout,'(1h&,a,3(1h&,f8.3,1h&,f8.3,1h&,f8.3,1h&))') - & 'x',((censc(k,j,i),k=1,3),j=1,nlobi) - do k=1,3 - write (iout,'(2h& ,5(2x,1h&,3(f7.3,1h&)))') - & ((gaussc(k,l,j,i),l=1,3),j=1,nlobi) - enddo - else - write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi) - write (iout,'(a,f10.4,4(16x,f10.4))') - & 'Center ',(bsc(j,i),j=1,nlobi) - write (iout,'(5(2x,3f8.4))') ((censc(k,j,i),k=1,3), - & j=1,nlobi) - write (iout,'(a)') - endif - endif - enddo - endif -#else -C -C Read scrot parameters for potentials determined from all-atom AM1 calculations -C added by Urszula Kozlowska 07/11/2007 -C - do i=1,ntyp - read (irotam,*,end=112,err=112) - if (i.eq.10) then - read (irotam,*,end=112,err=112) - else - do j=1,65 - read(irotam,*,end=112,err=112) sc_parmin(j,i) - enddo - endif - enddo -C -C Read the parameters of the probability distribution/energy expression -C of the side chains. -C - do i=1,ntyp - read (irotam_pdb,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - if (i.ne.10) then - do j=1,nlob(i) - do k=1,3 - do l=1,3 - blower(l,k,j)=0.0D0 - enddo - enddo - enddo - bsc(1,i)=0.0D0 - read(irotam_pdb,*,end=112,err=112)(censc(k,1,i),k=1,3), - & ((blower(k,l,1),l=1,k),k=1,3) - do j=2,nlob(i) - read (irotam_pdb,*,end=112,err=112) bsc(j,i) - read (irotam_pdb,*,end=112,err=112) (censc(k,j,i),k=1,3), - & ((blower(k,l,j),l=1,k),k=1,3) - enddo - do j=1,nlob(i) - do k=1,3 - do l=1,k - akl=0.0D0 - do m=1,3 - akl=akl+blower(k,m,j)*blower(l,m,j) - enddo - gaussc(k,l,j,i)=akl - gaussc(l,k,j,i)=akl - enddo - enddo - enddo - endif - enddo - close (irotam_pdb) -#endif - close(irotam) - -#ifdef CRYST_TOR -C -C Read torsional parameters in old format -C - read (itorp,*,end=113,err=113) ntortyp,nterm_old - if (lprint)write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old - read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) - do i=1,ntortyp - do j=1,ntortyp - read (itorp,'(a)') - do k=1,nterm_old - read (itorp,*,end=113,err=113) kk,v1(k,j,i),v2(k,j,i) - enddo - enddo - enddo - close (itorp) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,ntortyp - do j=1,ntortyp - write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) - write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) - enddo - enddo - endif -#else -C -C Read torsional parameters -C - read (itorp,*,end=113,err=113) ntortyp - read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) -c write (iout,*) 'ntortyp',ntortyp - do i=1,ntortyp - do j=1,ntortyp - read (itorp,*,end=113,err=113) nterm(i,j),nlor(i,j) - v0ij=0.0d0 - si=-1.0d0 - do k=1,nterm(i,j) - read (itorp,*,end=113,err=113) kk,v1(k,i,j),v2(k,i,j) - v0ij=v0ij+si*v1(k,i,j) - si=-si - enddo - do k=1,nlor(i,j) - read (itorp,*,end=113,err=113) kk,vlor1(k,i,j), - & vlor2(k,i,j),vlor3(k,i,j) - v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) - enddo - v0(i,j)=v0ij - enddo - enddo - close (itorp) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,ntortyp - do j=1,ntortyp - write (iout,*) 'ityp',i,' jtyp',j - write (iout,*) 'Fourier constants' - do k=1,nterm(i,j) - write (iout,'(2(1pe15.5))') v1(k,i,j),v2(k,i,j) - enddo - write (iout,*) 'Lorenz constants' - do k=1,nlor(i,j) - write (iout,'(3(1pe15.5))') - & vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) - enddo - enddo - enddo - endif -C -C 6/23/01 Read parameters for double torsionals -C - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - read (itordp,'(3a1)',end=114,err=114) t1,t2,t3 - if (t1.ne.onelett(i) .or. t2.ne.onelett(j) - & .or. t3.ne.onelett(k)) then - write (iout,*) "Error in double torsional parameter file", - & i,j,k,t1,t2,t3 -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop "Error in double torsional parameter file" - endif - read (itordp,*,end=114,err=114) ntermd_1(i,j,k), - & ntermd_2(i,j,k) - read (itordp,*,end=114,err=114) (v1c(1,l,i,j,k),l=1, - & ntermd_1(i,j,k)) - read (itordp,*,end=114,err=114) (v1s(1,l,i,j,k),l=1, - & ntermd_1(i,j,k)) - read (itordp,*,end=114,err=114) (v1c(2,l,i,j,k),l=1, - & ntermd_1(i,j,k)) - read (itordp,*,end=114,err=114) (v1s(2,l,i,j,k),l=1, - & ntermd_1(i,j,k)) - read (itordp,*,end=114,err=114) ((v2c(l,m,i,j,k), - & v2c(m,l,i,j,k),v2s(l,m,i,j,k),v2s(m,l,i,j,k), - & m=1,l-1),l=1,ntermd_2(i,j,k)) - enddo - enddo - enddo - if (lprint) then - write (iout,*) - write (iout,*) 'Constants for double torsionals' - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k, - & ' nsingle',ntermd_1(i,j,k),' ndouble',ntermd_2(i,j,k) - write (iout,*) - write (iout,*) 'Single angles:' - do l=1,ntermd_1(i,j,k) - write (iout,'(i5,2f10.5,5x,2f10.5)') l, - & v1c(1,l,i,j,k),v1s(1,l,i,j,k), - & v1c(2,l,i,j,k),v1s(2,l,i,j,k) - enddo - write (iout,*) - write (iout,*) 'Pairs of angles:' - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) - do l=1,ntermd_2(i,j,k) - write (iout,'(i5,20f10.5)') - & l,(v2c(l,m,i,j,k),m=1,ntermd_2(i,j,k)) - enddo - write (iout,*) - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) - do l=1,ntermd_2(i,j,k) - write (iout,'(i5,20f10.5)') - & l,(v2s(l,m,i,j,k),m=1,ntermd_2(i,j,k)) - enddo - write (iout,*) - enddo - enddo - enddo - endif -#endif -C Read of Side-chain backbone correlation parameters -C Modified 11 May 2012 by Adasko -CCC -C - read (isccor,*,end=1113,err=1113) nsccortyp - read (isccor,*,end=1113,err=1113) (isccortyp(i),i=1,ntyp) -c write (iout,*) 'ntortyp',ntortyp - maxinter=3 -cc maxinter is maximum interaction sites - do l=1,maxinter - do i=1,nsccortyp - do j=1,nsccortyp - read (isccor,*,end=1113,err=1113) nterm_sccor(i,j), - & nlor_sccor(i,j) - v0ijsccor=0.0d0 - si=-1.0d0 - - do k=1,nterm_sccor(i,j) - read (isccor,*,end=1113,err=1113) kk,v1sccor(k,l,i,j) - & ,v2sccor(k,l,i,j) - v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) - si=-si - enddo - do k=1,nlor_sccor(i,j) - read (isccor,*,end=1113,err=1113) kk,vlor1sccor(k,i,j), - & vlor2sccor(k,i,j),vlor3sccor(k,i,j) - v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ - &(1+vlor3sccor(k,i,j)**2) - enddo - v0sccor(i,j)=v0ijsccor - enddo - enddo - enddo - close (isccor) - - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,nsccortyp - do j=1,nsccortyp - write (iout,*) 'ityp',i,' jtyp',j - write (iout,*) 'Fourier constants' - do k=1,nterm_sccor(i,j) - write (iout,'(2(1pe15.5))') v1sccor(k,l,i,j),v2sccor(k,l,i,j) - enddo - write (iout,*) 'Lorenz constants' - do k=1,nlor_sccor(i,j) - write (iout,'(3(1pe15.5))') - & vlor1sccor(k,i,j),vlor2sccor(k,i,j),vlor3sccor(k,i,j) - enddo - enddo - enddo - endif -C -C -C 9/18/99 (AL) Read coefficients of the Fourier expansion of the local -C interaction energy of the Gly, Ala, and Pro prototypes. -C - if (lprint) then - write (iout,*) - write (iout,*) "Coefficients of the cumulants" - endif - read (ifourier,*) nloctyp - do i=1,nloctyp - read (ifourier,*,end=115,err=115) - read (ifourier,*,end=115,err=115) (b(ii),ii=1,13) - if (lprint) then - write (iout,*) 'Type',i - write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii),ii=1,13) - endif - B1(1,i) = b(3) - B1(2,i) = b(5) -c b1(1,i)=0.0d0 -c b1(2,i)=0.0d0 - B1tilde(1,i) = b(3) - B1tilde(2,i) =-b(5) -c b1tilde(1,i)=0.0d0 -c b1tilde(2,i)=0.0d0 - B2(1,i) = b(2) - B2(2,i) = b(4) -c b2(1,i)=0.0d0 -c b2(2,i)=0.0d0 - CC(1,1,i)= b(7) - CC(2,2,i)=-b(7) - CC(2,1,i)= b(9) - CC(1,2,i)= b(9) -c CC(1,1,i)=0.0d0 -c CC(2,2,i)=0.0d0 -c CC(2,1,i)=0.0d0 -c CC(1,2,i)=0.0d0 - Ctilde(1,1,i)=b(7) - Ctilde(1,2,i)=b(9) - Ctilde(2,1,i)=-b(9) - Ctilde(2,2,i)=b(7) -c Ctilde(1,1,i)=0.0d0 -c Ctilde(1,2,i)=0.0d0 -c Ctilde(2,1,i)=0.0d0 -c Ctilde(2,2,i)=0.0d0 - DD(1,1,i)= b(6) - DD(2,2,i)=-b(6) - DD(2,1,i)= b(8) - DD(1,2,i)= b(8) -c DD(1,1,i)=0.0d0 -c DD(2,2,i)=0.0d0 -c DD(2,1,i)=0.0d0 -c DD(1,2,i)=0.0d0 - Dtilde(1,1,i)=b(6) - Dtilde(1,2,i)=b(8) - Dtilde(2,1,i)=-b(8) - Dtilde(2,2,i)=b(6) -c Dtilde(1,1,i)=0.0d0 -c Dtilde(1,2,i)=0.0d0 -c Dtilde(2,1,i)=0.0d0 -c Dtilde(2,2,i)=0.0d0 - EE(1,1,i)= b(10)+b(11) - EE(2,2,i)=-b(10)+b(11) - EE(2,1,i)= b(12)-b(13) - EE(1,2,i)= b(12)+b(13) -c ee(1,1,i)=1.0d0 -c ee(2,2,i)=1.0d0 -c ee(2,1,i)=0.0d0 -c ee(1,2,i)=0.0d0 -c ee(2,1,i)=ee(1,2,i) - enddo - if (lprint) then - do i=1,nloctyp - write (iout,*) 'Type',i - write (iout,*) 'B1' - write(iout,*) B1(1,i),B1(2,i) - write (iout,*) 'B2' - write(iout,*) B2(1,i),B2(2,i) - write (iout,*) 'CC' - do j=1,2 - write (iout,'(2f10.5)') CC(j,1,i),CC(j,2,i) - enddo - write(iout,*) 'DD' - do j=1,2 - write (iout,'(2f10.5)') DD(j,1,i),DD(j,2,i) - enddo - write(iout,*) 'EE' - do j=1,2 - write (iout,'(2f10.5)') EE(j,1,i),EE(j,2,i) - enddo - enddo - endif -C -C Read electrostatic-interaction parameters -C - if (lprint) then - write (iout,*) - write (iout,'(/a)') 'Electrostatic interaction constants:' - write (iout,'(1x,a,1x,a,10x,a,11x,a,11x,a,11x,a)') - & 'IT','JT','APP','BPP','AEL6','AEL3' - endif - read (ielep,*,end=116,err=116) ((epp(i,j),j=1,2),i=1,2) - read (ielep,*,end=116,err=116) ((rpp(i,j),j=1,2),i=1,2) - read (ielep,*,end=116,err=116) ((elpp6(i,j),j=1,2),i=1,2) - read (ielep,*,end=116,err=116) ((elpp3(i,j),j=1,2),i=1,2) - close (ielep) - do i=1,2 - do j=1,2 - rri=rpp(i,j)**6 - app (i,j)=epp(i,j)*rri*rri - bpp (i,j)=-2.0D0*epp(i,j)*rri - ael6(i,j)=elpp6(i,j)*4.2D0**6 - ael3(i,j)=elpp3(i,j)*4.2D0**3 - if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j), - & ael6(i,j),ael3(i,j) - enddo - enddo -C -C Read side-chain interaction parameters. -C - read (isidep,*,end=117,err=117) ipot,expon - if (ipot.lt.1 .or. ipot.gt.5) then - write (iout,'(2a)') 'Error while reading SC interaction', - & 'potential file - unknown potential type.' -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop - endif - expon2=expon/2 - if(me.eq.king) - & write(iout,'(/3a,2i3)') 'Potential is ',potname(ipot), - & ', exponents are ',expon,2*expon - goto (10,20,30,30,40) ipot -C----------------------- LJ potential --------------------------------- - 10 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJ potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,a)') 'residue','sigma' - write (iout,'(a3,6x,f10.5)') (restyp(i),sigma0(i),i=1,ntyp) - endif - goto 50 -C----------------------- LJK potential -------------------------------- - 20 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJK potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,2a)') 'residue',' sigma ',' r0 ' - write (iout,'(a3,6x,2f10.5)') (restyp(i),sigma0(i),rr0(i), - & i=1,ntyp) - endif - goto 50 -C---------------------- GB or BP potential ----------------------------- - 30 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(sigii(i),i=1,ntyp),(chip(i),i=1,ntyp), - & (alp(i),i=1,ntyp) -C For the GB potential convert sigma'**2 into chi' - if (ipot.eq.4) then - do i=1,ntyp - chip(i)=(chip(i)-1.0D0)/(chip(i)+1.0D0) - enddo - endif - if (lprint) then - write (iout,'(/a/)') 'Parameters of the BP potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,4a)') 'residue',' sigma ','s||/s_|_^2', - & ' chip ',' alph ' - write (iout,'(a3,6x,4f10.5)') (restyp(i),sigma0(i),sigii(i), - & chip(i),alp(i),i=1,ntyp) - endif - goto 50 -C--------------------- GBV potential ----------------------------------- - 40 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp),(sigii(i),i=1,ntyp), - & (chip(i),i=1,ntyp),(alp(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the GBV potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,5a)') 'residue',' sigma ',' r0 ', - & 's||/s_|_^2',' chip ',' alph ' - write (iout,'(a3,6x,5f10.5)') (restyp(i),sigma0(i),rr0(i), - & sigii(i),chip(i),alp(i),i=1,ntyp) - endif - 50 continue - close (isidep) -C----------------------------------------------------------------------- -C Calculate the "working" parameters of SC interactions. - do i=2,ntyp - do j=1,i-1 - eps(i,j)=eps(j,i) - enddo - enddo - do i=1,ntyp - do j=i,ntyp - sigma(i,j)=dsqrt(sigma0(i)**2+sigma0(j)**2) - sigma(j,i)=sigma(i,j) - rs0(i,j)=dwa16*sigma(i,j) - rs0(j,i)=rs0(i,j) - enddo - enddo - if (lprint) write (iout,'(/a/10x,7a/72(1h-))') - & 'Working parameters of the SC interactions:', - & ' a ',' b ',' augm ',' sigma ',' r0 ', - & ' chi1 ',' chi2 ' - do i=1,ntyp - do j=i,ntyp - epsij=eps(i,j) - if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then - rrij=sigma(i,j) - else - rrij=rr0(i)+rr0(j) - endif - r0(i,j)=rrij - r0(j,i)=rrij - rrij=rrij**expon - epsij=eps(i,j) - sigeps=dsign(1.0D0,epsij) - epsij=dabs(epsij) - aa(i,j)=epsij*rrij*rrij - bb(i,j)=-sigeps*epsij*rrij - aa(j,i)=aa(i,j) - bb(j,i)=bb(i,j) - if (ipot.gt.2) then - sigt1sq=sigma0(i)**2 - sigt2sq=sigma0(j)**2 - sigii1=sigii(i) - sigii2=sigii(j) - ratsig1=sigt2sq/sigt1sq - ratsig2=1.0D0/ratsig1 - chi(i,j)=(sigii1-1.0D0)/(sigii1+ratsig1) - if (j.gt.i) chi(j,i)=(sigii2-1.0D0)/(sigii2+ratsig2) - rsum_max=dsqrt(sigii1*sigt1sq+sigii2*sigt2sq) - else - rsum_max=sigma(i,j) - endif -c if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then - sigmaii(i,j)=rsum_max - sigmaii(j,i)=rsum_max -c else -c sigmaii(i,j)=r0(i,j) -c sigmaii(j,i)=r0(i,j) -c endif -cd write (iout,*) i,j,r0(i,j),sigma(i,j),rsum_max - if ((ipot.eq.2 .or. ipot.eq.5) .and. r0(i,j).gt.rsum_max) then - r_augm=sigma(i,j)*(rrij-sigma(i,j))/rrij - augm(i,j)=epsij*r_augm**(2*expon) -c augm(i,j)=0.5D0**(2*expon)*aa(i,j) - augm(j,i)=augm(i,j) - else - augm(i,j)=0.0D0 - augm(j,i)=0.0D0 - endif - if (lprint) then - write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') - & restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j), - & sigma(i,j),r0(i,j),chi(i,j),chi(j,i) - endif - enddo - enddo -#ifdef OLDSCP -C -C Define the SC-p interaction constants (hard-coded; old style) -C - do i=1,20 -C "Soft" SC-p repulsion (causes helices to be too flat, but facilitates -C helix formation) -c aad(i,1)=0.3D0*4.0D0**12 -C Following line for constants currently implemented -C "Hard" SC-p repulsion (gives correct turn spacing in helices) - aad(i,1)=1.5D0*4.0D0**12 -c aad(i,1)=0.17D0*5.6D0**12 - aad(i,2)=aad(i,1) -C "Soft" SC-p repulsion - bad(i,1)=0.0D0 -C Following line for constants currently implemented -c aad(i,1)=0.3D0*4.0D0**6 -C "Hard" SC-p repulsion - bad(i,1)=3.0D0*4.0D0**6 -c bad(i,1)=-2.0D0*0.17D0*5.6D0**6 - bad(i,2)=bad(i,1) -c aad(i,1)=0.0D0 -c aad(i,2)=0.0D0 -c bad(i,1)=1228.8D0 -c bad(i,2)=1228.8D0 - enddo -#else -C -C 8/9/01 Read the SC-p interaction constants from file -C - do i=1,ntyp - read (iscpp,*,end=118,err=118) (eps_scp(i,j),rscp(i,j),j=1,2) - enddo - do i=1,ntyp - aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12 - aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12 - bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6 - bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6 - enddo - - if (lprint) then - write (iout,*) "Parameters of SC-p interactions:" - do i=1,20 - write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1), - & eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) - enddo - endif -#endif -C -C Define the constants of the disulfide bridge -C - ebr=-5.50D0 -c -c Old arbitrary potential - commented out. -c -c dbr= 4.20D0 -c fbr= 3.30D0 -c -c Constants of the disulfide-bond potential determined based on the RHF/6-31G** -c energy surface of diethyl disulfide. -c A. Liwo and U. Kozlowska, 11/24/03 -c - D0CM = 3.78d0 - AKCM = 15.1d0 - AKTH = 11.0d0 - AKCT = 12.0d0 - V1SS =-1.08d0 - V2SS = 7.61d0 - V3SS = 13.7d0 -c akcm=0.0d0 -c akth=0.0d0 -c akct=0.0d0 -c v1ss=0.0d0 -c v2ss=0.0d0 -c v3ss=0.0d0 - - if(me.eq.king) then - write (iout,'(/a)') "Disulfide bridge parameters:" - write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr - write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm - write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct - write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss, - & ' v3ss:',v3ss - endif - return - 111 write (iout,*) "Error reading bending energy parameters." - goto 999 - 112 write (iout,*) "Error reading rotamer energy parameters." - goto 999 - 113 write (iout,*) "Error reading torsional energy parameters." - goto 999 - 1113 write (iout,*) - & "Error reading side-chain torsional energy parameters." - goto 999 - 114 write (iout,*) "Error reading double torsional energy parameters." - goto 999 - 115 write (iout,*) - & "Error reading cumulant (multibody energy) parameters." - goto 999 - 116 write (iout,*) "Error reading electrostatic energy parameters." - goto 999 - 117 write (iout,*) "Error reading side chain interaction parameters." - goto 999 - 118 write (iout,*) "Error reading SCp interaction parameters." - goto 999 - 119 write (iout,*) "Error reading SCCOR parameters" - 999 continue -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop - return - end - - - subroutine getenv_loc(var, val) - character(*) var, val - -#ifdef WINIFL - character(2000) line - external ilen - - open (196,file='env',status='old',readonly,shared) - iread=0 -c write(*,*)'looking for ',var -10 read(196,*,err=11,end=11)line - iread=index(line,var) -c write(*,*)iread,' ',var,' ',line - if (iread.eq.0) go to 10 -c write(*,*)'---> ',line -11 continue - if(iread.eq.0) then -c write(*,*)'CHUJ' - val='' - else - iread=iread+ilen(var)+1 - read (line(iread:),*,err=12,end=12) val -c write(*,*)'OK: ',var,' = ',val - endif - close(196) - return -12 val='' - close(196) -#elif (defined CRAY) - integer lennam,lenval,ierror -c -c getenv using a POSIX call, useful on the T3D -c Sept 1996, comment out error check on advice of H. Pritchard -c - lennam = len(var) - if(lennam.le.0) stop '--error calling getenv--' - call pxfgetenv(var,lennam,val,lenval,ierror) -c-HP- if(ierror.ne.0) stop '--error returned by pxfgetenv--' -#else - call getenv(var,val) -#endif - - return - end diff --git a/source/unres/src_MD_DFA/pinorm.f b/source/unres/src_MD_DFA/pinorm.f deleted file mode 100644 index 91392bf..0000000 --- a/source/unres/src_MD_DFA/pinorm.f +++ /dev/null @@ -1,17 +0,0 @@ - double precision function pinorm(x) - implicit real*8 (a-h,o-z) -c -c this function takes an angle (in radians) and puts it in the range of -c -pi to +pi. -c - integer n - include 'COMMON.GEO' - n = x / dwapi - pinorm = x - n * dwapi - if ( pinorm .gt. pi ) then - pinorm = pinorm - dwapi - else if ( pinorm .lt. - pi ) then - pinorm = pinorm + dwapi - end if - return - end diff --git a/source/unres/src_MD_DFA/printmat.f b/source/unres/src_MD_DFA/printmat.f deleted file mode 100644 index be2b38f..0000000 --- a/source/unres/src_MD_DFA/printmat.f +++ /dev/null @@ -1,16 +0,0 @@ - subroutine printmat(ldim,m,n,iout,key,a) - character*3 key(n) - double precision a(ldim,n) - do 1 i=1,n,8 - nlim=min0(i+7,n) - write (iout,1000) (key(k),k=i,nlim) - write (iout,1020) - 1000 format (/5x,8(6x,a3)) - 1020 format (/80(1h-)/) - do 2 j=1,n - write (iout,1010) key(j),(a(j,k),k=i,nlim) - 2 continue - 1 continue - 1010 format (a3,2x,8(f9.4)) - return - end diff --git a/source/unres/src_MD_DFA/prng.f b/source/unres/src_MD_DFA/prng.f deleted file mode 100644 index 73f6766..0000000 --- a/source/unres/src_MD_DFA/prng.f +++ /dev/null @@ -1,525 +0,0 @@ - real*8 function prng_next(me) - implicit none - integer me -c -c Calling sequence: -c = prng_next ( ) -c = vprng ( , , ) -c -c This code is based on a sequential algorithm provided by Mal Kalos. -c This version uses a single 64-bit word to store the initial seeds -c and additive constants. -c A 64-bit floating point number is returned. -c -c The array "iparam" is full-word aligned, being padded by zeros to -c let each generator be on a subpage boundary. -c That is, rows 1 and 2 in a given column of the array are for real, -c rows 3-16 are bogus. -c -c July 12, 1993: double the number of sequences. We should have been -c using two packets per seed, rather than four -c October 31, 1993: merge the two arrays of seeds and constants, -c and switch to 64-bit arithmetic. -c June 1994: port to RS6K. Internal state is kept as 2 64-bit integers -c The ishft function is defined only on 32-bit integers, so we will -c shift numbers by dividing by 2**11 and then adding on 2**53-1. -c -c November 1994: ishift now works on 64-bit numbers (though it gives a -c warning). Thus we go back to using it. John Zollweg also added the -c vprng() routine to return vectors of real*8 random numbers. -c - real*8 recip53 - parameter ( recip53 = 2.0D0**(-53) ) - integer*8 two - parameter ( two = 2**11) - integer*8 m,ishift -c parameter ( m = 34522712143931 ) ! 11**13 -c parameter ( ishift = 9007199254740991 ) ! 2**53-1 - - integer nmax - integer*8 iparam - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - integer*8 next - -crc g77 doesn't support integer*8 constants - m = dint(34522712143931.0d0) - ishift = dint(9007199254740991.0d0) - -c RS6K porting note: ishift now takes 64-bit integers , with a warning - if ( 0.le.me .and. me.le.nmax ) then - next = iparam(1,me)*m + iparam(2,me) - iparam(1,me) = next - prng_next = recip53 * ishft( next, -11 ) - else - prng_next=-1.0D0 - endif - - end -c -c vprng(me, rn, num) Get a vector of random numbers -c - subroutine vprng(me,rn,num) - real*8 recip53, rn(1) - parameter ( recip53 = 2.0D0**(-53) ) - integer*8 m,iparam -c parameter ( m = 34522712143931 ) ! 11**13 - integer nmax, num, me - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - integer*8 next - -crc g77 doesn't support integer*8 constants - m = dint(34522712143931.0d0) - - if ( 0.le.me .and. me.le.nmax ) then - do 1 i=1,num - next = iparam(1,me)*m + iparam(2,me) - iparam(1,me) = next - rn(i) = recip53 * ishft( next, -11 ) - 1 continue - else - rn(1)=-1.0D0 - endif - return - end - -c -c prng_chkpnt Get the current state of a generator -c -c Calling sequence: -c logical prng_chkpnt, status -c status = prng_chkpnt (me, iseed) where -c -c me is the particular generator whose state is being gotten -c seed is an 4-element integer array where the "l"-values will be saved -c - logical function prng_chkpnt (me, iseed) - implicit none - integer me - integer*8 iseed - - integer nmax - integer*8 iparam - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - if (me .lt. 0 .or. me .gt. nmax) then - prng_chkpnt=.false. - else - prng_chkpnt=.true. - iseed=iparam(1,me) - endif - end -c -c prng_restart Restart generator from a saved state -c -c Calling sequence: -c logical prng_restart, status -c status = prng_restart (me, iseed) where -c -c me is the particular generator being restarted -c iseed is a 8-byte integer containing the "l"-values -c - logical function prng_restart (me, iseed) - implicit none - integer me - integer*8 iseed - - integer nmax - integer*8 iparam - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - if (me .lt. 0 .or. me .gt. nmax) then - prng_restart=.false. - return - else - prng_restart=.true. - iparam(1,me)=iseed - endif - end - - block data prngblk - parameter(nmax=1021) - integer*8 iparam - common/ksrprng/iparam(2,0:nmax) - data (iparam(1,i),iparam(2,i),i= 0, 29) / - + 11848219, 11848219, 11848237, 11848237, 11848241, 11848241, - + 11848247, 11848247, 11848253, 11848253, 11848271, 11848271, - + 11848297, 11848297, 11848313, 11848313, 11848339, 11848339, - + 11848351, 11848351, 11848357, 11848357, 11848363, 11848363, - + 11848367, 11848367, 11848373, 11848373, 11848379, 11848379, - + 11848393, 11848393, 11848433, 11848433, 11848451, 11848451, - + 11848469, 11848469, 11848477, 11848477, 11848489, 11848489, - + 11848493, 11848493, 11848513, 11848513, 11848523, 11848523, - + 11848531, 11848531, 11848537, 11848537, 11848553, 11848553, - + 11848589, 11848589, 11848591, 11848591, 11848601, 11848601 / - data (iparam(1,i),iparam(2,i),i= 30, 59) / - + 11848619, 11848619, 11848637, 11848637, 11848663, 11848663, - + 11848673, 11848673, 11848679, 11848679, 11848691, 11848691, - + 11848699, 11848699, 11848709, 11848709, 11848717, 11848717, - + 11848721, 11848721, 11848729, 11848729, 11848741, 11848741, - + 11848751, 11848751, 11848757, 11848757, 11848787, 11848787, - + 11848801, 11848801, 11848829, 11848829, 11848853, 11848853, - + 11848861, 11848861, 11848867, 11848867, 11848873, 11848873, - + 11848891, 11848891, 11848909, 11848909, 11848919, 11848919, - + 11848931, 11848931, 11848937, 11848937, 11848961, 11848961, - + 11848981, 11848981, 11849021, 11849021, 11849039, 11849039 / - data (iparam(1,i),iparam(2,i),i= 60, 89) / - + 11849053, 11849053, 11849059, 11849059, 11849069, 11849069, - + 11849077, 11849077, 11849087, 11849087, 11849093, 11849093, - + 11849107, 11849107, 11849111, 11849111, 11849129, 11849129, - + 11849137, 11849137, 11849177, 11849177, 11849183, 11849183, - + 11849203, 11849203, 11849231, 11849231, 11849237, 11849237, - + 11849239, 11849239, 11849249, 11849249, 11849251, 11849251, - + 11849269, 11849269, 11849273, 11849273, 11849291, 11849291, - + 11849297, 11849297, 11849309, 11849309, 11849339, 11849339, - + 11849359, 11849359, 11849363, 11849363, 11849399, 11849399, - + 11849401, 11849401, 11849413, 11849413, 11849417, 11849417 / - data (iparam(1,i),iparam(2,i),i= 90, 119) / - + 11849437, 11849437, 11849443, 11849443, 11849473, 11849473, - + 11849491, 11849491, 11849503, 11849503, 11849507, 11849507, - + 11849557, 11849557, 11849567, 11849567, 11849569, 11849569, - + 11849573, 11849573, 11849587, 11849587, 11849599, 11849599, - + 11849633, 11849633, 11849641, 11849641, 11849653, 11849653, - + 11849659, 11849659, 11849671, 11849671, 11849683, 11849683, - + 11849689, 11849689, 11849693, 11849693, 11849699, 11849699, - + 11849701, 11849701, 11849707, 11849707, 11849713, 11849713, - + 11849723, 11849723, 11849741, 11849741, 11849743, 11849743, - + 11849759, 11849759, 11849767, 11849767, 11849771, 11849771 / - data (iparam(1,i),iparam(2,i),i= 120, 149) / - + 11849791, 11849791, 11849801, 11849801, 11849809, 11849809, - + 11849813, 11849813, 11849869, 11849869, 11849881, 11849881, - + 11849891, 11849891, 11849909, 11849909, 11849923, 11849923, - + 11849933, 11849933, 11849947, 11849947, 11849987, 11849987, - + 11850001, 11850001, 11850011, 11850011, 11850019, 11850019, - + 11850023, 11850023, 11850031, 11850031, 11850049, 11850049, - + 11850061, 11850061, 11850073, 11850073, 11850077, 11850077, - + 11850103, 11850103, 11850109, 11850109, 11850121, 11850121, - + 11850127, 11850127, 11850133, 11850133, 11850149, 11850149, - + 11850161, 11850161, 11850169, 11850169, 11850191, 11850191 / - data (iparam(1,i),iparam(2,i),i= 150, 179) / - + 11850233, 11850233, 11850247, 11850247, 11850259, 11850259, - + 11850269, 11850269, 11850283, 11850283, 11850301, 11850301, - + 11850341, 11850341, 11850347, 11850347, 11850367, 11850367, - + 11850373, 11850373, 11850379, 11850379, 11850389, 11850389, - + 11850407, 11850407, 11850427, 11850427, 11850437, 11850437, - + 11850469, 11850469, 11850481, 11850481, 11850511, 11850511, - + 11850529, 11850529, 11850541, 11850541, 11850557, 11850557, - + 11850607, 11850607, 11850611, 11850611, 11850667, 11850667, - + 11850677, 11850677, 11850679, 11850679, 11850701, 11850701, - + 11850731, 11850731, 11850739, 11850739, 11850749, 11850749 / - data (iparam(1,i),iparam(2,i),i= 180, 209) / - + 11850791, 11850791, 11850803, 11850803, 11850829, 11850829, - + 11850833, 11850833, 11850859, 11850859, 11850877, 11850877, - + 11850899, 11850899, 11850907, 11850907, 11850913, 11850913, - + 11850919, 11850919, 11850931, 11850931, 11850941, 11850941, - + 11850947, 11850947, 11850953, 11850953, 11850961, 11850961, - + 11850983, 11850983, 11850991, 11850991, 11850997, 11850997, - + 11851031, 11851031, 11851033, 11851033, 11851051, 11851051, - + 11851061, 11851061, 11851067, 11851067, 11851093, 11851093, - + 11851109, 11851109, 11851123, 11851123, 11851127, 11851127, - + 11851139, 11851139, 11851157, 11851157, 11851163, 11851163 / - data (iparam(1,i),iparam(2,i),i= 210, 239) / - + 11851181, 11851181, 11851201, 11851201, 11851219, 11851219, - + 11851291, 11851291, 11851303, 11851303, 11851309, 11851309, - + 11851313, 11851313, 11851319, 11851319, 11851349, 11851349, - + 11851351, 11851351, 11851361, 11851361, 11851373, 11851373, - + 11851403, 11851403, 11851409, 11851409, 11851423, 11851423, - + 11851447, 11851447, 11851451, 11851451, 11851481, 11851481, - + 11851493, 11851493, 11851519, 11851519, 11851523, 11851523, - + 11851529, 11851529, 11851547, 11851547, 11851549, 11851549, - + 11851559, 11851559, 11851577, 11851577, 11851589, 11851589, - + 11851591, 11851591, 11851597, 11851597, 11851603, 11851603 / - data (iparam(1,i),iparam(2,i),i= 240, 269) / - + 11851607, 11851607, 11851613, 11851613, 11851621, 11851621, - + 11851627, 11851627, 11851639, 11851639, 11851673, 11851673, - + 11851681, 11851681, 11851727, 11851727, 11851753, 11851753, - + 11851759, 11851759, 11851787, 11851787, 11851793, 11851793, - + 11851799, 11851799, 11851813, 11851813, 11851841, 11851841, - + 11851859, 11851859, 11851867, 11851867, 11851891, 11851891, - + 11851909, 11851909, 11851919, 11851919, 11851927, 11851927, - + 11851933, 11851933, 11851949, 11851949, 11851967, 11851967, - + 11851997, 11851997, 11852017, 11852017, 11852051, 11852051, - + 11852053, 11852053, 11852059, 11852059, 11852083, 11852083 / - data (iparam(1,i),iparam(2,i),i= 270, 299) / - + 11852089, 11852089, 11852129, 11852129, 11852147, 11852147, - + 11852149, 11852149, 11852161, 11852161, 11852171, 11852171, - + 11852177, 11852177, 11852209, 11852209, 11852221, 11852221, - + 11852237, 11852237, 11852251, 11852251, 11852263, 11852263, - + 11852273, 11852273, 11852279, 11852279, 11852287, 11852287, - + 11852293, 11852293, 11852297, 11852297, 11852303, 11852303, - + 11852311, 11852311, 11852327, 11852327, 11852339, 11852339, - + 11852341, 11852341, 11852359, 11852359, 11852369, 11852369, - + 11852437, 11852437, 11852453, 11852453, 11852459, 11852459, - + 11852473, 11852473, 11852513, 11852513, 11852531, 11852531 / - data (iparam(1,i),iparam(2,i),i= 300, 329) / - + 11852537, 11852537, 11852539, 11852539, 11852557, 11852557, - + 11852573, 11852573, 11852579, 11852579, 11852591, 11852591, - + 11852609, 11852609, 11852611, 11852611, 11852623, 11852623, - + 11852641, 11852641, 11852647, 11852647, 11852657, 11852657, - + 11852663, 11852663, 11852717, 11852717, 11852719, 11852719, - + 11852741, 11852741, 11852759, 11852759, 11852767, 11852767, - + 11852773, 11852773, 11852803, 11852803, 11852807, 11852807, - + 11852809, 11852809, 11852831, 11852831, 11852833, 11852833, - + 11852837, 11852837, 11852857, 11852857, 11852873, 11852873, - + 11852879, 11852879, 11852891, 11852891, 11852917, 11852917 / - data (iparam(1,i),iparam(2,i),i= 330, 359) / - + 11852921, 11852921, 11852957, 11852957, 11852959, 11852959, - + 11852969, 11852969, 11852983, 11852983, 11852989, 11852989, - + 11853001, 11853001, 11853013, 11853013, 11853019, 11853019, - + 11853031, 11853031, 11853089, 11853089, 11853133, 11853133, - + 11853157, 11853157, 11853161, 11853161, 11853181, 11853181, - + 11853203, 11853203, 11853217, 11853217, 11853221, 11853221, - + 11853227, 11853227, 11853241, 11853241, 11853307, 11853307, - + 11853319, 11853319, 11853323, 11853323, 11853329, 11853329, - + 11853367, 11853367, 11853383, 11853383, 11853419, 11853419, - + 11853421, 11853421, 11853427, 11853427, 11853449, 11853449 / - data (iparam(1,i),iparam(2,i),i= 360, 389) / - + 11853451, 11853451, 11853463, 11853463, 11853529, 11853529, - + 11853557, 11853557, 11853571, 11853571, 11853601, 11853601, - + 11853613, 11853613, 11853617, 11853617, 11853629, 11853629, - + 11853649, 11853649, 11853659, 11853659, 11853679, 11853679, - + 11853689, 11853689, 11853719, 11853719, 11853731, 11853731, - + 11853757, 11853757, 11853761, 11853761, 11853773, 11853773, - + 11853791, 11853791, 11853817, 11853817, 11853839, 11853839, - + 11853847, 11853847, 11853857, 11853857, 11853869, 11853869, - + 11853883, 11853883, 11853887, 11853887, 11853889, 11853889, - + 11853893, 11853893, 11853899, 11853899, 11853911, 11853911 / - data (iparam(1,i),iparam(2,i),i= 390, 419) / - + 11853931, 11853931, 11853943, 11853943, 11853979, 11853979, - + 11853991, 11853991, 11854001, 11854001, 11854009, 11854009, - + 11854019, 11854019, 11854057, 11854057, 11854061, 11854061, - + 11854147, 11854147, 11854159, 11854159, 11854163, 11854163, - + 11854169, 11854169, 11854211, 11854211, 11854247, 11854247, - + 11854261, 11854261, 11854267, 11854267, 11854279, 11854279, - + 11854303, 11854303, 11854327, 11854327, 11854331, 11854331, - + 11854333, 11854333, 11854363, 11854363, 11854379, 11854379, - + 11854399, 11854399, 11854411, 11854411, 11854429, 11854429, - + 11854433, 11854433, 11854439, 11854439, 11854441, 11854441 / - data (iparam(1,i),iparam(2,i),i= 420, 449) / - + 11854463, 11854463, 11854477, 11854477, 11854489, 11854489, - + 11854517, 11854517, 11854519, 11854519, 11854523, 11854523, - + 11854529, 11854529, 11854567, 11854567, 11854571, 11854571, - + 11854573, 11854573, 11854603, 11854603, 11854607, 11854607, - + 11854681, 11854681, 11854691, 11854691, 11854709, 11854709, - + 11854723, 11854723, 11854757, 11854757, 11854783, 11854783, - + 11854793, 11854793, 11854813, 11854813, 11854847, 11854847, - + 11854853, 11854853, 11854873, 11854873, 11854877, 11854877, - + 11854883, 11854883, 11854891, 11854891, 11854897, 11854897, - + 11854901, 11854901, 11854919, 11854919, 11854937, 11854937 / - data (iparam(1,i),iparam(2,i),i= 450, 479) / - + 11854961, 11854961, 11854963, 11854963, 11854979, 11854979, - + 11855003, 11855003, 11855017, 11855017, 11855023, 11855023, - + 11855029, 11855029, 11855033, 11855033, 11855111, 11855111, - + 11855141, 11855141, 11855147, 11855147, 11855149, 11855149, - + 11855159, 11855159, 11855177, 11855177, 11855203, 11855203, - + 11855213, 11855213, 11855219, 11855219, 11855231, 11855231, - + 11855267, 11855267, 11855269, 11855269, 11855303, 11855303, - + 11855309, 11855309, 11855321, 11855321, 11855329, 11855329, - + 11855339, 11855339, 11855351, 11855351, 11855353, 11855353, - + 11855357, 11855357, 11855359, 11855359, 11855381, 11855381 / - data (iparam(1,i),iparam(2,i),i= 480, 509) / - + 11855383, 11855383, 11855387, 11855387, 11855399, 11855399, - + 11855407, 11855407, 11855413, 11855413, 11855489, 11855489, - + 11855491, 11855491, 11855507, 11855507, 11855521, 11855521, - + 11855531, 11855531, 11855549, 11855549, 11855551, 11855551, - + 11855567, 11855567, 11855581, 11855581, 11855587, 11855587, - + 11855593, 11855593, 11855633, 11855633, 11855653, 11855653, - + 11855663, 11855663, 11855687, 11855687, 11855689, 11855689, - + 11855699, 11855699, 11855713, 11855713, 11855731, 11855731, - + 11855737, 11855737, 11855743, 11855743, 11855747, 11855747, - + 11855759, 11855759, 11855773, 11855773, 11855801, 11855801 / - data (iparam(1,i),iparam(2,i),i= 510, 539) / - + 11855807, 11855807, 11855813, 11855813, 11855827, 11855827, - + 11855839, 11855839, 11855869, 11855869, 11855881, 11855881, - + 11855903, 11855903, 11855911, 11855911, 11855933, 11855933, - + 11855959, 11855959, 11855989, 11855989, 11855993, 11855993, - + 11855999, 11855999, 11856001, 11856001, 11856023, 11856023, - + 11856049, 11856049, 11856071, 11856071, 11856101, 11856101, - + 11856107, 11856107, 11856113, 11856113, 11856139, 11856139, - + 11856151, 11856151, 11856161, 11856161, 11856179, 11856179, - + 11856193, 11856193, 11856199, 11856199, 11856223, 11856223, - + 11856239, 11856239, 11856263, 11856263, 11856269, 11856269 / - data (iparam(1,i),iparam(2,i),i= 540, 569) / - + 11856281, 11856281, 11856287, 11856287, 11856307, 11856307, - + 11856311, 11856311, 11856329, 11856329, 11856343, 11856343, - + 11856359, 11856359, 11856371, 11856371, 11856373, 11856373, - + 11856409, 11856409, 11856419, 11856419, 11856461, 11856461, - + 11856469, 11856469, 11856473, 11856473, 11856479, 11856479, - + 11856511, 11856511, 11856517, 11856517, 11856541, 11856541, - + 11856547, 11856547, 11856553, 11856553, 11856583, 11856583, - + 11856629, 11856629, 11856641, 11856641, 11856653, 11856653, - + 11856659, 11856659, 11856673, 11856673, 11856697, 11856697, - + 11856709, 11856709, 11856727, 11856727, 11856731, 11856731 / - data (iparam(1,i),iparam(2,i),i= 570, 599) / - + 11856763, 11856763, 11856809, 11856809, 11856811, 11856811, - + 11856821, 11856821, 11856841, 11856841, 11856857, 11856857, - + 11856877, 11856877, 11856883, 11856883, 11856899, 11856899, - + 11856919, 11856919, 11856947, 11856947, 11856953, 11856953, - + 11856979, 11856979, 11857003, 11857003, 11857033, 11857033, - + 11857037, 11857037, 11857039, 11857039, 11857049, 11857049, - + 11857061, 11857061, 11857067, 11857067, 11857073, 11857073, - + 11857081, 11857081, 11857091, 11857091, 11857093, 11857093, - + 11857099, 11857099, 11857123, 11857123, 11857127, 11857127, - + 11857147, 11857147, 11857151, 11857151, 11857193, 11857193 / - data (iparam(1,i),iparam(2,i),i= 600, 629) / - + 11857217, 11857217, 11857229, 11857229, 11857243, 11857243, - + 11857249, 11857249, 11857267, 11857267, 11857277, 11857277, - + 11857291, 11857291, 11857303, 11857303, 11857309, 11857309, - + 11857327, 11857327, 11857331, 11857331, 11857333, 11857333, - + 11857361, 11857361, 11857367, 11857367, 11857369, 11857369, - + 11857393, 11857393, 11857399, 11857399, 11857409, 11857409, - + 11857421, 11857421, 11857423, 11857423, 11857451, 11857451, - + 11857453, 11857453, 11857457, 11857457, 11857477, 11857477, - + 11857481, 11857481, 11857493, 11857493, 11857499, 11857499, - + 11857519, 11857519, 11857523, 11857523, 11857529, 11857529 / - data (iparam(1,i),iparam(2,i),i= 630, 659) / - + 11857543, 11857543, 11857561, 11857561, 11857589, 11857589, - + 11857591, 11857591, 11857613, 11857613, 11857621, 11857621, - + 11857661, 11857661, 11857667, 11857667, 11857693, 11857693, - + 11857697, 11857697, 11857709, 11857709, 11857711, 11857711, - + 11857751, 11857751, 11857753, 11857753, 11857759, 11857759, - + 11857763, 11857763, 11857777, 11857777, 11857787, 11857787, - + 11857793, 11857793, 11857801, 11857801, 11857817, 11857817, - + 11857819, 11857819, 11857831, 11857831, 11857837, 11857837, - + 11857873, 11857873, 11857877, 11857877, 11857883, 11857883, - + 11857889, 11857889, 11857907, 11857907, 11857913, 11857913 / - data (iparam(1,i),iparam(2,i),i= 660, 689) / - + 11857931, 11857931, 11857969, 11857969, 11857991, 11857991, - + 11857999, 11857999, 11858009, 11858009, 11858017, 11858017, - + 11858023, 11858023, 11858029, 11858029, 11858039, 11858039, - + 11858051, 11858051, 11858057, 11858057, 11858059, 11858059, - + 11858101, 11858101, 11858111, 11858111, 11858131, 11858131, - + 11858149, 11858149, 11858159, 11858159, 11858177, 11858177, - + 11858191, 11858191, 11858201, 11858201, 11858227, 11858227, - + 11858243, 11858243, 11858267, 11858267, 11858269, 11858269, - + 11858279, 11858279, 11858281, 11858281, 11858291, 11858291, - + 11858311, 11858311, 11858323, 11858323, 11858359, 11858359 / - data (iparam(1,i),iparam(2,i),i= 690, 719) / - + 11858377, 11858377, 11858381, 11858381, 11858387, 11858387, - + 11858423, 11858423, 11858443, 11858443, 11858447, 11858447, - + 11858479, 11858479, 11858533, 11858533, 11858543, 11858543, - + 11858551, 11858551, 11858557, 11858557, 11858569, 11858569, - + 11858573, 11858573, 11858579, 11858579, 11858597, 11858597, - + 11858599, 11858599, 11858629, 11858629, 11858657, 11858657, - + 11858659, 11858659, 11858683, 11858683, 11858701, 11858701, - + 11858719, 11858719, 11858723, 11858723, 11858729, 11858729, - + 11858747, 11858747, 11858779, 11858779, 11858783, 11858783, - + 11858801, 11858801, 11858807, 11858807, 11858813, 11858813 / - data (iparam(1,i),iparam(2,i),i= 720, 749) / - + 11858839, 11858839, 11858851, 11858851, 11858893, 11858893, - + 11858897, 11858897, 11858921, 11858921, 11858947, 11858947, - + 11858953, 11858953, 11858969, 11858969, 11858971, 11858971, - + 11858989, 11858989, 11859017, 11859017, 11859031, 11859031, - + 11859049, 11859049, 11859061, 11859061, 11859073, 11859073, - + 11859077, 11859077, 11859079, 11859079, 11859083, 11859083, - + 11859101, 11859101, 11859109, 11859109, 11859137, 11859137, - + 11859139, 11859139, 11859151, 11859151, 11859157, 11859157, - + 11859163, 11859163, 11859167, 11859167, 11859179, 11859179, - + 11859187, 11859187, 11859229, 11859229, 11859233, 11859233 / - data (iparam(1,i),iparam(2,i),i= 750, 779) / - + 11859241, 11859241, 11859247, 11859247, 11859269, 11859269, - + 11859293, 11859293, 11859307, 11859307, 11859311, 11859311, - + 11859349, 11859349, 11859359, 11859359, 11859371, 11859371, - + 11859377, 11859377, 11859383, 11859383, 11859427, 11859427, - + 11859433, 11859433, 11859451, 11859451, 11859457, 11859457, - + 11859461, 11859461, 11859473, 11859473, 11859481, 11859481, - + 11859487, 11859487, 11859493, 11859493, 11859503, 11859503, - + 11859509, 11859509, 11859539, 11859539, 11859541, 11859541, - + 11859563, 11859563, 11859569, 11859569, 11859571, 11859571, - + 11859583, 11859583, 11859599, 11859599, 11859611, 11859611 / - data (iparam(1,i),iparam(2,i),i= 780, 809) / - + 11859643, 11859643, 11859707, 11859707, 11859713, 11859713, - + 11859719, 11859719, 11859739, 11859739, 11859751, 11859751, - + 11859791, 11859791, 11859817, 11859817, 11859821, 11859821, - + 11859833, 11859833, 11859847, 11859847, 11859853, 11859853, - + 11859877, 11859877, 11859889, 11859889, 11859893, 11859893, - + 11859901, 11859901, 11859907, 11859907, 11859917, 11859917, - + 11859923, 11859923, 11859929, 11859929, 11859961, 11859961, - + 11859979, 11859979, 11859989, 11859989, 11859997, 11859997, - + 11860021, 11860021, 11860031, 11860031, 11860039, 11860039, - + 11860049, 11860049, 11860081, 11860081, 11860087, 11860087 / - data (iparam(1,i),iparam(2,i),i= 810, 839) / - + 11860097, 11860097, 11860103, 11860103, 11860109, 11860109, - + 11860117, 11860117, 11860133, 11860133, 11860151, 11860151, - + 11860171, 11860171, 11860207, 11860207, 11860223, 11860223, - + 11860231, 11860231, 11860243, 11860243, 11860267, 11860267, - + 11860301, 11860301, 11860307, 11860307, 11860327, 11860327, - + 11860379, 11860379, 11860397, 11860397, 11860411, 11860411, - + 11860469, 11860469, 11860477, 11860477, 11860483, 11860483, - + 11860487, 11860487, 11860489, 11860489, 11860493, 11860493, - + 11860517, 11860517, 11860547, 11860547, 11860567, 11860567, - + 11860573, 11860573, 11860613, 11860613, 11860619, 11860619 / - data (iparam(1,i),iparam(2,i),i= 840, 869) / - + 11860627, 11860627, 11860637, 11860637, 11860643, 11860643, - + 11860649, 11860649, 11860661, 11860661, 11860669, 11860669, - + 11860687, 11860687, 11860691, 11860691, 11860697, 11860697, - + 11860699, 11860699, 11860703, 11860703, 11860727, 11860727, - + 11860741, 11860741, 11860753, 11860753, 11860777, 11860777, - + 11860787, 11860787, 11860789, 11860789, 11860811, 11860811, - + 11860837, 11860837, 11860859, 11860859, 11860867, 11860867, - + 11860889, 11860889, 11860897, 11860897, 11860963, 11860963, - + 11860969, 11860969, 11860973, 11860973, 11860993, 11860993, - + 11861011, 11861011, 11861033, 11861033, 11861071, 11861071 / - data (iparam(1,i),iparam(2,i),i= 870, 899) / - + 11861081, 11861081, 11861089, 11861089, 11861093, 11861093, - + 11861099, 11861099, 11861107, 11861107, 11861131, 11861131, - + 11861141, 11861141, 11861159, 11861159, 11861167, 11861167, - + 11861191, 11861191, 11861197, 11861197, 11861207, 11861207, - + 11861219, 11861219, 11861221, 11861221, 11861231, 11861231, - + 11861237, 11861237, 11861273, 11861273, 11861293, 11861293, - + 11861299, 11861299, 11861303, 11861303, 11861327, 11861327, - + 11861351, 11861351, 11861357, 11861357, 11861363, 11861363, - + 11861371, 11861371, 11861401, 11861401, 11861407, 11861407, - + 11861411, 11861411, 11861413, 11861413, 11861429, 11861429 / - data (iparam(1,i),iparam(2,i),i= 900, 929) / - + 11861441, 11861441, 11861467, 11861467, 11861527, 11861527, - + 11861539, 11861539, 11861543, 11861543, 11861557, 11861557, - + 11861569, 11861569, 11861573, 11861573, 11861579, 11861579, - + 11861581, 11861581, 11861599, 11861599, 11861611, 11861611, - + 11861617, 11861617, 11861627, 11861627, 11861639, 11861639, - + 11861651, 11861651, 11861659, 11861659, 11861671, 11861671, - + 11861683, 11861683, 11861687, 11861687, 11861693, 11861693, - + 11861701, 11861701, 11861711, 11861711, 11861713, 11861713, - + 11861749, 11861749, 11861791, 11861791, 11861803, 11861803, - + 11861819, 11861819, 11861827, 11861827, 11861849, 11861849 / - data (iparam(1,i),iparam(2,i),i= 930, 959) / - + 11861873, 11861873, 11861879, 11861879, 11861887, 11861887, - + 11861911, 11861911, 11861917, 11861917, 11861921, 11861921, - + 11861923, 11861923, 11861953, 11861953, 11861959, 11861959, - + 11861987, 11861987, 11862007, 11862007, 11862013, 11862013, - + 11862029, 11862029, 11862031, 11862031, 11862049, 11862049, - + 11862077, 11862077, 11862083, 11862083, 11862157, 11862157, - + 11862167, 11862167, 11862199, 11862199, 11862203, 11862203, - + 11862217, 11862217, 11862223, 11862223, 11862229, 11862229, - + 11862233, 11862233, 11862239, 11862239, 11862241, 11862241, - + 11862259, 11862259, 11862269, 11862269, 11862271, 11862271 / - data (iparam(1,i),iparam(2,i),i= 960, 989) / - + 11862293, 11862293, 11862307, 11862307, 11862313, 11862313, - + 11862317, 11862317, 11862343, 11862343, 11862353, 11862353, - + 11862373, 11862373, 11862391, 11862391, 11862439, 11862439, - + 11862469, 11862469, 11862493, 11862493, 11862527, 11862527, - + 11862547, 11862547, 11862563, 11862563, 11862569, 11862569, - + 11862577, 11862577, 11862581, 11862581, 11862611, 11862611, - + 11862623, 11862623, 11862661, 11862661, 11862673, 11862673, - + 11862679, 11862679, 11862701, 11862701, 11862703, 11862703, - + 11862713, 11862713, 11862761, 11862761, 11862791, 11862791, - + 11862803, 11862803, 11862839, 11862839, 11862841, 11862841 / - data (iparam(1,i),iparam(2,i),i= 990,1019) / - + 11862857, 11862857, 11862869, 11862869, 11862881, 11862881, - + 11862911, 11862911, 11862919, 11862919, 11862959, 11862959, - + 11862979, 11862979, 11862989, 11862989, 11862997, 11862997, - + 11863021, 11863021, 11863031, 11863031, 11863037, 11863037, - + 11863039, 11863039, 11863057, 11863057, 11863067, 11863067, - + 11863073, 11863073, 11863099, 11863099, 11863109, 11863109, - + 11863121, 11863121, 11863123, 11863123, 11863133, 11863133, - + 11863151, 11863151, 11863153, 11863153, 11863171, 11863171, - + 11863183, 11863183, 11863207, 11863207, 11863213, 11863213, - + 11863237, 11863237, 11863249, 11863249, 11863253, 11863253 / - data (iparam(1,i),iparam(2,i),i=1020,1021) / - + 11863259, 11863259, 11863279, 11863279 / - end diff --git a/source/unres/src_MD_DFA/prng_32.F b/source/unres/src_MD_DFA/prng_32.F deleted file mode 100644 index 9448f31..0000000 --- a/source/unres/src_MD_DFA/prng_32.F +++ /dev/null @@ -1,1077 +0,0 @@ -#if defined(AIX) || defined(AMD64) - real*8 function prng_next(mel) - implicit none - integer me,mel -c -c Calling sequence: -c = prng_next ( ) -c = vprng ( , , ) -c -c This code is based on a sequential algorithm provided by Mal Kalos. -c This version uses a single 64-bit word to store the initial seeds -c and additive constants. -c A 64-bit floating point number is returned. -c -c The array "iparam" is full-word aligned, being padded by zeros to -c let each generator be on a subpage boundary. -c That is, rows 1 and 2 in a given column of the array are for real, -c rows 3-16 are bogus. -c -c July 12, 1993: double the number of sequences. We should have been -c using two packets per seed, rather than four -c October 31, 1993: merge the two arrays of seeds and constants, -c and switch to 64-bit arithmetic. -c June 1994: port to RS6K. Internal state is kept as 2 64-bit integers -c The ishft function is defined only on 32-bit integers, so we will -c shift numbers by dividing by 2**11 and then adding on 2**53-1. -c -c November 1994: ishift now works on 64-bit numbers (though it gives a -c warning). Thus we go back to using it. John Zollweg also added the -c vprng() routine to return vectors of real*8 random numbers. -c - real*8 recip53 - parameter ( recip53 = 2.0D0**(-53) ) - integer*8 two - parameter ( two = 2**11) - integer*8 m,ishift -c parameter ( m = 34522712143931 ) ! 11**13 -c parameter ( ishift = 9007199254740991 ) ! 2**53-1 - - integer nmax - integer*8 iparam - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - integer*8 next - -crc g77 doesn't support integer*8 constants - m = dint(34522712143931.0d0) - ishift = dint(9007199254740991.0d0) - if(mel.gt.nmax) then - me=mod(mel,nmax) - else - me=mel - endif -c RS6K porting note: ishift now takes 64-bit integers , with a warning - if ( 0.le.me .and. me.le.nmax ) then - next = iparam(1,me)*m + iparam(2,me) - iparam(1,me) = next - prng_next = recip53 * ishft( next, -11 ) - else - prng_next=-1.0D0 - endif - - end -c -c vprng(me, rn, num) Get a vector of random numbers -c - subroutine vprng(me,rn,num) - real*8 recip53, rn(1) - parameter ( recip53 = 2.0D0**(-53) ) - integer*8 m,iparam -c parameter ( m = 34522712143931 ) ! 11**13 - integer nmax, num, me - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - integer*8 next - -crc g77 doesn't support integer*8 constants - m = dint(34522712143931.0d0) - - if ( 0.le.me .and. me.le.nmax ) then - do 1 i=1,num - next = iparam(1,me)*m + iparam(2,me) - iparam(1,me) = next - rn(i) = recip53 * ishft( next, -11 ) - 1 continue - else - rn(1)=-1.0D0 - endif - return - end - -c -c prng_chkpnt Get the current state of a generator -c -c Calling sequence: -c logical prng_chkpnt, status -c status = prng_chkpnt (me, iseed) where -c -c me is the particular generator whose state is being gotten -c seed is an 4-element integer array where the "l"-values will be saved -c - logical function prng_chkpnt (me, iseed) - implicit none - integer me - integer*8 iseed - - integer nmax - integer*8 iparam - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - if (me .lt. 0 .or. me .gt. nmax) then - prng_chkpnt=.false. - else - prng_chkpnt=.true. - iseed=iparam(1,me) - endif - end -c -c prng_restart Restart generator from a saved state -c -c Calling sequence: -c logical prng_restart, status -c status = prng_restart (me, iseed) where -c -c me is the particular generator being restarted -c iseed is a 8-byte integer containing the "l"-values -c - logical function prng_restart (mel, iseed) - implicit none - integer me,mel - integer*8 iseed - - integer nmax - integer*8 iparam - parameter(nmax=1021) - common/ksrprng/iparam(2,0:nmax) - - if(mel.gt.nmax) then - me=mod(mel,nmax) - else - me=mel - endif - if (me .lt. 0 .or. me .gt. nmax) then - prng_restart=.false. - return - else - prng_restart=.true. - iparam(1,me)=iseed - endif - end - - block data prngblk - parameter(nmax=1021) - integer*8 iparam - common/ksrprng/iparam(2,0:nmax) - data (iparam(1,i),iparam(2,i),i= 0, 29) / - + 11848219, 11848219, 11848237, 11848237, 11848241, 11848241, - + 11848247, 11848247, 11848253, 11848253, 11848271, 11848271, - + 11848297, 11848297, 11848313, 11848313, 11848339, 11848339, - + 11848351, 11848351, 11848357, 11848357, 11848363, 11848363, - + 11848367, 11848367, 11848373, 11848373, 11848379, 11848379, - + 11848393, 11848393, 11848433, 11848433, 11848451, 11848451, - + 11848469, 11848469, 11848477, 11848477, 11848489, 11848489, - + 11848493, 11848493, 11848513, 11848513, 11848523, 11848523, - + 11848531, 11848531, 11848537, 11848537, 11848553, 11848553, - + 11848589, 11848589, 11848591, 11848591, 11848601, 11848601 / - data (iparam(1,i),iparam(2,i),i= 30, 59) / - + 11848619, 11848619, 11848637, 11848637, 11848663, 11848663, - + 11848673, 11848673, 11848679, 11848679, 11848691, 11848691, - + 11848699, 11848699, 11848709, 11848709, 11848717, 11848717, - + 11848721, 11848721, 11848729, 11848729, 11848741, 11848741, - + 11848751, 11848751, 11848757, 11848757, 11848787, 11848787, - + 11848801, 11848801, 11848829, 11848829, 11848853, 11848853, - + 11848861, 11848861, 11848867, 11848867, 11848873, 11848873, - + 11848891, 11848891, 11848909, 11848909, 11848919, 11848919, - + 11848931, 11848931, 11848937, 11848937, 11848961, 11848961, - + 11848981, 11848981, 11849021, 11849021, 11849039, 11849039 / - data (iparam(1,i),iparam(2,i),i= 60, 89) / - + 11849053, 11849053, 11849059, 11849059, 11849069, 11849069, - + 11849077, 11849077, 11849087, 11849087, 11849093, 11849093, - + 11849107, 11849107, 11849111, 11849111, 11849129, 11849129, - + 11849137, 11849137, 11849177, 11849177, 11849183, 11849183, - + 11849203, 11849203, 11849231, 11849231, 11849237, 11849237, - + 11849239, 11849239, 11849249, 11849249, 11849251, 11849251, - + 11849269, 11849269, 11849273, 11849273, 11849291, 11849291, - + 11849297, 11849297, 11849309, 11849309, 11849339, 11849339, - + 11849359, 11849359, 11849363, 11849363, 11849399, 11849399, - + 11849401, 11849401, 11849413, 11849413, 11849417, 11849417 / - data (iparam(1,i),iparam(2,i),i= 90, 119) / - + 11849437, 11849437, 11849443, 11849443, 11849473, 11849473, - + 11849491, 11849491, 11849503, 11849503, 11849507, 11849507, - + 11849557, 11849557, 11849567, 11849567, 11849569, 11849569, - + 11849573, 11849573, 11849587, 11849587, 11849599, 11849599, - + 11849633, 11849633, 11849641, 11849641, 11849653, 11849653, - + 11849659, 11849659, 11849671, 11849671, 11849683, 11849683, - + 11849689, 11849689, 11849693, 11849693, 11849699, 11849699, - + 11849701, 11849701, 11849707, 11849707, 11849713, 11849713, - + 11849723, 11849723, 11849741, 11849741, 11849743, 11849743, - + 11849759, 11849759, 11849767, 11849767, 11849771, 11849771 / - data (iparam(1,i),iparam(2,i),i= 120, 149) / - + 11849791, 11849791, 11849801, 11849801, 11849809, 11849809, - + 11849813, 11849813, 11849869, 11849869, 11849881, 11849881, - + 11849891, 11849891, 11849909, 11849909, 11849923, 11849923, - + 11849933, 11849933, 11849947, 11849947, 11849987, 11849987, - + 11850001, 11850001, 11850011, 11850011, 11850019, 11850019, - + 11850023, 11850023, 11850031, 11850031, 11850049, 11850049, - + 11850061, 11850061, 11850073, 11850073, 11850077, 11850077, - + 11850103, 11850103, 11850109, 11850109, 11850121, 11850121, - + 11850127, 11850127, 11850133, 11850133, 11850149, 11850149, - + 11850161, 11850161, 11850169, 11850169, 11850191, 11850191 / - data (iparam(1,i),iparam(2,i),i= 150, 179) / - + 11850233, 11850233, 11850247, 11850247, 11850259, 11850259, - + 11850269, 11850269, 11850283, 11850283, 11850301, 11850301, - + 11850341, 11850341, 11850347, 11850347, 11850367, 11850367, - + 11850373, 11850373, 11850379, 11850379, 11850389, 11850389, - + 11850407, 11850407, 11850427, 11850427, 11850437, 11850437, - + 11850469, 11850469, 11850481, 11850481, 11850511, 11850511, - + 11850529, 11850529, 11850541, 11850541, 11850557, 11850557, - + 11850607, 11850607, 11850611, 11850611, 11850667, 11850667, - + 11850677, 11850677, 11850679, 11850679, 11850701, 11850701, - + 11850731, 11850731, 11850739, 11850739, 11850749, 11850749 / - data (iparam(1,i),iparam(2,i),i= 180, 209) / - + 11850791, 11850791, 11850803, 11850803, 11850829, 11850829, - + 11850833, 11850833, 11850859, 11850859, 11850877, 11850877, - + 11850899, 11850899, 11850907, 11850907, 11850913, 11850913, - + 11850919, 11850919, 11850931, 11850931, 11850941, 11850941, - + 11850947, 11850947, 11850953, 11850953, 11850961, 11850961, - + 11850983, 11850983, 11850991, 11850991, 11850997, 11850997, - + 11851031, 11851031, 11851033, 11851033, 11851051, 11851051, - + 11851061, 11851061, 11851067, 11851067, 11851093, 11851093, - + 11851109, 11851109, 11851123, 11851123, 11851127, 11851127, - + 11851139, 11851139, 11851157, 11851157, 11851163, 11851163 / - data (iparam(1,i),iparam(2,i),i= 210, 239) / - + 11851181, 11851181, 11851201, 11851201, 11851219, 11851219, - + 11851291, 11851291, 11851303, 11851303, 11851309, 11851309, - + 11851313, 11851313, 11851319, 11851319, 11851349, 11851349, - + 11851351, 11851351, 11851361, 11851361, 11851373, 11851373, - + 11851403, 11851403, 11851409, 11851409, 11851423, 11851423, - + 11851447, 11851447, 11851451, 11851451, 11851481, 11851481, - + 11851493, 11851493, 11851519, 11851519, 11851523, 11851523, - + 11851529, 11851529, 11851547, 11851547, 11851549, 11851549, - + 11851559, 11851559, 11851577, 11851577, 11851589, 11851589, - + 11851591, 11851591, 11851597, 11851597, 11851603, 11851603 / - data (iparam(1,i),iparam(2,i),i= 240, 269) / - + 11851607, 11851607, 11851613, 11851613, 11851621, 11851621, - + 11851627, 11851627, 11851639, 11851639, 11851673, 11851673, - + 11851681, 11851681, 11851727, 11851727, 11851753, 11851753, - + 11851759, 11851759, 11851787, 11851787, 11851793, 11851793, - + 11851799, 11851799, 11851813, 11851813, 11851841, 11851841, - + 11851859, 11851859, 11851867, 11851867, 11851891, 11851891, - + 11851909, 11851909, 11851919, 11851919, 11851927, 11851927, - + 11851933, 11851933, 11851949, 11851949, 11851967, 11851967, - + 11851997, 11851997, 11852017, 11852017, 11852051, 11852051, - + 11852053, 11852053, 11852059, 11852059, 11852083, 11852083 / - data (iparam(1,i),iparam(2,i),i= 270, 299) / - + 11852089, 11852089, 11852129, 11852129, 11852147, 11852147, - + 11852149, 11852149, 11852161, 11852161, 11852171, 11852171, - + 11852177, 11852177, 11852209, 11852209, 11852221, 11852221, - + 11852237, 11852237, 11852251, 11852251, 11852263, 11852263, - + 11852273, 11852273, 11852279, 11852279, 11852287, 11852287, - + 11852293, 11852293, 11852297, 11852297, 11852303, 11852303, - + 11852311, 11852311, 11852327, 11852327, 11852339, 11852339, - + 11852341, 11852341, 11852359, 11852359, 11852369, 11852369, - + 11852437, 11852437, 11852453, 11852453, 11852459, 11852459, - + 11852473, 11852473, 11852513, 11852513, 11852531, 11852531 / - data (iparam(1,i),iparam(2,i),i= 300, 329) / - + 11852537, 11852537, 11852539, 11852539, 11852557, 11852557, - + 11852573, 11852573, 11852579, 11852579, 11852591, 11852591, - + 11852609, 11852609, 11852611, 11852611, 11852623, 11852623, - + 11852641, 11852641, 11852647, 11852647, 11852657, 11852657, - + 11852663, 11852663, 11852717, 11852717, 11852719, 11852719, - + 11852741, 11852741, 11852759, 11852759, 11852767, 11852767, - + 11852773, 11852773, 11852803, 11852803, 11852807, 11852807, - + 11852809, 11852809, 11852831, 11852831, 11852833, 11852833, - + 11852837, 11852837, 11852857, 11852857, 11852873, 11852873, - + 11852879, 11852879, 11852891, 11852891, 11852917, 11852917 / - data (iparam(1,i),iparam(2,i),i= 330, 359) / - + 11852921, 11852921, 11852957, 11852957, 11852959, 11852959, - + 11852969, 11852969, 11852983, 11852983, 11852989, 11852989, - + 11853001, 11853001, 11853013, 11853013, 11853019, 11853019, - + 11853031, 11853031, 11853089, 11853089, 11853133, 11853133, - + 11853157, 11853157, 11853161, 11853161, 11853181, 11853181, - + 11853203, 11853203, 11853217, 11853217, 11853221, 11853221, - + 11853227, 11853227, 11853241, 11853241, 11853307, 11853307, - + 11853319, 11853319, 11853323, 11853323, 11853329, 11853329, - + 11853367, 11853367, 11853383, 11853383, 11853419, 11853419, - + 11853421, 11853421, 11853427, 11853427, 11853449, 11853449 / - data (iparam(1,i),iparam(2,i),i= 360, 389) / - + 11853451, 11853451, 11853463, 11853463, 11853529, 11853529, - + 11853557, 11853557, 11853571, 11853571, 11853601, 11853601, - + 11853613, 11853613, 11853617, 11853617, 11853629, 11853629, - + 11853649, 11853649, 11853659, 11853659, 11853679, 11853679, - + 11853689, 11853689, 11853719, 11853719, 11853731, 11853731, - + 11853757, 11853757, 11853761, 11853761, 11853773, 11853773, - + 11853791, 11853791, 11853817, 11853817, 11853839, 11853839, - + 11853847, 11853847, 11853857, 11853857, 11853869, 11853869, - + 11853883, 11853883, 11853887, 11853887, 11853889, 11853889, - + 11853893, 11853893, 11853899, 11853899, 11853911, 11853911 / - data (iparam(1,i),iparam(2,i),i= 390, 419) / - + 11853931, 11853931, 11853943, 11853943, 11853979, 11853979, - + 11853991, 11853991, 11854001, 11854001, 11854009, 11854009, - + 11854019, 11854019, 11854057, 11854057, 11854061, 11854061, - + 11854147, 11854147, 11854159, 11854159, 11854163, 11854163, - + 11854169, 11854169, 11854211, 11854211, 11854247, 11854247, - + 11854261, 11854261, 11854267, 11854267, 11854279, 11854279, - + 11854303, 11854303, 11854327, 11854327, 11854331, 11854331, - + 11854333, 11854333, 11854363, 11854363, 11854379, 11854379, - + 11854399, 11854399, 11854411, 11854411, 11854429, 11854429, - + 11854433, 11854433, 11854439, 11854439, 11854441, 11854441 / - data (iparam(1,i),iparam(2,i),i= 420, 449) / - + 11854463, 11854463, 11854477, 11854477, 11854489, 11854489, - + 11854517, 11854517, 11854519, 11854519, 11854523, 11854523, - + 11854529, 11854529, 11854567, 11854567, 11854571, 11854571, - + 11854573, 11854573, 11854603, 11854603, 11854607, 11854607, - + 11854681, 11854681, 11854691, 11854691, 11854709, 11854709, - + 11854723, 11854723, 11854757, 11854757, 11854783, 11854783, - + 11854793, 11854793, 11854813, 11854813, 11854847, 11854847, - + 11854853, 11854853, 11854873, 11854873, 11854877, 11854877, - + 11854883, 11854883, 11854891, 11854891, 11854897, 11854897, - + 11854901, 11854901, 11854919, 11854919, 11854937, 11854937 / - data (iparam(1,i),iparam(2,i),i= 450, 479) / - + 11854961, 11854961, 11854963, 11854963, 11854979, 11854979, - + 11855003, 11855003, 11855017, 11855017, 11855023, 11855023, - + 11855029, 11855029, 11855033, 11855033, 11855111, 11855111, - + 11855141, 11855141, 11855147, 11855147, 11855149, 11855149, - + 11855159, 11855159, 11855177, 11855177, 11855203, 11855203, - + 11855213, 11855213, 11855219, 11855219, 11855231, 11855231, - + 11855267, 11855267, 11855269, 11855269, 11855303, 11855303, - + 11855309, 11855309, 11855321, 11855321, 11855329, 11855329, - + 11855339, 11855339, 11855351, 11855351, 11855353, 11855353, - + 11855357, 11855357, 11855359, 11855359, 11855381, 11855381 / - data (iparam(1,i),iparam(2,i),i= 480, 509) / - + 11855383, 11855383, 11855387, 11855387, 11855399, 11855399, - + 11855407, 11855407, 11855413, 11855413, 11855489, 11855489, - + 11855491, 11855491, 11855507, 11855507, 11855521, 11855521, - + 11855531, 11855531, 11855549, 11855549, 11855551, 11855551, - + 11855567, 11855567, 11855581, 11855581, 11855587, 11855587, - + 11855593, 11855593, 11855633, 11855633, 11855653, 11855653, - + 11855663, 11855663, 11855687, 11855687, 11855689, 11855689, - + 11855699, 11855699, 11855713, 11855713, 11855731, 11855731, - + 11855737, 11855737, 11855743, 11855743, 11855747, 11855747, - + 11855759, 11855759, 11855773, 11855773, 11855801, 11855801 / - data (iparam(1,i),iparam(2,i),i= 510, 539) / - + 11855807, 11855807, 11855813, 11855813, 11855827, 11855827, - + 11855839, 11855839, 11855869, 11855869, 11855881, 11855881, - + 11855903, 11855903, 11855911, 11855911, 11855933, 11855933, - + 11855959, 11855959, 11855989, 11855989, 11855993, 11855993, - + 11855999, 11855999, 11856001, 11856001, 11856023, 11856023, - + 11856049, 11856049, 11856071, 11856071, 11856101, 11856101, - + 11856107, 11856107, 11856113, 11856113, 11856139, 11856139, - + 11856151, 11856151, 11856161, 11856161, 11856179, 11856179, - + 11856193, 11856193, 11856199, 11856199, 11856223, 11856223, - + 11856239, 11856239, 11856263, 11856263, 11856269, 11856269 / - data (iparam(1,i),iparam(2,i),i= 540, 569) / - + 11856281, 11856281, 11856287, 11856287, 11856307, 11856307, - + 11856311, 11856311, 11856329, 11856329, 11856343, 11856343, - + 11856359, 11856359, 11856371, 11856371, 11856373, 11856373, - + 11856409, 11856409, 11856419, 11856419, 11856461, 11856461, - + 11856469, 11856469, 11856473, 11856473, 11856479, 11856479, - + 11856511, 11856511, 11856517, 11856517, 11856541, 11856541, - + 11856547, 11856547, 11856553, 11856553, 11856583, 11856583, - + 11856629, 11856629, 11856641, 11856641, 11856653, 11856653, - + 11856659, 11856659, 11856673, 11856673, 11856697, 11856697, - + 11856709, 11856709, 11856727, 11856727, 11856731, 11856731 / - data (iparam(1,i),iparam(2,i),i= 570, 599) / - + 11856763, 11856763, 11856809, 11856809, 11856811, 11856811, - + 11856821, 11856821, 11856841, 11856841, 11856857, 11856857, - + 11856877, 11856877, 11856883, 11856883, 11856899, 11856899, - + 11856919, 11856919, 11856947, 11856947, 11856953, 11856953, - + 11856979, 11856979, 11857003, 11857003, 11857033, 11857033, - + 11857037, 11857037, 11857039, 11857039, 11857049, 11857049, - + 11857061, 11857061, 11857067, 11857067, 11857073, 11857073, - + 11857081, 11857081, 11857091, 11857091, 11857093, 11857093, - + 11857099, 11857099, 11857123, 11857123, 11857127, 11857127, - + 11857147, 11857147, 11857151, 11857151, 11857193, 11857193 / - data (iparam(1,i),iparam(2,i),i= 600, 629) / - + 11857217, 11857217, 11857229, 11857229, 11857243, 11857243, - + 11857249, 11857249, 11857267, 11857267, 11857277, 11857277, - + 11857291, 11857291, 11857303, 11857303, 11857309, 11857309, - + 11857327, 11857327, 11857331, 11857331, 11857333, 11857333, - + 11857361, 11857361, 11857367, 11857367, 11857369, 11857369, - + 11857393, 11857393, 11857399, 11857399, 11857409, 11857409, - + 11857421, 11857421, 11857423, 11857423, 11857451, 11857451, - + 11857453, 11857453, 11857457, 11857457, 11857477, 11857477, - + 11857481, 11857481, 11857493, 11857493, 11857499, 11857499, - + 11857519, 11857519, 11857523, 11857523, 11857529, 11857529 / - data (iparam(1,i),iparam(2,i),i= 630, 659) / - + 11857543, 11857543, 11857561, 11857561, 11857589, 11857589, - + 11857591, 11857591, 11857613, 11857613, 11857621, 11857621, - + 11857661, 11857661, 11857667, 11857667, 11857693, 11857693, - + 11857697, 11857697, 11857709, 11857709, 11857711, 11857711, - + 11857751, 11857751, 11857753, 11857753, 11857759, 11857759, - + 11857763, 11857763, 11857777, 11857777, 11857787, 11857787, - + 11857793, 11857793, 11857801, 11857801, 11857817, 11857817, - + 11857819, 11857819, 11857831, 11857831, 11857837, 11857837, - + 11857873, 11857873, 11857877, 11857877, 11857883, 11857883, - + 11857889, 11857889, 11857907, 11857907, 11857913, 11857913 / - data (iparam(1,i),iparam(2,i),i= 660, 689) / - + 11857931, 11857931, 11857969, 11857969, 11857991, 11857991, - + 11857999, 11857999, 11858009, 11858009, 11858017, 11858017, - + 11858023, 11858023, 11858029, 11858029, 11858039, 11858039, - + 11858051, 11858051, 11858057, 11858057, 11858059, 11858059, - + 11858101, 11858101, 11858111, 11858111, 11858131, 11858131, - + 11858149, 11858149, 11858159, 11858159, 11858177, 11858177, - + 11858191, 11858191, 11858201, 11858201, 11858227, 11858227, - + 11858243, 11858243, 11858267, 11858267, 11858269, 11858269, - + 11858279, 11858279, 11858281, 11858281, 11858291, 11858291, - + 11858311, 11858311, 11858323, 11858323, 11858359, 11858359 / - data (iparam(1,i),iparam(2,i),i= 690, 719) / - + 11858377, 11858377, 11858381, 11858381, 11858387, 11858387, - + 11858423, 11858423, 11858443, 11858443, 11858447, 11858447, - + 11858479, 11858479, 11858533, 11858533, 11858543, 11858543, - + 11858551, 11858551, 11858557, 11858557, 11858569, 11858569, - + 11858573, 11858573, 11858579, 11858579, 11858597, 11858597, - + 11858599, 11858599, 11858629, 11858629, 11858657, 11858657, - + 11858659, 11858659, 11858683, 11858683, 11858701, 11858701, - + 11858719, 11858719, 11858723, 11858723, 11858729, 11858729, - + 11858747, 11858747, 11858779, 11858779, 11858783, 11858783, - + 11858801, 11858801, 11858807, 11858807, 11858813, 11858813 / - data (iparam(1,i),iparam(2,i),i= 720, 749) / - + 11858839, 11858839, 11858851, 11858851, 11858893, 11858893, - + 11858897, 11858897, 11858921, 11858921, 11858947, 11858947, - + 11858953, 11858953, 11858969, 11858969, 11858971, 11858971, - + 11858989, 11858989, 11859017, 11859017, 11859031, 11859031, - + 11859049, 11859049, 11859061, 11859061, 11859073, 11859073, - + 11859077, 11859077, 11859079, 11859079, 11859083, 11859083, - + 11859101, 11859101, 11859109, 11859109, 11859137, 11859137, - + 11859139, 11859139, 11859151, 11859151, 11859157, 11859157, - + 11859163, 11859163, 11859167, 11859167, 11859179, 11859179, - + 11859187, 11859187, 11859229, 11859229, 11859233, 11859233 / - data (iparam(1,i),iparam(2,i),i= 750, 779) / - + 11859241, 11859241, 11859247, 11859247, 11859269, 11859269, - + 11859293, 11859293, 11859307, 11859307, 11859311, 11859311, - + 11859349, 11859349, 11859359, 11859359, 11859371, 11859371, - + 11859377, 11859377, 11859383, 11859383, 11859427, 11859427, - + 11859433, 11859433, 11859451, 11859451, 11859457, 11859457, - + 11859461, 11859461, 11859473, 11859473, 11859481, 11859481, - + 11859487, 11859487, 11859493, 11859493, 11859503, 11859503, - + 11859509, 11859509, 11859539, 11859539, 11859541, 11859541, - + 11859563, 11859563, 11859569, 11859569, 11859571, 11859571, - + 11859583, 11859583, 11859599, 11859599, 11859611, 11859611 / - data (iparam(1,i),iparam(2,i),i= 780, 809) / - + 11859643, 11859643, 11859707, 11859707, 11859713, 11859713, - + 11859719, 11859719, 11859739, 11859739, 11859751, 11859751, - + 11859791, 11859791, 11859817, 11859817, 11859821, 11859821, - + 11859833, 11859833, 11859847, 11859847, 11859853, 11859853, - + 11859877, 11859877, 11859889, 11859889, 11859893, 11859893, - + 11859901, 11859901, 11859907, 11859907, 11859917, 11859917, - + 11859923, 11859923, 11859929, 11859929, 11859961, 11859961, - + 11859979, 11859979, 11859989, 11859989, 11859997, 11859997, - + 11860021, 11860021, 11860031, 11860031, 11860039, 11860039, - + 11860049, 11860049, 11860081, 11860081, 11860087, 11860087 / - data (iparam(1,i),iparam(2,i),i= 810, 839) / - + 11860097, 11860097, 11860103, 11860103, 11860109, 11860109, - + 11860117, 11860117, 11860133, 11860133, 11860151, 11860151, - + 11860171, 11860171, 11860207, 11860207, 11860223, 11860223, - + 11860231, 11860231, 11860243, 11860243, 11860267, 11860267, - + 11860301, 11860301, 11860307, 11860307, 11860327, 11860327, - + 11860379, 11860379, 11860397, 11860397, 11860411, 11860411, - + 11860469, 11860469, 11860477, 11860477, 11860483, 11860483, - + 11860487, 11860487, 11860489, 11860489, 11860493, 11860493, - + 11860517, 11860517, 11860547, 11860547, 11860567, 11860567, - + 11860573, 11860573, 11860613, 11860613, 11860619, 11860619 / - data (iparam(1,i),iparam(2,i),i= 840, 869) / - + 11860627, 11860627, 11860637, 11860637, 11860643, 11860643, - + 11860649, 11860649, 11860661, 11860661, 11860669, 11860669, - + 11860687, 11860687, 11860691, 11860691, 11860697, 11860697, - + 11860699, 11860699, 11860703, 11860703, 11860727, 11860727, - + 11860741, 11860741, 11860753, 11860753, 11860777, 11860777, - + 11860787, 11860787, 11860789, 11860789, 11860811, 11860811, - + 11860837, 11860837, 11860859, 11860859, 11860867, 11860867, - + 11860889, 11860889, 11860897, 11860897, 11860963, 11860963, - + 11860969, 11860969, 11860973, 11860973, 11860993, 11860993, - + 11861011, 11861011, 11861033, 11861033, 11861071, 11861071 / - data (iparam(1,i),iparam(2,i),i= 870, 899) / - + 11861081, 11861081, 11861089, 11861089, 11861093, 11861093, - + 11861099, 11861099, 11861107, 11861107, 11861131, 11861131, - + 11861141, 11861141, 11861159, 11861159, 11861167, 11861167, - + 11861191, 11861191, 11861197, 11861197, 11861207, 11861207, - + 11861219, 11861219, 11861221, 11861221, 11861231, 11861231, - + 11861237, 11861237, 11861273, 11861273, 11861293, 11861293, - + 11861299, 11861299, 11861303, 11861303, 11861327, 11861327, - + 11861351, 11861351, 11861357, 11861357, 11861363, 11861363, - + 11861371, 11861371, 11861401, 11861401, 11861407, 11861407, - + 11861411, 11861411, 11861413, 11861413, 11861429, 11861429 / - data (iparam(1,i),iparam(2,i),i= 900, 929) / - + 11861441, 11861441, 11861467, 11861467, 11861527, 11861527, - + 11861539, 11861539, 11861543, 11861543, 11861557, 11861557, - + 11861569, 11861569, 11861573, 11861573, 11861579, 11861579, - + 11861581, 11861581, 11861599, 11861599, 11861611, 11861611, - + 11861617, 11861617, 11861627, 11861627, 11861639, 11861639, - + 11861651, 11861651, 11861659, 11861659, 11861671, 11861671, - + 11861683, 11861683, 11861687, 11861687, 11861693, 11861693, - + 11861701, 11861701, 11861711, 11861711, 11861713, 11861713, - + 11861749, 11861749, 11861791, 11861791, 11861803, 11861803, - + 11861819, 11861819, 11861827, 11861827, 11861849, 11861849 / - data (iparam(1,i),iparam(2,i),i= 930, 959) / - + 11861873, 11861873, 11861879, 11861879, 11861887, 11861887, - + 11861911, 11861911, 11861917, 11861917, 11861921, 11861921, - + 11861923, 11861923, 11861953, 11861953, 11861959, 11861959, - + 11861987, 11861987, 11862007, 11862007, 11862013, 11862013, - + 11862029, 11862029, 11862031, 11862031, 11862049, 11862049, - + 11862077, 11862077, 11862083, 11862083, 11862157, 11862157, - + 11862167, 11862167, 11862199, 11862199, 11862203, 11862203, - + 11862217, 11862217, 11862223, 11862223, 11862229, 11862229, - + 11862233, 11862233, 11862239, 11862239, 11862241, 11862241, - + 11862259, 11862259, 11862269, 11862269, 11862271, 11862271 / - data (iparam(1,i),iparam(2,i),i= 960, 989) / - + 11862293, 11862293, 11862307, 11862307, 11862313, 11862313, - + 11862317, 11862317, 11862343, 11862343, 11862353, 11862353, - + 11862373, 11862373, 11862391, 11862391, 11862439, 11862439, - + 11862469, 11862469, 11862493, 11862493, 11862527, 11862527, - + 11862547, 11862547, 11862563, 11862563, 11862569, 11862569, - + 11862577, 11862577, 11862581, 11862581, 11862611, 11862611, - + 11862623, 11862623, 11862661, 11862661, 11862673, 11862673, - + 11862679, 11862679, 11862701, 11862701, 11862703, 11862703, - + 11862713, 11862713, 11862761, 11862761, 11862791, 11862791, - + 11862803, 11862803, 11862839, 11862839, 11862841, 11862841 / - data (iparam(1,i),iparam(2,i),i= 990,1019) / - + 11862857, 11862857, 11862869, 11862869, 11862881, 11862881, - + 11862911, 11862911, 11862919, 11862919, 11862959, 11862959, - + 11862979, 11862979, 11862989, 11862989, 11862997, 11862997, - + 11863021, 11863021, 11863031, 11863031, 11863037, 11863037, - + 11863039, 11863039, 11863057, 11863057, 11863067, 11863067, - + 11863073, 11863073, 11863099, 11863099, 11863109, 11863109, - + 11863121, 11863121, 11863123, 11863123, 11863133, 11863133, - + 11863151, 11863151, 11863153, 11863153, 11863171, 11863171, - + 11863183, 11863183, 11863207, 11863207, 11863213, 11863213, - + 11863237, 11863237, 11863249, 11863249, 11863253, 11863253 / - data (iparam(1,i),iparam(2,i),i=1020,1021) / - + 11863259, 11863259, 11863279, 11863279 / - end -#else - real function prng_next(me) -crc logical prng_restart, prng_chkpnt -c -c Calling sequence: -c = prng_next ( ) -c -c This code is based on a sequential algorithm provided by Mal Kalos. -c This version uses 4 16-bit packets, and uses a block data common -c area for the initial seeds and constants. A 64-bit floating point -c number is returned. -c -c The arrays "l" and "n" are full-word aligned, being padded by zeros -c That is, rows 1-4 in a given column are for real, rows 5-16 are bogus -c -c July 12, 1993: double the number of sequences. We should have been -c using two packets per seed, rather than four -c - real tpm12 - integer iseed(4) - parameter(tpm12 = 1.d0/65536.d0) - parameter(nmax=1021) -c external prngblk - common/ksrprng/l(16,0:nmax),n(16,0:nmax) -c*ksr*subpage /ksrprng/ - data m1,m2,m3,m4 / 0, 8037, 61950, 30779/ - if (me .lt. 0 .or. me .gt. nmax) then - prng_next=-1.0 - return - endif - l1=l(1,me) - l2=l(2,me) - l3=l(3,me) - l4=l(4,me) - i1=l1*m4+l2*m3+l3*m2+l4*m1 + n(1,me) - i2=l2*m4+l3*m3+l4*m2 + n(2,me) - i3=l3*m4+l4*m3 + n(3,me) - i4=l4*m4 + n(4,me) - l4=and(i4,65535) - i3=i3+ishft(i4,-16) - l3=and(i3,65535) - i2=i2+ishft(i3,-16) - l2=and(i2,65535) - l1=and(i1+ishft(i2,-16),65535) - prng_next=tpm12*(l1+tpm12*(l2+tpm12*(l3+tpm12*l4))) - l(1,me)=l1 - l(2,me)=l2 - l(3,me)=l3 - l(4,me)=l4 - return - end -c -c prng_chkpnt Get the current state of a generator -c -c Calling sequence: -c logical prng_chkpnt, status -c status = prng_chkpnt (me, iseed) where -c -c me is the particular generator whose state is being gotten -c seed is an 4-element integer array where the "l"-values will be saved -c -crc entry prng_chkpnt (me, iseed) - logical function prng_chkpnt (me, iseed) - integer iseed(4) - parameter(nmax=1021) - common/ksrprng/l(16,0:nmax),n(16,0:nmax) - if (me .lt. 0 .or. me .gt. nmax) then - prng_chkpnt=.false. - else - prng_chkpnt=.true. - iseed(1)=l(1,me) - iseed(2)=l(2,me) - iseed(3)=l(3,me) - iseed(4)=l(4,me) - endif - return - end -c -c prng_restart Restart generator from a saved state -c -c Calling sequence: -c logical prng_restart, status -c status = prng_restart (me, iseed) where -c -c me is the particular generator being restarted -c seed is an 4-element integer array containing the "l"-values -c -crc entry prng_restart (me, iseed) - logical function prng_restart (me, iseed) - integer iseed(4) - parameter(nmax=1021) - common/ksrprng/l(16,0:nmax),n(16,0:nmax) - if (me .lt. 0 .or. me .gt. nmax) then - prng_restart=.false. - return - else - prng_restart=.true. - l(1,me)=iseed(1) - l(2,me)=iseed(2) - l(3,me)=iseed(3) - l(4,me)=iseed(4) - endif - return - end - - block data prngblk -c -c Sequence of prime numbers represented as pairs of 16-bit integers -c modulo 2**16, obtained from Mal Kalos August 28, 1992. Only 98 -c continuation cards are allowed by ksr Fortran, so several DATA -c statements are used to initialize 1022 generators. -c -c @cornell university, 1992 -c - parameter(nmax=1021,nmax1=2*nmax+2) - common/ksrprng/l(16,0:nmax),n(16,0:nmax) -c*ksr*subpage /ksrprng/ - -c High order quads in arrays "l" and "n" are initialized to zero : rows 1-2 -c Rows 5-16 remain uninitialized. They are just pads, never used. - DATA ((l(i,j),i=1,2),j=0,nmax)/nmax1*0.0/ - DATA ((n(i,j),i=1,2),j=0,nmax)/nmax1*0.0/ - -c The rest of array "l" and "n" are initialized to a 20-bit seed - DATA ((l(i,j),i=3,4),j=0,489)/ - .180, 51739,180, 51757,180, 51761,180, 51767,180,51773, - .180, 51791,180, 51817,180, 51833,180, 51859,180, 51871, - .180, 51877,180, 51883,180, 51887,180, 51893,180, 51899, - .180, 51913,180, 51953,180, 51971,180, 51989,180, 51997, - .180, 52009,180, 52013,180, 52033,180, 52043,180, 52051, - .180, 52057,180, 52073,180, 52109,180, 52111,180, 52121, - .180, 52139,180, 52157,180, 52183,180, 52193,180, 52199, - .180, 52211,180, 52219,180, 52229,180, 52237,180, 52241, - .180, 52249,180, 52261,180, 52271,180, 52277,180, 52307, - .180, 52321,180, 52349,180, 52373,180, 52381,180, 52387, - .180, 52393,180, 52411,180, 52429,180, 52439,180, 52451, - .180, 52457,180, 52481,180, 52501,180, 52541,180, 52559, - .180, 52573,180, 52579,180, 52589,180, 52597,180, 52607, - .180, 52613,180, 52627,180, 52631,180, 52649,180, 52657, - .180, 52697,180, 52703,180, 52723,180, 52751,180, 52757, - .180, 52759,180, 52769,180, 52771,180, 52789,180, 52793, - .180, 52811,180, 52817,180, 52829,180, 52859,180, 52879, - .180, 52883,180, 52919,180, 52921,180, 52933,180, 52937, - .180, 52957,180, 52963,180, 52993,180, 53011,180, 53023, - .180, 53027,180, 53077,180, 53087,180, 53089,180, 53093, - .180, 53107,180, 53119,180, 53153,180, 53161,180, 53173, - .180, 53179,180, 53191,180, 53203,180, 53209,180, 53213, - .180, 53219,180, 53221,180, 53227,180, 53233,180, 53243, - .180, 53261,180, 53263,180, 53279,180, 53287,180, 53291, - .180, 53311,180, 53321,180, 53329,180, 53333,180, 53389, - .180, 53401,180, 53411,180, 53429,180, 53443,180, 53453, - .180, 53467,180, 53507,180, 53521,180, 53531,180, 53539, - .180, 53543,180, 53551,180, 53569,180, 53581,180, 53593, - .180, 53597,180, 53623,180, 53629,180, 53641,180, 53647, - .180, 53653,180, 53669,180, 53681,180, 53689,180, 53711, - .180, 53753,180, 53767,180, 53779,180, 53789,180, 53803, - .180, 53821,180, 53861,180, 53867,180, 53887,180, 53893, - .180, 53899,180, 53909,180, 53927,180, 53947,180, 53957, - .180, 53989,180, 54001,180, 54031,180, 54049,180, 54061, - .180, 54077,180, 54127,180, 54131,180, 54187,180, 54197, - .180, 54199,180, 54221,180, 54251,180, 54259,180, 54269, - .180, 54311,180, 54323,180, 54349,180, 54353,180, 54379, - .180, 54397,180, 54419,180, 54427,180, 54433,180, 54439, - .180, 54451,180, 54461,180, 54467,180, 54473,180, 54481, - .180, 54503,180, 54511,180, 54517,180, 54551,180, 54553, - .180, 54571,180, 54581,180, 54587,180, 54613,180, 54629, - .180, 54643,180, 54647,180, 54659,180, 54677,180, 54683, - .180, 54701,180, 54721,180, 54739,180, 54811,180, 54823, - .180, 54829,180, 54833,180, 54839,180, 54869,180, 54871, - .180, 54881,180, 54893,180, 54923,180, 54929,180, 54943, - .180, 54967,180, 54971,180, 55001,180, 55013,180, 55039, - .180, 55043,180, 55049,180, 55067,180, 55069,180, 55079, - .180, 55097,180, 55109,180, 55111,180, 55117,180, 55123, - .180, 55127,180, 55133,180, 55141,180, 55147,180, 55159, - .180, 55193,180, 55201,180, 55247,180, 55273,180, 55279, - .180, 55307,180, 55313,180, 55319,180, 55333,180, 55361, - .180, 55379,180, 55387,180, 55411,180, 55429,180, 55439, - .180, 55447,180, 55453,180, 55469,180, 55487,180, 55517, - .180, 55537,180, 55571,180, 55573,180, 55579,180, 55603, - .180, 55609,180, 55649,180, 55667,180, 55669,180, 55681, - .180, 55691,180, 55697,180, 55729,180, 55741,180, 55757, - .180, 55771,180, 55783,180, 55793,180, 55799,180, 55807, - .180, 55813,180, 55817,180, 55823,180, 55831,180, 55847, - .180, 55859,180, 55861,180, 55879,180, 55889,180, 55957, - .180, 55973,180, 55979,180, 55993,180, 56033,180, 56051, - .180, 56057,180, 56059,180, 56077,180, 56093,180, 56099, - .180, 56111,180, 56129,180, 56131,180, 56143,180, 56161, - .180, 56167,180, 56177,180, 56183,180, 56237,180, 56239, - .180, 56261,180, 56279,180, 56287,180, 56293,180, 56323, - .180, 56327,180, 56329,180, 56351,180, 56353,180, 56357, - .180, 56377,180, 56393,180, 56399,180, 56411,180, 56437, - .180, 56441,180, 56477,180, 56479,180, 56489,180, 56503, - .180, 56509,180, 56521,180, 56533,180, 56539,180, 56551, - .180, 56609,180, 56653,180, 56677,180, 56681,180, 56701, - .180, 56723,180, 56737,180, 56741,180, 56747,180, 56761, - .180, 56827,180, 56839,180, 56843,180, 56849,180, 56887, - .180, 56903,180, 56939,180, 56941,180, 56947,180, 56969, - .180, 56971,180, 56983,180, 57049,180, 57077,180, 57091, - .180, 57121,180, 57133,180, 57137,180, 57149,180, 57169, - .180, 57179,180, 57199,180, 57209,180, 57239,180, 57251, - .180, 57277,180, 57281,180, 57293,180, 57311,180, 57337, - .180, 57359,180, 57367,180, 57377,180, 57389,180, 57403, - .180, 57407,180, 57409,180, 57413,180, 57419,180, 57431, - .180, 57451,180, 57463,180, 57499,180, 57511,180, 57521, - .180, 57529,180, 57539,180, 57577,180, 57581,180, 57667, - .180, 57679,180, 57683,180, 57689,180, 57731,180, 57767, - .180, 57781,180, 57787,180, 57799,180, 57823,180, 57847, - .180, 57851,180, 57853,180, 57883,180, 57899,180, 57919, - .180, 57931,180, 57949,180, 57953,180, 57959,180, 57961, - .180, 57983,180, 57997,180, 58009,180, 58037,180, 58039, - .180, 58043,180, 58049,180, 58087,180, 58091,180, 58093, - .180, 58123,180, 58127,180, 58201,180, 58211,180, 58229, - .180, 58243,180, 58277,180, 58303,180, 58313,180, 58333, - .180, 58367,180, 58373,180, 58393,180, 58397,180, 58403, - .180, 58411,180, 58417,180, 58421,180, 58439,180, 58457, - .180, 58481,180, 58483,180, 58499,180, 58523,180, 58537, - .180, 58543,180, 58549,180, 58553,180, 58631,180, 58661, - .180, 58667,180, 58669,180, 58679,180, 58697,180, 58723, - .180, 58733,180, 58739,180, 58751,180, 58787,180, 58789, - .180, 58823,180, 58829,180, 58841,180, 58849,180, 58859, - .180, 58871,180, 58873,180, 58877,180, 58879,180, 58901, - .180, 58903,180, 58907,180, 58919,180, 58927,180, 58933, - .180, 59009,180, 59011,180, 59027,180, 59041,180, 59051/ - DATA ((l(i,j),i=3,4),j=490,979)/ - .180, 59069,180, 59071,180, 59087,180, 59101,180, 59107, - .180, 59113,180, 59153,180, 59173,180, 59183,180, 59207, - .180, 59209,180, 59219,180, 59233,180, 59251,180, 59257, - .180, 59263,180, 59267,180, 59279,180, 59293,180, 59321, - .180, 59327,180, 59333,180, 59347,180, 59359,180, 59389, - .180, 59401,180, 59423,180, 59431,180, 59453,180, 59479, - .180, 59509,180, 59513,180, 59519,180, 59521,180, 59543, - .180, 59569,180, 59591,180, 59621,180, 59627,180, 59633, - .180, 59659,180, 59671,180, 59681,180, 59699,180, 59713, - .180, 59719,180, 59743,180, 59759,180, 59783,180, 59789, - .180, 59801,180, 59807,180, 59827,180, 59831,180, 59849, - .180, 59863,180, 59879,180, 59891,180, 59893,180, 59929, - .180, 59939,180, 59981,180, 59989,180, 59993,180, 59999, - .180, 60031,180, 60037,180, 60061,180, 60067,180, 60073, - .180, 60103,180, 60149,180, 60161,180, 60173,180, 60179, - .180, 60193,180, 60217,180, 60229,180, 60247,180, 60251, - .180, 60283,180, 60329,180, 60331,180, 60341,180, 60361, - .180, 60377,180, 60397,180, 60403,180, 60419,180, 60439, - .180, 60467,180, 60473,180, 60499,180, 60523,180, 60553, - .180, 60557,180, 60559,180, 60569,180, 60581,180, 60587, - .180, 60593,180, 60601,180, 60611,180, 60613,180, 60619, - .180, 60643,180, 60647,180, 60667,180, 60671,180, 60713, - .180, 60737,180, 60749,180, 60763,180, 60769,180, 60787, - .180, 60797,180, 60811,180, 60823,180, 60829,180, 60847, - .180, 60851,180, 60853,180, 60881,180, 60887,180, 60889, - .180, 60913,180, 60919,180, 60929,180, 60941,180, 60943, - .180, 60971,180, 60973,180, 60977,180, 60997,180, 61001, - .180, 61013,180, 61019,180, 61039,180, 61043,180, 61049, - .180, 61063,180, 61081,180, 61109,180, 61111,180, 61133, - .180, 61141,180, 61181,180, 61187,180, 61213,180, 61217, - .180, 61229,180, 61231,180, 61271,180, 61273,180, 61279, - .180, 61283,180, 61297,180, 61307,180, 61313,180, 61321, - .180, 61337,180, 61339,180, 61351,180, 61357,180, 61393, - .180, 61397,180, 61403,180, 61409,180, 61427,180, 61433, - .180, 61451,180, 61489,180, 61511,180, 61519,180, 61529, - .180, 61537,180, 61543,180, 61549,180, 61559,180, 61571, - .180, 61577,180, 61579,180, 61621,180, 61631,180, 61651, - .180, 61669,180, 61679,180, 61697,180, 61711,180, 61721, - .180, 61747,180, 61763,180, 61787,180, 61789,180, 61799, - .180, 61801,180, 61811,180, 61831,180, 61843,180, 61879, - .180, 61897,180, 61901,180, 61907,180, 61943,180, 61963, - .180, 61967,180, 61999,180, 62053,180, 62063,180, 62071, - .180, 62077,180, 62089,180, 62093,180, 62099,180, 62117, - .180, 62119,180, 62149,180, 62177,180, 62179,180, 62203, - .180, 62221,180, 62239,180, 62243,180, 62249,180, 62267, - .180, 62299,180, 62303,180, 62321,180, 62327,180, 62333, - .180, 62359,180, 62371,180, 62413,180, 62417,180, 62441, - .180, 62467,180, 62473,180, 62489,180, 62491,180, 62509, - .180, 62537,180, 62551,180, 62569,180, 62581,180, 62593, - .180, 62597,180, 62599,180, 62603,180, 62621,180, 62629, - .180, 62657,180, 62659,180, 62671,180, 62677,180, 62683, - .180, 62687,180, 62699,180, 62707,180, 62749,180, 62753, - .180, 62761,180, 62767,180, 62789,180, 62813,180, 62827, - .180, 62831,180, 62869,180, 62879,180, 62891,180, 62897, - .180, 62903,180, 62947,180, 62953,180, 62971,180, 62977, - .180, 62981,180, 62993,180, 63001,180, 63007,180, 63013, - .180, 63023,180, 63029,180, 63059,180, 63061,180, 63083, - .180, 63089,180, 63091,180, 63103,180, 63119,180, 63131, - .180, 63163,180, 63227,180, 63233,180, 63239,180, 63259, - .180, 63271,180, 63311,180, 63337,180, 63341,180, 63353, - .180, 63367,180, 63373,180, 63397,180, 63409,180, 63413, - .180, 63421,180, 63427,180, 63437,180, 63443,180, 63449, - .180, 63481,180, 63499,180, 63509,180, 63517,180, 63541, - .180, 63551,180, 63559,180, 63569,180, 63601,180, 63607, - .180, 63617,180, 63623,180, 63629,180, 63637,180, 63653, - .180, 63671,180, 63691,180, 63727,180, 63743,180, 63751, - .180, 63763,180, 63787,180, 63821,180, 63827,180, 63847, - .180, 63899,180, 63917,180, 63931,180, 63989,180, 63997, - .180, 64003,180, 64007,180, 64009,180, 64013,180, 64037, - .180, 64067,180, 64087,180, 64093,180, 64133,180, 64139, - .180, 64147,180, 64157,180, 64163,180, 64169,180, 64181, - .180, 64189,180, 64207,180, 64211,180, 64217,180, 64219, - .180, 64223,180, 64247,180, 64261,180, 64273,180, 64297, - .180, 64307,180, 64309,180, 64331,180, 64357,180, 64379, - .180, 64387,180, 64409,180, 64417,180, 64483,180, 64489, - .180, 64493,180, 64513,180, 64531,180, 64553,180, 64591, - .180, 64601,180, 64609,180, 64613,180, 64619,180, 64627, - .180, 64651,180, 64661,180, 64679,180, 64687,180, 64711, - .180, 64717,180, 64727,180, 64739,180, 64741,180, 64751, - .180, 64757,180, 64793,180, 64813,180, 64819,180, 64823, - .180, 64847,180, 64871,180, 64877,180, 64883,180, 64891, - .180, 64921,180, 64927,180, 64931,180, 64933,180, 64949, - .180, 64961,180, 64987,180, 65047,180, 65059,180, 65063, - .180, 65077,180, 65089,180, 65093,180, 65099,180, 65101, - .180, 65119,180, 65131,180, 65137,180, 65147,180, 65159, - .180, 65171,180, 65179,180, 65191,180, 65203,180, 65207, - .180, 65213,180, 65221,180, 65231,180, 65233,180, 65269, - .180, 65311,180, 65323,180, 65339,180, 65347,180, 65369, - .180, 65393,180, 65399,180, 65407,180, 65431,180, 65437, - .180, 65441,180, 65443,180, 65473,180, 65479,180, 65507, - .180, 65527,180, 65533,181, 13,181, 15,181, 33, - .181, 61,181, 67,181, 141,181, 151,181, 183, - .181, 187,181, 201,181, 207,181, 213,181, 217, - .181, 223,181, 225,181, 243,181, 253,181, 255, - .181, 277,181, 291,181, 297,181, 301,181, 327, - .181, 337,181, 357,181, 375,181, 423,181, 453, - .181, 477,181, 511,181, 531,181, 547,181, 553, - .181, 561,181, 565,181, 595,181, 607,181, 645/ - DATA ((l(i,j),i=3,4),j=980,nmax)/ - .181, 657,181, 663,181, 685,181, 687,181, 697, - .181, 745,181, 775,181, 787,181, 823,181, 825, - .181, 841,181, 853,181, 865,181, 895,181, 903, - .181, 943,181, 963,181, 973,181, 981,181, 1005, - .181,1015,181,1021,181,1023,181,1041,181,1051, - .181, 1057,181, 1083,181, 1093,181, 1105,181, 1107, - .181, 1117,181, 1135,181, 1137,181, 1155,181, 1167, - .181, 1191,181, 1197,181, 1221,181, 1233,181, 1237, - .181, 1243,181, 1263/ - DATA ((n(i,j),i=3,4),j=0,489)/ - .180, 51739,180, 51757,180, 51761,180, 51767,180, 51773, - .180, 51791,180, 51817,180, 51833,180, 51859,180, 51871, - .180, 51877,180, 51883,180, 51887,180, 51893,180, 51899, - .180, 51913,180, 51953,180, 51971,180, 51989,180, 51997, - .180, 52009,180, 52013,180, 52033,180, 52043,180, 52051, - .180, 52057,180, 52073,180, 52109,180, 52111,180, 52121, - .180, 52139,180, 52157,180, 52183,180, 52193,180, 52199, - .180, 52211,180, 52219,180, 52229,180, 52237,180, 52241, - .180, 52249,180, 52261,180, 52271,180, 52277,180, 52307, - .180, 52321,180, 52349,180, 52373,180, 52381,180, 52387, - .180, 52393,180, 52411,180, 52429,180, 52439,180, 52451, - .180, 52457,180, 52481,180, 52501,180, 52541,180, 52559, - .180, 52573,180, 52579,180, 52589,180, 52597,180, 52607, - .180, 52613,180, 52627,180, 52631,180, 52649,180, 52657, - .180, 52697,180, 52703,180, 52723,180, 52751,180, 52757, - .180, 52759,180, 52769,180, 52771,180, 52789,180, 52793, - .180, 52811,180, 52817,180, 52829,180, 52859,180, 52879, - .180, 52883,180, 52919,180, 52921,180, 52933,180, 52937, - .180, 52957,180, 52963,180, 52993,180, 53011,180, 53023, - .180, 53027,180, 53077,180, 53087,180, 53089,180, 53093, - .180, 53107,180, 53119,180, 53153,180, 53161,180, 53173, - .180, 53179,180, 53191,180, 53203,180, 53209,180, 53213, - .180, 53219,180, 53221,180, 53227,180, 53233,180, 53243, - .180, 53261,180, 53263,180, 53279,180, 53287,180, 53291, - .180, 53311,180, 53321,180, 53329,180, 53333,180, 53389, - .180, 53401,180, 53411,180, 53429,180, 53443,180, 53453, - .180, 53467,180, 53507,180, 53521,180, 53531,180, 53539, - .180, 53543,180, 53551,180, 53569,180, 53581,180, 53593, - .180, 53597,180, 53623,180, 53629,180, 53641,180, 53647, - .180, 53653,180, 53669,180, 53681,180, 53689,180, 53711, - .180, 53753,180, 53767,180, 53779,180, 53789,180, 53803, - .180, 53821,180, 53861,180, 53867,180, 53887,180, 53893, - .180, 53899,180, 53909,180, 53927,180, 53947,180, 53957, - .180, 53989,180, 54001,180, 54031,180, 54049,180, 54061, - .180, 54077,180, 54127,180, 54131,180, 54187,180, 54197, - .180, 54199,180, 54221,180, 54251,180, 54259,180, 54269, - .180, 54311,180, 54323,180, 54349,180, 54353,180, 54379, - .180, 54397,180, 54419,180, 54427,180, 54433,180, 54439, - .180, 54451,180, 54461,180, 54467,180, 54473,180, 54481, - .180, 54503,180, 54511,180, 54517,180, 54551,180, 54553, - .180, 54571,180, 54581,180, 54587,180, 54613,180, 54629, - .180, 54643,180, 54647,180, 54659,180, 54677,180, 54683, - .180, 54701,180, 54721,180, 54739,180, 54811,180, 54823, - .180, 54829,180, 54833,180, 54839,180, 54869,180, 54871, - .180, 54881,180, 54893,180, 54923,180, 54929,180, 54943, - .180, 54967,180, 54971,180, 55001,180, 55013,180, 55039, - .180, 55043,180, 55049,180, 55067,180, 55069,180, 55079, - .180, 55097,180, 55109,180, 55111,180, 55117,180, 55123, - .180, 55127,180, 55133,180, 55141,180, 55147,180, 55159, - .180, 55193,180, 55201,180, 55247,180, 55273,180, 55279, - .180, 55307,180, 55313,180, 55319,180, 55333,180, 55361, - .180, 55379,180, 55387,180, 55411,180, 55429,180, 55439, - .180, 55447,180, 55453,180, 55469,180, 55487,180, 55517, - .180, 55537,180, 55571,180, 55573,180, 55579,180, 55603, - .180, 55609,180, 55649,180, 55667,180, 55669,180, 55681, - .180, 55691,180, 55697,180, 55729,180, 55741,180, 55757, - .180, 55771,180, 55783,180, 55793,180, 55799,180, 55807, - .180, 55813,180, 55817,180, 55823,180, 55831,180, 55847, - .180, 55859,180, 55861,180, 55879,180, 55889,180, 55957, - .180, 55973,180, 55979,180, 55993,180, 56033,180, 56051, - .180, 56057,180, 56059,180, 56077,180, 56093,180, 56099, - .180, 56111,180, 56129,180, 56131,180, 56143,180, 56161, - .180, 56167,180, 56177,180, 56183,180, 56237,180, 56239, - .180, 56261,180, 56279,180, 56287,180, 56293,180, 56323, - .180, 56327,180, 56329,180, 56351,180, 56353,180, 56357, - .180, 56377,180, 56393,180, 56399,180, 56411,180, 56437, - .180, 56441,180, 56477,180, 56479,180, 56489,180, 56503, - .180, 56509,180, 56521,180, 56533,180, 56539,180, 56551, - .180, 56609,180, 56653,180, 56677,180, 56681,180, 56701, - .180, 56723,180, 56737,180, 56741,180, 56747,180, 56761, - .180, 56827,180, 56839,180, 56843,180, 56849,180, 56887, - .180, 56903,180, 56939,180, 56941,180, 56947,180, 56969, - .180, 56971,180, 56983,180, 57049,180, 57077,180, 57091, - .180, 57121,180, 57133,180, 57137,180, 57149,180, 57169, - .180, 57179,180, 57199,180, 57209,180, 57239,180, 57251, - .180, 57277,180, 57281,180, 57293,180, 57311,180, 57337, - .180, 57359,180, 57367,180, 57377,180, 57389,180, 57403, - .180, 57407,180, 57409,180, 57413,180, 57419,180, 57431, - .180, 57451,180, 57463,180, 57499,180, 57511,180, 57521, - .180, 57529,180, 57539,180, 57577,180, 57581,180, 57667, - .180, 57679,180, 57683,180, 57689,180, 57731,180, 57767, - .180, 57781,180, 57787,180, 57799,180, 57823,180, 57847, - .180, 57851,180, 57853,180, 57883,180, 57899,180, 57919, - .180, 57931,180, 57949,180, 57953,180, 57959,180, 57961, - .180, 57983,180, 57997,180, 58009,180, 58037,180, 58039, - .180, 58043,180, 58049,180, 58087,180, 58091,180, 58093, - .180, 58123,180, 58127,180, 58201,180, 58211,180, 58229, - .180, 58243,180, 58277,180, 58303,180, 58313,180, 58333, - .180, 58367,180, 58373,180, 58393,180, 58397,180, 58403, - .180, 58411,180, 58417,180, 58421,180, 58439,180, 58457, - .180, 58481,180, 58483,180, 58499,180, 58523,180, 58537, - .180, 58543,180, 58549,180, 58553,180, 58631,180, 58661, - .180, 58667,180, 58669,180, 58679,180, 58697,180, 58723, - .180, 58733,180, 58739,180, 58751,180, 58787,180, 58789, - .180, 58823,180, 58829,180, 58841,180, 58849,180, 58859, - .180, 58871,180, 58873,180, 58877,180, 58879,180, 58901, - .180, 58903,180, 58907,180, 58919,180, 58927,180, 58933, - .180, 59009,180, 59011,180, 59027,180, 59041,180, 59051/ - DATA ((n(i,j),i=3,4),j=490,979)/ - .180, 59069,180, 59071,180, 59087,180, 59101,180, 59107, - .180, 59113,180, 59153,180, 59173,180, 59183,180, 59207, - .180, 59209,180, 59219,180, 59233,180, 59251,180, 59257, - .180, 59263,180, 59267,180, 59279,180, 59293,180, 59321, - .180, 59327,180, 59333,180, 59347,180, 59359,180, 59389, - .180, 59401,180, 59423,180, 59431,180, 59453,180, 59479, - .180, 59509,180, 59513,180, 59519,180, 59521,180, 59543, - .180, 59569,180, 59591,180, 59621,180, 59627,180, 59633, - .180, 59659,180, 59671,180, 59681,180, 59699,180, 59713, - .180, 59719,180, 59743,180, 59759,180, 59783,180, 59789, - .180, 59801,180, 59807,180, 59827,180, 59831,180, 59849, - .180, 59863,180, 59879,180, 59891,180, 59893,180, 59929, - .180, 59939,180, 59981,180, 59989,180, 59993,180, 59999, - .180, 60031,180, 60037,180, 60061,180, 60067,180, 60073, - .180, 60103,180, 60149,180, 60161,180, 60173,180, 60179, - .180, 60193,180, 60217,180, 60229,180, 60247,180, 60251, - .180, 60283,180, 60329,180, 60331,180, 60341,180, 60361, - .180, 60377,180, 60397,180, 60403,180, 60419,180, 60439, - .180, 60467,180, 60473,180, 60499,180, 60523,180, 60553, - .180, 60557,180, 60559,180, 60569,180, 60581,180, 60587, - .180, 60593,180, 60601,180, 60611,180, 60613,180, 60619, - .180, 60643,180, 60647,180, 60667,180, 60671,180, 60713, - .180, 60737,180, 60749,180, 60763,180, 60769,180, 60787, - .180, 60797,180, 60811,180, 60823,180, 60829,180, 60847, - .180, 60851,180, 60853,180, 60881,180, 60887,180, 60889, - .180, 60913,180, 60919,180, 60929,180, 60941,180, 60943, - .180, 60971,180, 60973,180, 60977,180, 60997,180, 61001, - .180, 61013,180, 61019,180, 61039,180, 61043,180, 61049, - .180, 61063,180, 61081,180, 61109,180, 61111,180, 61133, - .180, 61141,180, 61181,180, 61187,180, 61213,180, 61217, - .180, 61229,180, 61231,180, 61271,180, 61273,180, 61279, - .180, 61283,180, 61297,180, 61307,180, 61313,180, 61321, - .180, 61337,180, 61339,180, 61351,180, 61357,180, 61393, - .180, 61397,180, 61403,180, 61409,180, 61427,180, 61433, - .180, 61451,180, 61489,180, 61511,180, 61519,180, 61529, - .180, 61537,180, 61543,180, 61549,180, 61559,180, 61571, - .180, 61577,180, 61579,180, 61621,180, 61631,180, 61651, - .180, 61669,180, 61679,180, 61697,180, 61711,180, 61721, - .180, 61747,180, 61763,180, 61787,180, 61789,180, 61799, - .180, 61801,180, 61811,180, 61831,180, 61843,180, 61879, - .180, 61897,180, 61901,180, 61907,180, 61943,180, 61963, - .180, 61967,180, 61999,180, 62053,180, 62063,180, 62071, - .180, 62077,180, 62089,180, 62093,180, 62099,180, 62117, - .180, 62119,180, 62149,180, 62177,180, 62179,180, 62203, - .180, 62221,180, 62239,180, 62243,180, 62249,180, 62267, - .180, 62299,180, 62303,180, 62321,180, 62327,180, 62333, - .180, 62359,180, 62371,180, 62413,180, 62417,180, 62441, - .180, 62467,180, 62473,180, 62489,180, 62491,180, 62509, - .180, 62537,180, 62551,180, 62569,180, 62581,180, 62593, - .180, 62597,180, 62599,180, 62603,180, 62621,180, 62629, - .180, 62657,180, 62659,180, 62671,180, 62677,180, 62683, - .180, 62687,180, 62699,180, 62707,180, 62749,180, 62753, - .180, 62761,180, 62767,180, 62789,180, 62813,180, 62827, - .180, 62831,180, 62869,180, 62879,180, 62891,180, 62897, - .180, 62903,180, 62947,180, 62953,180, 62971,180, 62977, - .180, 62981,180, 62993,180, 63001,180, 63007,180, 63013, - .180, 63023,180, 63029,180, 63059,180, 63061,180, 63083, - .180, 63089,180, 63091,180, 63103,180, 63119,180, 63131, - .180, 63163,180, 63227,180, 63233,180, 63239,180, 63259, - .180, 63271,180, 63311,180, 63337,180, 63341,180, 63353, - .180, 63367,180, 63373,180, 63397,180, 63409,180, 63413, - .180, 63421,180, 63427,180, 63437,180, 63443,180, 63449, - .180, 63481,180, 63499,180, 63509,180, 63517,180, 63541, - .180, 63551,180, 63559,180, 63569,180, 63601,180, 63607, - .180, 63617,180, 63623,180, 63629,180, 63637,180, 63653, - .180, 63671,180, 63691,180, 63727,180, 63743,180, 63751, - .180, 63763,180, 63787,180, 63821,180, 63827,180, 63847, - .180, 63899,180, 63917,180, 63931,180, 63989,180, 63997, - .180, 64003,180, 64007,180, 64009,180, 64013,180, 64037, - .180, 64067,180, 64087,180, 64093,180, 64133,180, 64139, - .180, 64147,180, 64157,180, 64163,180, 64169,180, 64181, - .180, 64189,180, 64207,180, 64211,180, 64217,180, 64219, - .180, 64223,180, 64247,180, 64261,180, 64273,180, 64297, - .180, 64307,180, 64309,180, 64331,180, 64357,180, 64379, - .180, 64387,180, 64409,180, 64417,180, 64483,180, 64489, - .180, 64493,180, 64513,180, 64531,180, 64553,180, 64591, - .180, 64601,180, 64609,180, 64613,180, 64619,180, 64627, - .180, 64651,180, 64661,180, 64679,180, 64687,180, 64711, - .180, 64717,180, 64727,180, 64739,180, 64741,180, 64751, - .180, 64757,180, 64793,180, 64813,180, 64819,180, 64823, - .180, 64847,180, 64871,180, 64877,180, 64883,180, 64891, - .180, 64921,180, 64927,180, 64931,180, 64933,180, 64949, - .180, 64961,180, 64987,180, 65047,180, 65059,180, 65063, - .180, 65077,180, 65089,180, 65093,180, 65099,180, 65101, - .180, 65119,180, 65131,180, 65137,180, 65147,180, 65159, - .180, 65171,180, 65179,180, 65191,180, 65203,180, 65207, - .180, 65213,180, 65221,180, 65231,180, 65233,180, 65269, - .180, 65311,180, 65323,180, 65339,180, 65347,180, 65369, - .180, 65393,180, 65399,180, 65407,180, 65431,180, 65437, - .180, 65441,180, 65443,180, 65473,180, 65479,180, 65507, - .180, 65527,180, 65533,181, 13,181, 15,181, 33, - .181, 61,181, 67,181, 141,181, 151,181, 183, - .181, 187,181, 201,181, 207,181, 213,181, 217, - .181, 223,181, 225,181, 243,181, 253,181, 255, - .181, 277,181, 291,181, 297,181, 301,181, 327, - .181, 337,181, 357,181, 375,181, 423,181, 453, - .181, 477,181, 511,181, 531,181, 547,181, 553, - .181, 561,181, 565,181, 595,181, 607,181, 645/ - DATA ((n(i,j),i=3,4),j=980,nmax)/ - .181, 657,181, 663,181, 685,181, 687,181, 697, - .181, 745,181, 775,181, 787,181, 823,181, 825, - .181, 841,181, 853,181, 865,181, 895,181, 903, - .181, 943,181, 963,181, 973,181, 981,181, 1005, - .181, 1015,181, 1021,181, 1023,181, 1041,181, 1051, - .181, 1057,181, 1083,181, 1093,181, 1105,181, 1107, - .181, 1117,181, 1135,181, 1137,181, 1155,181, 1167, - .181, 1191,181, 1197,181, 1221,181, 1233,181, 1237, - .181, 1243,181, 1263/ - end -#endif diff --git a/source/unres/src_MD_DFA/proc_proc.c b/source/unres/src_MD_DFA/proc_proc.c deleted file mode 100644 index d77c5a4..0000000 --- a/source/unres/src_MD_DFA/proc_proc.c +++ /dev/null @@ -1,139 +0,0 @@ -#include -#include - -#ifdef CRAY -void PROC_PROC(long int *f, int *i) -#else -#ifdef LINUX -#ifdef PGI -void proc_proc_(long int *f, int *i) -#else -void proc_proc__(long int *f, int *i) -#endif -#endif -#ifdef SGI -void proc_proc_(long int *f, int *i) -#endif -#if defined(WIN) && !defined(WINIFL) -void _stdcall PROC_PROC(long int *f, int *i) -#endif -#ifdef WINIFL -void proc_proc(long int *f, int *i) -#endif -#if defined(AIX) || defined(WINPGI) -void proc_proc(long int *f, int *i) -#endif -#endif - -{ -static long int NaNQ; -static long int NaNQm; - -if(*i==-1) - { - NaNQ=*f; - NaNQm=0xffffffff; - return; - } -*i=0; -if(*f==NaNQ) - *i=1; -if(*f==NaNQm) - *i=1; -} - -#ifdef CRAY -void PROC_CONV(char *buf, int *i, int n) -#endif -#ifdef LINUX -void proc_conv__(char *buf, int *i, int n) -#endif -#ifdef SGI -void proc_conv_(char *buf, int *i, int n) -#endif -#if defined(AIX) || defined(WINPGI) -void proc_conv(char *buf, int *i, int n) -#endif -#ifdef WIN -void _stdcall PROC_CONV(char *buf, int *i, int n) -#endif -{ -int j; - -sscanf(buf,"%d",&j); -*i=j; -return; -} - -#ifdef CRAY -void PROC_CONV_R(char *buf, int *i, int n) -#endif -#ifdef LINUX -void proc_conv_r__(char *buf, int *i, int n) -#endif -#ifdef SGI -void proc_conv_r_(char *buf, int *i, int n) -#endif -#if defined(AIX) || defined(WINPGI) -void proc_conv_r(char *buf, int *i, int n) -#endif -#ifdef WIN -void _stdcall PROC_CONV_R(char *buf, int *i, int n) -#endif - -{ - -/* sprintf(buf,"%d",*i); */ - -return; -} - - -#ifndef IMSL -#ifdef CRAY -void DSVRGP(int *n, double *tab1, double *tab2, int *itab) -#endif -#ifdef LINUX -void dsvrgp__(int *n, double *tab1, double *tab2, int *itab) -#endif -#ifdef SGI -void dsvrgp_(int *n, double *tab1, double *tab2, int *itab) -#endif -#if defined(AIX) || defined(WINPGI) -void dsvrgp(int *n, double *tab1, double *tab2, int *itab) -#endif -#ifdef WIN -void _stdcall DSVRGP(int *n, double *tab1, double *tab2, int *itab) -#endif -{ -double t; -int i,j,k; - -if(tab1 != tab2) - { - for(i=0; i<*n; i++) - tab2[i]=tab1[i]; - } -k=0; -while(k<*n-1) - { - j=k; - t=tab2[k]; - for(i=k+1; i<*n; i++) - if(t>tab2[i]) - { - j=i; - t=tab2[i]; - } - if(j!=k) - { - tab2[j]=tab2[k]; - tab2[k]=t; - i=itab[j]; - itab[j]=itab[k]; - itab[k]=i; - } - k++; - } -} -#endif diff --git a/source/unres/src_MD_DFA/q_measure.F b/source/unres/src_MD_DFA/q_measure.F deleted file mode 100644 index 417cf35..0000000 --- a/source/unres/src_MD_DFA/q_measure.F +++ /dev/null @@ -1,487 +0,0 @@ - double precision function qwolynes(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - integer i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4, - & secseg - integer nsep /3/ - double precision dist,qm - double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM - logical lprn /.false./ - logical flag - double precision sigm,x - sigm(x)=0.25d0*x - qq = 0.0d0 - nl=0 - if(flag) then - do il=seg1+nsep,seg2 - do jl=seg1,il-nsep - nl=nl+1 - d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ - & (cref(2,jl)-cref(2,il))**2+ - & (cref(3,jl)-cref(3,il))**2) - dij=dist(il,jl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,jl+nres)-cref(1,il+nres))**2+ - & (cref(2,jl+nres)-cref(2,il+nres))**2+ - & (cref(3,jl+nres)-cref(3,il+nres))**2) - dijCM=dist(il+nres,jl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - enddo - enddo - qq = qq/nl - else - do il=seg1,seg2 - if((seg3-il).lt.3) then - secseg=il+3 - else - secseg=seg3 - endif - do jl=secseg,seg4 - nl=nl+1 - d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ - & (cref(2,jl)-cref(2,il))**2+ - & (cref(3,jl)-cref(3,il))**2) - dij=dist(il,jl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,jl+nres)-cref(1,il+nres))**2+ - & (cref(2,jl+nres)-cref(2,il+nres))**2+ - & (cref(3,jl+nres)-cref(3,il+nres))**2) - dijCM=dist(il+nres,jl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - enddo - enddo - qq = qq/nl - endif - qwolynes=1.0d0-qq - return - end -c------------------------------------------------------------------- - subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.MD' - integer i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4, - & secseg - integer nsep /3/ - double precision dist - double precision dij,d0ij,dijCM,d0ijCM - logical lprn /.false./ - logical flag - double precision sigm,x,sim,dd0,fac,ddqij - sigm(x)=0.25d0*x - - do i=0,nres - do j=1,3 - dqwol(j,i)=0.0d0 - dxqwol(j,i)=0.0d0 - enddo - enddo - nl=0 - if(flag) then - do il=seg1+nsep,seg2 - do jl=seg1,il-nsep - nl=nl+1 - d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ - & (cref(2,jl)-cref(2,il))**2+ - & (cref(3,jl)-cref(3,il))**2) - dij=dist(il,jl) - sim = 1.0d0/sigm(d0ij) - sim = sim*sim - dd0 = dij-d0ij - fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim) - do k=1,3 - ddqij = (c(k,il)-c(k,jl))*fac - dqwol(k,il)=dqwol(k,il)+ddqij - dqwol(k,jl)=dqwol(k,jl)-ddqij - enddo - - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,jl+nres)-cref(1,il+nres))**2+ - & (cref(2,jl+nres)-cref(2,il+nres))**2+ - & (cref(3,jl+nres)-cref(3,il+nres))**2) - dijCM=dist(il+nres,jl+nres) - sim = 1.0d0/sigm(d0ijCM) - sim = sim*sim - dd0=dijCM-d0ijCM - fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim) - do k=1,3 - ddqij = (c(k,il+nres)-c(k,jl+nres))*fac - dxqwol(k,il)=dxqwol(k,il)+ddqij - dxqwol(k,jl)=dxqwol(k,jl)-ddqij - enddo - endif - enddo - enddo - else - do il=seg1,seg2 - if((seg3-il).lt.3) then - secseg=il+3 - else - secseg=seg3 - endif - do jl=secseg,seg4 - nl=nl+1 - d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ - & (cref(2,jl)-cref(2,il))**2+ - & (cref(3,jl)-cref(3,il))**2) - dij=dist(il,jl) - sim = 1.0d0/sigm(d0ij) - sim = sim*sim - dd0 = dij-d0ij - fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim) - do k=1,3 - ddqij = (c(k,il)-c(k,jl))*fac - dqwol(k,il)=dqwol(k,il)+ddqij - dqwol(k,jl)=dqwol(k,jl)-ddqij - enddo - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,jl+nres)-cref(1,il+nres))**2+ - & (cref(2,jl+nres)-cref(2,il+nres))**2+ - & (cref(3,jl+nres)-cref(3,il+nres))**2) - dijCM=dist(il+nres,jl+nres) - sim = 1.0d0/sigm(d0ijCM) - sim=sim*sim - dd0 = dijCM-d0ijCM - fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim) - do k=1,3 - ddqij = (c(k,il+nres)-c(k,jl+nres))*fac - dxqwol(k,il)=dxqwol(k,il)+ddqij - dxqwol(k,jl)=dxqwol(k,jl)-ddqij - enddo - endif - enddo - enddo - endif - do i=0,nres - do j=1,3 - dqwol(j,i)=dqwol(j,i)/nl - dxqwol(j,i)=dxqwol(j,i)/nl - enddo - enddo - return - end -c------------------------------------------------------------------- - subroutine qwol_num(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - integer seg1,seg2,seg3,seg4 - logical flag - double precision qwolan(3,0:maxres),cdummy(3,0:maxres2), - & qwolxan(3,0:maxres),q1,q2 - double precision delta /1.0d-10/ - do i=0,nres - do j=1,3 - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - cdummy(j,i)=c(j,i) - c(j,i)=c(j,i)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolan(j,i)=(q2-q1)/delta - c(j,i)=cdummy(j,i) - enddo - enddo - do i=0,nres - do j=1,3 - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - cdummy(j,i+nres)=c(j,i+nres) - c(j,i+nres)=c(j,i+nres)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolxan(j,i)=(q2-q1)/delta - c(j,i+nres)=cdummy(j,i+nres) - enddo - enddo -c write(iout,*) "Numerical Q carteisan gradients backbone: " -c do i=0,nct -c write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3) -c enddo -c write(iout,*) "Numerical Q carteisan gradients side-chain: " -c do i=0,nct -c write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3) -c enddo - return - end -c------------------------------------------------------------------------ - subroutine EconstrQ -c MD with umbrella_sampling using Wolyne's distance measure as a constraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision uzap1,uzap2,hm1,hm2,hmnum - double precision ucdelan,dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES), - & duconst(3,0:MAXRES),duxconst(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ - do i=0,nres - do j=1,3 - duconst(j,i)=0.0d0 - dudconst(j,i)=0.0d0 - duxconst(j,i)=0.0d0 - dudxconst(j,i)=0.0d0 - enddo - enddo - Uconst=0.0d0 - do i=1,nfrag - qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true. - & ,idummy,idummy) - Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset)) -c Calculating the derivatives of Constraint energy with respect to Q - Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i), - & qinfrag(i,iset)) -c hm1=harmonic(qfrag(i,iset),qinfrag(i,iset)) -c hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset)) -c hmnum=(hm2-hm1)/delta -c write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset), -c & qinfrag(i,iset)) -c write(iout,*) "harmonicnum frag", hmnum -c Calculating the derivatives of Q with respect to cartesian coordinates - call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true. - & ,idummy,idummy) -c write(iout,*) "dqwol " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3) -c enddo -c write(iout,*) "dxqwol " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) -c enddo -c Calculating numerical gradients of dU/dQi and dQi/dxi -c call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true. -c & ,idummy,idummy) -c The gradients of Uconst in Cs - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii) - enddo - enddo - enddo - do i=1,npair - kstart=ifrag(1,ipair(1,i,iset),iset) - kend=ifrag(2,ipair(1,i,iset),iset) - lstart=ifrag(1,ipair(2,i,iset),iset) - lend=ifrag(2,ipair(2,i,iset),iset) - qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend) - Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset)) -c Calculating dU/dQ - Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset)) -c hm1=harmonic(qpair(i),qinpair(i,iset)) -c hm2=harmonic(qpair(i)+delta,qinpair(i,iset)) -c hmnum=(hm2-hm1)/delta -c write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i), -c & qinpair(i,iset)) -c write(iout,*) "harmonicnum pair ", hmnum -c Calculating dQ/dXi - call qwolynes_prim(kstart,kend,.false. - & ,lstart,lend) -c write(iout,*) "dqwol " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3) -c enddo -c write(iout,*) "dxqwol " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) -c enddo -c Calculating numerical gradients -c call qwol_num(kstart,kend,.false. -c & ,lstart,lend) -c The gradients of Uconst in Cs - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii) - enddo - enddo - enddo -c write(iout,*) "Uconst inside subroutine ", Uconst -c Transforming the gradients from Cs to dCs for the backbone - do i=0,nres - do j=i+1,nres - do k=1,3 - dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j) - enddo - enddo - enddo -c Transforming the gradients from Cs to dCs for the side chains - do i=1,nres - do j=1,3 - dudxconst(j,i)=duxconst(j,i) - enddo - enddo -c write(iout,*) "dU/ddc backbone " -c do ii=0,nres -c write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/ddX side chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) -c enddo -c Calculating numerical gradients of dUconst/ddc and dUconst/ddx -c call dEconstrQ_num - return - end -c----------------------------------------------------------------------- - subroutine dEconstrQ_num -c Calculating numerical dUconst/ddc and dUconst/ddx - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision uzap1,uzap2 - double precision dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ -c For the backbone - do i=0,nres-1 - do j=1,3 - dUcartan(j,i)=0.0d0 - cdummy(j,i)=dc(j,i) - dc(j,i)=dc(j,i)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true. - & ,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii), - & qinpair(ii,iset)) - enddo - dc(j,i)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true. - & ,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii), - & qinpair(ii,iset)) - enddo - ducartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo -c Calculating numerical gradients for dU/ddx - do i=0,nres-1 - duxcartan(j,i)=0.0d0 - do j=1,3 - cdummy(j,i)=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true. - & ,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii), - & qinpair(ii,iset)) - enddo - dc(j,i+nres)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset), - & ifrag(2,ii,iset),.true.,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii), - & qinpair(ii,iset)) - enddo - duxcartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo - write(iout,*) "Numerical dUconst/ddc backbone " - do ii=0,nres - write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) - enddo -c write(iout,*) "Numerical dUconst/ddx side-chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) -c enddo - return - end -c--------------------------------------------------------------------------- diff --git a/source/unres/src_MD_DFA/q_measure1.F b/source/unres/src_MD_DFA/q_measure1.F deleted file mode 100644 index 9c1546d..0000000 --- a/source/unres/src_MD_DFA/q_measure1.F +++ /dev/null @@ -1,470 +0,0 @@ - double precision function qwolynes(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.MD' - integer i,j,jl,k,l,il,kl,nl,np,seg1,seg2,seg3,seg4,secseg - integer nsep /3/ - double precision dist,qm - double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM - logical lprn /.false./ - logical flag - qq = 0.0d0 - nl=0 - do i=0,nres - do j=1,3 - dqwol(j,i)=0.0d0 - dxqwol(j,i)=0.0d0 - enddo - enddo - if (lprn) then - write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4, - & " flag",flag - call flush(iout) - endif - if (flag) then - do il=seg1+nsep,seg2 - do jl=seg1,il-nsep - nl=nl+1 - if (itype(il).ne.10) then - ilnres=il+nres - else - ilnres=il - endif - if (itype(jl).ne.10) then - jlnres=jl+nres - else - jlnres=jl - endif - qqijCM = qcontrib(il,jl,ilnres,jlnres) - qq = qq+qqijCM - if (lprn) then - write (iout,*) "qqijCM",qqijCM - call flush(iout) - endif - enddo - enddo - if (lprn) then - write (iout,*) "nl",nl," qq",qq - call flush(iout) - endif - else - do il=seg1,seg2 - if((seg3-il).lt.3) then - secseg=il+3 - else - secseg=seg3 - endif - do jl=secseg,seg4 - nl=nl+1 - if (itype(il).ne.10) then - ilnres=il+nres - else - ilnres=il - endif - if (itype(jl).ne.10) then - jlnres=jl+nres - else - jlnres=jl - endif - qqijCM = qcontrib(il,jl,ilnres,jlnres) - qq = qq+qqijCM - if (lprn) then - write (iout,*) "qqijCM",qqijCM - call flush(iout) - endif - enddo - enddo - endif - qq = qq/nl - qwolynes=1.0d0-qq - do i=0,nres - do j=1,3 - dqwol(j,i)=dqwol(j,i)/nl - dxqwol(j,i)=dxqwol(j,i)/nl - enddo - enddo - return - end -c------------------------------------------------------------------- - subroutine qwol_num(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.MD' - integer seg1,seg2,seg3,seg4 - logical flag - double precision qwolan(3,0:maxres),cdummy(3,0:maxres2), - & qwolxan(3,0:maxres),q1,q2 - double precision delta /1.0d-7/ - write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4 - write(iout,*) "dQ/dc backbone " - do i=0,nres - write(iout,'(i5,3e15.5)') i, (dqwol(j,i),j=1,3) - enddo - write(iout,*) "dQ/dX side chain " - do i=1,nres - write(iout,'(i5,3e15.5)') i,(dxqwol(j,i),j=1,3) - enddo - do i=1,nres - do j=1,3 - cdummy(j,i)=c(j,i) - c(j,i)=c(j,i)-delta - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - c(j,i)=cdummy(j,i)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolan(j,i)=0.5d0*(q2-q1)/delta - c(j,i)=cdummy(j,i) -c write (iout,*) "i",i," j",j," q1",q1," a2",q2 - enddo - enddo - do i=1,nres - do j=1,3 - cdummy(j,i+nres)=c(j,i+nres) - c(j,i+nres)=c(j,i+nres)-delta - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - c(j,i+nres)=cdummy(j,i+nres)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolxan(j,i)=0.5d0*(q2-q1)/delta - c(j,i+nres)=cdummy(j,i+nres) - enddo - enddo - write(iout,*) "Numerical Q cartesian gradients backbone: " - do i=0,nres - write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3) - enddo - write(iout,*) "Numerical Q cartesian gradients side-chain: " - do i=0,nres - write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3) - enddo - return - end -c------------------------------------------------------------------------ - subroutine EconstrQ -c MD with umbrella_sampling using Wolyne's distance measure as a constraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision uzap1,uzap2,hm1,hm2,hmnum - double precision ucdelan,dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES), - & duconst(3,0:MAXRES),duxconst(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ - do i=0,nres - do j=1,3 - duconst(j,i)=0.0d0 - dudconst(j,i)=0.0d0 - duxconst(j,i)=0.0d0 - dudxconst(j,i)=0.0d0 - enddo - enddo - Uconst=0.0d0 - do i=1,nfrag - qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true. - & ,idummy,idummy) - Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset)) -c Calculating the derivatives of Constraint energy with respect to Q - Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),qinfrag(i,iset)) -c Calculating the derivatives of Q with respect to cartesian coordinates - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii) - enddo - enddo -c write (iout,*) "Calling qwol_num" -c call qwol_num(ifrag(1,i),ifrag(2,i),.true.,idummy,idummy) - enddo - do i=1,npair - kstart=ifrag(1,ipair(1,i,iset),iset) - kend=ifrag(2,ipair(1,i,iset),iset) - lstart=ifrag(1,ipair(2,i,iset),iset) - lend=ifrag(2,ipair(2,i,iset),iset) - qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend) - Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset)) -c Calculating dU/dQ - Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset)) -c Calculating dQ/dXi - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii) - enddo - enddo - enddo -c write(iout,*) "Uconst inside subroutine ", Uconst -c Transforming the gradients from Cs to dCs for the backbone - do i=0,nres - do j=i+1,nres - do k=1,3 - dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j) - enddo - enddo - enddo -c Transforming the gradients from Cs to dCs for the side chains - do i=1,nres - do j=1,3 - dudxconst(j,i)=duxconst(j,i) - enddo - enddo -c write(iout,*) "dU/dc backbone " -c do ii=0,nres -c write(iout,'(i5,3e15.5)') ii, (duconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/dX side chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/ddc backbone " -c do ii=0,nres -c write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/ddX side chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dudxconst(j,ii),j=1,3) -c enddo -c Calculating numerical gradients of dUconst/ddc and dUconst/ddx -c call dEconstrQ_num - return - end -c----------------------------------------------------------------------- - subroutine dEconstrQ_num -c Calculating numerical dUconst/ddc and dUconst/ddx - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision uzap1,uzap2 - double precision dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ -c For the backbone - do i=0,nres-1 - do j=1,3 - dUcartan(j,i)=0.0d0 - cdummy(j,i)=dc(j,i) - dc(j,i)=dc(j,i)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - dc(j,i)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - ducartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo -c Calculating numerical gradients for dU/ddx - do i=0,nres-1 - do j=1,3 - duxcartan(j,i)=0.0d0 - enddo - do j=1,3 - cdummy(j,i)=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - dc(j,i+nres)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - duxcartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo - write(iout,*) "Numerical dUconst/ddc backbone " - do ii=0,nres - write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) - enddo - write(iout,*) "Numerical dUconst/ddx side-chain " - do ii=1,nres - write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) - enddo - return - end -c--------------------------------------------------------------------------- - double precision function qcontrib(il,jl,il1,jl1) - implicit none - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.MD' - integer i,j,k,il,jl,il1,jl1,nd - double precision dist - external dist - double precision dij1,dij2,dij3,dij4,d0ij1,d0ij2,d0ij3,d0ij4,fac, - & fac1,ddave,ssij,ddqij - logical lprn /.false./ - d0ij1=dsqrt((cref(1,jl)-cref(1,il))**2+ - & (cref(2,jl)-cref(2,il))**2+ - & (cref(3,jl)-cref(3,il))**2) - dij1=dist(il,jl) - ddave=(dij1-d0ij1)**2 - nd=1 - if (jl1.ne.jl) then - d0ij2=dsqrt((cref(1,jl1)-cref(1,il))**2+ - & (cref(2,jl1)-cref(2,il))**2+ - & (cref(3,jl1)-cref(3,il))**2) - dij2=dist(il,jl1) - ddave=ddave+(dij2-d0ij2)**2 - nd=nd+1 - endif - if (il1.ne.il) then - d0ij3=dsqrt((cref(1,jl)-cref(1,il1))**2+ - & (cref(2,jl)-cref(2,il1))**2+ - & (cref(3,jl)-cref(3,il1))**2) - dij3=dist(il1,jl) - ddave=ddave+(dij3-d0ij3)**2 - nd=nd+1 - endif - if (il1.ne.il .and. jl1.ne.jl) then - d0ij4=dsqrt((cref(1,jl1)-cref(1,il1))**2+ - & (cref(2,jl1)-cref(2,il1))**2+ - & (cref(3,jl1)-cref(3,il1))**2) - dij4=dist(il1,jl1) - ddave=ddave+(dij4-d0ij4)**2 - nd=nd+1 - endif - ddave=ddave/nd - if (lprn) then - write (iout,*) "il",il," jl",jl, - & " itype",itype(il),itype(jl)," nd",nd - write (iout,*)"d0ij",d0ij1,d0ij2,d0ij3,d0ij4, - & " dij",dij1,dij2,dij3,dij4," ddave",ddave - call flush(iout) - endif -c ssij = (0.25d0*d0ij1)**2 - if (il.ne.il1 .and. jl.ne.jl1) then - ssij = 16.0d0/(d0ij1*d0ij4) - else - ssij = 16.0d0/(d0ij1*d0ij1) - endif - qcontrib = dexp(-0.5d0*ddave*ssij) -c Compute gradient - fac1 = qcontrib*ssij/nd - fac = fac1*(dij1-d0ij1)/dij1 - do k=1,3 - ddqij = (c(k,il)-c(k,jl))*fac - dqwol(k,il)=dqwol(k,il)+ddqij - dqwol(k,jl)=dqwol(k,jl)-ddqij - enddo - if (jl1.ne.jl) then - fac = fac1*(dij2-d0ij2)/dij2 - do k=1,3 - ddqij = (c(k,il)-c(k,jl1))*fac - dqwol(k,il)=dqwol(k,il)+ddqij - dxqwol(k,jl)=dxqwol(k,jl)-ddqij - enddo - endif - if (il1.ne.il) then - fac = fac1*(dij3-d0ij3)/dij3 - do k=1,3 - ddqij = (c(k,il1)-c(k,jl))*fac - dxqwol(k,il)=dxqwol(k,il)+ddqij - dqwol(k,jl)=dqwol(k,jl)-ddqij - enddo - endif - if (il1.ne.il .and. jl1.ne.jl) then - fac = fac1*(dij4-d0ij4)/dij4 - do k=1,3 - ddqij = (c(k,il1)-c(k,jl1))*fac - dxqwol(k,il)=dxqwol(k,il)+ddqij - dxqwol(k,jl)=dxqwol(k,jl)-ddqij - enddo - endif - return - end diff --git a/source/unres/src_MD_DFA/q_measure3.F b/source/unres/src_MD_DFA/q_measure3.F deleted file mode 100644 index f0a030e..0000000 --- a/source/unres/src_MD_DFA/q_measure3.F +++ /dev/null @@ -1,529 +0,0 @@ - double precision function qwolynes(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.MD' - integer i,j,jl,k,l,il,kl,nl,np,seg1,seg2,seg3,seg4,secseg - integer nsep /3/ - double precision dist,qm - double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM - logical lprn /.false./ - logical flag - qq = 0.0d0 - nl=0 - do i=0,nres - do j=1,3 - dqwol(j,i)=0.0d0 - dxqwol(j,i)=0.0d0 - enddo - enddo - if (lprn) then - write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4, - & " flag",flag - call flush(iout) - endif - if (flag) then - do il=seg1+nsep,seg2 - do jl=seg1,il-nsep - nl=nl+1 - if (itype(il).ne.10) then - ilnres=il+nres - else - ilnres=il - endif - if (itype(jl).ne.10) then - jlnres=jl+nres - else - jlnres=jl - endif - qqijCM = qcontrib(il,jl,ilnres,jlnres) - qq = qq+qqijCM - if (lprn) then - write (iout,*) "qqijCM",qqijCM - call flush(iout) - endif - enddo - enddo - if (lprn) then - write (iout,*) "nl",nl," qq",qq - call flush(iout) - endif - else - do il=seg1,seg2 - if((seg3-il).lt.3) then - secseg=il+3 - else - secseg=seg3 - endif - do jl=secseg,seg4 - nl=nl+1 - if (itype(il).ne.10) then - ilnres=il+nres - else - ilnres=il - endif - if (itype(jl).ne.10) then - jlnres=jl+nres - else - jlnres=jl - endif - qqijCM = qcontrib(il,jl,ilnres,jlnres) - qq = qq+qqijCM - if (lprn) then - write (iout,*) "qqijCM",qqijCM - call flush(iout) - endif - enddo - enddo - endif - qq = qq/nl - qwolynes=1.0d0-qq - do i=0,nres - do j=1,3 - dqwol(j,i)=dqwol(j,i)/nl - dxqwol(j,i)=dxqwol(j,i)/nl - enddo - enddo - return - end -c------------------------------------------------------------------- - subroutine qwol_num(seg1,seg2,flag,seg3,seg4) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.MD' - integer seg1,seg2,seg3,seg4 - logical flag - double precision qwolan(3,0:maxres),cdummy(3,0:maxres2), - & qwolxan(3,0:maxres),q1,q2 - double precision delta /1.0d-7/ - write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4 - write(iout,*) "dQ/dc backbone " - do i=0,nres - write(iout,'(i5,3e15.5)') i, (dqwol(j,i),j=1,3) - enddo - write(iout,*) "dQ/dX side chain " - do i=1,nres - write(iout,'(i5,3e15.5)') i,(dxqwol(j,i),j=1,3) - enddo - do i=1,nres - do j=1,3 - cdummy(j,i)=c(j,i) - c(j,i)=c(j,i)-delta - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - c(j,i)=cdummy(j,i)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolan(j,i)=0.5d0*(q2-q1)/delta - c(j,i)=cdummy(j,i) -c write (iout,*) "i",i," j",j," q1",q1," a2",q2 - enddo - enddo - do i=1,nres - do j=1,3 - cdummy(j,i+nres)=c(j,i+nres) - c(j,i+nres)=c(j,i+nres)-delta - q1=qwolynes(seg1,seg2,flag,seg3,seg4) - c(j,i+nres)=cdummy(j,i+nres)+delta - q2=qwolynes(seg1,seg2,flag,seg3,seg4) - qwolxan(j,i)=0.5d0*(q2-q1)/delta - c(j,i+nres)=cdummy(j,i+nres) - enddo - enddo - write(iout,*) "Numerical Q cartesian gradients backbone: " - do i=0,nres - write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3) - enddo - write(iout,*) "Numerical Q cartesian gradients side-chain: " - do i=0,nres - write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3) - enddo - return - end -c------------------------------------------------------------------------ - subroutine EconstrQ -c MD with umbrella_sampling using Wolyne's distance measure as a constraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision uzap1,uzap2,hm1,hm2,hmnum - double precision ucdelan,dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES), - & duconst(3,0:MAXRES),duxconst(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ - do i=0,nres - do j=1,3 - duconst(j,i)=0.0d0 - dudconst(j,i)=0.0d0 - duxconst(j,i)=0.0d0 - dudxconst(j,i)=0.0d0 - enddo - enddo - Uconst=0.0d0 - do i=1,nfrag - qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true. - & ,idummy,idummy) - Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset)) -c Calculating the derivatives of Constraint energy with respect to Q - Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),qinfrag(i,iset)) -c Calculating the derivatives of Q with respect to cartesian coordinates - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii) - enddo - enddo -c write (iout,*) "Calling qwol_num" -c call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.,idummy,idummy) - enddo -c stop - do i=1,npair - kstart=ifrag(1,ipair(1,i,iset),iset) - kend=ifrag(2,ipair(1,i,iset),iset) - lstart=ifrag(1,ipair(2,i,iset),iset) - lend=ifrag(2,ipair(2,i,iset),iset) - qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend) - Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset)) -c Calculating dU/dQ - Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset)) -c Calculating dQ/dXi - do ii=0,nres - do j=1,3 - duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii) - dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii) - enddo - enddo - enddo -c write(iout,*) "Uconst inside subroutine ", Uconst -c Transforming the gradients from Cs to dCs for the backbone - do i=0,nres - do j=i+1,nres - do k=1,3 - dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j) - enddo - enddo - enddo -c Transforming the gradients from Cs to dCs for the side chains - do i=1,nres - do j=1,3 - dudxconst(j,i)=duxconst(j,i) - enddo - enddo -c write(iout,*) "dU/dc backbone " -c do ii=0,nres -c write(iout,'(i5,3e15.5)') ii, (duconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/dX side chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/ddc backbone " -c do ii=0,nres -c write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3) -c enddo -c write(iout,*) "dU/ddX side chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dudxconst(j,ii),j=1,3) -c enddo -c Calculating numerical gradients of dUconst/ddc and dUconst/ddx -c call dEconstrQ_num - return - end -c----------------------------------------------------------------------- - subroutine dEconstrQ_num -c Calculating numerical dUconst/ddc and dUconst/ddx - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision uzap1,uzap2 - double precision dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ -c For the backbone - do i=0,nres-1 - do j=1,3 - dUcartan(j,i)=0.0d0 - cdummy(j,i)=dc(j,i) - dc(j,i)=dc(j,i)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - dc(j,i)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - ducartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo -c Calculating numerical gradients for dU/ddx - do i=0,nres-1 - do j=1,3 - duxcartan(j,i)=0.0d0 - enddo - do j=1,3 - cdummy(j,i)=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - dc(j,i+nres)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), - & .true.,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)* - & harmonic(qfrag(ii),qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)* - & harmonic(qpair(ii),qinpair(ii,iset)) - enddo - duxcartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo - write(iout,*) "Numerical dUconst/ddc backbone " - do ii=0,nres - write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) - enddo - write(iout,*) "Numerical dUconst/ddx side-chain " - do ii=1,nres - write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) - enddo - return - end -c--------------------------------------------------------------------------- - double precision function qcontrib(il,jl,il1,jl1) - implicit none - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.LOCAL' - integer i,j,k,il,jl,il1,jl1,nd,itl,jtl - double precision dist - external dist - double precision dij,dij1,d0ij,d0ij1,om1,om2,om12,om10,om20,om120 - & ,fac,fac1,ddave,ssij,ddqij,d0ii1,d0jj1,rij,eom1,eom2,eom12 - double precision u(3),v(3),er(3),er0(3),dcosom1(3),dcosom2(3), - & aux1,aux2 - double precision scalar - external scalar - logical lprn /.false./ - if (lprn) write (iout,*) "il",il," jl",jl," il1",il1," jl1",jl1 - d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ - & (cref(2,jl)-cref(2,il))**2+ - & (cref(3,jl)-cref(3,il))**2) - dij=dist(il,jl) - dij1=dist(il1,jl1) - do i=1,3 - er(i)=(c(i,jl1)-c(i,il1))/dij1 - enddo - do i=1,3 - er0(i)=cref(i,jl1)-cref(i,il1) - enddo - d0ij1=dsqrt(scalar(er0,er0)) - do i=1,3 - er0(i)=er0(i)/d0ij1 - enddo - if (il.ne.il1 .or. jl.ne.jl1) then - ddave=0.5d0*((dij-d0ij)**2+(dij1-d0ij1)**2) - nd=2 - else - ddave=(dij-d0ij)**2 - nd=1 - endif - if (il.ne.il1) then - do i=1,3 - u(i)=cref(i,il1)-cref(i,il) - enddo - d0ii1=dsqrt(scalar(u,u)) - do i=1,3 - u(i)=u(i)/d0ii1 - enddo - if (lprn) then - write (iout,*) "u",(u(i),i=1,3) - write (iout,*) "er0",(er0(i),i=1,3) - om10=scalar(er0,u) - om1=scalar(er,dc_norm(1,il1)) - write (iout,*) "om10",om10," om1",om1 - endif - else - om1=0.0d0 - om10=0.0d0 - endif - if (jl.ne.jl1) then - do i=1,3 - v(i)=cref(i,jl1)-cref(i,jl) - enddo - d0jj1=dsqrt(scalar(v,v)) - do i=1,3 - v(i)=v(i)/d0jj1 - enddo - if (lprn) then - write (iout,*) "v",(v(i),i=1,3) - write (iout,*) "er0",(er0(i),i=1,3) - om20=scalar(er,v) - om2=scalar(er,dc_norm(1,jl1)) - write (iout,*) "om20",om20," om2",om2 - endif - else - om2=0.0d0 - om20=0.0d0 - endif - if (il.ne.il1 .and. jl.ne.jl1) then - om120=scalar(u,v) - om12=scalar(dc_norm(1,il1),dc_norm(1,jl1)) - else - om12=0.0d0 - om120=0.0d0 - endif - if (lprn) then - write (iout,*) "il",il," jl",jl,itype(il),itype(jl) - write (iout,*)"d0ij",d0ij," om10",om10," om20",om20, - & " om120",om120, - & " dij",dij," om1",om1," om2",om2," om12",om12 - call flush(iout) - endif - ssij = 16.0d0/(d0ij*d0ij) - qcontrib = dexp(-0.5d0*(ddave*ssij+((om1-om10)**2 - & +(om2-om20)**2+(om12-om120)**2))) - if (lprn) write (iout,*) "ssij",ssij," qcontrib",qcontrib -c qcontrib = dexp(-0.5d0*(ddave*ssij)+(om1-om10)**2+(om2-om20)**2) -c qcontrib = dexp(-0.5d0*(ddave*ssij)) -c Compute gradient - radial component - fac1 = qcontrib*ssij/nd - fac = fac1*(dij-d0ij)/dij - do k=1,3 - ddqij = (c(k,il)-c(k,jl))*fac - dqwol(k,il)=dqwol(k,il)+ddqij - dqwol(k,jl)=dqwol(k,jl)-ddqij - enddo - if (il1.ne.il .or. jl1.ne.jl) then - fac = fac1*(dij1-d0ij1)/dij1 - do k=1,3 - ddqij = (c(k,il1)-c(k,jl1))*fac - if (il1.ne.il) then - dxqwol(k,il)=dxqwol(k,il)+ddqij - else - dqwol(k,il)=dqwol(k,il)+ddqij - endif - if (jl1.ne.jl) then - dxqwol(k,jl)=dxqwol(k,jl)-ddqij - else - dqwol(k,jl)=dqwol(k,jl)-ddqij - endif - enddo - endif -c return -c Orientational contributions - rij=1.0d0/dij1 - eom1=qcontrib*(om1-om10) - eom2=qcontrib*(om2-om20) - eom12=qcontrib*(om12-om120) - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,il1)-om1*er(k)) - dcosom2(k)=rij*(dc_norm(k,jl1)-om2*er(k)) - enddo - do k=1,3 - ddqij=eom1*dcosom1(k)+eom2*dcosom2(k) - aux1=(eom12*(dc_norm(k,jl1)-om12*dc_norm(k,il1)) - & +eom1*(er(k)-om1*dc_norm(k,il1)))*vbld_inv(il1) - aux2=(eom12*(dc_norm(k,il1)-om12*dc_norm(k,jl1)) - & +eom2*(er(k)-om2*dc_norm(k,jl1)))*vbld_inv(jl1) - dqwol(k,il)=dqwol(k,il)-ddqij-aux1 - dqwol(k,jl)=dqwol(k,jl)+ddqij-aux2 - dxqwol(k,il)=dxqwol(k,il)-ddqij+aux1 -c & +(eom12*(dc_norm(k,jl1)-om12*dc_norm(k,il1)) -c & +eom1*(er(k)-om1*dc_norm(k,il1)))*vbld_inv(il1) - dxqwol(k,jl)=dxqwol(k,jl)+ddqij+aux2 -c & +(eom12*(dc_norm(k,il1)-om12*dc_norm(k,jl1)) -c & +eom2*(er(k)-om2*dc_norm(k,jl1)))*vbld_inv(jl1) - enddo - return - end diff --git a/source/unres/src_MD_DFA/randgens.f b/source/unres/src_MD_DFA/randgens.f deleted file mode 100644 index 0daeb35..0000000 --- a/source/unres/src_MD_DFA/randgens.f +++ /dev/null @@ -1,99 +0,0 @@ -C $Date: 1994/10/04 16:19:52 $ -C $Revision: 2.1 $ -C -C -C See help for RANDOMV on the PSFSHARE disk to understand these -C subroutines. This is the VS Fortran version of this code. -C -C - SUBROUTINE VRND(VEC,N) - INTEGER A(250) - COMMON /VRANDD/ A, I, I147 - INTEGER LOOP,I,I147,VEC(N) - DO 23000 LOOP=1,N - I=I+1 - IF(.NOT.(I.GE.251))GOTO 23002 - I=1 -23002 CONTINUE - I147=I147+1 - IF(.NOT.(I147.GE.251))GOTO 23004 - I147=1 -23004 CONTINUE - A(I)=IEOR(A(I147),A(I)) - VEC(LOOP)=A(I) -23000 CONTINUE - RETURN - END -C -C - DOUBLE PRECISION FUNCTION RNDV(IDUM) - DOUBLE PRECISION RM1,RM2,R(99) - INTEGER IA1,IC1,M1, IA2,IC2,M2, IA3,IC3,M3, IDUM - SAVE - DATA IA1,IC1,M1/1279,351762,1664557/ - DATA IA2,IC2,M2/2011,221592,1048583/ - DATA IA3,IC3,M3/15551,6150,29101/ - IF(.NOT.(IDUM.LT.0))GOTO 23006 - IX1 = MOD(-IDUM,M1) - IX1 = MOD(IA1*IX1+IC1,M1) - IX2 = MOD(IX1,M2) - IX1 = MOD(IA1*IX1+IC1,M1) - IX3 = MOD(IX1,M3) - RM1 = 1./DBLE(M1) - RM2 = 1./DBLE(M2) - DO 23008 J = 1,99 - IX1 = MOD(IA1*IX1+IC1,M1) - IX2 = MOD(IA2*IX2+IC2,M2) - R(J) = (DBLE(IX1)+DBLE(IX2)*RM2)*RM1 -23008 CONTINUE -23006 CONTINUE - IX1 = MOD(IA1*IX1+IC1,M1) - IX2 = MOD(IA2*IX2+IC2,M2) - IX3 = MOD(IA3*IX3+IC3,M3) - J = 1+(99*IX3)/M3 - RNDV = R(J) - R(J) = (DBLE(IX1)+DBLE(IX2)*RM2)*RM1 - IDUM = IX1 - RETURN - END -C -C - SUBROUTINE VRNDST(SEED) - INTEGER A(250),LOOP,IDUM,SEED - DOUBLE PRECISION RNDV - COMMON /VRANDD/ A, I, I147 - I=0 - I147=103 - IDUM=SEED - DO 23010 LOOP=1,250 - A(LOOP)=INT(RNDV(IDUM)*2147483647) -23010 CONTINUE - RETURN - END -C -C - SUBROUTINE VRNDIN(IODEV) - INTEGER IODEV, A(250) - COMMON/VRANDD/ A, I, I147 - READ(IODEV) A, I, I147 - RETURN - END -C -C - SUBROUTINE VRNDOU(IODEV) -C This corresponds to VRNDOUT in the APFTN64 version - INTEGER IODEV, A(250) - COMMON/VRANDD/ A, I, I147 - WRITE(IODEV) A, I, I147 - RETURN - END - FUNCTION RNUNF(N) - INTEGER IRAN1(2000) - DATA FCTOR /2147483647.0D0/ -C We get only one random number, here! DR 9/1/92 - CALL VRND(IRAN1,1) - RNUNF= DBLE( IRAN1(1) ) / FCTOR -C****************************** -C write(6,*) 'rnunf in rnunf = ',rnunf - RETURN - END diff --git a/source/unres/src_MD_DFA/rattle.F b/source/unres/src_MD_DFA/rattle.F deleted file mode 100644 index a2e5034..0000000 --- a/source/unres/src_MD_DFA/rattle.F +++ /dev/null @@ -1,706 +0,0 @@ - subroutine rattle1 -c RATTLE algorithm for velocity Verlet - step 1, UNRES -c AL 9/24/04 - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision gginv(maxres2,maxres2), - & gdc(3,MAXRES2,MAXRES2),dC_uncor(3,MAXRES2), - & Cmat(MAXRES2,MAXRES2),x(MAXRES2),xcorr(3,MAXRES2) - common /przechowalnia/ GGinv,gdc,Cmat,nbond - integer max_rattle /5/ - logical lprn /.false./, lprn1 /.false./,not_done - double precision tol_rattle /1.0d-5/ - if (lprn) write (iout,*) "RATTLE1" - nbond=nct-nnt - do i=nnt,nct - if (itype(i).ne.10) nbond=nbond+1 - enddo -c Make a folded form of the Ginv-matrix - ind=0 - ii=0 - do i=nnt,nct-1 - ii=ii+1 - do j=1,3 - ind=ind+1 - ind1=0 - jj=0 - do k=nnt,nct-1 - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) - enddo - endif - enddo - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ii=ii+1 - do j=1,3 - ind=ind+1 - ind1=0 - jj=0 - do k=nnt,nct-1 - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) - enddo - endif - enddo - enddo - endif - enddo - if (lprn1) then - write (iout,*) "Matrix GGinv" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv) - endif - not_done=.true. - iter=0 - do while (not_done) - iter=iter+1 - if (iter.gt.max_rattle) then - write (iout,*) "Error - too many iterations in RATTLE." - stop - endif -c Calculate the matrix C = GG**(-1) dC_old o dC - ind1=0 - do i=nnt,nct-1 - ind1=ind1+1 - do j=1,3 - dC_uncor(j,ind1)=dC(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind1=ind1+1 - do j=1,3 - dC_uncor(j,ind1)=dC(j,i+nres) - enddo - endif - enddo - do i=1,nbond - ind=0 - do k=nnt,nct-1 - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres) - enddo - endif - enddo - enddo -c Calculate deviations from standard virtual-bond lengths - ind=0 - do i=nnt,nct-1 - ind=ind+1 - x(ind)=vbld(i+1)**2-vbl**2 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 - endif - enddo - if (lprn) then - write (iout,*) "Coordinates and violations" - do i=1,nbond - write(iout,'(i5,3f10.5,5x,e15.5)') - & i,(dC_uncor(j,i),j=1,3),x(i) - enddo - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i+nres,ind,(d_t_new(j,i+nres),j=1,3), - & scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) - endif - enddo -c write (iout,*) "gdc" -c do i=1,nbond -c write (iout,*) "i",i -c do j=1,nbond -c write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) -c enddo -c enddo - endif - xmax=dabs(x(1)) - do i=2,nbond - if (dabs(x(i)).gt.xmax) then - xmax=dabs(x(i)) - endif - enddo - if (xmax.lt.tol_rattle) then - not_done=.false. - goto 100 - endif -c Calculate the matrix of the system of equations - do i=1,nbond - do j=1,nbond - Cmat(i,j)=0.0d0 - do k=1,3 - Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Cmat" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) - endif - call gauss(Cmat,X,MAXRES2,nbond,1,*10) -c Add constraint term to positions - ind=0 - do i=nnt,nct-1 - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - xx=0.5d0*xx - dC(j,i)=dC(j,i)-xx - d_t_new(j,i)=d_t_new(j,i)-xx/d_time - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - xx=0.5d0*xx - dC(j,i+nres)=dC(j,i+nres)-xx - d_t_new(j,i+nres)=d_t_new(j,i+nres)-xx/d_time - enddo - endif - enddo -c Rebuild the chain using the new coordinates - call chainbuild_cart - if (lprn) then - write (iout,*) "New coordinates, Lagrange multipliers,", - & " and differences between actual and standard bond lengths" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - xx=vbld(i+1)**2-vbl**2 - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i),j=1,3),x(ind),xx - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - xx=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i+nres),j=1,3),x(ind),xx - endif - enddo - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i+nres,ind,(d_t_new(j,i+nres),j=1,3), - & scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) - endif - enddo - endif - enddo - 100 continue - return - 10 write (iout,*) "Error - singularity in solving the system", - & " of equations for Lagrange multipliers." - stop - end -c------------------------------------------------------------------------------ - subroutine rattle2 -c RATTLE algorithm for velocity Verlet - step 2, UNRES -c AL 9/24/04 - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision gginv(maxres2,maxres2), - & gdc(3,MAXRES2,MAXRES2),dC_uncor(3,MAXRES2), - & Cmat(MAXRES2,MAXRES2),x(MAXRES2) - common /przechowalnia/ GGinv,gdc,Cmat,nbond - integer max_rattle /5/ - logical lprn /.false./, lprn1 /.false./,not_done - double precision tol_rattle /1.0d-5/ - if (lprn) write (iout,*) "RATTLE2" - if (lprn) write (iout,*) "Velocity correction" -c Calculate the matrix G dC - do i=1,nbond - ind=0 - do k=nnt,nct-1 - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC(j,k) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC(j,k+nres) - enddo - endif - enddo - enddo -c if (lprn) then -c write (iout,*) "gdc" -c do i=1,nbond -c write (iout,*) "i",i -c do j=1,nbond -c write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) -c enddo -c enddo -c endif -c Calculate the matrix of the system of equations - ind=0 - do i=nnt,nct-1 - ind=ind+1 - do j=1,nbond - Cmat(ind,j)=0.0d0 - do k=1,3 - Cmat(ind,j)=Cmat(ind,j)+dC(k,i)*gdc(k,ind,j) - enddo - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - do j=1,nbond - Cmat(ind,j)=0.0d0 - do k=1,3 - Cmat(ind,j)=Cmat(ind,j)+dC(k,i+nres)*gdc(k,ind,j) - enddo - enddo - endif - enddo -c Calculate the scalar product dC o d_t_new - ind=0 - do i=nnt,nct-1 - ind=ind+1 - x(ind)=scalar(d_t(1,i),dC(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - x(ind)=scalar(d_t(1,i+nres),dC(1,i+nres)) - endif - enddo - if (lprn) then - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i,ind,(d_t(j,i),j=1,3),x(ind) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind) - endif - enddo - endif - xmax=dabs(x(1)) - do i=2,nbond - if (dabs(x(i)).gt.xmax) then - xmax=dabs(x(i)) - endif - enddo - if (xmax.lt.tol_rattle) then - not_done=.false. - goto 100 - endif - if (lprn1) then - write (iout,*) "Matrix Cmat" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) - endif - call gauss(Cmat,X,MAXRES2,nbond,1,*10) -c Add constraint term to velocities - ind=0 - do i=nnt,nct-1 - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - d_t(j,i)=d_t(j,i)-xx - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - d_t(j,i+nres)=d_t(j,i+nres)-xx - enddo - endif - enddo - if (lprn) then - write (iout,*) - & "New velocities, Lagrange multipliers violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - if (lprn) write (iout,'(2i5,3f10.5,5x,2e15.5)') - & i,ind,(d_t(j,i),j=1,3),x(ind),scalar(d_t(1,i),dC(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,2e15.5)') - & i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind), - & scalar(d_t(1,i+nres),dC(1,i+nres)) - endif - enddo - endif - 100 continue - return - 10 write (iout,*) "Error - singularity in solving the system", - & " of equations for Lagrange multipliers." - stop - end -c------------------------------------------------------------------------------ - subroutine rattle_brown -c RATTLE/LINCS algorithm for Brownian dynamics, UNRES -c AL 9/24/04 - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - double precision gginv(maxres2,maxres2), - & gdc(3,MAXRES2,MAXRES2),dC_uncor(3,MAXRES2), - & Cmat(MAXRES2,MAXRES2),x(MAXRES2) - common /przechowalnia/ GGinv,gdc,Cmat,nbond - integer max_rattle /5/ - logical lprn /.true./, lprn1 /.true./,not_done - double precision tol_rattle /1.0d-5/ - if (lprn) write (iout,*) "RATTLE_BROWN" - nbond=nct-nnt - do i=nnt,nct - if (itype(i).ne.10) nbond=nbond+1 - enddo -c Make a folded form of the Ginv-matrix - ind=0 - ii=0 - do i=nnt,nct-1 - ii=ii+1 - do j=1,3 - ind=ind+1 - ind1=0 - jj=0 - do k=nnt,nct-1 - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) - enddo - endif - enddo - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ii=ii+1 - do j=1,3 - ind=ind+1 - ind1=0 - jj=0 - do k=nnt,nct-1 - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - jj=jj+1 - do l=1,3 - ind1=ind1+1 - if (j.eq.1 .and. l.eq.1)GGinv(ii,jj)=fricmat(ind,ind1) - enddo - endif - enddo - enddo - endif - enddo - if (lprn1) then - write (iout,*) "Matrix GGinv" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv) - endif - not_done=.true. - iter=0 - do while (not_done) - iter=iter+1 - if (iter.gt.max_rattle) then - write (iout,*) "Error - too many iterations in RATTLE." - stop - endif -c Calculate the matrix C = GG**(-1) dC_old o dC - ind1=0 - do i=nnt,nct-1 - ind1=ind1+1 - do j=1,3 - dC_uncor(j,ind1)=dC(j,i) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind1=ind1+1 - do j=1,3 - dC_uncor(j,ind1)=dC(j,i+nres) - enddo - endif - enddo - do i=1,nbond - ind=0 - do k=nnt,nct-1 - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k) - enddo - enddo - do k=nnt,nct - if (itype(k).ne.10) then - ind=ind+1 - do j=1,3 - gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres) - enddo - endif - enddo - enddo -c Calculate deviations from standard virtual-bond lengths - ind=0 - do i=nnt,nct-1 - ind=ind+1 - x(ind)=vbld(i+1)**2-vbl**2 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 - endif - enddo - if (lprn) then - write (iout,*) "Coordinates and violations" - do i=1,nbond - write(iout,'(i5,3f10.5,5x,e15.5)') - & i,(dC_uncor(j,i),j=1,3),x(i) - enddo - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i,ind,(d_t(j,i),j=1,3),scalar(d_t(1,i),dC_old(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i+nres,ind,(d_t(j,i+nres),j=1,3), - & scalar(d_t(1,i+nres),dC_old(1,i+nres)) - endif - enddo - write (iout,*) "gdc" - do i=1,nbond - write (iout,*) "i",i - do j=1,nbond - write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) - enddo - enddo - endif - xmax=dabs(x(1)) - do i=2,nbond - if (dabs(x(i)).gt.xmax) then - xmax=dabs(x(i)) - endif - enddo - if (xmax.lt.tol_rattle) then - not_done=.false. - goto 100 - endif -c Calculate the matrix of the system of equations - do i=1,nbond - do j=1,nbond - Cmat(i,j)=0.0d0 - do k=1,3 - Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j) - enddo - enddo - enddo - if (lprn1) then - write (iout,*) "Matrix Cmat" - call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) - endif - call gauss(Cmat,X,MAXRES2,nbond,1,*10) -c Add constraint term to positions - ind=0 - do i=nnt,nct-1 - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - xx=-0.5d0*xx - d_t(j,i)=d_t(j,i)+xx/d_time - dC(j,i)=dC(j,i)+xx - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - do j=1,3 - xx=0.0d0 - do ii=1,nbond - xx = xx+x(ii)*gdc(j,ind,ii) - enddo - xx=-0.5d0*xx - d_t(j,i+nres)=d_t(j,i+nres)+xx/d_time - dC(j,i+nres)=dC(j,i+nres)+xx - enddo - endif - enddo -c Rebuild the chain using the new coordinates - call chainbuild_cart - if (lprn) then - write (iout,*) "New coordinates, Lagrange multipliers,", - & " and differences between actual and standard bond lengths" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - xx=vbld(i+1)**2-vbl**2 - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i),j=1,3),x(ind),xx - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - xx=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 - write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') - & i,(dC(j,i+nres),j=1,3),x(ind),xx - endif - enddo - write (iout,*) "Velocities and violations" - ind=0 - do i=nnt,nct-1 - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - ind=ind+1 - write (iout,'(2i5,3f10.5,5x,e15.5)') - & i+nres,ind,(d_t_new(j,i+nres),j=1,3), - & scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) - endif - enddo - endif - enddo - 100 continue - return - 10 write (iout,*) "Error - singularity in solving the system", - & " of equations for Lagrange multipliers." - stop - end diff --git a/source/unres/src_MD_DFA/readpdb.F b/source/unres/src_MD_DFA/readpdb.F deleted file mode 100644 index 97e9aa8..0000000 --- a/source/unres/src_MD_DFA/readpdb.F +++ /dev/null @@ -1,417 +0,0 @@ - subroutine readpdb -C Read the PDB file and convert the peptide geometry into virtual-chain -C geometry. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.NAMES' - include 'COMMON.CONTROL' - include 'COMMON.DISTFIT' - include 'COMMON.SETUP' - character*3 seq,atom,res - character*80 card - dimension sccor(3,20) - integer rescode - ibeg=1 - lsecondary=.false. - nhfrag=0 - nbfrag=0 - do i=1,10000 - read (ipdbin,'(a80)',end=10) card - if (card(:5).eq.'HELIX') then - nhfrag=nhfrag+1 - lsecondary=.true. - read(card(22:25),*) hfrag(1,nhfrag) - read(card(34:37),*) hfrag(2,nhfrag) - endif - if (card(:5).eq.'SHEET') then - nbfrag=nbfrag+1 - lsecondary=.true. - read(card(24:26),*) bfrag(1,nbfrag) - read(card(35:37),*) bfrag(2,nbfrag) -crc---------------------------------------- -crc to be corrected !!! - bfrag(3,nbfrag)=bfrag(1,nbfrag) - bfrag(4,nbfrag)=bfrag(2,nbfrag) -crc---------------------------------------- - endif - if (card(:3).eq.'END' .or. card(:3).eq.'TER') goto 10 -C Fish out the ATOM cards. - if (index(card(1:4),'ATOM').gt.0) then - read (card(14:16),'(a3)') atom - if (atom.eq.'CA' .or. atom.eq.'CH3') then -C Calculate the CM of the preceding residue. - if (ibeg.eq.0) then - if (unres_pdb) then - do j=1,3 - dc(j,ires+nres)=sccor(j,iii) - enddo - else - call sccenter(ires,iii,sccor) - endif - endif -C Start new residue. - read (card(24:26),*) ires - read (card(18:20),'(a3)') res - if (ibeg.eq.1) then - ishift=ires-1 - if (res.ne.'GLY' .and. res.ne. 'ACE') then - ishift=ishift-1 - itype(1)=21 - endif - ibeg=0 - endif - ires=ires-ishift - if (res.eq.'ACE') then - ity=10 - else - itype(ires)=rescode(ires,res,0) - endif - read(card(31:54),'(3f8.3)') (c(j,ires),j=1,3) -c if(me.eq.king.or..not.out1file) -c & write (iout,'(2i3,2x,a,3f8.3)') -c & ires,itype(ires),res,(c(j,ires),j=1,3) - iii=1 - do j=1,3 - sccor(j,iii)=c(j,ires) - enddo - else if (atom.ne.'O '.and.atom(1:1).ne.'H' .and. - & atom.ne.'N ' .and. atom.ne.'C ') then - iii=iii+1 - read(card(31:54),'(3f8.3)') (sccor(j,iii),j=1,3) - endif - endif - enddo - 10 if(me.eq.king.or..not.out1file) - & write (iout,'(a,i5)') ' Nres: ',ires -C Calculate the CM of the last side chain. - if (unres_pdb) then - do j=1,3 - dc(j,ires+nres)=sccor(j,iii) - enddo - else - call sccenter(ires,iii,sccor) - endif - nres=ires - nsup=nres - nstart_sup=1 - if (itype(nres).ne.10) then - nres=nres+1 - itype(nres)=21 - if (unres_pdb) then - c(1,nres)=c(1,nres-1)+3.8d0 - c(2,nres)=c(2,nres-1) - c(3,nres)=c(3,nres-1) - else - do j=1,3 - dcj=c(j,nres-2)-c(j,nres-3) - c(j,nres)=c(j,nres-1)+dcj - c(j,2*nres)=c(j,nres) - enddo - endif - endif - do i=2,nres-1 - do j=1,3 - c(j,i+nres)=dc(j,i) - enddo - enddo - do j=1,3 - c(j,nres+1)=c(j,1) - c(j,2*nres)=c(j,nres) - enddo - if (itype(1).eq.21) then - nsup=nsup-1 - nstart_sup=2 - if (unres_pdb) then - c(1,1)=c(1,2)-3.8d0 - c(2,1)=c(2,2) - c(3,1)=c(3,2) - else - do j=1,3 - dcj=c(j,4)-c(j,3) - c(j,1)=c(j,2)-dcj - c(j,nres+1)=c(j,1) - enddo - endif - endif -C Calculate internal coordinates. - if(me.eq.king.or..not.out1file)then - write (iout,'(a)') - & "Backbone and SC coordinates as read from the PDB" - do ires=1,nres - write (iout,'(2i3,2x,a,3f8.3,5x,3f8.3)') - & ires,itype(ires),restyp(itype(ires)),(c(j,ires),j=1,3), - & (c(j,nres+ires),j=1,3) - enddo - endif - call int_from_cart(.true.,.false.) - call sc_loc_geom(.false.) - do i=1,nres - thetaref(i)=theta(i) - phiref(i)=phi(i) - enddo - do i=1,nres-1 - do j=1,3 - dc(j,i)=c(j,i+1)-c(j,i) - dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) - enddo - enddo - do i=2,nres-1 - do j=1,3 - dc(j,i+nres)=c(j,i+nres)-c(j,i) - dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) - enddo -c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3), -c & vbld_inv(i+nres) - enddo -c call chainbuild -C Copy the coordinates to reference coordinates - do i=1,2*nres - do j=1,3 - cref(j,i)=c(j,i) - enddo - enddo - - - do j=1,nbfrag - do i=1,4 - bfrag(i,j)=bfrag(i,j)-ishift - enddo - enddo - - do j=1,nhfrag - do i=1,2 - hfrag(i,j)=hfrag(i,j)-ishift - enddo - enddo - - return - end -c--------------------------------------------------------------------------- - subroutine int_from_cart(lside,lprn) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.NAMES' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - character*3 seq,atom,res - character*80 card - dimension sccor(3,20) - integer rescode - logical lside,lprn - if(me.eq.king.or..not.out1file)then - if (lprn) then - write (iout,'(/a)') - & 'Internal coordinates calculated from crystal structure.' - if (lside) then - write (iout,'(8a)') ' Res ',' dvb',' Theta', - & ' Gamma',' Dsc_id',' Dsc',' Alpha', - & ' Beta ' - else - write (iout,'(4a)') ' Res ',' dvb',' Theta', - & ' Gamma' - endif - endif - endif - do i=1,nres-1 - iti=itype(i) - if (dist(i,i+1).lt.2.0D0 .or. dist(i,i+1).gt.5.0D0) then - write (iout,'(a,i4)') 'Bad Cartesians for residue',i -ctest stop - endif - vbld(i+1)=dist(i,i+1) - vbld_inv(i+1)=1.0d0/vbld(i+1) - if (i.gt.1) theta(i+1)=alpha(i-1,i,i+1) - if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) - enddo -c if (unres_pdb) then -c if (itype(1).eq.21) then -c theta(3)=90.0d0*deg2rad -c phi(4)=180.0d0*deg2rad -c vbld(2)=3.8d0 -c vbld_inv(2)=1.0d0/vbld(2) -c endif -c if (itype(nres).eq.21) then -c theta(nres)=90.0d0*deg2rad -c phi(nres)=180.0d0*deg2rad -c vbld(nres)=3.8d0 -c vbld_inv(nres)=1.0d0/vbld(2) -c endif -c endif - if (lside) then - do i=2,nres-1 - do j=1,3 - c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))*vbld_inv(i) - & +(c(j,i+1)-c(j,i))*vbld_inv(i+1)) - enddo - iti=itype(i) - di=dist(i,nres+i) -C 10/03/12 Adam: Correction for zero SC-SC bond length - if (itype(i).ne.10 .and. itype(i).ne.21. and. di.eq.0.0d0) - & di=dsc(itype(i)) - vbld(i+nres)=di - if (itype(i).ne.10) then - vbld_inv(i+nres)=1.0d0/di - else - vbld_inv(i+nres)=0.0d0 - endif - if (iti.ne.10) then - alph(i)=alpha(nres+i,i,maxres2) - omeg(i)=beta(nres+i,i,maxres2,i+1) - endif - if(me.eq.king.or..not.out1file)then - if (lprn) - & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,vbld(i), - & rad2deg*theta(i),rad2deg*phi(i),dsc(iti),vbld(nres+i), - & rad2deg*alph(i),rad2deg*omeg(i) - endif - enddo - else if (lprn) then - do i=2,nres - iti=itype(i) - if(me.eq.king.or..not.out1file) - & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1), - & rad2deg*theta(i),rad2deg*phi(i) - enddo - endif - return - end -c------------------------------------------------------------------------------- - subroutine sc_loc_geom(lprn) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.NAMES' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - double precision x_prime(3),y_prime(3),z_prime(3) - logical lprn - do i=1,nres-1 - do j=1,3 - dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i)) - enddo - enddo - do i=2,nres-1 - if (itype(i).ne.10) then - do j=1,3 - dc_norm(j,i+nres)=vbld_inv(i+nres)*(c(j,i+nres)-c(j,i)) - enddo - else - do j=1,3 - dc_norm(j,i+nres)=0.0d0 - enddo - endif - enddo - do i=2,nres-1 - costtab(i+1) =dcos(theta(i+1)) - sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) - cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) - sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) - cosfac2=0.5d0/(1.0d0+costtab(i+1)) - cosfac=dsqrt(cosfac2) - sinfac2=0.5d0/(1.0d0-costtab(i+1)) - sinfac=dsqrt(sinfac2) - it=itype(i) - if (it.ne.10) then -c -C Compute the axes of tghe local cartesian coordinates system; store in -c x_prime, y_prime and z_prime -c - do j=1,3 - x_prime(j) = 0.00 - y_prime(j) = 0.00 - z_prime(j) = 0.00 - enddo - do j = 1,3 - x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac - y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac - enddo - call vecpr(x_prime,y_prime,z_prime) -c -C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), -C to local coordinate system. Store in xx, yy, zz. -c - xx=0.0d0 - yy=0.0d0 - zz=0.0d0 - do j = 1,3 - xx = xx + x_prime(j)*dc_norm(j,i+nres) - yy = yy + y_prime(j)*dc_norm(j,i+nres) - zz = zz + z_prime(j)*dc_norm(j,i+nres) - enddo - - xxref(i)=xx - yyref(i)=yy - zzref(i)=zz - else - xxref(i)=0.0d0 - yyref(i)=0.0d0 - zzref(i)=0.0d0 - endif - enddo - if (lprn) then - do i=2,nres - iti=itype(i) - if(me.eq.king.or..not.out1file) - & write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i), - & yyref(i),zzref(i) - enddo - endif - return - end -c--------------------------------------------------------------------------- - subroutine sccenter(ires,nscat,sccor) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - dimension sccor(3,20) - do j=1,3 - sccmj=0.0D0 - do i=1,nscat - sccmj=sccmj+sccor(j,i) - enddo - dc(j,ires)=sccmj/nscat - enddo - return - end -c--------------------------------------------------------------------------- - subroutine bond_regular - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CALC' - include 'COMMON.INTERACT' - include 'COMMON.CHAIN' - do i=1,nres-1 - vbld(i+1)=vbl - vbld_inv(i+1)=1.0d0/vbld(i+1) - vbld(i+1+nres)=dsc(itype(i+1)) - vbld_inv(i+1+nres)=dsc_inv(itype(i+1)) -c print *,vbld(i+1),vbld(i+1+nres) - enddo - return - end - diff --git a/source/unres/src_MD_DFA/readrtns.F b/source/unres/src_MD_DFA/readrtns.F deleted file mode 100644 index 5f2ada2..0000000 --- a/source/unres/src_MD_DFA/readrtns.F +++ /dev/null @@ -1,2702 +0,0 @@ - subroutine readrtns - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - include 'COMMON.IOUNITS' - logical file_exist -C Read force-field parameters except weights - call parmread -C Read job setup parameters - call read_control -C Read control parameters for energy minimzation if required - if (minim) call read_minim -C Read MCM control parameters if required - if (modecalc.eq.3 .or. modecalc.eq.6) call mcmread -C Read MD control parameters if reqjuired - if (modecalc.eq.12) call read_MDpar -C Read MREMD control parameters if required - if (modecalc.eq.14) then - call read_MDpar - call read_REMDpar - endif -C Read MUCA control parameters if required - if (lmuca) call read_muca -C Read CSA control parameters if required (from fort.40 if exists -C otherwise from general input file) -csa if (modecalc.eq.8) then -csa inquire (file="fort.40",exist=file_exist) -csa if (.not.file_exist) call csaread -csa endif -cfmc if (modecalc.eq.10) call mcmfread -C Read molecule information, molecule geometry, energy-term weights, and -C restraints if requested - call molread -C Print restraint information -#ifdef MPI - if (.not. out1file .or. me.eq.king) then -#endif - if (nhpb.gt.nss) - &write (iout,'(a,i5,a)') "The following",nhpb-nss, - & " distance constraints have been imposed" - do i=nss+1,nhpb - write (iout,'(3i6,i2,3f10.5)') i-nss,ihpb(i),jhpb(i), - & ibecarb(i),dhpb(i),dhpb1(i),forcon(i) - enddo -#ifdef MPI - endif -#endif -c print *,"Processor",myrank," leaves READRTNS" - return - end -C------------------------------------------------------------------------------- - subroutine read_control -C -C Read contorl data -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MP - include 'mpif.h' - logical OKRandom, prng_restart - real*8 r1 -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.THREAD' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.MCM' - include 'COMMON.MAP' - include 'COMMON.HEADER' -csa include 'COMMON.CSA' - include 'COMMON.CHAIN' - include 'COMMON.MUCA' - include 'COMMON.MD' - include 'COMMON.FFIELD' - include 'COMMON.SETUP' - COMMON /MACHSW/ KDIAG,ICORFL,IXDR - character*8 diagmeth(0:3) /'Library','EVVRSP','Givens','Jacobi'/ - character*80 ucase - character*320 controlcard - - nglob_csa=0 - eglob_csa=1d99 - nmin_csa=0 - read (INP,'(a)') titel - call card_concat(controlcard) -c out1file=index(controlcard,'OUT1FILE').gt.0 .or. fg_rank.gt.0 -c print *,"Processor",me," fg_rank",fg_rank," out1file",out1file - call reada(controlcard,'SEED',seed,0.0D0) - call random_init(seed) -C Set up the time limit (caution! The time must be input in minutes!) - read_cart=index(controlcard,'READ_CART').gt.0 - call readi(controlcard,'CONSTR_DIST',constr_dist,0) - call reada(controlcard,'TIMLIM',timlim,960.0D0) ! default 16 hours - unres_pdb = index(controlcard,'UNRES_PDB') .gt. 0 - call reada(controlcard,'SAFETY',safety,30.0D0) ! default 30 minutes - call reada(controlcard,'RMSDBC',rmsdbc,3.0D0) - call reada(controlcard,'RMSDBC1',rmsdbc1,0.5D0) - call reada(controlcard,'RMSDBC1MAX',rmsdbc1max,1.5D0) - call reada(controlcard,'RMSDBCM',rmsdbcm,3.0D0) - call reada(controlcard,'DRMS',drms,0.1D0) - if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then - write (iout,'(a,f10.1)')'RMSDBC = ',rmsdbc - write (iout,'(a,f10.1)')'RMSDBC1 = ',rmsdbc1 - write (iout,'(a,f10.1)')'RMSDBC1MAX = ',rmsdbc1max - write (iout,'(a,f10.1)')'DRMS = ',drms - write (iout,'(a,f10.1)')'RMSDBCM = ',rmsdbcm - write (iout,'(a,f10.1)') 'Time limit (min):',timlim - endif - call readi(controlcard,'NZ_START',nz_start,0) - call readi(controlcard,'NZ_END',nz_end,0) - call readi(controlcard,'IZ_SC',iz_sc,0) - timlim=60.0D0*timlim - safety = 60.0d0*safety - timem=timlim - modecalc=0 - call reada(controlcard,"T_BATH",t_bath,300.0d0) - minim=(index(controlcard,'MINIMIZE').gt.0) - dccart=(index(controlcard,'CART').gt.0) - overlapsc=(index(controlcard,'OVERLAP').gt.0) - overlapsc=.not.overlapsc - searchsc=(index(controlcard,'NOSEARCHSC').gt.0) - searchsc=.not.searchsc - sideadd=(index(controlcard,'SIDEADD').gt.0) - energy_dec=(index(controlcard,'ENERGY_DEC').gt.0) - outpdb=(index(controlcard,'PDBOUT').gt.0) - outmol2=(index(controlcard,'MOL2OUT').gt.0) - pdbref=(index(controlcard,'PDBREF').gt.0) - refstr=pdbref .or. (index(controlcard,'REFSTR').gt.0) - indpdb=index(controlcard,'PDBSTART') - extconf=(index(controlcard,'EXTCONF').gt.0) - call readi(controlcard,'IPRINT',iprint,0) - call readi(controlcard,'MAXGEN',maxgen,10000) - call readi(controlcard,'MAXOVERLAP',maxoverlap,1000) - call readi(controlcard,"KDIAG",kdiag,0) - call readi(controlcard,"RESCALE_MODE",rescale_mode,2) - if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) - & write (iout,*) "RESCALE_MODE",rescale_mode - split_ene=index(controlcard,'SPLIT_ENE').gt.0 - if (index(controlcard,'REGULAR').gt.0.0D0) then - call reada(controlcard,'WEIDIS',weidis,0.1D0) - modecalc=1 - refstr=.true. - endif - if (index(controlcard,'CHECKGRAD').gt.0) then - modecalc=5 - if (index(controlcard,'CART').gt.0) then - icheckgrad=1 - elseif (index(controlcard,'CARINT').gt.0) then - icheckgrad=2 - else - icheckgrad=3 - endif - elseif (index(controlcard,'THREAD').gt.0) then - modecalc=2 - call readi(controlcard,'THREAD',nthread,0) - if (nthread.gt.0) then - call reada(controlcard,'WEIDIS',weidis,0.1D0) - else - if (fg_rank.eq.0) - & write (iout,'(a)')'A number has to follow the THREAD keyword.' - stop 'Error termination in Read_Control.' - endif - else if (index(controlcard,'MCMA').gt.0) then - modecalc=3 - else if (index(controlcard,'MCEE').gt.0) then - modecalc=6 - else if (index(controlcard,'MULTCONF').gt.0) then - modecalc=4 - else if (index(controlcard,'MAP').gt.0) then - modecalc=7 - call readi(controlcard,'MAP',nmap,0) - else if (index(controlcard,'CSA').gt.0) then - write(*,*) "CSA not supported in this version" - stop -csa modecalc=8 -crc else if (index(controlcard,'ZSCORE').gt.0) then -crc -crc ZSCORE is rm from UNRES, modecalc=9 is available -crc -crc modecalc=9 -cfcm else if (index(controlcard,'MCMF').gt.0) then -cfmc modecalc=10 - else if (index(controlcard,'SOFTREG').gt.0) then - modecalc=11 - else if (index(controlcard,'CHECK_BOND').gt.0) then - modecalc=-1 - else if (index(controlcard,'TEST').gt.0) then - modecalc=-2 - else if (index(controlcard,'MD').gt.0) then - modecalc=12 - else if (index(controlcard,'RE ').gt.0) then - modecalc=14 - endif - - lmuca=index(controlcard,'MUCA').gt.0 - call readi(controlcard,'MUCADYN',mucadyn,0) - call readi(controlcard,'MUCASMOOTH',muca_smooth,0) - if (lmuca .and. (me.eq.king .or. .not.out1file )) - & then - write (iout,*) 'MUCADYN=',mucadyn - write (iout,*) 'MUCASMOOTH=',muca_smooth - endif - - iscode=index(controlcard,'ONE_LETTER') - indphi=index(controlcard,'PHI') - indback=index(controlcard,'BACK') - iranconf=index(controlcard,'RAND_CONF') - i2ndstr=index(controlcard,'USE_SEC_PRED') - gradout=index(controlcard,'GRADOUT').gt.0 - gnorm_check=index(controlcard,'GNORM_CHECK').gt.0 - - if(me.eq.king.or..not.out1file) - & write (iout,'(2a)') diagmeth(kdiag), - & ' routine used to diagonalize matrices.' - return - end -c-------------------------------------------------------------------------- - subroutine read_REMDpar -C -C Read REMD settings -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.REMD' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - character*80 ucase - character*320 controlcard - character*3200 controlcard1 - integer iremd_m_total - - if(me.eq.king.or..not.out1file) - & write (iout,*) "REMD setup" - - call card_concat(controlcard) - call readi(controlcard,"NREP",nrep,3) - call readi(controlcard,"NSTEX",nstex,1000) - call reada(controlcard,"RETMIN",retmin,10.0d0) - call reada(controlcard,"RETMAX",retmax,1000.0d0) - mremdsync=(index(controlcard,'SYNC').gt.0) - call readi(controlcard,"NSYN",i_sync_step,100) - restart1file=(index(controlcard,'REST1FILE').gt.0) - traj1file=(index(controlcard,'TRAJ1FILE').gt.0) - call readi(controlcard,"TRAJCACHE",max_cache_traj_use,1) - if(max_cache_traj_use.gt.max_cache_traj) - & max_cache_traj_use=max_cache_traj - if(me.eq.king.or..not.out1file) then -cd if (traj1file) then -crc caching is in testing - NTWX is not ignored -cd write (iout,*) "NTWX value is ignored" -cd write (iout,*) " trajectory is stored to one file by master" -cd write (iout,*) " before exchange at NSTEX intervals" -cd endif - write (iout,*) "NREP= ",nrep - write (iout,*) "NSTEX= ",nstex - write (iout,*) "SYNC= ",mremdsync - write (iout,*) "NSYN= ",i_sync_step - write (iout,*) "TRAJCACHE= ",max_cache_traj_use - endif - - t_exchange_only=(index(controlcard,'TONLY').gt.0) - call readi(controlcard,"HREMD",hremd,0) - if((me.eq.king.or..not.out1file).and.hremd.gt.0) then - write (iout,*) "Hamiltonian REMD with ",hremd," sets of weights" - endif - if(usampl.and.hremd.gt.0) then - write (iout,'(//a)') - & "========== ERROR: USAMPL and HREMD cannot be used together" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop - endif - - - remd_tlist=.false. - if (index(controlcard,'TLIST').gt.0) then - remd_tlist=.true. - call card_concat(controlcard1) - read(controlcard1,*) (remd_t(i),i=1,nrep) - if(me.eq.king.or..not.out1file) - & write (iout,*)'tlist',(remd_t(i),i=1,nrep) - endif - remd_mlist=.false. - if (index(controlcard,'MLIST').gt.0) then - remd_mlist=.true. - call card_concat(controlcard1) - read(controlcard1,*) (remd_m(i),i=1,nrep) - if(me.eq.king.or..not.out1file) then - write (iout,*)'mlist',(remd_m(i),i=1,nrep) - iremd_m_total=0 - do i=1,nrep - iremd_m_total=iremd_m_total+remd_m(i) - enddo - if(hremd.gt.1)then - write (iout,*) 'Total number of replicas ', - & iremd_m_total*hremd - else - write (iout,*) 'Total number of replicas ',iremd_m_total - endif - endif - endif - if(me.eq.king.or..not.out1file) - & write (iout,'(/30(1h=),a,29(1h=)/)') " End of REMD run setup " - return - end -c-------------------------------------------------------------------------- - subroutine read_MDpar -C -C Read MD settings -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.SPLITELE' - character*80 ucase - character*320 controlcard - - call card_concat(controlcard) - call readi(controlcard,"NSTEP",n_timestep,1000000) - call readi(controlcard,"NTWE",ntwe,100) - call readi(controlcard,"NTWX",ntwx,1000) - call reada(controlcard,"DT",d_time,1.0d-1) - call reada(controlcard,"DVMAX",dvmax,2.0d1) - call reada(controlcard,"DAMAX",damax,1.0d1) - call reada(controlcard,"EDRIFTMAX",edriftmax,1.0d+1) - call readi(controlcard,"LANG",lang,0) - RESPA = index(controlcard,"RESPA") .gt. 0 - call readi(controlcard,"NTIME_SPLIT",ntime_split,1) - ntime_split0=ntime_split - call readi(controlcard,"MAXTIME_SPLIT",maxtime_split,64) - ntime_split0=ntime_split - call reada(controlcard,"R_CUT",r_cut,2.0d0) - call reada(controlcard,"LAMBDA",rlamb,0.3d0) - rest = index(controlcard,"REST").gt.0 - tbf = index(controlcard,"TBF").gt.0 - call readi(controlcard,"HMC",hmc,0) - tnp = index(controlcard,"NOSEPOINCARE99").gt.0 - tnp1 = index(controlcard,"NOSEPOINCARE01").gt.0 - tnh = index(controlcard,"NOSEHOOVER96").gt.0 - if (RESPA.and.tnh)then - xiresp = index(controlcard,"XIRESP").gt.0 - endif - call reada(controlcard,"Q_NP",Q_np,0.1d0) - usampl = index(controlcard,"USAMPL").gt.0 - - mdpdb = index(controlcard,"MDPDB").gt.0 - call reada(controlcard,"T_BATH",t_bath,300.0d0) - call reada(controlcard,"TAU_BATH",tau_bath,1.0d-1) - call reada(controlcard,"EQ_TIME",eq_time,1.0d+4) - call readi(controlcard,"RESET_MOMENT",count_reset_moment,1000) - if (count_reset_moment.eq.0) count_reset_moment=1000000000 - call readi(controlcard,"RESET_VEL",count_reset_vel,1000) - reset_moment=lang.eq.0 .and. tbf .and. count_reset_moment.gt.0 - reset_vel=lang.eq.0 .and. tbf .and. count_reset_vel.gt.0 - if (count_reset_vel.eq.0) count_reset_vel=1000000000 - large = index(controlcard,"LARGE").gt.0 - print_compon = index(controlcard,"PRINT_COMPON").gt.0 - rattle = index(controlcard,"RATTLE").gt.0 -c if performing umbrella sampling, fragments constrained are read from the fragment file - nset=0 - if(usampl) then - call read_fragments - endif - - if(me.eq.king.or..not.out1file) then - write (iout,*) - write (iout,'(27(1h=),a26,27(1h=))') " Parameters of the MD run " - write (iout,*) - write (iout,'(a)') "The units are:" - write (iout,'(a)') "positions: angstrom, time: 48.9 fs" - write (iout,'(2a)') "velocity: angstrom/(48.9 fs),", - & " acceleration: angstrom/(48.9 fs)**2" - write (iout,'(a)') "energy: kcal/mol, temperature: K" - write (iout,*) - write (iout,'(a60,i10)') "Number of time steps:",n_timestep - write (iout,'(a60,f10.5,a)') - & "Initial time step of numerical integration:",d_time, - & " natural units" - write (iout,'(60x,f10.5,a)') d_time*48.9," fs" - if (RESPA) then - write (iout,'(2a,i4,a)') - & "A-MTS algorithm used; initial time step for fast-varying", - & " short-range forces split into",ntime_split," steps." - write (iout,'(a,f5.2,a,f5.2)') "Short-range force cutoff", - & r_cut," lambda",rlamb - endif - write (iout,'(2a,f10.5)') - & "Maximum acceleration threshold to reduce the time step", - & "/increase split number:",damax - write (iout,'(2a,f10.5)') - & "Maximum predicted energy drift to reduce the timestep", - & "/increase split number:",edriftmax - write (iout,'(a60,f10.5)') - & "Maximum velocity threshold to reduce velocities:",dvmax - write (iout,'(a60,i10)') "Frequency of property output:",ntwe - write (iout,'(a60,i10)') "Frequency of coordinate output:",ntwx - if (rattle) write (iout,'(a60)') - & "Rattle algorithm used to constrain the virtual bonds" - endif - reset_fricmat=1000 - if (lang.gt.0) then - call reada(controlcard,"ETAWAT",etawat,0.8904d0) - call reada(controlcard,"RWAT",rwat,1.4d0) - call reada(controlcard,"SCAL_FRIC",scal_fric,2.0d-2) - surfarea=index(controlcard,"SURFAREA").gt.0 - call readi(controlcard,"RESET_FRICMAT",reset_fricmat,1000) - if(me.eq.king.or..not.out1file)then - write (iout,'(/a,$)') "Langevin dynamics calculation" - if (lang.eq.1) then - write (iout,'(a/)') - & " with direct integration of Langevin equations" - else if (lang.eq.2) then - write (iout,'(a/)') " with TINKER stochasic MD integrator" - else if (lang.eq.3) then - write (iout,'(a/)') " with Ciccotti's stochasic MD integrator" - else if (lang.eq.4) then - write (iout,'(a/)') " in overdamped mode" - else - write (iout,'(//a,i5)') - & "=========== ERROR: Unknown Langevin dynamics mode:",lang - stop - endif - write (iout,'(a60,f10.5)') "Temperature:",t_bath - write (iout,'(a60,f10.5)') "Viscosity of the solvent:",etawat - write (iout,'(a60,f10.5)') "Radius of solvent molecule:",rwat - write (iout,'(a60,f10.5)') - & "Scaling factor of the friction forces:",scal_fric - if (surfarea) write (iout,'(2a,i10,a)') - & "Friction coefficients will be scaled by solvent-accessible", - & " surface area every",reset_fricmat," steps." - endif -c Calculate friction coefficients and bounds of stochastic forces - eta=6*pi*cPoise*etawat - if(me.eq.king.or..not.out1file) - & write(iout,'(a60,f10.5)')"Eta of the solvent in natural units:" - & ,eta - gamp=scal_fric*(pstok+rwat)*eta - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - gamsc(i)=scal_fric*(restok(i)+rwat)*eta - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - if(me.eq.king.or..not.out1file)then - write (iout,'(/2a/)') - & "Radii of site types and friction coefficients and std's of", - & " stochastic forces of fully exposed sites" - write (iout,'(a5,f5.2,2f10.5)')'p',pstok,gamp,stdfp*dsqrt(gamp) - do i=1,ntyp - write (iout,'(a5,f5.2,2f10.5)') restyp(i),restok(i), - & gamsc(i),stdfsc(i)*dsqrt(gamsc(i)) - enddo - endif - else if (tbf) then - if(me.eq.king.or..not.out1file)then - write (iout,'(a)') "Berendsen bath calculation" - write (iout,'(a60,f10.5)') "Temperature:",t_bath - write (iout,'(a60,f10.5)') "Coupling constant (tau):",tau_bath - if (reset_moment) - & write (iout,'(a,i10,a)') "Momenta will be reset at zero every", - & count_reset_moment," steps" - if (reset_vel) - & write (iout,'(a,i10,a)') - & "Velocities will be reset at random every",count_reset_vel, - & " steps" - endif - else if (tnp .or. tnp1 .or. tnh) then - if (tnp .or. tnp1) then - write (iout,'(a)') "Nose-Poincare bath calculation" - if (tnp) write (iout,'(a)') - & "J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird" - if (tnp1) write (iout,'(a)') "JPSJ 70 75 (2001) S. Nose" - else - write (iout,'(a)') "Nose-Hoover bath calculation" - write (iout,'(a)') "Mol.Phys. 87 1117 (1996) Martyna et al." - nresn=1 - nyosh=1 - nnos=1 - do i=1,nnos - qmass(i)=Q_np - xlogs(i)=1.0 - vlogs(i)=0.0 - enddo - do i=1,nyosh - WDTI(i) = 1.0*d_time/nresn - WDTI2(i)=WDTI(i)/2 - WDTI4(i)=WDTI(i)/4 - WDTI8(i)=WDTI(i)/8 - enddo - if (RESPA) then - if(xiresp) then - write (iout,'(a)') "NVT-XI-RESPA algorithm" - else - write (iout,'(a)') "NVT-XO-RESPA algorithm" - endif - do i=1,nyosh - WDTIi(i) = 1.0*d_time/nresn/ntime_split - WDTIi2(i)=WDTIi(i)/2 - WDTIi4(i)=WDTIi(i)/4 - WDTIi8(i)=WDTIi(i)/8 - enddo - endif - endif - - write (iout,'(a60,f10.5)') "Temperature:",t_bath - write (iout,'(a60,f10.5)') "Q =",Q_np - if (reset_moment) - & write (iout,'(a,i10,a)') "Momenta will be reset at zero every", - & count_reset_moment," steps" - if (reset_vel) - & write (iout,'(a,i10,a)') - & "Velocities will be reset at random every",count_reset_vel, - & " steps" - - else if (hmc.gt.0) then - write (iout,'(a)') "Hybrid Monte Carlo calculation" - write (iout,'(a60,f10.5)') "Temperature:",t_bath - write (iout,'(a60,i10)') - & "Number of MD steps between Metropolis tests:",hmc - - else - if(me.eq.king.or..not.out1file) - & write (iout,'(a31)') "Microcanonical mode calculation" - endif - if(me.eq.king.or..not.out1file)then - if (rest) write (iout,'(/a/)') "===== Calculation restarted ====" - if (usampl) then - write(iout,*) "MD running with constraints." - write(iout,*) "Equilibration time ", eq_time, " mtus." - write(iout,*) "Constraining ", nfrag," fragments." - write(iout,*) "Length of each fragment, weight and q0:" - do iset=1,nset - write (iout,*) "Set of restraints #",iset - do i=1,nfrag - write(iout,'(2i5,f8.1,f7.4)') ifrag(1,i,iset), - & ifrag(2,i,iset),wfrag(i,iset),qinfrag(i,iset) - enddo - write(iout,*) "constraints between ", npair, "fragments." - write(iout,*) "constraint pairs, weights and q0:" - do i=1,npair - write(iout,'(2i5,f8.1,f7.4)') ipair(1,i,iset), - & ipair(2,i,iset),wpair(i,iset),qinpair(i,iset) - enddo - write(iout,*) "angle constraints within ", nfrag_back, - & "backbone fragments." - write(iout,*) "fragment, weights:" - do i=1,nfrag_back - write(iout,'(2i5,3f8.1)') ifrag_back(1,i,iset), - & ifrag_back(2,i,iset),wfrag_back(1,i,iset), - & wfrag_back(2,i,iset),wfrag_back(3,i,iset) - enddo - enddo - iset=mod(kolor,nset)+1 - endif - endif - if(me.eq.king.or..not.out1file) - & write (iout,'(/30(1h=),a,29(1h=)/)') " End of MD run setup " - return - end -c------------------------------------------------------------------------------ - subroutine molread -C -C Read molecular data. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer error_msg -#endif - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.DBASE' - include 'COMMON.THREAD' - include 'COMMON.CONTACTS' - include 'COMMON.TORCNSTR' - include 'COMMON.TIME1' - include 'COMMON.BOUNDS' - include 'COMMON.MD' - include 'COMMON.REMD' - include 'COMMON.SETUP' - character*4 sequence(maxres) - integer rescode - double precision x(maxvar) - character*256 pdbfile - character*320 weightcard - character*80 weightcard_t,ucase - dimension itype_pdb(maxres) - common /pizda/ itype_pdb - logical seq_comp,fail - double precision energia(0:n_ene) - integer ilen - external ilen -C -C Body -C -C Read weights of the subsequent energy terms. - if(hremd.gt.0) then - - k=0 - do il=1,hremd - do i=1,nrep - do j=1,remd_m(i) - i2set(k)=il - k=k+1 - enddo - enddo - enddo - - if(me.eq.king.or..not.out1file) then - write (iout,*) 'Reading ',hremd,' sets of weights for HREMD' - write (iout,*) 'Current weights for processor ', - & me,' set ',i2set(me) - endif - - do i=1,hremd - call card_concat(weightcard) - call reada(weightcard,'WLONG',wlong,1.0D0) - call reada(weightcard,'WSC',wsc,wlong) - call reada(weightcard,'WSCP',wscp,wlong) - call reada(weightcard,'WELEC',welec,1.0D0) - call reada(weightcard,'WVDWPP',wvdwpp,welec) - call reada(weightcard,'WEL_LOC',wel_loc,1.0D0) - call reada(weightcard,'WCORR4',wcorr4,0.0D0) - call reada(weightcard,'WCORR5',wcorr5,0.0D0) - call reada(weightcard,'WCORR6',wcorr6,0.0D0) - call reada(weightcard,'WTURN3',wturn3,1.0D0) - call reada(weightcard,'WTURN4',wturn4,1.0D0) - call reada(weightcard,'WTURN6',wturn6,1.0D0) - call reada(weightcard,'WSCCOR',wsccor,1.0D0) - call reada(weightcard,'WSTRAIN',wstrain,1.0D0) - call reada(weightcard,'WBOND',wbond,1.0D0) - call reada(weightcard,'WTOR',wtor,1.0D0) - call reada(weightcard,'WTORD',wtor_d,1.0D0) - call reada(weightcard,'WANG',wang,1.0D0) - call reada(weightcard,'WSCLOC',wscloc,1.0D0) - call reada(weightcard,'SCAL14',scal14,0.4D0) - call reada(weightcard,'SCALSCP',scalscp,1.0d0) - call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) - call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) - call reada(weightcard,'TEMP0',temp0,300.0d0) - if (index(weightcard,'SOFT').gt.0) ipot=6 -C 12/1/95 Added weight for the multi-body term WCORR - call reada(weightcard,'WCORRH',wcorr,1.0D0) - if (wcorr4.gt.0.0d0) wcorr=wcorr4 - - hweights(i,1)=wsc - hweights(i,2)=wscp - hweights(i,3)=welec - hweights(i,4)=wcorr - hweights(i,5)=wcorr5 - hweights(i,6)=wcorr6 - hweights(i,7)=wel_loc - hweights(i,8)=wturn3 - hweights(i,9)=wturn4 - hweights(i,10)=wturn6 - hweights(i,11)=wang - hweights(i,12)=wscloc - hweights(i,13)=wtor - hweights(i,14)=wtor_d - hweights(i,15)=wstrain - hweights(i,16)=wvdwpp - hweights(i,17)=wbond - hweights(i,18)=scal14 - hweights(i,21)=wsccor - - enddo - - do i=1,n_ene - weights(i)=hweights(i2set(me),i) - enddo - wsc =weights(1) - wscp =weights(2) - welec =weights(3) - wcorr =weights(4) - wcorr5 =weights(5) - wcorr6 =weights(6) - wel_loc=weights(7) - wturn3 =weights(8) - wturn4 =weights(9) - wturn6 =weights(10) - wang =weights(11) - wscloc =weights(12) - wtor =weights(13) - wtor_d =weights(14) - wstrain=weights(15) - wvdwpp =weights(16) - wbond =weights(17) - scal14 =weights(18) - wsccor =weights(21) - - - else - call card_concat(weightcard) - call reada(weightcard,'WLONG',wlong,1.0D0) - call reada(weightcard,'WSC',wsc,wlong) - call reada(weightcard,'WSCP',wscp,wlong) - call reada(weightcard,'WELEC',welec,1.0D0) - call reada(weightcard,'WVDWPP',wvdwpp,welec) - call reada(weightcard,'WEL_LOC',wel_loc,1.0D0) - call reada(weightcard,'WCORR4',wcorr4,0.0D0) - call reada(weightcard,'WCORR5',wcorr5,0.0D0) - call reada(weightcard,'WCORR6',wcorr6,0.0D0) - call reada(weightcard,'WTURN3',wturn3,1.0D0) - call reada(weightcard,'WTURN4',wturn4,1.0D0) - call reada(weightcard,'WTURN6',wturn6,1.0D0) - call reada(weightcard,'WSCCOR',wsccor,1.0D0) - call reada(weightcard,'WSTRAIN',wstrain,1.0D0) - call reada(weightcard,'WBOND',wbond,1.0D0) - call reada(weightcard,'WTOR',wtor,1.0D0) - call reada(weightcard,'WTORD',wtor_d,1.0D0) - call reada(weightcard,'WANG',wang,1.0D0) - call reada(weightcard,'WSCLOC',wscloc,1.0D0) -C Bartek - call reada(weightcard,'WDFAD',wdfa_dist,0.0d0) - call reada(weightcard,'WDFAT',wdfa_tor,0.0d0) - call reada(weightcard,'WDFAN',wdfa_nei,0.0d0) - call reada(weightcard,'WDFAB',wdfa_beta,0.0d0) - call reada(weightcard,'SCAL14',scal14,0.4D0) - call reada(weightcard,'SCALSCP',scalscp,1.0d0) - call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) - call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) - call reada(weightcard,'TEMP0',temp0,300.0d0) - if (index(weightcard,'SOFT').gt.0) ipot=6 -C 12/1/95 Added weight for the multi-body term WCORR - call reada(weightcard,'WCORRH',wcorr,1.0D0) - if (wcorr4.gt.0.0d0) wcorr=wcorr4 - weights(1)=wsc - weights(2)=wscp - weights(3)=welec - weights(4)=wcorr - weights(5)=wcorr5 - weights(6)=wcorr6 - weights(7)=wel_loc - weights(8)=wturn3 - weights(9)=wturn4 - weights(10)=wturn6 - weights(11)=wang - weights(12)=wscloc - weights(13)=wtor - weights(14)=wtor_d - weights(15)=wstrain - weights(16)=wvdwpp - weights(17)=wbond - weights(18)=scal14 - weights(21)=wsccor - endif - weights(24)=wdfa_dist - weights(25)=wdfa_tor - weights(26)=wdfa_nei - weights(27)=wdfa_beta - - if(me.eq.king.or..not.out1file) - & write (iout,10) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor, - & wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3, - & wturn4,wturn6, - & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta - 10 format (/'Energy-term weights (unscaled):'// - & 'WSCC= ',f10.6,' (SC-SC)'/ - & 'WSCP= ',f10.6,' (SC-p)'/ - & 'WELEC= ',f10.6,' (p-p electr)'/ - & 'WVDWPP= ',f10.6,' (p-p VDW)'/ - & 'WBOND= ',f10.6,' (stretching)'/ - & 'WANG= ',f10.6,' (bending)'/ - & 'WSCLOC= ',f10.6,' (SC local)'/ - & 'WTOR= ',f10.6,' (torsional)'/ - & 'WTORD= ',f10.6,' (double torsional)'/ - & 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ - & 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ - & 'WCORR4= ',f10.6,' (multi-body 4th order)'/ - & 'WCORR5= ',f10.6,' (multi-body 5th order)'/ - & 'WCORR6= ',f10.6,' (multi-body 6th order)'/ - & 'WSCCOR= ',f10.6,' (back-scloc correlation)'/ - & 'WTURN3= ',f10.6,' (turns, 3rd order)'/ - & 'WTURN4= ',f10.6,' (turns, 4th order)'/ - & 'WTURN6= ',f10.6,' (turns, 6th order)'/ - & 'WDFA_D= ',f10.6,' (DFA, distance)' / - & 'WDFA_T= ',f10.6,' (DFA, torsional)' / - & 'WDFA_N= ',f10.6,' (DFA, number of neighbor)' / - & 'WDFA_B= ',f10.6,' (DFA, beta formation)') - if(me.eq.king.or..not.out1file)then - if (wcorr4.gt.0.0d0) then - write (iout,'(/2a/)') 'Local-electrostatic type correlation ', - & 'between contact pairs of peptide groups' - write (iout,'(2(a,f5.3/))') - & 'Cutoff on 4-6th order correlation terms: ',cutoff_corr, - & 'Range of quenching the correlation terms:',2*delt_corr - else if (wcorr.gt.0.0d0) then - write (iout,'(/2a/)') 'Hydrogen-bonding correlation ', - & 'between contact pairs of peptide groups' - endif - write (iout,'(a,f8.3)') - & 'Scaling factor of 1,4 SC-p interactions:',scal14 - write (iout,'(a,f8.3)') - & 'General scaling factor of SC-p interactions:',scalscp - endif - r0_corr=cutoff_corr-delt_corr - do i=1,20 - aad(i,1)=scalscp*aad(i,1) - aad(i,2)=scalscp*aad(i,2) - bad(i,1)=scalscp*bad(i,1) - bad(i,2)=scalscp*bad(i,2) - enddo - call rescale_weights(t_bath) - if(me.eq.king.or..not.out1file) - & write (iout,22) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor, - & wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3, - & wturn4,wturn6, - & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta - 22 format (/'Energy-term weights (scaled):'// - & 'WSCC= ',f10.6,' (SC-SC)'/ - & 'WSCP= ',f10.6,' (SC-p)'/ - & 'WELEC= ',f10.6,' (p-p electr)'/ - & 'WVDWPP= ',f10.6,' (p-p VDW)'/ - & 'WBOND= ',f10.6,' (stretching)'/ - & 'WANG= ',f10.6,' (bending)'/ - & 'WSCLOC= ',f10.6,' (SC local)'/ - & 'WTOR= ',f10.6,' (torsional)'/ - & 'WTORD= ',f10.6,' (double torsional)'/ - & 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ - & 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ - & 'WCORR4= ',f10.6,' (multi-body 4th order)'/ - & 'WCORR5= ',f10.6,' (multi-body 5th order)'/ - & 'WCORR6= ',f10.6,' (multi-body 6th order)'/ - & 'WSCCOR= ',f10.6,' (back-scloc correlatkion)'/ - & 'WTURN3= ',f10.6,' (turns, 3rd order)'/ - & 'WTURN4= ',f10.6,' (turns, 4th order)'/ - & 'WTURN6= ',f10.6,' (turns, 6th order)'/ - & 'WDFA_D= ',f10.6,' (DFA, distance)' / - & 'WDFA_T= ',f10.6,' (DFA, torsional)' / - & 'WDFA_N= ',f10.6,' (DFA, number of neighbor)' / - & 'WDFA_B= ',f10.6,' (DFA, beta formation)') - - if(me.eq.king.or..not.out1file) - & write (iout,*) "Reference temperature for weights calculation:", - & temp0 - call reada(weightcard,"D0CM",d0cm,3.78d0) - call reada(weightcard,"AKCM",akcm,15.1d0) - call reada(weightcard,"AKTH",akth,11.0d0) - call reada(weightcard,"AKCT",akct,12.0d0) - call reada(weightcard,"V1SS",v1ss,-1.08d0) - call reada(weightcard,"V2SS",v2ss,7.61d0) - call reada(weightcard,"V3SS",v3ss,13.7d0) - call reada(weightcard,"EBR",ebr,-5.50D0) - if(me.eq.king.or..not.out1file) then - write (iout,*) "Parameters of the SS-bond potential:" - write (iout,*) "D0CM",d0cm," AKCM",akcm," AKTH",akth, - & " AKCT",akct - write (iout,*) "V1SS",v1ss," V2SS",v2ss," V3SS",v3ss - write (iout,*) "EBR",ebr - print *,'indpdb=',indpdb,' pdbref=',pdbref - endif - if (indpdb.gt.0 .or. pdbref) then - read(inp,'(a)') pdbfile - if(me.eq.king.or..not.out1file) - & write (iout,'(2a)') 'PDB data will be read from file ', - & pdbfile(:ilen(pdbfile)) - open(ipdbin,file=pdbfile,status='old',err=33) - goto 34 - 33 write (iout,'(a)') 'Error opening PDB file.' - stop - 34 continue -c print *,'Begin reading pdb data' - call readpdb -c print *,'Finished reading pdb data' - if(me.eq.king.or..not.out1file) - & write (iout,'(a,i3,a,i3)')'nsup=',nsup, - & ' nstart_sup=',nstart_sup - do i=1,nres - itype_pdb(i)=itype(i) - enddo - close (ipdbin) - nnt=nstart_sup - nct=nstart_sup+nsup-1 - call contact(.false.,ncont_ref,icont_ref,co) - - if (sideadd) then -C Following 2 lines for diagnostics; comment out if not needed - write (iout,*) "Before sideadd" - call intout - if(me.eq.king.or..not.out1file) - & write(iout,*)'Adding sidechains' - maxsi=1000 - do i=2,nres-1 - iti=itype(i) - if (iti.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(iti,theta(i+1),alph(i),omeg(i),fail) - nsi=nsi+1 - enddo - if(fail) write(iout,*)'Adding sidechain failed for res ', - & i,' after ',nsi,' trials' - endif - enddo -C 10/03/12 Adam: Recalculate coordinates with new side chain positions - call chainbuild - endif -C Following 2 lines for diagnostics; comment out if not needed - write (iout,*) "After sideadd" - call intout - endif - if (indpdb.eq.0) then -C Read sequence if not taken from the pdb file. - read (inp,*) nres -c print *,'nres=',nres - if (iscode.gt.0) then - read (inp,'(80a1)') (sequence(i)(1:1),i=1,nres) - else - read (inp,'(20(1x,a3))') (sequence(i),i=1,nres) - endif -C Convert sequence to numeric code - do i=1,nres - itype(i)=rescode(i,sequence(i),iscode) - enddo -C Assign initial virtual bond lengths - do i=2,nres - vbld(i)=vbl - vbld_inv(i)=vblinv - enddo - do i=2,nres-1 - vbld(i+nres)=dsc(itype(i)) - vbld_inv(i+nres)=dsc_inv(itype(i)) -c write (iout,*) "i",i," itype",itype(i), -c & " dsc",dsc(itype(i))," vbld",vbld(i),vbld(i+nres) - enddo - endif -c print *,nres -c print '(20i4)',(itype(i),i=1,nres) - do i=1,nres -#ifdef PROCOR - if (itype(i).eq.21 .or. itype(i+1).eq.21) then -#else - if (itype(i).eq.21) then -#endif - itel(i)=0 -#ifdef PROCOR - else if (itype(i+1).ne.20) then -#else - else if (itype(i).ne.20) then -#endif - itel(i)=1 - else - itel(i)=2 - endif - enddo - if(me.eq.king.or..not.out1file)then - write (iout,*) "ITEL" - do i=1,nres-1 - write (iout,*) i,itype(i),itel(i) - enddo - print *,'Call Read_Bridge.' - endif - call read_bridge -C 8/13/98 Set limits to generating the dihedral angles - do i=1,nres - phibound(1,i)=-pi - phibound(2,i)=pi - enddo - read (inp,*) ndih_constr - if (ndih_constr.gt.0) then - read (inp,*) ftors - read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr) - if(me.eq.king.or..not.out1file)then - write (iout,*) - & 'There are',ndih_constr,' constraints on phi angles.' - do i=1,ndih_constr - write (iout,'(i5,2f8.3)') idih_constr(i),phi0(i),drange(i) - enddo - endif - do i=1,ndih_constr - phi0(i)=deg2rad*phi0(i) - drange(i)=deg2rad*drange(i) - enddo - if(me.eq.king.or..not.out1file) - & write (iout,*) 'FTORS',ftors - do i=1,ndih_constr - ii = idih_constr(i) - phibound(1,ii) = phi0(i)-drange(i) - phibound(2,ii) = phi0(i)+drange(i) - enddo - endif - nnt=1 -#ifdef MPI - if (me.eq.king) then -#endif - write (iout,'(a)') 'Boundaries in phi angle sampling:' - do i=1,nres - write (iout,'(a3,i5,2f10.1)') - & restyp(itype(i)),i,phibound(1,i)*rad2deg,phibound(2,i)*rad2deg - enddo -#ifdef MP - endif -#endif - nct=nres -cd print *,'NNT=',NNT,' NCT=',NCT - if (itype(1).eq.21) nnt=2 - if (itype(nres).eq.21) nct=nct-1 - -C Juyong:READ init_vars -C Initialize variables! -C Juyong:READ read_info -C READ fragment information!! -C both routines should be in dfa.F file!! - - if (.not. (wdfa_dist.eq.0.0 .and. wdfa_tor.eq.0.0 .and. - & wdfa_nei.eq.0.0 .and. wdfa_beta.eq.0.0)) then - call init_dfa_vars - print*, 'init_dfa_vars finished!' - call read_dfa_info - print*, 'read_dfa_info finished!' - endif -C - if (pdbref) then - if(me.eq.king.or..not.out1file) - & write (iout,'(a,i3)') 'nsup=',nsup - nstart_seq=nnt - if (nsup.le.(nct-nnt+1)) then - do i=0,nct-nnt+1-nsup - if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup),nsup)) then - nstart_seq=nnt+i - goto 111 - endif - enddo - write (iout,'(a)') - & 'Error - sequences to be superposed do not match.' - stop - else - do i=0,nsup-(nct-nnt+1) - if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),nct-nnt+1)) - & then - nstart_sup=nstart_sup+i - nsup=nct-nnt+1 - goto 111 - endif - enddo - write (iout,'(a)') - & 'Error - sequences to be superposed do not match.' - endif - 111 continue - if (nsup.eq.0) nsup=nct-nnt - if (nstart_sup.eq.0) nstart_sup=nnt - if (nstart_seq.eq.0) nstart_seq=nnt - if(me.eq.king.or..not.out1file) - & write (iout,*) 'nsup=',nsup,' nstart_sup=',nstart_sup, - & ' nstart_seq=',nstart_seq - endif -c--- Zscore rms ------- - if (nz_start.eq.0) nz_start=nnt - if (nz_end.eq.0 .and. nsup.gt.0) then - nz_end=nnt+nsup-1 - else if (nz_end.eq.0) then - nz_end=nct - endif - if(me.eq.king.or..not.out1file)then - write (iout,*) 'NZ_START=',nz_start,' NZ_END=',nz_end - write (iout,*) 'IZ_SC=',iz_sc - endif -c---------------------- - call init_int_table - if (refstr) then - if (.not.pdbref) then - call read_angles(inp,*38) - goto 39 - 38 write (iout,'(a)') 'Error reading reference structure.' -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) - stop 'Error reading reference structure' -#endif - 39 call chainbuild - call setup_var -czscore call geom_to_var(nvar,coord_exp_zs(1,1)) - nstart_sup=nnt - nstart_seq=nnt - nsup=nct-nnt+1 - do i=1,2*nres - do j=1,3 - cref(j,i)=c(j,i) - enddo - enddo - call contact(.true.,ncont_ref,icont_ref,co) - endif - if(me.eq.king.or..not.out1file) - & write (iout,*) 'Contact order:',co - if (pdbref) then - if(me.eq.king.or..not.out1file) - & write (2,*) 'Shifting contacts:',nstart_seq,nstart_sup - do i=1,ncont_ref - do j=1,2 - icont_ref(j,i)=icont_ref(j,i)+nstart_seq-nstart_sup - enddo - if(me.eq.king.or..not.out1file) - & write (2,*) i,' ',restyp(itype(icont_ref(1,i))),' ', - & icont_ref(1,i),' ', - & restyp(itype(icont_ref(2,i))),' ',icont_ref(2,i) - enddo - endif - endif -c write (iout,*) "constr_dist",constr_dist,nstart_sup,nsup - if (constr_dist.gt.0) then - call read_dist_constr - endif - if (nhpb.gt.0) call hpb_partition -c write (iout,*) "After read_dist_constr nhpb",nhpb -c call flush(iout) - if (indpdb.eq.0 .and. modecalc.ne.2 .and. modecalc.ne.4 - & .and. modecalc.ne.8 .and. modecalc.ne.9 .and. - & modecalc.ne.10) then -C If input structure hasn't been supplied from the PDB file read or generate -C initial geometry. - if (iranconf.eq.0 .and. .not. extconf) then - if(me.eq.king.or..not.out1file .and.fg_rank.eq.0) - & write (iout,'(a)') 'Initial geometry will be read in.' - if (read_cart) then - read(inp,'(8f10.5)',end=36,err=36) - & ((c(l,k),l=1,3),k=1,nres), - & ((c(l,k+nres),l=1,3),k=nnt,nct) - call int_from_cart1(.false.) - do i=1,nres-1 - do j=1,3 - dc(j,i)=c(j,i+1)-c(j,i) - dc_norm(j,i)=dc_norm(j,i)*vbld_inv(i+1) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc(j,i+nres)=c(j,i+nres)-c(j,i) - dc_norm(j,i+nres)=dc_norm(j,i+nres)*vbld_inv(i+nres) - enddo - endif - enddo - return - else - call read_angles(inp,*36) - endif - goto 37 - 36 write (iout,'(a)') 'Error reading angle file.' -#ifdef MPI - call mpi_finalize( MPI_COMM_WORLD,IERR ) -#endif - stop 'Error reading angle file.' - 37 continue - else if (extconf) then - if(me.eq.king.or..not.out1file .and. fg_rank.eq.0) - & write (iout,'(a)') 'Extended chain initial geometry.' - do i=3,nres - theta(i)=90d0*deg2rad - enddo - do i=4,nres - phi(i)=180d0*deg2rad - enddo - do i=2,nres-1 - alph(i)=110d0*deg2rad - enddo - do i=2,nres-1 - omeg(i)=-120d0*deg2rad - enddo - else - if(me.eq.king.or..not.out1file) - & write (iout,'(a)') 'Random-generated initial geometry.' - - -#ifdef MPI - if (me.eq.king .or. fg_rank.eq.0 .and. ( - & modecalc.eq.12 .or. modecalc.eq.14) ) then -#endif - do itrial=1,100 - itmp=1 - call gen_rand_conf(itmp,*30) - goto 40 - 30 write (iout,*) 'Failed to generate random conformation', - & ', itrial=',itrial - write (*,*) 'Processor:',me, - & ' Failed to generate random conformation', - & ' itrial=',itrial - call intout - -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - enddo - write (iout,'(a,i3,a)') 'Processor:',me, - & ' error in generating random conformation.' - write (*,'(a,i3,a)') 'Processor:',me, - & ' error in generating random conformation.' - call flush(iout) -#ifdef MPI - call MPI_Abort(mpi_comm_world,error_msg,ierrcode) - 40 continue - endif -#else - 40 continue -#endif - endif - elseif (modecalc.eq.4) then - read (inp,'(a)') intinname - open (intin,file=intinname,status='old',err=333) - if (me.eq.king .or. .not.out1file.and.fg_rank.eq.0) - & write (iout,'(a)') 'intinname',intinname - write (*,'(a)') 'Processor',myrank,' intinname',intinname - goto 334 - 333 write (iout,'(2a)') 'Error opening angle file ',intinname -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERR) -#endif - stop 'Error opening angle file.' - 334 continue - - endif -C Generate distance constraints, if the PDB structure is to be regularized. - if (nthread.gt.0) then - call read_threadbase - endif - call setup_var - if (me.eq.king .or. .not. out1file) - & call intout - if (ns.gt.0 .and. (me.eq.king .or. .not.out1file) ) then - write (iout,'(/a,i3,a)') - & 'The chain contains',ns,' disulfide-bridging cysteines.' - write (iout,'(20i4)') (iss(i),i=1,ns) - write (iout,'(/a/)') 'Pre-formed links are:' - do i=1,nss - i1=ihpb(i)-nres - i2=jhpb(i)-nres - it1=itype(i1) - it2=itype(i2) - if (me.eq.king.or..not.out1file) - & write (iout,'(2a,i3,3a,i3,a,3f10.3)') - & restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')',dhpb(i), - & ebr,forcon(i) - enddo - write (iout,'(a)') - endif - if (i2ndstr.gt.0) call secstrp2dihc -c call geom_to_var(nvar,x) -c call etotal(energia(0)) -c call enerprint(energia(0)) -c call briefout(0,etot) -c stop -cd write (iout,'(2(a,i3))') 'NNT',NNT,' NCT',NCT -cd write (iout,'(a)') 'Variable list:' -cd write (iout,'(i4,f10.5)') (i,rad2deg*x(i),i=1,nvar) -#ifdef MPI - if (me.eq.king .or. (fg_rank.eq.0 .and. .not.out1file)) - & write (iout,'(//80(1h*)/20x,a,i4,a/80(1h*)//)') - & 'Processor',myrank,': end reading molecular data.' -#endif - return - end -c-------------------------------------------------------------------------- - logical function seq_comp(itypea,itypeb,length) - implicit none - integer length,itypea(length),itypeb(length) - integer i - do i=1,length - if (itypea(i).ne.itypeb(i)) then - seq_comp=.false. - return - endif - enddo - seq_comp=.true. - return - end -c----------------------------------------------------------------------------- - subroutine read_bridge -C Read information about disulfide bridges. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.DBASE' - include 'COMMON.THREAD' - include 'COMMON.TIME1' - include 'COMMON.SETUP' -C Read bridging residues. - read (inp,*) ns,(iss(i),i=1,ns) - print *,'ns=',ns - if(me.eq.king.or..not.out1file) - & write (iout,*) 'ns=',ns,' iss:',(iss(i),i=1,ns) -C Check whether the specified bridging residues are cystines. - do i=1,ns - if (itype(iss(i)).ne.1) then - if (me.eq.king.or..not.out1file) write (iout,'(2a,i3,a)') - & 'Do you REALLY think that the residue ',restyp(iss(i)),i, - & ' can form a disulfide bridge?!!!' - write (*,'(2a,i3,a)') - & 'Do you REALLY think that the residue ',restyp(iss(i)),i, - & ' can form a disulfide bridge?!!!' -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,ierror) - stop -#endif - endif - enddo -C Read preformed bridges. - if (ns.gt.0) then - read (inp,*) nss,(ihpb(i),jhpb(i),i=1,nss) - write (iout,*) 'nss=',nss,' ihpb,jhpb: ',(ihpb(i),jhpb(i),i=1,nss) - if (nss.gt.0) then - nhpb=nss -C Check if the residues involved in bridges are in the specified list of -C bridging residues. - do i=1,nss - do j=1,i-1 - if (ihpb(i).eq.ihpb(j).or.ihpb(i).eq.jhpb(j) - & .or.jhpb(i).eq.ihpb(j).or.jhpb(i).eq.jhpb(j)) then - write (iout,'(a,i3,a)') 'Disulfide pair',i, - & ' contains residues present in other pairs.' - write (*,'(a,i3,a)') 'Disulfide pair',i, - & ' contains residues present in other pairs.' -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,ierror) - stop -#endif - endif - enddo - do j=1,ns - if (ihpb(i).eq.iss(j)) goto 10 - enddo - write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' - 10 continue - do j=1,ns - if (jhpb(i).eq.iss(j)) goto 20 - enddo - write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' - 20 continue - dhpb(i)=dbr - forcon(i)=fbr - enddo - do i=1,nss - ihpb(i)=ihpb(i)+nres - jhpb(i)=jhpb(i)+nres - enddo - endif - endif - return - end -c---------------------------------------------------------------------------- - subroutine read_x(kanal,*) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' -c Read coordinates from input -c - read(kanal,'(8f10.5)',end=10,err=10) - & ((c(l,k),l=1,3),k=1,nres), - & ((c(l,k+nres),l=1,3),k=nnt,nct) - do j=1,3 - c(j,nres+1)=c(j,1) - c(j,2*nres)=c(j,nres) - enddo - call int_from_cart1(.false.) - do i=1,nres-1 - do j=1,3 - dc(j,i)=c(j,i+1)-c(j,i) - dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc(j,i+nres)=c(j,i+nres)-c(j,i) - dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) - enddo - endif - enddo - - return - 10 return1 - end -c---------------------------------------------------------------------------- - subroutine read_threadbase - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.DBASE' - include 'COMMON.THREAD' - include 'COMMON.TIME1' -C Read pattern database for threading. - read (icbase,*) nseq - do i=1,nseq - read (icbase,'(i5,2x,a8,2i4)') nres_base(1,i),str_nam(i), - & nres_base(2,i),nres_base(3,i) - read (icbase,'(9f8.3)') ((cart_base(k,j,i),k=1,3),j=1, - & nres_base(1,i)) -c write (iout,'(i5,2x,a8,2i4)') nres_base(1,i),str_nam(i), -c & nres_base(2,i),nres_base(3,i) -c write (iout,'(9f8.3)') ((cart_base(k,j,i),k=1,3),j=1, -c & nres_base(1,i)) - enddo - close (icbase) - if (weidis.eq.0.0D0) weidis=0.1D0 - do i=nnt,nct - do j=i+2,nct - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=weidis - enddo - enddo - read (inp,*) nexcl,(iexam(1,i),iexam(2,i),i=1,nexcl) - write (iout,'(a,i5)') 'nexcl: ',nexcl - write (iout,'(2i5)') (iexam(1,i),iexam(2,i),i=1,nexcl) - return - end -c------------------------------------------------------------------------------ - subroutine setup_var - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.DBASE' - include 'COMMON.THREAD' - include 'COMMON.TIME1' -C Set up variable list. - ntheta=nres-2 - nphi=nres-3 - nvar=ntheta+nphi - nside=0 - do i=2,nres-1 - if (itype(i).ne.10) then - nside=nside+1 - ialph(i,1)=nvar+nside - ialph(nside,2)=i - endif - enddo - if (indphi.gt.0) then - nvar=nphi - else if (indback.gt.0) then - nvar=nphi+ntheta - else - nvar=nvar+2*nside - endif -cd write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1) - return - end -c---------------------------------------------------------------------------- - subroutine gen_dist_constr -C Generate CA distance constraints. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.DBASE' - include 'COMMON.THREAD' - include 'COMMON.TIME1' - dimension itype_pdb(maxres) - common /pizda/ itype_pdb - character*2 iden -cd print *,'gen_dist_constr: nnt=',nnt,' nct=',nct -cd write (2,*) 'gen_dist_constr: nnt=',nnt,' nct=',nct, -cd & ' nstart_sup',nstart_sup,' nstart_seq',nstart_seq, -cd & ' nsup',nsup - do i=nstart_sup,nstart_sup+nsup-1 -cd write (2,*) 'i',i,' seq ',restyp(itype(i+nstart_seq-nstart_sup)), -cd & ' seq_pdb', restyp(itype_pdb(i)) - do j=i+2,nstart_sup+nsup-1 - nhpb=nhpb+1 - ihpb(nhpb)=i+nstart_seq-nstart_sup - jhpb(nhpb)=j+nstart_seq-nstart_sup - forcon(nhpb)=weidis - dhpb(nhpb)=dist(i,j) - enddo - enddo -cd write (iout,'(a)') 'Distance constraints:' -cd do i=nss+1,nhpb -cd ii=ihpb(i) -cd jj=jhpb(i) -cd iden='CA' -cd if (ii.gt.nres) then -cd iden='SC' -cd ii=ii-nres -cd jj=jj-nres -cd endif -cd write (iout,'(a,1x,a,i4,3x,a,1x,a,i4,2f10.3)') -cd & restyp(itype(ii)),iden,ii,restyp(itype(jj)),iden,jj, -cd & dhpb(i),forcon(i) -cd enddo - return - end -c---------------------------------------------------------------------------- - subroutine map_read - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MAP' - include 'COMMON.IOUNITS' - character*3 angid(4) /'THE','PHI','ALP','OME'/ - character*80 mapcard,ucase - do imap=1,nmap - read (inp,'(a)') mapcard - mapcard=ucase(mapcard) - if (index(mapcard,'PHI').gt.0) then - kang(imap)=1 - else if (index(mapcard,'THE').gt.0) then - kang(imap)=2 - else if (index(mapcard,'ALP').gt.0) then - kang(imap)=3 - else if (index(mapcard,'OME').gt.0) then - kang(imap)=4 - else - write(iout,'(a)')'Error - illegal variable spec in MAP card.' - stop 'Error - illegal variable spec in MAP card.' - endif - call readi (mapcard,'RES1',res1(imap),0) - call readi (mapcard,'RES2',res2(imap),0) - if (res1(imap).eq.0) then - res1(imap)=res2(imap) - else if (res2(imap).eq.0) then - res2(imap)=res1(imap) - endif - if(res1(imap)*res2(imap).eq.0 .or. res1(imap).gt.res2(imap))then - write (iout,'(a)') - & 'Error - illegal definition of variable group in MAP.' - stop 'Error - illegal definition of variable group in MAP.' - endif - call reada(mapcard,'FROM',ang_from(imap),0.0D0) - call reada(mapcard,'TO',ang_to(imap),0.0D0) - call readi(mapcard,'NSTEP',nstep(imap),0) - if (ang_from(imap).eq.ang_to(imap) .or. nstep(imap).eq.0) then - write (iout,'(a)') - & 'Illegal boundary and/or step size specification in MAP.' - stop 'Illegal boundary and/or step size specification in MAP.' - endif - enddo ! imap - return - end -c---------------------------------------------------------------------------- -csa subroutine csaread -csa implicit real*8 (a-h,o-z) -csa include 'DIMENSIONS' -csa include 'COMMON.IOUNITS' -csa include 'COMMON.GEO' -csa include 'COMMON.CSA' -csa include 'COMMON.BANK' -csa include 'COMMON.CONTROL' -csa character*80 ucase -csa character*620 mcmcard -csa call card_concat(mcmcard) -csa -csa call readi(mcmcard,'NCONF',nconf,50) -csa call readi(mcmcard,'NADD',nadd,0) -csa call readi(mcmcard,'JSTART',jstart,1) -csa call readi(mcmcard,'JEND',jend,1) -csa call readi(mcmcard,'NSTMAX',nstmax,500000) -csa call readi(mcmcard,'N0',n0,1) -csa call readi(mcmcard,'N1',n1,6) -csa call readi(mcmcard,'N2',n2,4) -csa call readi(mcmcard,'N3',n3,0) -csa call readi(mcmcard,'N4',n4,0) -csa call readi(mcmcard,'N5',n5,0) -csa call readi(mcmcard,'N6',n6,10) -csa call readi(mcmcard,'N7',n7,0) -csa call readi(mcmcard,'N8',n8,0) -csa call readi(mcmcard,'N9',n9,0) -csa call readi(mcmcard,'N14',n14,0) -csa call readi(mcmcard,'N15',n15,0) -csa call readi(mcmcard,'N16',n16,0) -csa call readi(mcmcard,'N17',n17,0) -csa call readi(mcmcard,'N18',n18,0) -csa -csa vdisulf=(index(mcmcard,'DYNSS').gt.0) -csa -csa call readi(mcmcard,'NDIFF',ndiff,2) -csa call reada(mcmcard,'DIFFCUT',diffcut,0.0d0) -csa call readi(mcmcard,'IS1',is1,1) -csa call readi(mcmcard,'IS2',is2,8) -csa call readi(mcmcard,'NRAN0',nran0,4) -csa call readi(mcmcard,'NRAN1',nran1,2) -csa call readi(mcmcard,'IRR',irr,1) -csa call readi(mcmcard,'NSEED',nseed,20) -csa call readi(mcmcard,'NTOTAL',ntotal,10000) -csa call reada(mcmcard,'CUT1',cut1,2.0d0) -csa call reada(mcmcard,'CUT2',cut2,5.0d0) -csa call reada(mcmcard,'ESTOP',estop,-3000.0d0) -csa call readi(mcmcard,'ICMAX',icmax,3) -csa call readi(mcmcard,'IRESTART',irestart,0) -csac!bankt call readi(mcmcard,'NBANKTM',ntbankm,0) -csa ntbankm=0 -csac!bankt -csa call reada(mcmcard,'DELE',dele,20.0d0) -csa call reada(mcmcard,'DIFCUT',difcut,720.0d0) -csa call readi(mcmcard,'IREF',iref,0) -csa call reada(mcmcard,'RMSCUT',rmscut,4.0d0) -csa call reada(mcmcard,'PNCCUT',pnccut,0.5d0) -csa call readi(mcmcard,'NCONF_IN',nconf_in,0) -csa call reada(mcmcard,'RDIH_BIAS',rdih_bias,0.5d0) -csa write (iout,*) "NCONF_IN",nconf_in -csa return -csa end -c---------------------------------------------------------------------------- -cfmc subroutine mcmfread -cfmc implicit real*8 (a-h,o-z) -cfmc include 'DIMENSIONS' -cfmc include 'COMMON.MCMF' -cfmc include 'COMMON.IOUNITS' -cfmc include 'COMMON.GEO' -cfmc character*80 ucase -cfmc character*620 mcmcard -cfmc call card_concat(mcmcard) -cfmc -cfmc call readi(mcmcard,'MAXRANT',maxrant,1000) -cfmc write(iout,*)'MAXRANT=',maxrant -cfmc call readi(mcmcard,'MAXFAM',maxfam,maxfam_p) -cfmc write(iout,*)'MAXFAM=',maxfam -cfmc call readi(mcmcard,'NNET1',nnet1,5) -cfmc write(iout,*)'NNET1=',nnet1 -cfmc call readi(mcmcard,'NNET2',nnet2,4) -cfmc write(iout,*)'NNET2=',nnet2 -cfmc call readi(mcmcard,'NNET3',nnet3,4) -cfmc write(iout,*)'NNET3=',nnet3 -cfmc call readi(mcmcard,'ILASTT',ilastt,0) -cfmc write(iout,*)'ILASTT=',ilastt -cfmc call readi(mcmcard,'MAXSTR',maxstr,maxstr_mcmf) -cfmc write(iout,*)'MAXSTR=',maxstr -cfmc maxstr_f=maxstr/maxfam -cfmc write(iout,*)'MAXSTR_F=',maxstr_f -cfmc call readi(mcmcard,'NMCMF',nmcmf,10) -cfmc write(iout,*)'NMCMF=',nmcmf -cfmc call readi(mcmcard,'IFOCUS',ifocus,nmcmf) -cfmc write(iout,*)'IFOCUS=',ifocus -cfmc call readi(mcmcard,'NLOCMCMF',nlocmcmf,1000) -cfmc write(iout,*)'NLOCMCMF=',nlocmcmf -cfmc call readi(mcmcard,'INTPRT',intprt,1000) -cfmc write(iout,*)'INTPRT=',intprt -cfmc call readi(mcmcard,'IPRT',iprt,100) -cfmc write(iout,*)'IPRT=',iprt -cfmc call readi(mcmcard,'IMAXTR',imaxtr,100) -cfmc write(iout,*)'IMAXTR=',imaxtr -cfmc call readi(mcmcard,'MAXEVEN',maxeven,1000) -cfmc write(iout,*)'MAXEVEN=',maxeven -cfmc call readi(mcmcard,'MAXEVEN1',maxeven1,3) -cfmc write(iout,*)'MAXEVEN1=',maxeven1 -cfmc call readi(mcmcard,'INIMIN',inimin,200) -cfmc write(iout,*)'INIMIN=',inimin -cfmc call readi(mcmcard,'NSTEPMCMF',nstepmcmf,10) -cfmc write(iout,*)'NSTEPMCMF=',nstepmcmf -cfmc call readi(mcmcard,'NTHREAD',nthread,5) -cfmc write(iout,*)'NTHREAD=',nthread -cfmc call readi(mcmcard,'MAXSTEPMCMF',maxstepmcmf,2500) -cfmc write(iout,*)'MAXSTEPMCMF=',maxstepmcmf -cfmc call readi(mcmcard,'MAXPERT',maxpert,9) -cfmc write(iout,*)'MAXPERT=',maxpert -cfmc call readi(mcmcard,'IRMSD',irmsd,1) -cfmc write(iout,*)'IRMSD=',irmsd -cfmc call reada(mcmcard,'DENEMIN',denemin,0.01D0) -cfmc write(iout,*)'DENEMIN=',denemin -cfmc call reada(mcmcard,'RCUT1S',rcut1s,3.5D0) -cfmc write(iout,*)'RCUT1S=',rcut1s -cfmc call reada(mcmcard,'RCUT1E',rcut1e,2.0D0) -cfmc write(iout,*)'RCUT1E=',rcut1e -cfmc call reada(mcmcard,'RCUT2S',rcut2s,0.5D0) -cfmc write(iout,*)'RCUT2S=',rcut2s -cfmc call reada(mcmcard,'RCUT2E',rcut2e,0.1D0) -cfmc write(iout,*)'RCUT2E=',rcut2e -cfmc call reada(mcmcard,'DPERT1',d_pert1,180.0D0) -cfmc write(iout,*)'DPERT1=',d_pert1 -cfmc call reada(mcmcard,'DPERT1A',d_pert1a,180.0D0) -cfmc write(iout,*)'DPERT1A=',d_pert1a -cfmc call reada(mcmcard,'DPERT2',d_pert2,90.0D0) -cfmc write(iout,*)'DPERT2=',d_pert2 -cfmc call reada(mcmcard,'DPERT2A',d_pert2a,45.0D0) -cfmc write(iout,*)'DPERT2A=',d_pert2a -cfmc call reada(mcmcard,'DPERT2B',d_pert2b,90.0D0) -cfmc write(iout,*)'DPERT2B=',d_pert2b -cfmc call reada(mcmcard,'DPERT2C',d_pert2c,60.0D0) -cfmc write(iout,*)'DPERT2C=',d_pert2c -cfmc d_pert1=deg2rad*d_pert1 -cfmc d_pert1a=deg2rad*d_pert1a -cfmc d_pert2=deg2rad*d_pert2 -cfmc d_pert2a=deg2rad*d_pert2a -cfmc d_pert2b=deg2rad*d_pert2b -cfmc d_pert2c=deg2rad*d_pert2c -cfmc call reada(mcmcard,'KT_MCMF1',kt_mcmf1,1.0D0) -cfmc write(iout,*)'KT_MCMF1=',kt_mcmf1 -cfmc call reada(mcmcard,'KT_MCMF2',kt_mcmf2,1.0D0) -cfmc write(iout,*)'KT_MCMF2=',kt_mcmf2 -cfmc call reada(mcmcard,'DKT_MCMF1',dkt_mcmf1,10.0D0) -cfmc write(iout,*)'DKT_MCMF1=',dkt_mcmf1 -cfmc call reada(mcmcard,'DKT_MCMF2',dkt_mcmf2,1.0D0) -cfmc write(iout,*)'DKT_MCMF2=',dkt_mcmf2 -cfmc call reada(mcmcard,'RCUTINI',rcutini,3.5D0) -cfmc write(iout,*)'RCUTINI=',rcutini -cfmc call reada(mcmcard,'GRAT',grat,0.5D0) -cfmc write(iout,*)'GRAT=',grat -cfmc call reada(mcmcard,'BIAS_MCMF',bias_mcmf,0.0D0) -cfmc write(iout,*)'BIAS_MCMF=',bias_mcmf -cfmc -cfmc return -cfmc end -c---------------------------------------------------------------------------- - subroutine mcmread - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.IOUNITS' - character*80 ucase - character*320 mcmcard - call card_concat(mcmcard) - call readi(mcmcard,'MAXACC',maxacc,100) - call readi(mcmcard,'MAX_MCM_IT',max_mcm_it,10000) - call readi(mcmcard,'MAXTRIAL',maxtrial,100) - call readi(mcmcard,'MAXTRIAL_ITER',maxtrial_iter,1000) - call readi(mcmcard,'MAXREPM',maxrepm,200) - call reada(mcmcard,'RANFRACT',RanFract,0.5D0) - call reada(mcmcard,'POOL_FRACT',pool_fraction,0.01D0) - call reada(mcmcard,'OVERLAP',overlap_cut,1.0D3) - call reada(mcmcard,'E_UP',e_up,5.0D0) - call reada(mcmcard,'DELTE',delte,0.1D0) - call readi(mcmcard,'NSWEEP',nsweep,5) - call readi(mcmcard,'NSTEPH',nsteph,0) - call readi(mcmcard,'NSTEPC',nstepc,0) - call reada(mcmcard,'TMIN',tmin,298.0D0) - call reada(mcmcard,'TMAX',tmax,298.0D0) - call readi(mcmcard,'NWINDOW',nwindow,0) - call readi(mcmcard,'PRINT_MC',print_mc,0) - print_stat=(index(mcmcard,'NO_PRINT_STAT').le.0) - print_int=(index(mcmcard,'NO_PRINT_INT').le.0) - ent_read=(index(mcmcard,'ENT_READ').gt.0) - call readi(mcmcard,'SAVE_FREQ',save_frequency,1000) - call readi(mcmcard,'MESSAGE_FREQ',message_frequency,1000) - call readi(mcmcard,'POOL_READ_FREQ',pool_read_freq,5000) - call readi(mcmcard,'POOL_SAVE_FREQ',pool_save_freq,1000) - call readi(mcmcard,'PRINT_FREQ',print_freq,1000) - if (nwindow.gt.0) then - read (inp,*) (winstart(i),winend(i),i=1,nwindow) - do i=1,nwindow - winlen(i)=winend(i)-winstart(i)+1 - enddo - endif - if (tmax.lt.tmin) tmax=tmin - if (tmax.eq.tmin) then - nstepc=0 - nsteph=0 - endif - if (nstepc.gt.0 .and. nsteph.gt.0) then - tsteph=(tmax/tmin)**(1.0D0/(nsteph+0.0D0)) - tstepc=(tmax/tmin)**(1.0D0/(nstepc+0.0D0)) - endif -C Probabilities of different move types - sumpro_type(0)=0.0D0 - call reada(mcmcard,'MULTI_BOND',sumpro_type(1),1.0d0) - call reada(mcmcard,'ONE_ANGLE' ,sumpro_type(2),2.0d0) - sumpro_type(2)=sumpro_type(1)+sumpro_type(2) - call reada(mcmcard,'THETA' ,sumpro_type(3),0.0d0) - sumpro_type(3)=sumpro_type(2)+sumpro_type(3) - call reada(mcmcard,'SIDE_CHAIN',sumpro_type(4),0.5d0) - sumpro_type(4)=sumpro_type(3)+sumpro_type(4) - do i=1,MaxMoveType - print *,'i',i,' sumprotype',sumpro_type(i) - sumpro_type(i)=sumpro_type(i)/sumpro_type(MaxMoveType) - print *,'i',i,' sumprotype',sumpro_type(i) - enddo - return - end -c---------------------------------------------------------------------------- - subroutine read_minim - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MINIM' - include 'COMMON.IOUNITS' - character*80 ucase - character*320 minimcard - call card_concat(minimcard) - call readi(minimcard,'MAXMIN',maxmin,2000) - call readi(minimcard,'MAXFUN',maxfun,5000) - call readi(minimcard,'MINMIN',minmin,maxmin) - call readi(minimcard,'MINFUN',minfun,maxmin) - call reada(minimcard,'TOLF',tolf,1.0D-2) - call reada(minimcard,'RTOLF',rtolf,1.0D-4) - print_min_stat=min0(index(minimcard,'PRINT_MIN_STAT'),1) - print_min_res=min0(index(minimcard,'PRINT_MIN_RES'),1) - print_min_ini=min0(index(minimcard,'PRINT_MIN_INI'),1) - write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Options in energy minimization:' - write (iout,'(4(a,i5),a,1pe14.5,a,1pe14.5)') - & 'MaxMin:',MaxMin,' MaxFun:',MaxFun, - & 'MinMin:',MinMin,' MinFun:',MinFun, - & ' TolF:',TolF,' RTolF:',RTolF - return - end -c---------------------------------------------------------------------------- - subroutine read_angles(kanal,*) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' -c Read angles from input -c - read (kanal,*,err=10,end=10) (theta(i),i=3,nres) - read (kanal,*,err=10,end=10) (phi(i),i=4,nres) - read (kanal,*,err=10,end=10) (alph(i),i=2,nres-1) - read (kanal,*,err=10,end=10) (omeg(i),i=2,nres-1) - - do i=1,nres -c 9/7/01 avoid 180 deg valence angle - if (theta(i).gt.179.99d0) theta(i)=179.99d0 -c - theta(i)=deg2rad*theta(i) - phi(i)=deg2rad*phi(i) - alph(i)=deg2rad*alph(i) - omeg(i)=deg2rad*omeg(i) - enddo - return - 10 return1 - end -c---------------------------------------------------------------------------- - subroutine reada(rekord,lancuch,wartosc,default) - implicit none - character*(*) rekord,lancuch - double precision wartosc,default - integer ilen,iread - external ilen - iread=index(rekord,lancuch) - if (iread.eq.0) then - wartosc=default - return - endif - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,err=10,end=10) wartosc - return - 10 wartosc=default - return - end -c---------------------------------------------------------------------------- - subroutine readi(rekord,lancuch,wartosc,default) - implicit none - character*(*) rekord,lancuch - integer wartosc,default - integer ilen,iread - external ilen - iread=index(rekord,lancuch) - if (iread.eq.0) then - wartosc=default - return - endif - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,err=10,end=10) wartosc - return - 10 wartosc=default - return - end -c---------------------------------------------------------------------------- - subroutine multreadi(rekord,lancuch,tablica,dim,default) - implicit none - integer dim,i - integer tablica(dim),default - character*(*) rekord,lancuch - character*80 aux - integer ilen,iread - external ilen - do i=1,dim - tablica(i)=default - enddo - iread=index(rekord,lancuch(:ilen(lancuch))//"=") - if (iread.eq.0) return - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) - 10 return - end -c---------------------------------------------------------------------------- - subroutine multreada(rekord,lancuch,tablica,dim,default) - implicit none - integer dim,i - double precision tablica(dim),default - character*(*) rekord,lancuch - character*80 aux - integer ilen,iread - external ilen - do i=1,dim - tablica(i)=default - enddo - iread=index(rekord,lancuch(:ilen(lancuch))//"=") - if (iread.eq.0) return - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) - 10 return - end -c---------------------------------------------------------------------------- - subroutine openunits - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - character*16 form,nodename - integer nodelen -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.MD' - include 'COMMON.CONTROL' - integer lenpre,lenpot,ilen,lentmp - external ilen - character*3 out1file_text,ucase - character*3 ll - external ucase -c print *,"Processor",myrank,"fg_rank",fg_rank," entered openunits" - call getenv_loc("PREFIX",prefix) - pref_orig = prefix - call getenv_loc("POT",pot) - call getenv_loc("DIRTMP",tmpdir) - call getenv_loc("CURDIR",curdir) - call getenv_loc("OUT1FILE",out1file_text) -c print *,"Processor",myrank,"fg_rank",fg_rank," did GETENV" - out1file_text=ucase(out1file_text) - if (out1file_text(1:1).eq."Y") then - out1file=.true. - else - out1file=fg_rank.gt.0 - endif - lenpre=ilen(prefix) - lenpot=ilen(pot) - lentmp=ilen(tmpdir) - if (lentmp.gt.0) then - write (*,'(80(1h!))') - write (*,'(a,19x,a,19x,a)') "!"," A T T E N T I O N ","!" - write (*,'(80(1h!))') - write (*,*)"All output files will be on node /tmp directory." -#ifdef MPI - call MPI_GET_PROCESSOR_NAME( nodename, nodelen, IERROR ) - if (me.eq.king) then - write (*,*) "The master node is ",nodename - else if (fg_rank.eq.0) then - write (*,*) "I am the CG slave node ",nodename - else - write (*,*) "I am the FG slave node ",nodename - endif -#endif - PREFIX = tmpdir(:lentmp)//'/'//prefix(:lenpre) - lenpre = lentmp+lenpre+1 - endif - entname=prefix(:lenpre)//'_'//pot(:lenpot)//'.entr' -C Get the names and open the input files -#if defined(WINIFL) || defined(WINPGI) - open(1,file=pref_orig(:ilen(pref_orig))// - & '.inp',status='old',readonly,shared) - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -C Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old',readonly,shared) - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old',readonly,shared) -#ifndef CRYST_THETA - call getenv_loc('THETPARPDB',thetname_pdb) - open (ithep_pdb,file=thetname_pdb,status='old',readonly,shared) -#endif - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old',readonly,shared) -#ifndef CRYST_SC - call getenv_loc('ROTPARPDB',rotname_pdb) - open (irotam_pdb,file=rotname_pdb,status='old',readonly,shared) -#endif - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old',readonly,shared) - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old',readonly,shared) - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old',readonly,shared) - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old',readonly,shared) - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old', - & action='read') -c print *,"Processor",myrank," opened file 1" - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -c print *,"Processor",myrank," opened file 9" -C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -C Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old',action='read') -c print *,"Processor",myrank," opened file IBOND" - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old',action='read') -c print *,"Processor",myrank," opened file ITHEP" -#ifndef CRYST_THETA - call getenv_loc('THETPARPDB',thetname_pdb) - open (ithep_pdb,file=thetname_pdb,status='old',action='read') -#endif - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old',action='read') -c print *,"Processor",myrank," opened file IROTAM" -#ifndef CRYST_SC - call getenv_loc('ROTPARPDB',rotname_pdb) - open (irotam_pdb,file=rotname_pdb,status='old',action='read') -#endif - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old',action='read') -c print *,"Processor",myrank," opened file ITORP" - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old',action='read') -c print *,"Processor",myrank," opened file ITORDP" - call getenv_loc('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old',action='read') -c print *,"Processor",myrank," opened file ISCCOR" - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old',action='read') -c print *,"Processor",myrank," opened file IFOURIER" - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old',action='read') -c print *,"Processor",myrank," opened file IELEP" - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old',action='read') -c print *,"Processor",myrank," opened file ISIDEP" -c print *,"Processor",myrank," opened parameter files" -#elif (defined G77) - open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old') - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -C Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old') - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old') -#ifndef CRYST_THETA - call getenv_loc('THETPARPDB',thetname_pdb) - open (ithep_pdb,file=thetname_pdb,status='old') -#endif - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old') -#ifndef CRYST_SC - call getenv_loc('ROTPARPDB',rotname_pdb) - open (irotam_pdb,file=rotname_pdb,status='old') -#endif - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old') - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old') - call getenv_loc('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old') - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old') - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old') - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old') -#else - open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old', - &action='read') - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -C Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old',action='read') - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old',action='read') -#ifndef CRYST_THETA - call getenv_loc('THETPARPDB',thetname_pdb) - print *,"thetname_pdb ",thetname_pdb - open (ithep_pdb,file=thetname_pdb,status='old',action='read') - print *,ithep_pdb," opened" -#endif - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old',action='read') -#ifndef CRYST_SC - call getenv_loc('ROTPARPDB',rotname_pdb) - open (irotam_pdb,file=rotname_pdb,status='old',action='read') -#endif - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old',action='read') - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old',action='read') - call getenv_loc('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old',action='read') - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old',action='read') - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old',action='read') - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old',action='read') -#endif -#ifndef OLDSCP -C -C 8/9/01 In the newest version SCp interaction constants are read from a file -C Use -DOLDSCP to use hard-coded constants instead. -C - call getenv_loc('SCPPAR',scpname) -#if defined(WINIFL) || defined(WINPGI) - open (iscpp,file=scpname,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open (iscpp,file=scpname,status='old',action='read') -#elif (defined G77) - open (iscpp,file=scpname,status='old') -#else - open (iscpp,file=scpname,status='old',action='read') -#endif -#endif - call getenv_loc('PATTERN',patname) -#if defined(WINIFL) || defined(WINPGI) - open (icbase,file=patname,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open (icbase,file=patname,status='old',action='read') -#elif (defined G77) - open (icbase,file=patname,status='old') -#else - open (icbase,file=patname,status='old',action='read') -#endif -#ifdef MPI -C Open output file only for CG processes -c print *,"Processor",myrank," fg_rank",fg_rank - if (fg_rank.eq.0) then - - if (nodes.eq.1) then - npos=3 - else - npos = dlog10(dfloat(nodes-1))+1 - endif - if (npos.lt.3) npos=3 - write (liczba,'(i1)') npos - form = '(bz,i'//liczba(:ilen(liczba))//'.'//liczba(:ilen(liczba)) - & //')' - write (liczba,form) me - outname=prefix(:lenpre)//'.out_'//pot(:lenpot)// - & liczba(:ilen(liczba)) - intname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba)) - & //'.int' - pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba)) - & //'.pdb' - mol2name=prefix(:lenpre)//'_'//pot(:lenpot)// - & liczba(:ilen(liczba))//'.mol2' - statname=prefix(:lenpre)//'_'//pot(:lenpot)// - & liczba(:ilen(liczba))//'.stat' - if (lentmp.gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot) - & //liczba(:ilen(liczba))//'.stat') - rest2name=prefix(:ilen(prefix))//"_"//liczba(:ilen(liczba)) - & //'.rst' - if(usampl) then - qname=prefix(:lenpre)//'_'//pot(:lenpot)// - & liczba(:ilen(liczba))//'.const' - endif - - endif -#else - outname=prefix(:lenpre)//'.out_'//pot(:lenpot) - intname=prefix(:lenpre)//'_'//pot(:lenpot)//'.int' - pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//'.pdb' - mol2name=prefix(:lenpre)//'_'//pot(:lenpot)//'.mol2' - statname=prefix(:lenpre)//'_'//pot(:lenpot)//'.stat' - if (lentmp.gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot) - & //'.stat') - rest2name=prefix(:ilen(prefix))//'.rst' - if(usampl) then - qname=prefix(:lenpre)//'_'//pot(:lenpot)//'.const' - endif -#endif -#if defined(AIX) || defined(PGI) - if (me.eq.king .or. .not. out1file) - & open(iout,file=outname,status='unknown') -c#define DEBUG -#ifdef DEBUG - if (fg_rank.gt.0) then - write (liczba,'(i3.3)') myrank/nfgtasks - write (ll,'(bz,i3.3)') fg_rank - open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll, - & status='unknown') - endif -#endif -c#undef DEBUG - if(me.eq.king) then - open(igeom,file=intname,status='unknown',position='append') - open(ipdb,file=pdbname,status='unknown') - open(imol2,file=mol2name,status='unknown') - open(istat,file=statname,status='unknown',position='append') - else -c1out open(iout,file=outname,status='unknown') - endif -#else - if (me.eq.king .or. .not.out1file) - & open(iout,file=outname,status='unknown') -c#define DEBUG -#ifdef DEBUG - if (fg_rank.gt.0) then - print "Processor",fg_rank," opening output file" - write (liczba,'(i3.3)') myrank/nfgtasks - write (ll,'(bz,i3.3)') fg_rank - open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll, - & status='unknown') - endif -#endif -c#undef DEBUG - if(me.eq.king) then - open(igeom,file=intname,status='unknown',access='append') - open(ipdb,file=pdbname,status='unknown') - open(imol2,file=mol2name,status='unknown') - open(istat,file=statname,status='unknown',access='append') - else -c1out open(iout,file=outname,status='unknown') - endif -#endif -csa csa_rbank=prefix(:lenpre)//'.CSA.rbank' -csa csa_seed=prefix(:lenpre)//'.CSA.seed' -csa csa_history=prefix(:lenpre)//'.CSA.history' -csa csa_bank=prefix(:lenpre)//'.CSA.bank' -csa csa_bank1=prefix(:lenpre)//'.CSA.bank1' -csa csa_alpha=prefix(:lenpre)//'.CSA.alpha' -csa csa_alpha1=prefix(:lenpre)//'.CSA.alpha1' -csac!bankt csa_bankt=prefix(:lenpre)//'.CSA.bankt' -csa csa_int=prefix(:lenpre)//'.int' -csa csa_bank_reminimized=prefix(:lenpre)//'.CSA.bank_reminimized' -csa csa_native_int=prefix(:lenpre)//'.CSA.native.int' -csa csa_in=prefix(:lenpre)//'.CSA.in' -c print *,"Processor",myrank,"fg_rank",fg_rank," opened files" -C Write file names - if (me.eq.king)then - write (iout,'(80(1h-))') - write (iout,'(30x,a)') "FILE ASSIGNMENT" - write (iout,'(80(1h-))') - write (iout,*) "Input file : ", - & pref_orig(:ilen(pref_orig))//'.inp' - write (iout,*) "Output file : ", - & outname(:ilen(outname)) - write (iout,*) - write (iout,*) "Sidechain potential file : ", - & sidename(:ilen(sidename)) -#ifndef OLDSCP - write (iout,*) "SCp potential file : ", - & scpname(:ilen(scpname)) -#endif - write (iout,*) "Electrostatic potential file : ", - & elename(:ilen(elename)) - write (iout,*) "Cumulant coefficient file : ", - & fouriername(:ilen(fouriername)) - write (iout,*) "Torsional parameter file : ", - & torname(:ilen(torname)) - write (iout,*) "Double torsional parameter file : ", - & tordname(:ilen(tordname)) - write (iout,*) "SCCOR parameter file : ", - & sccorname(:ilen(sccorname)) - write (iout,*) "Bond & inertia constant file : ", - & bondname(:ilen(bondname)) - write (iout,*) "Bending parameter file : ", - & thetname(:ilen(thetname)) - write (iout,*) "Rotamer parameter file : ", - & rotname(:ilen(rotname)) - write (iout,*) "Threading database : ", - & patname(:ilen(patname)) - if (lentmp.ne.0) - &write (iout,*)" DIRTMP : ", - & tmpdir(:lentmp) - write (iout,'(80(1h-))') - endif - return - end -c---------------------------------------------------------------------------- - subroutine card_concat(card) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - character*(*) card - character*80 karta,ucase - external ilen - read (inp,'(a)') karta - karta=ucase(karta) - card=' ' - do while (karta(80:80).eq.'&') - card=card(:ilen(card)+1)//karta(:79) - read (inp,'(a)') karta - karta=ucase(karta) - enddo - card=card(:ilen(card)+1)//karta - return - end -c---------------------------------------------------------------------------------- - subroutine readrst - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.MD' - open(irest2,file=rest2name,status='unknown') - read(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - read(irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - read(irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - if(usampl) then - read (irest2,*) iset - endif - close(irest2) - return - end -c--------------------------------------------------------------------------------- - subroutine read_fragments - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.MD' - include 'COMMON.CONTROL' - read(inp,*) nset,nfrag,npair,nfrag_back - if(me.eq.king.or..not.out1file) - & write(iout,*) "nset",nset," nfrag",nfrag," npair",npair, - & " nfrag_back",nfrag_back - do iset=1,nset - read(inp,*) mset(iset) - do i=1,nfrag - read(inp,*) wfrag(i,iset),ifrag(1,i,iset),ifrag(2,i,iset), - & qinfrag(i,iset) - if(me.eq.king.or..not.out1file) - & write(iout,*) "R ",i,wfrag(i,iset),ifrag(1,i,iset), - & ifrag(2,i,iset), qinfrag(i,iset) - enddo - do i=1,npair - read(inp,*) wpair(i,iset),ipair(1,i,iset),ipair(2,i,iset), - & qinpair(i,iset) - if(me.eq.king.or..not.out1file) - & write(iout,*) "R ",i,wpair(i,iset),ipair(1,i,iset), - & ipair(2,i,iset), qinpair(i,iset) - enddo - do i=1,nfrag_back - read(inp,*) wfrag_back(1,i,iset),wfrag_back(2,i,iset), - & wfrag_back(3,i,iset), - & ifrag_back(1,i,iset),ifrag_back(2,i,iset) - if(me.eq.king.or..not.out1file) - & write(iout,*) "A",i,wfrag_back(1,i,iset),wfrag_back(2,i,iset), - & wfrag_back(3,i,iset),ifrag_back(1,i,iset),ifrag_back(2,i,iset) - enddo - enddo - return - end -c------------------------------------------------------------------------------- - subroutine read_dist_constr - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.SBRIDGE' - integer ifrag_(2,100),ipair_(2,100) - double precision wfrag_(100),wpair_(100) - character*500 controlcard -c write (iout,*) "Calling read_dist_constr" -c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup -c call flush(iout) - call card_concat(controlcard) - call readi(controlcard,"NFRAG",nfrag_,0) - call readi(controlcard,"NPAIR",npair_,0) - call readi(controlcard,"NDIST",ndist_,0) - call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) - call multreadi(controlcard,"IFRAG",ifrag_(1,1),2*nfrag_,0) - call multreadi(controlcard,"IPAIR",ipair_(1,1),2*npair_,0) - call multreada(controlcard,"WFRAG",wfrag_(1),nfrag_,0.0d0) - call multreada(controlcard,"WPAIR",wpair_(1),npair_,0.0d0) -c write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_ -c write (iout,*) "IFRAG" -c do i=1,nfrag_ -c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) -c enddo -c write (iout,*) "IPAIR" -c do i=1,npair_ -c write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i) -c enddo - if (.not.refstr .and. nfrag.gt.0) then - write (iout,*) - & "ERROR: no reference structure to compute distance restraints" - write (iout,*) - & "Restraints must be specified explicitly (NDIST=number)" - stop - endif - if (nfrag.lt.2 .and. npair.gt.0) then - write (iout,*) "ERROR: Less than 2 fragments specified", - & " but distance restraints between pairs requested" - stop - endif - call flush(iout) - do i=1,nfrag_ - if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup - if (ifrag_(2,i).gt.nstart_sup+nsup-1) - & ifrag_(2,i)=nstart_sup+nsup-1 -c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) - call flush(iout) - if (wfrag_(i).gt.0.0d0) then - do j=ifrag_(1,i),ifrag_(2,i)-1 - do k=j+1,ifrag_(2,i) - write (iout,*) "j",j," k",k - ddjk=dist(j,k) - if (constr_dist.eq.1) then - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i) - else if (constr_dist.eq.2) then - if (ddjk.le.dist_cut) then - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i) - endif - else - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) - endif -#ifdef MPI - if (.not.out1file .or. me.eq.king) - & write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#else - write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#endif - enddo - enddo - endif - enddo - do i=1,npair_ - if (wpair_(i).gt.0.0d0) then - ii = ipair_(1,i) - jj = ipair_(2,i) - if (ii.gt.jj) then - itemp=ii - ii=jj - jj=itemp - endif - do j=ifrag_(1,ii),ifrag_(2,ii) - do k=ifrag_(1,jj),ifrag_(2,jj) - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - forcon(nhpb)=wpair_(i) - dhpb(nhpb)=dist(j,k) -#ifdef MPI - if (.not.out1file .or. me.eq.king) - & write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#else - write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#endif - enddo - enddo - endif - enddo - do i=1,ndist_ - read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(i),dhpb1(i), - & ibecarb(i),forcon(nhpb+1) - if (forcon(nhpb+1).gt.0.0d0) then - nhpb=nhpb+1 - if (ibecarb(i).gt.0) then - ihpb(i)=ihpb(i)+nres - jhpb(i)=jhpb(i)+nres - endif - if (dhpb(nhpb).eq.0.0d0) - & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) - endif - enddo -#ifdef MPI - if (.not.out1file .or. me.eq.king) then -#endif - do i=1,nhpb - write (iout,'(a,3i5,2f8.2,i2,f10.1)') "+dist.constr ", - & i,ihpb(i),jhpb(i),dhpb(i),dhpb1(i),ibecarb(i),forcon(i) - enddo - call flush(iout) -#ifdef MPI - endif -#endif - return - end -c------------------------------------------------------------------------------- -#ifdef WINIFL - subroutine flush(iu) - return - end -#endif -#ifdef AIX - subroutine flush(iu) - call flush_(iu) - return - end -#endif -c------------------------------------------------------------------------------ - subroutine copy_to_tmp(source) - include "DIMENSIONS" - include "COMMON.IOUNITS" - character*(*) source - character* 256 tmpfile - integer ilen - external ilen - logical ex - tmpfile=curdir(:ilen(curdir))//"/"//source(:ilen(source)) - inquire(file=tmpfile,exist=ex) - if (ex) then - write (*,*) "Copying ",tmpfile(:ilen(tmpfile)), - & " to temporary directory..." - write (*,*) "/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir - call system("/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir) - endif - return - end -c------------------------------------------------------------------------------ - subroutine move_from_tmp(source) - include "DIMENSIONS" - include "COMMON.IOUNITS" - character*(*) source - integer ilen - external ilen - write (*,*) "Moving ",source(:ilen(source)), - & " from temporary directory to working directory" - write (*,*) "/bin/mv "//source(:ilen(source))//" "//curdir - call system("/bin/mv "//source(:ilen(source))//" "//curdir) - return - end -c------------------------------------------------------------------------------ - subroutine random_init(seed) -C -C Initialize random number generator -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef AMD64 - integer*8 iseedi8 -#endif -#ifdef MPI - include 'mpif.h' - logical OKRandom, prng_restart - real*8 r1 - integer iseed_array(4) -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.THREAD' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.MCM' - include 'COMMON.MAP' - include 'COMMON.HEADER' -csa include 'COMMON.CSA' - include 'COMMON.CHAIN' - include 'COMMON.MUCA' - include 'COMMON.MD' - include 'COMMON.FFIELD' - include 'COMMON.SETUP' - iseed=-dint(dabs(seed)) - if (iseed.eq.0) then - write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Random seed undefined. The program will stop.' - write (*,'(/80(1h*)/20x,a/80(1h*))') - & 'Random seed undefined. The program will stop.' -#ifdef MPI - call mpi_finalize(mpi_comm_world,ierr) -#endif - stop 'Bad random seed.' - endif -#ifdef MPI - if (fg_rank.eq.0) then - seed=seed*(me+1)+1 -#ifdef AMD64 - iseedi8=dint(seed) - if(me.eq.king .or. .not. out1file) - & write (iout,*) 'MPI: node= ', me, ' iseed= ',iseedi8 - write (*,*) 'MPI: node= ', me, ' iseed= ',iseedi8 - OKRandom = prng_restart(me,iseedi8) -#else - do i=1,4 - tmp=65536.0d0**(4-i) - iseed_array(i) = dint(seed/tmp) - seed=seed-iseed_array(i)*tmp - enddo - if(me.eq.king .or. .not. out1file) - & write (iout,*) 'MPI: node= ', me, ' iseed(4)= ', - & (iseed_array(i),i=1,4) - write (*,*) 'MPI: node= ',me, ' iseed(4)= ', - & (iseed_array(i),i=1,4) - OKRandom = prng_restart(me,iseed_array) -#endif - if (OKRandom) then - r1=ran_number(0.0D0,1.0D0) - if(me.eq.king .or. .not. out1file) - & write (iout,*) 'ran_num',r1 - if (r1.lt.0.0d0) OKRandom=.false. - endif - if (.not.OKRandom) then - write (iout,*) 'PRNG IS NOT WORKING!!!' - print *,'PRNG IS NOT WORKING!!!' - if (me.eq.0) then - call flush(iout) - call mpi_abort(mpi_comm_world,error_msg,ierr) - stop - else - write (iout,*) 'too many processors for parallel prng' - write (*,*) 'too many processors for parallel prng' - call flush(iout) - stop - endif - endif - endif -#else - call vrndst(iseed) - write (iout,*) 'ran_num',ran_number(0.0d0,1.0d0) -#endif - return - end diff --git a/source/unres/src_MD_DFA/refsys.f b/source/unres/src_MD_DFA/refsys.f deleted file mode 100644 index ec620df..0000000 --- a/source/unres/src_MD_DFA/refsys.f +++ /dev/null @@ -1,67 +0,0 @@ - subroutine refsys(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 -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. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - logical fail - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.REFSYS' - double precision coinc/1.0D-4/,align /1.0D-7/ - fail=.false. - s1=0.0 - s2=0.0 - do 1 i=1,3 - zi=c(i,i2)-c(i,i3) - ui=c(i,i4)-c(i,i3) - s1=s1+zi*zi - s2=s2+ui*ui - z(i)=zi - 1 u(i)=ui - s1=sqrt(s1) - s2=sqrt(s2) - if (s1.gt.coinc) goto 2 - write (iout,1000) i2,i3,i1 - fail=.true. -c do 3 i=1,3 -c 3 c(i,i1)=0.0D0 - return - 2 if (s2.gt.coinc) goto 4 - write(iout,1000) i3,i4,i1 - fail=.true. - do 5 i=1,3 - 5 c(i,i1)=0.0D0 - return - 4 s1=1.0/s1 - s2=1.0/s2 - v1=z(2)*u(3)-z(3)*u(2) - v2=z(3)*u(1)-z(1)*u(3) - v3=z(1)*u(2)-z(2)*u(1) - anorm=dsqrt(v1*v1+v2*v2+v3*v3) - if (anorm.gt.align) goto 6 - write (iout,1010) i2,i3,i4,i1 - fail=.true. -c do 7 i=1,3 -c 7 c(i,i1)=0.0D0 - return - 6 anorm=1.0D0/anorm - e3(1)=v1*anorm - e3(2)=v2*anorm - e3(3)=v3*anorm - e1(1)=z(1)*s1 - e1(2)=z(2)*s1 - e1(3)=z(3)*s1 - e2(1)=e1(3)*e3(2)-e1(2)*e3(3) - e2(2)=e1(1)*e3(3)-e1(3)*e3(1) - e2(3)=e1(2)*e3(1)-e1(1)*e3(2) - 1000 format (/1x,' * * * Error - atoms',i4,' and',i4,' coincide.', - 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/unres/src_MD_DFA/regularize.F b/source/unres/src_MD_DFA/regularize.F deleted file mode 100644 index c506b8a..0000000 --- a/source/unres/src_MD_DFA/regularize.F +++ /dev/null @@ -1,76 +0,0 @@ - subroutine regularize(ncart,etot,rms,cref0,iretcode) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.HEADER' - include 'COMMON.IOUNITS' - include 'COMMON.MINIM' - double precision przes(3),obrot(3,3),fhpb0(maxdim),varia(maxvar) - double precision cref0(3,ncart) - double precision energia(0:n_ene) - logical non_conv - link_end0=link_end - do i=1,nhpb - fhpb0(i)=forcon(i) - enddo - maxit_reg=2 - print *,'Enter REGULARIZE: nnt=',nnt,' nct=',nct,' nsup=',nsup, - & ' nstart_seq=',nstart_seq,' nstart_sup',nstart_sup - write (iout,'(/a/)') 'Initial energies:' - call geom_to_var(nvar,varia) - call chainbuild - call etotal(energia(0)) - etot=energia(0) - call enerprint(energia(0)) - call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1), - & nsup,przes,obrot,non_conv) - write (iout,'(a,f10.5)') - & 'Enter REGULARIZE: Initial RMS deviation:',dsqrt(dabs(rms)) - write (*,'(a,f10.5)') - & 'Enter REGULARIZE: Initial RMS deviation:',dsqrt(dabs(rms)) - maxit0=maxit - maxfun0=maxfun - rtolf0=rtolf - maxit=100 - maxfun=200 - rtolf=1.0D-2 - do it=1,maxit_reg - print *,'Regularization: pass:',it -C Minimize with distance constraints, gradually relieving the weight. - call minimize(etot,varia,iretcode,nfun) - print *,'Etot=',Etot - if (iretcode.eq.11) return - call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1), - & nsup,przes,obrot,non_conv) - rms=dsqrt(rms) - write (iout,'(a,i2,a,f10.5,a,1pe14.5,a,i3/)') - & 'Finish pass',it,', RMS deviation:',rms,', energy',etot, - & ' SUMSL convergence',iretcode - do i=nss+1,nhpb - forcon(i)=0.1D0*forcon(i) - enddo - enddo -C Turn off the distance constraints and re-minimize energy. - print *,'Final minimization ... ' - maxit=maxit0 - maxfun=maxfun0 - rtolf=rtolf0 - link_end=min0(link_end,nss) - call minimize(etot,varia,iretcode,nfun) - print *,'Etot=',Etot - call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1),nsup, - & przes,obrot,non_conv) - rms=dsqrt(rms) - write (iout,'(a,f10.5,a,1pe14.5,a,i3/)') - & 'Final RMS deviation:',rms,' energy',etot,' SUMSL convergence', - & iretcode - link_end=link_end0 - do i=nss+1,nhpb - forcon(i)=fhpb0(i) - enddo - call var_to_geom(nvar,varia) - call chainbuild - return - end diff --git a/source/unres/src_MD_DFA/rescode.f b/source/unres/src_MD_DFA/rescode.f deleted file mode 100644 index 2973ef9..0000000 --- a/source/unres/src_MD_DFA/rescode.f +++ /dev/null @@ -1,32 +0,0 @@ - integer function rescode(iseq,nam,itype) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - character*3 nam,ucase - - if (itype.eq.0) then - - do i=1,ntyp1 - if (ucase(nam).eq.restyp(i)) then - rescode=i - return - endif - enddo - - else - - do i=1,ntyp1 - if (nam(1:1).eq.onelet(i)) then - rescode=i - return - endif - enddo - - endif - - write (iout,10) iseq,nam - stop - 10 format ('**** Error - residue',i4,' has an unresolved name ',a3) - end - diff --git a/source/unres/src_MD_DFA/rmdd.f b/source/unres/src_MD_DFA/rmdd.f deleted file mode 100644 index 799ab47..0000000 --- a/source/unres/src_MD_DFA/rmdd.f +++ /dev/null @@ -1,159 +0,0 @@ -c algorithm 611, collected algorithms from acm. -c algorithm appeared in acm-trans. math. software, vol.9, no. 4, -c dec., 1983, p. 503-524. - integer function imdcon(k) -c - integer k -c -c *** return integer machine-dependent constants *** -c -c *** k = 1 means return standard output unit number. *** -c *** k = 2 means return alternate output unit number. *** -c *** k = 3 means return input unit number. *** -c (note -- k = 2, 3 are used only by test programs.) -c -c +++ port version follows... -c external i1mach -c integer i1mach -c integer mdperm(3) -c data mdperm(1)/2/, mdperm(2)/4/, mdperm(3)/1/ -c imdcon = i1mach(mdperm(k)) -c +++ end of port version +++ -c -c +++ non-port version follows... - integer mdcon(3) - data mdcon(1)/6/, mdcon(2)/8/, mdcon(3)/5/ - imdcon = mdcon(k) -c +++ end of non-port version +++ -c - 999 return -c *** last card of imdcon follows *** - end - double precision function rmdcon(k) -c -c *** return machine dependent constants used by nl2sol *** -c -c +++ comments below contain data statements for various machines. +++ -c +++ to convert to another machine, place a c in column 1 of the +++ -c +++ data statement line(s) that correspond to the current machine +++ -c +++ and remove the c from column 1 of the data statement line(s) +++ -c +++ that correspond to the new machine. +++ -c - integer k -c -c *** the constant returned depends on k... -c -c *** k = 1... smallest pos. eta such that -eta exists. -c *** k = 2... square root of eta. -c *** k = 3... unit roundoff = smallest pos. no. machep such -c *** that 1 + machep .gt. 1 .and. 1 - machep .lt. 1. -c *** k = 4... square root of machep. -c *** k = 5... square root of big (see k = 6). -c *** k = 6... largest machine no. big such that -big exists. -c - double precision big, eta, machep - integer bigi(4), etai(4), machei(4) -c/+ - double precision dsqrt -c/ - equivalence (big,bigi(1)), (eta,etai(1)), (machep,machei(1)) -c -c +++ ibm 360, ibm 370, or xerox +++ -c -c data big/z7fffffffffffffff/, eta/z0010000000000000/, -c 1 machep/z3410000000000000/ -c -c +++ data general +++ -c -c data big/0.7237005577d+76/, eta/0.5397605347d-78/, -c 1 machep/2.22044605d-16/ -c -c +++ dec 11 +++ -c -c data big/1.7d+38/, eta/2.938735878d-39/, machep/2.775557562d-17/ -c -c +++ hp3000 +++ -c -c data big/1.157920892d+77/, eta/8.636168556d-78/, -c 1 machep/5.551115124d-17/ -c -c +++ honeywell +++ -c -c data big/1.69d+38/, eta/5.9d-39/, machep/2.1680435d-19/ -c -c +++ dec10 +++ -c -c data big/"377777100000000000000000/, -c 1 eta/"002400400000000000000000/, -c 2 machep/"104400000000000000000000/ -c -c +++ burroughs +++ -c -c data big/o0777777777777777,o7777777777777777/, -c 1 eta/o1771000000000000,o7770000000000000/, -c 2 machep/o1451000000000000,o0000000000000000/ -c -c +++ control data +++ -c -c data big/37767777777777777777b,37167777777777777777b/, -c 1 eta/00014000000000000000b,00000000000000000000b/, -c 2 machep/15614000000000000000b,15010000000000000000b/ -c -c +++ prime +++ -c -c data big/1.0d+9786/, eta/1.0d-9860/, machep/1.4210855d-14/ -c -c +++ univac +++ -c -c data big/8.988d+307/, eta/1.2d-308/, machep/1.734723476d-18/ -c -c +++ vax +++ -c - data big/1.7d+38/, eta/2.939d-39/, machep/1.3877788d-17/ -c -c +++ cray 1 +++ -c -c data bigi(1)/577767777777777777777b/, -c 1 bigi(2)/000007777777777777776b/, -c 2 etai(1)/200004000000000000000b/, -c 3 etai(2)/000000000000000000000b/, -c 4 machei(1)/377224000000000000000b/, -c 5 machei(2)/000000000000000000000b/ -c -c +++ port library -- requires more than just a data statement... +++ -c -c external d1mach -c double precision d1mach, zero -c data big/0.d+0/, eta/0.d+0/, machep/0.d+0/, zero/0.d+0/ -c if (big .gt. zero) go to 1 -c big = d1mach(2) -c eta = d1mach(1) -c machep = d1mach(4) -c1 continue -c -c +++ end of port +++ -c -c------------------------------- body -------------------------------- -c - go to (10, 20, 30, 40, 50, 60), k -c - 10 rmdcon = eta - go to 999 -c - 20 rmdcon = dsqrt(256.d+0*eta)/16.d+0 - go to 999 -c - 30 rmdcon = machep - go to 999 -c - 40 rmdcon = dsqrt(machep) - go to 999 -c - 50 rmdcon = dsqrt(big/256.d+0)*16.d+0 - go to 999 -c - 60 rmdcon = big -c - 999 return -c *** last card of rmdcon follows *** - end diff --git a/source/unres/src_MD_DFA/rmsd.F b/source/unres/src_MD_DFA/rmsd.F deleted file mode 100644 index 52e7b37..0000000 --- a/source/unres/src_MD_DFA/rmsd.F +++ /dev/null @@ -1,140 +0,0 @@ - subroutine rms_nac_nnc(rms,frac,frac_nn,co,lprn) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.CONTACTS' - include 'COMMON.IOUNITS' - double precision przes(3),obr(3,3) - logical non_conv,lprn -c call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes, -c & obr,non_conv) -c rms=dsqrt(rms) - call rmsd(rms) - call contact(.false.,ncont,icont,co) - frac=contact_fract(ncont,ncont_ref,icont,icont_ref) - frac_nn=contact_fract_nn(ncont,ncont_ref,icont,icont_ref) - if (lprn) write (iout,'(a,f8.3/a,f8.3/a,f8.3/a,f8.3)') - & 'RMS deviation from the reference structure:',rms, - & ' % of native contacts:',frac*100, - & ' % of nonnative contacts:',frac_nn*100, - & ' contact order:',co - - return - end -c--------------------------------------------------------------------------- - subroutine rmsd(drms) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.INTERACT' - logical non_conv - double precision przes(3),obrot(3,3) - double precision ccopy(3,maxres2+2),crefcopy(3,maxres2+2) - - iatom=0 -c print *,"nz_start",nz_start," nz_end",nz_end - do i=nz_start,nz_end - iatom=iatom+1 - iti=itype(i) - do k=1,3 - ccopy(k,iatom)=c(k,i+nstart_seq-nstart_sup) - crefcopy(k,iatom)=cref(k,i) - enddo - if (iz_sc.eq.1.and.iti.ne.10) then - iatom=iatom+1 - do k=1,3 - ccopy(k,iatom)=c(k,nres+i+nstart_seq-nstart_sup) - crefcopy(k,iatom)=cref(k,nres+i) - enddo - endif - enddo - -c ----- diagnostics -c write (iout,*) 'Ccopy and CREFcopy' -c print '(i5,3f10.5,5x,3f10.5)',(k,(ccopy(j,k),j=1,3), -c & (crefcopy(j,k),j=1,3),k=1,iatom) -c write (iout,'(i5,3f10.5,5x,3f10.5)') (k,(ccopy(j,k),j=1,3), -c & (crefcopy(j,k),j=1,3),k=1,iatom) -c ----- end diagnostics - - call fitsq(roznica,ccopy(1,1),crefcopy(1,1),iatom, - & przes,obrot,non_conv) - if (non_conv) then - print *,'Problems in FITSQ!!! rmsd' - write (iout,*) 'Problems in FITSQ!!! rmsd' - print *,'Ccopy and CREFcopy' - write (iout,*) 'Ccopy and CREFcopy' - print '(i5,3f10.5,5x,3f10.5)',(k,(ccopy(j,k),j=1,3), - & (crefcopy(j,k),j=1,3),k=1,iatom) - write (iout,'(i5,3f10.5,5x,3f10.5)') (k,(ccopy(j,k),j=1,3), - & (crefcopy(j,k),j=1,3),k=1,iatom) -#ifdef MPI -c call mpi_abort(mpi_comm_world,ierror,ierrcode) - roznica=100.0 -#else - stop -#endif - endif - drms=dsqrt(dabs(roznica)) -c ---- diagnostics -c write (iout,*) "rms",drms -c ---- end diagnostics - return - end - -c-------------------------------------------- - subroutine rmsd_csa(drms) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.INTERACT' - logical non_conv - double precision przes(3),obrot(3,3) - double precision ccopy(3,maxres2+2),crefcopy(3,maxres2+2) - - iatom=0 - do i=nz_start,nz_end - iatom=iatom+1 - iti=itype(i) - do k=1,3 - ccopy(k,iatom)=c(k,i) - crefcopy(k,iatom)=crefjlee(k,i) - enddo - if (iz_sc.eq.1.and.iti.ne.10) then - iatom=iatom+1 - do k=1,3 - ccopy(k,iatom)=c(k,nres+i) - crefcopy(k,iatom)=crefjlee(k,nres+i) - enddo - endif - enddo - - call fitsq(roznica,ccopy(1,1),crefcopy(1,1),iatom, - & przes,obrot,non_conv) - if (non_conv) then - print *,'Problems in FITSQ!!! rmsd_csa' - write (iout,*) 'Problems in FITSQ!!! rmsd_csa' - print *,'Ccopy and CREFcopy' - write (iout,*) 'Ccopy and CREFcopy' - print '(i5,3f10.5,5x,3f10.5)',(k,(ccopy(j,k),j=1,3), - & (crefcopy(j,k),j=1,3),k=1,iatom) - write (iout,'(i5,3f10.5,5x,3f10.5)') (k,(ccopy(j,k),j=1,3), - & (crefcopy(j,k),j=1,3),k=1,iatom) -#ifdef MPI - call mpi_abort(mpi_comm_world,ierror,ierrcode) -#else - stop -#endif - endif - drms=dsqrt(dabs(roznica)) - return - end - diff --git a/source/unres/src_MD_DFA/sc_move.F b/source/unres/src_MD_DFA/sc_move.F deleted file mode 100644 index b6837fd..0000000 --- a/source/unres/src_MD_DFA/sc_move.F +++ /dev/null @@ -1,823 +0,0 @@ - subroutine sc_move(n_start,n_end,n_maxtry,e_drop, - + n_fun,etot) -c Perform a quick search over side-chain arrangments (over -c residues n_start to n_end) for a given (frozen) CA trace -c Only side-chains are minimized (at most n_maxtry times each), -c not CA positions -c Stops if energy drops by e_drop, otherwise tries all residues -c in the given range -c If there is an energy drop, full minimization may be useful -c n_start, n_end CAN be modified by this routine, but only if -c out of bounds (n_start <= 1, n_end >= nres, n_start < n_end) -c NOTE: this move should never increase the energy -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.HEADER' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - -c External functions - integer iran_num - external iran_num - -c Input arguments - integer n_start,n_end,n_maxtry - double precision e_drop - -c Output arguments - integer n_fun - double precision etot - -c Local variables - double precision energy(0:n_ene) - double precision cur_alph(2:nres-1),cur_omeg(2:nres-1) - double precision orig_e,cur_e - integer n,n_steps,n_first,n_cur,n_tot,i - double precision orig_w(n_ene) - double precision wtime - - -c Set non side-chain weights to zero (minimization is faster) -c NOTE: e(2) does not actually depend on the side-chain, only CA - orig_w(2)=wscp - orig_w(3)=welec - orig_w(4)=wcorr - orig_w(5)=wcorr5 - orig_w(6)=wcorr6 - orig_w(7)=wel_loc - orig_w(8)=wturn3 - orig_w(9)=wturn4 - orig_w(10)=wturn6 - orig_w(11)=wang - orig_w(13)=wtor - orig_w(14)=wtor_d - orig_w(15)=wvdwpp - - wscp=0.D0 - welec=0.D0 - wcorr=0.D0 - wcorr5=0.D0 - wcorr6=0.D0 - wel_loc=0.D0 - wturn3=0.D0 - wturn4=0.D0 - wturn6=0.D0 - wang=0.D0 - wtor=0.D0 - wtor_d=0.D0 - wvdwpp=0.D0 - -c Make sure n_start, n_end are within proper range - if (n_start.lt.2) n_start=2 - if (n_end.gt.nres-1) n_end=nres-1 -crc if (n_start.lt.n_end) then - if (n_start.gt.n_end) then - n_start=2 - n_end=nres-1 - endif - -c Save the initial values of energy and coordinates -cd call chainbuild -cd call etotal(energy) -cd write (iout,*) 'start sc ene',energy(0) -cd call enerprint(energy(0)) -crc etot=energy(0) - n_fun=0 -crc orig_e=etot -crc cur_e=orig_e -crc do i=2,nres-1 -crc cur_alph(i)=alph(i) -crc cur_omeg(i)=omeg(i) -crc enddo - -ct wtime=MPI_WTIME() -c Try (one by one) all specified residues, starting from a -c random position in sequence -c Stop early if the energy has decreased by at least e_drop - n_tot=n_end-n_start+1 - n_first=iran_num(0,n_tot-1) - n_steps=0 - n=0 -crc do while (n.lt.n_tot .and. orig_e-etot.lt.e_drop) - do while (n.lt.n_tot) - n_cur=n_start+mod(n_first+n,n_tot) - call single_sc_move(n_cur,n_maxtry,e_drop, - + n_steps,n_fun,etot) -c If a lower energy was found, update the current structure... -crc if (etot.lt.cur_e) then -crc cur_e=etot -crc do i=2,nres-1 -crc cur_alph(i)=alph(i) -crc cur_omeg(i)=omeg(i) -crc enddo -crc else -c ...else revert to the previous one -crc etot=cur_e -crc do i=2,nres-1 -crc alph(i)=cur_alph(i) -crc omeg(i)=cur_omeg(i) -crc enddo -crc endif - n=n+1 -cd -cd call chainbuild -cd call etotal(energy) -cd print *,'running',n,energy(0) - enddo - -cd call chainbuild -cd call etotal(energy) -cd write (iout,*) 'end sc ene',energy(0) - -c Put the original weights back to calculate the full energy - wscp=orig_w(2) - welec=orig_w(3) - wcorr=orig_w(4) - wcorr5=orig_w(5) - wcorr6=orig_w(6) - wel_loc=orig_w(7) - wturn3=orig_w(8) - wturn4=orig_w(9) - wturn6=orig_w(10) - wang=orig_w(11) - wtor=orig_w(13) - wtor_d=orig_w(14) - wvdwpp=orig_w(15) - -crc n_fun=n_fun+1 -ct write (iout,*) 'sc_local time= ',MPI_WTIME()-wtime - return - end - -c------------------------------------------------------------- - - subroutine single_sc_move(res_pick,n_maxtry,e_drop, - + n_steps,n_fun,e_sc) -c Perturb one side-chain (res_pick) and minimize the -c neighbouring region, keeping all CA's and non-neighbouring -c side-chains fixed -c Try until e_drop energy improvement is achieved, or n_maxtry -c attempts have been made -c At the start, e_sc should contain the side-chain-only energy(0) -c nsteps and nfun for this move are ADDED to n_steps and n_fun -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.CHAIN' - include 'COMMON.MINIM' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - -c External functions - double precision dist - external dist - -c Input arguments - integer res_pick,n_maxtry - double precision e_drop - -c Input/Output arguments - integer n_steps,n_fun - double precision e_sc - -c Local variables - logical fail - integer i,j - integer nres_moved - integer iretcode,loc_nfun,orig_maxfun,n_try - double precision sc_dist,sc_dist_cutoff - double precision energy(0:n_ene),orig_e,cur_e - double precision evdw,escloc - double precision cur_alph(2:nres-1),cur_omeg(2:nres-1) - double precision var(maxvar) - - double precision orig_theta(1:nres),orig_phi(1:nres), - + orig_alph(1:nres),orig_omeg(1:nres) - - -c Define what is meant by "neighbouring side-chain" - sc_dist_cutoff=5.0D0 - -c Don't do glycine or ends - i=itype(res_pick) - if (i.eq.10 .or. i.eq.21) return - -c Freeze everything (later will relax only selected side-chains) - mask_r=.true. - do i=1,nres - mask_phi(i)=0 - mask_theta(i)=0 - mask_side(i)=0 - enddo - -c Find the neighbours of the side-chain to move -c and save initial variables -crc orig_e=e_sc -crc cur_e=orig_e - nres_moved=0 - do i=2,nres-1 -c Don't do glycine (itype(j)==10) - if (itype(i).ne.10) then - sc_dist=dist(nres+i,nres+res_pick) - else - sc_dist=sc_dist_cutoff - endif - if (sc_dist.lt.sc_dist_cutoff) then - nres_moved=nres_moved+1 - mask_side(i)=1 - cur_alph(i)=alph(i) - cur_omeg(i)=omeg(i) - endif - enddo - - call chainbuild - call egb1(evdw) - call esc(escloc) - e_sc=wsc*evdw+wscloc*escloc -cd call etotal(energy) -cd print *,'new ',(energy(k),k=0,n_ene) - orig_e=e_sc - cur_e=orig_e - - n_try=0 - do while (n_try.lt.n_maxtry .and. orig_e-cur_e.lt.e_drop) -c Move the selected residue (don't worry if it fails) - call gen_side(itype(res_pick),theta(res_pick+1), - + alph(res_pick),omeg(res_pick),fail) - -c Minimize the side-chains starting from the new arrangement - call geom_to_var(nvar,var) - orig_maxfun=maxfun - maxfun=7 - -crc do i=1,nres -crc orig_theta(i)=theta(i) -crc orig_phi(i)=phi(i) -crc orig_alph(i)=alph(i) -crc orig_omeg(i)=omeg(i) -crc enddo - - call minimize_sc1(e_sc,var,iretcode,loc_nfun) - -cv write(*,'(2i3,2f12.5,2i3)') -cv & res_pick,nres_moved,orig_e,e_sc-cur_e, -cv & iretcode,loc_nfun - -c$$$ if (iretcode.eq.8) then -c$$$ write(iout,*)'Coordinates just after code 8' -c$$$ call chainbuild -c$$$ call all_varout -c$$$ call flush(iout) -c$$$ do i=1,nres -c$$$ theta(i)=orig_theta(i) -c$$$ phi(i)=orig_phi(i) -c$$$ alph(i)=orig_alph(i) -c$$$ omeg(i)=orig_omeg(i) -c$$$ enddo -c$$$ write(iout,*)'Coordinates just before code 8' -c$$$ call chainbuild -c$$$ call all_varout -c$$$ call flush(iout) -c$$$ endif - - n_fun=n_fun+loc_nfun - maxfun=orig_maxfun - call var_to_geom(nvar,var) - -c If a lower energy was found, update the current structure... - if (e_sc.lt.cur_e) then -cv call chainbuild -cv call etotal(energy) -cd call egb1(evdw) -cd call esc(escloc) -cd e_sc1=wsc*evdw+wscloc*escloc -cd print *,' new',e_sc1,energy(0) -cv print *,'new ',energy(0) -cd call enerprint(energy(0)) - cur_e=e_sc - do i=2,nres-1 - if (mask_side(i).eq.1) then - cur_alph(i)=alph(i) - cur_omeg(i)=omeg(i) - endif - enddo - else -c ...else revert to the previous one - e_sc=cur_e - do i=2,nres-1 - if (mask_side(i).eq.1) then - alph(i)=cur_alph(i) - omeg(i)=cur_omeg(i) - endif - enddo - endif - n_try=n_try+1 - - enddo - n_steps=n_steps+n_try - -c Reset the minimization mask_r to false - mask_r=.false. - - return - end - -c------------------------------------------------------------- - - subroutine sc_minimize(etot,iretcode,nfun) -c Minimizes side-chains only, leaving backbone frozen -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - -c Output arguments - double precision etot - integer iretcode,nfun - -c Local variables - integer i - double precision orig_w(n_ene),energy(0:n_ene) - double precision var(maxvar) - - -c Set non side-chain weights to zero (minimization is faster) -c NOTE: e(2) does not actually depend on the side-chain, only CA - orig_w(2)=wscp - orig_w(3)=welec - orig_w(4)=wcorr - orig_w(5)=wcorr5 - orig_w(6)=wcorr6 - orig_w(7)=wel_loc - orig_w(8)=wturn3 - orig_w(9)=wturn4 - orig_w(10)=wturn6 - orig_w(11)=wang - orig_w(13)=wtor - orig_w(14)=wtor_d - - wscp=0.D0 - welec=0.D0 - wcorr=0.D0 - wcorr5=0.D0 - wcorr6=0.D0 - wel_loc=0.D0 - wturn3=0.D0 - wturn4=0.D0 - wturn6=0.D0 - wang=0.D0 - wtor=0.D0 - wtor_d=0.D0 - -c Prepare to freeze backbone - do i=1,nres - mask_phi(i)=0 - mask_theta(i)=0 - mask_side(i)=1 - enddo - -c Minimize the side-chains - mask_r=.true. - call geom_to_var(nvar,var) - call minimize(etot,var,iretcode,nfun) - call var_to_geom(nvar,var) - mask_r=.false. - -c Put the original weights back and calculate the full energy - wscp=orig_w(2) - welec=orig_w(3) - wcorr=orig_w(4) - wcorr5=orig_w(5) - wcorr6=orig_w(6) - wel_loc=orig_w(7) - wturn3=orig_w(8) - wturn4=orig_w(9) - wturn6=orig_w(10) - wang=orig_w(11) - wtor=orig_w(13) - wtor_d=orig_w(14) - - call chainbuild - call etotal(energy) - etot=energy(0) - - return - end - -c------------------------------------------------------------- - subroutine minimize_sc1(etot,x,iretcode,nfun) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.MINIM' - common /srutu/ icall - dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) - double precision energia(0:n_ene) - external func,gradient,fdum - external func_restr1,grad_restr1 - logical not_done,change,reduce - common /przechowalnia/ v - - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit -c iv(21)=iout - iv(21)=0 -* 1 means to print out result - iv(22)=0 -* 1 means to print out summary stats - iv(23)=0 -* 1 means to print initial x and d - iv(24)=0 -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -c v(25)=4.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo - IF (mask_r) THEN - call x2xx(x,xx,nvar_restr) - call sumsl(nvar_restr,d,xx,func_restr1,grad_restr1, - & iv,liv,lv,v,idum,rdum,fdum) - call xx2x(x,xx) - ELSE - call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) - ENDIF - etot=v(10) - iretcode=iv(1) - nfun=iv(6) - - return - end -************************************************************************ - subroutine func_restr1(n,x,nf,f,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - include 'COMMON.INTERACT' - include 'COMMON.TIME1' - common /chuju/ jjj - double precision energia(0:n_ene),evdw,escloc - integer jjj - double precision ufparm,e1,e2 - external ufparm - integer uiparm(1) - real*8 urparm(1) - dimension x(maxvar) - nfl=nf - icg=mod(nf,2)+1 - -#ifdef OSF -c Intercept NaNs in the coordinates, before calling etotal - x_sum=0.D0 - do i=1,n - x_sum=x_sum+x(i) - enddo - FOUND_NAN=.false. - if (x_sum.ne.x_sum) then - write(iout,*)" *** func_restr1 : Found NaN in coordinates" - f=1.0D+73 - FOUND_NAN=.true. - return - endif -#endif - - call var_to_geom_restr(n,x) - call zerograd - call chainbuild -cd write (iout,*) 'ETOTAL called from FUNC' - call egb1(evdw) - call esc(escloc) - f=wsc*evdw+wscloc*escloc -cd call etotal(energia(0)) -cd f=wsc*energia(1)+wscloc*energia(12) -cd print *,f,evdw,escloc,energia(0) -C -C Sum up the components of the Cartesian gradient. -C - do i=1,nct - do j=1,3 - gradx(j,i,icg)=wsc*gvdwx(j,i) - enddo - enddo - - return - end -c------------------------------------------------------- - subroutine grad_restr1(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - external ufparm - integer uiparm(1) - double precision urparm(1) - dimension x(maxvar),g(maxvar) - - icg=mod(nf,2)+1 - if (nf-nfl+1) 20,30,40 - 20 call func_restr1(n,x,nf,f,uiparm,urparm,ufparm) -c write (iout,*) 'grad 20' - if (nf.eq.0) return - goto 40 - 30 call var_to_geom_restr(n,x) - call chainbuild -C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartder -C -C Convert the Cartesian gradient into internal-coordinate gradient. -C - - ig=0 - ind=nres-2 - do i=2,nres-2 - IF (mask_phi(i+2).eq.1) THEN - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) - enddo - enddo - ig=ig+1 - g(ig)=gphii - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - - ind=0 - do i=1,nres-2 - IF (mask_theta(i+2).eq.1) THEN - ig=ig+1 - gthetai=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) - enddo - enddo - g(ig)=gthetai - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - galphai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - g(ig)=galphai - ENDIF - endif - enddo - - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - gomegai=0.0D0 - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ig)=gomegai - ENDIF - endif - enddo - -C -C Add the components corresponding to local energy terms. -C - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - endif - enddo - enddo - -cd do i=1,ig -cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) -cd enddo - return - end -C----------------------------------------------------------------------------- - subroutine egb1(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - include 'COMMON.CONTROL' - logical lprn - evdw=0.0D0 -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.true. - ind=0 - do i=iatsc_s,iatsc_e - - - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) - dsci_inv=dsc_inv(itypi) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN - ind=ind+1 - itypj=itype(j) - dscj_inv=dsc_inv(itypj) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) -C For diagnostics only!!! -c chi1=0.0D0 -c chi2=0.0D0 -c chi12=0.0D0 -c chip1=0.0D0 -c chip2=0.0D0 -c chip12=0.0D0 -c alf1=0.0D0 -c alf2=0.0D0 -c alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 -cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & epsi,sigm,chi1,chi2,chip1,chip2, -cd & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, -cd & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, -cd & evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij - -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad - ENDIF - enddo ! j - enddo ! iint - enddo ! i - end -C----------------------------------------------------------------------------- diff --git a/source/unres/src_MD_DFA/sizes.i b/source/unres/src_MD_DFA/sizes.i deleted file mode 100644 index 45c44ff..0000000 --- a/source/unres/src_MD_DFA/sizes.i +++ /dev/null @@ -1,83 +0,0 @@ -c -c -c ################################################### -c ## COPYRIGHT (C) 1992 by Jay William Ponder ## -c ## All Rights Reserved ## -c ################################################### -c -c ############################################################# -c ## ## -c ## sizes.i -- parameter values to set array dimensions ## -c ## ## -c ############################################################# -c -c -c "sizes.i" sets values for critical array dimensions used -c throughout the software; these parameters will fix the size -c of the largest systems that can be handled; values too large -c for the computer's memory and/or swap space to accomodate -c will result in poor performance or outright failure -c -c parameter: maximum allowed number of: -c -c maxatm atoms in the molecular system -c maxval atoms directly bonded to an atom -c maxgrp user-defined groups of atoms -c maxtyp force field atom type definitions -c maxclass force field atom class definitions -c maxkey lines in the keyword file -c maxrot bonds for torsional rotation -c maxvar optimization variables (vector storage) -c maxopt optimization variables (matrix storage) -c maxhess off-diagonal Hessian elements -c maxlight sites for method of lights neighbors -c maxvib vibrational frequencies -c maxgeo distance geometry points -c maxcell unit cells in replicated crystal -c maxring 3-, 4-, or 5-membered rings -c maxfix geometric restraints -c maxbio biopolymer atom definitions -c maxres residues in the macromolecule -c maxamino amino acid residue types -c maxnuc nucleic acid residue types -c maxbnd covalent bonds in molecular system -c maxang bond angles in molecular system -c maxtors torsional angles in molecular system -c maxpi atoms in conjugated pisystem -c maxpib covalent bonds involving pisystem -c maxpit torsional angles involving pisystem -c -c - integer maxatm,maxval,maxgrp - integer maxtyp,maxclass,maxkey - integer maxrot,maxopt - integer maxhess,maxlight,maxvib - integer maxgeo,maxcell,maxring - integer maxfix,maxbio - integer maxamino,maxnuc,maxbnd - integer maxang,maxtors,maxpi - integer maxpib,maxpit - parameter (maxatm=maxres2) - parameter (maxval=8) - parameter (maxgrp=1000) - parameter (maxtyp=3000) - parameter (maxclass=500) - parameter (maxkey=10000) - parameter (maxrot=1000) - parameter (maxopt=1000) - parameter (maxhess=1000000) - parameter (maxlight=8*maxatm) - parameter (maxvib=1000) - parameter (maxgeo=1000) - parameter (maxcell=10000) - parameter (maxring=10000) - parameter (maxfix=10000) - parameter (maxbio=10000) - parameter (maxamino=31) - parameter (maxnuc=12) - parameter (maxbnd=2*maxatm) - parameter (maxang=3*maxatm) - parameter (maxtors=4*maxatm) - parameter (maxpi=100) - parameter (maxpib=2*maxpi) - parameter (maxpit=4*maxpi) diff --git a/source/unres/src_MD_DFA/sort.f b/source/unres/src_MD_DFA/sort.f deleted file mode 100644 index 46b43d9..0000000 --- a/source/unres/src_MD_DFA/sort.f +++ /dev/null @@ -1,589 +0,0 @@ -c -c -c ################################################### -c ## COPYRIGHT (C) 1990 by Jay William Ponder ## -c ## All Rights Reserved ## -c ################################################### -c -c ######################################################### -c ## ## -c ## subroutine sort -- heapsort of an integer array ## -c ## ## -c ######################################################### -c -c -c "sort" takes an input list of integers and sorts it -c into ascending order using the Heapsort algorithm -c -c - subroutine sort (n,list) - implicit none - integer i,j,k,n - integer index,lists - integer list(*) -c -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end -c -c -c ############################################################## -c ## ## -c ## subroutine sort2 -- heapsort of real array with keys ## -c ## ## -c ############################################################## -c -c -c "sort2" takes an input list of reals and sorts it -c into ascending order using the Heapsort algorithm; -c it also returns a key into the original ordering -c -c - subroutine sort2 (n,list,key) - implicit none - integer i,j,k,n - integer index,keys - integer key(*) - real*8 lists - real*8 list(*) -c -c -c initialize index into the original ordering -c - do i = 1, n - key(i) = i - end do -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - keys = key(k) - else - lists = list(index) - keys = key(index) - list(index) = list(1) - key(index) = key(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - key(1) = keys - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - key(i) = key(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - key(i) = keys - end do - return - end -c -c -c ################################################################# -c ## ## -c ## subroutine sort3 -- heapsort of integer array with keys ## -c ## ## -c ################################################################# -c -c -c "sort3" takes an input list of integers and sorts it -c into ascending order using the Heapsort algorithm; -c it also returns a key into the original ordering -c -c - subroutine sort3 (n,list,key) - implicit none - integer i,j,k,n - integer index - integer lists - integer keys - integer list(*) - integer key(*) -c -c -c initialize index into the original ordering -c - do i = 1, n - key(i) = i - end do -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - keys = key(k) - else - lists = list(index) - keys = key(index) - list(index) = list(1) - key(index) = key(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - key(1) = keys - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - key(i) = key(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - key(i) = keys - end do - return - end -c -c -c ################################################################# -c ## ## -c ## subroutine sort4 -- heapsort of integer absolute values ## -c ## ## -c ################################################################# -c -c -c "sort4" takes an input list of integers and sorts it into -c ascending absolute value using the Heapsort algorithm -c -c - subroutine sort4 (n,list) - implicit none - integer i,j,k,n - integer index - integer lists - integer list(*) -c -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (abs(list(j)) .lt. abs(list(j+1))) j = j + 1 - end if - if (abs(lists) .lt. abs(list(j))) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end -c -c -c ################################################################ -c ## ## -c ## subroutine sort5 -- heapsort of integer array modulo m ## -c ## ## -c ################################################################ -c -c -c "sort5" takes an input list of integers and sorts it -c into ascending order based on each value modulo "m" -c -c - subroutine sort5 (n,list,m) - implicit none - integer i,j,k,m,n - integer index,smod - integer jmod,j1mod - integer lists - integer list(*) -c -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - jmod = mod(list(j),m) - j1mod = mod(list(j+1),m) - if (jmod .lt. j1mod) then - j = j + 1 - else if (jmod.eq.j1mod .and. list(j).lt.list(j+1)) then - j = j + 1 - end if - end if - smod = mod(lists,m) - jmod = mod(list(j),m) - if (smod .lt. jmod) then - list(i) = list(j) - i = j - j = j + j - else if (smod.eq.jmod .and. lists.lt.list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end -c -c -c ############################################################# -c ## ## -c ## subroutine sort6 -- heapsort of a text string array ## -c ## ## -c ############################################################# -c -c -c "sort6" takes an input list of character strings and sorts -c it into alphabetical order using the Heapsort algorithm -c -c - subroutine sort6 (n,list) - implicit none - integer i,j,k,n - integer index - character*256 lists - character*(*) list(*) -c -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end -c -c -c ################################################################ -c ## ## -c ## subroutine sort7 -- heapsort of text strings with keys ## -c ## ## -c ################################################################ -c -c -c "sort7" takes an input list of character strings and sorts it -c into alphabetical order using the Heapsort algorithm; it also -c returns a key into the original ordering -c -c - subroutine sort7 (n,list,key) - implicit none - integer i,j,k,n - integer index - integer keys - integer key(*) - character*256 lists - character*(*) list(*) -c -c -c initialize index into the original ordering -c - do i = 1, n - key(i) = i - end do -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - keys = key(k) - else - lists = list(index) - keys = key(index) - list(index) = list(1) - key(index) = key(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists - key(1) = keys - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - key(i) = key(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - key(i) = keys - end do - return - end -c -c -c ######################################################### -c ## ## -c ## subroutine sort8 -- heapsort to unique integers ## -c ## ## -c ######################################################### -c -c -c "sort8" takes an input list of integers and sorts it into -c ascending order using the Heapsort algorithm, duplicate -c values are removed from the final sorted list -c -c - subroutine sort8 (n,list) - implicit none - integer i,j,k,n - integer index - integer lists - integer list(*) -c -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists -c -c remove duplicate values from final list -c - j = 1 - do i = 2, n - if (list(i-1) .ne. list(i)) then - j = j + 1 - list(j) = list(i) - end if - end do - if (j .lt. n) n = j - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end -c -c -c ############################################################# -c ## ## -c ## subroutine sort9 -- heapsort to unique text strings ## -c ## ## -c ############################################################# -c -c -c "sort9" takes an input list of character strings and sorts -c it into alphabetical order using the Heapsort algorithm, -c duplicate values are removed from the final sorted list -c -c - subroutine sort9 (n,list) - implicit none - integer i,j,k,n - integer index - character*256 lists - character*(*) list(*) -c -c -c perform the heapsort of the input list -c - k = n/2 + 1 - index = n - dowhile (n .gt. 1) - if (k .gt. 1) then - k = k - 1 - lists = list(k) - else - lists = list(index) - list(index) = list(1) - index = index - 1 - if (index .le. 1) then - list(1) = lists -c -c remove duplicate values from final list -c - j = 1 - do i = 2, n - if (list(i-1) .ne. list(i)) then - j = j + 1 - list(j) = list(i) - end if - end do - if (j .lt. n) n = j - return - end if - end if - i = k - j = k + k - dowhile (j .le. index) - if (j .lt. index) then - if (list(j) .lt. list(j+1)) j = j + 1 - end if - if (lists .lt. list(j)) then - list(i) = list(j) - i = j - j = j + j - else - j = index + 1 - end if - end do - list(i) = lists - end do - return - end diff --git a/source/unres/src_MD_DFA/stochfric.F b/source/unres/src_MD_DFA/stochfric.F deleted file mode 100644 index 74eda61..0000000 --- a/source/unres/src_MD_DFA/stochfric.F +++ /dev/null @@ -1,626 +0,0 @@ - subroutine friction_force - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.IOUNITS' - double precision gamvec(MAXRES6) - common /syfek/ gamvec - double precision vv(3),vvtot(3,maxres),v_work(MAXRES6), - & ginvfric(maxres2,maxres2) - common /przechowalnia/ ginvfric - - logical lprn /.false./, checkmode /.false./ - - do i=0,MAXRES2 - do j=1,3 - friction(j,i)=0.0d0 - enddo - enddo - - do j=1,3 - d_t_work(j)=d_t(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - d_t_work(ind+j)=d_t(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - d_t_work(ind+j)=d_t(j,i+nres) - enddo - ind=ind+3 - endif - enddo - - call fricmat_mult(d_t_work,fric_work) - - if (.not.checkmode) return - - if (lprn) then - write (iout,*) "d_t_work and fric_work" - do i=1,3*dimen - write (iout,'(i3,2e15.5)') i,d_t_work(i),fric_work(i) - enddo - endif - do j=1,3 - friction(j,0)=fric_work(j) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - friction(j,i)=fric_work(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - friction(j,i+nres)=fric_work(ind+j) - enddo - ind=ind+3 - endif - enddo - if (lprn) then - write(iout,*) "Friction backbone" - do i=0,nct-1 - write(iout,'(i5,3e15.5,5x,3e15.5)') - & i,(friction(j,i),j=1,3),(d_t(j,i),j=1,3) - enddo - write(iout,*) "Friction side chain" - do i=nnt,nct - write(iout,'(i5,3e15.5,5x,3e15.5)') - & i,(friction(j,i+nres),j=1,3),(d_t(j,i+nres),j=1,3) - enddo - endif - if (lprn) then - do j=1,3 - vv(j)=d_t(j,0) - enddo - do i=nnt,nct - do j=1,3 - vvtot(j,i)=vv(j)+0.5d0*d_t(j,i) - vvtot(j,i+nres)=vv(j)+d_t(j,i+nres) - vv(j)=vv(j)+d_t(j,i) - enddo - enddo - write (iout,*) "vvtot backbone and sidechain" - do i=nnt,nct - write (iout,'(i5,3e15.5,5x,3e15.5)') i,(vvtot(j,i),j=1,3), - & (vvtot(j,i+nres),j=1,3) - enddo - ind=0 - do i=nnt,nct-1 - do j=1,3 - v_work(ind+j)=vvtot(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - do j=1,3 - v_work(ind+j)=vvtot(j,i+nres) - enddo - ind=ind+3 - enddo - write (iout,*) "v_work gamvec and site-based friction forces" - do i=1,dimen1 - write (iout,'(i5,3e15.5)') i,v_work(i),gamvec(i), - & gamvec(i)*v_work(i) - enddo -c do i=1,dimen -c fric_work1(i)=0.0d0 -c do j=1,dimen1 -c fric_work1(i)=fric_work1(i)-A(j,i)*gamvec(j)*v_work(j) -c enddo -c enddo -c write (iout,*) "fric_work and fric_work1" -c do i=1,dimen -c write (iout,'(i5,2e15.5)') i,fric_work(i),fric_work1(i) -c enddo - do i=1,dimen - do j=1,dimen - ginvfric(i,j)=0.0d0 - do k=1,dimen - ginvfric(i,j)=ginvfric(i,j)+ginv(i,k)*fricmat(k,j) - enddo - enddo - enddo - write (iout,*) "ginvfric" - do i=1,dimen - write (iout,'(i5,100f8.3)') i,(ginvfric(i,j),j=1,dimen) - enddo - write (iout,*) "symmetry check" - do i=1,dimen - do j=1,i-1 - write (iout,*) i,j,ginvfric(i,j)-ginvfric(j,i) - enddo - enddo - endif - return - end -c----------------------------------------------------- - subroutine stochastic_force(stochforcvec) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.TIME1' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.IOUNITS' - - double precision x,sig,lowb,highb, - & ff(3),force(3,0:MAXRES2),zeta2,lowb2, - & highb2,sig2,forcvec(MAXRES6),stochforcvec(MAXRES6) - logical lprn /.false./ - do i=0,MAXRES2 - do j=1,3 - stochforc(j,i)=0.0d0 - enddo - enddo - x=0.0d0 - -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif -c Compute the stochastic forces acting on bodies. Store in force. - do i=nnt,nct-1 - sig=stdforcp(i) - lowb=-5*sig - highb=5*sig - do j=1,3 - force(j,i)=anorm_distr(x,sig,lowb,highb) - enddo - enddo - do i=nnt,nct - sig2=stdforcsc(i) - lowb2=-5*sig2 - highb2=5*sig2 - do j=1,3 - force(j,i+nres)=anorm_distr(x,sig2,lowb2,highb2) - enddo - enddo -#ifdef MPI - time_fsample=time_fsample+MPI_Wtime()-time00 -#else - time_fsample=time_fsample+tcpu()-time00 -#endif -c Compute the stochastic forces acting on virtual-bond vectors. - do j=1,3 - ff(j)=0.0d0 - enddo - do i=nct-1,nnt,-1 - do j=1,3 - stochforc(j,i)=ff(j)+0.5d0*force(j,i) - enddo - do j=1,3 - ff(j)=ff(j)+force(j,i) - enddo - if (itype(i+1).ne.21) then - do j=1,3 - stochforc(j,i)=stochforc(j,i)+force(j,i+nres+1) - ff(j)=ff(j)+force(j,i+nres+1) - enddo - endif - enddo - do j=1,3 - stochforc(j,0)=ff(j)+force(j,nnt+nres) - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - stochforc(j,i+nres)=force(j,i+nres) - enddo - endif - enddo - - do j=1,3 - stochforcvec(j)=stochforc(j,0) - enddo - ind=3 - do i=nnt,nct-1 - do j=1,3 - stochforcvec(ind+j)=stochforc(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - stochforcvec(ind+j)=stochforc(j,i+nres) - enddo - ind=ind+3 - endif - enddo - if (lprn) then - write (iout,*) "stochforcvec" - do i=1,3*dimen - write(iout,'(i5,e15.5)') i,stochforcvec(i) - enddo - write(iout,*) "Stochastic forces backbone" - do i=0,nct-1 - write(iout,'(i5,3e15.5)') i,(stochforc(j,i),j=1,3) - enddo - write(iout,*) "Stochastic forces side chain" - do i=nnt,nct - write(iout,'(i5,3e15.5)') - & i,(stochforc(j,i+nres),j=1,3) - enddo - endif - - if (lprn) then - - ind=0 - do i=nnt,nct-1 - write (iout,*) i,ind - do j=1,3 - forcvec(ind+j)=force(j,i) - enddo - ind=ind+3 - enddo - do i=nnt,nct - write (iout,*) i,ind - do j=1,3 - forcvec(j+ind)=force(j,i+nres) - enddo - ind=ind+3 - enddo - - write (iout,*) "forcvec" - ind=0 - do i=nnt,nct-1 - do j=1,3 - write (iout,'(2i3,2f10.5)') i,j,force(j,i), - & forcvec(ind+j) - enddo - ind=ind+3 - enddo - do i=nnt,nct - do j=1,3 - write (iout,'(2i3,2f10.5)') i,j,force(j,i+nres), - & forcvec(ind+j) - enddo - ind=ind+3 - enddo - - endif - - return - end -c------------------------------------------------------------------ - subroutine setup_fricmat - implicit real*8 (a-h,o-z) -#ifdef MPI - include 'mpif.h' -#endif - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD' - include 'COMMON.SETUP' - include 'COMMON.TIME1' -c integer licznik /0/ -c save licznik -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.IOUNITS' - integer IERROR - integer i,j,ind,ind1,m - logical lprn /.false./ - double precision dtdi,gamvec(MAXRES2), - & ginvfric(maxres2,maxres2),Ghalf(mmaxres2),fcopy(maxres2,maxres2) - common /syfek/ gamvec - double precision work(8*maxres2) - integer iwork(maxres2) - common /przechowalnia/ ginvfric,Ghalf,fcopy -#ifdef MPI - if (fg_rank.ne.king) goto 10 -#endif -c Zeroing out fricmat - do i=1,dimen - do j=1,dimen - fricmat(i,j)=0.0d0 - enddo - enddo -c Load the friction coefficients corresponding to peptide groups - ind1=0 - do i=nnt,nct-1 - ind1=ind1+1 - gamvec(ind1)=gamp - enddo -c Load the friction coefficients corresponding to side chains - m=nct-nnt - ind=0 - do i=nnt,nct - ind=ind+1 - ii = ind+m - iti=itype(i) - gamvec(ii)=gamsc(iti) - enddo - if (surfarea) call sdarea(gamvec) -c if (lprn) then -c write (iout,*) "Matrix A and vector gamma" -c do i=1,dimen1 -c write (iout,'(i2,$)') i -c do j=1,dimen -c write (iout,'(f4.1,$)') A(i,j) -c enddo -c write (iout,'(f8.3)') gamvec(i) -c enddo -c endif - if (lprn) then - write (iout,*) "Vector gamvec" - do i=1,dimen1 - write (iout,'(i5,f10.5)') i, gamvec(i) - enddo - endif - -c The friction matrix - do k=1,dimen - do i=1,dimen - dtdi=0.0d0 - do j=1,dimen1 - dtdi=dtdi+A(j,k)*A(j,i)*gamvec(j) - enddo - fricmat(k,i)=dtdi - enddo - enddo - - if (lprn) then - write (iout,'(//a)') "Matrix fricmat" - call matout2(dimen,dimen,maxres2,maxres2,fricmat) - endif - if (lang.eq.2 .or. lang.eq.3) then -c Mass-scale the friction matrix if non-direct integration will be performed - do i=1,dimen - do j=1,dimen - Ginvfric(i,j)=0.0d0 - do k=1,dimen - do l=1,dimen - Ginvfric(i,j)=Ginvfric(i,j)+ - & Gsqrm(i,k)*Gsqrm(l,j)*fricmat(k,l) - enddo - enddo - enddo - enddo -c Diagonalize the friction matrix - ind=0 - do i=1,dimen - do j=1,i - ind=ind+1 - Ghalf(ind)=Ginvfric(i,j) - enddo - enddo - call gldiag(maxres2,dimen,dimen,Ghalf,work,fricgam,fricvec, - & ierr,iwork) - if (lprn) then - write (iout,'(//2a)') "Eigenvectors and eigenvalues of the", - & " mass-scaled friction matrix" - call eigout(dimen,dimen,maxres2,maxres2,fricvec,fricgam) - endif -c Precompute matrices for tinker stochastic integrator -#ifndef LANG0 - do i=1,dimen - do j=1,dimen - mt1(i,j)=0.0d0 - mt2(i,j)=0.0d0 - do k=1,dimen - mt1(i,j)=mt1(i,j)+fricvec(k,i)*gsqrm(k,j) - mt2(i,j)=mt2(i,j)+fricvec(k,i)*gsqrp(k,j) - enddo - mt3(j,i)=mt1(i,j) - enddo - enddo -#endif - else if (lang.eq.4) then -c Diagonalize the friction matrix - ind=0 - do i=1,dimen - do j=1,i - ind=ind+1 - Ghalf(ind)=fricmat(i,j) - enddo - enddo - call gldiag(maxres2,dimen,dimen,Ghalf,work,fricgam,fricvec, - & ierr,iwork) - if (lprn) then - write (iout,'(//2a)') "Eigenvectors and eigenvalues of the", - & " friction matrix" - call eigout(dimen,dimen,maxres2,maxres2,fricvec,fricgam) - endif -c Determine the number of zero eigenvalues of the friction matrix - nzero=max0(dimen-dimen1,0) -c do while (fricgam(nzero+1).le.1.0d-5 .and. nzero.lt.dimen) -c nzero=nzero+1 -c enddo - write (iout,*) "Number of zero eigenvalues:",nzero - do i=1,dimen - do j=1,dimen - fricmat(i,j)=0.0d0 - do k=nzero+1,dimen - fricmat(i,j)=fricmat(i,j) - & +fricvec(i,k)*fricvec(j,k)/fricgam(k) - enddo - enddo - enddo - if (lprn) then - write (iout,'(//a)') "Generalized inverse of fricmat" - call matout(dimen,dimen,maxres6,maxres6,fricmat) - endif - endif -#ifdef MPI - 10 continue - if (nfgtasks.gt.1) then - if (fg_rank.eq.0) then -c The matching BROADCAST for fg processors is called in ERGASTULUM -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif - call MPI_Bcast(10,1,MPI_INTEGER,king,FG_COMM,IERROR) -#ifdef MPI - time_Bcast=time_Bcast+MPI_Wtime()-time00 -#else - time_Bcast=time_Bcast+tcpu()-time00 -#endif -c print *,"Processor",myrank, -c & " BROADCAST iorder in SETUP_FRICMAT" - endif -c licznik=licznik+1 -c write (iout,*) "setup_fricmat licznik",licznik -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif -c Scatter the friction matrix - call MPI_Scatterv(fricmat(1,1),nginv_counts(0), - & nginv_start(0),MPI_DOUBLE_PRECISION,fcopy(1,1), - & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) -#ifdef TIMING -#ifdef MPI - time_scatter=time_scatter+MPI_Wtime()-time00 - time_scatter_fmat=time_scatter_fmat+MPI_Wtime()-time00 -#else - time_scatter=time_scatter+tcpu()-time00 - time_scatter_fmat=time_scatter_fmat+tcpu()-time00 -#endif -#endif - do i=1,dimen - do j=1,2*my_ng_count - fricmat(j,i)=fcopy(i,j) - enddo - enddo -c write (iout,*) "My chunk of fricmat" -c call MATOUT2(my_ng_count,dimen,maxres2,maxres2,fcopy) - endif -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sdarea(gamvec) -c -c Scale the friction coefficients according to solvent accessible surface areas -c Code adapted from TINKER -c AL 9/3/04 -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - double precision radius(maxres2),gamvec(maxres2) - parameter (twosix=1.122462048309372981d0) - logical lprn /.false./ -c -c determine new friction coefficients every few SD steps -c -c set the atomic radii to estimates of sigma values -c -c print *,"Entered sdarea" - probe = 0.0d0 - - do i=1,2*nres - radius(i)=0.0d0 - enddo -c Load peptide group radii - do i=nnt,nct-1 - radius(i)=pstok - enddo -c Load side chain radii - do i=nnt,nct - iti=itype(i) - radius(i+nres)=restok(iti) - enddo -c do i=1,2*nres -c write (iout,*) "i",i," radius",radius(i) -c enddo - do i = 1, 2*nres - radius(i) = radius(i) / twosix - if (radius(i) .ne. 0.0d0) radius(i) = radius(i) + probe - end do -c -c scale atomic friction coefficients by accessible area -c - if (lprn) write (iout,*) - & "Original gammas, surface areas, scaling factors, new gammas, ", - & "std's of stochastic forces" - ind=0 - do i=nnt,nct-1 - if (radius(i).gt.0.0d0) then - call surfatom (i,area,radius) - ratio = dmax1(area/(4.0d0*pi*radius(i)**2),1.0d-1) - if (lprn) write (iout,'(i5,3f10.5,$)') - & i,gamvec(ind+1),area,ratio - do j=1,3 - ind=ind+1 - gamvec(ind) = ratio * gamvec(ind) - enddo - stdforcp(i)=stdfp*dsqrt(gamvec(ind)) - if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcp(i) - endif - enddo - do i=nnt,nct - if (radius(i+nres).gt.0.0d0) then - call surfatom (i+nres,area,radius) - ratio = dmax1(area/(4.0d0*pi*radius(i+nres)**2),1.0d-1) - if (lprn) write (iout,'(i5,3f10.5,$)') - & i,gamvec(ind+1),area,ratio - do j=1,3 - ind=ind+1 - gamvec(ind) = ratio * gamvec(ind) - enddo - stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamvec(ind)) - if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcsc(i) - endif - enddo - - return - end diff --git a/source/unres/src_MD_DFA/sumsld.f b/source/unres/src_MD_DFA/sumsld.f deleted file mode 100644 index 1ce7b78..0000000 --- a/source/unres/src_MD_DFA/sumsld.f +++ /dev/null @@ -1,1446 +0,0 @@ - subroutine sumsl(n, d, x, calcf, calcg, iv, liv, lv, v, - 1 uiparm, urparm, ufparm) -c -c *** minimize general unconstrained objective function using *** -c *** analytic gradient and hessian approx. from secant update *** -c - integer n, liv, lv - integer iv(liv), uiparm(1) - double precision d(n), x(n), v(lv), urparm(1) -c dimension v(71 + n*(n+15)/2), uiparm(*), urparm(*) - external calcf, calcg, ufparm -c -c *** purpose *** -c -c this routine interacts with subroutine sumit in an attempt -c to find an n-vector x* that minimizes the (unconstrained) -c objective function computed by calcf. (often the x* found is -c a local minimizer rather than a global one.) -c -c-------------------------- parameter usage -------------------------- -c -c n........ (input) the number of variables on which f depends, i.e., -c the number of components in x. -c d........ (input/output) a scale vector such that d(i)*x(i), -c i = 1,2,...,n, are all in comparable units. -c d can strongly affect the behavior of sumsl. -c finding the best choice of d is generally a trial- -c and-error process. choosing d so that d(i)*x(i) -c has about the same value for all i often works well. -c the defaults provided by subroutine deflt (see i -c below) require the caller to supply d. -c x........ (input/output) before (initially) calling sumsl, the call- -c er should set x to an initial guess at x*. when -c sumsl returns, x contains the best point so far -c found, i.e., the one that gives the least value so -c far seen for f(x). -c calcf.... (input) a subroutine that, given x, computes f(x). calcf -c must be declared external in the calling program. -c it is invoked by -c call calcf(n, x, nf, f, uiparm, urparm, ufparm) -c when calcf is called, nf is the invocation -c count for calcf. nf is included for possible use -c with calcg. if x is out of bounds (e.g., if it -c would cause overflow in computing f(x)), then calcf -c should set nf to 0. this will cause a shorter step -c to be attempted. (if x is in bounds, then calcf -c should not change nf.) the other parameters are as -c described above and below. calcf should not change -c n, p, or x. -c calcg.... (input) a subroutine that, given x, computes g(x), the gra- -c dient of f at x. calcg must be declared external in -c the calling program. it is invoked by -c call calcg(n, x, nf, g, uiparm, urparm, ufaprm) -c when calcg is called, nf is the invocation -c count for calcf at the time f(x) was evaluated. the -c x passed to calcg is usually the one passed to calcf -c on either its most recent invocation or the one -c prior to it. if calcf saves intermediate results -c for use by calcg, then it is possible to tell from -c nf whether they are valid for the current x (or -c which copy is valid if two copies are kept). if g -c cannot be computed at x, then calcg should set nf to -c 0. in this case, sumsl will return with iv(1) = 65. -c (if g can be computed at x, then calcg should not -c changed nf.) the other parameters to calcg are as -c described above and below. calcg should not change -c n or x. -c iv....... (input/output) an integer value array of length liv (see -c below) that helps control the sumsl algorithm and -c that is used to store various intermediate quanti- -c ties. of particular interest are the initialization/ -c return code iv(1) and the entries in iv that control -c printing and limit the number of iterations and func- -c tion evaluations. see the section on iv input -c values below. -c liv...... (input) length of iv array. must be at least 60. if li -c is too small, then sumsl returns with iv(1) = 15. -c when sumsl returns, the smallest allowed value of -c liv is stored in iv(lastiv) -- see the section on -c iv output values below. (this is intended for use -c with extensions of sumsl that handle constraints.) -c lv....... (input) length of v array. must be at least 71+n*(n+15)/2. -c (at least 77+n*(n+17)/2 for smsno, at least -c 78+n*(n+12) for humsl). if lv is too small, then -c sumsl returns with iv(1) = 16. when sumsl returns, -c the smallest allowed value of lv is stored in -c iv(lastv) -- see the section on iv output values -c below. -c v........ (input/output) a floating-point value array of length l -c (see below) that helps control the sumsl algorithm -c and that is used to store various intermediate -c quantities. of particular interest are the entries -c in v that limit the length of the first step -c attempted (lmax0) and specify convergence tolerances -c (afctol, lmaxs, rfctol, sctol, xctol, xftol). -c uiparm... (input) user integer parameter array passed without change -c to calcf and calcg. -c urparm... (input) user floating-point parameter array passed without -c change to calcf and calcg. -c ufparm... (input) user external subroutine or function passed without -c change to calcf and calcg. -c -c *** iv input values (from subroutine deflt) *** -c -c iv(1)... on input, iv(1) should have a value between 0 and 14...... -c 0 and 12 mean this is a fresh start. 0 means that -c deflt(2, iv, liv, lv, v) -c is to be called to provide all default values to iv and -c v. 12 (the value that deflt assigns to iv(1)) means the -c caller has already called deflt and has possibly changed -c some iv and/or v entries to non-default values. -c 13 means deflt has been called and that sumsl (and -c sumit) should only do their storage allocation. that is, -c they should set the output components of iv that tell -c where various subarrays arrays of v begin, such as iv(g) -c (and, for humsl and humit only, iv(dtol)), and return. -c 14 means that a storage has been allocated (by a call -c with iv(1) = 13) and that the algorithm should be -c started. when called with iv(1) = 13, sumsl returns -c iv(1) = 14 unless liv or lv is too small (or n is not -c positive). default = 12. -c iv(inith).... iv(25) tells whether the hessian approximation h should -c be initialized. 1 (the default) means sumit should -c initialize h to the diagonal matrix whose i-th diagonal -c element is d(i)**2. 0 means the caller has supplied a -c cholesky factor l of the initial hessian approximation -c h = l*(l**t) in v, starting at v(iv(lmat)) = v(iv(42)) -c (and stored compactly by rows). note that iv(lmat) may -c be initialized by calling sumsl with iv(1) = 13 (see -c the iv(1) discussion above). default = 1. -c iv(mxfcal)... iv(17) gives the maximum number of function evaluations -c (calls on calcf) allowed. if this number does not suf- -c fice, then sumsl returns with iv(1) = 9. default = 200. -c iv(mxiter)... iv(18) gives the maximum number of iterations allowed. -c it also indirectly limits the number of gradient evalua- -c tions (calls on calcg) to iv(mxiter) + 1. if iv(mxiter) -c iterations do not suffice, then sumsl returns with -c iv(1) = 10. default = 150. -c iv(outlev)... iv(19) controls the number and length of iteration sum- -c mary lines printed (by itsum). iv(outlev) = 0 means do -c not print any summary lines. otherwise, print a summary -c line after each abs(iv(outlev)) iterations. if iv(outlev) -c is positive, then summary lines of length 78 (plus carri- -c age control) are printed, including the following... the -c iteration and function evaluation counts, f = the current -c function value, relative difference in function values -c achieved by the latest step (i.e., reldf = (f0-v(f))/f01, -c where f01 is the maximum of abs(v(f)) and abs(v(f0)) and -c v(f0) is the function value from the previous itera- -c tion), the relative function reduction predicted for the -c step just taken (i.e., preldf = v(preduc) / f01, where -c v(preduc) is described below), the scaled relative change -c in x (see v(reldx) below), the step parameter for the -c step just taken (stppar = 0 means a full newton step, -c between 0 and 1 means a relaxed newton step, between 1 -c and 2 means a double dogleg step, greater than 2 means -c a scaled down cauchy step -- see subroutine dbldog), the -c 2-norm of the scale vector d times the step just taken -c (see v(dstnrm) below), and npreldf, i.e., -c v(nreduc)/f01, where v(nreduc) is described below -- if -c npreldf is positive, then it is the relative function -c reduction predicted for a newton step (one with -c stppar = 0). if npreldf is negative, then it is the -c negative of the relative function reduction predicted -c for a step computed with step bound v(lmaxs) for use in -c testing for singular convergence. -c if iv(outlev) is negative, then lines of length 50 -c are printed, including only the first 6 items listed -c above (through reldx). -c default = 1. -c iv(parprt)... iv(20) = 1 means print any nondefault v values on a -c fresh start or any changed v values on a restart. -c iv(parprt) = 0 means skip this printing. default = 1. -c iv(prunit)... iv(21) is the output unit number on which all printing -c is done. iv(prunit) = 0 means suppress all printing. -c default = standard output unit (unit 6 on most systems). -c iv(solprt)... iv(22) = 1 means print out the value of x returned (as -c well as the gradient and the scale vector d). -c iv(solprt) = 0 means skip this printing. default = 1. -c iv(statpr)... iv(23) = 1 means print summary statistics upon return- -c ing. these consist of the function value, the scaled -c relative change in x caused by the most recent step (see -c v(reldx) below), the number of function and gradient -c evaluations (calls on calcf and calcg), and the relative -c function reductions predicted for the last step taken and -c for a newton step (or perhaps a step bounded by v(lmaxs) -c -- see the descriptions of preldf and npreldf under -c iv(outlev) above). -c iv(statpr) = 0 means skip this printing. -c iv(statpr) = -1 means skip this printing as well as that -c of the one-line termination reason message. default = 1. -c iv(x0prt).... iv(24) = 1 means print the initial x and scale vector d -c (on a fresh start only). iv(x0prt) = 0 means skip this -c printing. default = 1. -c -c *** (selected) iv output values *** -c -c iv(1)........ on output, iv(1) is a return code.... -c 3 = x-convergence. the scaled relative difference (see -c v(reldx)) between the current parameter vector x and -c a locally optimal parameter vector is very likely at -c most v(xctol). -c 4 = relative function convergence. the relative differ- -c ence between the current function value and its lo- -c cally optimal value is very likely at most v(rfctol). -c 5 = both x- and relative function convergence (i.e., the -c conditions for iv(1) = 3 and iv(1) = 4 both hold). -c 6 = absolute function convergence. the current function -c value is at most v(afctol) in absolute value. -c 7 = singular convergence. the hessian near the current -c iterate appears to be singular or nearly so, and a -c step of length at most v(lmaxs) is unlikely to yield -c a relative function decrease of more than v(sctol). -c 8 = false convergence. the iterates appear to be converg- -c ing to a noncritical point. this may mean that the -c convergence tolerances (v(afctol), v(rfctol), -c v(xctol)) are too small for the accuracy to which -c the function and gradient are being computed, that -c there is an error in computing the gradient, or that -c the function or gradient is discontinuous near x. -c 9 = function evaluation limit reached without other con- -c vergence (see iv(mxfcal)). -c 10 = iteration limit reached without other convergence -c (see iv(mxiter)). -c 11 = stopx returned .true. (external interrupt). see the -c usage notes below. -c 14 = storage has been allocated (after a call with -c iv(1) = 13). -c 17 = restart attempted with n changed. -c 18 = d has a negative component and iv(dtype) .le. 0. -c 19...43 = v(iv(1)) is out of range. -c 63 = f(x) cannot be computed at the initial x. -c 64 = bad parameters passed to assess (which should not -c occur). -c 65 = the gradient could not be computed at x (see calcg -c above). -c 67 = bad first parameter to deflt. -c 80 = iv(1) was out of range. -c 81 = n is not positive. -c iv(g)........ iv(28) is the starting subscript in v of the current -c gradient vector (the one corresponding to x). -c iv(lastiv)... iv(44) is the least acceptable value of liv. (it is -c only set if liv is at least 44.) -c iv(lastv).... iv(45) is the least acceptable value of lv. (it is -c only set if liv is large enough, at least iv(lastiv).) -c iv(nfcall)... iv(6) is the number of calls so far made on calcf (i.e., -c function evaluations). -c iv(ngcall)... iv(30) is the number of gradient evaluations (calls on -c calcg). -c iv(niter).... iv(31) is the number of iterations performed. -c -c *** (selected) v input values (from subroutine deflt) *** -c -c v(bias)..... v(43) is the bias parameter used in subroutine dbldog -- -c see that subroutine for details. default = 0.8. -c v(afctol)... v(31) is the absolute function convergence tolerance. -c if sumsl finds a point where the function value is less -c than v(afctol) in absolute value, and if sumsl does not -c return with iv(1) = 3, 4, or 5, then it returns with -c iv(1) = 6. this test can be turned off by setting -c v(afctol) to zero. default = max(10**-20, machep**2), -c where machep is the unit roundoff. -c v(dinit).... v(38), if nonnegative, is the value to which the scale -c vector d is initialized. default = -1. -c v(lmax0).... v(35) gives the maximum 2-norm allowed for d times the -c very first step that sumsl attempts. this parameter can -c markedly affect the performance of sumsl. -c v(lmaxs).... v(36) is used in testing for singular convergence -- if -c the function reduction predicted for a step of length -c bounded by v(lmaxs) is at most v(sctol) * abs(f0), where -c f0 is the function value at the start of the current -c iteration, and if sumsl does not return with iv(1) = 3, -c 4, 5, or 6, then it returns with iv(1) = 7. default = 1. -c v(rfctol)... v(32) is the relative function convergence tolerance. -c if the current model predicts a maximum possible function -c reduction (see v(nreduc)) of at most v(rfctol)*abs(f0) -c at the start of the current iteration, where f0 is the -c then current function value, and if the last step attempt- -c ed achieved no more than twice the predicted function -c decrease, then sumsl returns with iv(1) = 4 (or 5). -c default = max(10**-10, machep**(2/3)), where machep is -c the unit roundoff. -c v(sctol).... v(37) is the singular convergence tolerance -- see the -c description of v(lmaxs) above. -c v(tuner1)... v(26) helps decide when to check for false convergence. -c this is done if the actual function decrease from the -c current step is no more than v(tuner1) times its predict- -c ed value. default = 0.1. -c v(xctol).... v(33) is the x-convergence tolerance. if a newton step -c (see v(nreduc)) is tried that has v(reldx) .le. v(xctol) -c and if this step yields at most twice the predicted func- -c tion decrease, then sumsl returns with iv(1) = 3 (or 5). -c (see the description of v(reldx) below.) -c default = machep**0.5, where machep is the unit roundoff. -c v(xftol).... v(34) is the false convergence tolerance. if a step is -c tried that gives no more than v(tuner1) times the predict- -c ed function decrease and that has v(reldx) .le. v(xftol), -c and if sumsl does not return with iv(1) = 3, 4, 5, 6, or -c 7, then it returns with iv(1) = 8. (see the description -c of v(reldx) below.) default = 100*machep, where -c machep is the unit roundoff. -c v(*)........ deflt supplies to v a number of tuning constants, with -c which it should ordinarily be unnecessary to tinker. see -c section 17 of version 2.2 of the nl2sol usage summary -c (i.e., the appendix to ref. 1) for details on v(i), -c i = decfac, incfac, phmnfc, phmxfc, rdfcmn, rdfcmx, -c tuner2, tuner3, tuner4, tuner5. -c -c *** (selected) v output values *** -c -c v(dgnorm)... v(1) is the 2-norm of (diag(d)**-1)*g, where g is the -c most recently computed gradient. -c v(dstnrm)... v(2) is the 2-norm of diag(d)*step, where step is the -c current step. -c v(f)........ v(10) is the current function value. -c v(f0)....... v(13) is the function value at the start of the current -c iteration. -c v(nreduc)... v(6), if positive, is the maximum function reduction -c possible according to the current model, i.e., the func- -c tion reduction predicted for a newton step (i.e., -c step = -h**-1 * g, where g is the current gradient and -c h is the current hessian approximation). -c if v(nreduc) is negative, then it is the negative of -c the function reduction predicted for a step computed with -c a step bound of v(lmaxs) for use in testing for singular -c convergence. -c v(preduc)... v(7) is the function reduction predicted (by the current -c quadratic model) for the current step. this (divided by -c v(f0)) is used in testing for relative function -c convergence. -c v(reldx).... v(17) is the scaled relative change in x caused by the -c current step, computed as -c max(abs(d(i)*(x(i)-x0(i)), 1 .le. i .le. p) / -c max(d(i)*(abs(x(i))+abs(x0(i))), 1 .le. i .le. p), -c where x = x0 + step. -c -c------------------------------- notes ------------------------------- -c -c *** algorithm notes *** -c -c this routine uses a hessian approximation computed from the -c bfgs update (see ref 3). only a cholesky factor of the hessian -c approximation is stored, and this is updated using ideas from -c ref. 4. steps are computed by the double dogleg scheme described -c in ref. 2. the steps are assessed as in ref. 1. -c -c *** usage notes *** -c -c after a return with iv(1) .le. 11, it is possible to restart, -c i.e., to change some of the iv and v input values described above -c and continue the algorithm from the point where it was interrupt- -c ed. iv(1) should not be changed, nor should any entries of i -c and v other than the input values (those supplied by deflt). -c those who do not wish to write a calcg which computes the -c gradient analytically should call smsno rather than sumsl. -c smsno uses finite differences to compute an approximate gradient. -c those who would prefer to provide f and g (the function and -c gradient) by reverse communication rather than by writing subrou- -c tines calcf and calcg may call on sumit directly. see the com- -c ments at the beginning of sumit. -c those who use sumsl interactively may wish to supply their -c own stopx function, which should return .true. if the break key -c has been pressed since stopx was last invoked. this makes it -c possible to externally interrupt sumsl (which will return with -c iv(1) = 11 if stopx returns .true.). -c storage for g is allocated at the end of v. thus the caller -c may make v longer than specified above and may allow calcg to use -c elements of g beyond the first n as scratch storage. -c -c *** portability notes *** -c -c the sumsl distribution tape contains both single- and double- -c precision versions of the sumsl source code, so it should be un- -c necessary to change precisions. -c only the functions imdcon and rmdcon contain machine-dependent -c constants. to change from one machine to another, it should -c suffice to change the (few) relevant lines in these functions. -c intrinsic functions are explicitly declared. on certain com- -c puters (e.g. univac), it may be necessary to comment out these -c declarations. so that this may be done automatically by a simple -c program, such declarations are preceded by a comment having c/+ -c in columns 1-3 and blanks in columns 4-72 and are followed by -c a comment having c/ in columns 1 and 2 and blanks in columns 3-72. -c the sumsl source code is expressed in 1966 ansi standard -c fortran. it may be converted to fortran 77 by commenting out all -c lines that fall between a line having c/6 in columns 1-3 and a -c line having c/7 in columns 1-3 and by removing (i.e., replacing -c by a blank) the c in column 1 of the lines that follow the c/7 -c line and precede a line having c/ in columns 1-2 and blanks in -c columns 3-72. these changes convert some data statements into -c parameter statements, convert some variables from real to -c character*4, and make the data statements that initialize these -c variables use character strings delimited by primes instead -c of hollerith constants. (such variables and data statements -c appear only in modules itsum and parck. parameter statements -c appear nearly everywhere.) these changes also add save state- -c ments for variables given machine-dependent constants by rmdcon. -c -c *** references *** -c -c 1. dennis, j.e., gay, d.m., and welsch, r.e. (1981), algorithm 573 -- -c an adaptive nonlinear least-squares algorithm, acm trans. -c math. software 7, pp. 369-383. -c -c 2. dennis, j.e., and mei, h.h.w. (1979), two new unconstrained opti- -c mization algorithms which use function and gradient -c values, j. optim. theory applic. 28, pp. 453-482. -c -c 3. dennis, j.e., and more, j.j. (1977), quasi-newton methods, motiva- -c tion and theory, siam rev. 19, pp. 46-89. -c -c 4. goldfarb, d. (1976), factorized variable metric methods for uncon- -c strained optimization, math. comput. 30, pp. 796-811. -c -c *** general *** -c -c coded by david m. gay (winter 1980). revised summer 1982. -c this subroutine was written in connection with research -c supported in part by the national science foundation under -c grants mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, -c and mcs-7906671. -c. -c -c---------------------------- declarations --------------------------- -c - external deflt, sumit -c -c deflt... supplies default iv and v input components. -c sumit... reverse-communication routine that carries out sumsl algo- -c rithm. -c - integer g1, iv1, nf - double precision f -c -c *** subscripts for iv *** -c - integer nextv, nfcall, nfgcal, g, toobig, vneed -c -c/6 -c data nextv/47/, nfcall/6/, nfgcal/7/, g/28/, toobig/2/, vneed/4/ -c/7 - parameter (nextv=47, nfcall=6, nfgcal=7, g=28, toobig=2, vneed=4) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - iv1 = iv(1) - if (iv1 .eq. 12 .or. iv1 .eq. 13) iv(vneed) = iv(vneed) + n - if (iv1 .eq. 14) go to 10 - if (iv1 .gt. 2 .and. iv1 .lt. 12) go to 10 - g1 = 1 - if (iv1 .eq. 12) iv(1) = 13 - go to 20 -c - 10 g1 = iv(g) -c - 20 call sumit(d, f, v(g1), iv, liv, lv, n, v, x) - if (iv(1) - 2) 30, 40, 50 -c - 30 nf = iv(nfcall) - call calcf(n, x, nf, f, uiparm, urparm, ufparm) - if (nf .le. 0) iv(toobig) = 1 - go to 20 -c - 40 call calcg(n, x, iv(nfgcal), v(g1), uiparm, urparm, ufparm) - go to 20 -c - 50 if (iv(1) .ne. 14) go to 999 -c -c *** storage allocation -c - iv(g) = iv(nextv) - iv(nextv) = iv(g) + n - if (iv1 .ne. 13) go to 10 -c - 999 return -c *** last card of sumsl follows *** - end - subroutine sumit(d, fx, g, iv, liv, lv, n, v, x) -c -c *** carry out sumsl (unconstrained minimization) iterations, using -c *** double-dogleg/bfgs steps. -c -c *** parameter declarations *** -c - integer liv, lv, n - integer iv(liv) - double precision d(n), fx, g(n), v(lv), x(n) -c -c-------------------------- parameter usage -------------------------- -c -c d.... scale vector. -c fx... function value. -c g.... gradient vector. -c iv... integer value array. -c liv.. length of iv (at least 60). -c lv... length of v (at least 71 + n*(n+13)/2). -c n.... number of variables (components in x and g). -c v.... floating-point value array. -c x.... vector of parameters to be optimized. -c -c *** discussion *** -c -c parameters iv, n, v, and x are the same as the corresponding -c ones to sumsl (which see), except that v can be shorter (since -c the part of v that sumsl uses for storing g is not needed). -c moreover, compared with sumsl, iv(1) may have the two additional -c output values 1 and 2, which are explained below, as is the use -c of iv(toobig) and iv(nfgcal). the value iv(g), which is an -c output value from sumsl (and smsno), is not referenced by -c sumit or the subroutines it calls. -c fx and g need not have been initialized when sumit is called -c with iv(1) = 12, 13, or 14. -c -c iv(1) = 1 means the caller should set fx to f(x), the function value -c at x, and call sumit again, having changed none of the -c other parameters. an exception occurs if f(x) cannot be -c (e.g. if overflow would occur), which may happen because -c of an oversized step. in this case the caller should set -c iv(toobig) = iv(2) to 1, which will cause sumit to ig- -c nore fx and try a smaller step. the parameter nf that -c sumsl passes to calcf (for possible use by calcg) is a -c copy of iv(nfcall) = iv(6). -c iv(1) = 2 means the caller should set g to g(x), the gradient vector -c of f at x, and call sumit again, having changed none of -c the other parameters except possibly the scale vector d -c when iv(dtype) = 0. the parameter nf that sumsl passes -c to calcg is iv(nfgcal) = iv(7). if g(x) cannot be -c evaluated, then the caller may set iv(nfgcal) to 0, in -c which case sumit will return with iv(1) = 65. -c. -c *** general *** -c -c coded by david m. gay (december 1979). revised sept. 1982. -c this subroutine was written in connection with research supported -c in part by the national science foundation under grants -c mcs-7600324 and mcs-7906671. -c -c (see sumsl for references.) -c -c+++++++++++++++++++++++++++ declarations ++++++++++++++++++++++++++++ -c -c *** local variables *** -c - integer dg1, dummy, g01, i, k, l, lstgst, nwtst1, step1, - 1 temp1, w, x01, z - double precision t -c -c *** constants *** -c - double precision half, negone, one, onep2, zero -c -c *** no intrinsic functions *** -c -c *** external functions and subroutines *** -c - external assst, dbdog, deflt, dotprd, itsum, litvmu, livmul, - 1 ltvmul, lupdat, lvmul, parck, reldst, stopx, vaxpy, - 2 vcopy, vscopy, vvmulp, v2norm, wzbfgs - logical stopx - double precision dotprd, reldst, v2norm -c -c assst.... assesses candidate step. -c dbdog.... computes double-dogleg (candidate) step. -c deflt.... supplies default iv and v input components. -c dotprd... returns inner product of two vectors. -c itsum.... prints iteration summary and info on initial and final x. -c litvmu... multiplies inverse transpose of lower triangle times vector. -c livmul... multiplies inverse of lower triangle times vector. -c ltvmul... multiplies transpose of lower triangle times vector. -c lupdt.... updates cholesky factor of hessian approximation. -c lvmul.... multiplies lower triangle times vector. -c parck.... checks validity of input iv and v values. -c reldst... computes v(reldx) = relative step size. -c stopx.... returns .true. if the break key has been pressed. -c vaxpy.... computes scalar times one vector plus another. -c vcopy.... copies one vector to another. -c vscopy... sets all elements of a vector to a scalar. -c vvmulp... multiplies vector by vector raised to power (componentwise). -c v2norm... returns the 2-norm of a vector. -c wzbfgs... computes w and z for lupdat corresponding to bfgs update. -c -c *** subscripts for iv and v *** -c - integer afctol - integer cnvcod, dg, dgnorm, dinit, dstnrm, dst0, f, f0, fdif, - 1 gthg, gtstep, g0, incfac, inith, irc, kagqt, lmat, lmax0, - 2 lmaxs, mode, model, mxfcal, mxiter, nextv, nfcall, nfgcal, - 3 ngcall, niter, nreduc, nwtstp, preduc, radfac, radinc, - 4 radius, rad0, reldx, restor, step, stglim, stlstg, toobig, - 5 tuner4, tuner5, vneed, xirc, x0 -c -c *** iv subscript values *** -c -c/6 -c data cnvcod/55/, dg/37/, g0/48/, inith/25/, irc/29/, kagqt/33/, -c 1 mode/35/, model/5/, mxfcal/17/, mxiter/18/, nfcall/6/, -c 2 nfgcal/7/, ngcall/30/, niter/31/, nwtstp/34/, radinc/8/, -c 3 restor/9/, step/40/, stglim/11/, stlstg/41/, toobig/2/, -c 4 vneed/4/, xirc/13/, x0/43/ -c/7 - parameter (cnvcod=55, dg=37, g0=48, inith=25, irc=29, kagqt=33, - 1 mode=35, model=5, mxfcal=17, mxiter=18, nfcall=6, - 2 nfgcal=7, ngcall=30, niter=31, nwtstp=34, radinc=8, - 3 restor=9, step=40, stglim=11, stlstg=41, toobig=2, - 4 vneed=4, xirc=13, x0=43) -c/ -c -c *** v subscript values *** -c -c/6 -c data afctol/31/ -c data dgnorm/1/, dinit/38/, dstnrm/2/, dst0/3/, f/10/, f0/13/, -c 1 fdif/11/, gthg/44/, gtstep/4/, incfac/23/, lmat/42/, -c 2 lmax0/35/, lmaxs/36/, nextv/47/, nreduc/6/, preduc/7/, -c 3 radfac/16/, radius/8/, rad0/9/, reldx/17/, tuner4/29/, -c 4 tuner5/30/ -c/7 - parameter (afctol=31) - parameter (dgnorm=1, dinit=38, dstnrm=2, dst0=3, f=10, f0=13, - 1 fdif=11, gthg=44, gtstep=4, incfac=23, lmat=42, - 2 lmax0=35, lmaxs=36, nextv=47, nreduc=6, preduc=7, - 3 radfac=16, radius=8, rad0=9, reldx=17, tuner4=29, - 4 tuner5=30) -c/ -c -c/6 -c data half/0.5d+0/, negone/-1.d+0/, one/1.d+0/, onep2/1.2d+0/, -c 1 zero/0.d+0/ -c/7 - parameter (half=0.5d+0, negone=-1.d+0, one=1.d+0, onep2=1.2d+0, - 1 zero=0.d+0) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c -C Following SAVE statement inserted. - save l - i = iv(1) - if (i .eq. 1) go to 50 - if (i .eq. 2) go to 60 -c -c *** check validity of iv and v input values *** -c - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - if (iv(1) .eq. 12 .or. iv(1) .eq. 13) - 1 iv(vneed) = iv(vneed) + n*(n+13)/2 - call parck(2, d, iv, liv, lv, n, v) - i = iv(1) - 2 - if (i .gt. 12) go to 999 - go to (180, 180, 180, 180, 180, 180, 120, 90, 120, 10, 10, 20), i -c -c *** storage allocation *** -c -10 l = iv(lmat) - iv(x0) = l + n*(n+1)/2 - iv(step) = iv(x0) + n - iv(stlstg) = iv(step) + n - iv(g0) = iv(stlstg) + n - iv(nwtstp) = iv(g0) + n - iv(dg) = iv(nwtstp) + n - iv(nextv) = iv(dg) + n - if (iv(1) .ne. 13) go to 20 - iv(1) = 14 - go to 999 -c -c *** initialization *** -c - 20 iv(niter) = 0 - iv(nfcall) = 1 - iv(ngcall) = 1 - iv(nfgcal) = 1 - iv(mode) = -1 - iv(model) = 1 - iv(stglim) = 1 - iv(toobig) = 0 - iv(cnvcod) = 0 - iv(radinc) = 0 - v(rad0) = zero - if (v(dinit) .ge. zero) call vscopy(n, d, v(dinit)) - if (iv(inith) .ne. 1) go to 40 -c -c *** set the initial hessian approximation to diag(d)**-2 *** -c - l = iv(lmat) - call vscopy(n*(n+1)/2, v(l), zero) - k = l - 1 - do 30 i = 1, n - k = k + i - t = d(i) - if (t .le. zero) t = one - v(k) = t - 30 continue -c -c *** compute initial function value *** -c - 40 iv(1) = 1 - go to 999 -c - 50 v(f) = fx - if (iv(mode) .ge. 0) go to 180 - iv(1) = 2 - if (iv(toobig) .eq. 0) go to 999 - iv(1) = 63 - go to 300 -c -c *** make sure gradient could be computed *** -c - 60 if (iv(nfgcal) .ne. 0) go to 70 - iv(1) = 65 - go to 300 -c - 70 dg1 = iv(dg) - call vvmulp(n, v(dg1), g, d, -1) - v(dgnorm) = v2norm(n, v(dg1)) -c -c *** test norm of gradient *** -c - if (v(dgnorm) .gt. v(afctol)) go to 75 - iv(irc) = 10 - iv(cnvcod) = iv(irc) - 4 -c - 75 if (iv(cnvcod) .ne. 0) go to 290 - if (iv(mode) .eq. 0) go to 250 -c -c *** allow first step to have scaled 2-norm at most v(lmax0) *** -c - v(radius) = v(lmax0) -c - iv(mode) = 0 -c -c -c----------------------------- main loop ----------------------------- -c -c -c *** print iteration summary, check iteration limit *** -c - 80 call itsum(d, g, iv, liv, lv, n, v, x) - 90 k = iv(niter) - if (k .lt. iv(mxiter)) go to 100 - iv(1) = 10 - go to 300 -c -c *** update radius *** -c - 100 iv(niter) = k + 1 - if(k.gt.0)v(radius) = v(radfac) * v(dstnrm) -c -c *** initialize for start of next iteration *** -c - g01 = iv(g0) - x01 = iv(x0) - v(f0) = v(f) - iv(irc) = 4 - iv(kagqt) = -1 -c -c *** copy x to x0, g to g0 *** -c - call vcopy(n, v(x01), x) - call vcopy(n, v(g01), g) -c -c *** check stopx and function evaluation limit *** -c -C AL 4/30/95 - dummy=iv(nfcall) - 110 if (.not. stopx(dummy)) go to 130 - iv(1) = 11 - go to 140 -c -c *** come here when restarting after func. eval. limit or stopx. -c - 120 if (v(f) .ge. v(f0)) go to 130 - v(radfac) = one - k = iv(niter) - go to 100 -c - 130 if (iv(nfcall) .lt. iv(mxfcal)) go to 150 - iv(1) = 9 - 140 if (v(f) .ge. v(f0)) go to 300 -c -c *** in case of stopx or function evaluation limit with -c *** improved v(f), evaluate the gradient at x. -c - iv(cnvcod) = iv(1) - go to 240 -c -c. . . . . . . . . . . . . compute candidate step . . . . . . . . . . -c - 150 step1 = iv(step) - dg1 = iv(dg) - nwtst1 = iv(nwtstp) - if (iv(kagqt) .ge. 0) go to 160 - l = iv(lmat) - call livmul(n, v(nwtst1), v(l), g) - v(nreduc) = half * dotprd(n, v(nwtst1), v(nwtst1)) - call litvmu(n, v(nwtst1), v(l), v(nwtst1)) - call vvmulp(n, v(step1), v(nwtst1), d, 1) - v(dst0) = v2norm(n, v(step1)) - call vvmulp(n, v(dg1), v(dg1), d, -1) - call ltvmul(n, v(step1), v(l), v(dg1)) - v(gthg) = v2norm(n, v(step1)) - iv(kagqt) = 0 - 160 call dbdog(v(dg1), lv, n, v(nwtst1), v(step1), v) - if (iv(irc) .eq. 6) go to 180 -c -c *** check whether evaluating f(x0 + step) looks worthwhile *** -c - if (v(dstnrm) .le. zero) go to 180 - if (iv(irc) .ne. 5) go to 170 - if (v(radfac) .le. one) go to 170 - if (v(preduc) .le. onep2 * v(fdif)) go to 180 -c -c *** compute f(x0 + step) *** -c - 170 x01 = iv(x0) - step1 = iv(step) - call vaxpy(n, x, one, v(step1), v(x01)) - iv(nfcall) = iv(nfcall) + 1 - iv(1) = 1 - iv(toobig) = 0 - go to 999 -c -c. . . . . . . . . . . . . assess candidate step . . . . . . . . . . . -c - 180 x01 = iv(x0) - v(reldx) = reldst(n, d, x, v(x01)) - call assst(iv, liv, lv, v) - step1 = iv(step) - lstgst = iv(stlstg) - if (iv(restor) .eq. 1) call vcopy(n, x, v(x01)) - if (iv(restor) .eq. 2) call vcopy(n, v(lstgst), v(step1)) - if (iv(restor) .ne. 3) go to 190 - call vcopy(n, v(step1), v(lstgst)) - call vaxpy(n, x, one, v(step1), v(x01)) - v(reldx) = reldst(n, d, x, v(x01)) -c - 190 k = iv(irc) - go to (200,230,230,230,200,210,220,220,220,220,220,220,280,250), k -c -c *** recompute step with changed radius *** -c - 200 v(radius) = v(radfac) * v(dstnrm) - go to 110 -c -c *** compute step of length v(lmaxs) for singular convergence test. -c - 210 v(radius) = v(lmaxs) - go to 150 -c -c *** convergence or false convergence *** -c - 220 iv(cnvcod) = k - 4 - if (v(f) .ge. v(f0)) go to 290 - if (iv(xirc) .eq. 14) go to 290 - iv(xirc) = 14 -c -c. . . . . . . . . . . . process acceptable step . . . . . . . . . . . -c - 230 if (iv(irc) .ne. 3) go to 240 - step1 = iv(step) - temp1 = iv(stlstg) -c -c *** set temp1 = hessian * step for use in gradient tests *** -c - l = iv(lmat) - call ltvmul(n, v(temp1), v(l), v(step1)) - call lvmul(n, v(temp1), v(l), v(temp1)) -c -c *** compute gradient *** -c - 240 iv(ngcall) = iv(ngcall) + 1 - iv(1) = 2 - go to 999 -c -c *** initializations -- g0 = g - g0, etc. *** -c - 250 g01 = iv(g0) - call vaxpy(n, v(g01), negone, v(g01), g) - step1 = iv(step) - temp1 = iv(stlstg) - if (iv(irc) .ne. 3) go to 270 -c -c *** set v(radfac) by gradient tests *** -c -c *** set temp1 = diag(d)**-1 * (hessian*step + (g(x0)-g(x))) *** -c - call vaxpy(n, v(temp1), negone, v(g01), v(temp1)) - call vvmulp(n, v(temp1), v(temp1), d, -1) -c -c *** do gradient tests *** -c - if (v2norm(n, v(temp1)) .le. v(dgnorm) * v(tuner4)) - 1 go to 260 - if (dotprd(n, g, v(step1)) - 1 .ge. v(gtstep) * v(tuner5)) go to 270 - 260 v(radfac) = v(incfac) -c -c *** update h, loop *** -c - 270 w = iv(nwtstp) - z = iv(x0) - l = iv(lmat) - call wzbfgs(v(l), n, v(step1), v(w), v(g01), v(z)) -c -c ** use the n-vectors starting at v(step1) and v(g01) for scratch.. - call lupdat(v(temp1), v(step1), v(l), v(g01), v(l), n, v(w), v(z)) - iv(1) = 2 - go to 80 -c -c. . . . . . . . . . . . . . misc. details . . . . . . . . . . . . . . -c -c *** bad parameters to assess *** -c - 280 iv(1) = 64 - go to 300 -c -c *** print summary of final iteration and other requested items *** -c - 290 iv(1) = iv(cnvcod) - iv(cnvcod) = 0 - 300 call itsum(d, g, iv, liv, lv, n, v, x) -c - 999 return -c -c *** last line of sumit follows *** - end - subroutine dbdog(dig, lv, n, nwtstp, step, v) -c -c *** compute double dogleg step *** -c -c *** parameter declarations *** -c - integer lv, n - double precision dig(n), nwtstp(n), step(n), v(lv) -c -c *** purpose *** -c -c this subroutine computes a candidate step (for use in an uncon- -c strained minimization code) by the double dogleg algorithm of -c dennis and mei (ref. 1), which is a variation on powell*s dogleg -c scheme (ref. 2, p. 95). -c -c-------------------------- parameter usage -------------------------- -c -c dig (input) diag(d)**-2 * g -- see algorithm notes. -c g (input) the current gradient vector. -c lv (input) length of v. -c n (input) number of components in dig, g, nwtstp, and step. -c nwtstp (input) negative newton step -- see algorithm notes. -c step (output) the computed step. -c v (i/o) values array, the following components of which are -c used here... -c v(bias) (input) bias for relaxed newton step, which is v(bias) of -c the way from the full newton to the fully relaxed newton -c step. recommended value = 0.8 . -c v(dgnorm) (input) 2-norm of diag(d)**-1 * g -- see algorithm notes. -c v(dstnrm) (output) 2-norm of diag(d) * step, which is v(radius) -c unless v(stppar) = 0 -- see algorithm notes. -c v(dst0) (input) 2-norm of diag(d) * nwtstp -- see algorithm notes. -c v(grdfac) (output) the coefficient of dig in the step returned -- -c step(i) = v(grdfac)*dig(i) + v(nwtfac)*nwtstp(i). -c v(gthg) (input) square-root of (dig**t) * (hessian) * dig -- see -c algorithm notes. -c v(gtstep) (output) inner product between g and step. -c v(nreduc) (output) function reduction predicted for the full newton -c step. -c v(nwtfac) (output) the coefficient of nwtstp in the step returned -- -c see v(grdfac) above. -c v(preduc) (output) function reduction predicted for the step returned. -c v(radius) (input) the trust region radius. d times the step returned -c has 2-norm v(radius) unless v(stppar) = 0. -c v(stppar) (output) code telling how step was computed... 0 means a -c full newton step. between 0 and 1 means v(stppar) of the -c way from the newton to the relaxed newton step. between -c 1 and 2 means a true double dogleg step, v(stppar) - 1 of -c the way from the relaxed newton to the cauchy step. -c greater than 2 means 1 / (v(stppar) - 1) times the cauchy -c step. -c -c------------------------------- notes ------------------------------- -c -c *** algorithm notes *** -c -c let g and h be the current gradient and hessian approxima- -c tion respectively and let d be the current scale vector. this -c routine assumes dig = diag(d)**-2 * g and nwtstp = h**-1 * g. -c the step computed is the same one would get by replacing g and h -c by diag(d)**-1 * g and diag(d)**-1 * h * diag(d)**-1, -c computing step, and translating step back to the original -c variables, i.e., premultiplying it by diag(d)**-1. -c -c *** references *** -c -c 1. dennis, j.e., and mei, h.h.w. (1979), two new unconstrained opti- -c mization algorithms which use function and gradient -c values, j. optim. theory applic. 28, pp. 453-482. -c 2. powell, m.j.d. (1970), a hybrid method for non-linear equations, -c in numerical methods for non-linear equations, edited by -c p. rabinowitz, gordon and breach, london. -c -c *** general *** -c -c coded by david m. gay. -c this subroutine was written in connection with research supported -c by the national science foundation under grants mcs-7600324 and -c mcs-7906671. -c -c------------------------ external quantities ------------------------ -c -c *** functions and subroutines called *** -c - external dotprd, v2norm - double precision dotprd, v2norm -c -c dotprd... returns inner product of two vectors. -c v2norm... returns 2-norm of a vector. -c -c *** intrinsic functions *** -c/+ - double precision dsqrt -c/ -c-------------------------- local variables -------------------------- -c - integer i - double precision cfact, cnorm, ctrnwt, ghinvg, femnsq, gnorm, - 1 nwtnrm, relax, rlambd, t, t1, t2 - double precision half, one, two, zero -c -c *** v subscripts *** -c - integer bias, dgnorm, dstnrm, dst0, grdfac, gthg, gtstep, - 1 nreduc, nwtfac, preduc, radius, stppar -c -c *** data initializations *** -c -c/6 -c data half/0.5d+0/, one/1.d+0/, two/2.d+0/, zero/0.d+0/ -c/7 - parameter (half=0.5d+0, one=1.d+0, two=2.d+0, zero=0.d+0) -c/ -c -c/6 -c data bias/43/, dgnorm/1/, dstnrm/2/, dst0/3/, grdfac/45/, -c 1 gthg/44/, gtstep/4/, nreduc/6/, nwtfac/46/, preduc/7/, -c 2 radius/8/, stppar/5/ -c/7 - parameter (bias=43, dgnorm=1, dstnrm=2, dst0=3, grdfac=45, - 1 gthg=44, gtstep=4, nreduc=6, nwtfac=46, preduc=7, - 2 radius=8, stppar=5) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - nwtnrm = v(dst0) - rlambd = one - if (nwtnrm .gt. zero) rlambd = v(radius) / nwtnrm - gnorm = v(dgnorm) - ghinvg = two * v(nreduc) - v(grdfac) = zero - v(nwtfac) = zero - if (rlambd .lt. one) go to 30 -c -c *** the newton step is inside the trust region *** -c - v(stppar) = zero - v(dstnrm) = nwtnrm - v(gtstep) = -ghinvg - v(preduc) = v(nreduc) - v(nwtfac) = -one - do 20 i = 1, n - 20 step(i) = -nwtstp(i) - go to 999 -c - 30 v(dstnrm) = v(radius) - cfact = (gnorm / v(gthg))**2 -c *** cauchy step = -cfact * g. - cnorm = gnorm * cfact - relax = one - v(bias) * (one - gnorm*cnorm/ghinvg) - if (rlambd .lt. relax) go to 50 -c -c *** step is between relaxed newton and full newton steps *** -c - v(stppar) = one - (rlambd - relax) / (one - relax) - t = -rlambd - v(gtstep) = t * ghinvg - v(preduc) = rlambd * (one - half*rlambd) * ghinvg - v(nwtfac) = t - do 40 i = 1, n - 40 step(i) = t * nwtstp(i) - go to 999 -c - 50 if (cnorm .lt. v(radius)) go to 70 -c -c *** the cauchy step lies outside the trust region -- -c *** step = scaled cauchy step *** -c - t = -v(radius) / gnorm - v(grdfac) = t - v(stppar) = one + cnorm / v(radius) - v(gtstep) = -v(radius) * gnorm - v(preduc) = v(radius)*(gnorm - half*v(radius)*(v(gthg)/gnorm)**2) - do 60 i = 1, n - 60 step(i) = t * dig(i) - go to 999 -c -c *** compute dogleg step between cauchy and relaxed newton *** -c *** femur = relaxed newton step minus cauchy step *** -c - 70 ctrnwt = cfact * relax * ghinvg / gnorm -c *** ctrnwt = inner prod. of cauchy and relaxed newton steps, -c *** scaled by gnorm**-1. - t1 = ctrnwt - gnorm*cfact**2 -c *** t1 = inner prod. of femur and cauchy step, scaled by -c *** gnorm**-1. - t2 = v(radius)*(v(radius)/gnorm) - gnorm*cfact**2 - t = relax * nwtnrm - femnsq = (t/gnorm)*t - ctrnwt - t1 -c *** femnsq = square of 2-norm of femur, scaled by gnorm**-1. - t = t2 / (t1 + dsqrt(t1**2 + femnsq*t2)) -c *** dogleg step = cauchy step + t * femur. - t1 = (t - one) * cfact - v(grdfac) = t1 - t2 = -t * relax - v(nwtfac) = t2 - v(stppar) = two - t - v(gtstep) = t1*gnorm**2 + t2*ghinvg - v(preduc) = -t1*gnorm * ((t2 + one)*gnorm) - 1 - t2 * (one + half*t2)*ghinvg - 2 - half * (v(gthg)*t1)**2 - do 80 i = 1, n - 80 step(i) = t1*dig(i) + t2*nwtstp(i) -c - 999 return -c *** last line of dbdog follows *** - end - subroutine ltvmul(n, x, l, y) -c -c *** compute x = (l**t)*y, where l is an n x n lower -c *** triangular matrix stored compactly by rows. x and y may -c *** occupy the same storage. *** -c - integer n -cal double precision x(n), l(1), y(n) - double precision x(n), l(n*(n+1)/2), y(n) -c dimension l(n*(n+1)/2) - integer i, ij, i0, j - double precision yi, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - i0 = 0 - do 20 i = 1, n - yi = y(i) - x(i) = zero - do 10 j = 1, i - ij = i0 + j - x(j) = x(j) + yi*l(ij) - 10 continue - i0 = i0 + i - 20 continue - 999 return -c *** last card of ltvmul follows *** - end - subroutine lupdat(beta, gamma, l, lambda, lplus, n, w, z) -c -c *** compute lplus = secant update of l *** -c -c *** parameter declarations *** -c - integer n -cal double precision beta(n), gamma(n), l(1), lambda(n), lplus(1), - double precision beta(n), gamma(n), l(n*(n+1)/2), lambda(n), - 1 lplus(n*(n+1)/2),w(n), z(n) -c dimension l(n*(n+1)/2), lplus(n*(n+1)/2) -c -c-------------------------- parameter usage -------------------------- -c -c beta = scratch vector. -c gamma = scratch vector. -c l (input) lower triangular matrix, stored rowwise. -c lambda = scratch vector. -c lplus (output) lower triangular matrix, stored rowwise, which may -c occupy the same storage as l. -c n (input) length of vector parameters and order of matrices. -c w (input, destroyed on output) right singular vector of rank 1 -c correction to l. -c z (input, destroyed on output) left singular vector of rank 1 -c correction to l. -c -c------------------------------- notes ------------------------------- -c -c *** application and usage restrictions *** -c -c this routine updates the cholesky factor l of a symmetric -c positive definite matrix to which a secant update is being -c applied -- it computes a cholesky factor lplus of -c l * (i + z*w**t) * (i + w*z**t) * l**t. it is assumed that w -c and z have been chosen so that the updated matrix is strictly -c positive definite. -c -c *** algorithm notes *** -c -c this code uses recurrence 3 of ref. 1 (with d(j) = 1 for all j) -c to compute lplus of the form l * (i + z*w**t) * q, where q -c is an orthogonal matrix that makes the result lower triangular. -c lplus may have some negative diagonal elements. -c -c *** references *** -c -c 1. goldfarb, d. (1976), factorized variable metric methods for uncon- -c strained optimization, math. comput. 30, pp. 796-811. -c -c *** general *** -c -c coded by david m. gay (fall 1979). -c this subroutine was written in connection with research supported -c by the national science foundation under grants mcs-7600324 and -c mcs-7906671. -c -c------------------------ external quantities ------------------------ -c -c *** intrinsic functions *** -c/+ - double precision dsqrt -c/ -c-------------------------- local variables -------------------------- -c - integer i, ij, j, jj, jp1, k, nm1, np1 - double precision a, b, bj, eta, gj, lj, lij, ljj, nu, s, theta, - 1 wj, zj - double precision one, zero -c -c *** data initializations *** -c -c/6 -c data one/1.d+0/, zero/0.d+0/ -c/7 - parameter (one=1.d+0, zero=0.d+0) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - nu = one - eta = zero - if (n .le. 1) go to 30 - nm1 = n - 1 -c -c *** temporarily store s(j) = sum over k = j+1 to n of w(k)**2 in -c *** lambda(j). -c - s = zero - do 10 i = 1, nm1 - j = n - i - s = s + w(j+1)**2 - lambda(j) = s - 10 continue -c -c *** compute lambda, gamma, and beta by goldfarb*s recurrence 3. -c - do 20 j = 1, nm1 - wj = w(j) - a = nu*z(j) - eta*wj - theta = one + a*wj - s = a*lambda(j) - lj = dsqrt(theta**2 + a*s) - if (theta .gt. zero) lj = -lj - lambda(j) = lj - b = theta*wj + s - gamma(j) = b * nu / lj - beta(j) = (a - b*eta) / lj - nu = -nu / lj - eta = -(eta + (a**2)/(theta - lj)) / lj - 20 continue - 30 lambda(n) = one + (nu*z(n) - eta*w(n))*w(n) -c -c *** update l, gradually overwriting w and z with l*w and l*z. -c - np1 = n + 1 - jj = n * (n + 1) / 2 - do 60 k = 1, n - j = np1 - k - lj = lambda(j) - ljj = l(jj) - lplus(jj) = lj * ljj - wj = w(j) - w(j) = ljj * wj - zj = z(j) - z(j) = ljj * zj - if (k .eq. 1) go to 50 - bj = beta(j) - gj = gamma(j) - ij = jj + j - jp1 = j + 1 - do 40 i = jp1, n - lij = l(ij) - lplus(ij) = lj*lij + bj*w(i) + gj*z(i) - w(i) = w(i) + lij*wj - z(i) = z(i) + lij*zj - ij = ij + i - 40 continue - 50 jj = jj - j - 60 continue -c - 999 return -c *** last card of lupdat follows *** - end - subroutine lvmul(n, x, l, y) -c -c *** compute x = l*y, where l is an n x n lower triangular -c *** matrix stored compactly by rows. x and y may occupy the same -c *** storage. *** -c - integer n -cal double precision x(n), l(1), y(n) - double precision x(n), l(n*(n+1)/2), y(n) -c dimension l(n*(n+1)/2) - integer i, ii, ij, i0, j, np1 - double precision t, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - np1 = n + 1 - i0 = n*(n+1)/2 - do 20 ii = 1, n - i = np1 - ii - i0 = i0 - i - t = zero - do 10 j = 1, i - ij = i0 + j - t = t + l(ij)*y(j) - 10 continue - x(i) = t - 20 continue - 999 return -c *** last card of lvmul follows *** - end - subroutine vvmulp(n, x, y, z, k) -c -c *** set x(i) = y(i) * z(i)**k, 1 .le. i .le. n (for k = 1 or -1) *** -c - integer n, k - double precision x(n), y(n), z(n) - integer i -c - if (k .ge. 0) go to 20 - do 10 i = 1, n - 10 x(i) = y(i) / z(i) - go to 999 -c - 20 do 30 i = 1, n - 30 x(i) = y(i) * z(i) - 999 return -c *** last card of vvmulp follows *** - end - subroutine wzbfgs (l, n, s, w, y, z) -c -c *** compute y and z for lupdat corresponding to bfgs update. -c - integer n -cal double precision l(1), s(n), w(n), y(n), z(n) - double precision l(n*(n+1)/2), s(n), w(n), y(n), z(n) -c dimension l(n*(n+1)/2) -c -c-------------------------- parameter usage -------------------------- -c -c l (i/o) cholesky factor of hessian, a lower triang. matrix stored -c compactly by rows. -c n (input) order of l and length of s, w, y, z. -c s (input) the step just taken. -c w (output) right singular vector of rank 1 correction to l. -c y (input) change in gradients corresponding to s. -c z (output) left singular vector of rank 1 correction to l. -c -c------------------------------- notes ------------------------------- -c -c *** algorithm notes *** -c -c when s is computed in certain ways, e.g. by gqtstp or -c dbldog, it is possible to save n**2/2 operations since (l**t)*s -c or l*(l**t)*s is then known. -c if the bfgs update to l*(l**t) would reduce its determinant to -c less than eps times its old value, then this routine in effect -c replaces y by theta*y + (1 - theta)*l*(l**t)*s, where theta -c (between 0 and 1) is chosen to make the reduction factor = eps. -c -c *** general *** -c -c coded by david m. gay (fall 1979). -c this subroutine was written in connection with research supported -c by the national science foundation under grants mcs-7600324 and -c mcs-7906671. -c -c------------------------ external quantities ------------------------ -c -c *** functions and subroutines called *** -c - external dotprd, livmul, ltvmul - double precision dotprd -c dotprd returns inner product of two vectors. -c livmul multiplies l**-1 times a vector. -c ltvmul multiplies l**t times a vector. -c -c *** intrinsic functions *** -c/+ - double precision dsqrt -c/ -c-------------------------- local variables -------------------------- -c - integer i - double precision cs, cy, eps, epsrt, one, shs, ys, theta -c -c *** data initializations *** -c -c/6 -c data eps/0.1d+0/, one/1.d+0/ -c/7 - parameter (eps=0.1d+0, one=1.d+0) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - call ltvmul(n, w, l, s) - shs = dotprd(n, w, w) - ys = dotprd(n, y, s) - if (ys .ge. eps*shs) go to 10 - theta = (one - eps) * shs / (shs - ys) - epsrt = dsqrt(eps) - cy = theta / (shs * epsrt) - cs = (one + (theta-one)/epsrt) / shs - go to 20 - 10 cy = one / (dsqrt(ys) * dsqrt(shs)) - cs = one / shs - 20 call livmul(n, z, l, y) - do 30 i = 1, n - 30 z(i) = cy * z(i) - cs * w(i) -c - 999 return -c *** last card of wzbfgs follows *** - end diff --git a/source/unres/src_MD_DFA/surfatom.f b/source/unres/src_MD_DFA/surfatom.f deleted file mode 100644 index 9974842..0000000 --- a/source/unres/src_MD_DFA/surfatom.f +++ /dev/null @@ -1,494 +0,0 @@ -c -c -c ################################################### -c ## COPYRIGHT (C) 1996 by Jay William Ponder ## -c ## All Rights Reserved ## -c ################################################### -c -c ################################################################ -c ## ## -c ## subroutine surfatom -- exposed surface area of an atom ## -c ## ## -c ################################################################ -c -c -c "surfatom" performs an analytical computation of the surface -c area of a specified atom; a simplified version of "surface" -c -c literature references: -c -c T. J. Richmond, "Solvent Accessible Surface Area and -c Excluded Volume in Proteins", Journal of Molecular Biology, -c 178, 63-89 (1984) -c -c L. Wesson and D. Eisenberg, "Atomic Solvation Parameters -c Applied to Molecular Dynamics of Proteins in Solution", -c Protein Science, 1, 227-235 (1992) -c -c variables and parameters: -c -c ir number of atom for which area is desired -c area accessible surface area of the atom -c radius radii of each of the individual atoms -c -c - subroutine surfatom (ir,area,radius) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizes.i' - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - integer nres,nsup,nstart_sup - double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm - common /chain/ c(3,maxres2+2),dc(3,0:maxres2),dc_old(3,0:maxres2), - & xloc(3,maxres),xrot(3,maxres),dc_norm(3,0:maxres2), - & dc_work(MAXRES6),nres,nres0 - integer maxarc - parameter (maxarc=300) - integer i,j,k,m - integer ii,ib,jb - integer io,ir - integer mi,ni,narc - integer key(maxarc) - integer intag(maxarc) - integer intag1(maxarc) - real*8 area,arcsum - real*8 arclen,exang - real*8 delta,delta2 - real*8 eps,rmove - real*8 xr,yr,zr - real*8 rr,rrsq - real*8 rplus,rminus - real*8 axx,axy,axz - real*8 ayx,ayy - real*8 azx,azy,azz - real*8 uxj,uyj,uzj - real*8 tx,ty,tz - real*8 txb,tyb,td - real*8 tr2,tr,txr,tyr - real*8 tk1,tk2 - real*8 thec,the,t,tb - real*8 txk,tyk,tzk - real*8 t1,ti,tf,tt - real*8 txj,tyj,tzj - real*8 ccsq,cc,xysq - real*8 bsqk,bk,cosine - real*8 dsqj,gi,pix2 - real*8 therk,dk,gk - real*8 risqk,rik - real*8 radius(maxatm) - real*8 ri(maxarc),risq(maxarc) - real*8 ux(maxarc),uy(maxarc),uz(maxarc) - real*8 xc(maxarc),yc(maxarc),zc(maxarc) - real*8 xc1(maxarc),yc1(maxarc),zc1(maxarc) - real*8 dsq(maxarc),bsq(maxarc) - real*8 dsq1(maxarc),bsq1(maxarc) - real*8 arci(maxarc),arcf(maxarc) - real*8 ex(maxarc),lt(maxarc),gr(maxarc) - real*8 b(maxarc),b1(maxarc),bg(maxarc) - real*8 kent(maxarc),kout(maxarc) - real*8 ther(maxarc) - logical moved,top - logical omit(maxarc) -c -c -c zero out the surface area for the sphere of interest -c - area = 0.0d0 -c write (2,*) "ir",ir," radius",radius(ir) - if (radius(ir) .eq. 0.0d0) return -c -c set the overlap significance and connectivity shift -c - pix2 = 2.0d0 * pi - delta = 1.0d-8 - delta2 = delta * delta - eps = 1.0d-8 - moved = .false. - rmove = 1.0d-8 -c -c store coordinates and radius of the sphere of interest -c - xr = c(1,ir) - yr = c(2,ir) - zr = c(3,ir) - rr = radius(ir) - rrsq = rr * rr -c -c initialize values of some counters and summations -c - 10 continue - io = 0 - jb = 0 - ib = 0 - arclen = 0.0d0 - exang = 0.0d0 -c -c test each sphere to see if it overlaps the sphere of interest -c - do i = 1, 2*nres - if (i.eq.ir .or. radius(i).eq.0.0d0) goto 30 - rplus = rr + radius(i) - tx = c(1,i) - xr - if (abs(tx) .ge. rplus) goto 30 - ty = c(2,i) - yr - if (abs(ty) .ge. rplus) goto 30 - tz = c(3,i) - zr - if (abs(tz) .ge. rplus) goto 30 -c -c check for sphere overlap by testing distance against radii -c - xysq = tx*tx + ty*ty - if (xysq .lt. delta2) then - tx = delta - ty = 0.0d0 - xysq = delta2 - end if - ccsq = xysq + tz*tz - cc = sqrt(ccsq) - if (rplus-cc .le. delta) goto 30 - rminus = rr - radius(i) -c -c check to see if sphere of interest is completely buried -c - if (cc-abs(rminus) .le. delta) then - if (rminus .le. 0.0d0) goto 170 - goto 30 - end if -c -c check for too many overlaps with sphere of interest -c - if (io .ge. maxarc) then - write (iout,20) - 20 format (/,' SURFATOM -- Increase the Value of MAXARC') - stop - end if -c -c get overlap between current sphere and sphere of interest -c - io = io + 1 - xc1(io) = tx - yc1(io) = ty - zc1(io) = tz - dsq1(io) = xysq - bsq1(io) = ccsq - b1(io) = cc - gr(io) = (ccsq+rplus*rminus) / (2.0d0*rr*b1(io)) - intag1(io) = i - omit(io) = .false. - 30 continue - end do -c -c case where no other spheres overlap the sphere of interest -c - if (io .eq. 0) then - area = 4.0d0 * pi * rrsq - return - end if -c -c case where only one sphere overlaps the sphere of interest -c - if (io .eq. 1) then - area = pix2 * (1.0d0 + gr(1)) - area = mod(area,4.0d0*pi) * rrsq - return - end if -c -c case where many spheres intersect the sphere of interest; -c sort the intersecting spheres by their degree of overlap -c - call sort2 (io,gr,key) - do i = 1, io - k = key(i) - intag(i) = intag1(k) - xc(i) = xc1(k) - yc(i) = yc1(k) - zc(i) = zc1(k) - dsq(i) = dsq1(k) - b(i) = b1(k) - bsq(i) = bsq1(k) - end do -c -c get radius of each overlap circle on surface of the sphere -c - do i = 1, io - gi = gr(i) * rr - bg(i) = b(i) * gi - risq(i) = rrsq - gi*gi - ri(i) = sqrt(risq(i)) - ther(i) = 0.5d0*pi - asin(min(1.0d0,max(-1.0d0,gr(i)))) - end do -c -c find boundary of inaccessible area on sphere of interest -c - do k = 1, io-1 - if (.not. omit(k)) then - txk = xc(k) - tyk = yc(k) - tzk = zc(k) - bk = b(k) - therk = ther(k) -c -c check to see if J circle is intersecting K circle; -c get distance between circle centers and sum of radii -c - do j = k+1, io - if (omit(j)) goto 60 - cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j)) - cc = acos(min(1.0d0,max(-1.0d0,cc))) - td = therk + ther(j) -c -c check to see if circles enclose separate regions -c - if (cc .ge. td) goto 60 -c -c check for circle J completely inside circle K -c - if (cc+ther(j) .lt. therk) goto 40 -c -c check for circles that are essentially parallel -c - if (cc .gt. delta) goto 50 - 40 continue - omit(j) = .true. - goto 60 -c -c check to see if sphere of interest is completely buried -c - 50 continue - if (pix2-cc .le. td) goto 170 - 60 continue - end do - end if - end do -c -c find T value of circle intersections -c - do k = 1, io - if (omit(k)) goto 110 - omit(k) = .true. - narc = 0 - top = .false. - txk = xc(k) - tyk = yc(k) - tzk = zc(k) - dk = sqrt(dsq(k)) - bsqk = bsq(k) - bk = b(k) - gk = gr(k) * rr - risqk = risq(k) - rik = ri(k) - therk = ther(k) -c -c rotation matrix elements -c - t1 = tzk / (bk*dk) - axx = txk * t1 - axy = tyk * t1 - axz = dk / bk - ayx = tyk / dk - ayy = txk / dk - azx = txk / bk - azy = tyk / bk - azz = tzk / bk - do j = 1, io - if (.not. omit(j)) then - txj = xc(j) - tyj = yc(j) - tzj = zc(j) -c -c rotate spheres so K vector colinear with z-axis -c - uxj = txj*axx + tyj*axy - tzj*axz - uyj = tyj*ayy - txj*ayx - uzj = txj*azx + tyj*azy + tzj*azz - cosine = min(1.0d0,max(-1.0d0,uzj/b(j))) - if (acos(cosine) .lt. therk+ther(j)) then - dsqj = uxj*uxj + uyj*uyj - tb = uzj*gk - bg(j) - txb = uxj * tb - tyb = uyj * tb - td = rik * dsqj - tr2 = risqk*dsqj - tb*tb - tr2 = max(eps,tr2) - tr = sqrt(tr2) - txr = uxj * tr - tyr = uyj * tr -c -c get T values of intersection for K circle -c - tb = (txb+tyr) / td - tb = min(1.0d0,max(-1.0d0,tb)) - tk1 = acos(tb) - if (tyb-txr .lt. 0.0d0) tk1 = pix2 - tk1 - tb = (txb-tyr) / td - tb = min(1.0d0,max(-1.0d0,tb)) - tk2 = acos(tb) - if (tyb+txr .lt. 0.0d0) tk2 = pix2 - tk2 - thec = (rrsq*uzj-gk*bg(j)) / (rik*ri(j)*b(j)) - if (abs(thec) .lt. 1.0d0) then - the = -acos(thec) - else if (thec .ge. 1.0d0) then - the = 0.0d0 - else if (thec .le. -1.0d0) then - the = -pi - end if -c -c see if "tk1" is entry or exit point; check t=0 point; -c "ti" is exit point, "tf" is entry point -c - cosine = min(1.0d0,max(-1.0d0, - & (uzj*gk-uxj*rik)/(b(j)*rr))) - if ((acos(cosine)-ther(j))*(tk2-tk1) .le. 0.0d0) then - ti = tk2 - tf = tk1 - else - ti = tk2 - tf = tk1 - end if - narc = narc + 1 - if (narc .ge. maxarc) then - write (iout,70) - 70 format (/,' SURFATOM -- Increase the Value', - & ' of MAXARC') - stop - end if - if (tf .le. ti) then - arcf(narc) = tf - arci(narc) = 0.0d0 - tf = pix2 - lt(narc) = j - ex(narc) = the - top = .true. - narc = narc + 1 - end if - arcf(narc) = tf - arci(narc) = ti - lt(narc) = j - ex(narc) = the - ux(j) = uxj - uy(j) = uyj - uz(j) = uzj - end if - end if - end do - omit(k) = .false. -c -c special case; K circle without intersections -c - if (narc .le. 0) goto 90 -c -c general case; sum up arclength and set connectivity code -c - call sort2 (narc,arci,key) - arcsum = arci(1) - mi = key(1) - t = arcf(mi) - ni = mi - if (narc .gt. 1) then - do j = 2, narc - m = key(j) - if (t .lt. arci(j)) then - arcsum = arcsum + arci(j) - t - exang = exang + ex(ni) - jb = jb + 1 - if (jb .ge. maxarc) then - write (iout,80) - 80 format (/,' SURFATOM -- Increase the Value', - & ' of MAXARC') - stop - end if - i = lt(ni) - kent(jb) = maxarc*i + k - i = lt(m) - kout(jb) = maxarc*k + i - end if - tt = arcf(m) - if (tt .ge. t) then - t = tt - ni = m - end if - end do - end if - arcsum = arcsum + pix2 - t - if (.not. top) then - exang = exang + ex(ni) - jb = jb + 1 - i = lt(ni) - kent(jb) = maxarc*i + k - i = lt(mi) - kout(jb) = maxarc*k + i - end if - goto 100 - 90 continue - arcsum = pix2 - ib = ib + 1 - 100 continue - arclen = arclen + gr(k)*arcsum - 110 continue - end do - if (arclen .eq. 0.0d0) goto 170 - if (jb .eq. 0) goto 150 -c -c find number of independent boundaries and check connectivity -c - j = 0 - do k = 1, jb - if (kout(k) .ne. 0) then - i = k - 120 continue - m = kout(i) - kout(i) = 0 - j = j + 1 - do ii = 1, jb - if (m .eq. kent(ii)) then - if (ii .eq. k) then - ib = ib + 1 - if (j .eq. jb) goto 150 - goto 130 - end if - i = ii - goto 120 - end if - end do - 130 continue - end if - end do - ib = ib + 1 -c -c attempt to fix connectivity error by moving atom slightly -c - if (moved) then - write (iout,140) ir - 140 format (/,' SURFATOM -- Connectivity Error at Atom',i6) - else - moved = .true. - xr = xr + rmove - yr = yr + rmove - zr = zr + rmove - goto 10 - end if -c -c compute the exposed surface area for the sphere of interest -c - 150 continue - area = ib*pix2 + exang + arclen - area = mod(area,4.0d0*pi) * rrsq -c -c attempt to fix negative area by moving atom slightly -c - if (area .lt. 0.0d0) then - if (moved) then - write (iout,160) ir - 160 format (/,' SURFATOM -- Negative Area at Atom',i6) - else - moved = .true. - xr = xr + rmove - yr = yr + rmove - zr = zr + rmove - goto 10 - end if - end if - 170 continue - return - end diff --git a/source/unres/src_MD_DFA/test.F b/source/unres/src_MD_DFA/test.F deleted file mode 100644 index 0140ee5..0000000 --- a/source/unres/src_MD_DFA/test.F +++ /dev/null @@ -1,863 +0,0 @@ - subroutine test - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.CHAIN' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar),var1(maxvar) - integer j1,j2 - logical debug,accepted - debug=.true. - - - call geom_to_var(nvar,var1) - call chainbuild - call etotal(energy(0)) - etot=energy(0) - call rmsd(rms) - write(iout,*) 'etot=',0,etot,rms - call secondary2(.false.) - - call write_pdb(0,'first structure',etot) - - j1=13 - j2=21 - da=180.0*deg2rad - - - - temp=3000.0d0 - betbol=1.0D0/(1.9858D-3*temp) - jr=iran_num(j1,j2) - d=ran_number(-pi,pi) -c phi(jr)=pinorm(phi(jr)+d) - call chainbuild - call etotal(energy(0)) - etot0=energy(0) - call rmsd(rms) - write(iout,*) 'etot=',1,etot0,rms - call write_pdb(1,'perturb structure',etot0) - - do i=2,500,2 - jr=iran_num(j1,j2) - d=ran_number(-da,da) - phiold=phi(jr) - phi(jr)=pinorm(phi(jr)+d) - call chainbuild - call etotal(energy(0)) - etot=energy(0) - - if (etot.lt.etot0) then - accepted=.true. - else - accepted=.false. - xxr=ran_number(0.0D0,1.0D0) - xxh=betbol*(etot-etot0) - if (xxh.lt.50.0D0) then - xxh=dexp(-xxh) - if (xxh.gt.xxr) accepted=.true. - endif - endif - accepted=.true. -c print *,etot0,etot,accepted - if (accepted) then - etot0=etot - call rmsd(rms) - write(iout,*) 'etot=',i,etot,rms - call write_pdb(i,'MC structure',etot) -c minimize -c call geom_to_var(nvar,var1) - call sc_move(2,nres-1,1,10d0,nft_sc,etot) - call geom_to_var(nvar,var) - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun - call var_to_geom(nvar,var) - call chainbuild - call rmsd(rms) - write(iout,*) 'etot mcm=',i,etot,rms - call write_pdb(i+1,'MCM structure',etot) - call var_to_geom(nvar,var1) -c -------- - else - phi(jr)=phiold - endif - enddo - -c minimize -c call sc_move(2,nres-1,1,10d0,nft_sc,etot) -c call geom_to_var(nvar,var) -c -c call chainbuild -c call write_pdb(998 ,'sc min',etot) -c -c call minimize(etot,var,iretcode,nfun) -c write(iout,*)'------------------------------------------------' -c write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun -c -c call var_to_geom(nvar,var) -c call chainbuild -c call write_pdb(999,'full min',etot) - - - return - end - - - - - subroutine test_local - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision varia(maxvar) -c - call chainbuild -c call geom_to_var(nvar,varia) - call write_pdb(1,'first structure',0d0) - - call etotal(energy(0)) - etot=energy(0) - write(iout,*) nnt,nct,etot - - write(iout,*) 'calling sc_move' - call sc_move(nnt,nct,5,10d0,nft_sc,etot) - write(iout,*) nft_sc,etot - call write_pdb(2,'second structure',etot) - - write(iout,*) 'calling local_move' - call local_move_init(.false.) - call local_move(24,29,20d0,50d0) - call chainbuild - call write_pdb(3,'third structure',etot) - - write(iout,*) 'calling sc_move' - call sc_move(24,29,5,10d0,nft_sc,etot) - write(iout,*) nft_sc,etot - call write_pdb(2,'last structure',etot) - - - return - end - - subroutine test_sc - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision varia(maxvar) -c - call chainbuild -c call geom_to_var(nvar,varia) - call write_pdb(1,'first structure',0d0) - - call etotal(energy(0)) - etot=energy(0) - write(iout,*) nnt,nct,etot - - write(iout,*) 'calling sc_move' - - call sc_move(nnt,nct,5,10d0,nft_sc,etot) - write(iout,*) nft_sc,etot - call write_pdb(2,'second structure',etot) - - write(iout,*) 'calling sc_move 2nd time' - - call sc_move(nnt,nct,5,1d0,nft_sc,etot) - write(iout,*) nft_sc,etot - call write_pdb(3,'last structure',etot) - return - end -c-------------------------------------------------------- - subroutine bgrow(bstrand,nbstrand,in,ind,new) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - integer bstrand(maxres/3,6) - - ishift=iabs(bstrand(in,ind+4)-new) - - print *,'bgrow',bstrand(in,ind+4),new,ishift - - bstrand(in,ind)=new - - if(ind.eq.1)then - bstrand(nbstrand,5)=bstrand(nbstrand,1) - do i=1,nbstrand-1 - IF (bstrand(nbstrand,3).eq.bstrand(i,3)) THEN - if (bstrand(i,5).lt.bstrand(i,6)) then - bstrand(i,5)=bstrand(i,5)-ishift - else - bstrand(i,5)=bstrand(i,5)+ishift - endif - ENDIF - enddo - else - bstrand(nbstrand,6)=bstrand(nbstrand,2) - do i=1,nbstrand-1 - IF (bstrand(nbstrand,3).eq.bstrand(i,3)) THEN - if (bstrand(i,6).lt.bstrand(i,5)) then - bstrand(i,6)=bstrand(i,6)-ishift - else - bstrand(i,6)=bstrand(i,6)+ishift - endif - ENDIF - enddo - endif - - - return - end - - -c------------------------------------------------- - - subroutine secondary(lprint) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - - integer ncont,icont(2,maxres*maxres/2),isec(maxres,3) - logical lprint,not_done - real dcont(maxres*maxres/2),d - real rcomp /7.0/ - real rbeta /5.2/ - real ralfa /5.2/ - real r310 /6.6/ - double precision xpi(3),xpj(3) - - - - call chainbuild -cd call write_pdb(99,'sec structure',0d0) - ncont=0 - nbfrag=0 - nhfrag=0 - do i=1,nres - isec(i,1)=0 - isec(i,2)=0 - isec(i,3)=0 - enddo - - do i=2,nres-3 - do k=1,3 - xpi(k)=0.5d0*(c(k,i-1)+c(k,i)) - enddo - do j=i+2,nres - do k=1,3 - xpj(k)=0.5d0*(c(k,j-1)+c(k,j)) - enddo -cd d = (c(1,i)-c(1,j))*(c(1,i)-c(1,j)) + -cd & (c(2,i)-c(2,j))*(c(2,i)-c(2,j)) + -cd & (c(3,i)-c(3,j))*(c(3,i)-c(3,j)) -cd print *,'CA',i,j,d - d = (xpi(1)-xpj(1))*(xpi(1)-xpj(1)) + - & (xpi(2)-xpj(2))*(xpi(2)-xpj(2)) + - & (xpi(3)-xpj(3))*(xpi(3)-xpj(3)) - if ( d.lt.rcomp*rcomp) then - ncont=ncont+1 - icont(1,ncont)=i - icont(2,ncont)=j - dcont(ncont)=sqrt(d) - endif - enddo - enddo - if (lprint) then - write (iout,*) - write (iout,'(a)') '#PP contact map distances:' - do i=1,ncont - write (iout,'(3i4,f10.5)') - & i,icont(1,i),icont(2,i),dcont(i) - enddo - endif - -c finding parallel beta -cd write (iout,*) '------- looking for parallel beta -----------' - nbeta=0 - nstrand=0 - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if(dcont(i).le.rbeta .and. j1-i1.gt.4 .and. - & isec(i1,1).le.1.and.isec(j1,1).le.1.and. - & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. - & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. - & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. - & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) - & ) then - ii1=i1 - jj1=j1 -cd write (iout,*) i1,j1,dcont(i) - not_done=.true. - do while (not_done) - i1=i1+1 - j1=j1+1 - do j=1,ncont - if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j) - & .and. dcont(j).le.rbeta .and. - & isec(i1,1).le.1.and.isec(j1,1).le.1.and. - & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. - & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. - & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. - & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) - & ) goto 5 - enddo - not_done=.false. - 5 continue -cd write (iout,*) i1,j1,dcont(j),not_done - enddo - j1=j1-1 - i1=i1-1 - if (i1-ii1.gt.1) then - ii1=max0(ii1-1,1) - jj1=max0(jj1-1,1) - nbeta=nbeta+1 - if(lprint)write(iout,*)'parallel beta',nbeta,ii1,i1,jj1,j1 - - nbfrag=nbfrag+1 - bfrag(1,nbfrag)=ii1 - bfrag(2,nbfrag)=i1 - bfrag(3,nbfrag)=jj1 - bfrag(4,nbfrag)=j1 - - do ij=ii1,i1 - isec(ij,1)=isec(ij,1)+1 - isec(ij,1+isec(ij,1))=nbeta - enddo - do ij=jj1,j1 - isec(ij,1)=isec(ij,1)+1 - isec(ij,1+isec(ij,1))=nbeta - enddo - - if(lprint) then - nstrand=nstrand+1 - if (nbeta.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-1,"..",i1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-1,"..",i1-1,"'" - endif - nstrand=nstrand+1 - if (nbeta.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",jj1-1,"..",j1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",jj1-1,"..",j1-1,"'" - endif - write(12,'(a8,4i4)') - & "SetNeigh",ii1-1,i1-1,jj1-1,j1-1 - endif - endif - endif - enddo - -c finding antiparallel beta -cd write (iout,*) '--------- looking for antiparallel beta ---------' - - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if (dcont(i).le.rbeta.and. - & isec(i1,1).le.1.and.isec(j1,1).le.1.and. - & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. - & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. - & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. - & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) - & ) then - ii1=i1 - jj1=j1 -cd write (iout,*) i1,j1,dcont(i) - - not_done=.true. - do while (not_done) - i1=i1+1 - j1=j1-1 - do j=1,ncont - if (i1.eq.icont(1,j).and.j1.eq.icont(2,j) .and. - & isec(i1,1).le.1.and.isec(j1,1).le.1.and. - & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. - & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. - & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. - & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) - & .and. dcont(j).le.rbeta ) goto 6 - enddo - not_done=.false. - 6 continue -cd write (iout,*) i1,j1,dcont(j),not_done - enddo - i1=i1-1 - j1=j1+1 - if (i1-ii1.gt.1) then - if(lprint)write (iout,*)'antiparallel beta', - & nbeta,ii1-1,i1,jj1,j1-1 - - nbfrag=nbfrag+1 - bfrag(1,nbfrag)=max0(ii1-1,1) - bfrag(2,nbfrag)=i1 - bfrag(3,nbfrag)=jj1 - bfrag(4,nbfrag)=max0(j1-1,1) - - nbeta=nbeta+1 - iii1=max0(ii1-1,1) - do ij=iii1,i1 - isec(ij,1)=isec(ij,1)+1 - isec(ij,1+isec(ij,1))=nbeta - enddo - jjj1=max0(j1-1,1) - do ij=jjj1,jj1 - isec(ij,1)=isec(ij,1)+1 - isec(ij,1+isec(ij,1))=nbeta - enddo - - - if (lprint) then - nstrand=nstrand+1 - if (nstrand.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-2,"..",i1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-2,"..",i1-1,"'" - endif - nstrand=nstrand+1 - if (nstrand.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",j1-2,"..",jj1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",j1-2,"..",jj1-1,"'" - endif - write(12,'(a8,4i4)') - & "SetNeigh",ii1-2,i1-1,jj1-1,j1-2 - endif - endif - endif - enddo - - if (nstrand.gt.0.and.lprint) then - write(12,'(a27,$)') "DefPropRes 'sheet' 'strand1" - do i=2,nstrand - if (i.le.9) then - write(12,'(a9,i1,$)') " | strand",i - else - write(12,'(a9,i2,$)') " | strand",i - endif - enddo - write(12,'(a1)') "'" - endif - - -c finding alpha or 310 helix - - nhelix=0 - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if (j1.eq.i1+3.and.dcont(i).le.r310 - & .or.j1.eq.i1+4.and.dcont(i).le.ralfa ) then -cd if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,dcont(i) -cd if (j1.eq.i1+4) write (iout,*) "found 1-5 ",i1,j1,dcont(i) - ii1=i1 - jj1=j1 - if (isec(ii1,1).eq.0) then - not_done=.true. - else - not_done=.false. - endif - do while (not_done) - i1=i1+1 - j1=j1+1 - do j=1,ncont - if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10 - enddo - not_done=.false. - 10 continue -cd write (iout,*) i1,j1,not_done - enddo - j1=j1-1 - if (j1-ii1.gt.4) then - nhelix=nhelix+1 -cd write (iout,*)'helix',nhelix,ii1,j1 - - nhfrag=nhfrag+1 - hfrag(1,nhfrag)=ii1 - hfrag(2,nhfrag)=max0(j1-1,1) - - do ij=ii1,j1 - isec(ij,1)=-1 - enddo - if (lprint) then - write (iout,'(a6,i3,2i4)') "Helix",nhelix,ii1-1,j1-2 - if (nhelix.le.9) then - write(12,'(a17,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'helix",nhelix, - & "' 'num = ",ii1-1,"..",j1-2,"'" - else - write(12,'(a17,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'helix",nhelix, - & "' 'num = ",ii1-1,"..",j1-2,"'" - endif - endif - endif - endif - enddo - - if (nhelix.gt.0.and.lprint) then - write(12,'(a26,$)') "DefPropRes 'helix' 'helix1" - do i=2,nhelix - if (nhelix.le.9) then - write(12,'(a8,i1,$)') " | helix",i - else - write(12,'(a8,i2,$)') " | helix",i - endif - enddo - write(12,'(a1)') "'" - endif - - if (lprint) then - write(12,'(a37)') "DefPropRes 'coil' '! (helix | sheet)'" - write(12,'(a20)') "XMacStand ribbon.mac" - endif - - - return - end -c---------------------------------------------------------------------------- - - subroutine write_pdb(npdb,titelloc,ee) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - character*50 titelloc1 - character*(*) titelloc - character*3 zahl - character*5 liczba5 - double precision ee - integer npdb,ilen - external ilen - - titelloc1=titelloc - lenpre=ilen(prefix) - if (npdb.lt.1000) then - call numstr(npdb,zahl) - open(ipdb,file=prefix(:lenpre)//'@@'//zahl//'.pdb') - else - if (npdb.lt.10000) then - write(liczba5,'(i1,i4)') 0,npdb - else - write(liczba5,'(i5)') npdb - endif - open(ipdb,file=prefix(:lenpre)//'@@'//liczba5//'.pdb') - endif - call pdbout(ee,titelloc1,ipdb) - close(ipdb) - return - end - -c-------------------------------------------------------- - subroutine softreg - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.INTERACT' -c - include 'COMMON.DISTFIT' - integer iff(maxres) - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar) - integer ieval -c - logical debug,ltest,fail - character*50 linia -c - linia='test' - debug=.true. - in_pdb=0 - - - -c------------------------ -c -c freeze sec.elements -c - do i=1,nres - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - iff(i)=0 - enddo - - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - enddo - mask_r=.true. - - - - nhpb0=nhpb -c -c store dist. constrains -c - do i=1,nres-3 - do j=i+3,nres - if ( iff(i).eq.1.and.iff(j).eq.1 ) then - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=0.1 - dhpb(nhpb)=DIST(i,j) - endif - enddo - enddo - call hpb_partition - - if (debug) then - call chainbuild - call write_pdb(100+in_pdb,'input reg. structure',0d0) - endif - - - ipot0=ipot - maxmin0=maxmin - maxfun0=maxfun - wstrain0=wstrain - wang0=wang -c -c run soft pot. optimization -c - ipot=6 - wang=3.0 - maxmin=2000 - maxfun=4000 - call geom_to_var(nvar,var) -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - - write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, - & nfun/(time1-time0),' SOFT eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(300+in_pdb,'soft structure',etot) - endif -c -c run full UNRES optimization with constrains and frozen 2D -c the same variables as soft pot. optimizatio -c - ipot=ipot0 - wang=wang0 - maxmin=maxmin0 - maxfun=maxfun0 -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL MASK DIST return code is',iretcode, - & ' eval ',nfun - ieval=nfun -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)') - & ' Time for mask dist min.',time1-time0, - & nfun/(time1-time0),' eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(400+in_pdb,'mask & dist',etot) - endif -c -c switch off constrains and -c run full UNRES optimization with frozen 2D -c - -c -c reset constrains -c - nhpb_c=nhpb - nhpb=nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL MASK return code is',iretcode,' eval ',nfun - ieval=ieval+nfun -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for mask min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(500+in_pdb,'mask 2d frozen',etot) - endif - - mask_r=.false. - - -c -c run full UNRES optimization with constrains and NO frozen 2D -c - - nhpb=nhpb_c - link_start=1 - link_end=nhpb - maxfun=maxfun0/5 - - do ico=1,5 - - wstrain=wstrain0/ico -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - write(iout,'(a10,f6.3,a14,i3,a6,i5)') - & ' SUMSL DIST',wstrain,' return code is',iretcode, - & ' eval ',nfun - ieval=nfun -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)') - & ' Time for dist min.',time1-time0, - & nfun/(time1-time0),' eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(600+in_pdb+ico,'dist cons',etot) - endif - - enddo -c - nhpb=nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - maxfun=maxfun0 - - -c - if (minim) then -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, - & '+ DIST eval',ieval -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(999,'full min',etot) - endif - - return - end - - diff --git a/source/unres/src_MD_DFA/thread.F b/source/unres/src_MD_DFA/thread.F deleted file mode 100644 index 9f169a0..0000000 --- a/source/unres/src_MD_DFA/thread.F +++ /dev/null @@ -1,549 +0,0 @@ - subroutine thread_seq -C Thread the sequence through a database of known structures - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.DBASE' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.THREAD' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.CONTACTS' - include 'COMMON.MCM' - include 'COMMON.NAMES' -#ifdef MPI - include 'COMMON.INFO' - integer ThreadId,ThreadType,Kwita -#endif - double precision varia(maxvar) - double precision przes(3),obr(3,3) - double precision time_for_thread - logical found_pattern,non_conv - character*32 head_pdb - double precision energia(0:n_ene) - n_ene_comp=nprint_ene -C -C Body -C -#ifdef MPI - if (me.eq.king) then - do i=1,nctasks - nsave_part(i)=0 - enddo - endif - nacc_tot=0 -#endif - Kwita=0 - close(igeom) - close(ipdb) - close(istat) - do i=1,maxthread - do j=1,14 - ener0(j,i)=0.0D0 - ener(j,i)=0.0D0 - enddo - enddo - nres0=nct-nnt+1 - ave_time_for_thread=0.0D0 - max_time_for_thread=0.0D0 -cd print *,'nthread=',nthread,' nseq=',nseq,' nres0=',nres0 - nthread=nexcl+nthread - do ithread=1,nthread - found_pattern=.false. - itrial=0 - do while (.not.found_pattern) - itrial=itrial+1 - if (itrial.gt.1000) then - write (iout,'(/a/)') 'Too many attempts to find pattern.' - nthread=ithread-1 -#ifdef MPI - call recv_stop_sig(Kwita) - call send_stop_sig(-3) -#endif - goto 777 - endif -C Find long enough chain in the database - ii=iran_num(1,nseq) - nres_t=nres_base(1,ii) -C Select the starting position to thread. - print *,'nseq',nseq,' ii=',ii,' nres_t=', - & nres_t,' nres0=',nres0 - if (nres_t.ge.nres0) then - ist=iran_num(0,nres_t-nres0) -#ifdef MPI - if (Kwita.eq.0) call recv_stop_sig(Kwita) - if (Kwita.lt.0) then - write (iout,*) 'Stop signal received. Terminating.' - write (*,*) 'Stop signal received. Terminating.' - nthread=ithread-1 - write (*,*) 'ithread=',ithread,' nthread=',nthread - goto 777 - endif - call pattern_receive -#endif - do i=1,nexcl - if (iexam(1,i).eq.ii .and. iexam(2,i).eq.ist) goto 10 - enddo - found_pattern=.true. - endif -C If this point is reached, the pattern has not yet been examined. - 10 continue -c print *,'found_pattern:',found_pattern - enddo - nexcl=nexcl+1 - iexam(1,nexcl)=ii - iexam(2,nexcl)=ist -#ifdef MPI - if (Kwita.eq.0) call recv_stop_sig(Kwita) - if (Kwita.lt.0) then - write (iout,*) 'Stop signal received. Terminating.' - nthread=ithread-1 - write (*,*) 'ithread=',ithread,' nthread=',nthread - goto 777 - endif - call pattern_send -#endif - ipatt(1,ithread)=ii - ipatt(2,ithread)=ist -#ifdef MPI - write (iout,'(/80(1h*)/a,i4,a,i5,2a,i3,a,i3,a,i3/)') - & 'Processor:',me,' Attempt:',ithread, - & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii), - & ' start at res.',ist+1 - write (*,'(a,i4,a,i5,2a,i3,a,i3,a,i3)') 'Processor:',me, - & ' Attempt:',ithread, - & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii), - & ' start at res.',ist+1 -#else - write (iout,'(/80(1h*)/a,i5,2a,i3,a,i3,a,i3/)') - & 'Attempt:',ithread, - & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii), - & ' start at res.',ist+1 - write (*,'(a,i5,2a,i3,a,i3,a,i3)') - & 'Attempt:',ithread, - & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii), - & ' start at res.',ist+1 -#endif - ipattern=ii -C Copy coordinates from the database. - ist=ist-(nnt-1) - do i=nnt,nct - do j=1,3 - c(j,i)=cart_base(j,i+ist,ii) -c cref(j,i)=c(j,i) - enddo -cd write (iout,'(a,i4,3f10.5)') restyp(itype(i)),i,(c(j,i),j=1,3) - enddo -cd call fitsq(rms,c(1,nnt),cref(1,nnt),nct-nnt+1,przes,obr, -cd non_conv) -cd write (iout,'(a,f10.5)') -cd & 'Initial RMS deviation from reference structure:',rms - if (itype(nres).eq.21) then - do j=1,3 - dcj=c(j,nres-2)-c(j,nres-3) - c(j,nres)=c(j,nres-1)+dcj - c(j,2*nres)=c(j,nres) - enddo - endif - if (itype(1).eq.21) then - do j=1,3 - dcj=c(j,4)-c(j,3) - c(j,1)=c(j,2)-dcj - c(j,nres+1)=c(j,1) - enddo - endif - call int_from_cart(.false.,.false.) -cd print *,'Exit INT_FROM_CART.' -cd print *,'nhpb=',nhpb - do i=nss+1,nhpb - ii=ihpb(i) - jj=jhpb(i) - dhpb(i)=dist(ii,jj) -c write (iout,'(2i5,2f10.5)') ihpb(i),jhpb(i),dhpb(i),forcon(i) - enddo -c stop 'End generate' -C Generate SC conformations. - call sc_conf -c call intout -#ifdef MPI -cd print *,'Processor:',me,': exit GEN_SIDE.' -#else -cd print *,'Exit GEN_SIDE.' -#endif -C Calculate initial energy. - call chainbuild - call etotal(energia(0)) - etot=energia(0) - do i=1,n_ene_comp - ener0(i,ithread)=energia(i) - enddo - ener0(n_ene_comp+1,ithread)=energia(0) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - ener0(n_ene_comp+3,ithread)=contact_fract(ncont,ncont_ref, - & icont,icont_ref) - ener0(n_ene_comp+2,ithread)=rms - ener0(n_ene_comp+4,ithread)=frac - ener0(n_ene_comp+5,ithread)=frac_nn - endif - ener0(n_ene_comp+3,ithread)=0.0d0 -C Minimize energy. -#ifdef MPI - print*,'Processor:',me,' ithread=',ithread,' Start REGULARIZE.' -#else - print*,'ithread=',ithread,' Start REGULARIZE.' -#endif - curr_tim=tcpu() - call regularize(nct-nnt+1,etot,rms, - & cart_base(1,ist+nnt,ipattern),iretcode) - curr_tim1=tcpu() - time_for_thread=curr_tim1-curr_tim - ave_time_for_thread= - & ((ithread-1)*ave_time_for_thread+time_for_thread)/ithread - if (time_for_thread.gt.max_time_for_thread) - & max_time_for_thread=time_for_thread -#ifdef MPI - print *,'Processor',me,': Exit REGULARIZE.' - if (WhatsUp.eq.2) then - write (iout,*) - & 'Sufficient number of confs. collected. Terminating.' - nthread=ithread-1 - goto 777 - else if (WhatsUp.eq.-1) then - nthread=ithread-1 - write (iout,*) 'Time up in REGULARIZE. Call SEND_STOP_SIG.' - if (Kwita.eq.0) call recv_stop_sig(Kwita) - call send_stop_sig(-2) - goto 777 - else if (WhatsUp.eq.-2) then - nthread=ithread-1 - write (iout,*) 'Timeup signal received. Terminating.' - goto 777 - else if (WhatsUp.eq.-3) then - nthread=ithread-1 - write (iout,*) 'Error stop signal received. Terminating.' - goto 777 - endif -#else - print *,'Exit REGULARIZE.' - if (iretcode.eq.11) then - write (iout,'(/a/)') - &'******* Allocated time exceeded in SUMSL. The program will stop.' - nthread=ithread-1 - goto 777 - endif -#endif - head_pdb=titel(:24)//':'//str_nam(ipattern) - if (outpdb) call pdbout(etot,head_pdb,ipdb) - if (outmol2) call mol2out(etot,head_pdb) -c call intout - call briefout(ithread,etot) - link_end0=link_end - link_end=min0(link_end,nss) - write (iout,*) 'link_end=',link_end,' link_end0=',link_end0, - & ' nss=',nss - call etotal(energia(0)) -c call enerprint(energia(0)) - link_end=link_end0 -cd call chainbuild -cd call fitsq(rms,c(1,nnt),cref(1,nnt),nct-nnt+1,przes,obr,non_conv) -cd write (iout,'(a,f10.5)') -cd & 'RMS deviation from reference structure:',dsqrt(rms) - do i=1,n_ene_comp - ener(i,ithread)=energia(i) - enddo - ener(n_ene_comp+1,ithread)=energia(0) - ener(n_ene_comp+3,ithread)=rms - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - ener(n_ene_comp+2,ithread)=rms - ener(n_ene_comp+4,ithread)=frac - ener(n_ene_comp+5,ithread)=frac_nn - endif - call write_stat_thread(ithread,ipattern,ist) -c write (istat,'(i4,2x,a8,i4,11(1pe14.5),2(0pf8.3),f8.5)') -c & ithread,str_nam(ipattern),ist+1,(ener(k,ithread),k=1,11), -c & (ener(k,ithread),k=12,14) -#ifdef MPI - if (me.eq.king) then - nacc_tot=nacc_tot+1 - call pattern_receive - call receive_MCM_info - if (nacc_tot.ge.nthread) then - write (iout,*) - & 'Sufficient number of conformations collected nacc_tot=', - & nacc_tot,'. Stopping other processors and terminating.' - write (*,*) - & 'Sufficient number of conformations collected nacc_tot=', - & nacc_tot,'. Stopping other processors and terminating.' - call recv_stop_sig(Kwita) - if (Kwita.eq.0) call send_stop_sig(-1) - nthread=ithread - goto 777 - endif - else - call send_MCM_info(2) - endif -#endif - if (timlim-curr_tim1-safety .lt. max_time_for_thread) then - write (iout,'(/2a)') - & '********** There would be not enough time for another thread. ', - & 'The program will stop.' - write (*,'(/2a)') - & '********** There would be not enough time for another thread. ', - & 'The program will stop.' - write (iout,'(a,1pe14.4/)') - & 'Elapsed time for last threading step: ',time_for_thread - nthread=ithread -#ifdef MPI - call recv_stop_sig(Kwita) - call send_stop_sig(-2) -#endif - goto 777 - else - curr_tim=curr_tim1 - write (iout,'(a,1pe14.4)') - & 'Elapsed time for this threading step: ',time_for_thread - endif -#ifdef MPI - if (Kwita.eq.0) call recv_stop_sig(Kwita) - if (Kwita.lt.0) then - write (iout,*) 'Stop signal received. Terminating.' - write (*,*) 'Stop signal received. Terminating.' - nthread=ithread - write (*,*) 'nthread=',nthread,' ithread=',ithread - goto 777 - endif -#endif - enddo -#ifdef MPI - call send_stop_sig(-1) -#endif - 777 continue -#ifdef MPI -C Any messages left for me? - call pattern_receive - if (Kwita.eq.0) call recv_stop_sig(Kwita) -#endif - call write_thread_summary -#ifdef MPI - if (king.eq.king) then - Kwita=1 - do while (Kwita.ne.0 .or. nacc_tot.ne.0) - Kwita=0 - nacc_tot=0 - call recv_stop_sig(Kwita) - call receive_MCM_info - enddo - do iproc=1,nprocs-1 - call receive_thread_results(iproc) - enddo - call write_thread_summary - else - call send_thread_results - endif -#endif - return - end -c-------------------------------------------------------------------------- - subroutine write_thread_summary -C Thread the sequence through a database of known structures - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.DBASE' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.THREAD' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' -#ifdef MPI - include 'COMMON.INFO' -#endif - dimension ip(maxthread) - double precision energia(0:n_ene) - write (iout,'(30x,a/)') - & ' *********** Summary threading statistics ************' - write (iout,'(a)') 'Initial energies:' - write (iout,'(a4,2x,a12,14a14,3a8)') - & 'No','seq',(ename(print_order(i)),i=1,nprint_ene),'ETOT', - & 'RMSnat','NatCONT','NNCONT','RMS' -C Energy sort patterns - do i=1,nthread - ip(i)=i - enddo - do i=1,nthread-1 - enet=ener(n_ene-1,ip(i)) - jj=i - do j=i+1,nthread - if (ener(n_ene-1,ip(j)).lt.enet) then - jj=j - enet=ener(n_ene-1,ip(j)) - endif - enddo - if (jj.ne.i) then - ipj=ip(jj) - ip(jj)=ip(i) - ip(i)=ipj - endif - enddo - do ik=1,nthread - i=ip(ik) - ii=ipatt(1,i) - ist=nres_base(2,ii)+ipatt(2,i) - do kk=1,n_ene_comp - energia(i)=ener0(kk,i) - enddo - etot=ener0(n_ene_comp+1,i) - rmsnat=ener0(n_ene_comp+2,i) - rms=ener0(n_ene_comp+3,i) - frac=ener0(n_ene_comp+4,i) - frac_nn=ener0(n_ene_comp+5,i) - - if (refstr) then - write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') - & i,str_nam(ii),ist+1, - & (energia(print_order(kk)),kk=1,nprint_ene), - & etot,rmsnat,frac,frac_nn,rms - else - write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3)') - & i,str_nam(ii),ist+1, - & (energia(print_order(kk)),kk=1,nprint_ene),etot - endif - enddo - write (iout,'(//a)') 'Final energies:' - write (iout,'(a4,2x,a12,17a14,3a8)') - & 'No','seq',(ename(print_order(kk)),kk=1,nprint_ene),'ETOT', - & 'RMSnat','NatCONT','NNCONT','RMS' - do ik=1,nthread - i=ip(ik) - ii=ipatt(1,i) - ist=nres_base(2,ii)+ipatt(2,i) - do kk=1,n_ene_comp - energia(kk)=ener(kk,ik) - enddo - etot=ener(n_ene_comp+1,i) - rmsnat=ener(n_ene_comp+2,i) - rms=ener(n_ene_comp+3,i) - frac=ener(n_ene_comp+4,i) - frac_nn=ener(n_ene_comp+5,i) - write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') - & i,str_nam(ii),ist+1, - & (energia(print_order(kk)),kk=1,nprint_ene), - & etot,rmsnat,frac,frac_nn,rms - enddo - write (iout,'(/a/)') 'IEXAM array:' - write (iout,'(i5)') nexcl - do i=1,nexcl - write (iout,'(2i5)') iexam(1,i),iexam(2,i) - enddo - write (iout,'(/a,1pe14.4/a,1pe14.4/)') - & 'Max. time for threading step ',max_time_for_thread, - & 'Average time for threading step: ',ave_time_for_thread - return - end -c---------------------------------------------------------------------------- - subroutine sc_conf -C Sample (hopefully) optimal SC orientations given backcone conformation. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DBASE' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.THREAD' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - double precision varia(maxvar) - common /srutu/ icall - double precision energia(0:n_ene) - logical glycine,fail - maxsample=10 - link_end0=link_end - link_end=min0(link_end,nss) - do i=nnt,nct - if (itype(i).ne.10) then -cd print *,'i=',i,' itype=',itype(i),' theta=',theta(i+1) - call gen_side(itype(i),theta(i+1),alph(i),omeg(i),fail) - endif - enddo - call chainbuild - call etotal(energia(0)) - do isample=1,maxsample -C Choose a non-glycine side chain. - glycine=.true. - do while(glycine) - ind_sc=iran_num(nnt,nct) - glycine=(itype(ind_sc).eq.10) - enddo - alph0=alph(ind_sc) - omeg0=omeg(ind_sc) - call gen_side(itype(ind_sc),theta(ind_sc+1),alph(ind_sc), - & omeg(ind_sc),fail) - call chainbuild - call etotal(energia(0)) -cd write (iout,'(a,i5,a,i4,2(a,f8.3),2(a,1pe14.5))') -cd & 'Step:',isample,' SC',ind_sc,' alpha',alph(ind_sc)*rad2deg, -cd & ' omega',omeg(ind_sc)*rad2deg,' old energy',e0,' new energy',e1 - e1=0.0d0 - if (e0.le.e1) then - alph(ind_sc)=alph0 - omeg(ind_sc)=omeg0 - else - e0=e1 - endif - enddo - link_end=link_end0 - return - end -c--------------------------------------------------------------------------- - subroutine write_stat_thread(ithread,ipattern,ist) - implicit real*8 (a-h,o-z) - include "DIMENSIONS" - include "COMMON.CONTROL" - include "COMMON.IOUNITS" - include "COMMON.THREAD" - include "COMMON.FFIELD" - include "COMMON.DBASE" - include "COMMON.NAMES" - double precision energia(0:n_ene) - -#if defined(AIX) || defined(PGI) - open(istat,file=statname,position='append') -#else - open(istat,file=statname,access='append') -#endif - do i=1,n_ene_comp - energia(i)=ener(i,ithread) - enddo - etot=ener(n_ene_comp+1,ithread) - rmsnat=ener(n_ene_comp+2,ithread) - rms=ener(n_ene_comp+3,ithread) - frac=ener(n_ene_comp+4,ithread) - frac_nn=ener(n_ene_comp+5,ithread) - write (istat,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') - & ithread,str_nam(ipattern),ist+1, - & (energia(print_order(i)),i=1,nprint_ene), - & etot,rmsnat,frac,frac_nn,rms - close (istat) - return - end diff --git a/source/unres/src_MD_DFA/timing.F b/source/unres/src_MD_DFA/timing.F deleted file mode 100644 index fb65430..0000000 --- a/source/unres/src_MD_DFA/timing.F +++ /dev/null @@ -1,344 +0,0 @@ -C $Date: 1994/10/05 16:41:52 $ -C $Revision: 2.2 $ -C -C -C - subroutine set_timers -c - implicit none - double precision tcpu - include 'COMMON.TIME1' -#ifdef MP - include 'mpif.h' -#endif -C Diminish the assigned time limit a little so that there is some time to -C end a batch job -c timlim=batime-150.0 -C Calculate the initial time, if it is not zero (e.g. for the SUN). - stime=tcpu() -#ifdef MPI - walltime=MPI_WTIME() - time_reduce=0.0d0 - time_allreduce=0.0d0 - time_bcast=0.0d0 - time_gather=0.0d0 - time_sendrecv=0.0d0 - time_scatter=0.0d0 - time_scatter_fmat=0.0d0 - time_scatter_ginv=0.0d0 - time_scatter_fmatmult=0.0d0 - time_scatter_ginvmult=0.0d0 - time_barrier_e=0.0d0 - time_barrier_g=0.0d0 - time_enecalc=0.0d0 - time_sumene=0.0d0 - time_lagrangian=0.0d0 - time_sumgradient=0.0d0 - time_intcartderiv=0.0d0 - time_inttocart=0.0d0 - time_ginvmult=0.0d0 - time_fricmatmult=0.0d0 - time_cartgrad=0.0d0 - time_bcastc=0.0d0 - time_bcast7=0.0d0 - time_bcastw=0.0d0 - time_intfcart=0.0d0 - time_vec=0.0d0 - time_mat=0.0d0 - time_fric=0.0d0 - time_stoch=0.0d0 - time_fricmatmult=0.0d0 - time_fsample=0.0d0 -#endif -cd print *,' in SET_TIMERS stime=',stime - return - end -C------------------------------------------------------------------------------ - logical function stopx(nf) -C This function returns .true. if one of the following reasons to exit SUMSL -C occurs. The "reason" code is stored in WHATSUP passed thru a COMMON block: -C -C... WHATSUP = 0 - go on, no reason to stop. Stopx will return .false. -C... 1 - Time up in current node; -C... 2 - STOP signal was received from another node because the -C... node's task was accomplished (parallel only); -C... -1 - STOP signal was received from another node because of error; -C... -2 - STOP signal was received from another node, because -C... the node's time was up. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - integer nf - logical ovrtim -#ifdef MP - include 'mpif.h' - include 'COMMON.INFO' -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - integer Kwita - -cd print *,'Processor',MyID,' NF=',nf -#ifndef MPI - if (ovrtim()) then -C Finish if time is up. - stopx = .true. - WhatsUp=1 -#ifdef MPL - else if (mod(nf,100).eq.0) then -C Other processors might have finished. Check this every 100th function -C evaluation. -C Master checks if any other processor has sent accepted conformation(s) to it. - if (MyID.ne.MasterID) call receive_mcm_info - if (MyID.eq.MasterID) call receive_conf -cd print *,'Processor ',MyID,' is checking STOP: nf=',nf - call recv_stop_sig(Kwita) - if (Kwita.eq.-1) then - write (iout,'(a,i4,a,i5)') 'Processor', - & MyID,' has received STOP signal in STOPX; NF=',nf - write (*,'(a,i4,a,i5)') 'Processor', - & MyID,' has received STOP signal in STOPX; NF=',nf - stopx=.true. - WhatsUp=2 - elseif (Kwita.eq.-2) then - write (iout,*) - & 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.' - write (*,*) - & 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.' - WhatsUp=-2 - stopx=.true. - else if (Kwita.eq.-3) then - write (iout,*) - & 'Processor',MyID,' received ERROR-STOP signal in SUMSL.' - write (*,*) - & 'Processor',MyID,' received ERROR-STOP signal in SUMSL.' - WhatsUp=-1 - stopx=.true. - else - stopx=.false. - WhatsUp=0 - endif -#endif - else - stopx = .false. - WhatsUp=0 - endif -#else - stopx=.false. -#endif - -#ifdef OSF -c Check for FOUND_NAN flag - if (FOUND_NAN) then - write(iout,*)" *** stopx : Found a NaN" - stopx=.true. - endif -#endif - - return - end -C-------------------------------------------------------------------------- - logical function ovrtim() - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - real*8 tcpu -#ifdef MPI - include "mpif.h" - curtim = MPI_Wtime()-walltime -#else - curtim= tcpu() -#endif -C curtim is the current time in seconds. -c write (iout,*) "curtim",curtim," timlim",timlim," safety",safety - if (curtim .ge. timlim - safety) then - if (me.eq.king .or. .not. out1file) - & write (iout,'(a,f10.2,a,f10.2,a,f10.2,a)') - & "***************** Elapsed time (",curtim, - & " s) is within the safety limit (",safety, - & " s) of the allocated time (",timlim," s). Terminating." - ovrtim=.true. - else - ovrtim=.false. - endif - return - end -************************************************************************** - double precision function tcpu() - include 'COMMON.TIME1' -#ifdef ES9000 -**************************** -C Next definition for EAGLE (ibm-es9000) - real*8 micseconds - integer rcode - tcpu=cputime(micseconds,rcode) - tcpu=(micseconds/1.0E6) - stime -**************************** -#endif -#ifdef SUN -**************************** -C Next definitions for sun - REAL*8 ECPU,ETIME,ETCPU - dimension tarray(2) - tcpu=etime(tarray) - tcpu=tarray(1) -**************************** -#endif -#ifdef KSR -**************************** -C Next definitions for ksr -C this function uses the ksr timer ALL_SECONDS from the PMON library to -C return the elapsed time in seconds - tcpu= all_seconds() - stime -**************************** -#endif -#ifdef SGI -**************************** -C Next definitions for sgi - real timar(2), etime - seconds = etime(timar) -Cd print *,'seconds=',seconds,' stime=',stime -C usrsec = timar(1) -C syssec = timar(2) - tcpu=seconds - stime -**************************** -#endif - -#ifdef LINUX -**************************** -C Next definitions for sgi - real timar(2), etime - seconds = etime(timar) -Cd print *,'seconds=',seconds,' stime=',stime -C usrsec = timar(1) -C syssec = timar(2) - tcpu=seconds - stime -**************************** -#endif - - -#ifdef CRAY -**************************** -C Next definitions for Cray -C call date(curdat) -C curdat=curdat(1:9) -C call clock(curtim) -C curtim=curtim(1:8) - cpusec = second() - tcpu=cpusec - stime -**************************** -#endif -#ifdef AIX -**************************** -C Next definitions for RS6000 - integer*4 i1,mclock - i1 = mclock() - tcpu = (i1+0.0D0)/100.0D0 -#endif -#ifdef WINPGI -**************************** -c next definitions for windows NT Digital fortran - real time_real - call cpu_time(time_real) - tcpu = time_real -#endif -#ifdef WINIFL -**************************** -c next definitions for windows NT Digital fortran - real time_real - call cpu_time(time_real) - tcpu = time_real -#endif - - return - end -C--------------------------------------------------------------------------- - subroutine dajczas(rntime,hrtime,mintime,sectime) - include 'COMMON.IOUNITS' - real*8 rntime,hrtime,mintime,sectime - hrtime=rntime/3600.0D0 - hrtime=aint(hrtime) - mintime=aint((rntime-3600.0D0*hrtime)/60.0D0) - sectime=aint((rntime-3600.0D0*hrtime-60.0D0*mintime)+0.5D0) - if (sectime.eq.60.0D0) then - sectime=0.0D0 - mintime=mintime+1.0D0 - endif - ihr=hrtime - imn=mintime - isc=sectime - write (iout,328) ihr,imn,isc - 328 FORMAT(//'***** Computation time: ',I4 ,' hours ',I2 , - 1 ' minutes ', I2 ,' seconds *****') - return - end -C--------------------------------------------------------------------------- - subroutine print_detailed_timing - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.SETUP' -#ifdef MPI - time1=MPI_WTIME() - write (iout,'(80(1h=)/a/(80(1h=)))') - & "Details of FG communication time" - write (*,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))') - & "BROADCAST:",time_bcast,"REDUCE:",time_reduce, - & "GATHER:",time_gather, - & "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv, - & "BARRIER ene",time_barrier_e, - & "BARRIER grad",time_barrier_g, - & "TOTAL:", - & time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv - write (*,*) fg_rank,myrank, - & ': Total wall clock time',time1-walltime,' sec' - write (*,*) "Processor",fg_rank,myrank, - & ": BROADCAST time",time_bcast," REDUCE time", - & time_reduce," GATHER time",time_gather," SCATTER time", - & time_scatter, - & " SCATTER fmatmult",time_scatter_fmatmult, - & " SCATTER ginvmult",time_scatter_ginvmult, - & " SCATTER fmat",time_scatter_fmat, - & " SCATTER ginv",time_scatter_ginv, - & " SENDRECV",time_sendrecv, - & " BARRIER ene",time_barrier_e, - & " BARRIER GRAD",time_barrier_g, - & " BCAST7",time_bcast7," BCASTC",time_bcastc, - & " BCASTW",time_bcastw," ALLREDUCE",time_allreduce, - & " TOTAL", - & time_bcast+time_reduce+time_gather+time_scatter+ - & time_sendrecv+time_barrier+time_bcastc -#else - time1=tcpu() -#endif - write (*,*) "Processor",fg_rank,myrank," enecalc",time_enecalc - write (*,*) "Processor",fg_rank,myrank," sumene",time_sumene - write (*,*) "Processor",fg_rank,myrank," intfromcart", - & time_intfcart - write (*,*) "Processor",fg_rank,myrank," vecandderiv", - & time_vec - write (*,*) "Processor",fg_rank,myrank," setmatrices", - & time_mat - write (*,*) "Processor",fg_rank,myrank," ginvmult", - & time_ginvmult - write (*,*) "Processor",fg_rank,myrank," fricmatmult", - & time_fricmatmult - write (*,*) "Processor",fg_rank,myrank," inttocart", - & time_inttocart - write (*,*) "Processor",fg_rank,myrank," sumgradient", - & time_sumgradient - write (*,*) "Processor",fg_rank,myrank," intcartderiv", - & time_intcartderiv - if (fg_rank.eq.0) then - write (*,*) "Processor",fg_rank,myrank," lagrangian", - & time_lagrangian - write (*,*) "Processor",fg_rank,myrank," cartgrad", - & time_cartgrad - endif - return - end diff --git a/source/unres/src_MD_DFA/unres.F b/source/unres/src_MD_DFA/unres.F deleted file mode 100644 index 06ddd69..0000000 --- a/source/unres/src_MD_DFA/unres.F +++ /dev/null @@ -1,794 +0,0 @@ -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C U N R E S C -C C -C Program to carry out conformational search of proteins in an united-residue C -C approximation. C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - - -#ifdef MPI - include 'mpif.h' - include 'COMMON.SETUP' -#endif - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.REMD' - include 'COMMON.MD' - include 'COMMON.SBRIDGE' - double precision hrtime,mintime,sectime - character*64 text_mode_calc(-2:14) /'test', - & 'SC rotamer distribution', - & 'Energy evaluation or minimization', - & 'Regularization of PDB structure', - & 'Threading of a sequence on PDB structures', - & 'Monte Carlo (with minimization) ', - & 'Energy minimization of multiple conformations', - & 'Checking energy gradient', - & 'Entropic sampling Monte Carlo (with minimization)', - & 'Energy map', - & 'CSA calculations', - & 'Not used 9', - & 'Not used 10', - & 'Soft regularization of PDB structure', - & 'Mesoscopic molecular dynamics (MD) ', - & 'Not used 13', - & 'Replica exchange molecular dynamics (REMD)'/ - external ilen - -c call memmon_print_usage() - - call init_task - if (me.eq.king) - & write(iout,*)'### LAST MODIFIED 03/28/12 23:29 by czarek' - if (me.eq.king) call cinfo -C Read force field parameters and job setup data - call readrtns - call flush(iout) -C - if (me.eq.king .or. .not. out1file) then - write (iout,'(2a/)') - & text_mode_calc(modecalc)(:ilen(text_mode_calc(modecalc))), - & ' calculation.' - if (minim) write (iout,'(a)') - & 'Conformations will be energy-minimized.' - write (iout,'(80(1h*)/)') - endif - call flush(iout) -C - if (modecalc.eq.-2) then - call test - stop - else if (modecalc.eq.-1) then - write(iout,*) "call check_sc_map next" - call check_bond - stop - endif -#ifdef MPI - if (fg_rank.gt.0) then -C Fine-grain slaves just do energy and gradient components. - call ergastulum ! slave workhouse in Latin - else -#endif - if (modecalc.eq.0) then - call exec_eeval_or_minim - else if (modecalc.eq.1) then - call exec_regularize - else if (modecalc.eq.2) then - call exec_thread - else if (modecalc.eq.3 .or. modecalc .eq.6) then - call exec_MC - else if (modecalc.eq.4) then - call exec_mult_eeval_or_minim - else if (modecalc.eq.5) then - call exec_checkgrad - else if (ModeCalc.eq.7) then - call exec_map - else if (ModeCalc.eq.8) then - call exec_CSA - else if (modecalc.eq.11) then - call exec_softreg - else if (modecalc.eq.12) then - call exec_MD - else if (modecalc.eq.14) then - call exec_MREMD - else - write (iout,'(a)') 'This calculation type is not supported', - & ModeCalc - endif -#ifdef MPI - endif -C Finish task. - if (fg_rank.eq.0) call finish_task -c call memmon_print_usage() -#ifdef TIMING - call print_detailed_timing -#endif - call MPI_Finalize(ierr) - stop 'Bye Bye...' -#else - call dajczas(tcpu(),hrtime,mintime,sectime) - stop '********** Program terminated normally.' -#endif - end -c-------------------------------------------------------------------------- - subroutine exec_MD - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - if (me.eq.king .or. .not. out1file) - & write (iout,*) "Calling chainbuild" - call chainbuild - call MD - return - end -c--------------------------------------------------------------------------- - subroutine exec_MREMD - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.REMD' - if (me.eq.king .or. .not. out1file) - & write (iout,*) "Calling chainbuild" - call chainbuild - if (me.eq.king .or. .not. out1file) - & write (iout,*) "Calling REMD" - if (remd_mlist) then - call MREMD - else - do i=1,nrep - remd_m(i)=1 - enddo - call MREMD - endif -#else - write (iout,*) "MREMD works on parallel machines only" -#endif - return - end -c--------------------------------------------------------------------------- - subroutine exec_eeval_or_minim - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.REMD' - include 'COMMON.MD' - include 'COMMON.SBRIDGE' - common /srutu/ icall - double precision energy(0:n_ene) - double precision energy_long(0:n_ene),energy_short(0:n_ene) - double precision varia(maxvar) - if (indpdb.eq.0) call chainbuild -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif - call chainbuild_cart - if (split_ene) then - print *,"Processor",myrank," after chainbuild" - icall=1 - call etotal_long(energy_long(0)) - write (iout,*) "Printing long range energy" - call enerprint(energy_long(0)) - call etotal_short(energy_short(0)) - write (iout,*) "Printing short range energy" - call enerprint(energy_short(0)) - do i=0,n_ene - energy(i)=energy_long(i)+energy_short(i) - write (iout,*) i,energy_long(i),energy_short(i),energy(i) - enddo - write (iout,*) "Printing long+short range energy" - call enerprint(energy(0)) - endif - call etotal(energy(0)) -#ifdef MPI - time_ene=MPI_Wtime()-time00 -#else - time_ene=tcpu()-time00 -#endif - write (iout,*) "Time for energy evaluation",time_ene - print *,"after etotal" - etota = energy(0) - etot =etota - call enerprint(energy(0)) - call hairpin(.true.,nharp,iharp) - call secondary2(.true.) - if (minim) then -crc overlap test - if (overlapsc) then - print *, 'Calling OVERLAP_SC' - call overlap_sc(fail) - endif - - if (searchsc) then - call sc_move(2,nres-1,10,1d10,nft_sc,etot) - print *,'SC_move',nft_sc,etot - write(iout,*) 'SC_move',nft_sc,etot - endif - - if (dccart) then - print *, 'Calling MINIM_DC' -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - call minim_dc(etot,iretcode,nfun) - else - if (indpdb.ne.0) then - call bond_regular - call chainbuild - endif - call geom_to_var(nvar,varia) - print *,'Calling MINIMIZE.' -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - call minimize(etot,varia,iretcode,nfun) - endif - print *,'SUMSL return code is',iretcode,' eval ',nfun -#ifdef MPI - evals=nfun/(MPI_WTIME()-time1) -#else - evals=nfun/(tcpu()-time1) -#endif - print *,'# eval/s',evals - print *,'refstr=',refstr - call hairpin(.true.,nharp,iharp) - call secondary2(.true.) - call etotal(energy(0)) - etot = energy(0) - call enerprint(energy(0)) - - call intout - call briefout(0,etot) - if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (iout,'(a,i3)') 'SUMSL return code:',iretcode - write (iout,'(a,i20)') '# of energy evaluations:',nfun+1 - write (iout,'(a,f16.3)')'# of energy evaluations/sec:',evals - else - print *,'refstr=',refstr - if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - call briefout(0,etot) - endif - if (outpdb) call pdbout(etot,titel(:32),ipdb) - if (outmol2) call mol2out(etot,titel(:32)) - return - end -c--------------------------------------------------------------------------- - subroutine exec_regularize - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.REMD' - include 'COMMON.MD' - include 'COMMON.SBRIDGE' - double precision energy(0:n_ene) - - call gen_dist_constr - call sc_conf - call intout - call regularize(nct-nnt+1,etot,rms,cref(1,nnt),iretcode) - call etotal(energy(0)) - energy(0)=energy(0)-energy(14) - etot=energy(0) - call enerprint(energy(0)) - call intout - call briefout(0,etot) - if (outpdb) call pdbout(etot,titel(:32),ipdb) - if (outmol2) call mol2out(etot,titel(:32)) - if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (iout,'(a,i3)') 'SUMSL return code:',iretcode - return - end -c--------------------------------------------------------------------------- - subroutine exec_thread - include 'DIMENSIONS' -#ifdef MP - include "mpif.h" -#endif - include "COMMON.SETUP" - call thread_seq - return - end -c--------------------------------------------------------------------------- - subroutine exec_MC - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - character*10 nodeinfo - double precision varia(maxvar) -#ifdef MPI - include "mpif.h" -#endif - include "COMMON.SETUP" - include 'COMMON.CONTROL' - call mcm_setup - if (minim) then -#ifdef MPI - if (modecalc.eq.3) then - call do_mcm(ipar) - else - call entmcm - endif -#else - if (modecalc.eq.3) then - call do_mcm(ipar) - else - call entmcm - endif -#endif - else - call monte_carlo - endif - return - end -c--------------------------------------------------------------------------- - subroutine exec_mult_eeval_or_minim - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - dimension muster(mpi_status_size) -#endif - include 'COMMON.SETUP' - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.REMD' - include 'COMMON.MD' - include 'COMMON.SBRIDGE' - double precision varia(maxvar) - dimension ind(6) - double precision energy(0:max_ene) - logical eof - eof=.false. -#ifdef MPI - if(me.ne.king) then - call minim_mcmf - return - endif - - close (intin) - open(intin,file=intinname,status='old') - write (istat,'(a5,20a12)')"# ", - & (wname(print_order(i)),i=1,nprint_ene) - if (refstr) then - write (istat,'(a5,20a12)')"# ", - & (ename(print_order(i)),i=1,nprint_ene), - & "ETOT total","RMSD","nat.contact","nnt.contact" - else - write (istat,'(a5,20a12)')"# ", - & (ename(print_order(i)),i=1,nprint_ene),"ETOT total" - endif - - if (.not.minim) then - do while (.not. eof) - if (read_cart) then - read (intin,'(e15.10,e15.5)',end=1100,err=1100) time,ene - call read_x(intin,*11) -#ifdef MPI -c Broadcast the order to compute internal coordinates to the slaves. - if (nfgtasks.gt.1) - & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - call int_from_cart1(.false.) - else - read (intin,'(i5)',end=1100,err=1100) iconf - call read_angles(intin,*11) - call geom_to_var(nvar,varia) - call chainbuild - endif - write (iout,'(a,i7)') 'Conformation #',iconf - call etotal(energy(0)) - call briefout(iconf,energy(0)) - call enerprint(energy(0)) - etot=energy(0) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (istat,'(i5,20(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot, - & rms,frac,frac_nn,co -cjlee end - else - write (istat,'(i5,16(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot - endif - enddo -1100 continue - goto 1101 - endif - - mm=0 - imm=0 - nft=0 - ene0=0.0d0 - n=0 - iconf=0 -c do n=1,nzsc - do while (.not. eof) - mm=mm+1 - if (mm.lt.nodes) then - if (read_cart) then - read (intin,'(e15.10,e15.5)',end=11,err=11) time,ene - call read_x(intin,*11) -#ifdef MPI -c Broadcast the order to compute internal coordinates to the slaves. - if (nfgtasks.gt.1) - & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - call int_from_cart1(.false.) - else - read (intin,'(i5)',end=11,err=11) iconf - call read_angles(intin,*11) - call geom_to_var(nvar,varia) - call chainbuild - endif - write (iout,'(a,i7)') 'Conformation #',iconf - n=n+1 - imm=imm+1 - ind(1)=1 - ind(2)=n - ind(3)=0 - ind(4)=0 - ind(5)=0 - ind(6)=0 - ene0=0.0d0 - call mpi_send(ind,6,mpi_integer,mm,idint,CG_COMM, - * ierr) - call mpi_send(varia,nvar,mpi_double_precision,mm, - * idreal,CG_COMM,ierr) - call mpi_send(ene0,1,mpi_double_precision,mm, - * idreal,CG_COMM,ierr) -c print *,'task ',n,' sent to worker ',mm,nvar - else - call mpi_recv(ind,6,mpi_integer,mpi_any_source,idint, - * CG_COMM,muster,ierr) - man=muster(mpi_source) -c print *,'receiving result from worker ',man,' (',iii1,iii,')' - call mpi_recv(varia,nvar,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) - call mpi_recv(ene,1, - * mpi_double_precision,man,idreal, - * CG_COMM,muster,ierr) - call mpi_recv(ene0,1, - * mpi_double_precision,man,idreal, - * CG_COMM,muster,ierr) -c print *,'result received from worker ',man,' sending now' - - call var_to_geom(nvar,varia) - call chainbuild - call etotal(energy(0)) - iconf=ind(2) - write (iout,*) - write (iout,*) - write (iout,'(a,2i7)') 'Conformation #',iconf,ind(5) - - etot=energy(0) - call enerprint(energy(0)) - call briefout(it,etot) -c if (minim) call briefout(it,etot) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (istat,'(i5,19(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot, - & rms,frac,frac_nn,co - else - write (istat,'(i5,15(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot - endif - - imm=imm-1 - if (read_cart) then - read (intin,'(e15.10,e15.5)',end=1101,err=1101) time,ene - call read_x(intin,*11) -#ifdef MPI -c Broadcast the order to compute internal coordinates to the slaves. - if (nfgtasks.gt.1) - & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - call int_from_cart1(.false.) - else - read (intin,'(i5)',end=1101,err=1101) iconf - call read_angles(intin,*11) - call geom_to_var(nvar,varia) - call chainbuild - endif - n=n+1 - imm=imm+1 - ind(1)=1 - ind(2)=n - ind(3)=0 - ind(4)=0 - ind(5)=0 - ind(6)=0 - call mpi_send(ind,6,mpi_integer,man,idint,CG_COMM, - * ierr) - call mpi_send(varia,nvar,mpi_double_precision,man, - * idreal,CG_COMM,ierr) - call mpi_send(ene0,1,mpi_double_precision,man, - * idreal,CG_COMM,ierr) - nf_mcmf=nf_mcmf+ind(4) - nmin=nmin+1 - endif - enddo -11 continue - do j=1,imm - call mpi_recv(ind,6,mpi_integer,mpi_any_source,idint, - * CG_COMM,muster,ierr) - man=muster(mpi_source) - call mpi_recv(varia,nvar,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) - call mpi_recv(ene,1, - * mpi_double_precision,man,idreal, - * CG_COMM,muster,ierr) - call mpi_recv(ene0,1, - * mpi_double_precision,man,idreal, - * CG_COMM,muster,ierr) - - call var_to_geom(nvar,varia) - call chainbuild - call etotal(energy(0)) - iconf=ind(2) - write (iout,*) - write (iout,*) - write (iout,'(a,2i7)') 'Conformation #',iconf,ind(5) - - etot=energy(0) - call enerprint(energy(0)) - call briefout(it,etot) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (istat,'(i5,19(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot, - & rms,frac,frac_nn,co - else - write (istat,'(i5,15(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot - endif - nmin=nmin+1 - enddo -1101 continue - do i=1, nodes-1 - ind(1)=0 - ind(2)=0 - ind(3)=0 - ind(4)=0 - ind(5)=0 - ind(6)=0 - call mpi_send(ind,6,mpi_integer,i,idint,CG_COMM, - * ierr) - enddo -#else - close (intin) - open(intin,file=intinname,status='old') - write (istat,'(a5,20a12)')"# ", - & (wname(print_order(i)),i=1,nprint_ene) - write (istat,'("# ",20(1pe12.4))') - & (weights(print_order(i)),i=1,nprint_ene) - if (refstr) then - write (istat,'(a5,20a12)')"# ", - & (ename(print_order(i)),i=1,nprint_ene), - & "ETOT total","RMSD","nat.contact","nnt.contact" - else - write (istat,'(a5,14a12)')"# ", - & (ename(print_order(i)),i=1,nprint_ene),"ETOT total" - endif - do while (.not. eof) - if (read_cart) then - read (intin,'(e15.10,e15.5)',end=1100,err=1100) time,ene - call read_x(intin,*11) -#ifdef MPI -c Broadcast the order to compute internal coordinates to the slaves. - if (nfgtasks.gt.1) - & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - call int_from_cart1(.false.) - else - read (intin,'(i5)',end=1100,err=1100) iconf - call read_angles(intin,*11) - call geom_to_var(nvar,varia) - call chainbuild - endif - write (iout,'(a,i7)') 'Conformation #',iconf - if (minim) call minimize(etot,varia,iretcode,nfun) - call etotal(energy(0)) - - etot=energy(0) - call enerprint(energy(0)) - if (minim) call briefout(it,etot) - if (refstr) then - call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (istat,'(i5,18(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene), - & etot,rms,frac,frac_nn,co -cjlee end - else - write (istat,'(i5,14(f12.3))') iconf, - & (energy(print_order(i)),i=1,nprint_ene),etot - endif - enddo - 11 continue - 1100 continue -#endif - return - end -c--------------------------------------------------------------------------- - subroutine exec_checkgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.REMD' - include 'COMMON.MD' - include 'COMMON.SBRIDGE' - common /srutu/ icall - double precision energy(0:max_ene) -c do i=2,nres -c vbld(i)=vbld(i)+ran_number(-0.1d0,0.1d0) -c if (itype(i).ne.10) -c & vbld(i+nres)=vbld(i+nres)+ran_number(-0.001d0,0.001d0) -c enddo - if (indpdb.eq.0) call chainbuild -c do i=0,nres -c do j=1,3 -c dc(j,i)=dc(j,i)+ran_number(-0.2d0,0.2d0) -c enddo -c enddo -c do i=1,nres-1 -c if (itype(i).ne.10) then -c do j=1,3 -c dc(j,i+nres)=dc(j,i+nres)+ran_number(-0.2d0,0.2d0) -c enddo -c endif -c enddo -c do j=1,3 -c dc(j,0)=ran_number(-0.2d0,0.2d0) -c enddo - usampl=.true. - totT=1.d0 - eq_time=0.0d0 - call read_fragments -cc read(inp,*) t_bath - call rescale_weights(t_bath) - call chainbuild_cart - call cartprint - call intout - icall=1 - call etotal(energy(0)) - etot = energy(0) - call enerprint(energy(0)) - write (iout,*) "Uconst",Uconst," Uconst_back",uconst_back - print *,'icheckgrad=',icheckgrad - goto (10,20,30) icheckgrad - 10 call check_ecartint - return - 20 call check_cartgrad - return - 30 call check_eint - return - end -c--------------------------------------------------------------------------- - subroutine exec_map -C Energy maps - call map_read - call map - return - end -c--------------------------------------------------------------------------- - subroutine exec_CSA -#ifdef MPI - include "mpif.h" -#endif - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -C Conformational Space Annealling programmed by Jooyoung Lee. -C This method works only with parallel machines! -#ifdef MPI -csa call together - write (iout,*) "CSA is not supported in this version" -#else -csa write (iout,*) "CSA works on parallel machines only" - write (iout,*) "CSA is not supported in this version" -#endif - return - end -c--------------------------------------------------------------------------- - subroutine exec_softreg - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - double precision energy(0:max_ene) - logical debug /.false./ - call chainbuild - call etotal(energy(0)) - call enerprint(energy(0)) - if (.not.lsecondary) then - write(iout,*) 'Calling secondary structure recognition' - call secondary2(debug) - else - write(iout,*) 'Using secondary structure supplied in pdb' - endif - - call softreg - - call etotal(energy(0)) - etot=energy(0) - call enerprint(energy(0)) - call intout - call briefout(0,etot) - call secondary2(.true.) - if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - return - end diff --git a/source/unres/src_MD_DFA/xdrf b/source/unres/src_MD_DFA/xdrf deleted file mode 120000 index 26825c5..0000000 --- a/source/unres/src_MD_DFA/xdrf +++ /dev/null @@ -1 +0,0 @@ -../../lib/xdrf \ No newline at end of file diff --git a/source/unres/src_MIN/CMakeLists.txt b/source/unres/src_MIN/CMakeLists.txt deleted file mode 100644 index 079f58c..0000000 --- a/source/unres/src_MIN/CMakeLists.txt +++ /dev/null @@ -1,225 +0,0 @@ -# -# CMake project file for UNRES with Minimazation -# - -enable_language (Fortran) - -#================================ -# Set source file lists -#================================ -# sources used with FFLAGS0 -set(UNRES_MIN_SRC0 - arcos.f - cartder.F - cartprint.f - chainbuild.F - checkder_p.F - convert.f - djacob.f - econstr_local.F - gen_rand_conf.F - geomout_min.F - initialize_p.F - intcartderiv.F - intcor.f - intlocal.f - int_to_cart.f - matmult.f - minimize_p.F - misc.f - MP.F - parmread.F - pinorm.f - printmat.f - randgens.f - readrtns_min.F - refsys.f - rescode.f - refsys.f - rmdd.f - sc_move.F - sumsld.f - timing.F - unres_min.F - -) -# sources used with FFLAGS1 -set(UNRES_MIN_SRC1 - cored.f -) - -# sources used with FFLAGS2 -set(UNRES_MIN_SRC2 - readpdb.F -) - -# sources used with FFLAGS3 -set(UNRES_MIN_SRC3 - energy_p_new_barrier.F - gradient_p.F -) - -# sources used with preprocesor flags (should also be listed above with FFLAGSX) -set(UNRES_MIN_PP_SRC - bank.F - cartder.F - chainbuild.F - checkder_p.F - compare_s1.F - cored.f - csa.f - dihed_cons.F - diff12.f - econstr_local.F - energy_p_new.F - energy_p_new_barrier.F - energy_split-sep.F - entmcm.F - gen_rand_conf.F - geomout.F - gradient_p.F - intcor.f - initialize_p.F - intcartderiv.F - lagrangian_lesyng.F - matmult.f - mc.F - mcm.F - MD_A-MTS.F - minimize_p.F - minim_jlee.F - minim_mcmf.F - MP.F - MREMD.F - newconf.f - parmread.F - permut.F - prng_32.F - q_measure1.F - q_measure3.F - q_measure.F - ran.f - rattle.F - readpdb.F - readrtns_min.F - regularize.F - rmdd.f - rmsd.F - sc_move.F - shift.F - stochfric.F - sumsld.f - test.F - thread.F - timing.F - together.F - unres.F -) - - -#================================================ -# Set comipiler flags for different sourcefiles -#================================================ -if (Fortran_COMPILER_NAME STREQUAL "ifort") - find_package (Threads) - set(FFLAGS0 "-g -ip -w" ) - set(FFLAGS1 "-w -g -d2 -CA -CB" ) - set(FFLAGS2 "-w -g -00 ") - set(FFLAGS3 "-g -w -ipo " ) -elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") - set(FFLAGS0 "-std=legacy -O " ) - set(FFLAGS1 "-std=legacy -g -C" ) - set(FFLAGS2 "-std=legacy -g -O0 ") - set(FFLAGS3 "-std=legacy -O3" ) -endif (Fortran_COMPILER_NAME STREQUAL "ifort") - - -set_property(SOURCE ${UNRES_MIN_SRC0} PROPERTY COMPILE_FLAGS ${FFLAGS0} ) -set_property(SOURCE ${UNRES_MIN_SRC1} PROPERTY COMPILE_FLAGS ${FFLAGS1} ) -set_property(SOURCE ${UNRES_MIN_SRC2} PROPERTY COMPILE_FLAGS ${FFLAGS2} ) -set_property(SOURCE ${UNRES_MIM_SRC3} PROPERTY COMPILE_FLAGS ${FFLAGS3} ) - -# set preprocesor flags -set(CPPFLAGS "PROCOR -DLINUX -DISNAN -DSPLITELE -DLANG0" ) - -if (Fortran_COMPILER_NAME STREQUAL "ifort") - # Add ifort preprocessor flags - set(CPPFLAGS "${CPPFLAGS} -DPGI") -elseif (Fortran_COMPILER_NAME STREQUAL "f95") - # Add gfortran flags - set(CPPFLAGS "${CPPFLAGS} -DG77") -elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") - # Add gfortran flags - set(CPPFLAGS "${CPPFLAGS} -DG77") -endif (Fortran_COMPILER_NAME STREQUAL "ifort") - - -# 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_MIN_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) - - - -#======================================== -# Setting binary name -#======================================== -set(UNRES_BIN "unres_min_${Fortran_COMPILER_NAME}.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} "CPPFLAGS =" "${CPPFLAGS}") - -FILE(APPEND ${CINFO} -" write(iout,*)'Version MINI energy and minimalization only' - write(iout,*)'++++ End of compile info ++++' - return - end ") - -# add include path -set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f PROPERTY COMPILE_FLAGS "${FFLAGS0} -I${CMAKE_CURRENT_SOURCE_DIR}") - -#========================================= -# Set full unres MIN sources -#========================================= -set(UNRES_MIN_SRCS ${UNRES_MIN_SRC0} ${UNRES_MIN_SRC1} ${UNRES_MIN_SRC2} ${UNRES_MIN_SRC3} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f ) - -#========================================= -# Build the binary -#========================================= -add_executable(UNRES_MIN_BIN ${UNRES_MIN_SRCS} ) -set_target_properties(UNRES_MIN_BIN PROPERTIES OUTPUT_NAME ${UNRES_BIN}) - -if (Fortran_COMPILER_NAME STREQUAL "ifort") - target_link_libraries (UNRES_MIN_BIN ${CMAKE_THREAD_LIBS_INIT}) -endif (Fortran_COMPILER_NAME STREQUAL "ifort") -set_property(TARGET UNRES_MIN_BIN PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin ) - - -#========================================= -# Install Path -#========================================= -install(TARGETS UNRES_MIN_BIN DESTINATION ${CMAKE_INSTALL_PREFIX}/unres/MINIM) - diff --git a/source/unres/src_MIN/COMMON.BOUNDS b/source/unres/src_MIN/COMMON.BOUNDS deleted file mode 100644 index f3859ae..0000000 --- a/source/unres/src_MIN/COMMON.BOUNDS +++ /dev/null @@ -1,2 +0,0 @@ - double precision phibound(2,maxres) - common /bounds/ phibound diff --git a/source/unres/src_MIN/COMMON.CALC b/source/unres/src_MIN/COMMON.CALC deleted file mode 100644 index 67b4bb9..0000000 --- a/source/unres/src_MIN/COMMON.CALC +++ /dev/null @@ -1,15 +0,0 @@ - integer i,j,k,l - double precision erij,rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, - & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, - & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, - & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, - & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, - & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, - & dsci_inv,dscj_inv,gg - common /calc/ erij(3),rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, - & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, - & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, - & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, - & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, - & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, - & dsci_inv,dscj_inv,gg(3),i,j diff --git a/source/unres/src_MIN/COMMON.CHAIN b/source/unres/src_MIN/COMMON.CHAIN deleted file mode 100644 index f7a8a1d..0000000 --- a/source/unres/src_MIN/COMMON.CHAIN +++ /dev/null @@ -1,12 +0,0 @@ - integer nres,nsup,nstart_sup,nz_start,nz_end,iz_sc, - & nres0,nstart_seq - double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm,t,r, - & prod,rt,dc_work,cref,crefjlee - common /chain/ c(3,maxres2+2),dc(3,0:maxres2),dc_old(3,0:maxres2), - & xloc(3,maxres),xrot(3,maxres),dc_norm(3,0:maxres2), - & dc_work(MAXRES6),nres,nres0 - common /rotmat/ t(3,3,maxres),r(3,3,maxres),prod(3,3,maxres), - & rt(3,3,maxres) - common /refstruct/ cref(3,maxres2+2),crefjlee(3,maxres2+2), - & nsup,nstart_sup,nstart_seq - common /from_zscore/ nz_start,nz_end,iz_sc diff --git a/source/unres/src_MIN/COMMON.CONTACTS b/source/unres/src_MIN/COMMON.CONTACTS deleted file mode 100644 index 5b3a90d..0000000 --- a/source/unres/src_MIN/COMMON.CONTACTS +++ /dev/null @@ -1,82 +0,0 @@ -C Change 12/1/95 - common block CONTACTS1 included. - integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont - double precision facont,gacont - common /contacts/ ncont,ncont_ref,icont(2,maxcont), - & icont_ref(2,maxcont) - common /contacts1/ facont(maxconts,maxres), - & gacont(3,maxconts,maxres), - & num_cont(maxres),jcont(maxconts,maxres) -C 12/26/95 - H-bonding contacts - common /contacts_hb/ - & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), - & gacontp_hb3(3,maxconts,maxres), - & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), - & gacontm_hb3(3,maxconts,maxres), - & gacont_hbr(3,maxconts,maxres), - & grij_hb_cont(3,maxconts,maxres), - & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), - & ees0m(maxconts,maxres),d_cont(maxconts,maxres), - & num_cont_hb(maxres),jcont_hb(maxconts,maxres) -C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole -C interactions -c 7/25/08 Commented out; not needed when cumulants used -C Interactions of pseudo-dipoles generated by loc-el interactions. -c double precision dip,dipderg,dipderx -c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), -c & dipderx(3,5,4,maxconts,maxres) -C 10/30/99 Added other pre-computed vectors and matrices needed -C to calculate three - six-order el-loc correlation terms - double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, - & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder, - & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der - common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), - & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), - & obrot_der(2,maxres),obrot2_der(2,maxres) -C This common block contains vectors and matrices dependent on a single -C amino-acid residue. - common /precomp1/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres), - & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres), - & Dtobr2(2,maxres),Dtobr2der(2,maxres), - & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), - & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), - & DtUg2(2,2,maxres),DtUg2der(2,2,maxres) -C This common block contains vectors and matrices dependent on two -C consecutive amino-acid residues. - double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, - & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder - common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), - & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), - & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), - & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres), - & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres) - double precision costab,sintab,costab2,sintab2 - common /rotat_old/ costab(maxres),sintab(maxres), - & costab2(maxres),sintab2(maxres) -C This common block contains dipole-interaction matrices and their -C Cartesian derivatives. - double precision a_chuj,a_chuj_der - common /dipmat/ a_chuj(2,2,maxconts,maxres), - & a_chuj_der(2,2,3,5,maxconts,maxres) - double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, - & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, - & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont - common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), - & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), - & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), - & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), - & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), - & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), - & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), - & g_contij(3,2),ekont -C 12/13/2008 (again Poland-Jaruzel war anniversary) -C RE: Parallelization of 4th and higher order loc-el correlations - integer ncont_sent,ncont_recv,iint_sent,iisent_local, - & itask_cont_from,itask_cont_to,ntask_cont_from,ntask_cont_to, - & nat_sent,iat_sent,iturn3_sent,iturn4_sent,iturn3_sent_local, - & iturn4_sent_local - common /contdistrib/ ncont_sent(maxres),ncont_recv(maxres), - & iint_sent(4,maxres,maxres),iint_sent_local(4,maxres,maxres), - & iturn3_sent(4,maxres),iturn4_sent(4,maxres), - & iturn3_sent_local(4,maxres),iturn4_sent_local(4,maxres), - & nat_sent,iat_sent(maxres),itask_cont_from(0:max_fg_procs-1), - & itask_cont_to(0:max_fg_procs-1),ntask_cont_from,ntask_cont_to diff --git a/source/unres/src_MIN/COMMON.CONTROL b/source/unres/src_MIN/COMMON.CONTROL deleted file mode 100644 index c12ef3a..0000000 --- a/source/unres/src_MIN/COMMON.CONTROL +++ /dev/null @@ -1,13 +0,0 @@ - integer modecalc,iscode,indpdb,indback,indphi,iranconf,icheckgrad, - & inprint,i2ndstr,mucadyn,constr_dist - logical minim,refstr,pdbref,outpdb,outmol2,overlapsc,energy_dec, - & sideadd,lsecondary,read_cart,unres_pdb, - & vdisulf,searchsc,lmuca,dccart,extconf,out1file, - & gnorm_check,gradout,split_ene - common /cntrl/ modecalc,iscode,indpdb,indback,indphi,iranconf, - & icheckgrad,minim,i2ndstr,refstr,pdbref,outpdb,outmol2,iprint, - & overlapsc,energy_dec,sideadd,lsecondary,read_cart,unres_pdb - & ,vdisulf,searchsc,lmuca,dccart,mucadyn,extconf,out1file, - & constr_dist,gnorm_check,gradout,split_ene -C... minim = .true. means DO minimization. -C... energy_dec = .true. means print energy decomposition matrix diff --git a/source/unres/src_MIN/COMMON.DERIV b/source/unres/src_MIN/COMMON.DERIV deleted file mode 100644 index 2a5ddcf..0000000 --- a/source/unres/src_MIN/COMMON.DERIV +++ /dev/null @@ -1,36 +0,0 @@ - double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gelc_long, - & gvdwpp,gel_loc,gel_loc_long,gvdwc_scpp, - & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gloc_x,dtheta,dphi,dalpha, - & domega,gscloc,gsclocx,gradcorr,gradcorr_long,gradcorr5_long, - & gradcorr6_long,gcorr6_turn_long,gvdwcT,gvdwxT - integer nfl,icg - common /derivatT/ gvdwcT(3,maxres),gvdwxT(3,maxres) - common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), - & gradx(3,maxres,2),gradc(3,maxres,2),gvdwx(3,maxres), - & gvdwc(3,maxres),gelc(3,maxres),gelc_long(3,maxres), - & gvdwpp(3,maxres),gvdwc_scpp(3,maxres), - & gradx_scp(3,maxres),gvdwc_scp(3,maxres),ghpbx(3,maxres), - & ghpbc(3,maxres),gloc(maxvar,2),gradcorr(3,maxres), - & gradcorr_long(3,maxres),gradcorr5_long(3,maxres), - & gradcorr6_long(3,maxres),gcorr6_turn_long(3,maxres), - & gradxorr(3,maxres),gradcorr5(3,maxres),gradcorr6(3,maxres), - & gloc_x(maxvar,2),gel_loc(3,maxres),gel_loc_long(3,maxres), - & gcorr3_turn(3,maxres), - & gcorr4_turn(3,maxres),gcorr6_turn(3,maxres),gradb(3,maxres), - & gradbx(3,maxres),gel_loc_loc(maxvar),gel_loc_turn3(maxvar), - & gel_loc_turn4(maxvar),gel_loc_turn6(maxvar),gcorr_loc(maxvar), - & g_corr5_loc(maxvar),g_corr6_loc(maxvar),gsccorc(3,maxres), - & gsccorx(3,maxres),gsccor_loc(maxres),dtheta(3,2,maxres), - & gscloc(3,maxres),gsclocx(3,maxres), - & dphi(3,3,maxres),dalpha(3,3,maxres),domega(3,3,maxres),nfl,icg - double precision derx,derx_turn - common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2) - double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres), - & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres), - & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres), - & dZZ_XYZtab(3,maxres) - common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab, - & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab - integer igrad_start,igrad_end,jgrad_start(maxres), - & jgrad_end(maxres) - common /mpgrad/ igrad_start,igrad_end,jgrad_start,jgrad_end diff --git a/source/unres/src_MIN/COMMON.DISTFIT b/source/unres/src_MIN/COMMON.DISTFIT deleted file mode 100644 index 044225b..0000000 --- a/source/unres/src_MIN/COMMON.DISTFIT +++ /dev/null @@ -1,14 +0,0 @@ -c parameter (maxres22=maxres*(maxres+1)/2) - parameter (maxres22=1) - double precision w,d0,DRDG,DD,H,XX - integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0, - 1 lvar_frag,svar_frag,avar_frag - COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3) - COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3), - 1 lvar_frag(mxio,3),svar_frag(mxio,3), - 2 avar_frag(mxio,5) - COMMON /WAGI/ w(MAXRES22),d0(MAXRES22) - COMMON /POCHODNE/ NX,NY,DRDG(MAXRES22,MAXRES),DD(MAXRES22), - 1 H(MAXRES,MAXRES),XX(MAXRES) - COMMON /frozen/ mask(maxres) - COMMON /store0/ nhpb0 diff --git a/source/unres/src_MIN/COMMON.FFIELD b/source/unres/src_MIN/COMMON.FFIELD deleted file mode 100644 index 2deca8e..0000000 --- a/source/unres/src_MIN/COMMON.FFIELD +++ /dev/null @@ -1,25 +0,0 @@ -C----------------------------------------------------------------------- -C The following COMMON block selects the type of the force field used in -C calculations and defines weights of various energy terms. -C 12/1/95 wcorr added -C----------------------------------------------------------------------- - integer n_ene_comp,rescale_mode - common /ffield/ wsc,wscp,welec,wbond,wstrain,wtor,wtor_d,wang, - & wscloc,wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4, - & wturn6,wvdwpp,wsct,weights(n_ene),temp0, - & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp, - & rescale_mode - common /potentials/ potname(5) - character*3 potname -C----------------------------------------------------------------------- -C wlong,welec,wtor,wang,wscloc are the weight of the energy terms -C corresponding to side-chain, electrostatic, torsional, valence-angle, -C and local side-chain terms. -C -C IPOT determines which SC...SC interaction potential will be used: -C 1 - LJ: 2n-n Lennard-Jones -C 2 - LJK: 2n-n Kihara type (shifted Lennard-Jones) -C 3 - BP; Berne-Pechukas (angular dependence) -C 4 - GB; Gay-Berne (angular dependence) -C 5 - GBV; Gay-Berne-Vorobjev; angularly-dependent Kihara potential -C------------------------------------------------------------------------ diff --git a/source/unres/src_MIN/COMMON.GEO b/source/unres/src_MIN/COMMON.GEO deleted file mode 100644 index 8cfbbde..0000000 --- a/source/unres/src_MIN/COMMON.GEO +++ /dev/null @@ -1,2 +0,0 @@ - double precision pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin - common /geo/ pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin diff --git a/source/unres/src_MIN/COMMON.HEADER b/source/unres/src_MIN/COMMON.HEADER deleted file mode 100644 index 7154812..0000000 --- a/source/unres/src_MIN/COMMON.HEADER +++ /dev/null @@ -1,2 +0,0 @@ - character*80 titel - common /header/ titel diff --git a/source/unres/src_MIN/COMMON.INTERACT b/source/unres/src_MIN/COMMON.INTERACT deleted file mode 100644 index fabad93..0000000 --- a/source/unres/src_MIN/COMMON.INTERACT +++ /dev/null @@ -1,34 +0,0 @@ - double precision aa,bb,augm,aad,bad,app,bpp,ale6,ael3,ael6 - integer expon,expon2 - integer nnt,nct,nint_gr,istart,iend,itype,itel,itypro, - & ielstart,ielend,ielstart_vdw,ielend_vdw,nscp_gr,iscpstart, - & iscpend,iatsc_s,iatsc_e, - & iatel_s,iatel_e,iatscp_s,iatscp_e,iatel_s_vdw,iatel_e_vdw, - & ispp,iscp - common /interact/aa(ntyp,ntyp),bb(ntyp,ntyp),augm(ntyp,ntyp), - & aad(ntyp,2),bad(ntyp,2),app(2,2),bpp(2,2),ael6(2,2),ael3(2,2), - & expon,expon2,nnt,nct,nint_gr(maxres),istart(maxres,maxint_gr), - & iend(maxres,maxint_gr),itype(maxres),itel(maxres),itypro, - & ielstart(maxres),ielend(maxres),ielstart_vdw(maxres), - & ielend_vdw(maxres),nscp_gr(maxres), - & iscpstart(maxres,maxint_gr),iscpend(maxres,maxint_gr), - & iatsc_s,iatsc_e,iatel_s,iatel_e,iatel_s_vdw,iatel_e_vdw, - & iatscp_s,iatscp_e,ispp,iscp -C 12/1/95 Array EPS included in the COMMON block. - double precision eps,sigma,sigmaii,rs0,chi,chip,alp,sigma0,sigii, - & rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp - common /body/eps(ntyp,ntyp),sigma(0:ntyp1,0:ntyp1), - & sigmaii(ntyp,ntyp), - & rs0(ntyp,ntyp),chi(ntyp,ntyp),chip(ntyp),alp(ntyp),sigma0(ntyp), - & sigii(ntyp),rr0(ntyp),r0(ntyp,ntyp),r0e(ntyp,ntyp),r0d(ntyp,2), - & rpp(2,2),epp(2,2),elpp6(2,2),elpp3(2,2),eps_scp(20,2),rscp(20,2) -c 12/5/03 modified 09/18/03 Bond stretching parameters. - double precision vbldp0,vbldsc0,akp,aksc,abond0 - integer nbondterm - common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp, - & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp),nbondterm(ntyp) - double precision wdti,wdti2,wdti4,wdti8, - & wdtii,wdtii2,wdtii4,wdtii8 - common /nosehoover_dt/ - & wdti(maxyosh),wdti2(maxyosh),wdti4(maxyosh),wdti8(maxyosh), - & wdtii(maxyosh),wdtii2(maxyosh),wdtii4(maxyosh),wdtii8(maxyosh) diff --git a/source/unres/src_MIN/COMMON.IOUNITS b/source/unres/src_MIN/COMMON.IOUNITS deleted file mode 100644 index 49b6db3..0000000 --- a/source/unres/src_MIN/COMMON.IOUNITS +++ /dev/null @@ -1,69 +0,0 @@ -C----------------------------------------------------------------------- -C I/O units used by the program -C----------------------------------------------------------------------- -C 9/18/99 - unit ifourier and filename fouriername included to identify -C the file from which the coefficients of second-order Fourier expansion -C of the local-interaction energy are read. -C 8/9/01 - file for SCP interaction constants named scpname (unit iscpp) -C included. -C----------------------------------------------------------------------- -C General I/O units & files - integer inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,irotam, - & itorp,itordp,ifourier,ielep,isidep,iscpp,icbase,istat, - & ientin,ientout,izs1,isecpred,ibond,irest2,iifrag,icart, - & irest1,isccor,ithep_pdb,irotam_pdb - common /iounits/ inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep, - & irotam,itorp,itordp,ifourier,ielep,isidep,iscpp,icbase, - & istat,ientin,ientout,izs1,isecpred,ibond,irest2,iifrag, - & icart,irest1,isccor,ithep_pdb,irotam_pdb - character*256 outname,intname,pdbname,mol2name,statname,intinname, - & entname,prefix,secpred,rest2name,qname,cartname,tmpdir, - & mremd_rst_name,curdir,pref_orig - character*4 liczba - common /fnames/ outname,intname,pdbname,mol2name,statname, - & intinname,entname,prefix,pot,secpred,rest2name,qname, - & cartname,tmpdir,mremd_rst_name,curdir,pref_orig,liczba -C CSA I/O units & files - character*256 csa_rbank,csa_seed,csa_history,csa_bank, - & csa_bank1,csa_alpha,csa_alpha1,csa_bankt,csa_int, - & csa_bank_reminimized,csa_native_int,csa_in - common /csafiles/ csa_rbank,csa_seed,csa_history,csa_bank, - & csa_bank1,csa_alpha,csa_alpha1,csa_bankt,csa_int, - & csa_bank_reminimized,csa_native_int,csa_in - integer icsa_rbank,icsa_seed,icsa_history,icsa_bank, - & icsa_bank1,icsa_alpha,icsa_alpha1,icsa_bankt,icsa_int, - & icsa_bank_reminimized,icsa_native_int,icsa_in,icsa_pdb - common /csaunits/ icsa_rbank,icsa_seed,icsa_history,icsa_bank, - & icsa_bank1,icsa_alpha,icsa_alpha1,icsa_bankt,icsa_int, - & icsa_bank_reminimized,icsa_native_int,icsa_in,icsa_pdb -C Parameter files - character*256 bondname,thetname,rotname,torname,tordname, - & fouriername,elename,sidename,scpname,sccorname,patname, - & thetname_pdb,rotname_pdb - common /parfiles/ bondname,thetname,rotname,torname,tordname, - & fouriername,elename,sidename,scpname,sccorname,patname, - & thetname_pdb,rotname_pdb - character*3 pot -C----------------------------------------------------------------------- -C INP - main input file -C IOUT - list file -C IGEOM - geometry output in the form of virtual-chain internal coordinates -C INTIN - geometry input (for multiple conformation processing) in int. coords. -C IPDB - Cartesian-coordinate output in PDB format -C IMOL2 - Cartesian-coordinate output in Tripos mol2 format -C IPDBIN - PDB input file -C ITHEP - virtual-bond torsional angle parametrs -C IROTAM - side-chain geometry and local-interaction parameters -C ITORP - torsional parameters -C ITORDP - double torsional parameters -C IFOURIER - coefficients of the expansion of local-interaction energy -C IELEP - electrostatic-interaction parameters -C ISIDEP - side-chain interaction parameters. -C ISCPP - SCp interaction parameters. -C IBOND - virtual-bond constant parameters and moments of inertia. -C ISCCOR - parameters of the potential of SCCOR term -C ICBASE - data base with Cartesian coords of known structures. -C ISTAT - energies and other conf. characteristics from an MCM run. -C IENTIN - entropy from preceeding simulation(s) to be read in. -C SECPRED - SECONDARY STRUCTURE PREDICTION for dihedral constraint generation. -C----------------------------------------------------------------------- diff --git a/source/unres/src_MIN/COMMON.LOCAL b/source/unres/src_MIN/COMMON.LOCAL deleted file mode 100644 index 837a7a3..0000000 --- a/source/unres/src_MIN/COMMON.LOCAL +++ /dev/null @@ -1,53 +0,0 @@ - double precision a0thet,athet,bthet,polthet,gthet,theta0,sig0, - & sigc0,dsc,dsc_inv,bsc,censc,gaussc,dsc0 - integer nlob -C Parameters of the virtual-bond-angle probability distribution - common /thetas/ a0thet(ntyp),athet(2,ntyp),bthet(2,ntyp), - & polthet(0:3,ntyp),gthet(3,ntyp),theta0(ntyp),sig0(ntyp), - & sigc0(ntyp) -C Parameters of the side-chain probability distribution - common /sclocal/ dsc(ntyp1),dsc_inv(ntyp1),bsc(maxlob,ntyp), - & censc(3,maxlob,ntyp),gaussc(3,3,maxlob,ntyp),dsc0(ntyp1), - & nlob(ntyp1) -C Parameters of ab initio-derived potential of virtual-bond-angle bending - integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, - & ithetyp(ntyp1),nntheterm - double precision aa0thet(maxthetyp1,maxthetyp1,maxthetyp1), - & aathet(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1), - & bbthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ccthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ddthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & eethet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ffthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1), - & ggthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1) - common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet, - & ffthet, - & ggthet,ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle, - & ndouble,nntheterm -C Virtual-bond lenghts - double precision vbl,vblinv,vblinv2,vbl_cis,vbl0,vbld_inv - integer loc_start,loc_end,ithet_start,ithet_end,iphi_start, - & iphi_end,iphid_start,iphid_end,ibond_start,ibond_end, - & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end, - & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start, - & iint_end,iphi1_start,iphi1_end, - & ibond_displ(0:max_fg_procs-1),ibond_count(0:max_fg_procs-1), - & ithet_displ(0:max_fg_procs-1),ithet_count(0:max_fg_procs-1), - & iphi_displ(0:max_fg_procs-1),iphi_count(0:max_fg_procs-1), - & iphi1_displ(0:max_fg_procs-1),iphi1_count(0:max_fg_procs-1), - & ivec_displ(0:max_fg_procs-1),ivec_count(0:max_fg_procs-1), - & iset_displ(0:max_fg_procs-1),iset_count(0:max_fg_procs-1), - & iint_count(0:max_fg_procs-1),iint_displ(0:max_fg_procs-1) - common /peptbond/ vbl,vblinv,vblinv2,vbl_cis,vbl0 - common /indices/ loc_start,loc_end,ithet_start,ithet_end, - & iphi_start,iphi_end,iphid_start,iphid_end,ibond_start,ibond_end, - & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end, - & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start, - & iint_end,iphi1_start,iphi1_end,iint_count,iint_displ,ivec_displ, - & ivec_count,iset_displ, - & iset_count,ibond_displ,ibond_count,ithet_displ,ithet_count, - & iphi_displ,iphi_count,iphi1_displ,iphi1_count -C Inverses of the actual virtual bond lengths - common /invlen/ vbld_inv(maxres2) diff --git a/source/unres/src_MIN/COMMON.MAXGRAD b/source/unres/src_MIN/COMMON.MAXGRAD deleted file mode 100644 index 285241a..0000000 --- a/source/unres/src_MIN/COMMON.MAXGRAD +++ /dev/null @@ -1,12 +0,0 @@ - double precision - & gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max - common /maxgrad/ - & gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max diff --git a/source/unres/src_MIN/COMMON.MCM b/source/unres/src_MIN/COMMON.MCM deleted file mode 100644 index 576f912..0000000 --- a/source/unres/src_MIN/COMMON.MCM +++ /dev/null @@ -1,70 +0,0 @@ -C... Following COMMON block contains general variables controlling the MC/MCM -C... procedure -c----------------------------------------------------------------------------- - double precision Tcur,Tmin,Tmax,TstepH,TstepC,RanFract, - & overlap_cut,e_up,delte - integer nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter, - & maxrepm,ngen,ntrial,ntherm,nrepm,neneval,nsave,maxoverlap, - & nsave_part,max_mcm_it,nsweep,print_mc - logical print_stat,print_int - common /mcm/ Tcur,Tmin,Tmax,TstepH,TstepC,Rbol,betbol,RanFract, - & overlap_cut,e_up,delte, - & nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter,maxrepm, - & maxoverlap,ntrial,max_mcm_it, - & ngen,ntherm,nrepm,neneval,nsave,nsave_part(max_cg_procs),nsweep, - & print_mc,print_stat,print_int -c----------------------------------------------------------------------------- -C... The meaning of the above variables is as follows: -C... Tcur,Tmin,Tmax - Current,minimum and maximum temperature, respectively; -C... NstepC,NStepH - Number of cooling and heating steps, respectively; -C... TstepH,TstepC - factors by which T is multiplied in order to be -C... increased or decreased. -C... betbol - Boltzmann's inverse temperature (1/(Rbol*Tcur)); -C... Rbol - the gas constant; -C... RanFract - the chance that a new conformation will be random-generated; -C... maxacc - maximum number of accepted conformations; -C... maxgen,ngen - Maximum and current number of generated conformations; -C... maxtrial,ntrial - maximum number of trials before temperature is increased -C... and current number of trials, respectively; -C... maxrepm,nrepm - maximum number of allowed minima repetition and current -C... number of minima repetitions, respectively; -C... maxoverlap - max. # of overlapping confs generated in a single iteration; -C... neneval - number of energy evaluations; -C... nsave - number of confs. in the backup array; -C... nsweep - the number of macroiterations in generating the distributions. -c------------------------------------------------------------------------------ -C... Following COMMON block contains variables controlling motion. -c------------------------------------------------------------------------------ - double precision sumpro_type,sumpro_bond - integer koniecl, Nbm,MaxSideMove,nmove,moves(-1:MaxMoveType+1), - & moves_acc(-1:MaxMoveType+1),nacc_tot,nacc_part(0:MaxProcs) - common /move/ sumpro_type(0:MaxMoveType),sumpro_bond(0:maxres), - & koniecl,Nbm,MaxSideMove,nmove,nbond_move(maxres), - & nbond_acc(maxres),moves,moves_acc - common /accept_stats/ nacc_tot,nacc_part - integer nwindow,winstart,winend,winlen - common /windows/ nwindow,winstart(maxres),winend(maxres), - & winlen(maxres) - character*16 MovTypID - common /moveID/ MovTypID(-1:MaxMoveType+1) -c------------------------------------------------------------------------------ -C... koniecl - the number of bonds to be considered "end bonds" subjected to -C... end moves; -C... Nbm - The maximum length of N-bond segment to be moved; -C... MaxSideMove - maximum number of side chains subjected to local moves -C... simultaneously; -C... nmove - the current number of attempted moves; -C... nbond_move(*) array that stores the total numbers of 2-bond,3-bond,... -C... moves; -C... nendmove - number of endmoves; -C... nbackmove - number of backbone moves; -C... nsidemove - number of local side chain moves; -C... sumpro_type(*) - array that stores the lower and upper boundary of the -C... random-number range that determines the type of move -C... (N-bond, backbone or side chain); -C... sumpro_bond(*) - array that stores the probabilities to perform bond -C... moves of consecutive segment length. -C... winstart(*) - the starting position of the perturbation window; -C... winend(*) - the end position of the perturbation window; -C... winlen(*) - length of the perturbation window; -C... nwindow - the number of perturbation windows (0 - entire chain). diff --git a/source/unres/src_MIN/COMMON.MD_ b/source/unres/src_MIN/COMMON.MD_ deleted file mode 100644 index 22dba7c..0000000 --- a/source/unres/src_MIN/COMMON.MD_ +++ /dev/null @@ -1,74 +0,0 @@ - double precision gcart, gxcart, gradcag,gradxag - common /mdgrad/ gcart(3,0:MAXRES), gxcart(3,0:MAXRES), - & gradcag(3,MAXRES),gradxag(3,MAXRES) - integer dimen,dimen1, dimen3, ifrag(2,50,maxprocs/20), - & ipair(2,100,maxprocs/20),iset, - & mset(maxprocs/20),nset - double precision IP,ISC(ntyp+1),mp, - & msc(ntyp+1),d_t_work(MAXRES6), - & d_t_work_new(MAXRES6),d_t(3,0:MAXRES2),d_t_new(3,0:MAXRES2), - & d_af_work(MAXRES6),d_as_work(MAXRES6), - & d_t_old(3,0:MAXRES2),d_a_old(3,0:MAXRES2),d_a_short(3,0:MAXRES2), - & Gmat(MAXRES2,MAXRES2),Ginv(MAXRES2,MAXRES2),A(MAXRES2,MAXRES2), - & d_a(3,0:MAXRES2),d_a_work(6*MAXRES),kinetic_force(MAXRES6), - & Gsqrp(MAXRES2,MAXRES2),Gsqrm(MAXRES2,MAXRES2), - & vtot(MAXRES2),Gvec(maxres2,maxres2),Geigen(maxres2) - double precision v_ini,d_time,d_time0,t_bath,tau_bath, - & EK,potE,potEcomp(0:n_ene+4),totE,totT,amax,kinetic_T,dvmax,damax, - & edriftmax, - & eq_time,wfrag(50,maxprocs/20),wpair(100,maxprocs/20), - & qfrag(50),qpair(100), - & qinfrag(50,maxprocs/20),qinpair(100,maxprocs/20), - & Ucdfrag,Ucdpair,dUdconst(3,0:MAXRES),Uconst, - & dUdxconst(3,0:MAXRES),dqwol(3,0:MAXRES),dxqwol(3,0:MAXRES), - & utheta(maxfrag_back),ugamma(maxfrag_back),uscdiff(maxfrag_back), - & dutheta(maxres),dugamma(maxres),duscdiff(3,maxres), - & duscdiffx(3,maxres),wfrag_back(3,maxfrag_back,maxprocs/20), - & uconst_back - integer n_timestep,ntwx,ntwe,lang,count_reset_moment, - & count_reset_vel,reset_fricmat,nfrag,npair,nfrag_back, - & ifrag_back(3,maxfrag_back,maxprocs/20),ntime_split,ntime_split0, - & maxtime_split - integer nresn,nyosh,nnos - double precision glogs,qmass,vlogs,xlogs - logical large,print_compon,tbf,rest,reset_moment,reset_vel, - & surfarea,rattle,usampl,mdpdb,RESPA,tnp,tnp1,tnh,xiresp - integer igmult_start,igmult_end,my_ng_count,ng_start,ng_counts, - & nginv_start,nginv_counts,myginv_ng_count - common /back_constr/ uconst_back,utheta,ugamma,uscdiff, - & dutheta,dugamma,duscdiff,duscdiffx, - & wfrag_back,nfrag_back,ifrag_back - common /qmeas/ qfrag,qpair,qinfrag,qinpair,wfrag,wpair,eq_time, - & Ucdfrag,Ucdpair,dUdconst,dUdxconst,dqwol,dxqwol,Uconst, - & iset,mset,nset,usampl,ifrag,ipair,npair,nfrag - common /mdpar/ v_ini,d_time,d_time0,scal_fric, - & t_bath,tau_bath,dvmax,damax,n_timestep,mdpdb, - & ntime_split,ntime_split0,maxtime_split, - & ntwx,ntwe,large,print_compon,tbf,rest,tnp,tnp1,tnh - common /MDcalc/ totT,totE,potE,potEcomp,EK,amax,edriftmax, - & kinetic_T - common /lagrange/ d_t,d_t_old,d_t_new,d_t_work, - & d_t_work_new,d_a,d_a_old,d_a_work,d_af_work,d_as_work,d_a_short, - & kinetic_force, - & A,Ginv,Gmat,Gvec,Geigen,Gsqrp,Gsqrm, - & vtot,dimen,dimen1,dimen3,lang, - & reset_moment,reset_vel,count_reset_moment,count_reset_vel, - & rattle,RESPA - common /inertia/ IP,ISC,MP,MSC - double precision scal_fric,rwat,etawat,gamp, - & gamsc(ntyp),stdfp,stdfsc(ntyp),stdforcp(MAXRES), - & stdforcsc(MAXRES),pstok,restok(ntyp+1),cPoise,Rb - common /langevin/ pstok,restok,gamp,gamsc, - & stdfp,stdfsc,stdforcp,stdforcsc,rwat,etawat,cPoise,Rb,surfarea, - & reset_fricmat - common /mdpmpi/ igmult_start,igmult_end,my_ng_count, - & myginv_ng_count, - & ng_start(0:MaxProcs-1),ng_counts(0:MaxProcs-1), - & nginv_start(0:MaxProcs),nginv_counts(0:MaxProcs-1) - double precision pi_np,pistar,s_np,s12_np,Q_np,E_old,H0,E_long, - & sold_np,d_t_half,Csplit - common /nosepoincare/ pi_np,pistar,s_np,s12_np,Q_np,E_old,H0, - & E_long,sold_np,d_t_half(3,0:MAXRES2),Csplit - common /nosehoover/ glogs(maxmnh),qmass(maxmnh), - & vlogs(maxmnh),xlogs(maxmnh), - & nresn,nyosh,nnos,xiresp diff --git a/source/unres/src_MIN/COMMON.MINIM b/source/unres/src_MIN/COMMON.MINIM deleted file mode 100644 index e44f9cd..0000000 --- a/source/unres/src_MIN/COMMON.MINIM +++ /dev/null @@ -1,5 +0,0 @@ - double precision tolf,rtolf - integer maxfun,maxmin,minfun,minmin, - & print_min_ini,print_min_stat,print_min_res - common /minimm/ tolf,rtolf,maxfun,maxmin,minfun,minmin, - & print_min_ini,print_min_stat,print_min_res diff --git a/source/unres/src_MIN/COMMON.NAMES b/source/unres/src_MIN/COMMON.NAMES deleted file mode 100644 index e6f926b..0000000 --- a/source/unres/src_MIN/COMMON.NAMES +++ /dev/null @@ -1,7 +0,0 @@ - character*3 restyp - character*1 onelet - common /names/ restyp(ntyp+1),onelet(ntyp+1) - character*10 ename,wname - integer nprint_ene,print_order - common /namterm/ ename(n_ene),wname(n_ene),nprint_ene, - & print_order(n_ene) diff --git a/source/unres/src_MIN/COMMON.SBRIDGE b/source/unres/src_MIN/COMMON.SBRIDGE deleted file mode 100644 index 4cc80c8..0000000 --- a/source/unres/src_MIN/COMMON.SBRIDGE +++ /dev/null @@ -1,12 +0,0 @@ - double precision ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss - integer ns,nss,nfree,iss - common /sbridge/ ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss, - & ns,nss,nfree,iss(maxss) - double precision dhpb,forcon - integer ihpb,jhpb,nhpb - common /links/ dhpb(maxdim),forcon(maxdim),ihpb(maxdim), - & jhpb(maxdim),nhpb - double precision weidis - common /restraints/ weidis - integer link_start,link_end - common /links_split/ link_start,link_end diff --git a/source/unres/src_MIN/COMMON.SCCOR b/source/unres/src_MIN/COMMON.SCCOR deleted file mode 100644 index a28f621..0000000 --- a/source/unres/src_MIN/COMMON.SCCOR +++ /dev/null @@ -1,6 +0,0 @@ -C Parameters of the SCCOR term - double precision v1sccor,v2sccor - integer nterm_sccor - common/sccor/v1sccor(maxterm_sccor,20,20), - & v2sccor(maxterm_sccor,20,20), - & nterm_sccor diff --git a/source/unres/src_MIN/COMMON.SCROT b/source/unres/src_MIN/COMMON.SCROT deleted file mode 100644 index 2da7b8f..0000000 --- a/source/unres/src_MIN/COMMON.SCROT +++ /dev/null @@ -1,3 +0,0 @@ -C Parameters of the SC rotamers (local) term - double precision sc_parmin - common/scrot/sc_parmin(maxsccoef,20) diff --git a/source/unres/src_MIN/COMMON.SETUP b/source/unres/src_MIN/COMMON.SETUP deleted file mode 100644 index 5039116..0000000 --- a/source/unres/src_MIN/COMMON.SETUP +++ /dev/null @@ -1,21 +0,0 @@ - integer king,idint,idreal,idchar,is_done - parameter (king=0,idint=1105,idreal=1729,idchar=1597,is_done=1) - integer me,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,nfgtasks,kolor, - & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1),CG_COMM,FG_COMM, - & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp(0:maxprocs-1), - & kolor1,key1,nfgtasks1,MyRank, - & max_gs_size - logical yourjob, finished, cgdone - common/setup/me,MyRank,cg_rank,fg_rank,fg_rank1,nodes,Nprocs, - & nfgtasks,nfgtasks1, - & max_gs_size,kolor,koniec,WhatsUp,ifinish,CG_COMM,FG_COMM, - & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp - integer MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, - & MPI_THET,MPI_GAM, - & MPI_ROTAT1(0:1),MPI_ROTAT2(0:1),MPI_ROTAT_OLD(0:1), - & MPI_PRECOMP11(0:1),MPI_PRECOMP12(0:1),MPI_PRECOMP22(0:1), - & MPI_PRECOMP23(0:1) - common /types/ MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, - & MPI_THET,MPI_GAM, - & MPI_ROTAT1,MPI_ROTAT2,MPI_ROTAT_OLD,MPI_PRECOMP11,MPI_PRECOMP12, - & MPI_PRECOMP22,MPI_PRECOMP23 diff --git a/source/unres/src_MIN/COMMON.SPLITELE b/source/unres/src_MIN/COMMON.SPLITELE deleted file mode 100644 index a2f0447..0000000 --- a/source/unres/src_MIN/COMMON.SPLITELE +++ /dev/null @@ -1,2 +0,0 @@ - double precision r_cut,rlamb - common /splitele/ r_cut,rlamb diff --git a/source/unres/src_MIN/COMMON.TIME1 b/source/unres/src_MIN/COMMON.TIME1 deleted file mode 100644 index d6203a6..0000000 --- a/source/unres/src_MIN/COMMON.TIME1 +++ /dev/null @@ -1,28 +0,0 @@ - DOUBLE PRECISION BATIME,TIMLIM,STIME,PREVTIM,SAFETY - DOUBLE PRECISION WALLTIME - INTEGER ISTOP -c FOUND_NAN - set by calcf to stop sumsl via stopx - logical FOUND_NAN - COMMON/TIME1/STIME,TIMLIM,BATIME,PREVTIM,SAFETY,WALLTIME - COMMON/STOPTIM/ISTOP - common /sumsl_flag/ FOUND_NAN - double precision t_init,t_MDsetup,t_langsetup,t_MD, - & t_enegrad,t_sdsetup,time_bcast,time_reduce,time_gather, - & time_sendrecv,time_barrier_e,time_barrier_g,time_scatter, - & t_eelecij,time_bcast7,time_bcastc,time_bcastw,time_allreduce, - & time_enecalc,time_sumene,time_lagrangian,time_cartgrad, - & time_sumgradient,time_intcartderiv,time_inttocart,time_intfcart, - & time_vec,time_mat,time_ginvmult,time_fricmatmult,time_fric, - & time_scatter_fmat,time_scatter_ginv, - & time_fsample,time_scatter_fmatmult,time_scatter_ginvmult, - & time_stoch,t_eshort,t_elong,t_etotal - common /timing/ t_init,t_MDsetup,t_langsetup, - & t_MD,t_enegrad,t_sdsetup,time_bcast,time_reduce,time_gather, - & time_sendrecv,time_scatter,time_barrier_e,time_barrier_g, - & time_bcast7,time_bcastc,time_bcastw,time_allreduce, - & t_eelecij,time_enecalc,time_sumene,time_lagrangian,time_cartgrad, - & time_sumgradient,time_intcartderiv,time_inttocart,time_intfcart, - & time_vec,time_mat,time_ginvmult,time_fricmatmult,time_fric, - & time_fsample,time_scatter_fmatmult,time_scatter_ginvmult, - & time_scatter_fmat,time_scatter_ginv, - & time_stoch,t_eshort,t_elong,t_etotal diff --git a/source/unres/src_MIN/COMMON.TORCNSTR b/source/unres/src_MIN/COMMON.TORCNSTR deleted file mode 100644 index e4af17c..0000000 --- a/source/unres/src_MIN/COMMON.TORCNSTR +++ /dev/null @@ -1,6 +0,0 @@ - integer ndih_constr,idih_constr(maxdih_constr) - integer ndih_nconstr,idih_nconstr(maxdih_constr) - integer idihconstr_start,idihconstr_end - double precision phi0(maxdih_constr),drange(maxdih_constr),ftors - common /torcnstr/ phi0,drange,ftors,ndih_constr,idih_constr, - & ndih_nconstr,idih_nconstr,idihconstr_start,idihconstr_end diff --git a/source/unres/src_MIN/COMMON.TORSION b/source/unres/src_MIN/COMMON.TORSION deleted file mode 100644 index 6b6605f..0000000 --- a/source/unres/src_MIN/COMMON.TORSION +++ /dev/null @@ -1,23 +0,0 @@ -C Torsional constants of the rotation about virtual-bond dihedral angles - double precision v1,v2,vlor1,vlor2,vlor3,v0 - integer itortyp,ntortyp,nterm,nlor,nterm_old - common/torsion/v0(maxtor,maxtor),v1(maxterm,maxtor,maxtor), - & v2(maxterm,maxtor,maxtor),vlor1(maxlor,maxtor,maxtor), - & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor), - & itortyp(ntyp),ntortyp,nterm(maxtor,maxtor),nlor(maxtor,maxtor) - & ,nterm_old -C 6/23/01 - constants for double torsionals - double precision v1c,v1s,v2c,v2s - integer ntermd_1,ntermd_2 - common /torsiond/ v1c(2,maxtermd_1,maxtor,maxtor,maxtor), - & v1s(2,maxtermd_1,maxtor,maxtor,maxtor), - & v2c(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor), - & v2s(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor), - & ntermd_1(maxtor,maxtor,maxtor),ntermd_2(maxtor,maxtor,maxtor) -C 9/18/99 - added Fourier coeffficients of the expansion of local energy -C surface - double precision b1,b2,cc,dd,ee,ctilde,dtilde,b2tilde - integer nloctyp - common/fourier/ b1(2,maxtor),b2(2,maxtor),cc(2,2,maxtor), - & dd(2,2,maxtor),ee(2,2,maxtor),ctilde(2,2,maxtor), - & dtilde(2,2,maxtor),b1tilde(2,maxtor),nloctyp diff --git a/source/unres/src_MIN/COMMON.VAR b/source/unres/src_MIN/COMMON.VAR deleted file mode 100644 index 71158b8..0000000 --- a/source/unres/src_MIN/COMMON.VAR +++ /dev/null @@ -1,20 +0,0 @@ -C Store the geometric variables in the following COMMON block. - integer ntheta,nphi,nside,nvar,Origin,nstore,ialph,ivar, - & mask_theta,mask_phi,mask_side - double precision theta,phi,alph,omeg,varsave,esave,varall,vbld, - & thetaref,phiref,costtab,sinttab,cost2tab,sint2tab, - & xxtab,yytab,zztab,xxref,yyref,zzref - common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), - & vbld(2*maxres),thetaref(maxres),phiref(maxres), - & costtab(maxres), sinttab(maxres), cost2tab(maxres), - & sint2tab(maxres),xxtab(maxres),yytab(maxres), - & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres), - & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar -C Store the angles and variables corresponding to old conformations (for use -C in MCM). - common /oldgeo/ varsave(maxvar,maxsave),esave(maxsave), - & Origin(maxsave),nstore -C freeze some variables - logical mask_r - common /restr/ varall(maxvar),mask_r,mask_theta(maxres), - & mask_phi(maxres),mask_side(maxres) diff --git a/source/unres/src_MIN/COMMON.VECTORS b/source/unres/src_MIN/COMMON.VECTORS deleted file mode 100644 index d880c24..0000000 --- a/source/unres/src_MIN/COMMON.VECTORS +++ /dev/null @@ -1,3 +0,0 @@ - common /vectors/ uy(3,maxres),uz(3,maxres), - & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres) - diff --git a/source/unres/src_MIN/DIMENSIONS b/source/unres/src_MIN/DIMENSIONS deleted file mode 100644 index 8f3f01c..0000000 --- a/source/unres/src_MIN/DIMENSIONS +++ /dev/null @@ -1,139 +0,0 @@ -******************************************************************************** -* Settings for the program of united-residue peptide simulation in real space * -* * -* ------- As of 6/23/01 ----------- * -* * -******************************************************************************** -C Max. number of processors. - integer maxprocs - parameter (maxprocs=2048) -C Max. number of fine-grain processors - integer max_fg_procs -c parameter (max_fg_procs=maxprocs) - parameter (max_fg_procs=512) -C Max. number of coarse-grain processors - integer max_cg_procs - parameter (max_cg_procs=maxprocs) -C Max. number of AA residues - integer maxres - parameter (maxres=100) -C Appr. max. number of interaction sites - integer maxres2,maxres6,mmaxres2 - parameter (maxres2=2*maxres,maxres6=6*maxres) - parameter (mmaxres2=(maxres2*(maxres2+1)/2)) -C Max. number of variables - integer maxvar - parameter (maxvar=6*maxres) -C Max. number of groups of interactions that a given SC is involved in - integer maxint_gr - parameter (maxint_gr=2) -C Max. number of derivatives of virtual-bond and side-chain vectors in theta -C or phi. - integer maxdim - parameter (maxdim=(maxres-1)*(maxres-2)/2) -C Max. number of SC contacts - integer maxcont - parameter (maxcont=12*maxres) -C Max. number of contacts per residue - integer maxconts - parameter (maxconts=maxres/4) -c parameter (maxconts=50) -C Number of AA types (at present only natural AA's will be handled - integer ntyp,ntyp1 - parameter (ntyp=20,ntyp1=ntyp+1) -C Max. number of types of dihedral angles & multiplicity of torsional barriers -C and the number of terms in double torsionals - integer maxtor,maxterm,maxlor,maxtermd_1,maxtermd_2 - parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) -C Max. number of residue types and parameters in expressions for -C virtual-bond angle bending potentials - integer maxthetyp,maxthetyp1,maxtheterm,maxtheterm2,maxtheterm3, - & maxsingle,maxdouble,mmaxtheterm - parameter (maxthetyp=3,maxthetyp1=maxthetyp+1,maxtheterm=20, - & maxtheterm2=6,maxtheterm3=4,maxsingle=6,maxdouble=4, - & mmaxtheterm=maxtheterm) -c Max number of torsional terms in SCCOR - integer maxterm_sccor - parameter (maxterm_sccor=3) -C Max. number of lobes in SC distribution - integer maxlob - parameter (maxlob=4) -C Max. number of S-S bridges - integer maxss - parameter (maxss=20) -C Max. number of dihedral angle constraints - integer maxdih_constr - parameter (maxdih_constr=maxres) -C Max. number of patterns in the pattern database - integer maxseq - parameter (maxseq=10) -C Max. number of residues in a peptide in the database - integer maxres_base - parameter (maxres_base=10) -C Max. number of threading attempts - integer maxthread - parameter (maxthread=20) -C Max. number of move types in MCM - integer maxmovetype - parameter (maxmovetype=4) -C Max. number of stored confs. in MC/MCM simulation - integer maxsave - parameter (maxsave=20) -C Max. number of energy intervals - integer max_ene - parameter (max_ene=10) -C Max. number of conformations in Master's cache array - integer max_cache - parameter (max_cache=10) -C Max. number of conformations in the pool - integer max_pool - parameter (max_pool=10) -C Number of energy components - integer n_ene,n_ene2 - parameter (n_ene=23,n_ene2=2*n_ene) -C Number of threads in deformation - integer max_thread,max_thread2 - parameter (max_thread=4,max_thread2=2*max_thread) -C Number of structures to compare at t=0 - integer max_threadss,max_threadss2 - parameter (max_threadss=8,max_threadss2=2*max_threadss) -C Maxmimum number of angles per residue - integer mxang - parameter (mxang=4) -C Maximum number of groups of angles - integer mxgr - parameter (mxgr=2*maxres) -C Maximum number of chains - integer mxch - parameter (mxch=1) -C Maximum number of generated conformations - integer mxio - parameter (mxio=2) -C Maximum number of n7 generated conformations - integer mxio2 - parameter (mxio2=2) -C Maximum number of moves (n1-n8) - integer mxmv - parameter (mxmv=18) -C Maximum number of seed - integer max_seed - parameter (max_seed=1) -C Maximum number of timesteps for which stochastic MD matrices can be stored - integer maxflag_stoch - parameter (maxflag_stoch=0) -C Maximum number of backbone fragments in restraining - integer maxfrag_back - parameter (maxfrag_back=4) -C Maximum number of SC local term fitting function coefficiants - integer maxsccoef - parameter (maxsccoef=65) -C Maximum number of terms in SC bond-stretching potential - integer maxbondterm - parameter (maxbondterm=3) -C Maximum number of conformation stored in cache on each CPU before sending -C to master; depends on nstex / ntwx ratio - integer max_cache_traj - parameter (max_cache_traj=10) -C Nose-Hoover chain - chain length and order of Yoshida algorithm - integer maxmnh,maxyosh - parameter(maxmnh=10,maxyosh=5) diff --git a/source/unres/src_MIN/MP.F b/source/unres/src_MIN/MP.F deleted file mode 100644 index 09bf922..0000000 --- a/source/unres/src_MIN/MP.F +++ /dev/null @@ -1,517 +0,0 @@ -#ifdef MPI - subroutine init_task - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - logical lprn /.false./ -c real*8 text1 /'group_i '/,text2/'group_f '/, -c & text3/'initialb'/,text4/'initiale'/, -c & text5/'openb'/,text6/'opene'/ - integer cgtasks(0:max_cg_procs) - character*3 cfgprocs - integer cg_size,fg_size,fg_size1 -c start parallel processing -c print *,'Initializing MPI' - call mpi_init(ierr) - if (ierr.ne.0) then - print *, ' cannot initialize MPI' - stop - endif -c determine # of nodes and current node - call MPI_Comm_rank( MPI_COMM_WORLD, me, ierr ) - if (ierr.ne.0) then - print *, ' cannot determine rank of all processes' - call MPI_Finalize( MPI_COMM_WORLD, IERR ) - stop - endif - call MPI_Comm_size( MPI_Comm_world, nodes, ierr ) - if (ierr.ne.0) then - print *, ' cannot determine number of processes' - stop - endif - Nprocs=nodes - MyRank=me -C Determine the number of "fine-grain" tasks - call getenv_loc("FGPROCS",cfgprocs) - read (cfgprocs,'(i3)') nfgtasks - if (nfgtasks.eq.0) nfgtasks=1 - call getenv_loc("MAXGSPROCS",cfgprocs) - read (cfgprocs,'(i3)') max_gs_size - if (max_gs_size.eq.0) max_gs_size=2 - if (lprn) - & print *,"Processor",me," nfgtasks",nfgtasks, - & " max_gs_size",max_gs_size - if (nfgtasks.eq.1) then - CG_COMM = MPI_COMM_WORLD - fg_size=1 - fg_rank=0 - nfgtasks1=1 - fg_rank1=0 - else - nodes=nprocs/nfgtasks - if (nfgtasks*nodes.ne.nprocs) then - write (*,'(a)') 'ERROR: Number of processors assigned', - & ' to coarse-grained tasks must be divisor', - & ' of the total number of processors.' - call MPI_Finalize( MPI_COMM_WORLD, IERR ) - stop - endif -C Put the ranks of coarse-grain processes in one table and create -C the respective communicator. The processes with ranks "in between" -C the ranks of CG processes will perform fine graining for the CG -C process with the next lower rank. - do i=0,nprocs-1,nfgtasks - cgtasks(i/nfgtasks)=i - enddo - if (lprn) then - print*,"Processor",me," cgtasks",(cgtasks(i),i=0,nodes-1) -c print "(a,i5,a)","Processor",myrank," Before MPI_Comm_group" - endif -c call memmon_print_usage() - call MPI_Comm_group(MPI_COMM_WORLD,world_group,IERR) - call MPI_Group_incl(world_group,nodes,cgtasks,cg_group,IERR) - call MPI_Comm_create(MPI_COMM_WORLD,cg_group,CG_COMM,IERR) - call MPI_Group_rank(cg_group,me,ierr) - call MPI_Group_free(world_group,ierr) - call MPI_Group_free(cg_group,ierr) -c print "(a,i5,a)","Processor",myrank," After MPI_Comm_group" -c call memmon_print_usage() - if (me.ne.MPI_UNDEFINED) call MPI_Comm_Rank(CG_COMM,me,ierr) - if (lprn) print *," Processor",myrank," CG rank",me -C Create communicators containig processes doing "fine grain" tasks. -C The processes within each FG_COMM should have fast communication. - kolor=MyRank/nfgtasks - key=mod(MyRank,nfgtasks) - call MPI_Comm_split(MPI_COMM_WORLD,kolor,key,FG_COMM,ierr) - call MPI_Comm_size(FG_COMM,fg_size,ierr) - if (fg_size.ne.nfgtasks) then - write (*,*) "OOOOps... the number of fg tasks is",fg_size, - & " but",nfgtasks," was requested. MyRank=",MyRank - endif - call MPI_Comm_rank(FG_COMM,fg_rank,ierr) - if (fg_size.gt.max_gs_size) then - kolor1=fg_rank/max_gs_size - key1=mod(fg_rank,max_gs_size) - call MPI_Comm_split(FG_COMM,kolor1,key1,FG_COMM1,ierr) - call MPI_Comm_size(FG_COMM1,nfgtasks1,ierr) - call MPI_Comm_rank(FG_COMM1,fg_rank1,ierr) - else - FG_COMM1=FG_COMM - nfgtasks1=nfgtasks - fg_rank1=fg_rank - endif - endif - if (fg_rank.eq.0) then - write (*,*) "Processor",MyRank," out of",nprocs, - & " rank in CG_COMM",me," size of CG_COMM",nodes, - & " size of FG_COMM",fg_size, - & " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1 - else - write (*,*) "Processor",MyRank," out of",nprocs, - & " rank in FG_COMM",fg_rank," size of FG_COMM",fg_size, - & " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1 - endif -C Initialize other variables. -c print '(a)','Before initialize' -c call memmon_print_usage() - call initialize -c print '(a,i5,a)','Processor',myrank,' After initialize' -c call memmon_print_usage() -C Open task-dependent files. -c print '(a,i5,a)','Processor',myrank,' Before openunits' -c call memmon_print_usage() - call openunits -c print '(a,i5,a)','Processor',myrank,' After openunits' -c call memmon_print_usage() - if (me.eq.king .or. fg_rank.eq.0 .and. .not. out1file) - & write (iout,'(80(1h*)/a/80(1h*))') - & 'United-residue force field calculation - parallel job.' -c print *,"Processor",myrank," exited OPENUNITS" - return - end -C----------------------------------------------------------------------------- - subroutine finish_task - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.REMD' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TIME1' - include 'COMMON.MD' - integer ilen - external ilen -c - call MPI_Barrier(CG_COMM,ierr) - if (nfgtasks.gt.1) - & call MPI_Bcast(-1,1,MPI_INTEGER,king,FG_COMM,IERROR) - time1=MPI_WTIME() - if (me.eq.king .or. .not. out1file) then - write (iout,'(a,i4,a)') 'CG processor',me,' is finishing work.' - write (iout,*) 'Total wall clock time',time1-walltime,' sec' - if (nfgtasks.gt.1) then - write (iout,'(80(1h=)/a/(80(1h=)))') - & "Details of FG communication time" - write (iout,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))') - & "BROADCAST:",time_bcast,"REDUCE:",time_reduce, - & "GATHER:",time_gather, - & "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv, - & "BARRIER ene",time_barrier_e, - & "BARRIER grad",time_barrier_g,"TOTAL:", - & time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv - & +time_barrier_e+time_barrier_g - write (*,*) 'Total wall clock time',time1-walltime,' sec' - write (*,*) "Processor",me," BROADCAST time",time_bcast, - & " REDUCE time", - & time_reduce," GATHER time",time_gather," SCATTER time", - & time_scatter," SENDRECV",time_sendrecv, - & " BARRIER ene",time_barrier_e," BARRIER grad",time_barrier_g - endif - endif - write (*,'(a,i4,a)') 'CG processor',me,' is finishing work.' - if (ilen(tmpdir).gt.0) then - write (*,*) "Processor",me, - & ": moving output files to the parent directory..." - close(inp) - close(istat,status='keep') - if (ntwe.gt.0) call move_from_tmp(statname) - close(irest2,status='keep') - if (modecalc.eq.12.or. - & (modecalc.eq.14 .and. .not.restart1file)) then - call move_from_tmp(rest2name) - else if (modecalc.eq.14.and. me.eq.king) then - call move_from_tmp(mremd_rst_name) - endif - if (mdpdb) then - close(ipdb,status='keep') - call move_from_tmp(pdbname) - else if (me.eq.king .or. .not.traj1file) then - close(icart,status='keep') - call move_from_tmp(cartname) - endif - if (me.eq.king .or. .not. out1file) then - close (iout,status='keep') - call move_from_tmp(outname) - endif - endif - return - end -c------------------------------------------------------------------------- - subroutine pattern_receive - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.THREAD' - include 'COMMON.IOUNITS' - integer tag,status(MPI_STATUS_SIZE) - integer source,ThreadType - logical flag - ThreadType=45 - source=mpi_any_source - call mpi_iprobe(source,ThreadType, - & CG_COMM,flag,status,ierr) - do while (flag) - write (iout,*) 'Processor ',Me,' is receiving threading', - & ' pattern from processor',status(mpi_source) - write (*,*) 'Processor ',Me,' is receiving threading', - & ' pattern from processor',status(mpi_source) - nexcl=nexcl+1 - call mpi_irecv(iexam(1,nexcl),2,mpi_integer,status(mpi_source), - & ThreadType, CG_COMM,ireq,ierr) - write (iout,*) 'Received pattern:',nexcl,iexam(1,nexcl), - & iexam(2,nexcl) - source=mpi_any_source - call mpi_iprobe(source,ThreadType, - & CG_COMM,flag,status,ierr) - enddo - return - end -c---------------------------------------------------------------------------- - subroutine pattern_send - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.INFO' - include 'COMMON.THREAD' - include 'COMMON.IOUNITS' - integer source,ThreadType,ireq - ThreadType=45 - do iproc=0,nprocs-1 - if (iproc.ne.me .and. .not.Koniec(iproc) ) then - call mpi_isend(iexam(1,nexcl),2,mpi_integer,iproc, - & ThreadType, CG_COMM, ireq, ierr) - write (iout,*) 'CG processor ',me,' has sent pattern ', - & 'to processor',iproc - write (*,*) 'CG processor ',me,' has sent pattern ', - & 'to processor',iproc - write (iout,*) 'Pattern:',nexcl,iexam(1,nexcl),iexam(2,nexcl) - endif - enddo - return - end -c----------------------------------------------------------------------------- - subroutine send_stop_sig(Kwita) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.INFO' - include 'COMMON.IOUNITS' - integer StopType,StopId,iproc,Kwita,NBytes - StopType=66 -c Kwita=-1 -C print *,'CG processor',me,' StopType=',StopType - Koniec(me)=.true. - if (me.eq.king) then -C Master sends the STOP signal to everybody. - write (iout,'(a,a)') - & 'Master is sending STOP signal to other processors.' - do iproc=1,nprocs-1 - print *,'Koniec(',iproc,')=',Koniec(iproc) - if (.not. Koniec(iproc)) then - call mpi_send(Kwita,1,mpi_integer,iproc,StopType, - & mpi_comm_world,ierr) - write (iout,*) 'Iproc=',iproc,' StopID=',StopID - write (*,*) 'Iproc=',iproc,' StopID=',StopID - endif - enddo - else -C Else send the STOP signal to Master. - call mpi_send(Kwita,1,mpi_integer,MasterID,StopType, - & mpi_comm_world,ierr) - write (iout,*) 'CG processor=',me,' StopID=',StopID - write (*,*) 'CG processor=',me,' StopID=',StopID - endif - return - end -c----------------------------------------------------------------------------- - subroutine recv_stop_sig(Kwita) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.INFO' - include 'COMMON.IOUNITS' - integer source,StopType,StopId,iproc,Kwita - logical flag - StopType=66 - Kwita=0 - source=mpi_any_source -c print *,'CG processor:',me,' StopType=',StopType - call mpi_iprobe(source,StopType, - & mpi_comm_world,flag,status,ierr) - do while (flag) - Koniec(status(mpi_source))=.true. - write (iout,*) 'CG processor ',me,' is receiving STOP signal', - & ' from processor',status(mpi_source) - write (*,*) 'CG processor ',me,' is receiving STOP signal', - & ' from processor',status(mpi_source) - call mpi_irecv(Kwita,1,mpi_integer,status(mpi_source),StopType, - & mpi_comm_world,ireq,ierr) - call mpi_iprobe(source,StopType, - & mpi_comm_world,flag,status,ierr) - enddo - return - end -c----------------------------------------------------------------------------- - subroutine send_MCM_info(ione) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - integer tag,status(MPI_STATUS_SIZE) - integer MCM_info_Type,MCM_info_ID,iproc,one,NBytes - common /aaaa/ isend,irecv - integer nsend - save nsend - nsend=nsend+1 - MCM_info_Type=77 -cd write (iout,'(a,i4,a)') 'CG Processor',me, -cd & ' is sending MCM info to Master.' - write (*,'(a,i4,a,i8)') 'CG processor',me, - & ' is sending MCM info to Master, MCM_info_ID=',MCM_info_ID - call mpi_isend(ione,1,mpi_integer,MasterID, - & MCM_info_Type,mpi_comm_world, MCM_info_ID, ierr) -cd write (iout,*) 'CG processor',me,' has sent info to the master;', -cd & ' MCM_info_ID=',MCM_info_ID - write (*,*) 'CG processor',me,' has sent info to the master;', - & ' MCM_info_ID=',MCM_info_ID,' ierr ',ierr - isend=0 - irecv=0 - return - end -c---------------------------------------------------------------------------- - subroutine receive_MCM_info - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.MCM' - include 'COMMON.IOUNITS' - integer tag,status(MPI_STATUS_SIZE) - integer source,MCM_info_Type,MCM_info_ID,iproc,ione - logical flag - MCM_info_Type=77 - source=mpi_any_source -c print *,'source=',source,' dontcare=',dontcare - call mpi_iprobe(source,MCM_info_Type, - & mpi_comm_world,flag,status,ierr) - do while (flag) - source=status(mpi_source) - itask=source/fgProcs+1 -cd write (iout,*) 'Master is receiving MCM info from processor ', -cd & source,' itask',itask - write (*,*) 'Master is receiving MCM info from processor ', - & source,' itask',itask - call mpi_irecv(ione,1,mpi_integer,source,MCM_info_type, - & mpi_comm_world,MCM_info_ID,ierr) -cd write (iout,*) 'Received from processor',source,' IONE=',ione - write (*,*) 'Received from processor',source,' IONE=',ione - nacc_tot=nacc_tot+1 - if (ione.eq.2) nsave_part(itask)=nsave_part(itask)+1 -cd print *,'nsave_part(',itask,')=',nsave_part(itask) -cd write (iout,*) 'Nacc_tot=',Nacc_tot -cd write (*,*) 'Nacc_tot=',Nacc_tot - source=mpi_any_source - call mpi_iprobe(source,MCM_info_Type, - & mpi_comm_world,flag,status,ierr) - enddo - return - end -c--------------------------------------------------------------------------- - subroutine send_thread_results - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - include 'COMMON.THREAD' - include 'COMMON.IOUNITS' - integer tag,status(MPI_STATUS_SIZE) - integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType, - & EnerID,msglen,nbytes - double precision buffer(20*maxthread+2) - ThreadType=444 - EnerType=555 - ipatt(1,nthread+1)=nthread - ipatt(2,nthread+1)=nexcl - do i=1,nthread - do j=1,n_ene - ener(j,i+nthread)=ener0(j,i) - enddo - enddo - ener(1,2*nthread+1)=max_time_for_thread - ener(2,2*nthread+1)=ave_time_for_thread -C Send the IPATT array - write (iout,*) 'CG processor',me, - & ' is sending IPATT array to master: NTHREAD=',nthread - write (*,*) 'CG processor',me, - & ' is sending IPATT array to master: NTHREAD=',nthread - msglen=2*nthread+2 - call mpi_send(ipatt(1,1),msglen,MPI_INTEGER,MasterID, - & ThreadType,mpi_comm_world,ierror) - write (iout,*) 'CG processor',me, - & ' has sent IPATT array to master MSGLEN',msglen - write (*,*) 'CG processor',me, - & ' has sent IPATT array to master MSGLEN',msglen -C Send the energies. - msglen=n_ene2*nthread+2 - write (iout,*) 'CG processor',me,' is sending energies to master.' - write (*,*) 'CG processor',me,' is sending energies to master.' - call mpi_send(ener(1,1),msglen,MPI_DOUBLE_PRECISION,MasterID, - & EnerType,mpi_comm_world,ierror) - write (iout,*) 'CG processor',me,' has sent energies to master.' - write (*,*) 'CG processor',me,' has sent energies to master.' - return - end -c---------------------------------------------------------------------------- - subroutine receive_thread_results(iproc) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.INFO' - include 'COMMON.THREAD' - include 'COMMON.IOUNITS' - integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType, - & EnerID,ReadyType,ReadyID,Ready,msglen,nbytes,nthread_temp - double precision buffer(20*maxthread+2),max_time_for_thread_t, - & ave_time_for_thread_t - logical flag - ThreadType=444 - EnerType=555 -C Receive the IPATT array - call mpi_probe(iproc,ThreadType, - & mpi_comm_world,status,ierr) - call MPI_GET_COUNT(STATUS, MPI_INTEGER, MSGLEN, IERROR) - write (iout,*) 'Master is receiving IPATT array from processor:', - & iproc,' MSGLEN',msglen - write (*,*) 'Master is receiving IPATT array from processor:', - & iproc,' MSGLEN',msglen - call mpi_recv(ipatt(1,nthread+1),msglen,mpi_integer,iproc, - & ThreadType, - & mpi_comm_world,status,ierror) - write (iout,*) 'Master has received IPATT array from processor:', - & iproc,' MSGLEN=',msglen - write (*,*) 'Master has received IPATT array from processor:', - & iproc,' MSGLEN=',msglen - nthread_temp=ipatt(1,nthread+msglen/2) - nexcl_temp=ipatt(2,nthread+msglen/2) -C Receive the energies. - call mpi_probe(iproc,EnerType, - & mpi_comm_world,status,ierr) - call MPI_GET_COUNT(STATUS, MPI_DOUBLE_PRECISION, MSGLEN, IERROR) - write (iout,*) 'Master is receiving energies from processor:', - & iproc,' MSGLEN=',MSGLEN - write (*,*) 'Master is receiving energies from processor:', - & iproc,' MSGLEN=',MSGLEN - call mpi_recv(ener(1,nthread+1),msglen, - & MPI_DOUBLE_PRECISION,iproc, - & EnerType,MPI_COMM_WORLD,status,ierror) - write (iout,*) 'Msglen=',Msglen - write (*,*) 'Msglen=',Msglen - write (iout,*) 'Master has received energies from processor',iproc - write (*,*) 'Master has received energies from processor',iproc - write (iout,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp - write (*,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp - do i=1,nthread_temp - do j=1,n_ene - ener0(j,nthread+i)=ener(j,nthread+nthread_temp+i) - enddo - enddo - max_time_for_thread_t=ener(1,nthread+2*nthread_temp+1) - ave_time_for_thread_t=ener(2,nthread+2*nthread_temp+1) - write (iout,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t - write (iout,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t - write (*,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t - write (*,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t - if (max_time_for_thread_t.gt.max_time_for_thread) - & max_time_for_thread=max_time_for_thread_t - ave_time_for_thread=(nthread*ave_time_for_thread+ - & nthread_temp*ave_time_for_thread_t)/(nthread+nthread_temp) - nthread=nthread+nthread_temp - return - end -#else - subroutine init_task - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - me=0 - myrank=0 - fg_rank=0 - fg_size=1 - nodes=1 - nprocs=1 - call initialize - call openunits - write (iout,'(80(1h*)/a/80(1h*))') - & 'United-residue force field calculation - serial job.' - return - end -#endif diff --git a/source/unres/src_MIN/Makefile b/source/unres/src_MIN/Makefile deleted file mode 120000 index cbb1cd3..0000000 --- a/source/unres/src_MIN/Makefile +++ /dev/null @@ -1 +0,0 @@ -Makefile_ifort_single \ No newline at end of file diff --git a/source/unres/src_MIN/Makefile_gfortran_single b/source/unres/src_MIN/Makefile_gfortran_single deleted file mode 100644 index 5701c47..0000000 --- a/source/unres/src_MIN/Makefile_gfortran_single +++ /dev/null @@ -1,88 +0,0 @@ -FC= gfortran - -OPT = -O - -FFLAGS = -c ${OPT} -FFLAGS1 = -c -g -C -FFLAGS2 = -c -g -O0 -FFLAGSE = -c -O3 - -LIBS = - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F.f -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F -.f.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.f - - -object = unres_min.o arcos.o cartprint.o chainbuild.o initialize_p.o \ - matmult.o readrtns_min.o parmread.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout_min.o readpdb.o \ - intcartderiv.o \ - MP.o printmat.o convert.o int_to_cart.o \ - djacob.o gen_rand_conf.o sc_move.o - -GAB: CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DISNAN \ - -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -GAB: BIN = ../../../bin/unres/MINIM/unres_gfortran_MIN_single_GAB.exe -GAB: ${object} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - -E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DISNAN \ - -DSPLITELE -DLANG0 -E0LL2Y: BIN = ../../../bin/unres/MINIM/unres_gfortran_MIN_single_E0LL2Y.exe -E0LL2Y: ${object} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new_barrier.o : energy_p_new_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F - -gradient_p.o : gradient_p.F - ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F diff --git a/source/unres/src_MIN/Makefile_ifort_single b/source/unres/src_MIN/Makefile_ifort_single deleted file mode 100644 index 1e5d224..0000000 --- a/source/unres/src_MIN/Makefile_ifort_single +++ /dev/null @@ -1,88 +0,0 @@ -FC= ifort -g - -OPT = -O3 -ip -w - -FFLAGS = -c ${OPT} -FFLAGS1 = -c -w -g -d2 -CA -CB -FFLAGS2 = -c -w -g -O0 -FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report - -LIBS = -lpthread - -ARCH = LINUX -PP = /lib/cpp -P - - -all: unres - -.SUFFIXES: .F.f -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F -.f.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.f - - -object = unres_min.o arcos.o cartprint.o chainbuild.o initialize_p.o \ - matmult.o readrtns_min.o parmread.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ - gradient_p.o minimize_p.o sumsld.o \ - cored.o rmdd.o geomout_min.o readpdb.o \ - intcartderiv.o \ - MP.o printmat.o convert.o int_to_cart.o \ - djacob.o gen_rand_conf.o sc_move.o refsys.o - -GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN \ - -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -GAB: BIN = ../../../bin/unres/MINIM/unres_ifort_MIN_single_GAB.exe -GAB: ${object} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - -E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN \ - -DSPLITELE -DLANG0 -E0LL2Y: BIN = ../../../bin/unres/MINIM/unres_ifort_MIN_single_E0LL2Y.exe -E0LL2Y: ${object} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o - -chainbuild.o: chainbuild.F - ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F - -matmult.o: matmult.f - ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f - -parmread.o : parmread.F - ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F - -intcor.o : intcor.f - ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f - -cartder.o : cartder.F - ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F - -readpdb.o : readpdb.F - ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F - -sumsld.o : sumsld.f - ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f - -cored.o : cored.f - ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f - -rmdd.o : rmdd.f - ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f - -energy_p_new_barrier.o : energy_p_new_barrier.F - ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F - -gradient_p.o : gradient_p.F - ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F diff --git a/source/unres/src_MIN/arcos.f b/source/unres/src_MIN/arcos.f deleted file mode 100644 index f054118..0000000 --- a/source/unres/src_MIN/arcos.f +++ /dev/null @@ -1,9 +0,0 @@ - FUNCTION ARCOS(X) - implicit real*8 (a-h,o-z) - include 'COMMON.GEO' - IF (DABS(X).LT.1.0D0) GOTO 1 - ARCOS=PIPOL*(1.0d0-DSIGN(1.0D0,X)) - RETURN - 1 ARCOS=DACOS(X) - RETURN - END diff --git a/source/unres/src_MIN/cartder.F b/source/unres/src_MIN/cartder.F deleted file mode 100644 index e2e8c1a..0000000 --- a/source/unres/src_MIN/cartder.F +++ /dev/null @@ -1,314 +0,0 @@ - subroutine cartder -*********************************************************************** -* This subroutine calculates the derivatives of the consecutive virtual -* bond vectors and the SC vectors in the virtual-bond angles theta and -* virtual-torsional angles phi, as well as the derivatives of SC vectors -* in the angles alpha and omega, describing the location of a side chain -* in its local coordinate system. -* -* The derivatives are stored in the following arrays: -* -* DDCDV - the derivatives of virtual-bond vectors DC in theta and phi. -* The structure is as follows: -* -* dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0, 0, 0 -* dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4) -* . . . . . . . . . . . . . . . . . . -* dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4) -* . -* . -* . -* dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N) -* -* DXDV - the derivatives of the side-chain vectors in theta and phi. -* The structure is same as above. -* -* DCDS - the derivatives of the side chain vectors in the local spherical -* andgles alph and omega: -* -* dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2) -* dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3) -* . -* . -* . -* dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1) -* -* Version of March '95, based on an early version of November '91. -* -*********************************************************************** - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - dimension drt(3,3,maxres),rdt(3,3,maxres),dp(3,3),temp(3,3), - & fromto(3,3,maxdim),prordt(3,3,maxres),prodrt(3,3,maxres) - dimension xx(3),xx1(3) -c common /przechowalnia/ fromto -* get the position of the jth ijth fragment of the chain coordinate system -* in the fromto array. - indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 -* -* calculate the derivatives of transformation matrix elements in theta -* - do i=1,nres-2 - rdt(1,1,i)=-rt(1,2,i) - rdt(1,2,i)= rt(1,1,i) - rdt(1,3,i)= 0.0d0 - rdt(2,1,i)=-rt(2,2,i) - rdt(2,2,i)= rt(2,1,i) - rdt(2,3,i)= 0.0d0 - rdt(3,1,i)=-rt(3,2,i) - rdt(3,2,i)= rt(3,1,i) - rdt(3,3,i)= 0.0d0 - enddo -* -* derivatives in phi -* - do i=2,nres-2 - drt(1,1,i)= 0.0d0 - drt(1,2,i)= 0.0d0 - drt(1,3,i)= 0.0d0 - drt(2,1,i)= rt(3,1,i) - drt(2,2,i)= rt(3,2,i) - drt(2,3,i)= rt(3,3,i) - drt(3,1,i)=-rt(2,1,i) - drt(3,2,i)=-rt(2,2,i) - drt(3,3,i)=-rt(2,3,i) - enddo -* -* generate the matrix products of type r(i)t(i)...r(j)t(j) -* - do i=2,nres-2 - ind=indmat(i,i+1) - do k=1,3 - do l=1,3 - temp(k,l)=rt(k,l,i) - enddo - enddo - do k=1,3 - do l=1,3 - fromto(k,l,ind)=temp(k,l) - enddo - enddo - do j=i+1,nres-2 - ind=indmat(i,j+1) - do k=1,3 - do l=1,3 - dpkl=0.0d0 - do m=1,3 - dpkl=dpkl+temp(k,m)*rt(m,l,j) - enddo - dp(k,l)=dpkl - fromto(k,l,ind)=dpkl - enddo - enddo - do k=1,3 - do l=1,3 - temp(k,l)=dp(k,l) - enddo - enddo - enddo - enddo -* -* Calculate derivatives. -* - ind1=0 - do i=1,nres-2 - ind1=ind1+1 -* -* Derivatives of DC(i+1) in theta(i+2) -* - do j=1,3 - do k=1,2 - dpjk=0.0D0 - do l=1,3 - dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) - enddo - dp(j,k)=dpjk - prordt(j,k,i)=dp(j,k) - enddo - dp(j,3)=0.0D0 - dcdv(j,ind1)=vbld(i+1)*dp(j,1) - enddo -* -* Derivatives of SC(i+1) in theta(i+2) -* - xx1(1)=-0.5D0*xloc(2,i+1) - xx1(2)= 0.5D0*xloc(1,i+1) - do j=1,3 - xj=0.0D0 - do k=1,2 - xj=xj+r(j,k,i)*xx1(k) - enddo - xx(j)=xj - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i)*xx(k) - enddo - dxdv(j,ind1)=rj - enddo -* -* Derivatives of SC(i+1) in theta(i+3). The have to be handled differently -* than the other off-diagonal derivatives. -* - do j=1,3 - dxoiij=0.0D0 - do k=1,3 - dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) - enddo - dxdv(j,ind1+1)=dxoiij - enddo -cd print *,ind1+1,(dxdv(j,ind1+1),j=1,3) -* -* Derivatives of DC(i+1) in phi(i+2) -* - do j=1,3 - do k=1,3 - dpjk=0.0 - do l=2,3 - dpjk=dpjk+prod(j,l,i)*drt(l,k,i) - enddo - dp(j,k)=dpjk - prodrt(j,k,i)=dp(j,k) - enddo - dcdv(j+3,ind1)=vbld(i+1)*dp(j,1) - enddo -* -* Derivatives of SC(i+1) in phi(i+2) -* - xx(1)= 0.0D0 - xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i) - xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i) - do j=1,3 - rj=0.0D0 - do k=2,3 - rj=rj+prod(j,k,i)*xx(k) - enddo - dxdv(j+3,ind1)=-rj - enddo -* -* Derivatives of SC(i+1) in phi(i+3). -* - do j=1,3 - dxoiij=0.0D0 - do k=1,3 - dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) - enddo - dxdv(j+3,ind1+1)=dxoiij - enddo -* -* Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru -* theta(nres) and phi(i+3) thru phi(nres). -* - do j=i+1,nres-2 - ind1=ind1+1 - ind=indmat(i+1,j+1) -cd print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 - do k=1,3 - do l=1,3 - tempkl=0.0D0 - do m=1,2 - tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind) - enddo - temp(k,l)=tempkl - enddo - enddo -cd print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3) -cd print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3) -cd print '(9f8.3)',((temp(k,l),l=1,3),k=1,3) -* Derivatives of virtual-bond vectors in theta - do k=1,3 - dcdv(k,ind1)=vbld(i+1)*temp(k,1) - enddo -cd print '(3f8.3)',(dcdv(k,ind1),k=1,3) -* Derivatives of SC vectors in theta - do k=1,3 - dxoijk=0.0D0 - do l=1,3 - dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) - enddo - dxdv(k,ind1+1)=dxoijk - enddo -* -*--- Calculate the derivatives in phi -* - do k=1,3 - do l=1,3 - tempkl=0.0D0 - do m=1,3 - tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind) - enddo - temp(k,l)=tempkl - enddo - enddo - do k=1,3 - dcdv(k+3,ind1)=vbld(i+1)*temp(k,1) - enddo - do k=1,3 - dxoijk=0.0D0 - do l=1,3 - dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) - enddo - dxdv(k+3,ind1+1)=dxoijk - enddo - enddo - enddo -* -* Derivatives in alpha and omega: -* - do i=2,nres-1 -c dsci=dsc(itype(i)) - dsci=vbld(i+nres) -#ifdef OSF - alphi=alph(i) - omegi=omeg(i) - if(alphi.ne.alphi) alphi=100.0 - if(omegi.ne.omegi) omegi=-100.0 -#else - alphi=alph(i) - omegi=omeg(i) -#endif -cd print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - temp(1,1)=-dsci*sinalphi - temp(2,1)= dsci*cosalphi*cosomegi - temp(3,1)=-dsci*cosalphi*sinomegi - temp(1,2)=0.0D0 - temp(2,2)=-dsci*sinalphi*sinomegi - temp(3,2)=-dsci*sinalphi*cosomegi - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - jjj=0 -cd print *,((temp(l,k),l=1,3),k=1,2) - do j=1,2 - xp=temp(1,j) - yp=temp(2,j) - xxp= xp*cost2+yp*sint2 - yyp=-xp*sint2+yp*cost2 - zzp=temp(3,j) - xx(1)=xxp - xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) - xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) - do k=1,3 - dj=0.0D0 - do l=1,3 - dj=dj+prod(k,l,i-1)*xx(l) - enddo - dxds(jjj+k,i)=dj - enddo - jjj=jjj+3 - enddo - enddo - return - end - diff --git a/source/unres/src_MIN/cartprint.f b/source/unres/src_MIN/cartprint.f deleted file mode 100644 index d79409e..0000000 --- a/source/unres/src_MIN/cartprint.f +++ /dev/null @@ -1,19 +0,0 @@ - subroutine cartprint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - write (iout,100) - do i=1,nres - write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i), - & c(3,i),c(1,nres+i),c(2,nres+i),c(3,nres+i) - enddo - 100 format (//' alpha-carbon coordinates ', - & ' centroid coordinates'/ - 1 ' ', 6X,'X',11X,'Y',11X,'Z', - & 10X,'X',11X,'Y',11X,'Z') - 110 format (a,'(',i3,')',6f12.5) - return - end diff --git a/source/unres/src_MIN/chainbuild.F b/source/unres/src_MIN/chainbuild.F deleted file mode 100644 index 45a1a53..0000000 --- a/source/unres/src_MIN/chainbuild.F +++ /dev/null @@ -1,274 +0,0 @@ - subroutine chainbuild -C -C Build the virtual polypeptide chain. Side-chain centroids are moveable. -C As of 2/17/95. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - logical lprn -C Set lprn=.true. for debugging - lprn = .false. -C -C Define the origin and orientation of the coordinate system and locate the -C first three CA's and SC(2). -C - call orig_frame -* -* Build the alpha-carbon chain. -* - do i=4,nres - call locate_next_res(i) - enddo -C -C First and last SC must coincide with the corresponding CA. -C - do j=1,3 - dc(j,nres+1)=0.0D0 - dc_norm(j,nres+1)=0.0D0 - dc(j,nres+nres)=0.0D0 - dc_norm(j,nres+nres)=0.0D0 - c(j,nres+1)=c(j,1) - c(j,nres+nres)=c(j,nres) - enddo -* -* Temporary diagnosis -* - if (lprn) then - - call cartprint - write (iout,'(/a)') 'Recalculated internal coordinates' - do i=2,nres-1 - do j=1,3 - c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) - enddo - be=0.0D0 - if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i) - be1=rad2deg*beta(nres+i,i,maxres2,i+1) - alfai=0.0D0 - if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i) - write (iout,1212) restyp(itype(i)),i,dist(i-1,i), - & alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,maxres2),be1 - enddo - 1212 format (a3,'(',i3,')',2(f10.5,2f10.2)) - - endif - - return - end -c------------------------------------------------------------------------- - subroutine orig_frame -C -C Define the origin and orientation of the coordinate system and locate -C the first three atoms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - cost=dcos(theta(3)) - sint=dsin(theta(3)) - t(1,1,1)=-cost - t(1,2,1)=-sint - t(1,3,1)= 0.0D0 - t(2,1,1)=-sint - t(2,2,1)= cost - t(2,3,1)= 0.0D0 - t(3,1,1)= 0.0D0 - t(3,2,1)= 0.0D0 - t(3,3,1)= 1.0D0 - r(1,1,1)= 1.0D0 - r(1,2,1)= 0.0D0 - r(1,3,1)= 0.0D0 - r(2,1,1)= 0.0D0 - r(2,2,1)= 1.0D0 - r(2,3,1)= 0.0D0 - r(3,1,1)= 0.0D0 - r(3,2,1)= 0.0D0 - r(3,3,1)= 1.0D0 - do i=1,3 - do j=1,3 - rt(i,j,1)=t(i,j,1) - enddo - enddo - do i=1,3 - do j=1,3 - prod(i,j,1)=0.0D0 - prod(i,j,2)=t(i,j,1) - enddo - prod(i,i,1)=1.0D0 - enddo - c(1,1)=0.0D0 - c(2,1)=0.0D0 - c(3,1)=0.0D0 - c(1,2)=vbld(2) - c(2,2)=0.0D0 - c(3,2)=0.0D0 - dc(1,0)=0.0d0 - dc(2,0)=0.0D0 - dc(3,0)=0.0D0 - dc(1,1)=vbld(2) - dc(2,1)=0.0D0 - dc(3,1)=0.0D0 - dc_norm(1,0)=0.0D0 - dc_norm(2,0)=0.0D0 - dc_norm(3,0)=0.0D0 - dc_norm(1,1)=1.0D0 - dc_norm(2,1)=0.0D0 - dc_norm(3,1)=0.0D0 - do j=1,3 - dc_norm(j,2)=prod(j,1,2) - dc(j,2)=vbld(3)*prod(j,1,2) - c(j,3)=c(j,2)+dc(j,2) - enddo - call locate_side_chain(2) - return - end -c----------------------------------------------------------------------------- - subroutine locate_next_res(i) -C -C Locate CA(i) and SC(i-1) -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' -C -C Define the rotation matrices corresponding to CA(i) -C -#ifdef OSF - theti=theta(i) - if (theti.ne.theti) theti=100.0 - phii=phi(i) - if (phii.ne.phii) phii=180.0 -#else - theti=theta(i) - phii=phi(i) -#endif - cost=dcos(theti) - sint=dsin(theti) - cosphi=dcos(phii) - sinphi=dsin(phii) -* Define the matrices of the rotation about the virtual-bond valence angles -* theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this -* program), R(i,j,k), and, the cumulative matrices of rotation RT - t(1,1,i-2)=-cost - t(1,2,i-2)=-sint - t(1,3,i-2)= 0.0D0 - t(2,1,i-2)=-sint - t(2,2,i-2)= cost - t(2,3,i-2)= 0.0D0 - t(3,1,i-2)= 0.0D0 - t(3,2,i-2)= 0.0D0 - t(3,3,i-2)= 1.0D0 - r(1,1,i-2)= 1.0D0 - r(1,2,i-2)= 0.0D0 - r(1,3,i-2)= 0.0D0 - r(2,1,i-2)= 0.0D0 - r(2,2,i-2)=-cosphi - r(2,3,i-2)= sinphi - r(3,1,i-2)= 0.0D0 - r(3,2,i-2)= sinphi - r(3,3,i-2)= cosphi - rt(1,1,i-2)=-cost - rt(1,2,i-2)=-sint - rt(1,3,i-2)=0.0D0 - rt(2,1,i-2)=sint*cosphi - rt(2,2,i-2)=-cost*cosphi - rt(2,3,i-2)=sinphi - rt(3,1,i-2)=-sint*sinphi - rt(3,2,i-2)=cost*sinphi - rt(3,3,i-2)=cosphi - call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1)) - do j=1,3 - dc_norm(j,i-1)=prod(j,1,i-1) - dc(j,i-1)=vbld(i)*prod(j,1,i-1) - c(j,i)=c(j,i-1)+dc(j,i-1) - enddo -cd print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3) -C -C Now calculate the coordinates of SC(i-1) -C - call locate_side_chain(i-1) - return - end -c----------------------------------------------------------------------------- - subroutine locate_side_chain(i) -C -C Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - dimension xx(3) - -c dsci=dsc(itype(i)) -c dsci_inv=dsc_inv(itype(i)) - dsci=vbld(i+nres) - dsci_inv=vbld_inv(i+nres) -#ifdef OSF - alphi=alph(i) - omegi=omeg(i) - if (alphi.ne.alphi) alphi=100.0 - if (omegi.ne.omegi) omegi=-100.0 -#else - alphi=alph(i) - omegi=omeg(i) -#endif - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - xp= dsci*cosalphi - yp= dsci*sinalphi*cosomegi - zp=-dsci*sinalphi*sinomegi -* Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its -* X-axis aligned with the vector DC(*,i) - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - xx(1)= xp*cost2+yp*sint2 - xx(2)=-xp*sint2+yp*cost2 - xx(3)= zp -cd print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i, -cd & xp,yp,zp,(xx(k),k=1,3) - do j=1,3 - xloc(j,i)=xx(j) - enddo -* Bring the SC vectors to the common coordinate system. - xx(1)=xloc(1,i) - xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1) - xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1) - do j=1,3 - xrot(j,i)=xx(j) - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i-1)*xx(k) - enddo - dc(j,nres+i)=rj - dc_norm(j,nres+i)=rj*dsci_inv - c(j,nres+i)=c(j,i)+rj - enddo - return - end diff --git a/source/unres/src_MIN/checkder_p.F b/source/unres/src_MIN/checkder_p.F deleted file mode 100644 index 67465bb..0000000 --- a/source/unres/src_MIN/checkder_p.F +++ /dev/null @@ -1,688 +0,0 @@ - subroutine check_cartgrad -C Check the gradient of Cartesian coordinates in internal coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.DERIV' - dimension temp(6,maxres),xx(3),gg(3) - indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 -* -* Check the gradient of the virtual-bond and SC vectors in the internal -* coordinates. -* - aincr=1.0d-7 - aincr2=5.0d-8 - call cartder - write (iout,'(a)') '**************** dx/dalpha' - write (iout,'(a)') - do i=2,nres-1 - alphi=alph(i) - alph(i)=alph(i)+aincr - do k=1,3 - temp(k,i)=dc(k,nres+i) - enddo - call chainbuild - do k=1,3 - gg(k)=(dc(k,nres+i)-temp(k,i))/aincr - xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr)) - enddo - write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') - & i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - alph(i)=alphi - call chainbuild - enddo - write (iout,'(a)') - write (iout,'(a)') '**************** dx/domega' - write (iout,'(a)') - do i=2,nres-1 - omegi=omeg(i) - omeg(i)=omeg(i)+aincr - do k=1,3 - temp(k,i)=dc(k,nres+i) - enddo - call chainbuild - do k=1,3 - gg(k)=(dc(k,nres+i)-temp(k,i))/aincr - xx(k)=dabs((gg(k)-dxds(k+3,i))/ - & (aincr*dabs(dxds(k+3,i))+aincr)) - enddo - write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') - & i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - omeg(i)=omegi - call chainbuild - enddo - write (iout,'(a)') - write (iout,'(a)') '**************** dx/dtheta' - write (iout,'(a)') - do i=3,nres - theti=theta(i) - theta(i)=theta(i)+aincr - do j=i-1,nres-1 - do k=1,3 - temp(k,j)=dc(k,nres+j) - enddo - enddo - call chainbuild - do j=i-1,nres-1 - ii = indmat(i-2,j) -c print *,'i=',i-2,' j=',j-1,' ii=',ii - do k=1,3 - gg(k)=(dc(k,nres+j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dxdv(k,ii))/ - & (aincr*dabs(dxdv(k,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3) - write(iout,'(a)') - enddo - write (iout,'(a)') - theta(i)=theti - call chainbuild - enddo - write (iout,'(a)') '***************** dx/dphi' - write (iout,'(a)') - do i=4,nres - phi(i)=phi(i)+aincr - do j=i-1,nres-1 - do k=1,3 - temp(k,j)=dc(k,nres+j) - enddo - enddo - call chainbuild - do j=i-1,nres-1 - ii = indmat(i-2,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,nres+j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ - & (aincr*dabs(dxdv(k+3,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3) - write(iout,'(a)') - enddo - phi(i)=phi(i)-aincr - call chainbuild - enddo - write (iout,'(a)') '****************** ddc/dtheta' - do i=1,nres-2 - thet=theta(i+2) - theta(i+2)=thet+aincr - do j=i,nres - do k=1,3 - temp(k,j)=dc(k,j) - enddo - enddo - call chainbuild - do j=i+1,nres-1 - ii = indmat(i,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dcdv(k,ii))/ - & (aincr*dabs(dcdv(k,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - enddo - do j=1,nres - do k=1,3 - dc(k,j)=temp(k,j) - enddo - enddo - theta(i+2)=thet - enddo - write (iout,'(a)') '******************* ddc/dphi' - do i=1,nres-3 - phii=phi(i+3) - phi(i+3)=phii+aincr - do j=1,nres - do k=1,3 - temp(k,j)=dc(k,j) - enddo - enddo - call chainbuild - do j=i+2,nres-1 - ii = indmat(i+1,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ - & (aincr*dabs(dcdv(k+3,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - enddo - do j=1,nres - do k=1,3 - dc(k,j)=temp(k,j) - enddo - enddo - phi(i+3)=phii - enddo - return - end -C---------------------------------------------------------------------------- - subroutine check_ecart -C Check the gradient of the energy in Cartesian coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTACTS' - common /srutu/ icall - dimension ggg(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar),g(maxvar) - dimension grad_s(6,maxres) - double precision energia(0:n_ene),energia1(0:n_ene) - integer uiparm(1) - double precision urparm(1) - external fdum - icg=1 - nf=0 - nfl=0 - call zerograd - aincr=1.0D-7 - print '(a)','CG processor',me,' calling CHECK_CART.' - nf=0 - icall=0 - call geom_to_var(nvar,x) - call etotal(energia(0)) - etot=energia(0) - call enerprint(energia(0)) - call gradient(nvar,x,nf,g,uiparm,urparm,fdum) - icall =1 - do i=1,nres - write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) - enddo - do i=1,nres - do j=1,3 - grad_s(j,i)=gradc(j,i,icg) - grad_s(j+3,i)=gradx(j,i,icg) - enddo - enddo - call flush(iout) - write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' - do i=1,nres - do j=1,3 - xx(j)=c(j,i+nres) - ddc(j)=dc(j,i) - ddx(j)=dc(j,i+nres) - enddo - do j=1,3 - dc(j,i)=dc(j,i)+aincr - do k=i+1,nres - c(j,k)=c(j,k)+aincr - c(j,k+nres)=c(j,k+nres)+aincr - enddo - call etotal(energia1(0)) - etot1=energia1(0) - ggg(j)=(etot1-etot)/aincr - dc(j,i)=ddc(j) - do k=i+1,nres - c(j,k)=c(j,k)-aincr - c(j,k+nres)=c(j,k+nres)-aincr - enddo - enddo - do j=1,3 - c(j,i+nres)=c(j,i+nres)+aincr - dc(j,i+nres)=dc(j,i+nres)+aincr - call etotal(energia1(0)) - etot1=energia1(0) - ggg(j+3)=(etot1-etot)/aincr - c(j,i+nres)=xx(j) - dc(j,i+nres)=ddx(j) - enddo - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') - & i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6) - enddo - return - end -c---------------------------------------------------------------------------- - subroutine check_ecartint -C Check the gradient of the energy in Cartesian coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTACTS' - include 'COMMON.MD_' - include 'COMMON.LOCAL' - include 'COMMON.SPLITELE' - common /srutu/ icall - dimension ggg(6),ggg1(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar), - & g(maxvar) - dimension dcnorm_safe(3),dxnorm_safe(3) - dimension grad_s(6,0:maxres),grad_s1(6,0:maxres) - double precision phi_temp(maxres),theta_temp(maxres), - & alph_temp(maxres),omeg_temp(maxres) - double precision energia(0:n_ene),energia1(0:n_ene) - integer uiparm(1) - double precision urparm(1) - external fdum - r_cut=2.0d0 - rlambd=0.3d0 - icg=1 - nf=0 - nfl=0 - call intout -c call intcartderiv -c call checkintcartgrad - call zerograd - aincr=1.0D-5 - write(iout,*) 'Calling CHECK_ECARTINT.' - nf=0 - icall=0 - call geom_to_var(nvar,x) - if (.not.split_ene) then - call etotal(energia(0)) - etot=energia(0) - call enerprint(energia(0)) - call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) - call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) - icall =1 - do i=1,nres - write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) - enddo - do j=1,3 - grad_s(j,0)=gcart(j,0) - enddo - do i=1,nres - do j=1,3 - grad_s(j,i)=gcart(j,i) - grad_s(j+3,i)=gxcart(j,i) - enddo - enddo - else -!- split gradient check - write (iout,*) "split_ene not supported" -c call zerograd -c call etotal_long(energia(0)) -c call enerprint(energia(0)) -c call flush(iout) -c write (iout,*) "enter cartgrad" -c call flush(iout) -c call cartgrad -c write (iout,*) "exit cartgrad" -c call flush(iout) -c icall =1 -c write (iout,*) "longrange grad" -c do i=1,nres -c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), -c & (gxcart(j,i),j=1,3) -c enddo -c do j=1,3 -c grad_s(j,0)=gcart(j,0) -c enddo -c do i=1,nres -c do j=1,3 -c grad_s(j,i)=gcart(j,i) -c grad_s(j+3,i)=gxcart(j,i) -c enddo -c enddo -c call zerograd -c call etotal_short(energia(0)) -c call enerprint(energia(0)) -c call flush(iout) -c write (iout,*) "enter cartgrad" -c call flush(iout) -c call cartgrad -c write (iout,*) "exit cartgrad" -c call flush(iout) -c icall =1 -c write (iout,*) "shortrange grad" -c do i=1,nres -c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), -c & (gxcart(j,i),j=1,3) -c enddo -c do j=1,3 -c grad_s1(j,0)=gcart(j,0) -c enddo -c do i=1,nres -c do j=1,3 -c grad_s1(j,i)=gcart(j,i) -c grad_s1(j+3,i)=gxcart(j,i) -c enddo -c enddo - endif - write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' - do i=0,nres - do j=1,3 - xx(j)=c(j,i+nres) - ddc(j)=dc(j,i) - ddx(j)=dc(j,i+nres) - do k=1,3 - dcnorm_safe(k)=dc_norm(k,i) - dxnorm_safe(k)=dc_norm(k,i+nres) - enddo - enddo - do j=1,3 - dc(j,i)=ddc(j)+aincr - call chainbuild_cart -#ifdef MPI -c Broadcast the order to compute internal coordinates to the slaves. -c if (nfgtasks.gt.1) -c & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif -c call int_from_cart1(.false.) - if (.not.split_ene) then - call etotal(energia1(0)) - etot1=energia1(0) - else -!- split gradient -c call etotal_long(energia1(0)) -c etot11=energia1(0) -c call etotal_short(energia1(0)) -c etot12=energia1(0) -c write (iout,*) "etot11",etot11," etot12",etot12 - endif -!- end split gradient -c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 - dc(j,i)=ddc(j)-aincr - call chainbuild_cart -c call int_from_cart1(.false.) - if (.not.split_ene) then - call etotal(energia1(0)) - etot2=energia1(0) - ggg(j)=(etot1-etot2)/(2*aincr) - else -!- split gradient -c call etotal_long(energia1(0)) -c etot21=energia1(0) -c ggg(j)=(etot11-etot21)/(2*aincr) -c call etotal_short(energia1(0)) -c etot22=energia1(0) -c ggg1(j)=(etot12-etot22)/(2*aincr) -!- end split gradient -c write (iout,*) "etot21",etot21," etot22",etot22 - endif -c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 - dc(j,i)=ddc(j) - call chainbuild_cart - enddo - do j=1,3 - dc(j,i+nres)=ddx(j)+aincr - call chainbuild_cart -c write (iout,*) "i",i," j",j," dxnorm+ and dxnorm" -c write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) -c write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) -c write (iout,*) "dxnormnorm",dsqrt( -c & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) -c write (iout,*) "dxnormnormsafe",dsqrt( -c & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) -c write (iout,*) - if (.not.split_ene) then - call etotal(energia1(0)) - etot1=energia1(0) - else -!- split gradient -c call etotal_long(energia1(0)) -c etot11=energia1(0) -c call etotal_short(energia1(0)) -c etot12=energia1(0) - endif -!- end split gradient -c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 - dc(j,i+nres)=ddx(j)-aincr - call chainbuild_cart -c write (iout,*) "i",i," j",j," dxnorm- and dxnorm" -c write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) -c write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) -c write (iout,*) -c write (iout,*) "dxnormnorm",dsqrt( -c & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) -c write (iout,*) "dxnormnormsafe",dsqrt( -c & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) - if (.not.split_ene) then - call etotal(energia1(0)) - etot2=energia1(0) - ggg(j+3)=(etot1-etot2)/(2*aincr) - else -!- split gradient -c call etotal_long(energia1(0)) -c etot21=energia1(0) -c ggg(j+3)=(etot11-etot21)/(2*aincr) -c call etotal_short(energia1(0)) -c etot22=energia1(0) -c ggg1(j+3)=(etot12-etot22)/(2*aincr) -!- end split gradient - endif -c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 - dc(j,i+nres)=ddx(j) - call chainbuild_cart - enddo - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') - & i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6) - if (split_ene) then - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') - & i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i), - & k=1,6) - write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') - & i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6), - & ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6) - endif - enddo - return - end -c------------------------------------------------------------------------- - subroutine int_from_cart1(lprn) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer ierror -#endif - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.SETUP' - include 'COMMON.TIME1' - logical lprn - if (lprn) write (iout,'(/a)') 'Recalculated internal coordinates' -#ifdef TIMING - time01=MPI_Wtime() -#endif -#if defined(PARINT) && defined(MPI) - do i=iint_start,iint_end -#else - do i=2,nres -#endif - dnorm1=dist(i-1,i) - dnorm2=dist(i,i+1) - do j=1,3 - c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))/dnorm1 - & +(c(j,i+1)-c(j,i))/dnorm2) - enddo - be=0.0D0 - if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) - omeg(i)=beta(nres+i,i,maxres2,i+1) - alph(i)=alpha(nres+i,i,maxres2) - theta(i+1)=alpha(i-1,i,i+1) - vbld(i)=dist(i-1,i) - vbld_inv(i)=1.0d0/vbld(i) - vbld(nres+i)=dist(nres+i,i) - if (itype(i).ne.10) then - vbld_inv(nres+i)=1.0d0/vbld(nres+i) - else - vbld_inv(nres+i)=0.0d0 - endif - enddo -#if defined(PARINT) && defined(MPI) - if (nfgtasks1.gt.1) then -cd write(iout,*) "iint_start",iint_start," iint_count", -cd & (iint_count(i),i=0,nfgtasks-1)," iint_displ", -cd & (iint_displ(i),i=0,nfgtasks-1) -cd write (iout,*) "Gather vbld backbone" -cd call flush(iout) - time00=MPI_Wtime() - call MPI_Allgatherv(vbld(iint_start),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,vbld(1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather vbld_inv" -cd call flush(iout) - call MPI_Allgatherv(vbld_inv(iint_start),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,vbld_inv(1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather vbld side chain" -cd call flush(iout) - call MPI_Allgatherv(vbld(iint_start+nres),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,vbld(nres+1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather vbld_inv side chain" -cd call flush(iout) - call MPI_Allgatherv(vbld_inv(iint_start+nres), - & iint_count(fg_rank1),MPI_DOUBLE_PRECISION,vbld_inv(nres+1), - & iint_count(0),iint_displ(0),MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather theta" -cd call flush(iout) - call MPI_Allgatherv(theta(iint_start+1),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,theta(2),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather phi" -cd call flush(iout) - call MPI_Allgatherv(phi(iint_start+1),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,phi(2),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -#ifdef CRYST_SC -cd write (iout,*) "Gather alph" -cd call flush(iout) - call MPI_Allgatherv(alph(iint_start),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,alph(1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -cd write (iout,*) "Gather omeg" -cd call flush(iout) - call MPI_Allgatherv(omeg(iint_start),iint_count(fg_rank1), - & MPI_DOUBLE_PRECISION,omeg(1),iint_count(0),iint_displ(0), - & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) -#endif - time_gather=time_gather+MPI_Wtime()-time00 - endif -#endif - do i=1,nres-1 - do j=1,3 - dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) - enddo - enddo - do i=2,nres-1 - do j=1,3 - dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) - enddo - enddo - if (lprn) then - do i=2,nres - write (iout,1212) restyp(itype(i)),i,vbld(i), - &rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i), - &rad2deg*alph(i),rad2deg*omeg(i) - enddo - endif - 1212 format (a3,'(',i3,')',2(f15.10,2f10.2)) -#ifdef TIMING - time_intfcart=time_intfcart+MPI_Wtime()-time01 -#endif - return - end -c---------------------------------------------------------------------------- - subroutine check_eint -C Check the gradient of energy in internal coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' - common /srutu/ icall - dimension x(maxvar),gana(maxvar),gg(maxvar) - integer uiparm(1) - double precision urparm(1) - double precision energia(0:n_ene),energia1(0:n_ene), - & energia2(0:n_ene) - character*6 key - external fdum - call zerograd - aincr=1.0D-7 - print '(a)','Calling CHECK_INT.' - nf=0 - nfl=0 - icg=1 - call geom_to_var(nvar,x) - call var_to_geom(nvar,x) - call chainbuild - icall=1 - print *,'ICG=',ICG - call etotal(energia(0)) - etot = energia(0) - call enerprint(energia(0)) - print *,'ICG=',ICG -#ifdef MPL - if (MyID.ne.BossID) then - call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID) - nf=x(nvar+1) - nfl=x(nvar+2) - icg=x(nvar+3) - endif -#endif - nf=1 - nfl=3 -cd write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar) - call gradient(nvar,x,nf,gana,uiparm,urparm,fdum) -cd write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar) - icall=1 - do i=1,nvar - xi=x(i) - x(i)=xi-0.5D0*aincr - call var_to_geom(nvar,x) - call chainbuild - call etotal(energia1(0)) - etot1=energia1(0) - x(i)=xi+0.5D0*aincr - call var_to_geom(nvar,x) - call chainbuild - call etotal(energia2(0)) - etot2=energia2(0) - gg(i)=(etot2-etot1)/aincr - write (iout,*) i,etot1,etot2 - x(i)=xi - enddo - write (iout,'(/2a)')' Variable Numerical Analytical', - & ' RelDiff*100% ' - do i=1,nvar - if (i.le.nphi) then - ii=i - key = ' phi' - else if (i.le.nphi+ntheta) then - ii=i-nphi - key=' theta' - else if (i.le.nphi+ntheta+nside) then - ii=i-(nphi+ntheta) - key=' alpha' - else - ii=i-(nphi+ntheta+nside) - key=' omega' - endif - write (iout,'(i3,a,i3,3(1pd16.6))') - & i,key,ii,gg(i),gana(i), - & 100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr) - enddo - return - end diff --git a/source/unres/src_MIN/compinfo.c b/source/unres/src_MIN/compinfo.c deleted file mode 100644 index e28f686..0000000 --- a/source/unres/src_MIN/compinfo.c +++ /dev/null @@ -1,82 +0,0 @@ -#include -#include -#include -#include -#include - -main() -{ -FILE *in, *in1, *out; -int i,j,k,iv1,iv2,iv3; -char *p1,buf[500],buf1[500],buf2[100],buf3[100]; -struct utsname Name; -time_t Tp; - -in=fopen("cinfo.f","r"); -out=fopen("cinfo.f.new","w"); -if (fgets(buf,498,in) != NULL) - fprintf(out,"C DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C\n"); -if (fgets(buf,498,in) != NULL) - sscanf(&buf[1],"%d %d %d",&iv1,&iv2,&iv3); -iv3++; -fprintf(out,"C %d %d %d\n",iv1,iv2,iv3); -fprintf(out," subroutine cinfo\n"); -fprintf(out," include 'COMMON.IOUNITS'\n"); -fprintf(out," write(iout,*)'++++ Compile info ++++'\n"); -fprintf(out," write(iout,*)'Version %d.%-d build %d'\n",iv1,iv2,iv3); -uname(&Name); -time(&Tp); -system("whoami > tmptmp"); -in1=fopen("tmptmp","r"); -if (fscanf(in1,"%s",buf1) != EOF) -{ -p1=ctime(&Tp); -p1[strlen(p1)-1]='\0'; -fprintf(out," write(iout,*)'compiled %s'\n",p1); -fprintf(out," write(iout,*)'compiled by %s@%s'\n",buf1,Name.nodename); -fprintf(out," write(iout,*)'OS name: %s '\n",Name.sysname); -fprintf(out," write(iout,*)'OS release: %s '\n",Name.release); -fprintf(out," write(iout,*)'OS version:',\n"); -fprintf(out," & ' %s '\n",Name.version); -fprintf(out," write(iout,*)'flags:'\n"); -} -system("rm tmptmp"); -fclose(in1); -in1=fopen("Makefile","r"); -while(fgets(buf,498,in1) != NULL) - { - if((p1=strchr(buf,'=')) != NULL && buf[0] != '#') - { - buf[strlen(buf)-1]='\0'; - if(strlen(buf) > 49) - { - buf[47]='\0'; - strcat(buf,"..."); - } - else - { - while(buf[strlen(buf)-1]=='\\') - { - strcat(buf,"\\"); - fprintf(out," write(iout,*)'%s'\n",buf); - if (fgets(buf,498,in1) != NULL) - buf[strlen(buf)-1]='\0'; - if(strlen(buf) > 49) - { - buf[47]='\0'; - strcat(buf,"..."); - } - } - } - - fprintf(out," write(iout,*)'%s'\n",buf); - } - } -fprintf(out," write(iout,*)'++++ End of compile info ++++'\n"); -fprintf(out," return\n"); -fprintf(out," end\n"); -fclose(out); -fclose(in1); -fclose(in); -system("mv cinfo.f.new cinfo.f"); -} diff --git a/source/unres/src_MIN/convert.f b/source/unres/src_MIN/convert.f deleted file mode 100644 index dc0cccd..0000000 --- a/source/unres/src_MIN/convert.f +++ /dev/null @@ -1,196 +0,0 @@ - subroutine geom_to_var(n,x) -C -C Transfer the geometry parameters to the variable array. -C The positions of variables are as follows: -C 1. Virtual-bond torsional angles: 1 thru nres-3 -C 2. Virtual-bond valence angles: nres-2 thru 2*nres-5 -C 3. The polar angles alpha of local SC orientation: 2*nres-4 thru -C 2*nres-4+nside -C 4. The torsional angles omega of SC orientation: 2*nres-4+nside+1 -C thru 2*nre-4+2*nside -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - double precision x(n) -cd print *,'nres',nres,' nphi',nphi,' ntheta',ntheta,' nvar',nvar - do i=4,nres - x(i-3)=phi(i) -cd print *,i,i-3,phi(i) - enddo - if (n.eq.nphi) return - do i=3,nres - x(i-2+nphi)=theta(i) -cd print *,i,i-2+nphi,theta(i) - enddo - if (n.eq.nphi+ntheta) return - do i=2,nres-1 - if (ialph(i,1).gt.0) then - x(ialph(i,1))=alph(i) - x(ialph(i,1)+nside)=omeg(i) -cd print *,i,ialph(i,1),ialph(i,1)+nside,alph(i),omeg(i) - endif - enddo - return - end -C-------------------------------------------------------------------- - subroutine var_to_geom(n,x) -C -C Update geometry parameters according to the variable array. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - dimension x(n) - logical change,reduce - change=reduce(x) - if (n.gt.nphi+ntheta) then - do i=1,nside - ii=ialph(i,2) - alph(ii)=x(nphi+ntheta+i) - omeg(ii)=pinorm(x(nphi+ntheta+nside+i)) - enddo - endif - do i=4,nres - phi(i)=x(i-3) - enddo - if (n.eq.nphi) return - do i=3,nres - theta(i)=x(i-2+nphi) - if (theta(i).eq.pi) theta(i)=0.99d0*pi - x(i-2+nphi)=theta(i) - enddo - return - end -c------------------------------------------------------------------------- - logical function convert_side(alphi,omegi) - implicit none - double precision alphi,omegi - double precision pinorm - include 'COMMON.GEO' - convert_side=.false. -C Apply periodicity restrictions. - if (alphi.gt.pi) then - alphi=dwapi-alphi - omegi=pinorm(omegi+pi) - convert_side=.true. - endif - return - end -c------------------------------------------------------------------------- - logical function reduce(x) -C -C Apply periodic restrictions to variables. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - logical zm,zmiana,convert_side - dimension x(nvar) - zmiana=.false. - do i=4,nres - x(i-3)=pinorm(x(i-3)) - enddo - if (nvar.gt.nphi+ntheta) then - do i=1,nside - ii=nphi+ntheta+i - iii=ii+nside - x(ii)=thetnorm(x(ii)) - x(iii)=pinorm(x(iii)) -C Apply periodic restrictions. - zm=convert_side(x(ii),x(iii)) - zmiana=zmiana.or.zm - enddo - endif - if (nvar.eq.nphi) return - do i=3,nres - ii=i-2+nphi - iii=i-3 - x(ii)=dmod(x(ii),dwapi) -C Apply periodic restrictions. - if (x(ii).gt.pi) then - zmiana=.true. - x(ii)=dwapi-x(ii) - if (iii.gt.0) x(iii)=pinorm(x(iii)+pi) - if (i.lt.nres) x(iii+1)=pinorm(x(iii+1)+pi) - ii=ialph(i-1,1) - if (ii.gt.0) then - x(ii)=dmod(pi-x(ii),dwapi) - x(ii+nside)=pinorm(-x(ii+nside)) - zm=convert_side(x(ii),x(ii+nside)) - endif - else if (x(ii).lt.-pi) then - zmiana=.true. - x(ii)=dwapi+x(ii) - ii=ialph(i-1,1) - if (ii.gt.0) then - x(ii)=dmod(pi-x(ii),dwapi) - x(ii+nside)=pinorm(-pi-x(ii+nside)) - zm=convert_side(x(ii),x(ii+nside)) - endif - else if (x(ii).lt.0.0d0) then - zmiana=.true. - x(ii)=-x(ii) - if (iii.gt.0) x(iii)=pinorm(x(iii)+pi) - if (i.lt.nres) x(iii+1)=pinorm(x(iii+1)+pi) - ii=ialph(i-1,1) - if (ii.gt.0) then - x(ii+nside)=pinorm(-x(ii+nside)) - zm=convert_side(x(ii),x(ii+nside)) - endif - endif - enddo - reduce=zmiana - return - end -c-------------------------------------------------------------------------- - double precision function thetnorm(x) -C This function puts x within [0,2Pi]. - implicit none - double precision x,xx - include 'COMMON.GEO' - xx=dmod(x,dwapi) - if (xx.lt.0.0d0) xx=xx+dwapi - if (xx.gt.0.9999d0*pi) xx=0.9999d0*pi - thetnorm=xx - return - end -C-------------------------------------------------------------------- - subroutine var_to_geom_restr(n,xx) -C -C Update geometry parameters according to the variable array. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.IOUNITS' - dimension x(maxvar),xx(maxvar) - logical change,reduce - - call xx2x(x,xx) - change=reduce(x) - do i=1,nside - ii=ialph(i,2) - alph(ii)=x(nphi+ntheta+i) - omeg(ii)=pinorm(x(nphi+ntheta+nside+i)) - enddo - do i=4,nres - phi(i)=x(i-3) - enddo - do i=3,nres - theta(i)=x(i-2+nphi) - if (theta(i).eq.pi) theta(i)=0.99d0*pi - x(i-2+nphi)=theta(i) - enddo - return - end -c------------------------------------------------------------------------- diff --git a/source/unres/src_MIN/cored.f b/source/unres/src_MIN/cored.f deleted file mode 100644 index 1cf25e5..0000000 --- a/source/unres/src_MIN/cored.f +++ /dev/null @@ -1,3151 +0,0 @@ - subroutine assst(iv, liv, lv, v) -c -c *** assess candidate step (***sol version 2.3) *** -c - integer liv, l - integer iv(liv) - double precision v(lv) -c -c *** purpose *** -c -c this subroutine is called by an unconstrained minimization -c routine to assess the next candidate step. it may recommend one -c of several courses of action, such as accepting the step, recom- -c puting it using the same or a new quadratic model, or halting due -c to convergence or false convergence. see the return code listing -c below. -c -c-------------------------- parameter usage -------------------------- -c -c iv (i/o) integer parameter and scratch vector -- see description -c below of iv values referenced. -c liv (in) length of iv array. -c lv (in) length of v array. -c v (i/o) real parameter and scratch vector -- see description -c below of v values referenced. -c -c *** iv values referenced *** -c -c iv(irc) (i/o) on input for the first step tried in a new iteration, -c iv(irc) should be set to 3 or 4 (the value to which it is -c set when step is definitely to be accepted). on input -c after step has been recomputed, iv(irc) should be -c unchanged since the previous return of assst. -c on output, iv(irc) is a return code having one of the -c following values... -c 1 = switch models or try smaller step. -c 2 = switch models or accept step. -c 3 = accept step and determine v(radfac) by gradient -c tests. -c 4 = accept step, v(radfac) has been determined. -c 5 = recompute step (using the same model). -c 6 = recompute step with radius = v(lmaxs) but do not -c evaulate the objective function. -c 7 = x-convergence (see v(xctol)). -c 8 = relative function convergence (see v(rfctol)). -c 9 = both x- and relative function convergence. -c 10 = absolute function convergence (see v(afctol)). -c 11 = singular convergence (see v(lmaxs)). -c 12 = false convergence (see v(xftol)). -c 13 = iv(irc) was out of range on input. -c return code i has precdence over i+1 for i = 9, 10, 11. -c iv(mlstgd) (i/o) saved value of iv(model). -c iv(model) (i/o) on input, iv(model) should be an integer identifying -c the current quadratic model of the objective function. -c if a previous step yielded a better function reduction, -c then iv(model) will be set to iv(mlstgd) on output. -c iv(nfcall) (in) invocation count for the objective function. -c iv(nfgcal) (i/o) value of iv(nfcall) at step that gave the biggest -c function reduction this iteration. iv(nfgcal) remains -c unchanged until a function reduction is obtained. -c iv(radinc) (i/o) the number of radius increases (or minus the number -c of decreases) so far this iteration. -c iv(restor) (out) set to 1 if v(f) has been restored and x should be -c restored to its initial value, to 2 if x should be saved, -c to 3 if x should be restored from the saved value, and to -c 0 otherwise. -c iv(stage) (i/o) count of the number of models tried so far in the -c current iteration. -c iv(stglim) (in) maximum number of models to consider. -c iv(switch) (out) set to 0 unless a new model is being tried and it -c gives a smaller function value than the previous model, -c in which case assst sets iv(switch) = 1. -c iv(toobig) (in) is nonzero if step was too big (e.g. if it caused -c overflow). -c iv(xirc) (i/o) value that iv(irc) would have in the absence of -c convergence, false convergence, and oversized steps. -c -c *** v values referenced *** -c -c v(afctol) (in) absolute function convergence tolerance. if the -c absolute value of the current function value v(f) is less -c than v(afctol), then assst returns with iv(irc) = 10. -c v(decfac) (in) factor by which to decrease radius when iv(toobig) is -c nonzero. -c v(dstnrm) (in) the 2-norm of d*step. -c v(dstsav) (i/o) value of v(dstnrm) on saved step. -c v(dst0) (in) the 2-norm of d times the newton step (when defined, -c i.e., for v(nreduc) .ge. 0). -c v(f) (i/o) on both input and output, v(f) is the objective func- -c tion value at x. if x is restored to a previous value, -c then v(f) is restored to the corresponding value. -c v(fdif) (out) the function reduction v(f0) - v(f) (for the output -c value of v(f) if an earlier step gave a bigger function -c decrease, and for the input value of v(f) otherwise). -c v(flstgd) (i/o) saved value of v(f). -c v(f0) (in) objective function value at start of iteration. -c v(gtslst) (i/o) value of v(gtstep) on saved step. -c v(gtstep) (in) inner product between step and gradient. -c v(incfac) (in) minimum factor by which to increase radius. -c v(lmaxs) (in) maximum reasonable step size (and initial step bound). -c if the actual function decrease is no more than twice -c what was predicted, if a return with iv(irc) = 7, 8, 9, -c or 10 does not occur, if v(dstnrm) .gt. v(lmaxs), and if -c v(preduc) .le. v(sctol) * abs(v(f0)), then assst re- -c turns with iv(irc) = 11. if so doing appears worthwhile, -c then assst repeats this test with v(preduc) computed for -c a step of length v(lmaxs) (by a return with iv(irc) = 6). -c v(nreduc) (i/o) function reduction predicted by quadratic model for -c newton step. if assst is called with iv(irc) = 6, i.e., -c if v(preduc) has been computed with radius = v(lmaxs) for -c use in the singular convervence test, then v(nreduc) is -c set to -v(preduc) before the latter is restored. -c v(plstgd) (i/o) value of v(preduc) on saved step. -c v(preduc) (i/o) function reduction predicted by quadratic model for -c current step. -c v(radfac) (out) factor to be used in determining the new radius, -c which should be v(radfac)*dst, where dst is either the -c output value of v(dstnrm) or the 2-norm of -c diag(newd)*step for the output value of step and the -c updated version, newd, of the scale vector d. for -c iv(irc) = 3, v(radfac) = 1.0 is returned. -c v(rdfcmn) (in) minimum value for v(radfac) in terms of the input -c value of v(dstnrm) -- suggested value = 0.1. -c v(rdfcmx) (in) maximum value for v(radfac) -- suggested value = 4.0. -c v(reldx) (in) scaled relative change in x caused by step, computed -c (e.g.) by function reldst as -c max (d(i)*abs(x(i)-x0(i)), 1 .le. i .le. p) / -c max (d(i)*(abs(x(i))+abs(x0(i))), 1 .le. i .le. p). -c v(rfctol) (in) relative function convergence tolerance. if the -c actual function reduction is at most twice what was pre- -c dicted and v(nreduc) .le. v(rfctol)*abs(v(f0)), then -c assst returns with iv(irc) = 8 or 9. -c v(stppar) (in) marquardt parameter -- 0 means full newton step. -c v(tuner1) (in) tuning constant used to decide if the function -c reduction was much less than expected. suggested -c value = 0.1. -c v(tuner2) (in) tuning constant used to decide if the function -c reduction was large enough to accept step. suggested -c value = 10**-4. -c v(tuner3) (in) tuning constant used to decide if the radius -c should be increased. suggested value = 0.75. -c v(xctol) (in) x-convergence criterion. if step is a newton step -c (v(stppar) = 0) having v(reldx) .le. v(xctol) and giving -c at most twice the predicted function decrease, then -c assst returns iv(irc) = 7 or 9. -c v(xftol) (in) false convergence tolerance. if step gave no or only -c a small function decrease and v(reldx) .le. v(xftol), -c then assst returns with iv(irc) = 12. -c -c------------------------------- notes ------------------------------- -c -c *** application and usage restrictions *** -c -c this routine is called as part of the nl2sol (nonlinear -c least-squares) package. it may be used in any unconstrained -c minimization solver that uses dogleg, goldfeld-quandt-trotter, -c or levenberg-marquardt steps. -c -c *** algorithm notes *** -c -c see (1) for further discussion of the assessing and model -c switching strategies. while nl2sol considers only two models, -c assst is designed to handle any number of models. -c -c *** usage notes *** -c -c on the first call of an iteration, only the i/o variables -c step, x, iv(irc), iv(model), v(f), v(dstnrm), v(gtstep), and -c v(preduc) need have been initialized. between calls, no i/o -c values execpt step, x, iv(model), v(f) and the stopping toler- -c ances should be changed. -c after a return for convergence or false convergence, one can -c change the stopping tolerances and call assst again, in which -c case the stopping tests will be repeated. -c -c *** references *** -c -c (1) dennis, j.e., jr., gay, d.m., and welsch, r.e. (1981), -c an adaptive nonlinear least-squares algorithm, -c acm trans. math. software, vol. 7, no. 3. -c -c (2) powell, m.j.d. (1970) a fortran subroutine for solving -c systems of nonlinear algebraic equations, in numerical -c methods for nonlinear algebraic equations, edited by -c p. rabinowitz, gordon and breach, london. -c -c *** history *** -c -c john dennis designed much of this routine, starting with -c ideas in (2). roy welsch suggested the model switching strategy. -c david gay and stephen peters cast this subroutine into a more -c portable form (winter 1977), and david gay cast it into its -c present form (fall 1978). -c -c *** general *** -c -c this subroutine was written in connection with research -c supported by the national science foundation under grants -c mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, and -c mcs-7906671. -c -c------------------------ external quantities ------------------------ -c -c *** no external functions and subroutines *** -c -c *** intrinsic functions *** -c/+ - double precision dabs, dmax1 -c/ -c *** no common blocks *** -c -c-------------------------- local variables -------------------------- -c - logical goodx - integer i, nfc - double precision emax, emaxs, gts, rfac1, xmax - double precision half, one, onep2, two, zero -c -c *** subscripts for iv and v *** -c - integer afctol, decfac, dstnrm, dstsav, dst0, f, fdif, flstgd, f0, - 1 gtslst, gtstep, incfac, irc, lmaxs, mlstgd, model, nfcall, - 2 nfgcal, nreduc, plstgd, preduc, radfac, radinc, rdfcmn, - 3 rdfcmx, reldx, restor, rfctol, sctol, stage, stglim, - 4 stppar, switch, toobig, tuner1, tuner2, tuner3, xctol, - 5 xftol, xirc -c -c *** data initializations *** -c -c/6 -c data half/0.5d+0/, one/1.d+0/, onep2/1.2d+0/, two/2.d+0/, -c 1 zero/0.d+0/ -c/7 - parameter (half=0.5d+0, one=1.d+0, onep2=1.2d+0, two=2.d+0, - 1 zero=0.d+0) -c/ -c -c/6 -c data irc/29/, mlstgd/32/, model/5/, nfcall/6/, nfgcal/7/, -c 1 radinc/8/, restor/9/, stage/10/, stglim/11/, switch/12/, -c 2 toobig/2/, xirc/13/ -c/7 - parameter (irc=29, mlstgd=32, model=5, nfcall=6, nfgcal=7, - 1 radinc=8, restor=9, stage=10, stglim=11, switch=12, - 2 toobig=2, xirc=13) -c/ -c/6 -c data afctol/31/, decfac/22/, dstnrm/2/, dst0/3/, dstsav/18/, -c 1 f/10/, fdif/11/, flstgd/12/, f0/13/, gtslst/14/, gtstep/4/, -c 2 incfac/23/, lmaxs/36/, nreduc/6/, plstgd/15/, preduc/7/, -c 3 radfac/16/, rdfcmn/24/, rdfcmx/25/, reldx/17/, rfctol/32/, -c 4 sctol/37/, stppar/5/, tuner1/26/, tuner2/27/, tuner3/28/, -c 5 xctol/33/, xftol/34/ -c/7 - parameter (afctol=31, decfac=22, dstnrm=2, dst0=3, dstsav=18, - 1 f=10, fdif=11, flstgd=12, f0=13, gtslst=14, gtstep=4, - 2 incfac=23, lmaxs=36, nreduc=6, plstgd=15, preduc=7, - 3 radfac=16, rdfcmn=24, rdfcmx=25, reldx=17, rfctol=32, - 4 sctol=37, stppar=5, tuner1=26, tuner2=27, tuner3=28, - 5 xctol=33, xftol=34) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - nfc = iv(nfcall) - iv(switch) = 0 - iv(restor) = 0 - rfac1 = one - goodx = .true. - i = iv(irc) - if (i .ge. 1 .and. i .le. 12) - 1 go to (20,30,10,10,40,280,220,220,220,220,220,170), i - iv(irc) = 13 - go to 999 -c -c *** initialize for new iteration *** -c - 10 iv(stage) = 1 - iv(radinc) = 0 - v(flstgd) = v(f0) - if (iv(toobig) .eq. 0) go to 110 - iv(stage) = -1 - iv(xirc) = i - go to 60 -c -c *** step was recomputed with new model or smaller radius *** -c *** first decide which *** -c - 20 if (iv(model) .ne. iv(mlstgd)) go to 30 -c *** old model retained, smaller radius tried *** -c *** do not consider any more new models this iteration *** - iv(stage) = iv(stglim) - iv(radinc) = -1 - go to 110 -c -c *** a new model is being tried. decide whether to keep it. *** -c - 30 iv(stage) = iv(stage) + 1 -c -c *** now we add the possibiltiy that step was recomputed with *** -c *** the same model, perhaps because of an oversized step. *** -c - 40 if (iv(stage) .gt. 0) go to 50 -c -c *** step was recomputed because it was too big. *** -c - if (iv(toobig) .ne. 0) go to 60 -c -c *** restore iv(stage) and pick up where we left off. *** -c - iv(stage) = -iv(stage) - i = iv(xirc) - go to (20, 30, 110, 110, 70), i -c - 50 if (iv(toobig) .eq. 0) go to 70 -c -c *** handle oversize step *** -c - if (iv(radinc) .gt. 0) go to 80 - iv(stage) = -iv(stage) - iv(xirc) = iv(irc) -c - 60 v(radfac) = v(decfac) - iv(radinc) = iv(radinc) - 1 - iv(irc) = 5 - iv(restor) = 1 - go to 999 -c - 70 if (v(f) .lt. v(flstgd)) go to 110 -c -c *** the new step is a loser. restore old model. *** -c - if (iv(model) .eq. iv(mlstgd)) go to 80 - iv(model) = iv(mlstgd) - iv(switch) = 1 -c -c *** restore step, etc. only if a previous step decreased v(f). -c - 80 if (v(flstgd) .ge. v(f0)) go to 110 - iv(restor) = 1 - v(f) = v(flstgd) - v(preduc) = v(plstgd) - v(gtstep) = v(gtslst) - if (iv(switch) .eq. 0) rfac1 = v(dstnrm) / v(dstsav) - v(dstnrm) = v(dstsav) - nfc = iv(nfgcal) - goodx = .false. -c - 110 v(fdif) = v(f0) - v(f) - if (v(fdif) .gt. v(tuner2) * v(preduc)) go to 140 - if(iv(radinc).gt.0) go to 140 -c -c *** no (or only a trivial) function decrease -c *** -- so try new model or smaller radius -c - if (v(f) .lt. v(f0)) go to 120 - iv(mlstgd) = iv(model) - v(flstgd) = v(f) - v(f) = v(f0) - iv(restor) = 1 - go to 130 - 120 iv(nfgcal) = nfc - 130 iv(irc) = 1 - if (iv(stage) .lt. iv(stglim)) go to 160 - iv(irc) = 5 - iv(radinc) = iv(radinc) - 1 - go to 160 -c -c *** nontrivial function decrease achieved *** -c - 140 iv(nfgcal) = nfc - rfac1 = one - v(dstsav) = v(dstnrm) - if (v(fdif) .gt. v(preduc)*v(tuner1)) go to 190 -c -c *** decrease was much less than predicted -- either change models -c *** or accept step with decreased radius. -c - if (iv(stage) .ge. iv(stglim)) go to 150 -c *** consider switching models *** - iv(irc) = 2 - go to 160 -c -c *** accept step with decreased radius *** -c - 150 iv(irc) = 4 -c -c *** set v(radfac) to fletcher*s decrease factor *** -c - 160 iv(xirc) = iv(irc) - emax = v(gtstep) + v(fdif) - v(radfac) = half * rfac1 - if (emax .lt. v(gtstep)) v(radfac) = rfac1 * dmax1(v(rdfcmn), - 1 half * v(gtstep)/emax) -c -c *** do false convergence test *** -c - 170 if (v(reldx) .le. v(xftol)) go to 180 - iv(irc) = iv(xirc) - if (v(f) .lt. v(f0)) go to 200 - go to 230 -c - 180 iv(irc) = 12 - go to 240 -c -c *** handle good function decrease *** -c - 190 if (v(fdif) .lt. (-v(tuner3) * v(gtstep))) go to 210 -c -c *** increasing radius looks worthwhile. see if we just -c *** recomputed step with a decreased radius or restored step -c *** after recomputing it with a larger radius. -c - if (iv(radinc) .lt. 0) go to 210 - if (iv(restor) .eq. 1) go to 210 -c -c *** we did not. try a longer step unless this was a newton -c *** step. -c - v(radfac) = v(rdfcmx) - gts = v(gtstep) - if (v(fdif) .lt. (half/v(radfac) - one) * gts) - 1 v(radfac) = dmax1(v(incfac), half*gts/(gts + v(fdif))) - iv(irc) = 4 - if (v(stppar) .eq. zero) go to 230 - if (v(dst0) .ge. zero .and. (v(dst0) .lt. two*v(dstnrm) - 1 .or. v(nreduc) .lt. onep2*v(fdif))) go to 230 -c *** step was not a newton step. recompute it with -c *** a larger radius. - iv(irc) = 5 - iv(radinc) = iv(radinc) + 1 -c -c *** save values corresponding to good step *** -c - 200 v(flstgd) = v(f) - iv(mlstgd) = iv(model) - if (iv(restor) .ne. 1) iv(restor) = 2 - v(dstsav) = v(dstnrm) - iv(nfgcal) = nfc - v(plstgd) = v(preduc) - v(gtslst) = v(gtstep) - go to 230 -c -c *** accept step with radius unchanged *** -c - 210 v(radfac) = one - iv(irc) = 3 - go to 230 -c -c *** come here for a restart after convergence *** -c - 220 iv(irc) = iv(xirc) - if (v(dstsav) .ge. zero) go to 240 - iv(irc) = 12 - go to 240 -c -c *** perform convergence tests *** -c - 230 iv(xirc) = iv(irc) - 240 if (iv(restor) .eq. 1 .and. v(flstgd) .lt. v(f0)) iv(restor) = 3 - if (half * v(fdif) .gt. v(preduc)) go to 999 - emax = v(rfctol) * dabs(v(f0)) - emaxs = v(sctol) * dabs(v(f0)) - if (v(dstnrm) .gt. v(lmaxs) .and. v(preduc) .le. emaxs) - 1 iv(irc) = 11 - if (v(dst0) .lt. zero) go to 250 - i = 0 - if ((v(nreduc) .gt. zero .and. v(nreduc) .le. emax) .or. - 1 (v(nreduc) .eq. zero. and. v(preduc) .eq. zero)) i = 2 - if (v(stppar) .eq. zero .and. v(reldx) .le. v(xctol) - 1 .and. goodx) i = i + 1 - if (i .gt. 0) iv(irc) = i + 6 -c -c *** consider recomputing step of length v(lmaxs) for singular -c *** convergence test. -c - 250 if (iv(irc) .gt. 5 .and. iv(irc) .ne. 12) go to 999 - if (v(dstnrm) .gt. v(lmaxs)) go to 260 - if (v(preduc) .ge. emaxs) go to 999 - if (v(dst0) .le. zero) go to 270 - if (half * v(dst0) .le. v(lmaxs)) go to 999 - go to 270 - 260 if (half * v(dstnrm) .le. v(lmaxs)) go to 999 - xmax = v(lmaxs) / v(dstnrm) - if (xmax * (two - xmax) * v(preduc) .ge. emaxs) go to 999 - 270 if (v(nreduc) .lt. zero) go to 290 -c -c *** recompute v(preduc) for use in singular convergence test *** -c - v(gtslst) = v(gtstep) - v(dstsav) = v(dstnrm) - if (iv(irc) .eq. 12) v(dstsav) = -v(dstsav) - v(plstgd) = v(preduc) - i = iv(restor) - iv(restor) = 2 - if (i .eq. 3) iv(restor) = 0 - iv(irc) = 6 - go to 999 -c -c *** perform singular convergence test with recomputed v(preduc) *** -c - 280 v(gtstep) = v(gtslst) - v(dstnrm) = dabs(v(dstsav)) - iv(irc) = iv(xirc) - if (v(dstsav) .le. zero) iv(irc) = 12 - v(nreduc) = -v(preduc) - v(preduc) = v(plstgd) - iv(restor) = 3 - 290 if (-v(nreduc) .le. v(sctol) * dabs(v(f0))) iv(irc) = 11 -c - 999 return -c -c *** last card of assst follows *** - end - subroutine deflt(alg, iv, liv, lv, v) -c -c *** supply ***sol (version 2.3) default values to iv and v *** -c -c *** alg = 1 means regression constants. -c *** alg = 2 means general unconstrained optimization constants. -c - integer liv, l - integer alg, iv(liv) - double precision v(lv) -c - external imdcon, vdflt - integer imdcon -c imdcon... returns machine-dependent integer constants. -c vdflt.... provides default values to v. -c - integer miv, m - integer miniv(2), minv(2) -c -c *** subscripts for iv *** -c - integer algsav, covprt, covreq, dtype, hc, ierr, inith, inits, - 1 ipivot, ivneed, lastiv, lastv, lmat, mxfcal, mxiter, - 2 nfcov, ngcov, nvdflt, outlev, parprt, parsav, perm, - 3 prunit, qrtyp, rdreq, rmat, solprt, statpr, vneed, - 4 vsave, x0prt -c -c *** iv subscript values *** -c -c/6 -c data algsav/51/, covprt/14/, covreq/15/, dtype/16/, hc/71/, -c 1 ierr/75/, inith/25/, inits/25/, ipivot/76/, ivneed/3/, -c 2 lastiv/44/, lastv/45/, lmat/42/, mxfcal/17/, mxiter/18/, -c 3 nfcov/52/, ngcov/53/, nvdflt/50/, outlev/19/, parprt/20/, -c 4 parsav/49/, perm/58/, prunit/21/, qrtyp/80/, rdreq/57/, -c 5 rmat/78/, solprt/22/, statpr/23/, vneed/4/, vsave/60/, -c 6 x0prt/24/ -c/7 - parameter (algsav=51, covprt=14, covreq=15, dtype=16, hc=71, - 1 ierr=75, inith=25, inits=25, ipivot=76, ivneed=3, - 2 lastiv=44, lastv=45, lmat=42, mxfcal=17, mxiter=18, - 3 nfcov=52, ngcov=53, nvdflt=50, outlev=19, parprt=20, - 4 parsav=49, perm=58, prunit=21, qrtyp=80, rdreq=57, - 5 rmat=78, solprt=22, statpr=23, vneed=4, vsave=60, - 6 x0prt=24) -c/ - data miniv(1)/80/, miniv(2)/59/, minv(1)/98/, minv(2)/71/ -c -c------------------------------- body -------------------------------- -c - if (alg .lt. 1 .or. alg .gt. 2) go to 40 - miv = miniv(alg) - if (liv .lt. miv) go to 20 - mv = minv(alg) - if (lv .lt. mv) go to 30 - call vdflt(alg, lv, v) - iv(1) = 12 - iv(algsav) = alg - iv(ivneed) = 0 - iv(lastiv) = miv - iv(lastv) = mv - iv(lmat) = mv + 1 - iv(mxfcal) = 200 - iv(mxiter) = 150 - iv(outlev) = 1 - iv(parprt) = 1 - iv(perm) = miv + 1 - iv(prunit) = imdcon(1) - iv(solprt) = 1 - iv(statpr) = 1 - iv(vneed) = 0 - iv(x0prt) = 1 -c - if (alg .ge. 2) go to 10 -c -c *** regression values -c - iv(covprt) = 3 - iv(covreq) = 1 - iv(dtype) = 1 - iv(hc) = 0 - iv(ierr) = 0 - iv(inits) = 0 - iv(ipivot) = 0 - iv(nvdflt) = 32 - iv(parsav) = 67 - iv(qrtyp) = 1 - iv(rdreq) = 3 - iv(rmat) = 0 - iv(vsave) = 58 - go to 999 -c -c *** general optimization values -c - 10 iv(dtype) = 0 - iv(inith) = 1 - iv(nfcov) = 0 - iv(ngcov) = 0 - iv(nvdflt) = 25 - iv(parsav) = 47 - go to 999 -c - 20 iv(1) = 15 - go to 999 -c - 30 iv(1) = 16 - go to 999 -c - 40 iv(1) = 67 -c - 999 return -c *** last card of deflt follows *** - end - double precision function dotprd(p, x, y) -c -c *** return the inner product of the p-vectors x and y. *** -c - integer p - double precision x(p), y(p) -c - integer i - double precision one, sqteta, t, zero -c/+ - double precision dmax1, dabs -c/ - external rmdcon - double precision rmdcon -c -c *** rmdcon(2) returns a machine-dependent constant, sqteta, which -c *** is slightly larger than the smallest positive number that -c *** can be squared without underflowing. -c -c/6 -c data one/1.d+0/, sqteta/0.d+0/, zero/0.d+0/ -c/7 - parameter (one=1.d+0, zero=0.d+0) - data sqteta/0.d+0/ -c/ -c - dotprd = zero - if (p .le. 0) go to 999 -crc if (sqteta .eq. zero) sqteta = rmdcon(2) - do 20 i = 1, p -crc t = dmax1(dabs(x(i)), dabs(y(i))) -crc if (t .gt. one) go to 10 -crc if (t .lt. sqteta) go to 20 -crc t = (x(i)/sqteta)*y(i) -crc if (dabs(t) .lt. sqteta) go to 20 - 10 dotprd = dotprd + x(i)*y(i) - 20 continue -c - 999 return -c *** last card of dotprd follows *** - end - subroutine itsum(d, g, iv, liv, lv, p, v, x) -c -c *** print iteration summary for ***sol (version 2.3) *** -c -c *** parameter declarations *** -c - integer liv, lv, p - integer iv(liv) - double precision d(p), g(p), v(lv), x(p) -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** local variables *** -c - integer alg, i, iv1, m, nf, ng, ol, pu -c/6 -c real model1(6), model2(6) -c/7 - character*4 model1(6), model2(6) -c/ - double precision nreldf, oldf, preldf, reldf, zero -c -c *** intrinsic functions *** -c/+ - integer iabs - double precision dabs, dmax1 -c/ -c *** no external functions or subroutines *** -c -c *** subscripts for iv and v *** -c - integer algsav, dstnrm, f, fdif, f0, needhd, nfcall, nfcov, ngcov, - 1 ngcall, niter, nreduc, outlev, preduc, prntit, prunit, - 2 reldx, solprt, statpr, stppar, sused, x0prt -c -c *** iv subscript values *** -c -c/6 -c data algsav/51/, needhd/36/, nfcall/6/, nfcov/52/, ngcall/30/, -c 1 ngcov/53/, niter/31/, outlev/19/, prntit/39/, prunit/21/, -c 2 solprt/22/, statpr/23/, sused/64/, x0prt/24/ -c/7 - parameter (algsav=51, needhd=36, nfcall=6, nfcov=52, ngcall=30, - 1 ngcov=53, niter=31, outlev=19, prntit=39, prunit=21, - 2 solprt=22, statpr=23, sused=64, x0prt=24) -c/ -c -c *** v subscript values *** -c -c/6 -c data dstnrm/2/, f/10/, f0/13/, fdif/11/, nreduc/6/, preduc/7/, -c 1 reldx/17/, stppar/5/ -c/7 - parameter (dstnrm=2, f=10, f0=13, fdif=11, nreduc=6, preduc=7, - 1 reldx=17, stppar=5) -c/ -c -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c/6 -c data model1(1)/4h /, model1(2)/4h /, model1(3)/4h /, -c 1 model1(4)/4h /, model1(5)/4h g /, model1(6)/4h s /, -c 2 model2(1)/4h g /, model2(2)/4h s /, model2(3)/4hg-s /, -c 3 model2(4)/4hs-g /, model2(5)/4h-s-g/, model2(6)/4h-g-s/ -c/7 - data model1/' ',' ',' ',' ',' g ',' s '/, - 1 model2/' g ',' s ','g-s ','s-g ','-s-g','-g-s'/ -c/ -c -c------------------------------- body -------------------------------- -c - pu = iv(prunit) - if (pu .eq. 0) go to 999 - iv1 = iv(1) - if (iv1 .gt. 62) iv1 = iv1 - 51 - ol = iv(outlev) - alg = iv(algsav) - if (iv1 .lt. 2 .or. iv1 .gt. 15) go to 370 - if (iv1 .ge. 12) go to 120 - if (iv1 .eq. 2 .and. iv(niter) .eq. 0) go to 390 - if (ol .eq. 0) go to 120 - if (iv1 .ge. 10 .and. iv(prntit) .eq. 0) go to 120 - if (iv1 .gt. 2) go to 10 - iv(prntit) = iv(prntit) + 1 - if (iv(prntit) .lt. iabs(ol)) go to 999 - 10 nf = iv(nfcall) - iabs(iv(nfcov)) - iv(prntit) = 0 - reldf = zero - preldf = zero - oldf = dmax1(dabs(v(f0)), dabs(v(f))) - if (oldf .le. zero) go to 20 - reldf = v(fdif) / oldf - preldf = v(preduc) / oldf - 20 if (ol .gt. 0) go to 60 -c -c *** print short summary line *** -c - if (iv(needhd) .eq. 1 .and. alg .eq. 1) write(pu,30) - 30 format(/10h it nf,6x,1hf,7x,5hreldf,3x,6hpreldf,3x,5hreldx, - 1 2x,13hmodel stppar) - if (iv(needhd) .eq. 1 .and. alg .eq. 2) write(pu,40) - 40 format(/11h it nf,7x,1hf,8x,5hreldf,4x,6hpreldf,4x,5hreldx, - 1 3x,6hstppar) - iv(needhd) = 0 - if (alg .eq. 2) go to 50 - m = iv(sused) - write(pu,100) iv(niter), nf, v(f), reldf, preldf, v(reldx), - 1 model1(m), model2(m), v(stppar) - go to 120 -c - 50 write(pu,110) iv(niter), nf, v(f), reldf, preldf, v(reldx), - 1 v(stppar) - go to 120 -c -c *** print long summary line *** -c - 60 if (iv(needhd) .eq. 1 .and. alg .eq. 1) write(pu,70) - 70 format(/11h it nf,6x,1hf,7x,5hreldf,3x,6hpreldf,3x,5hreldx, - 1 2x,13hmodel stppar,2x,6hd*step,2x,7hnpreldf) - if (iv(needhd) .eq. 1 .and. alg .eq. 2) write(pu,80) - 80 format(/11h it nf,7x,1hf,8x,5hreldf,4x,6hpreldf,4x,5hreldx, - 1 3x,6hstppar,3x,6hd*step,3x,7hnpreldf) - iv(needhd) = 0 - nreldf = zero - if (oldf .gt. zero) nreldf = v(nreduc) / oldf - if (alg .eq. 2) go to 90 - m = iv(sused) - write(pu,100) iv(niter), nf, v(f), reldf, preldf, v(reldx), - 1 model1(m), model2(m), v(stppar), v(dstnrm), nreldf - go to 120 -c - 90 write(pu,110) iv(niter), nf, v(f), reldf, preldf, - 1 v(reldx), v(stppar), v(dstnrm), nreldf - 100 format(i6,i5,d10.3,2d9.2,d8.1,a3,a4,2d8.1,d9.2) - 110 format(i6,i5,d11.3,2d10.2,3d9.1,d10.2) -c - 120 if (iv(statpr) .lt. 0) go to 430 - go to (999, 999, 130, 150, 170, 190, 210, 230, 250, 270, 290, 310, - 1 330, 350, 520), iv1 -c - 130 write(pu,140) - 140 format(/26h ***** x-convergence *****) - go to 430 -c - 150 write(pu,160) - 160 format(/42h ***** relative function convergence *****) - go to 430 -c - 170 write(pu,180) - 180 format(/49h ***** x- and relative function convergence *****) - go to 430 -c - 190 write(pu,200) - 200 format(/42h ***** absolute function convergence *****) - go to 430 -c - 210 write(pu,220) - 220 format(/33h ***** singular convergence *****) - go to 430 -c - 230 write(pu,240) - 240 format(/30h ***** false convergence *****) - go to 430 -c - 250 write(pu,260) - 260 format(/38h ***** function evaluation limit *****) - go to 430 -c - 270 write(pu,280) - 280 format(/28h ***** iteration limit *****) - go to 430 -c - 290 write(pu,300) - 300 format(/18h ***** stopx *****) - go to 430 -c - 310 write(pu,320) - 320 format(/44h ***** initial f(x) cannot be computed *****) -c - go to 390 -c - 330 write(pu,340) - 340 format(/37h ***** bad parameters to assess *****) - go to 999 -c - 350 write(pu,360) - 360 format(/43h ***** gradient could not be computed *****) - if (iv(niter) .gt. 0) go to 480 - go to 390 -c - 370 write(pu,380) iv(1) - 380 format(/14h ***** iv(1) =,i5,6h *****) - go to 999 -c -c *** initial call on itsum *** -c - 390 if (iv(x0prt) .ne. 0) write(pu,400) (i, x(i), d(i), i = 1, p) - 400 format(/23h i initial x(i),8x,4hd(i)//(1x,i5,d17.6,d14.3)) -c *** the following are to avoid undefined variables when the -c *** function evaluation limit is 1... - v(dstnrm) = zero - v(fdif) = zero - v(nreduc) = zero - v(preduc) = zero - v(reldx) = zero - if (iv1 .ge. 12) go to 999 - iv(needhd) = 0 - iv(prntit) = 0 - if (ol .eq. 0) go to 999 - if (ol .lt. 0 .and. alg .eq. 1) write(pu,30) - if (ol .lt. 0 .and. alg .eq. 2) write(pu,40) - if (ol .gt. 0 .and. alg .eq. 1) write(pu,70) - if (ol .gt. 0 .and. alg .eq. 2) write(pu,80) - if (alg .eq. 1) write(pu,410) v(f) - if (alg .eq. 2) write(pu,420) v(f) - 410 format(/11h 0 1,d10.3) -c365 format(/11h 0 1,e11.3) - 420 format(/11h 0 1,d11.3) - go to 999 -c -c *** print various information requested on solution *** -c - 430 iv(needhd) = 1 - if (iv(statpr) .eq. 0) go to 480 - oldf = dmax1(dabs(v(f0)), dabs(v(f))) - preldf = zero - nreldf = zero - if (oldf .le. zero) go to 440 - preldf = v(preduc) / oldf - nreldf = v(nreduc) / oldf - 440 nf = iv(nfcall) - iv(nfcov) - ng = iv(ngcall) - iv(ngcov) - write(pu,450) v(f), v(reldx), nf, ng, preldf, nreldf - 450 format(/9h function,d17.6,8h reldx,d17.3/12h func. evals, - 1 i8,9x,11hgrad. evals,i8/7h preldf,d16.3,6x,7hnpreldf,d15.3) -c - if (iv(nfcov) .gt. 0) write(pu,460) iv(nfcov) - 460 format(/1x,i4,50h extra func. evals for covariance and diagnost - 1ics.) - if (iv(ngcov) .gt. 0) write(pu,470) iv(ngcov) - 470 format(1x,i4,50h extra grad. evals for covariance and diagnosti - 1cs.) -c - 480 if (iv(solprt) .eq. 0) go to 999 - iv(needhd) = 1 - write(pu,490) - 490 format(/22h i final x(i),8x,4hd(i),10x,4hg(i)/) - do 500 i = 1, p - write(pu,510) i, x(i), d(i), g(i) - 500 continue - 510 format(1x,i5,d16.6,2d14.3) - go to 999 -c - 520 write(pu,530) - 530 format(/24h inconsistent dimensions) - 999 return -c *** last card of itsum follows *** - end - subroutine litvmu(n, x, l, y) -c -c *** solve (l**t)*x = y, where l is an n x n lower triangular -c *** matrix stored compactly by rows. x and y may occupy the same -c *** storage. *** -c - integer n -cal double precision x(n), l(1), y(n) - double precision x(n), l(n*(n+1)/2), y(n) - integer i, ii, ij, im1, i0, j, np1 - double precision xi, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - do 10 i = 1, n - 10 x(i) = y(i) - np1 = n + 1 - i0 = n*(n+1)/2 - do 30 ii = 1, n - i = np1 - ii - xi = x(i)/l(i0) - x(i) = xi - if (i .le. 1) go to 999 - i0 = i0 - i - if (xi .eq. zero) go to 30 - im1 = i - 1 - do 20 j = 1, im1 - ij = i0 + j - x(j) = x(j) - xi*l(ij) - 20 continue - 30 continue - 999 return -c *** last card of litvmu follows *** - end - subroutine livmul(n, x, l, y) -c -c *** solve l*x = y, where l is an n x n lower triangular -c *** matrix stored compactly by rows. x and y may occupy the same -c *** storage. *** -c - integer n -cal double precision x(n), l(1), y(n) - double precision x(n), l(n*(n+1)/2), y(n) - external dotprd - double precision dotprd - integer i, j, k - double precision t, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - do 10 k = 1, n - if (y(k) .ne. zero) go to 20 - x(k) = zero - 10 continue - go to 999 - 20 j = k*(k+1)/2 - x(k) = y(k) / l(j) - if (k .ge. n) go to 999 - k = k + 1 - do 30 i = k, n - t = dotprd(i-1, l(j+1), x) - j = j + i - x(i) = (y(i) - t)/l(j) - 30 continue - 999 return -c *** last card of livmul follows *** - end - subroutine parck(alg, d, iv, liv, lv, n, v) -c -c *** check ***sol (version 2.3) parameters, print changed values *** -c -c *** alg = 1 for regression, alg = 2 for general unconstrained opt. -c - integer alg, liv, lv, n - integer iv(liv) - double precision d(n), v(lv) -c - external rmdcon, vcopy, vdflt - double precision rmdcon -c rmdcon -- returns machine-dependent constants. -c vcopy -- copies one vector to another. -c vdflt -- supplies default parameter values to v alone. -c/+ - integer max0 -c/ -c -c *** local variables *** -c - integer i, ii, iv1, j, k, l, m, miv1, miv2, ndfalt, parsv1, pu - integer ijmp, jlim(2), miniv(2), ndflt(2) -c/6 -c integer varnm(2), sh(2) -c real cngd(3), dflt(3), vn(2,34), which(3) -c/7 - character*1 varnm(2), sh(2) - character*4 cngd(3), dflt(3), vn(2,34), which(3) -c/ - double precision big, machep, tiny, vk, vm(34), vx(34), zero -c -c *** iv and v subscripts *** -c - integer algsav, dinit, dtype, dtype0, epslon, inits, ivneed, - 1 lastiv, lastv, lmat, nextiv, nextv, nvdflt, oldn, - 2 parprt, parsav, perm, prunit, vneed -c -c -c/6 -c data algsav/51/, dinit/38/, dtype/16/, dtype0/54/, epslon/19/, -c 1 inits/25/, ivneed/3/, lastiv/44/, lastv/45/, lmat/42/, -c 2 nextiv/46/, nextv/47/, nvdflt/50/, oldn/38/, parprt/20/, -c 3 parsav/49/, perm/58/, prunit/21/, vneed/4/ -c/7 - parameter (algsav=51, dinit=38, dtype=16, dtype0=54, epslon=19, - 1 inits=25, ivneed=3, lastiv=44, lastv=45, lmat=42, - 2 nextiv=46, nextv=47, nvdflt=50, oldn=38, parprt=20, - 3 parsav=49, perm=58, prunit=21, vneed=4) - save big, machep, tiny -c/ -c - data big/0.d+0/, machep/-1.d+0/, tiny/1.d+0/, zero/0.d+0/ -c/6 -c data vn(1,1),vn(2,1)/4hepsl,4hon../ -c data vn(1,2),vn(2,2)/4hphmn,4hfc../ -c data vn(1,3),vn(2,3)/4hphmx,4hfc../ -c data vn(1,4),vn(2,4)/4hdecf,4hac../ -c data vn(1,5),vn(2,5)/4hincf,4hac../ -c data vn(1,6),vn(2,6)/4hrdfc,4hmn../ -c data vn(1,7),vn(2,7)/4hrdfc,4hmx../ -c data vn(1,8),vn(2,8)/4htune,4hr1../ -c data vn(1,9),vn(2,9)/4htune,4hr2../ -c data vn(1,10),vn(2,10)/4htune,4hr3../ -c data vn(1,11),vn(2,11)/4htune,4hr4../ -c data vn(1,12),vn(2,12)/4htune,4hr5../ -c data vn(1,13),vn(2,13)/4hafct,4hol../ -c data vn(1,14),vn(2,14)/4hrfct,4hol../ -c data vn(1,15),vn(2,15)/4hxcto,4hl.../ -c data vn(1,16),vn(2,16)/4hxfto,4hl.../ -c data vn(1,17),vn(2,17)/4hlmax,4h0.../ -c data vn(1,18),vn(2,18)/4hlmax,4hs.../ -c data vn(1,19),vn(2,19)/4hscto,4hl.../ -c data vn(1,20),vn(2,20)/4hdini,4ht.../ -c data vn(1,21),vn(2,21)/4hdtin,4hit../ -c data vn(1,22),vn(2,22)/4hd0in,4hit../ -c data vn(1,23),vn(2,23)/4hdfac,4h..../ -c data vn(1,24),vn(2,24)/4hdltf,4hdc../ -c data vn(1,25),vn(2,25)/4hdltf,4hdj../ -c data vn(1,26),vn(2,26)/4hdelt,4ha0../ -c data vn(1,27),vn(2,27)/4hfuzz,4h..../ -c data vn(1,28),vn(2,28)/4hrlim,4hit../ -c data vn(1,29),vn(2,29)/4hcosm,4hin../ -c data vn(1,30),vn(2,30)/4hhube,4hrc../ -c data vn(1,31),vn(2,31)/4hrspt,4hol../ -c data vn(1,32),vn(2,32)/4hsigm,4hin../ -c data vn(1,33),vn(2,33)/4heta0,4h..../ -c data vn(1,34),vn(2,34)/4hbias,4h..../ -c/7 - data vn(1,1),vn(2,1)/'epsl','on..'/ - data vn(1,2),vn(2,2)/'phmn','fc..'/ - data vn(1,3),vn(2,3)/'phmx','fc..'/ - data vn(1,4),vn(2,4)/'decf','ac..'/ - data vn(1,5),vn(2,5)/'incf','ac..'/ - data vn(1,6),vn(2,6)/'rdfc','mn..'/ - data vn(1,7),vn(2,7)/'rdfc','mx..'/ - data vn(1,8),vn(2,8)/'tune','r1..'/ - data vn(1,9),vn(2,9)/'tune','r2..'/ - data vn(1,10),vn(2,10)/'tune','r3..'/ - data vn(1,11),vn(2,11)/'tune','r4..'/ - data vn(1,12),vn(2,12)/'tune','r5..'/ - data vn(1,13),vn(2,13)/'afct','ol..'/ - data vn(1,14),vn(2,14)/'rfct','ol..'/ - data vn(1,15),vn(2,15)/'xcto','l...'/ - data vn(1,16),vn(2,16)/'xfto','l...'/ - data vn(1,17),vn(2,17)/'lmax','0...'/ - data vn(1,18),vn(2,18)/'lmax','s...'/ - data vn(1,19),vn(2,19)/'scto','l...'/ - data vn(1,20),vn(2,20)/'dini','t...'/ - data vn(1,21),vn(2,21)/'dtin','it..'/ - data vn(1,22),vn(2,22)/'d0in','it..'/ - data vn(1,23),vn(2,23)/'dfac','....'/ - data vn(1,24),vn(2,24)/'dltf','dc..'/ - data vn(1,25),vn(2,25)/'dltf','dj..'/ - data vn(1,26),vn(2,26)/'delt','a0..'/ - data vn(1,27),vn(2,27)/'fuzz','....'/ - data vn(1,28),vn(2,28)/'rlim','it..'/ - data vn(1,29),vn(2,29)/'cosm','in..'/ - data vn(1,30),vn(2,30)/'hube','rc..'/ - data vn(1,31),vn(2,31)/'rspt','ol..'/ - data vn(1,32),vn(2,32)/'sigm','in..'/ - data vn(1,33),vn(2,33)/'eta0','....'/ - data vn(1,34),vn(2,34)/'bias','....'/ -c/ -c - data vm(1)/1.0d-3/, vm(2)/-0.99d+0/, vm(3)/1.0d-3/, vm(4)/1.0d-2/, - 1 vm(5)/1.2d+0/, vm(6)/1.d-2/, vm(7)/1.2d+0/, vm(8)/0.d+0/, - 2 vm(9)/0.d+0/, vm(10)/1.d-3/, vm(11)/-1.d+0/, vm(13)/0.d+0/, - 3 vm(15)/0.d+0/, vm(16)/0.d+0/, vm(19)/0.d+0/, vm(20)/-10.d+0/, - 4 vm(21)/0.d+0/, vm(22)/0.d+0/, vm(23)/0.d+0/, vm(27)/1.01d+0/, - 5 vm(28)/1.d+10/, vm(30)/0.d+0/, vm(31)/0.d+0/, vm(32)/0.d+0/, - 6 vm(34)/0.d+0/ - data vx(1)/0.9d+0/, vx(2)/-1.d-3/, vx(3)/1.d+1/, vx(4)/0.8d+0/, - 1 vx(5)/1.d+2/, vx(6)/0.8d+0/, vx(7)/1.d+2/, vx(8)/0.5d+0/, - 2 vx(9)/0.5d+0/, vx(10)/1.d+0/, vx(11)/1.d+0/, vx(14)/0.1d+0/, - 3 vx(15)/1.d+0/, vx(16)/1.d+0/, vx(19)/1.d+0/, vx(23)/1.d+0/, - 4 vx(24)/1.d+0/, vx(25)/1.d+0/, vx(26)/1.d+0/, vx(27)/1.d+10/, - 5 vx(29)/1.d+0/, vx(31)/1.d+0/, vx(32)/1.d+0/, vx(33)/1.d+0/, - 6 vx(34)/1.d+0/ -c -c/6 -c data varnm(1)/1hp/, varnm(2)/1hn/, sh(1)/1hs/, sh(2)/1hh/ -c data cngd(1),cngd(2),cngd(3)/4h---c,4hhang,4hed v/, -c 1 dflt(1),dflt(2),dflt(3)/4hnond,4hefau,4hlt v/ -c/7 - data varnm(1)/'p'/, varnm(2)/'n'/, sh(1)/'s'/, sh(2)/'h'/ - data cngd(1),cngd(2),cngd(3)/'---c','hang','ed v'/, - 1 dflt(1),dflt(2),dflt(3)/'nond','efau','lt v'/ -c/ - data ijmp/33/, jlim(1)/0/, jlim(2)/24/, ndflt(1)/32/, ndflt(2)/25/ - data miniv(1)/80/, miniv(2)/59/ -c -c............................... body ................................ -c - pu = 0 - if (prunit .le. liv) pu = iv(prunit) - if (alg .lt. 1 .or. alg .gt. 2) go to 340 - if (iv(1) .eq. 0) call deflt(alg, iv, liv, lv, v) - iv1 = iv(1) - if (iv1 .ne. 13 .and. iv1 .ne. 12) go to 10 - miv1 = miniv(alg) - if (perm .le. liv) miv1 = max0(miv1, iv(perm) - 1) - if (ivneed .le. liv) miv2 = miv1 + max0(iv(ivneed), 0) - if (lastiv .le. liv) iv(lastiv) = miv2 - if (liv .lt. miv1) go to 300 - iv(ivneed) = 0 - iv(lastv) = max0(iv(vneed), 0) + iv(lmat) - 1 - iv(vneed) = 0 - if (liv .lt. miv2) go to 300 - if (lv .lt. iv(lastv)) go to 320 - 10 if (alg .eq. iv(algsav)) go to 30 - if (pu .ne. 0) write(pu,20) alg, iv(algsav) - 20 format(/39h the first parameter to deflt should be,i3, - 1 12h rather than,i3) - iv(1) = 82 - go to 999 - 30 if (iv1 .lt. 12 .or. iv1 .gt. 14) go to 60 - if (n .ge. 1) go to 50 - iv(1) = 81 - if (pu .eq. 0) go to 999 - write(pu,40) varnm(alg), n - 40 format(/8h /// bad,a1,2h =,i5) - go to 999 - 50 if (iv1 .ne. 14) iv(nextiv) = iv(perm) - if (iv1 .ne. 14) iv(nextv) = iv(lmat) - if (iv1 .eq. 13) go to 999 - k = iv(parsav) - epslon - call vdflt(alg, lv-k, v(k+1)) - iv(dtype0) = 2 - alg - iv(oldn) = n - which(1) = dflt(1) - which(2) = dflt(2) - which(3) = dflt(3) - go to 110 - 60 if (n .eq. iv(oldn)) go to 80 - iv(1) = 17 - if (pu .eq. 0) go to 999 - write(pu,70) varnm(alg), iv(oldn), n - 70 format(/5h /// ,1a1,14h changed from ,i5,4h to ,i5) - go to 999 -c - 80 if (iv1 .le. 11 .and. iv1 .ge. 1) go to 100 - iv(1) = 80 - if (pu .ne. 0) write(pu,90) iv1 - 90 format(/13h /// iv(1) =,i5,28h should be between 0 and 14.) - go to 999 -c - 100 which(1) = cngd(1) - which(2) = cngd(2) - which(3) = cngd(3) -c - 110 if (iv1 .eq. 14) iv1 = 12 - if (big .gt. tiny) go to 120 - tiny = rmdcon(1) - machep = rmdcon(3) - big = rmdcon(6) - vm(12) = machep - vx(12) = big - vx(13) = big - vm(14) = machep - vm(17) = tiny - vx(17) = big - vm(18) = tiny - vx(18) = big - vx(20) = big - vx(21) = big - vx(22) = big - vm(24) = machep - vm(25) = machep - vm(26) = machep - vx(28) = rmdcon(5) - vm(29) = machep - vx(30) = big - vm(33) = machep - 120 m = 0 - i = 1 - j = jlim(alg) - k = epslon - ndfalt = ndflt(alg) - do 150 l = 1, ndfalt - vk = v(k) - if (vk .ge. vm(i) .and. vk .le. vx(i)) go to 140 - m = k - if (pu .ne. 0) write(pu,130) vn(1,i), vn(2,i), k, vk, - 1 vm(i), vx(i) - 130 format(/6h /// ,2a4,5h.. v(,i2,3h) =,d11.3,7h should, - 1 11h be between,d11.3,4h and,d11.3) - 140 k = k + 1 - i = i + 1 - if (i .eq. j) i = ijmp - 150 continue -c - if (iv(nvdflt) .eq. ndfalt) go to 170 - iv(1) = 51 - if (pu .eq. 0) go to 999 - write(pu,160) iv(nvdflt), ndfalt - 160 format(/13h iv(nvdflt) =,i5,13h rather than ,i5) - go to 999 - 170 if ((iv(dtype) .gt. 0 .or. v(dinit) .gt. zero) .and. iv1 .eq. 12) - 1 go to 200 - do 190 i = 1, n - if (d(i) .gt. zero) go to 190 - m = 18 - if (pu .ne. 0) write(pu,180) i, d(i) - 180 format(/8h /// d(,i3,3h) =,d11.3,19h should be positive) - 190 continue - 200 if (m .eq. 0) go to 210 - iv(1) = m - go to 999 -c - 210 if (pu .eq. 0 .or. iv(parprt) .eq. 0) go to 999 - if (iv1 .ne. 12 .or. iv(inits) .eq. alg-1) go to 230 - m = 1 - write(pu,220) sh(alg), iv(inits) - 220 format(/22h nondefault values..../5h init,a1,14h..... iv(25) =, - 1 i3) - 230 if (iv(dtype) .eq. iv(dtype0)) go to 250 - if (m .eq. 0) write(pu,260) which - m = 1 - write(pu,240) iv(dtype) - 240 format(20h dtype..... iv(16) =,i3) - 250 i = 1 - j = jlim(alg) - k = epslon - l = iv(parsav) - ndfalt = ndflt(alg) - do 290 ii = 1, ndfalt - if (v(k) .eq. v(l)) go to 280 - if (m .eq. 0) write(pu,260) which - 260 format(/1h ,3a4,9halues..../) - m = 1 - write(pu,270) vn(1,i), vn(2,i), k, v(k) - 270 format(1x,2a4,5h.. v(,i2,3h) =,d15.7) - 280 k = k + 1 - l = l + 1 - i = i + 1 - if (i .eq. j) i = ijmp - 290 continue -c - iv(dtype0) = iv(dtype) - parsv1 = iv(parsav) - call vcopy(iv(nvdflt), v(parsv1), v(epslon)) - go to 999 -c - 300 iv(1) = 15 - if (pu .eq. 0) go to 999 - write(pu,310) liv, miv2 - 310 format(/10h /// liv =,i5,17h must be at least,i5) - if (liv .lt. miv1) go to 999 - if (lv .lt. iv(lastv)) go to 320 - go to 999 -c - 320 iv(1) = 16 - if (pu .eq. 0) go to 999 - write(pu,330) lv, iv(lastv) - 330 format(/9h /// lv =,i5,17h must be at least,i5) - go to 999 -c - 340 iv(1) = 67 - if (pu .eq. 0) go to 999 - write(pu,350) alg - 350 format(/10h /// alg =,i5,15h must be 1 or 2) -c - 999 return -c *** last card of parck follows *** - end - double precision function reldst(p, d, x, x0) -c -c *** compute and return relative difference between x and x0 *** -c *** nl2sol version 2.2 *** -c - integer p - double precision d(p), x(p), x0(p) -c/+ - double precision dabs -c/ - integer i - double precision emax, t, xmax, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - emax = zero - xmax = zero - do 10 i = 1, p - t = dabs(d(i) * (x(i) - x0(i))) - if (emax .lt. t) emax = t - t = d(i) * (dabs(x(i)) + dabs(x0(i))) - if (xmax .lt. t) xmax = t - 10 continue - reldst = zero - if (xmax .gt. zero) reldst = emax / xmax - 999 return -c *** last card of reldst follows *** - end -c logical function stopx(idummy) -c *****parameters... -c integer idummy -c -c .................................................................. -c -c *****purpose... -c this function may serve as the stopx (asynchronous interruption) -c function for the nl2sol (nonlinear least-squares) package at -c those installations which do not wish to implement a -c dynamic stopx. -c -c *****algorithm notes... -c at installations where the nl2sol system is used -c interactively, this dummy stopx should be replaced by a -c function that returns .true. if and only if the interrupt -c (break) key has been pressed since the last call on stopx. -c -c .................................................................. -c -c stopx = .false. -c return -c end - subroutine vaxpy(p, w, a, x, y) -c -c *** set w = a*x + y -- w, x, y = p-vectors, a = scalar *** -c - integer p - double precision a, w(p), x(p), y(p) -c - integer i -c - do 10 i = 1, p - 10 w(i) = a*x(i) + y(i) - return - end - subroutine vcopy(p, y, x) -c -c *** set y = x, where x and y are p-vectors *** -c - integer p - double precision x(p), y(p) -c - integer i -c - do 10 i = 1, p - 10 y(i) = x(i) - return - end - subroutine vdflt(alg, lv, v) -c -c *** supply ***sol (version 2.3) default values to v *** -c -c *** alg = 1 means regression constants. -c *** alg = 2 means general unconstrained optimization constants. -c - integer alg, l - double precision v(lv) -c/+ - double precision dmax1 -c/ - external rmdcon - double precision rmdcon -c rmdcon... returns machine-dependent constants -c - double precision machep, mepcrt, one, sqteps, three -c -c *** subscripts for v *** -c - integer afctol, bias, cosmin, decfac, delta0, dfac, dinit, dltfdc, - 1 dltfdj, dtinit, d0init, epslon, eta0, fuzz, huberc, - 2 incfac, lmax0, lmaxs, phmnfc, phmxfc, rdfcmn, rdfcmx, - 3 rfctol, rlimit, rsptol, sctol, sigmin, tuner1, tuner2, - 4 tuner3, tuner4, tuner5, xctol, xftol -c -c/6 -c data one/1.d+0/, three/3.d+0/ -c/7 - parameter (one=1.d+0, three=3.d+0) -c/ -c -c *** v subscript values *** -c -c/6 -c data afctol/31/, bias/43/, cosmin/47/, decfac/22/, delta0/44/, -c 1 dfac/41/, dinit/38/, dltfdc/42/, dltfdj/43/, dtinit/39/, -c 2 d0init/40/, epslon/19/, eta0/42/, fuzz/45/, huberc/48/, -c 3 incfac/23/, lmax0/35/, lmaxs/36/, phmnfc/20/, phmxfc/21/, -c 4 rdfcmn/24/, rdfcmx/25/, rfctol/32/, rlimit/46/, rsptol/49/, -c 5 sctol/37/, sigmin/50/, tuner1/26/, tuner2/27/, tuner3/28/, -c 6 tuner4/29/, tuner5/30/, xctol/33/, xftol/34/ -c/7 - parameter (afctol=31, bias=43, cosmin=47, decfac=22, delta0=44, - 1 dfac=41, dinit=38, dltfdc=42, dltfdj=43, dtinit=39, - 2 d0init=40, epslon=19, eta0=42, fuzz=45, huberc=48, - 3 incfac=23, lmax0=35, lmaxs=36, phmnfc=20, phmxfc=21, - 4 rdfcmn=24, rdfcmx=25, rfctol=32, rlimit=46, rsptol=49, - 5 sctol=37, sigmin=50, tuner1=26, tuner2=27, tuner3=28, - 6 tuner4=29, tuner5=30, xctol=33, xftol=34) -c/ -c -c------------------------------- body -------------------------------- -c - machep = rmdcon(3) - v(afctol) = 1.d-20 - if (machep .gt. 1.d-10) v(afctol) = machep**2 - v(decfac) = 0.5d+0 - sqteps = rmdcon(4) - v(dfac) = 0.6d+0 - v(delta0) = sqteps - v(dtinit) = 1.d-6 - mepcrt = machep ** (one/three) - v(d0init) = 1.d+0 - v(epslon) = 0.1d+0 - v(incfac) = 2.d+0 - v(lmax0) = 1.d+0 - v(lmaxs) = 1.d+0 - v(phmnfc) = -0.1d+0 - v(phmxfc) = 0.1d+0 - v(rdfcmn) = 0.1d+0 - v(rdfcmx) = 4.d+0 - v(rfctol) = dmax1(1.d-10, mepcrt**2) - v(sctol) = v(rfctol) - v(tuner1) = 0.1d+0 - v(tuner2) = 1.d-4 - v(tuner3) = 0.75d+0 - v(tuner4) = 0.5d+0 - v(tuner5) = 0.75d+0 - v(xctol) = sqteps - v(xftol) = 1.d+2 * machep -c - if (alg .ge. 2) go to 10 -c -c *** regression values -c - v(cosmin) = dmax1(1.d-6, 1.d+2 * machep) - v(dinit) = 0.d+0 - v(dltfdc) = mepcrt - v(dltfdj) = sqteps - v(fuzz) = 1.5d+0 - v(huberc) = 0.7d+0 - v(rlimit) = rmdcon(5) - v(rsptol) = 1.d-3 - v(sigmin) = 1.d-4 - go to 999 -c -c *** general optimization values -c - 10 v(bias) = 0.8d+0 - v(dinit) = -1.0d+0 - v(eta0) = 1.0d+3 * machep -c - 999 return -c *** last card of vdflt follows *** - end - subroutine vscopy(p, y, s) -c -c *** set p-vector y to scalar s *** -c - integer p - double precision s, y(p) -c - integer i -c - do 10 i = 1, p - 10 y(i) = s - return - end - double precision function v2norm(p, x) -c -c *** return the 2-norm of the p-vector x, taking *** -c *** care to avoid the most likely underflows. *** -c - integer p - double precision x(p) -c - integer i, j - double precision one, r, scale, sqteta, t, xi, zero -c/+ - double precision dabs, dsqrt -c/ - external rmdcon - double precision rmdcon -c -c/6 -c data one/1.d+0/, zero/0.d+0/ -c/7 - parameter (one=1.d+0, zero=0.d+0) - save sqteta -c/ - data sqteta/0.d+0/ -c - if (p .gt. 0) go to 10 - v2norm = zero - go to 999 - 10 do 20 i = 1, p - if (x(i) .ne. zero) go to 30 - 20 continue - v2norm = zero - go to 999 -c - 30 scale = dabs(x(i)) - if (i .lt. p) go to 40 - v2norm = scale - go to 999 - 40 t = one - if (sqteta .eq. zero) sqteta = rmdcon(2) -c -c *** sqteta is (slightly larger than) the square root of the -c *** smallest positive floating point number on the machine. -c *** the tests involving sqteta are done to prevent underflows. -c - j = i + 1 - do 60 i = j, p - xi = dabs(x(i)) - if (xi .gt. scale) go to 50 - r = xi / scale - if (r .gt. sqteta) t = t + r*r - go to 60 - 50 r = scale / xi - if (r .le. sqteta) r = zero - t = one + t * r*r - scale = xi - 60 continue -c - v2norm = scale * dsqrt(t) - 999 return -c *** last card of v2norm follows *** - end - subroutine humsl(n, d, x, calcf, calcgh, iv, liv, lv, v, - 1 uiparm, urparm, ufparm) -c -c *** minimize general unconstrained objective function using *** -c *** (analytic) gradient and hessian provided by the caller. *** -c - integer liv, lv, n - integer iv(liv), uiparm(1) - double precision d(n), x(n), v(lv), urparm(1) -c dimension v(78 + n*(n+12)), uiparm(*), urparm(*) - external calcf, calcgh, ufparm -c -c------------------------------ discussion --------------------------- -c -c this routine is like sumsl, except that the subroutine para- -c meter calcg of sumsl (which computes the gradient of the objec- -c tive function) is replaced by the subroutine parameter calcgh, -c which computes both the gradient and (lower triangle of the) -c hessian of the objective function. the calling sequence is... -c call calcgh(n, x, nf, g, h, uiparm, urparm, ufparm) -c parameters n, x, nf, g, uiparm, urparm, and ufparm are the same -c as for sumsl, while h is an array of length n*(n+1)/2 in which -c calcgh must store the lower triangle of the hessian at x. start- -c ing at h(1), calcgh must store the hessian entries in the order -c (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ... -c the value printed (by itsum) in the column labelled stppar -c is the levenberg-marquardt used in computing the current step. -c zero means a full newton step. if the special case described in -c ref. 1 is detected, then stppar is negated. the value printed -c in the column labelled npreldf is zero if the current hessian -c is not positive definite. -c it sometimes proves worthwhile to let d be determined from the -c diagonal of the hessian matrix by setting iv(dtype) = 1 and -c v(dinit) = 0. the following iv and v components are relevant... -c -c iv(dtol)..... iv(59) gives the starting subscript in v of the dtol -c array used when d is updated. (iv(dtol) can be -c initialized by calling humsl with iv(1) = 13.) -c iv(dtype).... iv(16) tells how the scale vector d should be chosen. -c iv(dtype) .le. 0 means that d should not be updated, and -c iv(dtype) .ge. 1 means that d should be updated as -c described below with v(dfac). default = 0. -c v(dfac)..... v(41) and the dtol and d0 arrays (see v(dtinit) and -c v(d0init)) are used in updating the scale vector d when -c iv(dtype) .gt. 0. (d is initialized according to -c v(dinit), described in sumsl.) let -c d1(i) = max(sqrt(abs(h(i,i))), v(dfac)*d(i)), -c where h(i,i) is the i-th diagonal element of the current -c hessian. if iv(dtype) = 1, then d(i) is set to d1(i) -c unless d1(i) .lt. dtol(i), in which case d(i) is set to -c max(d0(i), dtol(i)). -c if iv(dtype) .ge. 2, then d is updated during the first -c iteration as for iv(dtype) = 1 (after any initialization -c due to v(dinit)) and is left unchanged thereafter. -c default = 0.6. -c v(dtinit)... v(39), if positive, is the value to which all components -c of the dtol array (see v(dfac)) are initialized. if -c v(dtinit) = 0, then it is assumed that the caller has -c stored dtol in v starting at v(iv(dtol)). -c default = 10**-6. -c v(d0init)... v(40), if positive, is the value to which all components -c of the d0 vector (see v(dfac)) are initialized. if -c v(dfac) = 0, then it is assumed that the caller has -c stored d0 in v starting at v(iv(dtol)+n). default = 1.0. -c -c *** reference *** -c -c 1. gay, d.m. (1981), computing optimal locally constrained steps, -c siam j. sci. statist. comput. 2, pp. 186-197. -c. -c *** general *** -c -c coded by david m. gay (winter 1980). revised sept. 1982. -c this subroutine was written in connection with research supported -c in part by the national science foundation under grants -c mcs-7600324 and mcs-7906671. -c -c---------------------------- declarations --------------------------- -c - external deflt, humit -c -c deflt... provides default input values for iv and v. -c humit... reverse-communication routine that does humsl algorithm. -c - integer g1, h1, iv1, lh, nf - double precision f -c -c *** subscripts for iv *** -c - integer g, h, nextv, nfcall, nfgcal, toobig, vneed -c -c/6 -c data nextv/47/, nfcall/6/, nfgcal/7/, g/28/, h/56/, toobig/2/, -c 1 vneed/4/ -c/7 - parameter (nextv=47, nfcall=6, nfgcal=7, g=28, h=56, toobig=2, - 1 vneed=4) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - lh = n * (n + 1) / 2 - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - if (iv(1) .eq. 12 .or. iv(1) .eq. 13) - 1 iv(vneed) = iv(vneed) + n*(n+3)/2 - iv1 = iv(1) - if (iv1 .eq. 14) go to 10 - if (iv1 .gt. 2 .and. iv1 .lt. 12) go to 10 - g1 = 1 - h1 = 1 - if (iv1 .eq. 12) iv(1) = 13 - go to 20 -c - 10 g1 = iv(g) - h1 = iv(h) -c - 20 call humit(d, f, v(g1), v(h1), iv, lh, liv, lv, n, v, x) - if (iv(1) - 2) 30, 40, 50 -c - 30 nf = iv(nfcall) - call calcf(n, x, nf, f, uiparm, urparm, ufparm) - if (nf .le. 0) iv(toobig) = 1 - go to 20 -c - 40 call calcgh(n, x, iv(nfgcal), v(g1), v(h1), uiparm, urparm, - 1 ufparm) - go to 20 -c - 50 if (iv(1) .ne. 14) go to 999 -c -c *** storage allocation -c - iv(g) = iv(nextv) - iv(h) = iv(g) + n - iv(nextv) = iv(h) + n*(n+1)/2 - if (iv1 .ne. 13) go to 10 -c - 999 return -c *** last card of humsl follows *** - end - subroutine humit(d, fx, g, h, iv, lh, liv, lv, n, v, x) -c -c *** carry out humsl (unconstrained minimization) iterations, using -c *** hessian matrix provided by the caller. -c -c *** parameter declarations *** -c - integer lh, liv, lv, n - integer iv(liv) - double precision d(n), fx, g(n), h(lh), v(lv), x(n) -c -c-------------------------- parameter usage -------------------------- -c -c d.... scale vector. -c fx... function value. -c g.... gradient vector. -c h.... lower triangle of the hessian, stored rowwise. -c iv... integer value array. -c lh... length of h = p*(p+1)/2. -c liv.. length of iv (at least 60). -c lv... length of v (at least 78 + n*(n+21)/2). -c n.... number of variables (components in x and g). -c v.... floating-point value array. -c x.... parameter vector. -c -c *** discussion *** -c -c parameters iv, n, v, and x are the same as the corresponding -c ones to humsl (which see), except that v can be shorter (since -c the part of v that humsl uses for storing g and h is not needed). -c moreover, compared with humsl, iv(1) may have the two additional -c output values 1 and 2, which are explained below, as is the use -c of iv(toobig) and iv(nfgcal). the value iv(g), which is an -c output value from humsl, is not referenced by humit or the -c subroutines it calls. -c -c iv(1) = 1 means the caller should set fx to f(x), the function value -c at x, and call humit again, having changed none of the -c other parameters. an exception occurs if f(x) cannot be -c computed (e.g. if overflow would occur), which may happen -c because of an oversized step. in this case the caller -c should set iv(toobig) = iv(2) to 1, which will cause -c humit to ignore fx and try a smaller step. the para- -c meter nf that humsl passes to calcf (for possible use by -c calcgh) is a copy of iv(nfcall) = iv(6). -c iv(1) = 2 means the caller should set g to g(x), the gradient of f at -c x, and h to the lower triangle of h(x), the hessian of f -c at x, and call humit again, having changed none of the -c other parameters except perhaps the scale vector d. -c the parameter nf that humsl passes to calcg is -c iv(nfgcal) = iv(7). if g(x) and h(x) cannot be evaluated, -c then the caller may set iv(nfgcal) to 0, in which case -c humit will return with iv(1) = 65. -c note -- humit overwrites h with the lower triangle -c of diag(d)**-1 * h(x) * diag(d)**-1. -c. -c *** general *** -c -c coded by david m. gay (winter 1980). revised sept. 1982. -c this subroutine was written in connection with research supported -c in part by the national science foundation under grants -c mcs-7600324 and mcs-7906671. -c -c (see sumsl and humsl for references.) -c -c+++++++++++++++++++++++++++ declarations ++++++++++++++++++++++++++++ -c -c *** local variables *** -c - integer dg1, dummy, i, j, k, l, lstgst, nn1o2, step1, - 1 temp1, w1, x01 - double precision t -c -c *** constants *** -c - double precision one, onep2, zero -c -c *** no intrinsic functions *** -c -c *** external functions and subroutines *** -c - external assst, deflt, dotprd, dupdu, gqtst, itsum, parck, - 1 reldst, slvmul, stopx, vaxpy, vcopy, vscopy, v2norm - logical stopx - double precision dotprd, reldst, v2norm -c -c assst.... assesses candidate step. -c deflt.... provides default iv and v input values. -c dotprd... returns inner product of two vectors. -c dupdu.... updates scale vector d. -c gqtst.... computes optimally locally constrained step. -c itsum.... prints iteration summary and info on initial and final x. -c parck.... checks validity of input iv and v values. -c reldst... computes v(reldx) = relative step size. -c slvmul... multiplies symmetric matrix times vector, given the lower -c triangle of the matrix. -c stopx.... returns .true. if the break key has been pressed. -c vaxpy.... computes scalar times one vector plus another. -c vcopy.... copies one vector to another. -c vscopy... sets all elements of a vector to a scalar. -c v2norm... returns the 2-norm of a vector. -c -c *** subscripts for iv and v *** -c - integer cnvcod, dg, dgnorm, dinit, dstnrm, dtinit, dtol, - 1 dtype, d0init, f, f0, fdif, gtstep, incfac, irc, kagqt, - 2 lmat, lmax0, lmaxs, mode, model, mxfcal, mxiter, nextv, - 3 nfcall, nfgcal, ngcall, niter, preduc, radfac, radinc, - 4 radius, rad0, reldx, restor, step, stglim, stlstg, stppar, - 5 toobig, tuner4, tuner5, vneed, w, xirc, x0 -c -c *** iv subscript values *** -c -c/6 -c data cnvcod/55/, dg/37/, dtol/59/, dtype/16/, irc/29/, kagqt/33/, -c 1 lmat/42/, mode/35/, model/5/, mxfcal/17/, mxiter/18/, -c 2 nextv/47/, nfcall/6/, nfgcal/7/, ngcall/30/, niter/31/, -c 3 radinc/8/, restor/9/, step/40/, stglim/11/, stlstg/41/, -c 4 toobig/2/, vneed/4/, w/34/, xirc/13/, x0/43/ -c/7 - parameter (cnvcod=55, dg=37, dtol=59, dtype=16, irc=29, kagqt=33, - 1 lmat=42, mode=35, model=5, mxfcal=17, mxiter=18, - 2 nextv=47, nfcall=6, nfgcal=7, ngcall=30, niter=31, - 3 radinc=8, restor=9, step=40, stglim=11, stlstg=41, - 4 toobig=2, vneed=4, w=34, xirc=13, x0=43) -c/ -c -c *** v subscript values *** -c -c/6 -c data dgnorm/1/, dinit/38/, dstnrm/2/, dtinit/39/, d0init/40/, -c 1 f/10/, f0/13/, fdif/11/, gtstep/4/, incfac/23/, lmax0/35/, -c 2 lmaxs/36/, preduc/7/, radfac/16/, radius/8/, rad0/9/, -c 3 reldx/17/, stppar/5/, tuner4/29/, tuner5/30/ -c/7 - parameter (dgnorm=1, dinit=38, dstnrm=2, dtinit=39, d0init=40, - 1 f=10, f0=13, fdif=11, gtstep=4, incfac=23, lmax0=35, - 2 lmaxs=36, preduc=7, radfac=16, radius=8, rad0=9, - 3 reldx=17, stppar=5, tuner4=29, tuner5=30) -c/ -c -c/6 -c data one/1.d+0/, onep2/1.2d+0/, zero/0.d+0/ -c/7 - parameter (one=1.d+0, onep2=1.2d+0, zero=0.d+0) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - i = iv(1) - if (i .eq. 1) go to 30 - if (i .eq. 2) go to 40 -c -c *** check validity of iv and v input values *** -c - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - if (iv(1) .eq. 12 .or. iv(1) .eq. 13) - 1 iv(vneed) = iv(vneed) + n*(n+21)/2 + 7 - call parck(2, d, iv, liv, lv, n, v) - i = iv(1) - 2 - if (i .gt. 12) go to 999 - nn1o2 = n * (n + 1) / 2 - if (lh .ge. nn1o2) go to (210,210,210,210,210,210,160,120,160, - 1 10,10,20), i - iv(1) = 66 - go to 350 -c -c *** storage allocation *** -c - 10 iv(dtol) = iv(lmat) + nn1o2 - iv(x0) = iv(dtol) + 2*n - iv(step) = iv(x0) + n - iv(stlstg) = iv(step) + n - iv(dg) = iv(stlstg) + n - iv(w) = iv(dg) + n - iv(nextv) = iv(w) + 4*n + 7 - if (iv(1) .ne. 13) go to 20 - iv(1) = 14 - go to 999 -c -c *** initialization *** -c - 20 iv(niter) = 0 - iv(nfcall) = 1 - iv(ngcall) = 1 - iv(nfgcal) = 1 - iv(mode) = -1 - iv(model) = 1 - iv(stglim) = 1 - iv(toobig) = 0 - iv(cnvcod) = 0 - iv(radinc) = 0 - v(rad0) = zero - v(stppar) = zero - if (v(dinit) .ge. zero) call vscopy(n, d, v(dinit)) - k = iv(dtol) - if (v(dtinit) .gt. zero) call vscopy(n, v(k), v(dtinit)) - k = k + n - if (v(d0init) .gt. zero) call vscopy(n, v(k), v(d0init)) - iv(1) = 1 - go to 999 -c - 30 v(f) = fx - if (iv(mode) .ge. 0) go to 210 - iv(1) = 2 - if (iv(toobig) .eq. 0) go to 999 - iv(1) = 63 - go to 350 -c -c *** make sure gradient could be computed *** -c - 40 if (iv(nfgcal) .ne. 0) go to 50 - iv(1) = 65 - go to 350 -c -c *** update the scale vector d *** -c - 50 dg1 = iv(dg) - if (iv(dtype) .le. 0) go to 70 - k = dg1 - j = 0 - do 60 i = 1, n - j = j + i - v(k) = h(j) - k = k + 1 - 60 continue - call dupdu(d, v(dg1), iv, liv, lv, n, v) -c -c *** compute scaled gradient and its norm *** -c - 70 dg1 = iv(dg) - k = dg1 - do 80 i = 1, n - v(k) = g(i) / d(i) - k = k + 1 - 80 continue - v(dgnorm) = v2norm(n, v(dg1)) -c -c *** compute scaled hessian *** -c - k = 1 - do 100 i = 1, n - t = one / d(i) - do 90 j = 1, i - h(k) = t * h(k) / d(j) - k = k + 1 - 90 continue - 100 continue -c - if (iv(cnvcod) .ne. 0) go to 340 - if (iv(mode) .eq. 0) go to 300 -c -c *** allow first step to have scaled 2-norm at most v(lmax0) *** -c - v(radius) = v(lmax0) -c - iv(mode) = 0 -c -c -c----------------------------- main loop ----------------------------- -c -c -c *** print iteration summary, check iteration limit *** -c - 110 call itsum(d, g, iv, liv, lv, n, v, x) - 120 k = iv(niter) - if (k .lt. iv(mxiter)) go to 130 - iv(1) = 10 - go to 350 -c - 130 iv(niter) = k + 1 -c -c *** initialize for start of next iteration *** -c - dg1 = iv(dg) - x01 = iv(x0) - v(f0) = v(f) - iv(irc) = 4 - iv(kagqt) = -1 -c -c *** copy x to x0 *** -c - call vcopy(n, v(x01), x) -c -c *** update radius *** -c - if (k .eq. 0) go to 150 - step1 = iv(step) - k = step1 - do 140 i = 1, n - v(k) = d(i) * v(k) - k = k + 1 - 140 continue - v(radius) = v(radfac) * v2norm(n, v(step1)) -c -c *** check stopx and function evaluation limit *** -c -C AL 4/30/95 - dummy=iv(nfcall) - 150 if (.not. stopx(dummy)) go to 170 - iv(1) = 11 - go to 180 -c -c *** come here when restarting after func. eval. limit or stopx. -c - 160 if (v(f) .ge. v(f0)) go to 170 - v(radfac) = one - k = iv(niter) - go to 130 -c - 170 if (iv(nfcall) .lt. iv(mxfcal)) go to 190 - iv(1) = 9 - 180 if (v(f) .ge. v(f0)) go to 350 -c -c *** in case of stopx or function evaluation limit with -c *** improved v(f), evaluate the gradient at x. -c - iv(cnvcod) = iv(1) - go to 290 -c -c. . . . . . . . . . . . . compute candidate step . . . . . . . . . . -c - 190 step1 = iv(step) - dg1 = iv(dg) - l = iv(lmat) - w1 = iv(w) - call gqtst(d, v(dg1), h, iv(kagqt), v(l), n, v(step1), v, v(w1)) - if (iv(irc) .eq. 6) go to 210 -c -c *** check whether evaluating f(x0 + step) looks worthwhile *** -c - if (v(dstnrm) .le. zero) go to 210 - if (iv(irc) .ne. 5) go to 200 - if (v(radfac) .le. one) go to 200 - if (v(preduc) .le. onep2 * v(fdif)) go to 210 -c -c *** compute f(x0 + step) *** -c - 200 x01 = iv(x0) - step1 = iv(step) - call vaxpy(n, x, one, v(step1), v(x01)) - iv(nfcall) = iv(nfcall) + 1 - iv(1) = 1 - iv(toobig) = 0 - go to 999 -c -c. . . . . . . . . . . . . assess candidate step . . . . . . . . . . . -c - 210 x01 = iv(x0) - v(reldx) = reldst(n, d, x, v(x01)) - call assst(iv, liv, lv, v) - step1 = iv(step) - lstgst = iv(stlstg) - if (iv(restor) .eq. 1) call vcopy(n, x, v(x01)) - if (iv(restor) .eq. 2) call vcopy(n, v(lstgst), v(step1)) - if (iv(restor) .ne. 3) go to 220 - call vcopy(n, v(step1), v(lstgst)) - call vaxpy(n, x, one, v(step1), v(x01)) - v(reldx) = reldst(n, d, x, v(x01)) -c - 220 k = iv(irc) - go to (230,260,260,260,230,240,250,250,250,250,250,250,330,300), k -c -c *** recompute step with new radius *** -c - 230 v(radius) = v(radfac) * v(dstnrm) - go to 150 -c -c *** compute step of length v(lmaxs) for singular convergence test. -c - 240 v(radius) = v(lmaxs) - go to 190 -c -c *** convergence or false convergence *** -c - 250 iv(cnvcod) = k - 4 - if (v(f) .ge. v(f0)) go to 340 - if (iv(xirc) .eq. 14) go to 340 - iv(xirc) = 14 -c -c. . . . . . . . . . . . process acceptable step . . . . . . . . . . . -c - 260 if (iv(irc) .ne. 3) go to 290 - temp1 = lstgst -c -c *** prepare for gradient tests *** -c *** set temp1 = hessian * step + g(x0) -c *** = diag(d) * (h * step + g(x0)) -c -c use x0 vector as temporary. - k = x01 - do 270 i = 1, n - v(k) = d(i) * v(step1) - k = k + 1 - step1 = step1 + 1 - 270 continue - call slvmul(n, v(temp1), h, v(x01)) - do 280 i = 1, n - v(temp1) = d(i) * v(temp1) + g(i) - temp1 = temp1 + 1 - 280 continue -c -c *** compute gradient and hessian *** -c - 290 iv(ngcall) = iv(ngcall) + 1 - iv(1) = 2 - go to 999 -c - 300 iv(1) = 2 - if (iv(irc) .ne. 3) go to 110 -c -c *** set v(radfac) by gradient tests *** -c - temp1 = iv(stlstg) - step1 = iv(step) -c -c *** set temp1 = diag(d)**-1 * (hessian*step + (g(x0)-g(x))) *** -c - k = temp1 - do 310 i = 1, n - v(k) = (v(k) - g(i)) / d(i) - k = k + 1 - 310 continue -c -c *** do gradient tests *** -c - if (v2norm(n, v(temp1)) .le. v(dgnorm) * v(tuner4)) go to 320 - if (dotprd(n, g, v(step1)) - 1 .ge. v(gtstep) * v(tuner5)) go to 110 - 320 v(radfac) = v(incfac) - go to 110 -c -c. . . . . . . . . . . . . . misc. details . . . . . . . . . . . . . . -c -c *** bad parameters to assess *** -c - 330 iv(1) = 64 - go to 350 -c -c *** print summary of final iteration and other requested items *** -c - 340 iv(1) = iv(cnvcod) - iv(cnvcod) = 0 - 350 call itsum(d, g, iv, liv, lv, n, v, x) -c - 999 return -c -c *** last card of humit follows *** - end - subroutine dupdu(d, hdiag, iv, liv, lv, n, v) -c -c *** update scale vector d for humsl *** -c -c *** parameter declarations *** -c - integer liv, lv, n - integer iv(liv) - double precision d(n), hdiag(n), v(lv) -c -c *** local variables *** -c - integer dtoli, d0i, i - double precision t, vdfac -c -c *** intrinsic functions *** -c/+ - double precision dabs, dmax1, dsqrt -c/ -c *** subscripts for iv and v *** -c - integer dfac, dtol, dtype, niter -c/6 -c data dfac/41/, dtol/59/, dtype/16/, niter/31/ -c/7 - parameter (dfac=41, dtol=59, dtype=16, niter=31) -c/ -c -c------------------------------- body -------------------------------- -c - i = iv(dtype) - if (i .eq. 1) go to 10 - if (iv(niter) .gt. 0) go to 999 -c - 10 dtoli = iv(dtol) - d0i = dtoli + n - vdfac = v(dfac) - do 20 i = 1, n - t = dmax1(dsqrt(dabs(hdiag(i))), vdfac*d(i)) - if (t .lt. v(dtoli)) t = dmax1(v(dtoli), v(d0i)) - d(i) = t - dtoli = dtoli + 1 - d0i = d0i + 1 - 20 continue -c - 999 return -c *** last card of dupdu follows *** - end - subroutine gqtst(d, dig, dihdi, ka, l, p, step, v, w) -c -c *** compute goldfeld-quandt-trotter step by more-hebden technique *** -c *** (nl2sol version 2.2), modified a la more and sorensen *** -c -c *** parameter declarations *** -c - integer ka, p -cal double precision d(p), dig(p), dihdi(1), l(1), v(21), step(p), -cal 1 w(1) - double precision d(p), dig(p), dihdi(p*(p+1)/2), l(p*(p+1)/2), - 1 v(21), step(p),w(4*p+7) -c dimension dihdi(p*(p+1)/2), l(p*(p+1)/2), w(4*p+7) -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** purpose *** -c -c given the (compactly stored) lower triangle of a scaled -c hessian (approximation) and a nonzero scaled gradient vector, -c this subroutine computes a goldfeld-quandt-trotter step of -c approximate length v(radius) by the more-hebden technique. in -c other words, step is computed to (approximately) minimize -c psi(step) = (g**t)*step + 0.5*(step**t)*h*step such that the -c 2-norm of d*step is at most (approximately) v(radius), where -c g is the gradient, h is the hessian, and d is a diagonal -c scale matrix whose diagonal is stored in the parameter d. -c (gqtst assumes dig = d**-1 * g and dihdi = d**-1 * h * d**-1.) -c -c *** parameter description *** -c -c d (in) = the scale vector, i.e. the diagonal of the scale -c matrix d mentioned above under purpose. -c dig (in) = the scaled gradient vector, d**-1 * g. if g = 0, then -c step = 0 and v(stppar) = 0 are returned. -c dihdi (in) = lower triangle of the scaled hessian (approximation), -c i.e., d**-1 * h * d**-1, stored compactly by rows., i.e., -c in the order (1,1), (2,1), (2,2), (3,1), (3,2), etc. -c ka (i/o) = the number of hebden iterations (so far) taken to deter- -c mine step. ka .lt. 0 on input means this is the first -c attempt to determine step (for the present dig and dihdi) -c -- ka is initialized to 0 in this case. output with -c ka = 0 (or v(stppar) = 0) means step = -(h**-1)*g. -c l (i/o) = workspace of length p*(p+1)/2 for cholesky factors. -c p (in) = number of parameters -- the hessian is a p x p matrix. -c step (i/o) = the step computed. -c v (i/o) contains various constants and variables described below. -c w (i/o) = workspace of length 4*p + 6. -c -c *** entries in v *** -c -c v(dgnorm) (i/o) = 2-norm of (d**-1)*g. -c v(dstnrm) (output) = 2-norm of d*step. -c v(dst0) (i/o) = 2-norm of d*(h**-1)*g (for pos. def. h only), or -c overestimate of smallest eigenvalue of (d**-1)*h*(d**-1). -c v(epslon) (in) = max. rel. error allowed for psi(step). for the -c step returned, psi(step) will exceed its optimal value -c by less than -v(epslon)*psi(step). suggested value = 0.1. -c v(gtstep) (out) = inner product between g and step. -c v(nreduc) (out) = psi(-(h**-1)*g) = psi(newton step) (for pos. def. -c h only -- v(nreduc) is set to zero otherwise). -c v(phmnfc) (in) = tol. (together with v(phmxfc)) for accepting step -c (more*s sigma). the error v(dstnrm) - v(radius) must lie -c between v(phmnfc)*v(radius) and v(phmxfc)*v(radius). -c v(phmxfc) (in) (see v(phmnfc).) -c suggested values -- v(phmnfc) = -0.25, v(phmxfc) = 0.5. -c v(preduc) (out) = psi(step) = predicted obj. func. reduction for step. -c v(radius) (in) = radius of current (scaled) trust region. -c v(rad0) (i/o) = value of v(radius) from previous call. -c v(stppar) (i/o) is normally the marquardt parameter, i.e. the alpha -c described below under algorithm notes. if h + alpha*d**2 -c (see algorithm notes) is (nearly) singular, however, -c then v(stppar) = -alpha. -c -c *** usage notes *** -c -c if it is desired to recompute step using a different value of -c v(radius), then this routine may be restarted by calling it -c with all parameters unchanged except v(radius). (this explains -c why step and w are listed as i/o). on an initial call (one with -c ka .lt. 0), step and w need not be initialized and only compo- -c nents v(epslon), v(stppar), v(phmnfc), v(phmxfc), v(radius), and -c v(rad0) of v must be initialized. -c -c *** algorithm notes *** -c -c the desired g-q-t step (ref. 2, 3, 4, 6) satisfies -c (h + alpha*d**2)*step = -g for some nonnegative alpha such that -c h + alpha*d**2 is positive semidefinite. alpha and step are -c computed by a scheme analogous to the one described in ref. 5. -c estimates of the smallest and largest eigenvalues of the hessian -c are obtained from the gerschgorin circle theorem enhanced by a -c simple form of the scaling described in ref. 7. cases in which -c h + alpha*d**2 is nearly (or exactly) singular are handled by -c the technique discussed in ref. 2. in these cases, a step of -c (exact) length v(radius) is returned for which psi(step) exceeds -c its optimal value by less than -v(epslon)*psi(step). the test -c suggested in ref. 6 for detecting the special case is performed -c once two matrix factorizations have been done -- doing so sooner -c seems to degrade the performance of optimization routines that -c call this routine. -c -c *** functions and subroutines called *** -c -c dotprd - returns inner product of two vectors. -c litvmu - applies inverse-transpose of compact lower triang. matrix. -c livmul - applies inverse of compact lower triang. matrix. -c lsqrt - finds cholesky factor (of compactly stored lower triang.). -c lsvmin - returns approx. to min. sing. value of lower triang. matrix. -c rmdcon - returns machine-dependent constants. -c v2norm - returns 2-norm of a vector. -c -c *** references *** -c -c 1. dennis, j.e., gay, d.m., and welsch, r.e. (1981), an adaptive -c nonlinear least-squares algorithm, acm trans. math. -c software, vol. 7, no. 3. -c 2. gay, d.m. (1981), computing optimal locally constrained steps, -c siam j. sci. statist. computing, vol. 2, no. 2, pp. -c 186-197. -c 3. goldfeld, s.m., quandt, r.e., and trotter, h.f. (1966), -c maximization by quadratic hill-climbing, econometrica 34, -c pp. 541-551. -c 4. hebden, m.d. (1973), an algorithm for minimization using exact -c second derivatives, report t.p. 515, theoretical physics -c div., a.e.r.e. harwell, oxon., england. -c 5. more, j.j. (1978), the levenberg-marquardt algorithm, implemen- -c tation and theory, pp.105-116 of springer lecture notes -c in mathematics no. 630, edited by g.a. watson, springer- -c verlag, berlin and new york. -c 6. more, j.j., and sorensen, d.c. (1981), computing a trust region -c step, technical report anl-81-83, argonne national lab. -c 7. varga, r.s. (1965), minimal gerschgorin sets, pacific j. math. 15, -c pp. 719-729. -c -c *** general *** -c -c coded by david m. gay. -c this subroutine was written in connection with research -c supported by the national science foundation under grants -c mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, and -c mcs-7906671. -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** local variables *** -c - logical restrt - integer dggdmx, diag, diag0, dstsav, emax, emin, i, im1, inc, irc, - 1 j, k, kalim, kamin, k1, lk0, phipin, q, q0, uk0, x - double precision alphak, aki, akk, delta, dst, eps, gtsta, lk, - 1 oldphi, phi, phimax, phimin, psifac, rad, radsq, - 2 root, si, sk, sw, t, twopsi, t1, t2, uk, wi -c -c *** constants *** - double precision big, dgxfac, epsfac, four, half, kappa, negone, - 1 one, p001, six, three, two, zero -c -c *** intrinsic functions *** -c/+ - double precision dabs, dmax1, dmin1, dsqrt -c/ -c *** external functions and subroutines *** -c - external dotprd, litvmu, livmul, lsqrt, lsvmin, rmdcon, v2norm - double precision dotprd, lsvmin, rmdcon, v2norm -c -c *** subscripts for v *** -c - integer dgnorm, dstnrm, dst0, epslon, gtstep, stppar, nreduc, - 1 phmnfc, phmxfc, preduc, radius, rad0 -c/6 -c data dgnorm/1/, dstnrm/2/, dst0/3/, epslon/19/, gtstep/4/, -c 1 nreduc/6/, phmnfc/20/, phmxfc/21/, preduc/7/, radius/8/, -c 2 rad0/9/, stppar/5/ -c/7 - parameter (dgnorm=1, dstnrm=2, dst0=3, epslon=19, gtstep=4, - 1 nreduc=6, phmnfc=20, phmxfc=21, preduc=7, radius=8, - 2 rad0=9, stppar=5) -c/ -c -c/6 -c data epsfac/50.0d+0/, four/4.0d+0/, half/0.5d+0/, -c 1 kappa/2.0d+0/, negone/-1.0d+0/, one/1.0d+0/, p001/1.0d-3/, -c 2 six/6.0d+0/, three/3.0d+0/, two/2.0d+0/, zero/0.0d+0/ -c/7 - parameter (epsfac=50.0d+0, four=4.0d+0, half=0.5d+0, - 1 kappa=2.0d+0, negone=-1.0d+0, one=1.0d+0, p001=1.0d-3, - 2 six=6.0d+0, three=3.0d+0, two=2.0d+0, zero=0.0d+0) - save dgxfac -c/ - data big/0.d+0/, dgxfac/0.d+0/ -c -c *** body *** -c -c *** store largest abs. entry in (d**-1)*h*(d**-1) at w(dggdmx). - dggdmx = p + 1 -c *** store gerschgorin over- and underestimates of the largest -c *** and smallest eigenvalues of (d**-1)*h*(d**-1) at w(emax) -c *** and w(emin) respectively. - emax = dggdmx + 1 - emin = emax + 1 -c *** for use in recomputing step, the final values of lk, uk, dst, -c *** and the inverse derivative of more*s phi at 0 (for pos. def. -c *** h) are stored in w(lk0), w(uk0), w(dstsav), and w(phipin) -c *** respectively. - lk0 = emin + 1 - phipin = lk0 + 1 - uk0 = phipin + 1 - dstsav = uk0 + 1 -c *** store diag of (d**-1)*h*(d**-1) in w(diag),...,w(diag0+p). - diag0 = dstsav - diag = diag0 + 1 -c *** store -d*step in w(q),...,w(q0+p). - q0 = diag0 + p - q = q0 + 1 -c *** allocate storage for scratch vector x *** - x = q + p - rad = v(radius) - radsq = rad**2 -c *** phitol = max. error allowed in dst = v(dstnrm) = 2-norm of -c *** d*step. - phimax = v(phmxfc) * rad - phimin = v(phmnfc) * rad - psifac = two * v(epslon) / (three * (four * (v(phmnfc) + one) * - 1 (kappa + one) + kappa + two) * rad**2) -c *** oldphi is used to detect limits of numerical accuracy. if -c *** we recompute step and it does not change, then we accept it. - oldphi = zero - eps = v(epslon) - irc = 0 - restrt = .false. - kalim = ka + 50 -c -c *** start or restart, depending on ka *** -c - if (ka .ge. 0) go to 290 -c -c *** fresh start *** -c - k = 0 - uk = negone - ka = 0 - kalim = 50 - v(dgnorm) = v2norm(p, dig) - v(nreduc) = zero - v(dst0) = zero - kamin = 3 - if (v(dgnorm) .eq. zero) kamin = 0 -c -c *** store diag(dihdi) in w(diag0+1),...,w(diag0+p) *** -c - j = 0 - do 10 i = 1, p - j = j + i - k1 = diag0 + i - w(k1) = dihdi(j) - 10 continue -c -c *** determine w(dggdmx), the largest element of dihdi *** -c - t1 = zero - j = p * (p + 1) / 2 - do 20 i = 1, j - t = dabs(dihdi(i)) - if (t1 .lt. t) t1 = t - 20 continue - w(dggdmx) = t1 -c -c *** try alpha = 0 *** -c - 30 call lsqrt(1, p, l, dihdi, irc) - if (irc .eq. 0) go to 50 -c *** indef. h -- underestimate smallest eigenvalue, use this -c *** estimate to initialize lower bound lk on alpha. - j = irc*(irc+1)/2 - t = l(j) - l(j) = one - do 40 i = 1, irc - 40 w(i) = zero - w(irc) = one - call litvmu(irc, w, l, w) - t1 = v2norm(irc, w) - lk = -t / t1 / t1 - v(dst0) = -lk - if (restrt) go to 210 - go to 70 -c -c *** positive definite h -- compute unmodified newton step. *** - 50 lk = zero - t = lsvmin(p, l, w(q), w(q)) - if (t .ge. one) go to 60 - if (big .le. zero) big = rmdcon(6) - if (v(dgnorm) .ge. t*t*big) go to 70 - 60 call livmul(p, w(q), l, dig) - gtsta = dotprd(p, w(q), w(q)) - v(nreduc) = half * gtsta - call litvmu(p, w(q), l, w(q)) - dst = v2norm(p, w(q)) - v(dst0) = dst - phi = dst - rad - if (phi .le. phimax) go to 260 - if (restrt) go to 210 -c -c *** prepare to compute gerschgorin estimates of largest (and -c *** smallest) eigenvalues. *** -c - 70 k = 0 - do 100 i = 1, p - wi = zero - if (i .eq. 1) go to 90 - im1 = i - 1 - do 80 j = 1, im1 - k = k + 1 - t = dabs(dihdi(k)) - wi = wi + t - w(j) = w(j) + t - 80 continue - 90 w(i) = wi - k = k + 1 - 100 continue -c -c *** (under-)estimate smallest eigenvalue of (d**-1)*h*(d**-1) *** -c - k = 1 - t1 = w(diag) - w(1) - if (p .le. 1) go to 120 - do 110 i = 2, p - j = diag0 + i - t = w(j) - w(i) - if (t .ge. t1) go to 110 - t1 = t - k = i - 110 continue -c - 120 sk = w(k) - j = diag0 + k - akk = w(j) - k1 = k*(k-1)/2 + 1 - inc = 1 - t = zero - do 150 i = 1, p - if (i .eq. k) go to 130 - aki = dabs(dihdi(k1)) - si = w(i) - j = diag0 + i - t1 = half * (akk - w(j) + si - aki) - t1 = t1 + dsqrt(t1*t1 + sk*aki) - if (t .lt. t1) t = t1 - if (i .lt. k) go to 140 - 130 inc = i - 140 k1 = k1 + inc - 150 continue -c - w(emin) = akk - t - uk = v(dgnorm)/rad - w(emin) - if (v(dgnorm) .eq. zero) uk = uk + p001 + p001*uk - if (uk .le. zero) uk = p001 -c -c *** compute gerschgorin (over-)estimate of largest eigenvalue *** -c - k = 1 - t1 = w(diag) + w(1) - if (p .le. 1) go to 170 - do 160 i = 2, p - j = diag0 + i - t = w(j) + w(i) - if (t .le. t1) go to 160 - t1 = t - k = i - 160 continue -c - 170 sk = w(k) - j = diag0 + k - akk = w(j) - k1 = k*(k-1)/2 + 1 - inc = 1 - t = zero - do 200 i = 1, p - if (i .eq. k) go to 180 - aki = dabs(dihdi(k1)) - si = w(i) - j = diag0 + i - t1 = half * (w(j) + si - aki - akk) - t1 = t1 + dsqrt(t1*t1 + sk*aki) - if (t .lt. t1) t = t1 - if (i .lt. k) go to 190 - 180 inc = i - 190 k1 = k1 + inc - 200 continue -c - w(emax) = akk + t - lk = dmax1(lk, v(dgnorm)/rad - w(emax)) -c -c *** alphak = current value of alpha (see alg. notes above). we -c *** use more*s scheme for initializing it. - alphak = dabs(v(stppar)) * v(rad0)/rad -c - if (irc .ne. 0) go to 210 -c -c *** compute l0 for positive definite h *** -c - call livmul(p, w, l, w(q)) - t = v2norm(p, w) - w(phipin) = dst / t / t - lk = dmax1(lk, phi*w(phipin)) -c -c *** safeguard alphak and add alphak*i to (d**-1)*h*(d**-1) *** -c - 210 ka = ka + 1 - if (-v(dst0) .ge. alphak .or. alphak .lt. lk .or. alphak .ge. uk) - 1 alphak = uk * dmax1(p001, dsqrt(lk/uk)) - if (alphak .le. zero) alphak = half * uk - if (alphak .le. zero) alphak = uk - k = 0 - do 220 i = 1, p - k = k + i - j = diag0 + i - dihdi(k) = w(j) + alphak - 220 continue -c -c *** try computing cholesky decomposition *** -c - call lsqrt(1, p, l, dihdi, irc) - if (irc .eq. 0) go to 240 -c -c *** (d**-1)*h*(d**-1) + alphak*i is indefinite -- overestimate -c *** smallest eigenvalue for use in updating lk *** -c - j = (irc*(irc+1))/2 - t = l(j) - l(j) = one - do 230 i = 1, irc - 230 w(i) = zero - w(irc) = one - call litvmu(irc, w, l, w) - t1 = v2norm(irc, w) - lk = alphak - t/t1/t1 - v(dst0) = -lk - go to 210 -c -c *** alphak makes (d**-1)*h*(d**-1) positive definite. -c *** compute q = -d*step, check for convergence. *** -c - 240 call livmul(p, w(q), l, dig) - gtsta = dotprd(p, w(q), w(q)) - call litvmu(p, w(q), l, w(q)) - dst = v2norm(p, w(q)) - phi = dst - rad - if (phi .le. phimax .and. phi .ge. phimin) go to 270 - if (phi .eq. oldphi) go to 270 - oldphi = phi - if (phi .lt. zero) go to 330 -c -c *** unacceptable alphak -- update lk, uk, alphak *** -c - 250 if (ka .ge. kalim) go to 270 -c *** the following dmin1 is necessary because of restarts *** - if (phi .lt. zero) uk = dmin1(uk, alphak) -c *** kamin = 0 only iff the gradient vanishes *** - if (kamin .eq. 0) go to 210 - call livmul(p, w, l, w(q)) - t1 = v2norm(p, w) - alphak = alphak + (phi/t1) * (dst/t1) * (dst/rad) - lk = dmax1(lk, alphak) - go to 210 -c -c *** acceptable step on first try *** -c - 260 alphak = zero -c -c *** successful step in general. compute step = -(d**-1)*q *** -c - 270 do 280 i = 1, p - j = q0 + i - step(i) = -w(j)/d(i) - 280 continue - v(gtstep) = -gtsta - v(preduc) = half * (dabs(alphak)*dst*dst + gtsta) - go to 410 -c -c -c *** restart with new radius *** -c - 290 if (v(dst0) .le. zero .or. v(dst0) - rad .gt. phimax) go to 310 -c -c *** prepare to return newton step *** -c - restrt = .true. - ka = ka + 1 - k = 0 - do 300 i = 1, p - k = k + i - j = diag0 + i - dihdi(k) = w(j) - 300 continue - uk = negone - go to 30 -c - 310 kamin = ka + 3 - if (v(dgnorm) .eq. zero) kamin = 0 - if (ka .eq. 0) go to 50 -c - dst = w(dstsav) - alphak = dabs(v(stppar)) - phi = dst - rad - t = v(dgnorm)/rad - uk = t - w(emin) - if (v(dgnorm) .eq. zero) uk = uk + p001 + p001*uk - if (uk .le. zero) uk = p001 - if (rad .gt. v(rad0)) go to 320 -c -c *** smaller radius *** - lk = zero - if (alphak .gt. zero) lk = w(lk0) - lk = dmax1(lk, t - w(emax)) - if (v(dst0) .gt. zero) lk = dmax1(lk, (v(dst0)-rad)*w(phipin)) - go to 250 -c -c *** bigger radius *** - 320 if (alphak .gt. zero) uk = dmin1(uk, w(uk0)) - lk = dmax1(zero, -v(dst0), t - w(emax)) - if (v(dst0) .gt. zero) lk = dmax1(lk, (v(dst0)-rad)*w(phipin)) - go to 250 -c -c *** decide whether to check for special case... in practice (from -c *** the standpoint of the calling optimization code) it seems best -c *** not to check until a few iterations have failed -- hence the -c *** test on kamin below. -c - 330 delta = alphak + dmin1(zero, v(dst0)) - twopsi = alphak*dst*dst + gtsta - if (ka .ge. kamin) go to 340 -c *** if the test in ref. 2 is satisfied, fall through to handle -c *** the special case (as soon as the more-sorensen test detects -c *** it). - if (delta .ge. psifac*twopsi) go to 370 -c -c *** check for the special case of h + alpha*d**2 (nearly) -c *** singular. use one step of inverse power method with start -c *** from lsvmin to obtain approximate eigenvector corresponding -c *** to smallest eigenvalue of (d**-1)*h*(d**-1). lsvmin returns -c *** x and w with l*w = x. -c - 340 t = lsvmin(p, l, w(x), w) -c -c *** normalize w *** - do 350 i = 1, p - 350 w(i) = t*w(i) -c *** complete current inv. power iter. -- replace w by (l**-t)*w. - call litvmu(p, w, l, w) - t2 = one/v2norm(p, w) - do 360 i = 1, p - 360 w(i) = t2*w(i) - t = t2 * t -c -c *** now w is the desired approximate (unit) eigenvector and -c *** t*x = ((d**-1)*h*(d**-1) + alphak*i)*w. -c - sw = dotprd(p, w(q), w) - t1 = (rad + dst) * (rad - dst) - root = dsqrt(sw*sw + t1) - if (sw .lt. zero) root = -root - si = t1 / (sw + root) -c -c *** the actual test for the special case... -c - if ((t2*si)**2 .le. eps*(dst**2 + alphak*radsq)) go to 380 -c -c *** update upper bound on smallest eigenvalue (when not positive) -c *** (as recommended by more and sorensen) and continue... -c - if (v(dst0) .le. zero) v(dst0) = dmin1(v(dst0), t2**2 - alphak) - lk = dmax1(lk, -v(dst0)) -c -c *** check whether we can hope to detect the special case in -c *** the available arithmetic. accept step as it is if not. -c -c *** if not yet available, obtain machine dependent value dgxfac. - 370 if (dgxfac .eq. zero) dgxfac = epsfac * rmdcon(3) -c - if (delta .gt. dgxfac*w(dggdmx)) go to 250 - go to 270 -c -c *** special case detected... negate alphak to indicate special case -c - 380 alphak = -alphak - v(preduc) = half * twopsi -c -c *** accept current step if adding si*w would lead to a -c *** further relative reduction in psi of less than v(epslon)/3. -c - t1 = zero - t = si*(alphak*sw - half*si*(alphak + t*dotprd(p,w(x),w))) - if (t .lt. eps*twopsi/six) go to 390 - v(preduc) = v(preduc) + t - dst = rad - t1 = -si - 390 do 400 i = 1, p - j = q0 + i - w(j) = t1*w(i) - w(j) - step(i) = w(j) / d(i) - 400 continue - v(gtstep) = dotprd(p, dig, w(q)) -c -c *** save values for use in a possible restart *** -c - 410 v(dstnrm) = dst - v(stppar) = alphak - w(lk0) = lk - w(uk0) = uk - v(rad0) = rad - w(dstsav) = dst -c -c *** restore diagonal of dihdi *** -c - j = 0 - do 420 i = 1, p - j = j + i - k = diag0 + i - dihdi(j) = w(k) - 420 continue -c - 999 return -c -c *** last card of gqtst follows *** - end - subroutine lsqrt(n1, n, l, a, irc) -c -c *** compute rows n1 through n of the cholesky factor l of -c *** a = l*(l**t), where l and the lower triangle of a are both -c *** stored compactly by rows (and may occupy the same storage). -c *** irc = 0 means all went well. irc = j means the leading -c *** principal j x j submatrix of a is not positive definite -- -c *** and l(j*(j+1)/2) contains the (nonpos.) reduced j-th diagonal. -c -c *** parameters *** -c - integer n1, n, irc -cal double precision l(1), a(1) - double precision l(n*(n+1)/2), a(n*(n+1)/2) -c dimension l(n*(n+1)/2), a(n*(n+1)/2) -c -c *** local variables *** -c - integer i, ij, ik, im1, i0, j, jk, jm1, j0, k - double precision t, td, zero -c -c *** intrinsic functions *** -c/+ - double precision dsqrt -c/ -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c -c *** body *** -c - i0 = n1 * (n1 - 1) / 2 - do 50 i = n1, n - td = zero - if (i .eq. 1) go to 40 - j0 = 0 - im1 = i - 1 - do 30 j = 1, im1 - t = zero - if (j .eq. 1) go to 20 - jm1 = j - 1 - do 10 k = 1, jm1 - ik = i0 + k - jk = j0 + k - t = t + l(ik)*l(jk) - 10 continue - 20 ij = i0 + j - j0 = j0 + j - t = (a(ij) - t) / l(j0) - l(ij) = t - td = td + t*t - 30 continue - 40 i0 = i0 + i - t = a(i0) - td - if (t .le. zero) go to 60 - l(i0) = dsqrt(t) - 50 continue -c - irc = 0 - go to 999 -c - 60 l(i0) = t - irc = i -c - 999 return -c -c *** last card of lsqrt *** - end - double precision function lsvmin(p, l, x, y) -c -c *** estimate smallest sing. value of packed lower triang. matrix l -c -c *** parameter declarations *** -c - integer p -cal double precision l(1), x(p), y(p) - double precision l(p*(p+1)/2), x(p), y(p) -c dimension l(p*(p+1)/2) -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** purpose *** -c -c this function returns a good over-estimate of the smallest -c singular value of the packed lower triangular matrix l. -c -c *** parameter description *** -c -c p (in) = the order of l. l is a p x p lower triangular matrix. -c l (in) = array holding the elements of l in row order, i.e. -c l(1,1), l(2,1), l(2,2), l(3,1), l(3,2), l(3,3), etc. -c x (out) if lsvmin returns a positive value, then x is a normalized -c approximate left singular vector corresponding to the -c smallest singular value. this approximation may be very -c crude. if lsvmin returns zero, then some components of x -c are zero and the rest retain their input values. -c y (out) if lsvmin returns a positive value, then y = (l**-1)*x is an -c unnormalized approximate right singular vector correspond- -c ing to the smallest singular value. this approximation -c may be crude. if lsvmin returns zero, then y retains its -c input value. the caller may pass the same vector for x -c and y (nonstandard fortran usage), in which case y over- -c writes x (for nonzero lsvmin returns). -c -c *** algorithm notes *** -c -c the algorithm is based on (1), with the additional provision that -c lsvmin = 0 is returned if the smallest diagonal element of l -c (in magnitude) is not more than the unit roundoff times the -c largest. the algorithm uses a random number generator proposed -c in (4), which passes the spectral test with flying colors -- see -c (2) and (3). -c -c *** subroutines and functions called *** -c -c v2norm - function, returns the 2-norm of a vector. -c -c *** references *** -c -c (1) cline, a., moler, c., stewart, g., and wilkinson, j.h.(1977), -c an estimate for the condition number of a matrix, report -c tm-310, applied math. div., argonne national laboratory. -c -c (2) hoaglin, d.c. (1976), theoretical properties of congruential -c random-number generators -- an empirical view, -c memorandum ns-340, dept. of statistics, harvard univ. -c -c (3) knuth, d.e. (1969), the art of computer programming, vol. 2 -c (seminumerical algorithms), addison-wesley, reading, mass. -c -c (4) smith, c.s. (1971), multiplicative pseudo-random number -c generators with prime modulus, j. assoc. comput. mach. 18, -c pp. 586-593. -c -c *** history *** -c -c designed and coded by david m. gay (winter 1977/summer 1978). -c -c *** general *** -c -c this subroutine was written in connection with research -c supported by the national science foundation under grants -c mcs-7600324, dcr75-10143, 76-14311dss, and mcs76-11989. -c -c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -c -c *** local variables *** -c - integer i, ii, ix, j, ji, jj, jjj, jm1, j0, pm1 - double precision b, sminus, splus, t, xminus, xplus -c -c *** constants *** -c - double precision half, one, r9973, zero -c -c *** intrinsic functions *** -c/+ - integer mod - real float - double precision dabs -c/ -c *** external functions and subroutines *** -c - external dotprd, v2norm, vaxpy - double precision dotprd, v2norm -c -c/6 -c data half/0.5d+0/, one/1.d+0/, r9973/9973.d+0/, zero/0.d+0/ -c/7 - parameter (half=0.5d+0, one=1.d+0, r9973=9973.d+0, zero=0.d+0) -c/ -c -c *** body *** -c - ix = 2 - pm1 = p - 1 -c -c *** first check whether to return lsvmin = 0 and initialize x *** -c - ii = 0 - j0 = p*pm1/2 - jj = j0 + p - if (l(jj) .eq. zero) go to 110 - ix = mod(3432*ix, 9973) - b = half*(one + float(ix)/r9973) - xplus = b / l(jj) - x(p) = xplus - if (p .le. 1) go to 60 - do 10 i = 1, pm1 - ii = ii + i - if (l(ii) .eq. zero) go to 110 - ji = j0 + i - x(i) = xplus * l(ji) - 10 continue -c -c *** solve (l**t)*x = b, where the components of b have randomly -c *** chosen magnitudes in (.5,1) with signs chosen to make x large. -c -c do j = p-1 to 1 by -1... - do 50 jjj = 1, pm1 - j = p - jjj -c *** determine x(j) in this iteration. note for i = 1,2,...,j -c *** that x(i) holds the current partial sum for row i. - ix = mod(3432*ix, 9973) - b = half*(one + float(ix)/r9973) - xplus = (b - x(j)) - xminus = (-b - x(j)) - splus = dabs(xplus) - sminus = dabs(xminus) - jm1 = j - 1 - j0 = j*jm1/2 - jj = j0 + j - xplus = xplus/l(jj) - xminus = xminus/l(jj) - if (jm1 .eq. 0) go to 30 - do 20 i = 1, jm1 - ji = j0 + i - splus = splus + dabs(x(i) + l(ji)*xplus) - sminus = sminus + dabs(x(i) + l(ji)*xminus) - 20 continue - 30 if (sminus .gt. splus) xplus = xminus - x(j) = xplus -c *** update partial sums *** - if (jm1 .gt. 0) call vaxpy(jm1, x, xplus, l(j0+1), x) - 50 continue -c -c *** normalize x *** -c - 60 t = one/v2norm(p, x) - do 70 i = 1, p - 70 x(i) = t*x(i) -c -c *** solve l*y = x and return lsvmin = 1/twonorm(y) *** -c - do 100 j = 1, p - jm1 = j - 1 - j0 = j*jm1/2 - jj = j0 + j - t = zero - if (jm1 .gt. 0) t = dotprd(jm1, l(j0+1), y) - y(j) = (x(j) - t) / l(jj) - 100 continue -c - lsvmin = one/v2norm(p, y) - go to 999 -c - 110 lsvmin = zero - 999 return -c *** last card of lsvmin follows *** - end - subroutine slvmul(p, y, s, x) -c -c *** set y = s * x, s = p x p symmetric matrix. *** -c *** lower triangle of s stored rowwise. *** -c -c *** parameter declarations *** -c - integer p -cal double precision s(1), x(p), y(p) - double precision s(p*(p+1)/2), x(p), y(p) -c dimension s(p*(p+1)/2) -c -c *** local variables *** -c - integer i, im1, j, k - double precision xi -c -c *** no intrinsic functions *** -c -c *** external function *** -c - external dotprd - double precision dotprd -c -c----------------------------------------------------------------------- -c - j = 1 - do 10 i = 1, p - y(i) = dotprd(i, s(j), x) - j = j + i - 10 continue -c - if (p .le. 1) go to 999 - j = 1 - do 40 i = 2, p - xi = x(i) - im1 = i - 1 - j = j + 1 - do 30 k = 1, im1 - y(k) = y(k) + s(j)*xi - j = j + 1 - 30 continue - 40 continue -c - 999 return -c *** last card of slvmul follows *** - end diff --git a/source/unres/src_MIN/djacob.f b/source/unres/src_MIN/djacob.f deleted file mode 100644 index e3f46bc..0000000 --- a/source/unres/src_MIN/djacob.f +++ /dev/null @@ -1,107 +0,0 @@ - SUBROUTINE DJACOB(N,NMAX,MAXJAC,E,A,C,AII) - IMPLICIT REAL*8 (A-H,O-Z) -C THE JACOBI DIAGONALIZATION PROCEDURE - COMMON INP,IOUT,IPN - DIMENSION A(NMAX,N),C(NMAX,N),AII(150),AJJ(150) - SIN45 = .70710678 - COS45 = .70710678 - S45SQ = 0.50 - C45SQ = 0.50 -C UNIT EIGENVECTOR MATRIX - DO 70 I = 1,N - DO 7 J = I,N - A(J,I)=A(I,J) - C(I,J) = 0.0 - 7 C(J,I) = 0.0 - 70 C(I,I) = 1.0 -C DETERMINATION OF SEARCH ARGUMENT, TEST - AMAX = 0.0 - DO 1 I = 1,N - DO 1 J = 1,I - TEMPA=DABS(A(I,J)) - IF (AMAX-TEMPA) 2,1,1 - 2 AMAX = TEMPA - 1 CONTINUE - TEST = AMAX*E -C SEARCH FOR LARGEST OFF DIAGONAL ELEMENT - DO 72 IJAC=1,MAXJAC - AIJMAX = 0.0 - DO 3 I = 2,N - LIM = I-1 - DO 3 J = 1,LIM - TAIJ=DABS(A(I,J)) - IF (AIJMAX-TAIJ) 4,3,3 - 4 AIJMAX = TAIJ - IPIV = I - JPIV = J - 3 CONTINUE - IF(AIJMAX-TEST)300,300,5 -C PARAMETERS FOR ROTATION - 5 TAII = A(IPIV,IPIV) - TAJJ = A(JPIV,JPIV) - TAIJ = A(IPIV,JPIV) - TMT = TAII-TAJJ - IF(DABS(TMT/TAIJ)-1.0D-12) 60,60,6 - 60 IF(TAIJ) 10,10,11 - 6 ZAMMA=TAIJ/(2.0*TMT) - 90 IF(DABS(ZAMMA)-0.38268)8,8,9 - 9 IF(ZAMMA)10,10,11 - 10 SINT = -SIN45 - GO TO 12 - 11 SINT = SIN45 - 12 COST = COS45 - SINSQ = S45SQ - COSSQ = C45SQ - GO TO 120 - 8 GAMSQ=ZAMMA*ZAMMA - SINT=2.0*ZAMMA/(1.0+GAMSQ) - COST = (1.0-GAMSQ)/(1.0+GAMSQ) - SINSQ=SINT*SINT - COSSQ=COST*COST -C ROTATION - 120 DO 13 K = 1,N - TAIK = A(IPIV,K) - TAJK = A(JPIV,K) - A(IPIV,K) = TAIK*COST+TAJK*SINT - A(JPIV,K) = TAJK*COST-TAIK*SINT - TCIK = C(IPIV,K) - TCJK = C(JPIV,K) - C(IPIV,K) = TCIK*COST+TCJK*SINT - 13 C(JPIV,K) = TCJK*COST-TCIK*SINT - A(IPIV,IPIV) = TAII*COSSQ+TAJJ*SINSQ+2.0*TAIJ*SINT*COST - A(JPIV,JPIV) = TAII*SINSQ+TAJJ*COSSQ-2.0*TAIJ*SINT*COST - A(IPIV,JPIV) = TAIJ*(COSSQ-SINSQ)-SINT*COST*TMT - A(JPIV,IPIV) = A(IPIV,JPIV) - DO 30 K = 1,N - A(K,IPIV) = A(IPIV,K) - 30 A(K,JPIV) = A(JPIV,K) - 72 CONTINUE - WRITE (IOUT,1000) AIJMAX - 1000 FORMAT (/1X,'NONCONVERGENT JACOBI. LARGEST OFF-DIAGONAL ELE', - 1 'MENT = ',1PE14.7) -C ARRANGEMENT OF EIGENVALUES IN ASCENDING ORDER - 300 DO 14 I=1,N - 14 AJJ(I)=A(I,I) - LT=N+1 - DO15 L=1,N - LT=LT-1 - AIIMIN=1.0E+30 - DO16 I=1,N - IF(AJJ(I)-AIIMIN)17,16,16 - 17 AIIMIN=AJJ(I) - IT=I - 16 CONTINUE - IN=L - AII(IN)=AIIMIN - AJJ(IT)=1.0E+30 - DO15 K=1,N - 15 A(IN,K)=C(IT,K) - DO 18 I=1,N - IF(A(I,1))19,22,22 - 19 T=-1.0 - GO TO 91 - 22 T=1.0 - 91 DO 18 J=1,N - 18 C(J,I)=T*A(I,J) - RETURN - END diff --git a/source/unres/src_MIN/econstr_local.F b/source/unres/src_MIN/econstr_local.F deleted file mode 100644 index da6c830..0000000 --- a/source/unres/src_MIN/econstr_local.F +++ /dev/null @@ -1,91 +0,0 @@ - subroutine Econstr_back -c MD with umbrella_sampling using Wolyne's distance measure as a constraint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD_' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else -c include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.TIME1' - Uconst_back=0.0d0 - do i=1,nres - dutheta(i)=0.0d0 - dugamma(i)=0.0d0 - do j=1,3 - duscdiff(j,i)=0.0d0 - duscdiffx(j,i)=0.0d0 - enddo - enddo - do i=1,nfrag_back - ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) -c -c Deviations from theta angles -c - utheta_i=0.0d0 - do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) - dtheta_i=theta(j)-thetaref(j) - utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i - dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) - enddo - utheta(i)=utheta_i/(ii-1) -c -c Deviations from gamma angles -c - ugamma_i=0.0d0 - do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset) - dgamma_i=pinorm(phi(j)-phiref(j)) -c write (iout,*) j,phi(j),phi(j)-phiref(j) - ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i - dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2) -c write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3) - enddo - ugamma(i)=ugamma_i/(ii-2) -c -c Deviations from local SC geometry -c - uscdiff(i)=0.0d0 - do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 - dxx=xxtab(j)-xxref(j) - dyy=yytab(j)-yyref(j) - dzz=zztab(j)-zzref(j) - uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz - do k=1,3 - duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* - & (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ - & (ii-1) - duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* - & (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ - & (ii-1) - duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* - & (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) - & /(ii-1) - enddo -c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), -c & xxref(j),yyref(j),zzref(j) - enddo - uscdiff(i)=0.5d0*uscdiff(i)/(ii-1) -c write (iout,*) i," uscdiff",uscdiff(i) -c -c Put together deviations from local geometry -c - Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ - & wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i) -c write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i), -c & " uconst_back",uconst_back - utheta(i)=dsqrt(utheta(i)) - ugamma(i)=dsqrt(ugamma(i)) - uscdiff(i)=dsqrt(uscdiff(i)) - enddo - return - end diff --git a/source/unres/src_MIN/energy_p_new_barrier.F b/source/unres/src_MIN/energy_p_new_barrier.F deleted file mode 100644 index 96df440..0000000 --- a/source/unres/src_MIN/energy_p_new_barrier.F +++ /dev/null @@ -1,9024 +0,0 @@ - subroutine etotal(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.LOCAL' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.MD_' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' -#ifdef MPI -c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, -c & " nfgtasks",nfgtasks - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR) -c print *,"Processor",myrank," BROADCAST iorder" -C FG master sets up the WEIGHTS_ array which will be broadcast to the -C FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor - weights_(22)=wsct -C FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -C FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - wsct=weights(22) - endif - time_Bcast=time_Bcast+MPI_Wtime()-time00 - time_Bcastw=time_Bcastw+MPI_Wtime()-time00 -c call chainbuild_cart - endif -c print *,'Processor',myrank,' calling etotal ipot=',ipot -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#else -c if (modecalc.eq.12.or.modecalc.eq.14) then -c call int_from_cart1(.false.) -c endif -#endif -#ifdef TIMING - time00=MPI_Wtime() -#endif -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105,106) ipot -C Lennard-Jones potential. - 101 call elj(evdw,evdw_p,evdw_m) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk(evdw,evdw_p,evdw_m) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp(evdw,evdw_p,evdw_m) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb(evdw,evdw_p,evdw_m) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv(evdw,evdw_p,evdw_m) - goto 107 -C Soft-sphere potential - 106 call e_softsphere(evdw) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 continue -c print *,"Processor",myrank," computed USCSC" -#ifdef TIMING - time01=MPI_Wtime() -#endif - call vec_and_deriv -#ifdef TIMING - time_vec=time_vec+MPI_Wtime()-time01 -#endif -c print *,"Processor",myrank," left VEC_AND_DERIV" - if (ipot.lt.6) then -#ifdef SPLITELE - if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#else - if (welec.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#endif - call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) - else - ees=0.0d0 - evdw1=0.0d0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 - endif - else -c write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, - & eello_turn4) - endif -c print *,"Processor",myrank," computed UELEC" -C -C Calculate excluded-volume interaction energy between peptide groups -C and side chains. -C - if (ipot.lt.6) then - if(wscp.gt.0d0) then - call escp(evdw2,evdw2_14) - else - evdw2=0 - evdw2_14=0 - endif - else -c write (iout,*) "Soft-sphere SCP potential" - call escp_soft_sphere(evdw2,evdw2_14) - endif -c -c Calculate the bond-stretching energy -c - call ebond(estr) -C -C Calculate the disulfide-bridge and other energy and the contributions -C from other distance constraints. -cd print *,'Calling EHPB' - call edis(ehpb) -cd print *,'EHPB exitted succesfully.' -C -C Calculate the virtual-bond-angle energy. -C - if (wang.gt.0d0) then - call ebend(ebe) - else - ebe=0 - endif -c print *,"Processor",myrank," computed UB" -C -C Calculate the SC local energy. -C - call esc(escloc) -c print *,"Processor",myrank," computed USC" -C -C Calculate the virtual-bond torsional energy. -C -cd print *,'nterm=',nterm - if (wtor.gt.0) then - call etor(etors,edihcnstr) - else - etors=0 - edihcnstr=0 - endif -c print *,"Processor",myrank," computed Utor" -C -C 6/23/01 Calculate double-torsional energy -C - if (wtor_d.gt.0) then - call etor_d(etors_d) - else - etors_d=0 - endif -c print *,"Processor",myrank," computed Utord" -C -C 21/5/07 Calculate local sicdechain correlation energy -C - if (wsccor.gt.0.0d0) then - call eback_sc_corr(esccor) - else - esccor=0.0d0 - endif -c print *,"Processor",myrank," computed Usccorr" -C -C 12/1/95 Multi-body terms -C - n_corr=0 - n_corr1=0 - if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 - & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then - call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1, -cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -cd write (iout,*) "multibody_hb ecorr",ecorr - endif -c print *,"Processor",myrank," computed Ucorr" -C -C If performing constraint dynamics, call the constraint energy -C after the equilibration time - if(usampl.and.totT.gt.eq_time) then -c call EconstrQ - call Econstr_back - else - Uconst=0.0d0 - Uconst_back=0.0d0 - endif -#ifdef TIMING - time_enecalc=time_enecalc+MPI_Wtime()-time00 -#endif -c print *,"Processor",myrank," computed Uconstr" -#ifdef TIMING - time00=MPI_Wtime() -#endif -c -C Sum the energies -C - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(19)=edihcnstr - energia(17)=estr - energia(20)=Uconst+Uconst_back - energia(21)=esccor - energia(22)=evdw_p - energia(23)=evdw_m -c print *," Processor",myrank," calls SUM_ENERGY" - call sum_energy(energia,.true.) -c print *," Processor",myrank," left SUM_ENERGY" -#ifdef TIMING - time_sumene=time_sumene+MPI_Wtime()-time00 -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sum_energy(energia,reduce) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene),enebuff(0:n_ene+1) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - logical reduce -#ifdef MPI - if (nfgtasks.gt.1 .and. reduce) then -#ifdef DEBUG - write (iout,*) "energies before REDUCE" - call enerprint(energia) - call flush(iout) -#endif - do i=0,n_ene - enebuff(i)=energia(i) - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_e=time_barrier_e+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(enebuff(0),energia(0),n_ene+1, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) -#ifdef DEBUG - write (iout,*) "energies after REDUCE" - call enerprint(energia) - call flush(iout) -#endif - time_Reduce=time_Reduce+MPI_Wtime()-time00 - endif - if (fg_rank.eq.0) then -#endif -#ifdef TSCSC - evdw=energia(22)+wsct*energia(23) -#else - evdw=energia(1) -#endif -#ifdef SCP14 - evdw2=energia(2)+energia(18) - evdw2_14=energia(18) -#else - evdw2=energia(2) -#endif -#ifdef SPLITELE - ees=energia(3) - evdw1=energia(16) -#else - ees=energia(3) - evdw1=0.0d0 -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eturn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor -#else - etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor -#endif - energia(0)=etot -c detecting NaNQ -#ifdef ISNAN -#ifdef AIX - if (isnan(etot).ne.0) energia(0)=1.0d+99 -#else - if (isnan(etot)) energia(0)=1.0d+99 -#endif -#else - i=0 -#ifdef WINPGI - idumm=proc_proc(etot,i) -#else - call proc_proc(etot,i) -#endif - if(i.eq.1)energia(0)=1.0d+99 -#endif -#ifdef MPI - endif -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sum_gradient - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include 'mpif.h' - double precision gradbufc(3,maxres),gradbufx(3,maxres), - & glocbuf(4*maxres),gradbufc_sum(3,maxres) -#else - double precision gradbufc(3,maxres),gradbufx(3,maxres), - & glocbuf(4*maxres),gradbufc_sum(3,maxres) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - include 'COMMON.MAXGRAD' -#ifdef TIMING - time01=MPI_Wtime() -#endif -#ifdef DEBUG - write (iout,*) "sum_gradient gvdwc, gvdwx" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)') - & i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3), - & (gvdwcT(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef MPI -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (nfgtasks.gt.1 .and. fg_rank.eq.0) - & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif -C -C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient -C in virtual-bond-vector coordinates -C -#ifdef DEBUG -c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" -c do i=1,nres-1 -c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') -c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) -c enddo -c write (iout,*) "gel_loc_tur3 gel_loc_turn4" -c do i=1,nres-1 -c write (iout,'(i5,3f10.5,2x,f10.5)') -c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) -c enddo - write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3), - & g_corr5_loc(i) - enddo - call flush(iout) -#endif -#ifdef SPLITELE -#ifdef TSCSC - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i) - enddo - enddo -#else - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i) - enddo - enddo -#endif -#else - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+ - & wbond*gradb(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i) - enddo - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -#ifdef DEBUG - write (iout,*) "gradbufc before allreduce" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -#ifdef DEBUG - write (iout,*) "gradbufc_sum after allreduce" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef TIMING - time_allreduce=time_allreduce+MPI_Wtime()-time00 -#endif - do i=nnt,nres - do k=1,3 - gradbufc(k,i)=0.0d0 - enddo - enddo - do i=igrad_start,igrad_end - do j=jgrad_start(i),jgrad_end(i) - do k=1,3 - gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) - enddo - enddo - enddo - else -#endif -#ifdef DEBUG - write (iout,*) "gradbufc" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - do i=nnt,nres-1 - do k=1,3 - gradbufc(k,i)=0.0d0 - enddo - do j=i+1,nres - do k=1,3 - gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) - enddo - enddo - enddo -#ifdef MPI - endif -#endif - do k=1,3 - gradbufc(k,nres)=0.0d0 - enddo - do i=1,nct - do j=1,3 -#ifdef SPLITELE - gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ - & wel_loc*gel_loc(j,i)+ - & 0.5d0*(wscp*gvdwc_scpp(j,i)+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i))+ - & wbond*gradb(j,i)+ - & wcorr*gradcorr(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) -#else - gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ - & wel_loc*gel_loc(j,i)+ - & 0.5d0*(wscp*gvdwc_scpp(j,i)+ - & welec*gelc_long(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i))+ - & wbond*gradb(j,i)+ - & wcorr*gradcorr(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) -#endif -#ifdef TSCSC - gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+ - & wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*gsccorx(j,i) - & +wscloc*gsclocx(j,i) -#else - gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*gsccorx(j,i) - & +wscloc*gsclocx(j,i) -#endif - enddo - enddo -#ifdef DEBUG - write (iout,*) "gloc before adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) - & +wcorr5*g_corr5_loc(i) - & +wcorr6*g_corr6_loc(i) - & +wturn4*gel_loc_turn4(i) - & +wturn3*gel_loc_turn3(i) - & +wturn6*gel_loc_turn6(i) - & +wel_loc*gel_loc_loc(i) - & +wsccor*gsccor_loc(i) - enddo -#ifdef DEBUG - write (iout,*) "gloc after adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - do j=1,3 - do i=1,nres - gradbufc(j,i)=gradc(j,i,icg) - gradbufx(j,i)=gradx(j,i,icg) - enddo - enddo - do i=1,4*nres - glocbuf(i)=gloc(i,icg) - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_g=time_barrier_g+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -#ifdef DEBUG - write (iout,*) "gloc after reduce" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - endif -#endif - if (gnorm_check) then -c -c Compute the maximum elements of the gradient -c - gvdwc_max=0.0d0 - gvdwc_scp_max=0.0d0 - gelc_max=0.0d0 - gvdwpp_max=0.0d0 - gradb_max=0.0d0 - ghpbc_max=0.0d0 - gradcorr_max=0.0d0 - gel_loc_max=0.0d0 - gcorr3_turn_max=0.0d0 - gcorr4_turn_max=0.0d0 - gradcorr5_max=0.0d0 - gradcorr6_max=0.0d0 - gcorr6_turn_max=0.0d0 - gsccorc_max=0.0d0 - gscloc_max=0.0d0 - gvdwx_max=0.0d0 - gradx_scp_max=0.0d0 - ghpbx_max=0.0d0 - gradxorr_max=0.0d0 - gsccorx_max=0.0d0 - gsclocx_max=0.0d0 - do i=1,nct - gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) - if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm -#ifdef TSCSC - gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i))) - if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm -#endif - gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i))) - if (gvdwc_scp_norm.gt.gvdwc_scp_max) - & gvdwc_scp_max=gvdwc_scp_norm - gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i))) - if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm - gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i))) - if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm - gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i))) - if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm - ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i))) - if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm - gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i))) - if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm - gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i))) - if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm - gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i), - & gcorr3_turn(1,i))) - if (gcorr3_turn_norm.gt.gcorr3_turn_max) - & gcorr3_turn_max=gcorr3_turn_norm - gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i), - & gcorr4_turn(1,i))) - if (gcorr4_turn_norm.gt.gcorr4_turn_max) - & gcorr4_turn_max=gcorr4_turn_norm - gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i))) - if (gradcorr5_norm.gt.gradcorr5_max) - & gradcorr5_max=gradcorr5_norm - gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i))) - if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm - gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i), - & gcorr6_turn(1,i))) - if (gcorr6_turn_norm.gt.gcorr6_turn_max) - & gcorr6_turn_max=gcorr6_turn_norm - gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) - if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm - gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) - if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm - gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) - if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm -#ifdef TSCSC - gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i))) - if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm -#endif - gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i))) - if (gradx_scp_norm.gt.gradx_scp_max) - & gradx_scp_max=gradx_scp_norm - ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i))) - if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm - gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i))) - if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm - gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i))) - if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm - gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i))) - if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm - enddo - if (gradout) then -#ifdef AIX - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif - write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max, - & gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max - close(istat) - if (gvdwc_max.gt.1.0d4) then - write (iout,*) "gvdwc gvdwx gradb gradbx" - do i=nnt,nct - write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i), - & gradb(j,i),gradbx(j,i),j=1,3) - enddo - call pdbout(0.0d0,'cipiszcze',iout) - call flush(iout) - endif - endif - endif -#ifdef DEBUG - write (iout,*) "gradc gradx gloc" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) - enddo -#endif -#ifdef TIMING - time_sumgradient=time_sumgradient+MPI_Wtime()-time01 -#endif - return - end -c------------------------------------------------------------------------------- - subroutine rescale_weights(t_bath) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - double precision kfac /2.4d0/ - double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/ -c facT=temp0/t_bath -c facT=2*temp0/(t_bath+temp0) - if (rescale_mode.eq.0) then - facT=1.0d0 - facT2=1.0d0 - facT3=1.0d0 - facT4=1.0d0 - facT5=1.0d0 - else if (rescale_mode.eq.1) then - facT=kfac/(kfac-1.0d0+t_bath/temp0) - facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) - facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) - facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) - facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) - else if (rescale_mode.eq.2) then - x=t_bath/temp0 - x2=x*x - x3=x2*x - x4=x3*x - x5=x4*x - facT=licznik/dlog(dexp(x)+dexp(-x)) - facT2=licznik/dlog(dexp(x2)+dexp(-x2)) - facT3=licznik/dlog(dexp(x3)+dexp(-x3)) - facT4=licznik/dlog(dexp(x4)+dexp(-x4)) - facT5=licznik/dlog(dexp(x5)+dexp(-x5)) - else - write (iout,*) "Wrong RESCALE_MODE",rescale_mode - write (*,*) "Wrong RESCALE_MODE",rescale_mode -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) -#endif - stop 555 - endif - welec=weights(3)*fact - wcorr=weights(4)*fact3 - wcorr5=weights(5)*fact4 - wcorr6=weights(6)*fact5 - wel_loc=weights(7)*fact2 - wturn3=weights(8)*fact2 - wturn4=weights(9)*fact3 - wturn6=weights(10)*fact5 - wtor=weights(13)*fact - wtor_d=weights(14)*fact2 - wsccor=weights(21)*fact -#ifdef TSCSC -c wsct=t_bath/temp0 - wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0 -#endif - return - end -C------------------------------------------------------------------------ - subroutine enerprint(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.MD_' - double precision energia(0:n_ene) - etot=energia(0) -#ifdef TSCSC - evdw=energia(22)+wsct*energia(23) -#else - evdw=energia(1) -#endif - evdw2=energia(2) -#ifdef SCP14 - evdw2=energia(2)+energia(18) -#else - evdw2=energia(2) -#endif - ees=energia(3) -#ifdef SPLITELE - evdw1=energia(16) -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eello_turn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor, - & edihcnstr,ebr*nss, - & Uconst,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST= ',1pE16.6,' (Constraint energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#else - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr, - & ebr*nss,Uconst,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST=',1pE16.6,' (Constraint energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#endif - return - end -C----------------------------------------------------------------------- - subroutine elj(evdw,evdw_p,evdw_m) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJ potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C Change 12/1/95 - num_conti=0 -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) -cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -cd & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi -C Change 12/1/95 to calculate four-body interactions - rij=xj*xj+yj*yj+zj*zj - rrij=1.0D0/rij -c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) -#ifdef TSCSC - if (bb(itypi,itypj).gt.0) then - evdw_p=evdw_p+evdwij - else - evdw_m=evdw_m+evdwij - endif -#else - evdw=evdw+evdwij -#endif -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -#ifdef TSCSC - if (bb(itypi,itypj).gt.0.0d0) then - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - else - do k=1,3 - gvdwxT(k,i)=gvdwxT(k,i)-gg(k) - gvdwxT(k,j)=gvdwxT(k,j)+gg(k) - gvdwcT(k,i)=gvdwcT(k,i)-gg(k) - gvdwcT(k,j)=gvdwcT(k,j)+gg(k) - enddo - endif -#else - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo -#endif -cgrad do k=i,j-1 -cgrad do l=1,3 -cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) -cgrad enddo -cgrad enddo -C -C 12/1/95, revised on 5/20/97 -C -C Calculate the contact function. The ith column of the array JCONT will -C contain the numbers of atoms that make contacts with the atom I (of numbers -C greater than I). The arrays FACONT and GACONT will contain the values of -C the contact function and its derivative. -C -C Uncomment next line, if the correlation interactions include EVDW explicitly. -c if (j.gt.i+1 .and. evdwij.le.0.0D0) then -C Uncomment next line, if the correlation interactions are contact function only - if (j.gt.i+1.and. eps0ij.gt.0.0D0) then - rij=dsqrt(rij) - sigij=sigma(itypi,itypj) - r0ij=rs0(itypi,itypj) -C -C Check whether the SC's are not too far to make a contact. -C - rcut=1.5d0*r0ij - call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) -C Add a new contact, if the SC's are close enough, but not too close (ri' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - return - end -C----------------------------------------------------------------------------- - subroutine escp(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+e1+e2 - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw2',i,j,evdwij -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -cgrad if (j.lt.i) then -cd write (iout,*) 'ji' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time the factor EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C-------------------------------------------------------------------------- - subroutine edis(ehpb) -C -C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - dimension ggg(3) - ehpb=0.0D0 -cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr -cd write(iout,*)'link_start=',link_start,' link_end=',link_end - if (link_end.eq.0) return - do i=link_start,link_end -C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a -C CA-CA distance used in regularization of structure. - ii=ihpb(i) - jj=jhpb(i) -C iii and jjj point to the residues for which the distance is assigned. - if (ii.gt.nres) then - iii=ii-nres - jjj=jj-nres - else - iii=ii - jjj=jj - endif -cd write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj -C 24/11/03 AL: SS bridges handled separately because of introducing a specific -C distance and angle dependent SS bond potential. - if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then - call ssbond_ene(iii,jjj,eij) - ehpb=ehpb+2*eij -cd write (iout,*) "eij",eij - else -C Calculate the distance between the two points and its difference from the -C target distance. - dd=dist(ii,jj) - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd -cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, -cd & ' waga=',waga,' fac=',fac - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo -cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) -C If this is a SC-SC distance, we need to calculate the contributions to the -C Cartesian gradient in the SC vectors (ghpbx). - if (iii.lt.ii) then - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - endif -cgrad do j=iii,jjj-1 -cgrad do k=1,3 -cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k) -cgrad enddo -cgrad enddo - do k=1,3 - ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) - ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) - enddo - endif - enddo - ehpb=0.5D0*ehpb - return - end -C-------------------------------------------------------------------------- - subroutine ssbond_ene(i,j,eij) -C -C Calculate the distance and angle dependent SS-bond potential energy -C using a free-energy function derived based on RHF/6-31G** ab initio -C calculations of diethyl disulfide. -C -C A. Liwo and U. Kozlowska, 11/24/03 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - double precision erij(3),dcosom1(3),dcosom2(3),gg(3) - itypi=itype(i) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(nres+i) - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(nres+j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - erij(1)=xj*rij - erij(2)=yj*rij - erij(3)=zj*rij - om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) - om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) - om12=dxi*dxj+dyi*dyj+dzi*dzj - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - rij=1.0d0/rij - deltad=rij-d0cm - deltat1=1.0d0-om1 - deltat2=1.0d0+om2 - deltat12=om2-om1+2.0d0 - cosphi=om12-om1*om2 - eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) - & +akct*deltad*deltat12 - & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi -c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, -c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, -c & " deltat12",deltat12," eij",eij - ed=2*akcm*deltad+akct*deltat12 - pom1=akct*deltad - pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi - eom1=-2*akth*deltat1-pom1-om2*pom2 - eom2= 2*akth*deltat2+pom1-om1*pom2 - eom12=pom2 - do k=1,3 - ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) - ghpbx(k,i)=ghpbx(k,i)-ggk - & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv - ghpbx(k,j)=ghpbx(k,j)+ggk - & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - ghpbc(k,i)=ghpbc(k,i)-ggk - ghpbc(k,j)=ghpbc(k,j)+ggk - enddo -C -C Calculate the components of the gradient in DC and X -C -cgrad do k=i,j-1 -cgrad do l=1,3 -cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l) -cgrad enddo -cgrad enddo - return - end -C-------------------------------------------------------------------------- - subroutine ebond(estr) -c -c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - double precision u(3),ud(3) - estr=0.0d0 - do i=ibondp_start,ibondp_end - diff = vbld(i)-vbldp0 -c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff - estr=estr+diff*diff - do j=1,3 - gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) - enddo -c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) - enddo - estr=0.5d0*AKP*estr -c -c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included -c - do i=ibond_start,ibond_end - iti=itype(i) - if (iti.ne.10) then - nbi=nbondterm(iti) - if (nbi.eq.1) then - diff=vbld(i+nres)-vbldsc0(1,iti) -c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, -c & AKSC(1,iti),AKSC(1,iti)*diff*diff - estr=estr+0.5d0*AKSC(1,iti)*diff*diff - do j=1,3 - gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) - enddo - else - do j=1,nbi - diff=vbld(i+nres)-vbldsc0(j,iti) - ud(j)=aksc(j,iti)*diff - u(j)=abond0(j,iti)+0.5d0*ud(j)*diff - enddo - uprod=u(1) - do j=2,nbi - uprod=uprod*u(j) - enddo - usum=0.0d0 - usumsqder=0.0d0 - do j=1,nbi - uprod1=1.0d0 - uprod2=1.0d0 - do k=1,nbi - if (k.ne.j) then - uprod1=uprod1*u(k) - uprod2=uprod2*u(k)*u(k) - endif - enddo - usum=usum+uprod1 - usumsqder=usumsqder+ud(j)*uprod2 - enddo - estr=estr+uprod/usum - do j=1,3 - gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) - enddo - endif - endif - enddo - return - end -#ifdef CRYST_THETA -C-------------------------------------------------------------------------- - subroutine ebend(etheta) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - double precision y(2),z(2) - delta=0.02d0*pi -c time11=dexp(-2*time) -c time12=1.0d0 - etheta=0.0D0 -c write (*,'(a,i2)') 'EBEND ICG=',icg - do i=ithet_start,ithet_end -C Zero the energy function and its derivative at 0 or pi. - call splinthet(theta(i),0.5d0*delta,ss,ssd) - it=itype(i-1) - if (i.gt.3) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - y(1)=dcos(phii) - y(2)=dsin(phii) - else - y(1)=0.0D0 - y(2)=0.0D0 - endif - if (i.lt.nres) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) - z(1)=cos(phii1) -#else - phii1=phi(i+1) - z(1)=dcos(phii1) -#endif - z(2)=dsin(phii1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif -C Calculate the "mean" value of theta from the part of the distribution -C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). -C In following comments this theta will be referred to as t_c. - thet_pred_mean=0.0d0 - do k=1,2 - athetk=athet(k,it) - bthetk=bthet(k,it) - thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) - enddo - dthett=thet_pred_mean*ssd - thet_pred_mean=thet_pred_mean*ss+a0thet(it) -C Derivatives of the "mean" values in gamma1 and gamma2. - dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss - dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss - if (theta(i).gt.pi-delta) then - call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, - & E_tc0) - call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) - call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, - & E_theta) - call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else if (theta(i).lt.delta) then - call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) - call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, - & E_theta) - call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) - call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else - call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, - & E_theta,E_tc) - endif - etheta=etheta+ethetai - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'ebend',i,ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 - gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) - enddo -C Ufff.... We've done all this!!! - return - end -C--------------------------------------------------------------------------- - subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, - & E_tc) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it -C Calculate the contributions to both Gaussian lobes. -C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) -C The "polynomial part" of the "standard deviation" of this part of -C the distribution. - sig=polthet(3,it) - do j=2,0,-1 - sig=sig*thet_pred_mean+polthet(j,it) - enddo -C Derivative of the "interior part" of the "standard deviation of the" -C gamma-dependent Gaussian lobe in t_c. - sigtc=3*polthet(3,it) - do j=2,1,-1 - sigtc=sigtc*thet_pred_mean+j*polthet(j,it) - enddo - sigtc=sig*sigtc -C Set the parameters of both Gaussian lobes of the distribution. -C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) - fac=sig*sig+sigc0(it) - sigcsq=fac+fac - sigc=1.0D0/sigcsq -C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c - sigsqtc=-4.0D0*sigcsq*sigtc -c print *,i,sig,sigtc,sigsqtc -C Following variable (sigtc) is d[sigma(t_c)]/dt_c - sigtc=-sigtc/(fac*fac) -C Following variable is sigma(t_c)**(-2) - sigcsq=sigcsq*sigcsq - sig0i=sig0(it) - sig0inv=1.0D0/sig0i**2 - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i - term1=-0.5D0*sigcsq*delthec*delthec - term2=-0.5D0*sig0inv*delthe0*delthe0 -C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and -C NaNs in taking the logarithm. We extract the largest exponent which is added -C to the energy (this being the log of the distribution) at the end of energy -C term evaluation for this virtual-bond angle. - if (term1.gt.term2) then - termm=term1 - term2=dexp(term2-termm) - term1=1.0d0 - else - termm=term2 - term1=dexp(term1-termm) - term2=1.0d0 - endif -C The ratio between the gamma-independent and gamma-dependent lobes of -C the distribution is a Gaussian function of thet_pred_mean too. - diffak=gthet(2,it)-thet_pred_mean - ratak=diffak/gthet(3,it)**2 - ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) -C Let's differentiate it in thet_pred_mean NOW. - aktc=ak*ratak -C Now put together the distribution terms to make complete distribution. - termexp=term1+ak*term2 - termpre=sigc+ak*sig0i -C Contribution of the bending energy from this theta is just the -log of -C the sum of the contributions from the two lobes and the pre-exponential -C factor. Simple enough, isn't it? - ethetai=(-dlog(termexp)-termm+dlog(termpre)) -C NOW the derivatives!!! -C 6/6/97 Take into account the deformation. - E_theta=(delthec*sigcsq*term1 - & +ak*delthe0*sig0inv*term2)/termexp - E_tc=((sigtc+aktc*sig0i)/termpre - & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ - & aktc*term2)/termexp) - return - end -c----------------------------------------------------------------------------- - subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i -C "Thank you" to MAPLE (probably spared one day of hand-differentiation). - t3 = thetai-thet_pred_mean - t6 = t3**2 - t9 = term1 - t12 = t3*sigcsq - t14 = t12+t6*sigsqtc - t16 = 1.0d0 - t21 = thetai-theta0i - t23 = t21**2 - t26 = term2 - t27 = t21*t26 - t32 = termexp - t40 = t32**2 - E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 - & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 - & *(-t12*t9-ak*sig0inv*t27) - return - end -#else -C-------------------------------------------------------------------------- - subroutine ebend(etheta) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C ab initio-derived potentials from -c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), - & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), - & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), - & sinph1ph2(maxdouble,maxdouble) - logical lprn /.false./, lprn1 /.false./ - etheta=0.0D0 - do i=ithet_start,ithet_end - dethetai=0.0d0 - dephii=0.0d0 - dephii1=0.0d0 - theti2=0.5d0*theta(i) - ityp2=ithetyp(itype(i-1)) - do k=1,nntheterm - coskt(k)=dcos(k*theti2) - sinkt(k)=dsin(k*theti2) - enddo - if (i.gt.3) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - ityp1=ithetyp(itype(i-2)) - do k=1,nsingle - cosph1(k)=dcos(k*phii) - sinph1(k)=dsin(k*phii) - enddo - else - phii=0.0d0 - ityp1=nthetyp+1 - do k=1,nsingle - cosph1(k)=0.0d0 - sinph1(k)=0.0d0 - enddo - endif - if (i.lt.nres) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) -#else - phii1=phi(i+1) -#endif - ityp3=ithetyp(itype(i)) - do k=1,nsingle - cosph2(k)=dcos(k*phii1) - sinph2(k)=dsin(k*phii1) - enddo - else - phii1=0.0d0 - ityp3=nthetyp+1 - do k=1,nsingle - cosph2(k)=0.0d0 - sinph2(k)=0.0d0 - enddo - endif - ethetai=aa0thet(ityp1,ityp2,ityp3) - do k=1,ndouble - do l=1,k-1 - ccl=cosph1(l)*cosph2(k-l) - ssl=sinph1(l)*sinph2(k-l) - scl=sinph1(l)*cosph2(k-l) - csl=cosph1(l)*sinph2(k-l) - cosph1ph2(l,k)=ccl-ssl - cosph1ph2(k,l)=ccl+ssl - sinph1ph2(l,k)=scl+csl - sinph1ph2(k,l)=scl-csl - enddo - enddo - if (lprn) then - write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, - & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 - write (iout,*) "coskt and sinkt" - do k=1,nntheterm - write (iout,*) k,coskt(k),sinkt(k) - enddo - endif - do k=1,ntheterm - ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k) - dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3) - & *coskt(k) - if (lprn) - & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), - & " ethetai",ethetai - enddo - if (lprn) then - write (iout,*) "cosph and sinph" - do k=1,nsingle - write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) - enddo - write (iout,*) "cosph1ph2 and sinph2ph2" - do k=2,ndouble - do l=1,k-1 - write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), - & sinph1ph2(l,k),sinph1ph2(k,l) - enddo - enddo - write(iout,*) "ethetai",ethetai - endif - do m=1,ntheterm2 - do k=1,nsingle - aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k) - & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k) - & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k) - & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*aux*coskt(m) - dephii=dephii+k*sinkt(m)*( - & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)- - & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) - dephii1=dephii1+k*sinkt(m)*( - & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- - & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) - if (lprn) - & write (iout,*) "m",m," k",k," bbthet", - & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", - & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", - & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", - & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai - enddo - enddo - if (lprn) - & write(iout,*) "ethetai",ethetai - do m=1,ntheterm3 - do k=2,ndouble - do l=1,k-1 - aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*coskt(m)*aux - dephii=dephii+l*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)- - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - dephii1=dephii1+(k-l)*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)- - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - if (lprn) then - write (iout,*) "m",m," k",k," l",l," ffthet", - & ffthet(l,k,m,ityp1,ityp2,ityp3), - & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", - & ggthet(l,k,m,ityp1,ityp2,ityp3), - & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai - write (iout,*) cosph1ph2(l,k)*sinkt(m), - & cosph1ph2(k,l)*sinkt(m), - & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) - endif - enddo - enddo - enddo -10 continue - if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') - & i,theta(i)*rad2deg,phii*rad2deg, - & phii1*rad2deg,ethetai - etheta=etheta+ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 - gloc(nphi+i-2,icg)=wang*dethetai - enddo - return - end -#endif -#ifdef CRYST_SC -c----------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), - & ddersc0(3),ddummy(3),xtemp(3),temp(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 -c write (iout,'(a)') 'ESC' - do i=loc_start,loc_end - it=itype(i) - if (it.eq.10) goto 1 - nlobit=nlob(it) -c print *,'i=',i,' it=',it,' nlobit=',nlobit -c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad - theti=theta(i+1)-pipol - x(1)=dtan(theti) - x(2)=alph(i) - x(3)=omeg(i) - - if (x(2).gt.pi-delta) then - xtemp(1)=x(1) - xtemp(2)=pi-delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=pi - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=pi-delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=pi - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - call splinthet(x(2),0.5d0*delta,ss,ssd) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c escloci=esclocbi -c write (iout,*) escloci - else if (x(2).lt.delta) then - xtemp(1)=x(1) - xtemp(2)=delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=0.0d0 - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=0.0d0 - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - call splinthet(x(2),0.5d0*delta,ss,ssd) - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c write (iout,*) escloci - else - call enesc(x,escloci,dersc,ddummy,.false.) - endif - - escloc=escloc+escloci - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'escloc',i,escloci -c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc - - gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ - & wscloc*dersc(1) - gloc(ialph(i,1),icg)=wscloc*dersc(2) - gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) - 1 continue - enddo - return - end -C--------------------------------------------------------------------------- - subroutine enesc(x,escloci,dersc,ddersc,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) - double precision contr(maxlob,-1:1) - logical mixed -c write (iout,*) 'it=',it,' nlobit=',nlobit - escloc_i=0.0D0 - do j=1,3 - dersc(j)=0.0D0 - if (mixed) ddersc(j)=0.0d0 - enddo - x3=x(3) - -C Because of periodicity of the dependence of the SC energy in omega we have -C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). -C To avoid underflows, first compute & store the exponents. - - do iii=-1,1 - - x(3)=x3+iii*dwapi - - do j=1,nlobit - do k=1,3 - z(k)=x(k)-censc(k,j,it) - enddo - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j,iii)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j,iii)*z(k) - enddo - contr(j,iii)=expfac - enddo ! j - - enddo ! iii - - x(3)=x3 -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1,-1) - do iii=-1,1 - do j=1,nlobit - if (emin.gt.contr(j,iii)) emin=contr(j,iii) - enddo - enddo - emin=0.5D0*emin -cd print *,'it=',it,' emin=',emin - -C Compute the contribution to SC energy and derivatives - do iii=-1,1 - - do j=1,nlobit -#ifdef OSF - adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin - if(adexp.ne.adexp) adexp=1.0 - expfac=dexp(adexp) -#else - expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin) -#endif -cd print *,'j=',j,' expfac=',expfac - escloc_i=escloc_i+expfac - do k=1,3 - dersc(k)=dersc(k)+Ax(k,j,iii)*expfac - enddo - if (mixed) then - do k=1,3,2 - ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) - & +gaussc(k,2,j,it))*expfac - enddo - endif - enddo - - enddo ! iii - - dersc(1)=dersc(1)/cos(theti)**2 - ddersc(1)=ddersc(1)/cos(theti)**2 - ddersc(3)=ddersc(3) - - escloci=-(dlog(escloc_i)-emin) - do j=1,3 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) then - do j=1,3,2 - ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) - enddo - endif - return - end -C------------------------------------------------------------------------------ - subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob),dersc(3) - double precision contr(maxlob) - logical mixed - - escloc_i=0.0D0 - - do j=1,3 - dersc(j)=0.0D0 - enddo - - do j=1,nlobit - do k=1,2 - z(k)=x(k)-censc(k,j,it) - enddo - z(3)=dwapi - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j)*z(k) - enddo - contr(j)=expfac - enddo ! j - -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1) - do j=1,nlobit - if (emin.gt.contr(j)) emin=contr(j) - enddo - emin=0.5D0*emin - -C Compute the contribution to SC energy and derivatives - - dersc12=0.0d0 - do j=1,nlobit - expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin) - escloc_i=escloc_i+expfac - do k=1,2 - dersc(k)=dersc(k)+Ax(k,j)*expfac - enddo - if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) - & +gaussc(1,2,j,it))*expfac - dersc(3)=0.0d0 - enddo - - dersc(1)=dersc(1)/cos(theti)**2 - dersc12=dersc12/cos(theti)**2 - escloci=-(dlog(escloc_i)-emin) - do j=1,2 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) - return - end -#else -c---------------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA derived from AM1 all-atom calculations. -C added by Urszula Kozlowska. 07/11/2007 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.SCROT' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - include 'COMMON.VECTORS' - double precision x_prime(3),y_prime(3),z_prime(3) - & , sumene,dsc_i,dp2_i,x(65), - & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, - & de_dxx,de_dyy,de_dzz,de_dt - double precision s1_t,s1_6_t,s2_t,s2_6_t - double precision - & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), - & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), - & dt_dCi(3),dt_dCi1(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 - do i=loc_start,loc_end - costtab(i+1) =dcos(theta(i+1)) - sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) - cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) - sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) - cosfac2=0.5d0/(1.0d0+costtab(i+1)) - cosfac=dsqrt(cosfac2) - sinfac2=0.5d0/(1.0d0-costtab(i+1)) - sinfac=dsqrt(sinfac2) - it=itype(i) - if (it.eq.10) goto 1 -c -C Compute the axes of tghe local cartesian coordinates system; store in -c x_prime, y_prime and z_prime -c - do j=1,3 - x_prime(j) = 0.00 - y_prime(j) = 0.00 - z_prime(j) = 0.00 - enddo -C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), -C & dc_norm(3,i+nres) - do j = 1,3 - x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac - y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac - enddo - do j = 1,3 - z_prime(j) = -uz(j,i-1) - enddo -c write (2,*) "i",i -c write (2,*) "x_prime",(x_prime(j),j=1,3) -c write (2,*) "y_prime",(y_prime(j),j=1,3) -c write (2,*) "z_prime",(z_prime(j),j=1,3) -c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), -c & " xy",scalar(x_prime(1),y_prime(1)), -c & " xz",scalar(x_prime(1),z_prime(1)), -c & " yy",scalar(y_prime(1),y_prime(1)), -c & " yz",scalar(y_prime(1),z_prime(1)), -c & " zz",scalar(z_prime(1),z_prime(1)) -c -C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), -C to local coordinate system. Store in xx, yy, zz. -c - xx=0.0d0 - yy=0.0d0 - zz=0.0d0 - do j = 1,3 - xx = xx + x_prime(j)*dc_norm(j,i+nres) - yy = yy + y_prime(j)*dc_norm(j,i+nres) - zz = zz + z_prime(j)*dc_norm(j,i+nres) - enddo - - xxtab(i)=xx - yytab(i)=yy - zztab(i)=zz -C -C Compute the energy of the ith side cbain -C -c write (2,*) "xx",xx," yy",yy," zz",zz - it=itype(i) - do j = 1,65 - x(j) = sc_parmin(j,it) - enddo -#ifdef CHECK_COORD -Cc diagnostics - remove later - xx1 = dcos(alph(2)) - yy1 = dsin(alph(2))*dcos(omeg(2)) - zz1 = -dsin(alph(2))*dsin(omeg(2)) - write(2,'(3f8.1,3f9.3,1x,3f9.3)') - & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, - & xx1,yy1,zz1 -C," --- ", xx_w,yy_w,zz_w -c end diagnostics -#endif - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) - & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) -c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, -c & sumene4, -c & dscp1,dscp2,sumene -c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - escloc = escloc + sumene -c write (2,*) "i",i," escloc",sumene,escloc -#ifdef DEBUG -C -C This section to check the numerical derivatives of the energy of ith side -C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert -C #define DEBUG in the code to turn it on. -C - write (2,*) "sumene =",sumene - aincr=1.0d-7 - xxsave=xx - xx=xx+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dxx_num=(sumenep-sumene)/aincr - xx=xxsave - write (2,*) "xx+ sumene from enesc=",sumenep - yysave=yy - yy=yy+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dyy_num=(sumenep-sumene)/aincr - yy=yysave - write (2,*) "yy+ sumene from enesc=",sumenep - zzsave=zz - zz=zz+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dzz_num=(sumenep-sumene)/aincr - zz=zzsave - write (2,*) "zz+ sumene from enesc=",sumenep - costsave=cost2tab(i+1) - sintsave=sint2tab(i+1) - cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) - sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dt_num=(sumenep-sumene)/aincr - write (2,*) " t+ sumene from enesc=",sumenep - cost2tab(i+1)=costsave - sint2tab(i+1)=sintsave -C End of diagnostics section. -#endif -C -C Compute the gradient of esc -C - pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 - pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 - pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 - pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 - pom_dx=dsc_i*dp2_i*cost2tab(i+1) - pom_dy=dsc_i*dp2_i*sint2tab(i+1) - pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) - pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) - pom1=(sumene3*sint2tab(i+1)+sumene1) - & *(pom_s1/dscp1+pom_s16*dscp1**4) - pom2=(sumene4*cost2tab(i+1)+sumene2) - & *(pom_s2/dscp2+pom_s26*dscp2**4) - sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy - sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 - & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) - & +x(40)*yy*zz - sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy - sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 - & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) - & +x(60)*yy*zz - de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) - & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) - & +(pom1+pom2)*pom_dx -#ifdef DEBUG - write(2,*), "de_dxx = ", de_dxx,de_dxx_num -#endif -C - sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz - sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 - & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) - & +x(40)*xx*zz - sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz - sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz - & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz - & +x(59)*zz**2 +x(60)*xx*zz - de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) - & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) - & +(pom1-pom2)*pom_dy -#ifdef DEBUG - write(2,*), "de_dyy = ", de_dyy,de_dyy_num -#endif -C - de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy - & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx - & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) - & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) - & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 - & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy - & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) - & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) -#ifdef DEBUG - write(2,*), "de_dzz = ", de_dzz,de_dzz_num -#endif -C - de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) - & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) - & +pom1*pom_dt1+pom2*pom_dt2 -#ifdef DEBUG - write(2,*), "de_dt = ", de_dt,de_dt_num -#endif -c -C - cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) - cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) - cosfac2xx=cosfac2*xx - sinfac2yy=sinfac2*yy - do k = 1,3 - dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* - & vbld_inv(i+1) - dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* - & vbld_inv(i) - pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) - pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) -c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, -c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) -c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), -c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) - dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx - dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx - dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy - dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy - dZZ_Ci1(k)=0.0d0 - dZZ_Ci(k)=0.0d0 - do j=1,3 - dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres) - dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres) - enddo - - dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) - dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) - dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) -c - dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) - dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) - enddo - - do k=1,3 - dXX_Ctab(k,i)=dXX_Ci(k) - dXX_C1tab(k,i)=dXX_Ci1(k) - dYY_Ctab(k,i)=dYY_Ci(k) - dYY_C1tab(k,i)=dYY_Ci1(k) - dZZ_Ctab(k,i)=dZZ_Ci(k) - dZZ_C1tab(k,i)=dZZ_Ci1(k) - dXX_XYZtab(k,i)=dXX_XYZ(k) - dYY_XYZtab(k,i)=dYY_XYZ(k) - dZZ_XYZtab(k,i)=dZZ_XYZ(k) - enddo - - do k = 1,3 -c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", -c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) -c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", -c & dyy_ci(k)," dzz_ci",dzz_ci(k) -c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", -c & dt_dci(k) -c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", -c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) - gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) - & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) - gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) - & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) - gsclocx(k,i)= de_dxx*dxx_XYZ(k) - & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) - enddo -c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), -c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) - -C to check gradient call subroutine check_grad - - 1 continue - enddo - return - end -c------------------------------------------------------------------------------ - double precision function enesc(x,xx,yy,zz,cost2,sint2) - implicit none - double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2, - & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6 - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2+yy*sint2)) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2-yy*sint2)) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) - & + (sumene4*cost2 +sumene2)*(s2+s2_6) - enesc=sumene - return - end -#endif -c------------------------------------------------------------------------------ - subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) -C -C This procedure calculates two-body contact function g(rij) and its derivative: -C -C eps0ij ! x < -1 -C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 -C 0 ! x > 1 -C -C where x=(rij-r0ij)/delta -C -C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy -C - implicit none - double precision rij,r0ij,eps0ij,fcont,fprimcont - double precision x,x2,x4,delta -c delta=0.02D0*r0ij -c delta=0.2D0*r0ij - x=(rij-r0ij)/delta - if (x.lt.-1.0D0) then - fcont=eps0ij - fprimcont=0.0D0 - else if (x.le.1.0D0) then - x2=x*x - x4=x2*x2 - fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) - fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta - else - fcont=0.0D0 - fprimcont=0.0D0 - endif - return - end -c------------------------------------------------------------------------------ - subroutine splinthet(theti,delta,ss,ssder) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - thetup=pi-delta - thetlow=delta - if (theti.gt.pipol) then - call gcont(theti,thetup,1.0d0,delta,ss,ssder) - else - call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) - ssder=-ssder - endif - return - end -c------------------------------------------------------------------------------ - subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) - implicit none - double precision x,x0,delta,f0,f1,fprim0,f,fprim - double precision ksi,ksi2,ksi3,a1,a2,a3 - a1=fprim0*delta/(f1-f0) - a2=3.0d0-2.0d0*a1 - a3=a1-2.0d0 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) - fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) - return - end -c------------------------------------------------------------------------------ - subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) - implicit none - double precision x,x0,delta,f0x,f1x,fprim0x,fx - double precision ksi,ksi2,ksi3,a1,a2,a3 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - a1=fprim0x*delta - a2=3*(f1x-f0x)-2*fprim0x*delta - a3=fprim0x*delta-2*(f1x-f0x) - fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 - return - end -C----------------------------------------------------------------------------- -#ifdef CRYST_TOR -C----------------------------------------------------------------------------- - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - etors_ii=0.0D0 - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -C Proline-Proline pair is a special case... - if (itori.eq.3 .and. itori1.eq.3) then - if (phii.gt.-dwapi3) then - cosphi=dcos(3*phii) - fac=1.0D0/(1.0D0-cosphi) - etorsi=v1(1,3,3)*fac - etorsi=etorsi+etorsi - etors=etors+etorsi-v1(1,3,3) - if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) - gloci=gloci-3*fac*etorsi*dsin(3*phii) - endif - do j=1,3 - v1ij=v1(j+1,itori,itori1) - v2ij=v2(j+1,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ - & v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - else - do j=1,nterm_old - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ - & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - endif - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'etor',i,etors_ii - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 - do i=1,ndih_constr - itori=idih_constr(i) - phii=phi(itori) - difi=phii-phi0(i) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - endif -! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, -! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -! write (iout,*) 'edihcnstr',edihcnstr - return - end -c------------------------------------------------------------------------------ - subroutine etor_d(etors_d) - etors_d=0.0d0 - return - end -c---------------------------------------------------------------------------- -#else - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - etors_ii=0.0D0 - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -C Regular cosine and sine terms - do j=1,nterm(itori,itori1) - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi - if (energy_dec) etors_ii=etors_ii+ - & v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo -C Lorentz terms -C v1 -C E = SUM ----------------------------------- - v1 -C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 -C - cosphi=dcos(0.5d0*phii) - sinphi=dsin(0.5d0*phii) - do j=1,nlor(itori,itori1) - vl1ij=vlor1(j,itori,itori1) - vl2ij=vlor2(j,itori,itori1) - vl3ij=vlor3(j,itori,itori1) - pom=vl2ij*cosphi+vl3ij*sinphi - pom1=1.0d0/(pom*pom+1.0d0) - etors=etors+vl1ij*pom1 - if (energy_dec) etors_ii=etors_ii+ - & vl1ij*pom1 - pom=-pom*pom1*pom1 - gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom - enddo -C Subtract the constant term - etors=etors-v0(itori,itori1) - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'etor',i,etors_ii-v0(itori,itori1) - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 -c do i=1,ndih_constr - do i=idihconstr_start,idihconstr_end - itori=idih_constr(i) - phii=phi(itori) - difi=pinorm(phii-phi0(i)) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else - difi=0.0 - endif -cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, -cd & rad2deg*phi0(i), rad2deg*drange(i), -cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -cd write (iout,*) 'edihcnstr',edihcnstr - return - end -c---------------------------------------------------------------------------- - subroutine etor_d(etors_d) -C 6/23/01 Compute double torsional energy - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors_d=0.0D0 - do i=iphid_start,iphid_end - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - itori2=itortyp(itype(i)) - phii=phi(i) - phii1=phi(i+1) - gloci1=0.0D0 - gloci2=0.0D0 -C Regular cosine and sine terms - do j=1,ntermd_1(itori,itori1,itori2) - v1cij=v1c(1,j,itori,itori1,itori2) - v1sij=v1s(1,j,itori,itori1,itori2) - v2cij=v1c(2,j,itori,itori1,itori2) - v2sij=v1s(2,j,itori,itori1,itori2) - cosphi1=dcos(j*phii) - sinphi1=dsin(j*phii) - cosphi2=dcos(j*phii1) - sinphi2=dsin(j*phii1) - etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ - & v2cij*cosphi2+v2sij*sinphi2 - gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) - gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) - enddo - do k=2,ntermd_2(itori,itori1,itori2) - do l=1,k-1 - v1cdij = v2c(k,l,itori,itori1,itori2) - v2cdij = v2c(l,k,itori,itori1,itori2) - v1sdij = v2s(k,l,itori,itori1,itori2) - v2sdij = v2s(l,k,itori,itori1,itori2) - cosphi1p2=dcos(l*phii+(k-l)*phii1) - cosphi1m2=dcos(l*phii-(k-l)*phii1) - sinphi1p2=dsin(l*phii+(k-l)*phii1) - sinphi1m2=dsin(l*phii-(k-l)*phii1) - etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ - & v1sdij*sinphi1p2+v2sdij*sinphi1m2 - gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) - gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) - enddo - enddo - gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 - gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 - enddo - return - end -#endif -c------------------------------------------------------------------------------ - subroutine eback_sc_corr(esccor) -c 7/21/2007 Correlations between the backbone-local and side-chain-local -c conformational states; temporarily implemented as differences -c between UNRES torsional potentials (dependent on three types of -c residues) and the torsional potentials dependent on all 20 types -c of residues computed from AM1 energy surfaces of terminally-blocked -c amino-acid residues. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.SCCOR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. -c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor - esccor=0.0D0 - do i=iphi_start,iphi_end - esccor_ii=0.0D0 - itori=itype(i-2) - itori1=itype(i-1) - phii=phi(i) - gloci=0.0D0 - do j=1,nterm_sccor - v1ij=v1sccor(j,itori,itori1) - v2ij=v2sccor(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - esccor=esccor+v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6) - gsccor_loc(i-3)=gsccor_loc(i-3)+gloci - enddo - return - end -c---------------------------------------------------------------------------- - subroutine multibody(ecorr) -C This subroutine calculates multi-body contributions to energy following -C the idea of Skolnick et al. If side chains I and J make a contact and -C at the same time side chains I+1 and J+1 make a contact, an extra -C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - -C Set lprn=.true. for debugging - lprn=.false. - - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(i2,20(1x,i2,f10.5))') - & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) - enddo - endif - ecorr=0.0D0 - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo - do i=nnt,nct-2 - - DO ISHIFT = 3,4 - - i1=i+ishift - num_conti=num_cont(i) - num_conti1=num_cont(i1) - do jj=1,num_conti - j=jcont(jj,i) - do kk=1,num_conti1 - j1=jcont(kk,i1) - if (j1.eq.j+ishift .or. j1.eq.j-ishift) then -cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, -cd & ' ishift=',ishift -C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) - endif ! j1==j+-ishift - enddo ! kk - enddo ! jj - - ENDDO ! ISHIFT - - enddo ! i - return - end -c------------------------------------------------------------------------------ - double precision function esccorr(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont(jj,i) - ekl=facont(kk,k) -cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl -C Calculate the multi-body contribution to energy. -C Calculate multi-body contributions to the gradient. -cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), -cd & k,l,(gacont(m,kk,k),m=1,3) - do m=1,3 - gx(m) =ekl*gacont(m,jj,i) - gx1(m)=eij*gacont(m,kk,k) - gradxorr(m,i)=gradxorr(m,i)-gx(m) - gradxorr(m,j)=gradxorr(m,j)+gx(m) - gradxorr(m,k)=gradxorr(m,k)-gx1(m) - gradxorr(m,l)=gradxorr(m,l)+gx1(m) - enddo - do m=i,j-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) - enddo - enddo - do m=k,l-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) - enddo - enddo - esccorr=-eij*ekl - return - end -c------------------------------------------------------------------------------ - subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPI - include "mpif.h" - parameter (max_cont=maxconts) - parameter (max_dim=26) - integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer status(MPI_STATUS_SIZE),req(maxconts*2), - & status_array(MPI_STATUS_SIZE,maxconts*2) -#endif - include 'COMMON.SETUP' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.LOCAL' - double precision gx(3),gx1(3),time00 - logical lprn,ldone - -C Set lprn=.true. for debugging - lprn=.false. -#ifdef MPI - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values before RECEIVE:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", -c & ntask_cont_to -C Make the list of contacts to send to send to other procesors -c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end -c call flush(iout) - do i=iturn3_start,iturn3_end -c write (iout,*) "make contact list turn3",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact(i,i+2,iturn3_sent_local(1,i)) - enddo - do i=iturn4_start,iturn4_end -c write (iout,*) "make contact list turn4",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact(i,i+3,iturn4_sent_local(1,i)) - enddo - do ii=1,nat_sent - i=iat_sent(ii) -c write (iout,*) "make contact list longrange",i,ii," num_cont", -c & num_cont_hb(i) - do j=1,num_cont_hb(i) - do k=1,4 - jjc=jcont_hb(j,i) - iproc=iint_sent_local(k,jjc,ii) -c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc - if (iproc.gt.0) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=i - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=facont_hb(j,i) - zapas(4,nn,iproc)=ees0p(j,i) - zapas(5,nn,iproc)=ees0m(j,i) - zapas(6,nn,iproc)=gacont_hbr(1,j,i) - zapas(7,nn,iproc)=gacont_hbr(2,j,i) - zapas(8,nn,iproc)=gacont_hbr(3,j,i) - zapas(9,nn,iproc)=gacontm_hb1(1,j,i) - zapas(10,nn,iproc)=gacontm_hb1(2,j,i) - zapas(11,nn,iproc)=gacontm_hb1(3,j,i) - zapas(12,nn,iproc)=gacontp_hb1(1,j,i) - zapas(13,nn,iproc)=gacontp_hb1(2,j,i) - zapas(14,nn,iproc)=gacontp_hb1(3,j,i) - zapas(15,nn,iproc)=gacontm_hb2(1,j,i) - zapas(16,nn,iproc)=gacontm_hb2(2,j,i) - zapas(17,nn,iproc)=gacontm_hb2(3,j,i) - zapas(18,nn,iproc)=gacontp_hb2(1,j,i) - zapas(19,nn,iproc)=gacontp_hb2(2,j,i) - zapas(20,nn,iproc)=gacontp_hb2(3,j,i) - zapas(21,nn,iproc)=gacontm_hb3(1,j,i) - zapas(22,nn,iproc)=gacontm_hb3(2,j,i) - zapas(23,nn,iproc)=gacontm_hb3(3,j,i) - zapas(24,nn,iproc)=gacontp_hb3(1,j,i) - zapas(25,nn,iproc)=gacontp_hb3(2,j,i) - zapas(26,nn,iproc)=gacontp_hb3(3,j,i) - endif - enddo - enddo - enddo - if (lprn) then - write (iout,*) - & "Numbers of contacts to be sent to other processors", - & (ncont_sent(i),i=1,ntask_cont_to) - write (iout,*) "Contacts sent" - do ii=1,ntask_cont_to - nn=ncont_sent(ii) - iproc=itask_cont_to(ii) - write (iout,*) nn," contacts to processor",iproc, - & " of CONT_TO_COMM group" - do i=1,nn - write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) - enddo - enddo - call flush(iout) - endif - CorrelType=477 - CorrelID=fg_rank+1 - CorrelType1=478 - CorrelID1=nfgtasks+fg_rank+1 - ireq=0 -C Receive the numbers of needed contacts from other processors - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - ireq=ireq+1 - call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "IRECV ended" -c call flush(iout) -C Send the number of contacts needed by other processors - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - ireq=ireq+1 - call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "ISEND ended" -c write (iout,*) "number of requests (nn)",ireq - call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) -c write (iout,*) -c & "Numbers of contacts to be received from other processors", -c & (ncont_recv(i),i=1,ntask_cont_from) -c call flush(iout) -C Receive contacts - ireq=0 - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - nn=ncont_recv(ii) -c write (iout,*) "Receiving",nn," contacts from processor",iproc, -c & " of CONT_TO_COMM group" - call flush(iout) - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, - & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) - endif - enddo -C Send the contacts to processors that need them - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - nn=ncont_sent(ii) -c write (iout,*) nn," contacts to processor",iproc, -c & " of CONT_TO_COMM group" - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, - & iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) -c do i=1,nn -c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) -c enddo - endif - enddo -c write (iout,*) "number of requests (contacts)",ireq -c write (iout,*) "req",(req(i),i=1,4) -c call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) - do iii=1,ntask_cont_from - iproc=itask_cont_from(iii) - nn=ncont_recv(iii) - if (lprn) then - write (iout,*) "Received",nn," contacts from processor",iproc, - & " of CONT_FROM_COMM group" - call flush(iout) - do i=1,nn - write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5) - enddo - call flush(iout) - endif - do i=1,nn - ii=zapas_recv(1,i,iii) -c Flag the received contacts to prevent double-counting - jj=-zapas_recv(2,i,iii) -c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj -c call flush(iout) - nnn=num_cont_hb(ii)+1 - num_cont_hb(ii)=nnn - jcont_hb(nnn,ii)=jj - facont_hb(nnn,ii)=zapas_recv(3,i,iii) - ees0p(nnn,ii)=zapas_recv(4,i,iii) - ees0m(nnn,ii)=zapas_recv(5,i,iii) - gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii) - gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii) - gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii) - gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii) - gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii) - gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii) - gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii) - gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii) - gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii) - gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii) - gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii) - gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii) - gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii) - gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii) - gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii) - gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii) - gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii) - gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii) - gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii) - gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii) - gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii) - enddo - enddo - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 -C Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -C Calculate the local-electrostatic correlation terms - do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end) - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - jp=iabs(j) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) - jp1=iabs(j1) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 - & .or. j.lt.0 .and. j1.gt.0) .and. - & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then -C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) - n_corr=n_corr+1 - else if (j1.eq.j) then -C Contacts I-J and I-(J+1) occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) - endif - enddo ! kk - do kk=1,num_conti - j1=jcont_hb(kk,i) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if (j1.eq.j+1) then -C Contacts I-J and (I+1)-J occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) - endif ! j1==j+1 - enddo ! kk - enddo ! jj - enddo ! i - return - end -c------------------------------------------------------------------------------ - subroutine add_hb_contact(ii,jj,itask) - implicit real*8 (a-h,o-z) - include "DIMENSIONS" - include "COMMON.IOUNITS" - integer max_cont - integer max_dim - parameter (max_cont=maxconts) - parameter (max_dim=26) - include "COMMON.CONTACTS" - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer i,j,ii,jj,iproc,itask(4),nn -c write (iout,*) "itask",itask - do i=1,2 - iproc=itask(i) - if (iproc.gt.0) then - do j=1,num_cont_hb(ii) - jjc=jcont_hb(j,ii) -c write (iout,*) "i",ii," j",jj," jjc",jjc - if (jjc.eq.jj) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=ii - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=facont_hb(j,ii) - zapas(4,nn,iproc)=ees0p(j,ii) - zapas(5,nn,iproc)=ees0m(j,ii) - zapas(6,nn,iproc)=gacont_hbr(1,j,ii) - zapas(7,nn,iproc)=gacont_hbr(2,j,ii) - zapas(8,nn,iproc)=gacont_hbr(3,j,ii) - zapas(9,nn,iproc)=gacontm_hb1(1,j,ii) - zapas(10,nn,iproc)=gacontm_hb1(2,j,ii) - zapas(11,nn,iproc)=gacontm_hb1(3,j,ii) - zapas(12,nn,iproc)=gacontp_hb1(1,j,ii) - zapas(13,nn,iproc)=gacontp_hb1(2,j,ii) - zapas(14,nn,iproc)=gacontp_hb1(3,j,ii) - zapas(15,nn,iproc)=gacontm_hb2(1,j,ii) - zapas(16,nn,iproc)=gacontm_hb2(2,j,ii) - zapas(17,nn,iproc)=gacontm_hb2(3,j,ii) - zapas(18,nn,iproc)=gacontp_hb2(1,j,ii) - zapas(19,nn,iproc)=gacontp_hb2(2,j,ii) - zapas(20,nn,iproc)=gacontp_hb2(3,j,ii) - zapas(21,nn,iproc)=gacontm_hb3(1,j,ii) - zapas(22,nn,iproc)=gacontm_hb3(2,j,ii) - zapas(23,nn,iproc)=gacontm_hb3(3,j,ii) - zapas(24,nn,iproc)=gacontp_hb3(1,j,ii) - zapas(25,nn,iproc)=gacontp_hb3(2,j,ii) - zapas(26,nn,iproc)=gacontp_hb3(3,j,ii) - exit - endif - enddo - endif - enddo - return - end -c------------------------------------------------------------------------------ - subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, - & n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPI - include "mpif.h" - parameter (max_cont=maxconts) - parameter (max_dim=70) - integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer status(MPI_STATUS_SIZE),req(maxconts*2), - & status_array(MPI_STATUS_SIZE,maxconts*2) -#endif - include 'COMMON.SETUP' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.CONTROL' - double precision gx(3),gx1(3) - integer num_cont_hb_old(maxres) - logical lprn,ldone - double precision eello4,eello5,eelo6,eello_turn6 - external eello4,eello5,eello6,eello_turn6 -C Set lprn=.true. for debugging - lprn=.false. - eturn6=0.0d0 -#ifdef MPI - do i=1,nres - num_cont_hb_old(i)=num_cont_hb(i) - enddo - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values before RECEIVE:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", -c & ntask_cont_to -C Make the list of contacts to send to send to other procesors - do i=iturn3_start,iturn3_end -c write (iout,*) "make contact list turn3",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i)) - enddo - do i=iturn4_start,iturn4_end -c write (iout,*) "make contact list turn4",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i)) - enddo - do ii=1,nat_sent - i=iat_sent(ii) -c write (iout,*) "make contact list longrange",i,ii," num_cont", -c & num_cont_hb(i) - do j=1,num_cont_hb(i) - do k=1,4 - jjc=jcont_hb(j,i) - iproc=iint_sent_local(k,jjc,ii) -c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc - if (iproc.ne.0) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=i - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=d_cont(j,i) - ind=3 - do kk=1,3 - ind=ind+1 - zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i) - enddo - enddo - enddo - enddo - endif - enddo - enddo - enddo - if (lprn) then - write (iout,*) - & "Numbers of contacts to be sent to other processors", - & (ncont_sent(i),i=1,ntask_cont_to) - write (iout,*) "Contacts sent" - do ii=1,ntask_cont_to - nn=ncont_sent(ii) - iproc=itask_cont_to(ii) - write (iout,*) nn," contacts to processor",iproc, - & " of CONT_TO_COMM group" - do i=1,nn - write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10) - enddo - enddo - call flush(iout) - endif - CorrelType=477 - CorrelID=fg_rank+1 - CorrelType1=478 - CorrelID1=nfgtasks+fg_rank+1 - ireq=0 -C Receive the numbers of needed contacts from other processors - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - ireq=ireq+1 - call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "IRECV ended" -c call flush(iout) -C Send the number of contacts needed by other processors - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - ireq=ireq+1 - call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "ISEND ended" -c write (iout,*) "number of requests (nn)",ireq - call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) -c write (iout,*) -c & "Numbers of contacts to be received from other processors", -c & (ncont_recv(i),i=1,ntask_cont_from) -c call flush(iout) -C Receive contacts - ireq=0 - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - nn=ncont_recv(ii) -c write (iout,*) "Receiving",nn," contacts from processor",iproc, -c & " of CONT_TO_COMM group" - call flush(iout) - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, - & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) - endif - enddo -C Send the contacts to processors that need them - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - nn=ncont_sent(ii) -c write (iout,*) nn," contacts to processor",iproc, -c & " of CONT_TO_COMM group" - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, - & iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) -c do i=1,nn -c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) -c enddo - endif - enddo -c write (iout,*) "number of requests (contacts)",ireq -c write (iout,*) "req",(req(i),i=1,4) -c call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) - do iii=1,ntask_cont_from - iproc=itask_cont_from(iii) - nn=ncont_recv(iii) - if (lprn) then - write (iout,*) "Received",nn," contacts from processor",iproc, - & " of CONT_FROM_COMM group" - call flush(iout) - do i=1,nn - write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10) - enddo - call flush(iout) - endif - do i=1,nn - ii=zapas_recv(1,i,iii) -c Flag the received contacts to prevent double-counting - jj=-zapas_recv(2,i,iii) -c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj -c call flush(iout) - nnn=num_cont_hb(ii)+1 - num_cont_hb(ii)=nnn - jcont_hb(nnn,ii)=jj - d_cont(nnn,ii)=zapas_recv(3,i,iii) - ind=3 - do kk=1,3 - ind=ind+1 - grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii) - enddo - enddo - enddo - enddo - enddo - enddo - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,5f6.3))') - & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), - & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,5f6.3))') - & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), - & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 - ecorr5=0.0d0 - ecorr6=0.0d0 -C Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -C Calculate the dipole-dipole interaction energies - if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then - do i=iatel_s,iatel_e+1 - num_conti=num_cont_hb(i) - do jj=1,num_conti - j=jcont_hb(jj,i) -#ifdef MOMENT - call dipole(i,j,jj) -#endif - enddo - enddo - endif -C Calculate the local-electrostatic correlation terms -c write (iout,*) "gradcorr5 in eello5 before loop" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) -c write (iout,*) "corr loop i",i - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - jp=iabs(j) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) - jp1=iabs(j1) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk -c if (j1.eq.j+1 .or. j1.eq.j-1) then - if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 - & .or. j.lt.0 .and. j1.gt.0) .and. - & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then -C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -C The system gains extra energy. - n_corr=n_corr+1 - sqd1=dsqrt(d_cont(jj,i)) - sqd2=dsqrt(d_cont(kk,i1)) - sred_geom = sqd1*sqd2 - IF (sred_geom.lt.cutoff_corr) THEN - call gcont(sred_geom,r0_corr,1.0D0,delt_corr, - & ekont,fprimcont) -cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, -cd & ' jj=',jj,' kk=',kk - fac_prim1=0.5d0*sqd2/sqd1*fprimcont - fac_prim2=0.5d0*sqd1/sqd2*fprimcont - do l=1,3 - g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) - g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) - enddo - n_corr1=n_corr1+1 -cd write (iout,*) 'sred_geom=',sred_geom, -cd & ' ekont=',ekont,' fprim=',fprimcont, -cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 -cd write (iout,*) "g_contij",g_contij -cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) -cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) - call calc_eello(i,jp,i+1,jp1,jj,kk) - if (wcorr4.gt.0.0d0) - & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) - if (energy_dec.and.wcorr4.gt.0.0d0) - 1 write (iout,'(a6,4i5,0pf7.3)') - 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) -c write (iout,*) "gradcorr5 before eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - if (wcorr5.gt.0.0d0) - & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) -c write (iout,*) "gradcorr5 after eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - if (energy_dec.and.wcorr5.gt.0.0d0) - 1 write (iout,'(a6,4i5,0pf7.3)') - 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) -cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 -cd write(2,*)'ijkl',i,jp,i+1,jp1 - if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 - & .or. wturn6.eq.0.0d0))then -cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 - ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) - if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') - 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) -cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, -cd & 'ecorr6=',ecorr6 -cd write (iout,'(4e15.5)') sred_geom, -cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)), -cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)), -cd & dabs(eello6(i,jp,i+1,jp1,jj,kk)) - else if (wturn6.gt.0.0d0 - & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then -cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 - eturn6=eturn6+eello_turn6(i,jj,kk) - if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') - 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) -cd write (2,*) 'multibody_eello:eturn6',eturn6 - endif - ENDIF -1111 continue - endif - enddo ! kk - enddo ! jj - enddo ! i - do i=1,nres - num_cont_hb(i)=num_cont_hb_old(i) - enddo -c write (iout,*) "gradcorr5 in eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - return - end -c------------------------------------------------------------------------------ - subroutine add_hb_contact_eello(ii,jj,itask) - implicit real*8 (a-h,o-z) - include "DIMENSIONS" - include "COMMON.IOUNITS" - integer max_cont - integer max_dim - parameter (max_cont=maxconts) - parameter (max_dim=70) - include "COMMON.CONTACTS" - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer i,j,ii,jj,iproc,itask(4),nn -c write (iout,*) "itask",itask - do i=1,2 - iproc=itask(i) - if (iproc.gt.0) then - do j=1,num_cont_hb(ii) - jjc=jcont_hb(j,ii) -c write (iout,*) "send turns i",ii," j",jj," jjc",jjc - if (jjc.eq.jj) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=ii - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=d_cont(j,ii) - ind=3 - do kk=1,3 - ind=ind+1 - zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii) - enddo - enddo - enddo - enddo - exit - endif - enddo - endif - enddo - return - end -c------------------------------------------------------------------------------ - double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont_hb(jj,i) - ekl=facont_hb(kk,k) - ees0pij=ees0p(jj,i) - ees0pkl=ees0p(kk,k) - ees0mij=ees0m(jj,i) - ees0mkl=ees0m(kk,k) - ekont=eij*ekl - ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) -cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) -C Following 4 lines for diagnostics. -cd ees0pkl=0.0D0 -cd ees0pij=1.0D0 -cd ees0mkl=0.0D0 -cd ees0mij=1.0D0 -c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') -c & 'Contacts ',i,j, -c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l -c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, -c & 'gradcorr_long' -C Calculate the multi-body contribution to energy. -c ecorr=ecorr+ekont*ees -C Calculate multi-body contributions to the gradient. - coeffpees0pij=coeffp*ees0pij - coeffmees0mij=coeffm*ees0mij - coeffpees0pkl=coeffp*ees0pkl - coeffmees0mkl=coeffm*ees0mkl - do ll=1,3 -cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) - gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi - & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb1(ll,jj,i)) - gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi - & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb2(ll,jj,i)) -cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k) - gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk - & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ - & coeffmees0mij*gacontm_hb1(ll,kk,k)) - gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk - & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ - & coeffmees0mij*gacontm_hb2(ll,kk,k)) - gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- - & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb3(ll,jj,i)) - gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij - gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij - gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- - & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ - & coeffmees0mij*gacontm_hb3(ll,kk,k)) - gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl - gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl -c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl - enddo -c write (iout,*) -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ -cgrad & ees*ekl*gacont_hbr(ll,jj,i)- -cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ -cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ -cgrad & ees*eij*gacont_hbr(ll,kk,k)- -cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ -cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) -cgrad enddo -cgrad enddo -c write (iout,*) "ehbcorr",ekont*ees - ehbcorr=ekont*ees - return - end -#ifdef MOMENT -C--------------------------------------------------------------------------- - subroutine dipole(i,j,jj) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), - & auxmat(2,2) - iti1 = itortyp(itype(i+1)) - if (j.lt.nres-1) then - itj1 = itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - do iii=1,2 - dipi(iii,1)=Ub2(iii,i) - dipderi(iii)=Ub2der(iii,i) - dipi(iii,2)=b1(iii,iti1) - dipj(iii,1)=Ub2(iii,j) - dipderj(iii)=Ub2der(iii,j) - dipj(iii,2)=b1(iii,itj1) - enddo - kkk=0 - do iii=1,2 - call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) - do jjj=1,2 - kkk=kkk+1 - dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - do kkk=1,5 - do lll=1,3 - mmm=0 - do iii=1,2 - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), - & auxvec(1)) - do jjj=1,2 - mmm=mmm+1 - dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - enddo - enddo - call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) - call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) - do iii=1,2 - dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) - enddo - call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) - do iii=1,2 - dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) - enddo - return - end -#endif -C--------------------------------------------------------------------------- - subroutine calc_eello(i,j,k,l,jj,kk) -C -C This subroutine computes matrices and vectors needed to calculate -C the fourth-, fifth-, and sixth-order local-electrostatic terms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), - & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) - logical lprn - common /kutas/ lprn -cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, -cd & ' jj=',jj,' kk=',kk -cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return -cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) -cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) - aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) - enddo - enddo - call transpose2(aa1(1,1),aa1t(1,1)) - call transpose2(aa2(1,1),aa2t(1,1)) - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), - & aa1tder(1,1,lll,kkk)) - call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), - & aa2tder(1,1,lll,kkk)) - enddo - enddo - if (l.eq.j+1) then -C parallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itj=itortyp(itype(j)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -C A1 kernel(j+1) A2T -cd do iii=1,2 -cd write (iout,'(3f10.5,5x,3f10.5)') -cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) -cd enddo - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), - & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - lprn=.false. - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), - & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants -cd lprn=.false. -cd if (lprn) then -cd write (2,*) 'In calc_eello6' -cd do iii=1,2 -cd write (2,*) 'iii=',iii -cd do kkk=1,5 -cd write (2,*) 'kkk=',kkk -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) -cd enddo -cd enddo -cd enddo -cd endif - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A1T kernel(i+1) A2 - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) -C Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - else -C Antiparallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif -C A2 kernel(j-1)T A1T - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. - & j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), - & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), - & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A2T kernel(i+1)T A1 - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. - & j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. - & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) -C Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - endif - return - end -C--------------------------------------------------------------------------- - subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, - & KK,KKderg,AKA,AKAderg,AKAderx) - implicit none - integer nderg - logical transp - double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), - & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), - & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) - integer iii,kkk,lll - integer jjj,mmm - logical lprn - common /kutas/ lprn - call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) - do iii=1,nderg - call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, - & AKAderg(1,1,iii)) - enddo -cd if (lprn) write (2,*) 'In kernel' - do kkk=1,5 -cd if (lprn) write (2,*) 'kkk=',kkk - do lll=1,3 - call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), - & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) -cd if (lprn) then -cd write (2,*) 'lll=',lll -cd write (2,*) 'iii=1' -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) -cd enddo -cd endif - call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), - & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) -cd if (lprn) then -cd write (2,*) 'lll=',lll -cd write (2,*) 'iii=2' -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) -cd enddo -cd endif - enddo - enddo - return - end -C--------------------------------------------------------------------------- - double precision function eello4(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then -cd eello4=0.0d0 -cd return -cd endif -cd print *,'eello4:',i,j,k,l,jj,kk -cd write (2,*) 'i',i,' j',j,' k',k,' l',l -cd call checkint4(i,j,k,l,jj,kk,eel4_num) -cold eij=facont_hb(jj,i) -cold ekl=facont_hb(kk,k) -cold ekont=eij*ekl - eel4=-EAEA(1,1,1)-EAEA(2,2,1) -cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) - gcorr_loc(k-1)=gcorr_loc(k-1) - & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) - if (l.eq.j+1) then - gcorr_loc(l-1)=gcorr_loc(l-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - else - gcorr_loc(j-1)=gcorr_loc(j-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) - & -EAEAderx(2,2,lll,kkk,iii,1) -cd derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd gcorr_loc(l-1)=0.0d0 -cd gcorr_loc(j-1)=0.0d0 -cd gcorr_loc(k-1)=0.0d0 -cd eel4=1.0d0 -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l, -cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel4*g_contij(ll,1) -cgrad ggg2(ll)=eel4*g_contij(ll,2) - glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) - glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) -cgrad ghalf=0.5d0*ggg1(ll) - gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) - gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) - gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) - gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) - gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij - gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij -cgrad ghalf=0.5d0*ggg2(ll) - gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) - gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) - gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) - gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) - gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl - gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl - enddo -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,gcorr_loc(iii) -cd enddo - eello4=ekont*eel4 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello4',ekont*eel4 - return - end -C--------------------------------------------------------------------------- - double precision function eello5(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) - double precision ggg1(3),ggg2(3) -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel chains C -C C -C o o o o C -C /l\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j| o |l1 | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C Antiparallel chains C -C C -C o o o o C -C /j\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j1| o |l | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C o denotes a local interaction, vertical lines an electrostatic interaction. C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then -cd eello5=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - itk=itortyp(itype(k)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - eello5_1=0.0d0 - eello5_2=0.0d0 - eello5_3=0.0d0 - eello5_4=0.0d0 -cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, -cd & eel5_3_num,eel5_4_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l -cd goto 1111 -C Contribution from the graph I. -cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) -cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) -C Explicit gradient in virtual-dihedral angles. - if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - if (l.eq.j+1) then - if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - else - if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) - enddo - enddo - enddo -c goto 1112 -c1111 continue -C Contribution from graph II - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - if (l.eq.j+1) then - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - else - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) - enddo - enddo - enddo -cd goto 1112 -cd1111 continue - if (l.eq.j+1) then -cd goto 1110 -C Parallel orientation -C Contribution from graph III - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) - call transpose2(EUgder(1,1,l),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) - enddo - enddo - enddo -cd goto 1112 -C Contribution from graph IV -cd1110 continue - call transpose2(EE(1,1,itl),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) - enddo - enddo - enddo - else -C Antiparallel orientation -C Contribution from graph III -c goto 1110 - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) - call transpose2(EUgder(1,1,j),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) - enddo - enddo - enddo -cd goto 1112 -C Contribution from graph IV -1110 continue - call transpose2(EE(1,1,itj),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) - enddo - enddo - enddo - endif -1112 continue - eel5=eello5_1+eello5_2+eello5_3+eello5_4 -cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then -cd write (2,*) 'ijkl',i,j,k,l -cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, -cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 -cd endif -cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num -cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num -cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num -cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 -cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont -C 2/11/08 AL Gradients over DC's connecting interacting sites will be -C summed up outside the subrouine as for the other subroutines -C handling long-range interactions. The old code is commented out -C with "cgrad" to keep track of changes. - do ll=1,3 -cgrad ggg1(ll)=eel5*g_contij(ll,1) -cgrad ggg2(ll)=eel5*g_contij(ll,2) - gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) - gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) -c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') -c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), -c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), -c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont -c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') -c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), -c & gradcorr5ij, -c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl -cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) - gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) - gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) - gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) - gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij - gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij -cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) -cgrad ghalf=0.5d0*ggg2(ll) -cd ghalf=0.0d0 - gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) - gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) - gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) - gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) - gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl - gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -c1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr5_loc(iii) -cd enddo - eello5=ekont*eel5 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello5',ekont*eel5 - return - end -c-------------------------------------------------------------------------- - double precision function eello6(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - eello6_1=0.0d0 - eello6_2=0.0d0 - eello6_3=0.0d0 - eello6_4=0.0d0 - eello6_5=0.0d0 - eello6_6=0.0d0 -cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, -cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - if (l.eq.j+1) then - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(j,i,l,k,2,.false.) - eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) - eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) - else - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(l,k,j,i,2,.true.) - eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - if (wturn6.eq.0.0d0 .or. j.ne.i+4) then - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) - else - eello6_5=0.0d0 - endif - eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) - endif -C If turn contributions are considered, they will be handled separately. - eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 -cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num -cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num -cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num -cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num -cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num -cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num -cd goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel6*g_contij(ll,1) -cgrad ggg2(ll)=eel6*g_contij(ll,2) -cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) - gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) - gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) - gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) - gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) - gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) - gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij - gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij -cgrad ghalf=0.5d0*ggg2(ll) -cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) -cd ghalf=0.0d0 - gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) - gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) - gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) - gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) - gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl - gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr6_loc(iii) -cd enddo - eello6=ekont*eel6 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello6',ekont*eel6 - return - end -c-------------------------------------------------------------------------- - double precision function eello6_graph1(i,j,k,l,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) - logical swap - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ /j\ C -C / \ / \ C -C /| o | | o |\ C -C \ j|/k\| / \ |/k\|l / C -C \ / \ / \ / \ / C -C o o o o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - itk=itortyp(itype(k)) - s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) - vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 - eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) - if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) - & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) - & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) - & +scalar2(vv(1),Dtobr2der(1,i))) - call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) - vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) - if (l.eq.j+1) then - g_corr6_loc(l-1)=g_corr6_loc(l-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - endif - call transpose2(EUgCder(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) - & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) - & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) - do iii=1,2 - if (swap) then - ind=3-iii - else - ind=iii - endif - do kkk=1,5 - do lll=1,3 - s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) - & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) - vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) - & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) - derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph2(i,j,k,l,jj,kk,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - logical swap - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxvec2(2),auxmat1(2,2) - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C \ /l\ /j\ / C -C \ / \ / \ / C -C o| o | | o |o C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l -C AL 7/4/01 s1 would occur in the sixth-order moment, -C but not in a cluster cumulant -#ifdef MOMENT - s1=dip(1,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph2=-(s1+s2+s3+s4) -#else - eello6_graph2=-(s2+s3+s4) -#endif -c eello6_graph2=-s3 -C Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - s1=dipderg(1,jj,i)*dip(1,kk,k) -#endif - s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif -c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 - endif -C Derivatives in gamma(k-1) -#ifdef MOMENT - s1=dip(1,jj,i)*dipderg(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif -c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 -C Derivatives in gamma(j-1) or gamma(l-1) - if (j.gt.1) then -#ifdef MOMENT - s1=dipderg(3,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) - call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - if (swap) then - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 - endif -#endif - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) -c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 - endif -C Derivatives in gamma(l-1) or gamma(j-1) - if (l.gt.1) then -#ifdef MOMENT - s1=dip(1,jj,i)*dipderg(3,kk,k) -#endif - call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - if (swap) then - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 - else - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 - endif -#endif - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) -c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 - endif -C Cartesian derivatives. - if (lprn) then - write (2,*) 'In eello6_graph2' - do iii=1,2 - write (2,*) 'iii=',iii - do kkk=1,5 - write (2,*) 'kkk=',kkk - do jjj=1,2 - write (2,'(3(2f10.5),5x)') - & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) - enddo - enddo - enddo - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) - else - s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) - endif -#endif - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), - & auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), - & auxvec(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph3(i,j,k,l,jj,kk,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C j|/k\| / |/k\|l / C -C / \ / / \ / C -C / o / o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. - iti=itortyp(itype(i)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -#ifdef MOMENT - s1=dip(4,jj,i)*dip(4,kk,k) -#endif - call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, -cd & "sum",-(s2+s3+s4) -#ifdef MOMENT - eello6_graph3=-(s1+s2+s3+s4) -#else - eello6_graph3=-(s2+s3+s4) -#endif -c eello6_graph3=-s4 -C Derivatives in gamma(k-1) - call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) -C Derivatives in gamma(l-1) - call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) -C Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) - else - s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif -c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxmat1(2,2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o \ o \ C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. -cd write (2,*) 'eello_graph4: wturn6',wturn6 - iti=itortyp(itype(i)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - if (k.lt.nres-1) then - itk1=itortyp(itype(k+1)) - else - itk1=ntortyp+1 - endif - itl=itortyp(itype(l)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l -cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, -cd & ' itl',itl,' itl1',itl1 -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dip(3,kk,k) - else - s1=dip(2,jj,j)*dip(2,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph4=-(s1+s2+s3+s4) -#else - eello6_graph4=-(s2+s3+s4) -#endif -C Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - if (imat.eq.1) then - s1=dipderg(2,jj,i)*dip(3,kk,k) - else - s1=dipderg(4,jj,j)*dip(2,kk,l) - endif -#endif - s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -cd write (2,*) 'turn6 derivatives' -#ifdef MOMENT - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif - endif - endif -C Derivatives in gamma(k-1) -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderg(2,kk,k) - else - s1=dip(2,jj,j)*dipderg(4,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif - endif -C Derivatives in gamma(j-1) or gamma(l-1) - if (l.eq.j+1 .and. l.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) - else if (j.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then - gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) - endif - endif -C Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - if (imat.eq.1) then - s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) - else - s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) - endif - else - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) - else - s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) - endif - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), - & auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itj1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) - else - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itl1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) - endif - call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (swap) then - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s1+s2+s4) -#else - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s2+s4) -#endif - derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 - else -#ifdef MOMENT - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) -#else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) -#endif - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - else -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (l.eq.j+1) then - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - endif - endif - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello_turn6(i,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), - & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), - & ggg1(3),ggg2(3) - double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), - & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) -C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to -C the respective energy moment and not to the cluster cumulant. - s1=0.0d0 - s8=0.0d0 - s13=0.0d0 -c - eello_turn6=0.0d0 - j=i+4 - k=i+1 - l=i+3 - iti=itortyp(itype(i)) - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) -cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj -cd write (2,*) 'i',i,' k',k,' j',j,' l',l -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l -cd call checkint_turn6(i,jj,kk,eel_turn6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx_turn(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) -cd eello6_5=0.0d0 -cd write (2,*) 'eello6_5',eello6_5 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) - ss1=scalar2(Ub2(1,i+2),b1(1,itl)) - s1 = (auxmat(1,1)+auxmat(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) - s2 = scalar2(b1(1,itk),vtemp1(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atemp(1,1)) - call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) - call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) - s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) - s12 = scalar2(Ub2(1,i+2),vtemp3(1)) -#ifdef MOMENT - call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) - call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) - call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) - ss13 = scalar2(b1(1,itk),vtemp4(1)) - s13 = (gtemp(1,1)+gtemp(2,2))*ss13 -#endif -c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 -c s1=0.0d0 -c s2=0.0d0 -c s8=0.0d0 -c s12=0.0d0 -c s13=0.0d0 - eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) -C Derivatives in gamma(i+2) - s1d =0.0d0 - s8d =0.0d0 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 - call transpose2(AEAderg(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 - gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) -C Derivatives in gamma(i+3) -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d -#endif - call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) - s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) -#endif - s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) - & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) - & -0.5d0*ekont*(s2d+s12d) -#endif -C Derivatives in gamma(i+4) - call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -C s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) -#else - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) -#endif -C Derivatives in gamma(i+5) -#ifdef MOMENT - call transpose2(AEAderg(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) - & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) - & -0.5d0*ekont*(s2d+s12d) -#endif -C Cartesian derivatives - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), - & vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))* - & scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), - & auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) - & - 0.5d0*(s1d+s2d) -#else - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) - & - 0.5d0*s2d -#endif -#ifdef MOMENT - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) - & - 0.5d0*(s8d+s12d) -#else - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) - & - 0.5d0*s12d -#endif - enddo - enddo - enddo -#ifdef MOMENT - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), - & achuj_tempd(1,1)) - call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d=(gtempd(1,1)+gtempd(2,2))*ss13 - derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), - & vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d - derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d - enddo - enddo -#endif -cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', -cd & 16*eel_turn6_num -cd goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel_turn6*g_contij(ll,1) -cgrad ggg2(ll)=eel_turn6*g_contij(ll,2) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) - gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) - gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf - & +ekont*derx_turn(ll,2,1) - gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) - gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf - & +ekont*derx_turn(ll,4,1) - gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) - gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij - gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij -cgrad ghalf=0.5d0*ggg2(ll) -cd ghalf=0.0d0 - gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf - & +ekont*derx_turn(ll,2,2) - gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) - gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf - & +ekont*derx_turn(ll,4,2) - gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) - gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl - gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr6_loc(iii) -cd enddo - eello_turn6=ekont*eel_turn6 -cd write (2,*) 'ekont',ekont -cd write (2,*) 'eel_turn6',ekont*eel_turn6 - return - end - -C----------------------------------------------------------------------------- - double precision function scalar(u,v) -!DIR$ INLINEALWAYS scalar -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::scalar -#endif - implicit none - double precision u(3),v(3) -cd double precision sc -cd integer i -cd sc=0.0d0 -cd do i=1,3 -cd sc=sc+u(i)*v(i) -cd enddo -cd scalar=sc - - scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3) - return - end -crc------------------------------------------------- - SUBROUTINE MATVEC2(A1,V1,V2) -!DIR$ INLINEALWAYS MATVEC2 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2 -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),V1(2),V2(2) -c DO 1 I=1,2 -c VI=0.0 -c DO 3 K=1,2 -c 3 VI=VI+A1(I,K)*V1(K) -c Vaux(I)=VI -c 1 CONTINUE - - vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) - vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) - - v2(1)=vaux1 - v2(2)=vaux2 - END -C--------------------------------------- - SUBROUTINE MATMAT2(A1,A2,A3) -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2 -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),A2(2,2),A3(2,2) -c DIMENSION AI3(2,2) -c DO J=1,2 -c A3IJ=0.0 -c DO K=1,2 -c A3IJ=A3IJ+A1(I,K)*A2(K,J) -c enddo -c A3(I,J)=A3IJ -c enddo -c enddo - - ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) - ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) - ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) - ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) - - A3(1,1)=AI3_11 - A3(2,1)=AI3_21 - A3(1,2)=AI3_12 - A3(2,2)=AI3_22 - END - -c------------------------------------------------------------------------- - double precision function scalar2(u,v) -!DIR$ INLINEALWAYS scalar2 - implicit none - double precision u(2),v(2) - double precision sc - integer i - scalar2=u(1)*v(1)+u(2)*v(2) - return - end - -C----------------------------------------------------------------------------- - - subroutine transpose2(a,at) -!DIR$ INLINEALWAYS transpose2 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::transpose2 -#endif - implicit none - double precision a(2,2),at(2,2) - at(1,1)=a(1,1) - at(1,2)=a(2,1) - at(2,1)=a(1,2) - at(2,2)=a(2,2) - return - end -c-------------------------------------------------------------------------- - subroutine transpose(n,a,at) - implicit none - integer n,i,j - double precision a(n,n),at(n,n) - do i=1,n - do j=1,n - at(j,i)=a(i,j) - enddo - enddo - return - end -C--------------------------------------------------------------------------- - subroutine prodmat3(a1,a2,kk,transp,prod) -!DIR$ INLINEALWAYS prodmat3 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::prodmat3 -#endif - implicit none - integer i,j - double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) - logical transp -crc double precision auxmat(2,2),prod_(2,2) - - if (transp) then -crc call transpose2(kk(1,1),auxmat(1,1)) -crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) - - else -crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) - - endif -c call transpose2(a2(1,1),a2t(1,1)) - -crc print *,transp -crc print *,((prod_(i,j),i=1,2),j=1,2) -crc print *,((prod(i,j),i=1,2),j=1,2) - - return - end - diff --git a/source/unres/src_MIN/gen_rand_conf.F b/source/unres/src_MIN/gen_rand_conf.F deleted file mode 100644 index 6cc31ba..0000000 --- a/source/unres/src_MIN/gen_rand_conf.F +++ /dev/null @@ -1,910 +0,0 @@ - subroutine gen_rand_conf(nstart,*) -C Generate random conformation or chain cut and regrowth. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.MCM' - include 'COMMON.GEO' - include 'COMMON.CONTROL' - logical overlap,back,fail -cd print *,' CG Processor',me,' maxgen=',maxgen - maxsi=100 -cd write (iout,*) 'Gen_Rand_conf: nstart=',nstart - if (nstart.lt.5) then - it1=itype(2) - phi(4)=gen_phi(4,itype(2),itype(3)) -c write(iout,*)'phi(4)=',rad2deg*phi(4) - if (nstart.lt.3) theta(3)=gen_theta(itype(2),pi,phi(4)) -c write(iout,*)'theta(3)=',rad2deg*theta(3) - if (it1.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(it1,theta(3),alph(2),omeg(2),fail) - nsi=nsi+1 - enddo - if (nsi.gt.maxsi) return1 - endif ! it1.ne.10 - call orig_frame - i=4 - nstart=4 - else - i=nstart - nstart=max0(i,4) - endif - - maxnit=0 - - nit=0 - niter=0 - back=.false. - do while (i.le.nres .and. niter.lt.maxgen) - if (i.lt.nstart) then - if(iprint.gt.1) then - write (iout,'(/80(1h*)/2a/80(1h*))') - & 'Generation procedure went down to ', - & 'chain beginning. Cannot continue...' - write (*,'(/80(1h*)/2a/80(1h*))') - & 'Generation procedure went down to ', - & 'chain beginning. Cannot continue...' - endif - return1 - endif - it1=itype(i-1) - it2=itype(i-2) - it=itype(i) -c print *,'Gen_Rand_Conf: i=',i,' it=',it,' it1=',it1,' it2=',it2, -c & ' nit=',nit,' niter=',niter,' maxgen=',maxgen - phi(i+1)=gen_phi(i+1,it1,it) - if (back) then - phi(i)=gen_phi(i+1,it2,it1) -c print *,'phi(',i,')=',phi(i) - theta(i-1)=gen_theta(it2,phi(i-1),phi(i)) - if (it2.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(it2,theta(i-1),alph(i-2),omeg(i-2),fail) - nsi=nsi+1 - enddo - if (nsi.gt.maxsi) return1 - endif - call locate_next_res(i-1) - endif - theta(i)=gen_theta(it1,phi(i),phi(i+1)) - if (it1.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(it1,theta(i),alph(i-1),omeg(i-1),fail) - nsi=nsi+1 - enddo - if (nsi.gt.maxsi) return1 - endif - call locate_next_res(i) - if (overlap(i-1)) then - if (nit.lt.maxnit) then - back=.true. - nit=nit+1 - else - nit=0 - if (i.gt.3) then - back=.true. - i=i-1 - else - write (iout,'(a)') - & 'Cannot generate non-overlaping conformation. Increase MAXNIT.' - write (*,'(a)') - & 'Cannot generate non-overlaping conformation. Increase MAXNIT.' - return1 - endif - endif - else - back=.false. - nit=0 - i=i+1 - endif - niter=niter+1 - enddo - if (niter.ge.maxgen) then - write (iout,'(a,2i5)') - & 'Too many trials in conformation generation',niter,maxgen - write (*,'(a,2i5)') - & 'Too many trials in conformation generation',niter,maxgen - return1 - endif - do j=1,3 - c(j,nres+1)=c(j,1) - c(j,nres+nres)=c(j,nres) - enddo - return - end -c------------------------------------------------------------------------- - logical function overlap(i) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - data redfac /0.5D0/ - overlap=.false. - iti=itype(i) - if (iti.gt.ntyp) return -C Check for SC-SC overlaps. -cd print *,'nnt=',nnt,' nct=',nct - do j=nnt,i-1 - itj=itype(j) - if (j.lt.i-1 .or. ipot.ne.4) then - rcomp=sigmaii(iti,itj) - else - rcomp=sigma(iti,itj) - endif -cd print *,'j=',j - if (dist(nres+i,nres+j).lt.redfac*rcomp) then - overlap=.true. -c print *,'overlap, SC-SC: i=',i,' j=',j, -c & ' dist=',dist(nres+i,nres+j),' rcomp=', -c & rcomp - return - endif - enddo -C Check for overlaps between the added peptide group and the preceding -C SCs. - iteli=itel(i) - do j=1,3 - c(j,maxres2+1)=0.5D0*(c(j,i)+c(j,i+1)) - enddo - do j=nnt,i-2 - itj=itype(j) -cd print *,'overlap, p-Sc: i=',i,' j=',j, -cd & ' dist=',dist(nres+j,maxres2+1) - if (dist(nres+j,maxres2+1).lt.4.0D0*redfac) then - overlap=.true. - return - endif - enddo -C Check for overlaps between the added side chain and the preceding peptide -C groups. - do j=1,nnt-2 - do k=1,3 - c(k,maxres2+1)=0.5D0*(c(k,j)+c(k,j+1)) - enddo -cd print *,'overlap, SC-p: i=',i,' j=',j, -cd & ' dist=',dist(nres+i,maxres2+1) - if (dist(nres+i,maxres2+1).lt.4.0D0*redfac) then - overlap=.true. - return - endif - enddo -C Check for p-p overlaps - do j=1,3 - c(j,maxres2+2)=0.5D0*(c(j,i)+c(j,i+1)) - enddo - do j=nnt,i-2 - itelj=itel(j) - do k=1,3 - c(k,maxres2+2)=0.5D0*(c(k,j)+c(k,j+1)) - enddo -cd print *,'overlap, p-p: i=',i,' j=',j, -cd & ' dist=',dist(maxres2+1,maxres2+2) - if(iteli.ne.0.and.itelj.ne.0)then - if (dist(maxres2+1,maxres2+2).lt.rpp(iteli,itelj)*redfac) then - overlap=.true. - return - endif - endif - enddo - return - end -c-------------------------------------------------------------------------- - double precision function gen_phi(i,it1,it2) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.BOUNDS' -c gen_phi=ran_number(-pi,pi) -C 8/13/98 Generate phi using pre-defined boundaries - gen_phi=ran_number(phibound(1,i),phibound(2,i)) - return - end -c--------------------------------------------------------------------------- - double precision function gen_theta(it,gama,gama1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - double precision y(2),z(2) - double precision theta_max,theta_min -c print *,'gen_theta: it=',it - theta_min=0.05D0*pi - theta_max=0.95D0*pi - if (dabs(gama).gt.dwapi) then - y(1)=dcos(gama) - y(2)=dsin(gama) - else - y(1)=0.0D0 - y(2)=0.0D0 - endif - if (dabs(gama1).gt.dwapi) then - z(1)=dcos(gama1) - z(2)=dsin(gama1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif - thet_pred_mean=a0thet(it) - do k=1,2 - thet_pred_mean=thet_pred_mean+athet(k,it)*y(k)+bthet(k,it)*z(k) - enddo - sig=polthet(3,it) - do j=2,0,-1 - sig=sig*thet_pred_mean+polthet(j,it) - enddo - sig=0.5D0/(sig*sig+sigc0(it)) - ak=dexp(gthet(1,it)- - &0.5D0*((gthet(2,it)-thet_pred_mean)/gthet(3,it))**2) -c print '(i5,5(1pe14.4))',it,(gthet(j,it),j=1,3) -c print '(5(1pe14.4))',thet_pred_mean,theta0(it),sig,sig0(it),ak - theta_temp=binorm(thet_pred_mean,theta0(it),sig,sig0(it),ak) - if (theta_temp.lt.theta_min) theta_temp=theta_min - if (theta_temp.gt.theta_max) theta_temp=theta_max - gen_theta=theta_temp -c print '(a)','Exiting GENTHETA.' - return - end -c------------------------------------------------------------------------- - subroutine gen_side(it,the,al,om,fail) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision MaxBoxLen /10.0D0/ - double precision Ap_inv(3,3),a(3,3),z(3,maxlob),W1(maxlob), - & sumW(0:maxlob),y(2),cm(2),eig(2),box(2,2),work(100),detAp(maxlob) - double precision eig_limit /1.0D-8/ - double precision Big /10.0D0/ - double precision vec(3,3) - logical lprint,fail,lcheck - lcheck=.false. - lprint=.false. - fail=.false. - if (the.eq.0.0D0 .or. the.eq.pi) then -#ifdef MPI - write (*,'(a,i4,a,i3,a,1pe14.5)') - & 'CG Processor:',me,' Error in GenSide: it=',it,' theta=',the -#else -cd write (iout,'(a,i3,a,1pe14.5)') -cd & 'Error in GenSide: it=',it,' theta=',the -#endif - fail=.true. - return - endif - tant=dtan(the-pipol) - nlobit=nlob(it) - if (lprint) then -#ifdef MPI - print '(a,i4,a)','CG Processor:',me,' Enter Gen_Side.' - write (iout,'(a,i4,a)') 'Processor:',me,' Enter Gen_Side.' -#endif - print *,'it=',it,' nlobit=',nlobit,' the=',the,' tant=',tant - write (iout,*) 'it=',it,' nlobit=',nlobit,' the=',the, - & ' tant=',tant - endif - do i=1,nlobit - zz1=tant-censc(1,i,it) - do k=1,3 - do l=1,3 - a(k,l)=gaussc(k,l,i,it) - enddo - enddo - detApi=a(2,2)*a(3,3)-a(2,3)**2 - Ap_inv(2,2)=a(3,3)/detApi - Ap_inv(2,3)=-a(2,3)/detApi - Ap_inv(3,2)=Ap_inv(2,3) - Ap_inv(3,3)=a(2,2)/detApi - if (lprint) then - write (*,'(/a,i2/)') 'Cluster #',i - write (*,'(3(1pe14.5),5x,1pe14.5)') - & ((a(l,k),l=1,3),censc(k,i,it),k=1,3) - write (iout,'(/a,i2/)') 'Cluster #',i - write (iout,'(3(1pe14.5),5x,1pe14.5)') - & ((a(l,k),l=1,3),censc(k,i,it),k=1,3) - endif - W1i=0.0D0 - do k=2,3 - do l=2,3 - W1i=W1i+a(k,1)*a(l,1)*Ap_inv(k,l) - enddo - enddo - W1i=a(1,1)-W1i - W1(i)=dexp(bsc(i,it)-0.5D0*W1i*zz1*zz1) -c if (lprint) write(*,'(a,3(1pe15.5)/)') -c & 'detAp, W1, anormi',detApi,W1i,anormi - do k=2,3 - zk=censc(k,i,it) - do l=2,3 - zk=zk+zz1*Ap_inv(k,l)*a(l,1) - enddo - z(k,i)=zk - enddo - detAp(i)=dsqrt(detApi) - enddo - - if (lprint) then - print *,'W1:',(w1(i),i=1,nlobit) - print *,'detAp:',(detAp(i),i=1,nlobit) - print *,'Z' - do i=1,nlobit - print '(i2,3f10.5)',i,(rad2deg*z(j,i),j=2,3) - enddo - write (iout,*) 'W1:',(w1(i),i=1,nlobit) - write (iout,*) 'detAp:',(detAp(i),i=1,nlobit) - write (iout,*) 'Z' - do i=1,nlobit - write (iout,'(i2,3f10.5)') i,(rad2deg*z(j,i),j=2,3) - enddo - endif - if (lcheck) then -C Writing the distribution just to check the procedure - fac=0.0D0 - dV=deg2rad**2*10.0D0 - sum=0.0D0 - sum1=0.0D0 - do i=1,nlobit - fac=fac+W1(i)/detAp(i) - enddo - fac=1.0D0/(2.0D0*fac*pi) -cd print *,it,'fac=',fac - do ial=90,180,2 - y(1)=deg2rad*ial - do iom=-180,180,5 - y(2)=deg2rad*iom - wart=0.0D0 - do i=1,nlobit - do j=2,3 - do k=2,3 - a(j-1,k-1)=gaussc(j,k,i,it) - enddo - enddo - y2=y(2) - - do iii=-1,1 - - y(2)=y2+iii*dwapi - - wykl=0.0D0 - do j=1,2 - do k=1,2 - wykl=wykl+a(j,k)*(y(j)-z(j+1,i))*(y(k)-z(k+1,i)) - enddo - enddo - wart=wart+W1(i)*dexp(-0.5D0*wykl) - - enddo - - y(2)=y2 - - enddo -c print *,'y',y(1),y(2),' fac=',fac - wart=fac*wart - write (20,'(2f10.3,1pd15.5)') y(1)*rad2deg,y(2)*rad2deg,wart - sum=sum+wart - sum1=sum1+1.0D0 - enddo - enddo -c print *,'it=',it,' sum=',sum*dV,' sum1=',sum1*dV - return - endif - -C Calculate the CM of the system -C - do i=1,nlobit - W1(i)=W1(i)/detAp(i) - enddo - sumW(0)=0.0D0 - do i=1,nlobit - sumW(i)=sumW(i-1)+W1(i) - enddo - cm(1)=z(2,1)*W1(1) - cm(2)=z(3,1)*W1(1) - do j=2,nlobit - cm(1)=cm(1)+z(2,j)*W1(j) - cm(2)=cm(2)+W1(j)*(z(3,1)+pinorm(z(3,j)-z(3,1))) - enddo - cm(1)=cm(1)/sumW(nlobit) - cm(2)=cm(2)/sumW(nlobit) - if (cm(1).gt.Big .or. cm(1).lt.-Big .or. - & cm(2).gt.Big .or. cm(2).lt.-Big) then -cd write (iout,'(a)') -cd & 'Unexpected error in GenSide - CM coordinates too large.' -cd write (iout,'(i5,2(1pe14.5))') it,cm(1),cm(2) -cd write (*,'(a)') -cd & 'Unexpected error in GenSide - CM coordinates too large.' -cd write (*,'(i5,2(1pe14.5))') it,cm(1),cm(2) - fail=.true. - return - endif -cd print *,'CM:',cm(1),cm(2) -C -C Find the largest search distance from CM -C - radmax=0.0D0 - do i=1,nlobit - do j=2,3 - do k=2,3 - a(j-1,k-1)=gaussc(j,k,i,it) - enddo - enddo -#ifdef NAG - call f02faf('N','U',2,a,3,eig,work,100,ifail) -#else - call djacob(2,3,10000,1.0d-10,a,vec,eig) -#endif -#ifdef MPI - if (lprint) then - print *,'*************** CG Processor',me - print *,'CM:',cm(1),cm(2) - write (iout,*) '*************** CG Processor',me - write (iout,*) 'CM:',cm(1),cm(2) - print '(A,8f10.5)','Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2) - write (iout,'(A,8f10.5)') - & 'Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2) - endif -#endif - if (eig(1).lt.eig_limit) then - write(iout,'(a)') - & 'From Mult_Norm: Eigenvalues of A are too small.' - write(*,'(a)') - & 'From Mult_Norm: Eigenvalues of A are too small.' - fail=.true. - return - endif - radius=0.0D0 -cd print *,'i=',i - do j=1,2 - radius=radius+pinorm(z(j+1,i)-cm(j))**2 - enddo - radius=dsqrt(radius)+3.0D0/dsqrt(eig(1)) - if (radius.gt.radmax) radmax=radius - enddo - if (radmax.gt.pi) radmax=pi -C -C Determine the boundaries of the search rectangle. -C - if (lprint) then - print '(a,4(1pe14.4))','W1: ',(W1(i),i=1,nlob(it) ) - print '(a,4(1pe14.4))','radmax: ',radmax - endif - box(1,1)=dmax1(cm(1)-radmax,0.0D0) - box(2,1)=dmin1(cm(1)+radmax,pi) - box(1,2)=cm(2)-radmax - box(2,2)=cm(2)+radmax - if (lprint) then -#ifdef MPI - print *,'CG Processor',me,' Array BOX:' -#else - print *,'Array BOX:' -#endif - print '(4(1pe14.4))',((box(k,j),k=1,2),j=1,2) - print '(a,4(1pe14.4))','sumW: ',(sumW(i),i=0,nlob(it) ) -#ifdef MPI - write (iout,*)'CG Processor',me,' Array BOX:' -#else - write (iout,*)'Array BOX:' -#endif - write(iout,'(4(1pe14.4))') ((box(k,j),k=1,2),j=1,2) - write(iout,'(a,4(1pe14.4))')'sumW: ',(sumW(i),i=0,nlob(it) ) - endif - if (box(1,2).lt.-MaxBoxLen .or. box(2,2).gt.MaxBoxLen) then -#ifdef MPI - write (iout,'(a,i4,a)') 'CG Processor:',me,': bad sampling box.' - write (*,'(a,i4,a)') 'CG Processor:',me,': bad sampling box.' -#else -c write (iout,'(a)') 'Bad sampling box.' -#endif - fail=.true. - return - endif - which_lobe=ran_number(0.0D0,sumW(nlobit)) -c print '(a,1pe14.4)','which_lobe=',which_lobe - do i=1,nlobit - if (sumW(i-1).le.which_lobe .and. sumW(i).ge.which_lobe) goto 1 - enddo - 1 ilob=i -c print *,'ilob=',ilob,' nlob=',nlob(it) - do i=2,3 - cm(i-1)=z(i,ilob) - do j=2,3 - a(i-1,j-1)=gaussc(i,j,ilob,it) - enddo - enddo -cd print '(a,i4,a)','CG Processor',me,' Calling MultNorm1.' - call mult_norm1(3,2,a,cm,box,y,fail) - if (fail) return - al=y(1) - om=pinorm(y(2)) -cd print *,'al=',al,' om=',om -cd stop - return - end -c--------------------------------------------------------------------------- - double precision function ran_number(x1,x2) -C Calculate a random real number from the range (x1,x2). - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - double precision x1,x2,fctor - data fctor /2147483647.0D0/ -#ifdef MPI - include "mpif.h" - include 'COMMON.SETUP' - ran_number=x1+(x2-x1)*prng_next(me) -#else - call vrnd(ix,1) - ran_number=x1+(x2-x1)*ix/fctor -#endif - return - end -c-------------------------------------------------------------------------- - integer function iran_num(n1,n2) -C Calculate a random integer number from the range (n1,n2). - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - integer n1,n2,ix - real fctor /2147483647.0/ -#ifdef MPI - include "mpif.h" - include 'COMMON.SETUP' - ix=n1+(n2-n1+1)*prng_next(me) - if (ix.lt.n1) ix=n1 - if (ix.gt.n2) ix=n2 - iran_num=ix -#else - call vrnd(ix,1) - ix=n1+(n2-n1+1)*(ix/fctor) - if (ix.gt.n2) ix=n2 - iran_num=ix -#endif - return - end -c-------------------------------------------------------------------------- - double precision function binorm(x1,x2,sigma1,sigma2,ak) - implicit real*8 (a-h,o-z) -c print '(a)','Enter BINORM.' - alowb=dmin1(x1-3.0D0*sigma1,x2-3.0D0*sigma2) - aupb=dmax1(x1+3.0D0*sigma1,x2+3.0D0*sigma2) - seg=sigma1/(sigma1+ak*sigma2) - alen=ran_number(0.0D0,1.0D0) - if (alen.lt.seg) then - binorm=anorm_distr(x1,sigma1,alowb,aupb) - else - binorm=anorm_distr(x2,sigma2,alowb,aupb) - endif -c print '(a)','Exiting BINORM.' - return - end -c----------------------------------------------------------------------- -c double precision function anorm_distr(x,sigma,alowb,aupb) -c implicit real*8 (a-h,o-z) -c print '(a)','Enter ANORM_DISTR.' -c 10 y=ran_number(alowb,aupb) -c expon=dexp(-0.5D0*((y-x)/sigma)**2) -c ran=ran_number(0.0D0,1.0D0) -c if (expon.lt.ran) goto 10 -c anorm_distr=y -c print '(a)','Exiting ANORM_DISTR.' -c return -c end -c----------------------------------------------------------------------- - double precision function anorm_distr(x,sigma,alowb,aupb) - implicit real*8 (a-h,o-z) -c to make a normally distributed deviate with zero mean and unit variance -c - integer iset - real fac,gset,rsq,v1,v2,ran1 - save iset,gset - data iset/0/ - if(iset.eq.0) then -1 v1=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0 - v2=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0 - rsq=v1**2+v2**2 - if(rsq.ge.1.d0.or.rsq.eq.0.0d0) goto 1 - fac=sqrt(-2.0d0*log(rsq)/rsq) - gset=v1*fac - gaussdev=v2*fac - iset=1 - else - gaussdev=gset - iset=0 - endif - anorm_distr=x+gaussdev*sigma - return - end -c------------------------------------------------------------------------ - subroutine mult_norm(lda,n,a,x,fail) -C -C Generate the vector X whose elements obey the multiple-normal distribution -C from exp(-0.5*X'AX). LDA is the leading dimension of the moment matrix A, -C n is the dimension of the problem. FAIL is set at .TRUE., if the smallest -C eigenvalue of the matrix A is close to 0. -C - implicit double precision (a-h,o-z) - double precision a(lda,n),x(n),eig(100),vec(3,3),work(100) - double precision eig_limit /1.0D-8/ - logical fail - fail=.false. -c print '(a)','Enter MULT_NORM.' -C -C Find the smallest eigenvalue of the matrix A. -C -c do i=1,n -c print '(8f10.5)',(a(i,j),j=1,n) -c enddo -#ifdef NAG - call f02faf('V','U',2,a,lda,eig,work,100,ifail) -#else - call djacob(2,lda,10000,1.0d-10,a,vec,eig) -#endif -c print '(8f10.5)',(eig(i),i=1,n) -C print '(a)' -c do i=1,n -c print '(8f10.5)',(a(i,j),j=1,n) -c enddo - if (eig(1).lt.eig_limit) then - print *,'From Mult_Norm: Eigenvalues of A are too small.' - fail=.true. - return - endif -C -C Generate points following the normal distributions along the principal -C axes of the moment matrix. Store in WORK. -C - do i=1,n - sigma=1.0D0/dsqrt(eig(i)) - alim=-3.0D0*sigma - work(i)=anorm_distr(0.0D0,sigma,-alim,alim) - enddo -C -C Transform the vector of normal variables back to the original basis. -C - do i=1,n - xi=0.0D0 - do j=1,n - xi=xi+a(i,j)*work(j) - enddo - x(i)=xi - enddo - return - end -c------------------------------------------------------------------------ - subroutine mult_norm1(lda,n,a,z,box,x,fail) -C -C Generate the vector X whose elements obey the multi-gaussian multi-dimensional -C distribution from sum_{i=1}^m W(i)exp[-0.5*X'(i)A(i)X(i)]. LDA is the -C leading dimension of the moment matrix A, n is the dimension of the -C distribution, nlob is the number of lobes. FAIL is set at .TRUE., if the -C smallest eigenvalue of the matrix A is close to 0. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - double precision a(lda,n),z(n),x(n),box(n,n) - double precision etmp - include 'COMMON.IOUNITS' -#ifdef MP - include 'COMMON.SETUP' -#endif - logical fail -C -C Generate points following the normal distributions along the principal -C axes of the moment matrix. Store in WORK. -C -cd print *,'CG Processor',me,' entered MultNorm1.' -cd print '(2(1pe14.4),3x,1pe14.4)',((a(i,j),j=1,2),z(i),i=1,2) -cd do i=1,n -cd print *,i,box(1,i),box(2,i) -cd enddo - istep = 0 - 10 istep = istep + 1 - if (istep.gt.10000) then -c write (iout,'(a,i4,2a)') 'CG Processor: ',me,': too many steps', -c & ' in MultNorm1.' -c write (*,'(a,i4,2a)') 'CG Processor: ',me,': too many steps', -c & ' in MultNorm1.' -c write (iout,*) 'box',box -c write (iout,*) 'a',a -c write (iout,*) 'z',z - fail=.true. - return - endif - do i=1,n - x(i)=ran_number(box(1,i),box(2,i)) - enddo - ww=0.0D0 - do i=1,n - xi=pinorm(x(i)-z(i)) - ww=ww+0.5D0*a(i,i)*xi*xi - do j=i+1,n - ww=ww+a(i,j)*xi*pinorm(x(j)-z(j)) - enddo - enddo - dec=ran_number(0.0D0,1.0D0) -c print *,(x(i),i=1,n),ww,dexp(-ww),dec -crc if (dec.gt.dexp(-ww)) goto 10 - if(-ww.lt.100) then - etmp=dexp(-ww) - else - return - endif - if (dec.gt.etmp) goto 10 -cd print *,'CG Processor',me,' exitting MultNorm1.' - return - end -c -crc-------------------------------------- - subroutine overlap_sc(scfail) -c Internal and cartesian coordinates must be consistent as input, -c and will be up-to-date on return. -c At the end of this procedure, scfail is true if there are -c overlapping residues left, or false otherwise (success) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.VAR' - include 'COMMON.SBRIDGE' - include 'COMMON.IOUNITS' - logical had_overlaps,fail,scfail - integer ioverlap(maxres),ioverlap_last - - had_overlaps=.false. - call overlap_sc_list(ioverlap,ioverlap_last) - if (ioverlap_last.gt.0) then - write (iout,*) '#OVERLAPing residues ',ioverlap_last - write (iout,'(20i4)') (ioverlap(k),k=1,ioverlap_last) - had_overlaps=.true. - endif - - maxsi=1000 - do k=1,1000 - if (ioverlap_last.eq.0) exit - - do ires=1,ioverlap_last - i=ioverlap(ires) - iti=itype(i) - if (iti.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(iti,theta(i+1),alph(i),omeg(i),fail) - nsi=nsi+1 - enddo - if(fail) goto 999 - endif - enddo - - call chainbuild - call overlap_sc_list(ioverlap,ioverlap_last) -c write (iout,*) 'Overlaping residues ',ioverlap_last, -c & (ioverlap(j),j=1,ioverlap_last) - enddo - - if (k.le.1000.and.ioverlap_last.eq.0) then - scfail=.false. - if (had_overlaps) then - write (iout,*) '#OVERLAPing all corrected after ',k, - & ' random generation' - endif - else - scfail=.true. - write (iout,*) '#OVERLAPing NOT all corrected ',ioverlap_last - write (iout,'(20i4)') (ioverlap(j),j=1,ioverlap_last) - endif - - return - - 999 continue - write (iout,'(a30,i5,a12,i4)') - & '#OVERLAP FAIL in gen_side after',maxsi, - & 'iter for RES',i - scfail=.true. - return - end - - subroutine overlap_sc_list(ioverlap,ioverlap_last) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.VAR' - include 'COMMON.CALC' - logical fail - integer ioverlap(maxres),ioverlap_last - data redfac /0.5D0/ - - ioverlap_last=0 -C Check for SC-SC overlaps and mark residues -c print *,'>>overlap_sc nnt=',nnt,' nct=',nct - ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) - dsci_inv=dsc_inv(itypi) -c - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - ind=ind+1 - itypj=itype(j) - dscj_inv=dsc_inv(itypj) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) - if (j.gt.i+1) then - rcomp=sigmaii(itypi,itypj) - else - rcomp=sigma(itypi,itypj) - endif -c print '(2(a3,2i3),a3,2f10.5)', -c & ' i=',i,iti,' j=',j,itj,' d=',dist(nres+i,nres+j) -c & ,rcomp - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij - -ct if ( 1.0/rij .lt. redfac*rcomp .or. -ct & rij_shift.le.0.0D0 ) then - if ( rij_shift.le.0.0D0 ) then -cd write (iout,'(a,i3,a,i3,a,f10.5,a,3f10.5)') -cd & 'overlap SC-SC: i=',i,' j=',j, -cd & ' dist=',dist(nres+i,nres+j),' rcomp=', -cd & rcomp,1.0/rij,rij_shift - ioverlap_last=ioverlap_last+1 - ioverlap(ioverlap_last)=i - do k=1,ioverlap_last-1 - if (ioverlap(k).eq.i) ioverlap_last=ioverlap_last-1 - enddo - ioverlap_last=ioverlap_last+1 - ioverlap(ioverlap_last)=j - do k=1,ioverlap_last-1 - if (ioverlap(k).eq.j) ioverlap_last=ioverlap_last-1 - enddo - endif - enddo - enddo - enddo - return - end diff --git a/source/unres/src_MIN/geomout_min.F b/source/unres/src_MIN/geomout_min.F deleted file mode 100644 index 5dab339..0000000 --- a/source/unres/src_MIN/geomout_min.F +++ /dev/null @@ -1,348 +0,0 @@ - subroutine pdbout(etot,tytul,iunit) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' - include 'COMMON.MD_' - character*50 tytul - dimension ica(maxres) - write (iunit,'(3a,1pe15.5)') 'REMARK ',tytul,' ENERGY ',etot -cmodel write (iunit,'(a5,i6)') 'MODEL',1 - if (nhfrag.gt.0) then - do j=1,nhfrag - iti=itype(hfrag(1,j)) - itj=itype(hfrag(2,j)) - if (j.lt.10) then - write (iunit,'(a5,i5,1x,a1,i1,2x,a3,i7,2x,a3,i7,i3,t76,i5)') - & 'HELIX',j,'H',j, - & restyp(iti),hfrag(1,j)-1, - & restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j) - else - write (iunit,'(a5,i5,1x,a1,i2,1x,a3,i7,2x,a3,i7,i3)') - & 'HELIX',j,'H',j, - & restyp(iti),hfrag(1,j)-1, - & restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j) - endif - enddo - endif - - if (nbfrag.gt.0) then - - do j=1,nbfrag - - iti=itype(bfrag(1,j)) - itj=itype(bfrag(2,j)-1) - - write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3)') - & 'SHEET',1,'B',j,2, - & restyp(iti),bfrag(1,j)-1, - & restyp(itj),bfrag(2,j)-2,0 - - if (bfrag(3,j).gt.bfrag(4,j)) then - - itk=itype(bfrag(3,j)) - itl=itype(bfrag(4,j)+1) - - write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3, - & 2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') - & 'SHEET',2,'B',j,2, - & restyp(itl),bfrag(4,j), - & restyp(itk),bfrag(3,j)-1,-1, - & "N",restyp(itk),bfrag(3,j)-1, - & "O",restyp(iti),bfrag(1,j)-1 - - else - - itk=itype(bfrag(3,j)) - itl=itype(bfrag(4,j)-1) - - - write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3, - & 2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') - & 'SHEET',2,'B',j,2, - & restyp(itk),bfrag(3,j)-1, - & restyp(itl),bfrag(4,j)-2,1, - & "N",restyp(itk),bfrag(3,j)-1, - & "O",restyp(iti),bfrag(1,j)-1 - - - - endif - - enddo - endif - - if (nss.gt.0) then - do i=1,nss - write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') - & 'SSBOND',i,'CYS',ihpb(i)-1-nres, - & 'CYS',jhpb(i)-1-nres - enddo - endif - - iatom=0 - do i=nnt,nct - ires=i-nnt+1 - iatom=iatom+1 - ica(i)=iatom - iti=itype(i) - write (iunit,10) iatom,restyp(iti),ires,(c(j,i),j=1,3),vtot(i) - if (iti.ne.10) then - iatom=iatom+1 - write (iunit,20) iatom,restyp(iti),ires,(c(j,nres+i),j=1,3), - & vtot(i+nres) - endif - enddo - write (iunit,'(a)') 'TER' - do i=nnt,nct-1 - if (itype(i).eq.10) then - write (iunit,30) ica(i),ica(i+1) - else - write (iunit,30) ica(i),ica(i+1),ica(i)+1 - endif - enddo - if (itype(nct).ne.10) then - write (iunit,30) ica(nct),ica(nct)+1 - endif - do i=1,nss - write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 - enddo - write (iunit,'(a6)') 'ENDMDL' - 10 FORMAT ('ATOM',I7,' CA ',A3,I6,4X,3F8.3,f15.3) - 20 FORMAT ('ATOM',I7,' CB ',A3,I6,4X,3F8.3,f15.3) - 30 FORMAT ('CONECT',8I5) - return - end -c------------------------------------------------------------------------------ - subroutine MOL2out(etot,tytul) -C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2 -C format. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - character*32 tytul,fd - character*3 zahl - character*6 res_num,pom,ucase -#ifdef AIX - call fdate_(fd) -#elif (defined CRAY) - call date(fd) -#else - call fdate(fd) -#endif - write (imol2,'(a)') '#' - write (imol2,'(a)') - & '# Creating user name: unres' - write (imol2,'(2a)') '# Creation time: ', - & fd - write (imol2,'(/a)') '\@MOLECULE' - write (imol2,'(a)') tytul - write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0 - write (imol2,'(a)') 'SMALL' - write (imol2,'(a)') 'USER_CHARGES' - write (imol2,'(a)') '\@ATOM' - do i=nnt,nct - write (zahl,'(i3)') i - pom=ucase(restyp(itype(i))) - res_num = pom(:3)//zahl(2:) - write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0 - enddo - write (imol2,'(a)') '\@BOND' - do i=nnt,nct-1 - write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1 - enddo - do i=1,nss - write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 - enddo - write (imol2,'(a)') '\@SUBSTRUCTURE' - do i=nnt,nct - write (zahl,'(i3)') i - pom = ucase(restyp(itype(i))) - res_num = pom(:3)//zahl(2:) - write (imol2,30) i-nnt+1,res_num,i-nnt+1,0 - enddo - 10 FORMAT (I7,' CA ',3F10.4,' C.3',I8,1X,A,F11.4,' ****') - 30 FORMAT (I7,1x,A,I14,' RESIDUE',I13,' **** ****') - return - end -c------------------------------------------------------------------------ - subroutine intout - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - write (iout,'(/a)') 'Geometry of the virtual chain.' - write (iout,'(7a)') ' Res ',' d',' Theta', - & ' Gamma',' Dsc',' Alpha',' Beta ' - do i=1,nres - iti=itype(i) - write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i), - & rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i), - & rad2deg*omeg(i) - enddo - return - end -c--------------------------------------------------------------------------- - subroutine briefout(it,ener) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.SBRIDGE' -c print '(a,i5)',intname,igeom -#if defined(AIX) || defined(PGI) - open (igeom,file=intname,position='append') -#else - open (igeom,file=intname,access='append') -#endif - IF (NSS.LE.9) THEN - WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS) - ELSE - WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9) - WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS) - ENDIF -c IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) - WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) - WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES) -c if (nvar.gt.nphi+ntheta) then - write (igeom,200) (rad2deg*alph(i),i=2,nres-1) - write (igeom,200) (rad2deg*omeg(i),i=2,nres-1) -c endif - close(igeom) - 180 format (I5,F12.3,I2,9(1X,2I3)) - 190 format (3X,11(1X,2I3)) - 200 format (8F10.4) - return - end -#ifdef WINIFL - subroutine fdate(fd) - character*32 fd - write(fd,'(32x)') - return - end -#endif -c----------------------------------------------------------------- - subroutine statout(itime) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.HEADER' - include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' - include 'COMMON.MD_' -c include 'COMMON.REMD' - include 'COMMON.SETUP' - integer itime - double precision energia(0:n_ene) - double precision gyrate - external gyrate - common /gucio/ cm - character*256 line1,line2 - character*4 format1,format2 - character*30 format -#ifdef AIX - if(itime.eq.0) then - open(istat,file=statname,position="append") - endif -#else -#ifdef PGI - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif -#endif - if (refstr) then -c call rms_nac_nnc(rms,frac,frac_nn,co,.false.) - write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)') - & itime,totT,EK,potE,totE, - & rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me - format1="a133" - else - write (line1,'(i10,f15.2,7f12.3,i5,$)') - & itime,totT,EK,potE,totE, - & amax,kinetic_T,t_bath,gyrate(),me - format1="a114" - endif - if(usampl.and.totT.gt.eq_time) then - write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back, - & (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair), - & (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back) - write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair - & +21*nfrag_back - elseif(hremd.gt.0) then - write(line2,'(i5)') iset - format2="a005" - else - format2="a001" - line2=' ' - endif - if (print_compon) then - write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2, - & ",20f12.3)" - write (istat,format) line1,line2, - & (potEcomp(print_order(i)),i=1,nprint_ene) - else - write(format,'(a1,a4,a1,a4,a1)') "(",format1,",",format2,")" - write (istat,format) line1,line2 - endif -#if defined(AIX) - call flush(istat) -#else - close(istat) -#endif - return - end -c--------------------------------------------------------------- - double precision function gyrate() - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.INTERACT' - include 'COMMON.CHAIN' - double precision cen(3),rg - - do j=1,3 - cen(j)=0.0d0 - enddo - - do i=nnt,nct - do j=1,3 - cen(j)=cen(j)+c(j,i) - enddo - enddo - do j=1,3 - cen(j)=cen(j)/dble(nct-nnt+1) - enddo - rg = 0.0d0 - do i = nnt, nct - do j=1,3 - rg = rg + (c(j,i)-cen(j))**2 - enddo - end do - gyrate = sqrt(rg/dble(nct-nnt+1)) - return - end - diff --git a/source/unres/src_MIN/gradient_p.F b/source/unres/src_MIN/gradient_p.F deleted file mode 100644 index 25d1b12..0000000 --- a/source/unres/src_MIN/gradient_p.F +++ /dev/null @@ -1,408 +0,0 @@ - subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.MD_' - include 'COMMON.IOUNITS' - external ufparm - integer uiparm(1) - double precision urparm(1) - dimension x(maxvar),g(maxvar) -c -c This subroutine calculates total internal coordinate gradient. -c Depending on the number of function evaluations, either whole energy -c is evaluated beforehand, Cartesian coordinates and their derivatives in -c internal coordinates are reevaluated or only the cartesian-in-internal -c coordinate derivatives are evaluated. The subroutine was designed to work -c with SUMSL. -c -c - icg=mod(nf,2)+1 - -cd print *,'grad',nf,icg - if (nf-nfl+1) 20,30,40 - 20 call func(n,x,nf,f,uiparm,urparm,ufparm) -c write (iout,*) 'grad 20' - if (nf.eq.0) return - goto 40 - 30 call var_to_geom(n,x) - call chainbuild -c write (iout,*) 'grad 30' -C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartder -c write (iout,*) 'grad 40' -c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon -C -C Convert the Cartesian gradient into internal-coordinate gradient. -C - ind=0 - ind1=0 - do i=1,nres-2 - gthetai=0.0D0 - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 -c ind=indmat(i,j) -c print *,'GRAD: i=',i,' jc=',j,' ind=',ind - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - enddo - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - enddo - enddo - do j=i+1,nres-1 - ind1=ind1+1 -c ind1=indmat(i,j) -c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 - do k=1,3 - gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) - gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) - enddo - enddo - if (i.gt.1) g(i-1)=gphii - if (n.gt.nphi) g(nphi+i)=gthetai - enddo - if (n.le.nphi+ntheta) goto 10 - do i=2,nres-1 - if (itype(i).ne.10) then - galphai=0.0D0 - gomegai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ialph(i,1))=galphai - g(ialph(i,1)+nside)=gomegai - endif - enddo -C -C Add the components corresponding to local energy terms. -C - 10 continue - do i=1,nvar -cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) - g(i)=g(i)+gloc(i,icg) - enddo -C Uncomment following three lines for diagnostics. -cd call intout -cd call briefout(0,0.0d0) -cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) - return - end -C------------------------------------------------------------------------- - subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - external ufparm - integer uiparm(1) - double precision urparm(1) - dimension x(maxvar),g(maxvar) - - icg=mod(nf,2)+1 - if (nf-nfl+1) 20,30,40 - 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm) -c write (iout,*) 'grad 20' - if (nf.eq.0) return - goto 40 - 30 continue -#ifdef OSF -c Intercept NaNs in the coordinates -c write(iout,*) (var(i),i=1,nvar) - x_sum=0.D0 - do i=1,n - x_sum=x_sum+x(i) - enddo - if (x_sum.ne.x_sum) then - write(iout,*)" *** grad_restr : Found NaN in coordinates" - call flush(iout) - print *," *** grad_restr : Found NaN in coordinates" - return - endif -#endif - call var_to_geom_restr(n,x) - call chainbuild -C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartder -C -C Convert the Cartesian gradient into internal-coordinate gradient. -C - - ig=0 - ind=nres-2 - do i=2,nres-2 - IF (mask_phi(i+2).eq.1) THEN - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) - enddo - enddo - ig=ig+1 - g(ig)=gphii - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - - ind=0 - do i=1,nres-2 - IF (mask_theta(i+2).eq.1) THEN - ig=ig+1 - gthetai=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) - enddo - enddo - g(ig)=gthetai - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - galphai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - g(ig)=galphai - ENDIF - endif - enddo - - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - gomegai=0.0D0 - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ig)=gomegai - ENDIF - endif - enddo - -C -C Add the components corresponding to local energy terms. -C - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - endif - enddo - enddo - -cd do i=1,ig -cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) -cd enddo - return - end -C------------------------------------------------------------------------- - subroutine cartgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.MD_' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' -c -c This subrouting calculates total Cartesian coordinate gradient. -c The subroutine chainbuild_cart and energy MUST be called beforehand. -c -#ifdef TIMING - time00=MPI_Wtime() -#endif - icg=1 - call sum_gradient -#ifdef TIMING -#endif -cd write (iout,*) "After sum_gradient" -cd do i=1,nres-1 -cd write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) -cd write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) -cd enddo -c If performing constraint dynamics, add the gradients of the constraint energy - if(usampl.and.totT.gt.eq_time) then - do i=1,nct - do j=1,3 - gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i) - gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i) - enddo - enddo - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+dugamma(i) - enddo - do i=1,nres-2 - gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i) - enddo - endif -#ifdef TIMING - time01=MPI_Wtime() -#endif - call intcartderiv -#ifdef TIMING - time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 -#endif -cd call checkintcartgrad -cd write(iout,*) 'calling int_to_cart' -cd write (iout,*) "gcart, gxcart, gloc before int_to_cart" - do i=1,nct - do j=1,3 - gcart(j,i)=gradc(j,i,icg) - gxcart(j,i)=gradx(j,i,icg) - enddo -cd write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3), -cd & (gxcart(j,i),j=1,3),gloc(i,icg) - enddo -#ifdef TIMING - time01=MPI_Wtime() -#endif - call int_to_cart -#ifdef TIMING - time_inttocart=time_inttocart+MPI_Wtime()-time01 -#endif -cd write (iout,*) "gcart and gxcart after int_to_cart" -cd do i=0,nres-1 -cd write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), -cd & (gxcart(j,i),j=1,3) -cd enddo -#ifdef TIMING - time_cartgrad=time_cartgrad+MPI_Wtime()-time00 -#endif - return - end -C------------------------------------------------------------------------- - subroutine zerograd - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.MD_' -C -C Initialize Cartesian-coordinate gradient -C - do i=1,nres - do j=1,3 - gvdwx(j,i)=0.0D0 - gvdwxT(j,i)=0.0D0 - gradx_scp(j,i)=0.0D0 - gvdwc(j,i)=0.0D0 - gvdwcT(j,i)=0.0D0 - gvdwc_scp(j,i)=0.0D0 - gvdwc_scpp(j,i)=0.0d0 - gelc (j,i)=0.0D0 - gelc_long(j,i)=0.0D0 - gradb(j,i)=0.0d0 - gradbx(j,i)=0.0d0 - gvdwpp(j,i)=0.0d0 - gel_loc(j,i)=0.0d0 - gel_loc_long(j,i)=0.0d0 - ghpbc(j,i)=0.0D0 - ghpbx(j,i)=0.0D0 - gcorr3_turn(j,i)=0.0d0 - gcorr4_turn(j,i)=0.0d0 - gradcorr(j,i)=0.0d0 - gradcorr_long(j,i)=0.0d0 - gradcorr5_long(j,i)=0.0d0 - gradcorr6_long(j,i)=0.0d0 - gcorr6_turn_long(j,i)=0.0d0 - gradcorr5(j,i)=0.0d0 - gradcorr6(j,i)=0.0d0 - gcorr6_turn(j,i)=0.0d0 - gsccorc(j,i)=0.0d0 - gsccorx(j,i)=0.0d0 - gradc(j,i,icg)=0.0d0 - gradx(j,i,icg)=0.0d0 - gscloc(j,i)=0.0d0 - gsclocx(j,i)=0.0d0 - enddo - enddo -C -C Initialize the gradient of local energy terms. -C - do i=1,4*nres - gloc(i,icg)=0.0D0 - enddo - do i=1,nres - gel_loc_loc(i)=0.0d0 - gcorr_loc(i)=0.0d0 - g_corr5_loc(i)=0.0d0 - g_corr6_loc(i)=0.0d0 - gel_loc_turn3(i)=0.0d0 - gel_loc_turn4(i)=0.0d0 - gel_loc_turn6(i)=0.0d0 - gsccor_loc(i)=0.0d0 - enddo -c initialize gcart and gxcart - do i=0,nres - do j=1,3 - gcart(j,i)=0.0d0 - gxcart(j,i)=0.0d0 - enddo - enddo - return - end -c------------------------------------------------------------------------- - double precision function fdum() - fdum=0.0D0 - return - end diff --git a/source/unres/src_MIN/initialize_p.F b/source/unres/src_MIN/initialize_p.F deleted file mode 100644 index 8cc2278..0000000 --- a/source/unres/src_MIN/initialize_p.F +++ /dev/null @@ -1,1385 +0,0 @@ - block data - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' -c include 'COMMON.MD' - data MovTypID - & /'pool','chain regrow','multi-bond','phi','theta','side chain', - & 'total'/ -c Conversion from poises to molecular unit and the gas constant -c data cPoise /2.9361d0/, Rb /0.001986d0/ - end -c-------------------------------------------------------------------------- - subroutine initialize -C -C Define constants and zero out tables. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.MCM' - include 'COMMON.MINIM' - include 'COMMON.DERIV' - include 'COMMON.SPLITELE' -c Common blocks from the diagonalization routines - COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) - COMMON /MACHSW/ KDIAG,ICORFL,IXDR - logical mask_r -c real*8 text1 /'initial_i'/ - - mask_r=.false. -#ifndef ISNAN -c NaNQ initialization - i=-1 - arg=100.0d0 - rr=dacos(arg) -#ifdef WINPGI - idumm=proc_proc(rr,i) -#else - call proc_proc(rr,i) -#endif -#endif - - kdiag=0 - icorfl=0 - iw=2 -C -C The following is just to define auxiliary variables used in angle conversion -C - pi=4.0D0*datan(1.0D0) - dwapi=2.0D0*pi - dwapi3=dwapi/3.0D0 - pipol=0.5D0*pi - deg2rad=pi/180.0D0 - rad2deg=1.0D0/deg2rad - angmin=10.0D0*deg2rad -C -C Define I/O units. -C - inp= 1 - iout= 2 - ipdbin= 3 - ipdb= 7 - icart = 30 - imol2= 4 - igeom= 8 - intin= 9 - ithep= 11 - ithep_pdb=51 - irotam=12 - irotam_pdb=52 - itorp= 13 - itordp= 23 - ielep= 14 - isidep=15 - iscpp=25 - icbase=16 - ifourier=20 - istat= 17 - irest1=55 - irest2=56 - iifrag=57 - ientin=18 - ientout=19 - ibond = 28 - isccor = 29 -crc for write_rmsbank1 - izs1=21 -cdr include secondary structure prediction bias - isecpred=27 -C -C CSA I/O units (separated from others especially for Jooyoung) -C - icsa_rbank=30 - icsa_seed=31 - icsa_history=32 - icsa_bank=33 - icsa_bank1=34 - icsa_alpha=35 - icsa_alpha1=36 - icsa_bankt=37 - icsa_int=39 - icsa_bank_reminimized=38 - icsa_native_int=41 - icsa_in=40 -crc for ifc error 118 - icsa_pdb=42 -C -C Set default weights of the energy terms. -C - wlong=1.0D0 - welec=1.0D0 - wtor =1.0D0 - wang =1.0D0 - wscloc=1.0D0 - wstrain=1.0D0 -C -C Zero out tables. -C - print '(a,$)','Inside initialize' -c call memmon_print_usage() - do i=1,maxres2 - do j=1,3 - c(j,i)=0.0D0 - dc(j,i)=0.0D0 - enddo - enddo - do i=1,maxres - do j=1,3 - xloc(j,i)=0.0D0 - enddo - enddo - do i=1,ntyp - do j=1,ntyp - aa(i,j)=0.0D0 - bb(i,j)=0.0D0 - augm(i,j)=0.0D0 - sigma(i,j)=0.0D0 - r0(i,j)=0.0D0 - chi(i,j)=0.0D0 - enddo - do j=1,2 - bad(i,j)=0.0D0 - enddo - chip(i)=0.0D0 - alp(i)=0.0D0 - sigma0(i)=0.0D0 - sigii(i)=0.0D0 - rr0(i)=0.0D0 - a0thet(i)=0.0D0 - do j=1,2 - athet(j,i)=0.0D0 - bthet(j,i)=0.0D0 - enddo - do j=0,3 - polthet(j,i)=0.0D0 - enddo - do j=1,3 - gthet(j,i)=0.0D0 - enddo - theta0(i)=0.0D0 - sig0(i)=0.0D0 - sigc0(i)=0.0D0 - do j=1,maxlob - bsc(j,i)=0.0D0 - do k=1,3 - censc(k,j,i)=0.0D0 - enddo - do k=1,3 - do l=1,3 - gaussc(l,k,j,i)=0.0D0 - enddo - enddo - nlob(i)=0 - enddo - enddo - nlob(ntyp1)=0 - dsc(ntyp1)=0.0D0 - do i=1,maxtor - itortyp(i)=0 - do j=1,maxtor - do k=1,maxterm - v1(k,j,i)=0.0D0 - v2(k,j,i)=0.0D0 - enddo - enddo - enddo - do i=1,maxres - itype(i)=0 - itel(i)=0 - enddo -C Initialize the bridge arrays - ns=0 - nss=0 - nhpb=0 - do i=1,maxss - iss(i)=0 - enddo - do i=1,maxdim - dhpb(i)=0.0D0 - enddo - do i=1,maxres - ihpb(i)=0 - jhpb(i)=0 - enddo -C -C Initialize timing. -C - call set_timers -C -C Initialize variables used in minimization. -C -c maxfun=5000 -c maxit=2000 - maxfun=500 - maxit=200 - tolf=1.0D-2 - rtolf=5.0D-4 -C -C Initialize the variables responsible for the mode of gradient storage. -C - nfl=0 - icg=1 -C -C Initialize constants used to split the energy into long- and short-range -C components -C - r_cut=2.0d0 - rlamb=0.3d0 -#ifndef SPLITELE - nprint_ene=nprint_ene-1 -#endif - return - end -c------------------------------------------------------------------------- - block data nazwy - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - data restyp / - &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR', - &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/ - data onelet / - &'C','M','F','I','L','V','W','Y','A','G','T', - &'S','Q','N','E','D','H','R','K','P','X'/ - data potname /'LJ','LJK','BP','GB','GBV'/ - data ename / - & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ", - & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ", - & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ", - & "ESTR ","EVDW2_14 ","UCONST ", " ","ESCCOR"," "," "/ - data wname / - & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", - & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD", - & "WSTRAIN","WVDWPP","WBOND","SCAL14"," "," ","WSCCOR", - & " "," "/ - data nprint_ene /20/ - data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16, - & 21,0,0,0/ - end -c--------------------------------------------------------------------------- - subroutine init_int_table - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer blocklengths(15),displs(15) -#endif - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.SBRIDGE' - include 'COMMON.TORCNSTR' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.CONTACTS' - common /przechowalnia/ iturn3_start_all(0:MaxProcs), - & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs), - & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs), - & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1), - & ielend_all(maxres,0:MaxProcs-1), - & ntask_cont_from_all(0:max_fg_procs-1), - & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1), - & ntask_cont_to_all(0:max_fg_procs-1), - & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1) - integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP - logical scheck,lprint,flag -#ifdef MPI - integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs), - & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs) -C... Determine the numbers of start and end SC-SC interaction -C... to deal with by current processor. - do i=0,nfgtasks-1 - itask_cont_from(i)=fg_rank - itask_cont_to(i)=fg_rank - enddo - lprint=.false. - if (lprint) - &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct - n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss - call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde) - if (lprint) - & write (iout,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',MyRank, - & ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds, - & ' my_sc_inde',my_sc_inde - ind_sctint=0 - iatsc_s=0 - iatsc_e=0 -#endif -c lprint=.false. - do i=1,maxres - nint_gr(i)=0 - nscp_gr(i)=0 - do j=1,maxint_gr - istart(i,1)=0 - iend(i,1)=0 - ielstart(i)=0 - ielend(i)=0 - iscpstart(i,1)=0 - iscpend(i,1)=0 - enddo - enddo - ind_scint=0 - ind_scint_old=0 -cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', -cd & (ihpb(i),jhpb(i),i=1,nss) - do i=nnt,nct-1 - scheck=.false. - do ii=1,nss - if (ihpb(ii).eq.i+nres) then - scheck=.true. - jj=jhpb(ii)-nres - goto 10 - endif - enddo - 10 continue -cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj - if (scheck) then - if (jj.eq.i+1) then -#ifdef MPI -c write (iout,*) 'jj=i+1' - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12) -#else - nint_gr(i)=1 - istart(i,1)=i+2 - iend(i,1)=nct -#endif - else if (jj.eq.nct) then -#ifdef MPI -c write (iout,*) 'jj=nct' - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12) -#else - nint_gr(i)=1 - istart(i,1)=i+1 - iend(i,1)=nct-1 -#endif - else -#ifdef MPI - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12) - ii=nint_gr(i)+1 - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12) -#else - nint_gr(i)=2 - istart(i,1)=i+1 - iend(i,1)=jj-1 - istart(i,2)=jj+1 - iend(i,2)=nct -#endif - endif - else -#ifdef MPI - call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, - & iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12) -#else - nint_gr(i)=1 - istart(i,1)=i+1 - iend(i,1)=nct - ind_scint=ind_scint+nct-i -#endif - endif -#ifdef MPI - ind_scint_old=ind_scint -#endif - enddo - 12 continue -#ifndef MPI - iatsc_s=nnt - iatsc_e=nct-1 -#endif -#ifdef MPI - if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor, - & ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e -#endif - if (lprint) then - write (iout,'(a)') 'Interaction array:' - do i=iatsc_s,iatsc_e - write (iout,'(i3,2(2x,2i3))') - & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i)) - enddo - endif - ispp=4 -#ifdef MPI -C Now partition the electrostatic-interaction array - npept=nct-nnt - nele_int_tot=(npept-ispp)*(npept-ispp+1)/2 - call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde) - if (lprint) - & write (*,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',MyRank, - & ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds, - & ' my_ele_inde',my_ele_inde - iatel_s=0 - iatel_e=0 - ind_eleint=0 - ind_eleint_old=0 - do i=nnt,nct-3 - ijunk=0 - call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i, - & iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13) - enddo ! i - 13 continue - if (iatel_s.eq.0) iatel_s=1 - nele_int_tot_vdw=(npept-2)*(npept-2+1)/2 -c write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw - call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw) -c write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw, -c & " my_ele_inde_vdw",my_ele_inde_vdw - ind_eleint_vdw=0 - ind_eleint_vdw_old=0 - iatel_s_vdw=0 - iatel_e_vdw=0 - do i=nnt,nct-3 - ijunk=0 - call int_partition(ind_eleint_vdw,my_ele_inds_vdw, - & my_ele_inde_vdw,i, - & iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i), - & ielend_vdw(i),*15) -c write (iout,*) i," ielstart_vdw",ielstart_vdw(i), -c & " ielend_vdw",ielend_vdw(i) - enddo ! i - if (iatel_s_vdw.eq.0) iatel_s_vdw=1 - 15 continue -#else - iatel_s=nnt - iatel_e=nct-5 - do i=iatel_s,iatel_e - ielstart(i)=i+4 - ielend(i)=nct-1 - enddo - iatel_s_vdw=nnt - iatel_e_vdw=nct-3 - do i=iatel_s_vdw,iatel_e_vdw - ielstart_vdw(i)=i+2 - ielend_vdw(i)=nct-1 - enddo -#endif - if (lprint) then - write (*,'(a)') 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',MyRank - write (iout,*) 'Electrostatic interaction array:' - do i=iatel_s,iatel_e - write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i) - enddo - endif ! lprint -c iscp=3 - iscp=2 -C Partition the SC-p interaction array -#ifdef MPI - nscp_int_tot=(npept-iscp+1)*(npept-iscp+1) - call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde) - if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',myrank, - & ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds, - & ' my_scp_inde',my_scp_inde - iatscp_s=0 - iatscp_e=0 - ind_scpint=0 - ind_scpint_old=0 - do i=nnt,nct-1 - if (i.lt.nnt+iscp) then -cd write (iout,*) 'i.le.nnt+iscp' - call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, - & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1), - & iscpend(i,1),*14) - else if (i.gt.nct-iscp) then -cd write (iout,*) 'i.gt.nct-iscp' - call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, - & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), - & iscpend(i,1),*14) - else - call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, - & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), - & iscpend(i,1),*14) - ii=nscp_gr(i)+1 - call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, - & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii), - & iscpend(i,ii),*14) - endif - enddo ! i - 14 continue -#else - iatscp_s=nnt - iatscp_e=nct-1 - do i=nnt,nct-1 - if (i.lt.nnt+iscp) then - nscp_gr(i)=1 - iscpstart(i,1)=i+iscp - iscpend(i,1)=nct - elseif (i.gt.nct-iscp) then - nscp_gr(i)=1 - iscpstart(i,1)=nnt - iscpend(i,1)=i-iscp - else - nscp_gr(i)=2 - iscpstart(i,1)=nnt - iscpend(i,1)=i-iscp - iscpstart(i,2)=i+iscp - iscpend(i,2)=nct - endif - enddo ! i -#endif - if (lprint) then - write (iout,'(a)') 'SC-p interaction array:' - do i=iatscp_s,iatscp_e - write (iout,'(i3,2(2x,2i3))') - & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) - enddo - endif ! lprint -C Partition local interactions -#ifdef MPI - call int_bounds(nres-2,loc_start,loc_end) - loc_start=loc_start+1 - loc_end=loc_end+1 - call int_bounds(nres-2,ithet_start,ithet_end) - ithet_start=ithet_start+2 - ithet_end=ithet_end+2 - call int_bounds(nct-nnt-2,iturn3_start,iturn3_end) - iturn3_start=iturn3_start+nnt - iphi_start=iturn3_start+2 - iturn3_end=iturn3_end+nnt - iphi_end=iturn3_end+2 - iturn3_start=iturn3_start-1 - iturn3_end=iturn3_end-1 - call int_bounds(nres-3,iphi1_start,iphi1_end) - iphi1_start=iphi1_start+3 - iphi1_end=iphi1_end+3 - call int_bounds(nct-nnt-3,iturn4_start,iturn4_end) - iturn4_start=iturn4_start+nnt - iphid_start=iturn4_start+2 - iturn4_end=iturn4_end+nnt - iphid_end=iturn4_end+2 - iturn4_start=iturn4_start-1 - iturn4_end=iturn4_end-1 - call int_bounds(nres-2,ibond_start,ibond_end) - ibond_start=ibond_start+1 - ibond_end=ibond_end+1 - call int_bounds(nct-nnt,ibondp_start,ibondp_end) - ibondp_start=ibondp_start+nnt - ibondp_end=ibondp_end+nnt - call int_bounds1(nres-1,ivec_start,ivec_end) - print *,"Processor",myrank,fg_rank,fg_rank1, - & " ivec_start",ivec_start," ivec_end",ivec_end - iset_start=loc_start+2 - iset_end=loc_end+2 - if (ndih_constr.eq.0) then - idihconstr_start=1 - idihconstr_end=0 - else - call int_bounds(ndih_constr,idihconstr_start,idihconstr_end) - endif - nsumgrad=(nres-nnt)*(nres-nnt+1)/2 - nlen=nres-nnt+1 - call int_bounds(nsumgrad,ngrad_start,ngrad_end) - igrad_start=((2*nlen+1) - & -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2 - jgrad_start(igrad_start)= - & ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2 - & +igrad_start - jgrad_end(igrad_start)=nres - igrad_end=((2*nlen+1) - & -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2 - if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1 - jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2 - & +igrad_end - do i=igrad_start+1,igrad_end-1 - jgrad_start(i)=i+1 - jgrad_end(i)=nres - enddo - if (lprint) then - write (*,*) 'Processor:',fg_rank,' CG group',kolor, - & ' absolute rank',myrank, - & ' loc_start',loc_start,' loc_end',loc_end, - & ' ithet_start',ithet_start,' ithet_end',ithet_end, - & ' iphi_start',iphi_start,' iphi_end',iphi_end, - & ' iphid_start',iphid_start,' iphid_end',iphid_end, - & ' ibond_start',ibond_start,' ibond_end',ibond_end, - & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end, - & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end, - & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end, - & ' ivec_start',ivec_start,' ivec_end',ivec_end, - & ' iset_start',iset_start,' iset_end',iset_end, - & ' idihconstr_start',idihconstr_start,' idihconstr_end', - & idihconstr_end - write (*,*) 'Processor:',fg_rank,myrank,' igrad_start', - & igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start, - & ' ngrad_end',ngrad_end - do i=igrad_start,igrad_end - write(*,*) 'Processor:',fg_rank,myrank,i, - & jgrad_start(i),jgrad_end(i) - enddo - endif - if (nfgtasks.gt.1) then - call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1, - & MPI_INTEGER,FG_COMM1,IERROR) - iaux=ivec_end-ivec_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1, - & MPI_INTEGER,FG_COMM1,IERROR) - call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=iset_end-iset_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=ibond_end-ibond_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=ithet_end-ithet_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=iphi_end-iphi_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - iaux=iphi1_end-iphi1_start+1 - call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1, - & MPI_INTEGER,FG_COMM,IERROR) - do i=0,maxprocs-1 - do j=1,maxres - ielstart_all(j,i)=0 - ielend_all(j,i)=0 - enddo - enddo - call MPI_Allgather(iturn3_start,1,MPI_INTEGER, - & iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iturn4_start,1,MPI_INTEGER, - & iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iturn3_end,1,MPI_INTEGER, - & iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iturn4_end,1,MPI_INTEGER, - & iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iatel_s,1,MPI_INTEGER, - & iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(iatel_e,1,MPI_INTEGER, - & iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER, - & ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ielend(1),maxres,MPI_INTEGER, - & ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR) - if (lprint) then - write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks) - write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks) - write (iout,*) "iturn3_start_all", - & (iturn3_start_all(i),i=0,nfgtasks-1) - write (iout,*) "iturn3_end_all", - & (iturn3_end_all(i),i=0,nfgtasks-1) - write (iout,*) "iturn4_start_all", - & (iturn4_start_all(i),i=0,nfgtasks-1) - write (iout,*) "iturn4_end_all", - & (iturn4_end_all(i),i=0,nfgtasks-1) - write (iout,*) "The ielstart_all array" - do i=nnt,nct - write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1) - enddo - write (iout,*) "The ielend_all array" - do i=nnt,nct - write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1) - enddo - call flush(iout) - endif - ntask_cont_from=0 - ntask_cont_to=0 - itask_cont_from(0)=fg_rank - itask_cont_to(0)=fg_rank - flag=.false. - do ii=iturn3_start,iturn3_end - call add_int(ii,ii+2,iturn3_sent(1,ii), - & ntask_cont_to,itask_cont_to,flag) - enddo - do ii=iturn4_start,iturn4_end - call add_int(ii,ii+3,iturn4_sent(1,ii), - & ntask_cont_to,itask_cont_to,flag) - enddo - do ii=iturn3_start,iturn3_end - call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from) - enddo - do ii=iturn4_start,iturn4_end - call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from) - enddo - if (lprint) then - write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from, - & " ntask_cont_to",ntask_cont_to - write (iout,*) "itask_cont_from", - & (itask_cont_from(i),i=1,ntask_cont_from) - write (iout,*) "itask_cont_to", - & (itask_cont_to(i),i=1,ntask_cont_to) - call flush(iout) - endif -c write (iout,*) "Loop forward" -c call flush(iout) - do i=iatel_s,iatel_e -c write (iout,*) "from loop i=",i -c call flush(iout) - do j=ielstart(i),ielend(i) - call add_int_from(i,j,ntask_cont_from,itask_cont_from) - enddo - enddo -c write (iout,*) "Loop backward iatel_e-1",iatel_e-1, -c & " iatel_e",iatel_e -c call flush(iout) - nat_sent=0 - do i=iatel_s,iatel_e -c write (iout,*) "i",i," ielstart",ielstart(i), -c & " ielend",ielend(i) -c call flush(iout) - flag=.false. - do j=ielstart(i),ielend(i) - call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to, - & itask_cont_to,flag) - enddo - if (flag) then - nat_sent=nat_sent+1 - iat_sent(nat_sent)=i - endif - enddo - if (lprint) then - write (iout,*)"After longrange ntask_cont_from",ntask_cont_from, - & " ntask_cont_to",ntask_cont_to - write (iout,*) "itask_cont_from", - & (itask_cont_from(i),i=1,ntask_cont_from) - write (iout,*) "itask_cont_to", - & (itask_cont_to(i),i=1,ntask_cont_to) - call flush(iout) - write (iout,*) "iint_sent" - do i=1,nat_sent - ii=iat_sent(i) - write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4), - & j=ielstart(ii),ielend(ii)) - enddo - write (iout,*) "iturn3_sent iturn3_start",iturn3_start, - & " iturn3_end",iturn3_end - write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4), - & i=iturn3_start,iturn3_end) - write (iout,*) "iturn4_sent iturn4_start",iturn4_start, - & " iturn4_end",iturn4_end - write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4), - & i=iturn4_start,iturn4_end) - call flush(iout) - endif - call MPI_Gather(ntask_cont_from,1,MPI_INTEGER, - & ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR) -c write (iout,*) "Gather ntask_cont_from ended" -c call flush(iout) - call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER, - & itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king, - & FG_COMM,IERR) -c write (iout,*) "Gather itask_cont_from ended" -c call flush(iout) - call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all, - & 1,MPI_INTEGER,king,FG_COMM,IERR) -c write (iout,*) "Gather ntask_cont_to ended" -c call flush(iout) - call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER, - & itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR) -c write (iout,*) "Gather itask_cont_to ended" -c call flush(iout) - if (fg_rank.eq.king) then - write (iout,*)"Contact receive task map (proc, #tasks, tasks)" - do i=0,nfgtasks-1 - write (iout,'(20i4)') i,ntask_cont_from_all(i), - & (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i)) - enddo - write (iout,*) - call flush(iout) - write (iout,*) "Contact send task map (proc, #tasks, tasks)" - do i=0,nfgtasks-1 - write (iout,'(20i4)') i,ntask_cont_to_all(i), - & (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i)) - enddo - write (iout,*) - call flush(iout) -C Check if every send will have a matching receive - ncheck_to=0 - ncheck_from=0 - do i=0,nfgtasks-1 - ncheck_to=ncheck_to+ntask_cont_to_all(i) - ncheck_from=ncheck_from+ntask_cont_from_all(i) - enddo - write (iout,*) "Control sums",ncheck_from,ncheck_to - if (ncheck_from.ne.ncheck_to) then - write (iout,*) "Error: #receive differs from #send." - write (iout,*) "Terminating program...!" - call flush(iout) - flag=.false. - else - flag=.true. - do i=0,nfgtasks-1 - do j=1,ntask_cont_to_all(i) - ii=itask_cont_to_all(j,i) - do k=1,ntask_cont_from_all(ii) - if (itask_cont_from_all(k,ii).eq.i) then - if(lprint)write(iout,*)"Matching send/receive",i,ii - exit - endif - enddo - if (k.eq.ntask_cont_from_all(ii)+1) then - flag=.false. - write (iout,*) "Error: send by",j," to",ii, - & " would have no matching receive" - endif - enddo - enddo - endif - if (.not.flag) then - write (iout,*) "Unmatched sends; terminating program" - call flush(iout) - endif - endif - call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR) -c write (iout,*) "flag broadcast ended flag=",flag -c call flush(iout) - if (.not.flag) then - call MPI_Finalize(IERROR) - stop "Error in INIT_INT_TABLE: unmatched send/receive." - endif - call MPI_Comm_group(FG_COMM,fg_group,IERR) -c write (iout,*) "MPI_Comm_group ended" -c call flush(iout) - call MPI_Group_incl(fg_group,ntask_cont_from+1, - & itask_cont_from(0),CONT_FROM_GROUP,IERR) - call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0), - & CONT_TO_GROUP,IERR) - do i=1,nat_sent - ii=iat_sent(i) - iaux=4*(ielend(ii)-ielstart(ii)+1) - call MPI_Group_translate_ranks(fg_group,iaux, - & iint_sent(1,ielstart(ii),i),CONT_TO_GROUP, - & iint_sent_local(1,ielstart(ii),i),IERR ) -c write (iout,*) "Ranks translated i=",i -c call flush(iout) - enddo - iaux=4*(iturn3_end-iturn3_start+1) - call MPI_Group_translate_ranks(fg_group,iaux, - & iturn3_sent(1,iturn3_start),CONT_TO_GROUP, - & iturn3_sent_local(1,iturn3_start),IERR) - iaux=4*(iturn4_end-iturn4_start+1) - call MPI_Group_translate_ranks(fg_group,iaux, - & iturn4_sent(1,iturn4_start),CONT_TO_GROUP, - & iturn4_sent_local(1,iturn4_start),IERR) - if (lprint) then - write (iout,*) "iint_sent_local" - do i=1,nat_sent - ii=iat_sent(i) - write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4), - & j=ielstart(ii),ielend(ii)) - call flush(iout) - enddo - write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start, - & " iturn3_end",iturn3_end - write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4), - & i=iturn3_start,iturn3_end) - write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start, - & " iturn4_end",iturn4_end - write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4), - & i=iturn4_start,iturn4_end) - call flush(iout) - endif - call MPI_Group_free(fg_group,ierr) - call MPI_Group_free(cont_from_group,ierr) - call MPI_Group_free(cont_to_group,ierr) - call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR) - call MPI_Type_commit(MPI_UYZ,IERROR) - call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD, - & IERROR) - call MPI_Type_commit(MPI_UYZGRAD,IERROR) - call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR) - call MPI_Type_commit(MPI_MU,IERROR) - call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR) - call MPI_Type_commit(MPI_MAT1,IERROR) - call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR) - call MPI_Type_commit(MPI_MAT2,IERROR) - call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR) - call MPI_Type_commit(MPI_THET,IERROR) - call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR) - call MPI_Type_commit(MPI_GAM,IERROR) -#ifndef MATGATHER -c 9/22/08 Derived types to send matrices which appear in correlation terms - do i=0,nfgtasks-1 - if (ivec_count(i).eq.ivec_count(0)) then - lentyp(i)=0 - else - lentyp(i)=1 - endif - enddo - do ind_typ=lentyp(0),lentyp(nfgtasks-1) - if (ind_typ.eq.0) then - ichunk=ivec_count(0) - else - ichunk=ivec_count(1) - endif -c do i=1,4 -c blocklengths(i)=4 -c enddo -c displs(1)=0 -c do i=2,4 -c displs(i)=displs(i-1)+blocklengths(i-1)*maxres -c enddo -c do i=1,4 -c blocklengths(i)=blocklengths(i)*ichunk -c enddo -c write (iout,*) "blocklengths and displs" -c do i=1,4 -c write (iout,*) i,blocklengths(i),displs(i) -c enddo -c call flush(iout) -c call MPI_Type_indexed(4,blocklengths(1),displs(1), -c & MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR) -c call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR) -c write (iout,*) "MPI_ROTAT1",MPI_ROTAT1 -c do i=1,4 -c blocklengths(i)=2 -c enddo -c displs(1)=0 -c do i=2,4 -c displs(i)=displs(i-1)+blocklengths(i-1)*maxres -c enddo -c do i=1,4 -c blocklengths(i)=blocklengths(i)*ichunk -c enddo -c write (iout,*) "blocklengths and displs" -c do i=1,4 -c write (iout,*) i,blocklengths(i),displs(i) -c enddo -c call flush(iout) -c call MPI_Type_indexed(4,blocklengths(1),displs(1), -c & MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR) -c call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR) -c write (iout,*) "MPI_ROTAT2",MPI_ROTAT2 - do i=1,8 - blocklengths(i)=2 - enddo - displs(1)=0 - do i=2,8 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,15 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(8,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR) - call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR) - do i=1,8 - blocklengths(i)=4 - enddo - displs(1)=0 - do i=2,8 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,15 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(8,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR) - call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR) - do i=1,6 - blocklengths(i)=4 - enddo - displs(1)=0 - do i=2,6 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,6 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(6,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR) - call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR) - do i=1,2 - blocklengths(i)=8 - enddo - displs(1)=0 - do i=2,2 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,2 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(2,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR) - call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR) - do i=1,4 - blocklengths(i)=1 - enddo - displs(1)=0 - do i=2,4 - displs(i)=displs(i-1)+blocklengths(i-1)*maxres - enddo - do i=1,4 - blocklengths(i)=blocklengths(i)*ichunk - enddo - call MPI_Type_indexed(4,blocklengths,displs, - & MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR) - call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR) - enddo -#endif - endif - iint_start=ivec_start+1 - iint_end=ivec_end+1 - do i=0,nfgtasks-1 - iint_count(i)=ivec_count(i) - iint_displ(i)=ivec_displ(i) - ivec_displ(i)=ivec_displ(i)-1 - iset_displ(i)=iset_displ(i)-1 - ithet_displ(i)=ithet_displ(i)-1 - iphi_displ(i)=iphi_displ(i)-1 - iphi1_displ(i)=iphi1_displ(i)-1 - ibond_displ(i)=ibond_displ(i)-1 - enddo - if (nfgtasks.gt.1 .and. fg_rank.eq.king - & .and. (me.eq.0 .or. out1file)) then - write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT" - do i=0,nfgtasks-1 - write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i), - & iset_count(i) - enddo - write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end, - & " iphi1_start",iphi1_start," iphi1_end",iphi1_end - write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL" - do i=0,nfgtasks-1 - write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i), - & iphi1_displ(i) - enddo - write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ', - & nele_int_tot,' electrostatic and ',nscp_int_tot, - & ' SC-p interactions','were distributed among',nfgtasks, - & ' fine-grain processors.' - endif -#else - loc_start=2 - loc_end=nres-1 - ithet_start=3 - ithet_end=nres - iturn3_start=nnt - iturn3_end=nct-3 - iturn4_start=nnt - iturn4_end=nct-4 - iphi_start=nnt+3 - iphi_end=nct - iphi1_start=4 - iphi1_end=nres - idihconstr_start=1 - idihconstr_end=ndih_constr - iphid_start=iphi_start - iphid_end=iphi_end-1 - ibond_start=2 - ibond_end=nres-1 - ibondp_start=nnt+1 - ibondp_end=nct - ivec_start=1 - ivec_end=nres-1 - iset_start=3 - iset_end=nres+1 - iint_start=2 - iint_end=nres-1 -#endif - return - end -#ifdef MPI -c--------------------------------------------------------------------------- - subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag) - implicit none - include "DIMENSIONS" - include "COMMON.INTERACT" - include "COMMON.SETUP" - include "COMMON.IOUNITS" - integer ii,jj,itask(4),ntask_cont_to,itask_cont_to(0:MaxProcs-1) - logical flag - integer iturn3_start_all,iturn3_end_all,iturn4_start_all, - & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all - common /przechowalnia/ iturn3_start_all(0:MaxProcs), - & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs), - & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs), - & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1), - & ielend_all(maxres,0:MaxProcs-1) - integer iproc,isent,k,l -c Determines whether to send interaction ii,jj to other processors; a given -c interaction can be sent to at most 2 processors. -c Sets flag=.true. if interaction ii,jj needs to be sent to at least -c one processor, otherwise flag is unchanged from the input value. - isent=0 - itask(1)=fg_rank - itask(2)=fg_rank - itask(3)=fg_rank - itask(4)=fg_rank -c write (iout,*) "ii",ii," jj",jj -c Loop over processors to check if anybody could need interaction ii,jj - do iproc=0,fg_rank-1 -c Check if the interaction matches any turn3 at iproc - do k=iturn3_start_all(iproc),iturn3_end_all(iproc) - l=k+2 - if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1 - & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1) - & then -c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l -c call flush(iout) - flag=.true. - if (iproc.ne.itask(1).and.iproc.ne.itask(2) - & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then - isent=isent+1 - itask(isent)=iproc - call add_task(iproc,ntask_cont_to,itask_cont_to) - endif - endif - enddo -C Check if the interaction matches any turn4 at iproc - do k=iturn4_start_all(iproc),iturn4_end_all(iproc) - l=k+3 - if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1 - & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1) - & then -c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l -c call flush(iout) - flag=.true. - if (iproc.ne.itask(1).and.iproc.ne.itask(2) - & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then - isent=isent+1 - itask(isent)=iproc - call add_task(iproc,ntask_cont_to,itask_cont_to) - endif - endif - enddo - if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and. - & iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then - if (ielstart_all(ii-1,iproc).le.jj-1.and. - & ielend_all(ii-1,iproc).ge.jj-1) then - flag=.true. - if (iproc.ne.itask(1).and.iproc.ne.itask(2) - & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then - isent=isent+1 - itask(isent)=iproc - call add_task(iproc,ntask_cont_to,itask_cont_to) - endif - endif - if (ielstart_all(ii-1,iproc).le.jj+1.and. - & ielend_all(ii-1,iproc).ge.jj+1) then - flag=.true. - if (iproc.ne.itask(1).and.iproc.ne.itask(2) - & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then - isent=isent+1 - itask(isent)=iproc - call add_task(iproc,ntask_cont_to,itask_cont_to) - endif - endif - endif - enddo - return - end -c--------------------------------------------------------------------------- - subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from) - implicit none - include "DIMENSIONS" - include "COMMON.INTERACT" - include "COMMON.SETUP" - include "COMMON.IOUNITS" - integer ii,jj,itask(2),ntask_cont_from, - & itask_cont_from(0:MaxProcs-1) - logical flag - integer iturn3_start_all,iturn3_end_all,iturn4_start_all, - & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all - common /przechowalnia/ iturn3_start_all(0:MaxProcs), - & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs), - & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs), - & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1), - & ielend_all(maxres,0:MaxProcs-1) - integer iproc,k,l - do iproc=fg_rank+1,nfgtasks-1 - do k=iturn3_start_all(iproc),iturn3_end_all(iproc) - l=k+2 - if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1 - & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1) - & then -c write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - enddo - do k=iturn4_start_all(iproc),iturn4_end_all(iproc) - l=k+3 - if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1 - & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1) - & then -c write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - enddo - if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then - if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc)) - & then - if (jj+1.ge.ielstart_all(ii+1,iproc).and. - & jj+1.le.ielend_all(ii+1,iproc)) then - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - if (jj-1.ge.ielstart_all(ii+1,iproc).and. - & jj-1.le.ielend_all(ii+1,iproc)) then - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - endif - if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc)) - & then - if (jj-1.ge.ielstart_all(ii-1,iproc).and. - & jj-1.le.ielend_all(ii-1,iproc)) then - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - if (jj+1.ge.ielstart_all(ii-1,iproc).and. - & jj+1.le.ielend_all(ii-1,iproc)) then - call add_task(iproc,ntask_cont_from,itask_cont_from) - endif - endif - endif - enddo - return - end -c--------------------------------------------------------------------------- - subroutine add_task(iproc,ntask_cont,itask_cont) - implicit none - include "DIMENSIONS" - integer iproc,ntask_cont,itask_cont(0:MaxProcs-1) - integer ii - do ii=1,ntask_cont - if (itask_cont(ii).eq.iproc) return - enddo - ntask_cont=ntask_cont+1 - itask_cont(ntask_cont)=iproc - return - end -c--------------------------------------------------------------------------- - subroutine int_bounds(total_ints,lower_bound,upper_bound) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - integer total_ints,lower_bound,upper_bound - integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs) - nint=total_ints/nfgtasks - do i=1,nfgtasks - int4proc(i-1)=nint - enddo - nexcess=total_ints-nint*nfgtasks - do i=1,nexcess - int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1 - enddo - lower_bound=0 - do i=0,fg_rank-1 - lower_bound=lower_bound+int4proc(i) - enddo - upper_bound=lower_bound+int4proc(fg_rank) - lower_bound=lower_bound+1 - return - end -c--------------------------------------------------------------------------- - subroutine int_bounds1(total_ints,lower_bound,upper_bound) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.SETUP' - integer total_ints,lower_bound,upper_bound - integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs) - nint=total_ints/nfgtasks1 - do i=1,nfgtasks1 - int4proc(i-1)=nint - enddo - nexcess=total_ints-nint*nfgtasks1 - do i=1,nexcess - int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1 - enddo - lower_bound=0 - do i=0,fg_rank1-1 - lower_bound=lower_bound+int4proc(i) - enddo - upper_bound=lower_bound+int4proc(fg_rank1) - lower_bound=lower_bound+1 - return - end -c--------------------------------------------------------------------------- - subroutine int_partition(int_index,lower_index,upper_index,atom, - & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - integer int_index,lower_index,upper_index,atom,at_start,at_end, - & first_atom,last_atom,int_gr,jat_start,jat_end - logical lprn - lprn=.false. - if (lprn) write (iout,*) 'int_index=',int_index - int_index_old=int_index - int_index=int_index+last_atom-first_atom+1 - if (lprn) - & write (iout,*) 'int_index=',int_index, - & ' int_index_old',int_index_old, - & ' lower_index=',lower_index, - & ' upper_index=',upper_index, - & ' atom=',atom,' first_atom=',first_atom, - & ' last_atom=',last_atom - if (int_index.ge.lower_index) then - int_gr=int_gr+1 - if (at_start.eq.0) then - at_start=atom - jat_start=first_atom-1+lower_index-int_index_old - else - jat_start=first_atom - endif - if (lprn) write (iout,*) 'jat_start',jat_start - if (int_index.ge.upper_index) then - at_end=atom - jat_end=first_atom-1+upper_index-int_index_old - return1 - else - jat_end=last_atom - endif - if (lprn) write (iout,*) 'jat_end',jat_end - endif - return - end -#endif -c------------------------------------------------------------------------------ - subroutine hpb_partition - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SBRIDGE' - include 'COMMON.IOUNITS' - include 'COMMON.SETUP' - include 'COMMON.CONTROL' -#ifdef MPI - call int_bounds(nhpb,link_start,link_end) - if (.not. out1file) - & write (iout,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',MyRank, - & ' nhpb',nhpb,' link_start=',link_start, - & ' link_end',link_end -#else - link_start=1 - link_end=nhpb -#endif - return - end diff --git a/source/unres/src_MIN/int_to_cart.f b/source/unres/src_MIN/int_to_cart.f deleted file mode 100644 index 97324ec..0000000 --- a/source/unres/src_MIN/int_to_cart.f +++ /dev/null @@ -1,119 +0,0 @@ - subroutine int_to_cart -c-------------------------------------------------------------- -c This subroutine converts the energy derivatives from internal -c coordinates to cartesian coordinates -c------------------------------------------------------------- - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.MD_' - include 'COMMON.IOUNITS' - -c calculating dE/ddc1 - if (nres.lt.3) return - do j=1,3 - gcart(j,1)=gcart(j,1)+gloc(1,icg)*dphi(j,1,4) - & +gloc(nres-2,icg)*dtheta(j,1,3) - if(itype(2).ne.10) then - gcart(j,1)=gcart(j,1)+gloc(ialph(2,1),icg)*dalpha(j,1,2)+ - & gloc(ialph(2,1)+nside,icg)*domega(j,1,2) - endif - enddo -c Calculating the remainder of dE/ddc2 - do j=1,3 - gcart(j,2)=gcart(j,2)+gloc(1,icg)*dphi(j,2,4)+ - & gloc(nres-2,icg)*dtheta(j,2,3)+gloc(nres-1,icg)*dtheta(j,1,4) - if(itype(2).ne.10) then - gcart(j,2)=gcart(j,2)+gloc(ialph(2,1),icg)*dalpha(j,2,2)+ - & gloc(ialph(2,1)+nside,icg)*domega(j,2,2) - endif - if(itype(3).ne.10) then - gcart(j,2)=gcart(j,2)+gloc(ialph(3,1),icg)*dalpha(j,1,3)+ - & gloc(ialph(3,1)+nside,icg)*domega(j,1,3) - endif - if(nres.gt.4) then - gcart(j,2)=gcart(j,2)+gloc(2,icg)*dphi(j,1,5) - endif - enddo -c If there are only five residues - if(nres.eq.5) then - do j=1,3 - gcart(j,3)=gcart(j,3)+gloc(1,icg)*dphi(j,3,4)+gloc(2,icg)* - & dphi(j,2,5)+gloc(nres-1,icg)*dtheta(j,2,4)+gloc(nres,icg)* - & dtheta(j,1,5) - if(itype(3).ne.10) then - gcart(j,3)=gcart(j,3)+gloc(ialph(3,1),icg)* - & dalpha(j,2,3)+gloc(ialph(3,1)+nside,icg)*domega(j,2,3) - endif - if(itype(4).ne.10) then - gcart(j,3)=gcart(j,3)+gloc(ialph(4,1),icg)* - & dalpha(j,1,4)+gloc(ialph(4,1)+nside,icg)*domega(j,1,4) - endif - enddo - endif -c If there are more than five residues - if(nres.gt.5) then - do i=3,nres-3 - do j=1,3 - gcart(j,i)=gcart(j,i)+gloc(i-2,icg)*dphi(j,3,i+1) - & +gloc(i-1,icg)*dphi(j,2,i+2)+ - & gloc(i,icg)*dphi(j,1,i+3)+gloc(nres+i-4,icg)*dtheta(j,2,i+1)+ - & gloc(nres+i-3,icg)*dtheta(j,1,i+2) - if(itype(i).ne.10) then - gcart(j,i)=gcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,2,i)+ - & gloc(ialph(i,1)+nside,icg)*domega(j,2,i) - endif - if(itype(i+1).ne.10) then - gcart(j,i)=gcart(j,i)+gloc(ialph(i+1,1),icg)*dalpha(j,1,i+1) - & +gloc(ialph(i+1,1)+nside,icg)*domega(j,1,i+1) - endif - enddo - enddo - endif -c Setting dE/ddnres-2 - if(nres.gt.5) then - do j=1,3 - gcart(j,nres-2)=gcart(j,nres-2)+gloc(nres-4,icg)* - & dphi(j,3,nres-1)+gloc(nres-3,icg)*dphi(j,2,nres) - & +gloc(2*nres-6,icg)* - & dtheta(j,2,nres-1)+gloc(2*nres-5,icg)*dtheta(j,1,nres) - if(itype(nres-2).ne.10) then - gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-2,1),icg)* - & dalpha(j,2,nres-2)+gloc(ialph(nres-2,1)+nside,icg)* - & domega(j,2,nres-2) - endif - if(itype(nres-1).ne.10) then - gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-1,1),icg)* - & dalpha(j,1,nres-1)+gloc(ialph(nres-1,1)+nside,icg)* - & domega(j,1,nres-1) - endif - enddo - endif -c Settind dE/ddnres-1 - do j=1,3 - gcart(j,nres-1)=gcart(j,nres-1)+gloc(nres-3,icg)*dphi(j,3,nres)+ - & gloc(2*nres-5,icg)*dtheta(j,2,nres) - if(itype(nres-1).ne.10) then - gcart(j,nres-1)=gcart(j,nres-1)+gloc(ialph(nres-1,1),icg)* - & dalpha(j,2,nres-1)+gloc(ialph(nres-1,1)+nside,icg)* - & domega(j,2,nres-1) - endif - enddo -c The side-chain vector derivatives - do i=2,nres-1 - if(itype(i).ne.10) then - do j=1,3 - gxcart(j,i)=gxcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,3,i) - & +gloc(ialph(i,1)+nside,icg)*domega(j,3,i) - enddo - endif - enddo - return - end - - diff --git a/source/unres/src_MIN/intcartderiv.F b/source/unres/src_MIN/intcartderiv.F deleted file mode 100644 index 5fea875..0000000 --- a/source/unres/src_MIN/intcartderiv.F +++ /dev/null @@ -1,466 +0,0 @@ - subroutine intcartderiv - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.LOCAL' - double precision dcostheta(3,2,maxres), - & dcosphi(3,3,maxres),dsinphi(3,3,maxres), - & dcosalpha(3,3,maxres),dcosomega(3,3,maxres), - & dsinomega(3,3,maxres),vo1(3),vo2(3),vo3(3), - & dummy(3),vp1(3),vp2(3),vp3(3),vpp1(3),n(3) - -#if defined(MPI) && defined(PARINTDER) - if (nfgtasks.gt.1 .and. me.eq.king) - & call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif - pi4 = 0.5d0*pipol - pi34 = 3*pi4 - -c write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end -c Derivatives of theta's -#if defined(MPI) && defined(PARINTDER) -c We need dtheta(:,:,i-1) to compute dphi(:,:,i) - do i=max0(ithet_start-1,3),ithet_end -#else - do i=3,nres -#endif - cost=dcos(theta(i)) - sint=sqrt(1-cost*cost) - do j=1,3 - dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/ - & vbld(i-1) - dtheta(j,1,i)=-1/sint*dcostheta(j,1,i) - dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/ - & vbld(i) - dtheta(j,2,i)=-1/sint*dcostheta(j,2,i) - enddo - enddo - -c Derivatives of phi: -c If phi is 0 or 180 degrees, then the formulas -c have to be derived by power series expansion of the -c conventional formulas around 0 and 180. -#ifdef PARINTDER - do i=iphi1_start,iphi1_end -#else - do i=4,nres -#endif -c the conventional case - sint=dsin(theta(i)) - sint1=dsin(theta(i-1)) - sing=dsin(phi(i)) - cost=dcos(theta(i)) - cost1=dcos(theta(i-1)) - cosg=dcos(phi(i)) - scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1)) - fac0=1.0d0/(sint1*sint) - fac1=cost*fac0 - fac2=cost1*fac0 - fac3=cosg*cost1/(sint1*sint1) - fac4=cosg*cost/(sint*sint) -c Obtaining the gamma derivatives from sine derivative - if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. - & phi(i).gt.pi34.and.phi(i).le.pi.or. - & phi(i).gt.-pi.and.phi(i).le.-pi34) then - call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2) - call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) - do j=1,3 - ctgt=cost/sint - ctgt1=cost1/sint1 - cosg_inv=1.0d0/cosg - dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) - & -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2) - dphi(j,1,i)=cosg_inv*dsinphi(j,1,i) - dsinphi(j,2,i)= - & -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) - & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) - dphi(j,2,i)=cosg_inv*dsinphi(j,2,i) -c Bug fixed 3/24/05 (AL) - dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) - & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) -c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) - dphi(j,3,i)=cosg_inv*dsinphi(j,3,i) - enddo -c Obtaining the gamma derivatives from cosine derivative - else - do j=1,3 - dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* - & dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* - & dc_norm(j,i-3))/vbld(i-2) - dphi(j,1,i)=-1/sing*dcosphi(j,1,i) - dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* - & dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* - & dcostheta(j,1,i) - dphi(j,2,i)=-1/sing*dcosphi(j,2,i) - dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* - & dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* - & dc_norm(j,i-1))/vbld(i) - dphi(j,3,i)=-1/sing*dcosphi(j,3,i) - enddo - endif - enddo -#ifdef CRYST_SC -c Derivatives of side-chain angles alpha and omega -#if defined(MPI) && defined(PARINTDER) - do i=ibond_start,ibond_end -#else - do i=2,nres-1 -#endif - if(itype(i).ne.10) then - fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1)))) - fac6=fac5/vbld(i) - fac7=fac5*fac5 - fac8=fac5/vbld(i+1) - fac9=fac5/vbld(i+nres) - scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) - scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres)) - cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))*( - & scalar(dC_norm(1,i),dC_norm(1,i+nres)) - & -scalar(dC_norm(1,i-1),dC_norm(1,i+nres))) - sina=sqrt(1-cosa*cosa) - sino=dsin(omeg(i)) - do j=1,3 - dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- - & dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1) - dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i) - dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- - & scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1) - dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i) - dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- - & dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ - & vbld(i+nres)) - dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i) - enddo -c obtaining the derivatives of omega from sines - if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. - & omeg(i).gt.pi34.and.omeg(i).le.pi.or. - & omeg(i).gt.-pi.and.omeg(i).le.-pi34) then - fac15=dcos(theta(i+1))/(dsin(theta(i+1))* - & dsin(theta(i+1))) - fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i))) - fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i))) - call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1) - call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2) - call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3) - coso_inv=1.0d0/dcos(omeg(i)) - do j=1,3 - dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) - & +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)-( - & sino*dc_norm(j,i-1))/vbld(i) - domega(j,1,i)=coso_inv*dsinomega(j,1,i) - dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) - & +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) - & -sino*dc_norm(j,i)/vbld(i+1) - domega(j,2,i)=coso_inv*dsinomega(j,2,i) - dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- - & fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ - & vbld(i+nres) - domega(j,3,i)=coso_inv*dsinomega(j,3,i) - enddo - else -c obtaining the derivatives of omega from cosines - fac10=sqrt(0.5d0*(1-dcos(theta(i+1)))) - fac11=sqrt(0.5d0*(1+dcos(theta(i+1)))) - fac12=fac10*sina - fac13=fac12*fac12 - fac14=sina*sina - do j=1,3 - dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* - & dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ - & (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* - & fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13 - domega(j,1,i)=-1/sino*dcosomega(j,1,i) - dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* - & dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* - & dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ - & (scala2-fac11*cosa)*(0.25d0*sina/fac10* - & dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i) - & ))/fac13 - domega(j,2,i)=-1/sino*dcosomega(j,2,i) - dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- - & scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ - & (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14 - domega(j,3,i)=-1/sino*dcosomega(j,3,i) - enddo - endif - endif - enddo -#endif -#if defined(MPI) && defined(PARINTDER) - if (nfgtasks.gt.1) then -#ifdef DEBUG -cd write (iout,*) "Gather dtheta" -cd call flush(iout) - write (iout,*) "dtheta before gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2) - enddo -#endif - call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank), - & MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET, - & king,FG_COMM,IERROR) -#ifdef DEBUG -cd write (iout,*) "Gather dphi" -cd call flush(iout) - write (iout,*) "dphi before gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3) - enddo -#endif - call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank), - & MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM, - & king,FG_COMM,IERROR) -cd write (iout,*) "Gather dalpha" -cd call flush(iout) -#ifdef CRYST_SC - call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank), - & MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM, - & king,FG_COMM,IERROR) -cd write (iout,*) "Gather domega" -cd call flush(iout) - call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank), - & MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM, - & king,FG_COMM,IERROR) -#endif - endif -#endif -#ifdef DEBUG - write (iout,*) "dtheta after gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),j=1,2) - enddo - write (iout,*) "dphi after gather" - do i=1,nres - write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3) - enddo -#endif - return - end - - subroutine checkintcartgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.SETUP' - double precision dthetanum(3,2,maxres),dphinum(3,3,maxres) - & ,dalphanum(3,3,maxres), domeganum(3,3,maxres) - double precision theta_s(maxres),phi_s(maxres),alph_s(maxres), - & omeg_s(maxres),dc_norm_s(3) - double precision aincr /1.0d-5/ - - do i=1,nres - phi_s(i)=phi(i) - theta_s(i)=theta(i) - alph_s(i)=alph(i) - omeg_s(i)=omeg(i) - enddo -c Check theta gradient - write (iout,*) - & "Analytical (upper) and numerical (lower) gradient of theta" - write (iout,*) - do i=3,nres - do j=1,3 - dcji=dc(j,i-2) - dc(j,i-2)=dcji+aincr - call chainbuild_cart - call int_from_cart1(.false.) - dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr - dc(j,i-2)=dcji - dcji=dc(j,i-1) - dc(j,i-1)=dc(j,i-1)+aincr - call chainbuild_cart - dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr - dc(j,i-1)=dcji - enddo - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3), - & (dtheta(j,2,i),j=1,3) - write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3), - & (dthetanum(j,2,i),j=1,3) - write (iout,'(5x,3f10.5,5x,3f10.5)') - & (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3), - & (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3) - write (iout,*) - enddo -c Check gamma gradient - write (iout,*) - & "Analytical (upper) and numerical (lower) gradient of gamma" - do i=4,nres - do j=1,3 - dcji=dc(j,i-3) - dc(j,i-3)=dcji+aincr - call chainbuild_cart - dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr - dc(j,i-3)=dcji - dcji=dc(j,i-2) - dc(j,i-2)=dcji+aincr - call chainbuild_cart - dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr - dc(j,i-2)=dcji - dcji=dc(j,i-1) - dc(j,i-1)=dc(j,i-1)+aincr - call chainbuild_cart - dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr - dc(j,i-1)=dcji - enddo - write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3), - & (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3), - & (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') - & (dphinum(j,1,i)/dphi(j,1,i),j=1,3), - & (dphinum(j,2,i)/dphi(j,2,i),j=1,3), - & (dphinum(j,3,i)/dphi(j,3,i),j=1,3) - write (iout,*) - enddo -c Check alpha gradient - write (iout,*) - & "Analytical (upper) and numerical (lower) gradient of alpha" - do i=2,nres-1 - if(itype(i).ne.10) then - do j=1,3 - dcji=dc(j,i-1) - dc(j,i-1)=dcji+aincr - call chainbuild_cart - dalphanum(j,1,i)=(alph(i)-alph_s(i)) - & /aincr - dc(j,i-1)=dcji - dcji=dc(j,i) - dc(j,i)=dcji+aincr - call chainbuild_cart - dalphanum(j,2,i)=(alph(i)-alph_s(i)) - & /aincr - dc(j,i)=dcji - dcji=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+aincr - call chainbuild_cart - dalphanum(j,3,i)=(alph(i)-alph_s(i)) - & /aincr - dc(j,i+nres)=dcji - enddo - endif - write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3), - & (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3), - & (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') - & (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3), - & (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3), - & (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3) - write (iout,*) - enddo -c Check omega gradient - write (iout,*) - & "Analytical (upper) and numerical (lower) gradient of omega" - do i=2,nres-1 - if(itype(i).ne.10) then - do j=1,3 - dcji=dc(j,i-1) - dc(j,i-1)=dcji+aincr - call chainbuild_cart - domeganum(j,1,i)=(omeg(i)-omeg_s(i)) - & /aincr - dc(j,i-1)=dcji - dcji=dc(j,i) - dc(j,i)=dcji+aincr - call chainbuild_cart - domeganum(j,2,i)=(omeg(i)-omeg_s(i)) - & /aincr - dc(j,i)=dcji - dcji=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+aincr - call chainbuild_cart - domeganum(j,3,i)=(omeg(i)-omeg_s(i)) - & /aincr - dc(j,i+nres)=dcji - enddo - endif - write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3), - & (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3), - & (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3) - write (iout,'(5x,3(3f10.5,5x))') - & (domeganum(j,1,i)/domega(j,1,i),j=1,3), - & (domeganum(j,2,i)/domega(j,2,i),j=1,3), - & (domeganum(j,3,i)/domega(j,3,i),j=1,3) - write (iout,*) - enddo - return - end - - subroutine chainbuild_cart - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.TIME1' - include 'COMMON.IOUNITS' - -#ifdef MPI - if (nfgtasks.gt.1) then -c write (iout,*) "BCAST in chainbuild_cart" -c call flush(iout) -c Broadcast the order to build the chain and compute internal coordinates -c to the slaves. The slaves receive the order in ERGASTULUM. - time00=MPI_Wtime() -c write (iout,*) "CHAINBUILD_CART: DC before BCAST" -c do i=0,nres -c write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), -c & (dc(j,i+nres),j=1,3) -c enddo - if (fg_rank.eq.0) - & call MPI_Bcast(7,1,MPI_INTEGER,king,FG_COMM,IERROR) - time_bcast7=time_bcast7+MPI_Wtime()-time00 - time01=MPI_Wtime() - call MPI_Bcast(dc(1,0),6*(nres+1),MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "CHAINBUILD_CART: DC after BCAST" -c do i=0,nres -c write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), -c & (dc(j,i+nres),j=1,3) -c enddo -c write (iout,*) "End BCAST in chainbuild_cart" -c call flush(iout) - time_bcast=time_bcast+MPI_Wtime()-time00 - time_bcastc=time_bcastc+MPI_Wtime()-time01 - endif -#endif - do j=1,3 - c(j,1)=dc(j,0) - enddo - do i=2,nres - do j=1,3 - c(j,i)=c(j,i-1)+dc(j,i-1) - enddo - enddo - do i=1,nres - do j=1,3 - c(j,i+nres)=c(j,i)+dc(j,i+nres) - enddo - enddo -c write (iout,*) "CHAINBUILD_CART" -c call cartprint - call int_from_cart1(.false.) - return - end diff --git a/source/unres/src_MIN/intcor.f b/source/unres/src_MIN/intcor.f deleted file mode 100644 index a3cd5d0..0000000 --- a/source/unres/src_MIN/intcor.f +++ /dev/null @@ -1,91 +0,0 @@ -C -C------------------------------------------------------------------------------ -C - double precision function alpha(i1,i2,i3) -c -c Calculates the planar angle between atoms (i1), (i2), and (i3). -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - x12=c(1,i1)-c(1,i2) - x23=c(1,i3)-c(1,i2) - y12=c(2,i1)-c(2,i2) - y23=c(2,i3)-c(2,i2) - z12=c(3,i1)-c(3,i2) - z23=c(3,i3)-c(3,i2) - vnorm=dsqrt(x12*x12+y12*y12+z12*z12) - wnorm=dsqrt(x23*x23+y23*y23+z23*z23) - scalar=(x12*x23+y12*y23+z12*z23)/(vnorm*wnorm) - alpha=arcos(scalar) - return - end -C -C------------------------------------------------------------------------------ -C - double precision function beta(i1,i2,i3,i4) -c -c Calculates the dihedral angle between atoms (i1), (i2), (i3) and (i4) -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - x12=c(1,i1)-c(1,i2) - x23=c(1,i3)-c(1,i2) - x34=c(1,i4)-c(1,i3) - y12=c(2,i1)-c(2,i2) - y23=c(2,i3)-c(2,i2) - y34=c(2,i4)-c(2,i3) - z12=c(3,i1)-c(3,i2) - z23=c(3,i3)-c(3,i2) - z34=c(3,i4)-c(3,i3) -cd print '(2i3,3f10.5)',i1,i2,x12,y12,z12 -cd print '(2i3,3f10.5)',i2,i3,x23,y23,z23 -cd print '(2i3,3f10.5)',i3,i4,x34,y34,z34 - wx=-y23*z34+y34*z23 - wy=x23*z34-z23*x34 - wz=-x23*y34+y23*x34 - wnorm=dsqrt(wx*wx+wy*wy+wz*wz) - vx=y12*z23-z12*y23 - vy=-x12*z23+z12*x23 - vz=x12*y23-y12*x23 - vnorm=dsqrt(vx*vx+vy*vy+vz*vz) - if (vnorm.gt.1.0D-13 .and. wnorm.gt.1.0D-13) then - scalar=(vx*wx+vy*wy+vz*wz)/(vnorm*wnorm) - if (dabs(scalar).gt.1.0D0) - &scalar=0.99999999999999D0*scalar/dabs(scalar) - angle=dacos(scalar) -cd print '(2i4,10f7.3)',i2,i3,vx,vy,vz,wx,wy,wz,vnorm,wnorm, -cd &scalar,angle - else - angle=pi - endif -c if (angle.le.0.0D0) angle=pi+angle - tx=vy*wz-vz*wy - ty=-vx*wz+vz*wx - tz=vx*wy-vy*wx - scalar=tx*x23+ty*y23+tz*z23 - if (scalar.lt.0.0D0) angle=-angle - beta=angle - return - end -C -C------------------------------------------------------------------------------ -C - function dist(i1,i2) -c -c Calculates the distance between atoms (i1) and (i2). -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - x12=c(1,i1)-c(1,i2) - y12=c(2,i1)-c(2,i2) - z12=c(3,i1)-c(3,i2) - dist=dsqrt(x12*x12+y12*y12+z12*z12) - return - end -C diff --git a/source/unres/src_MIN/intlocal.f b/source/unres/src_MIN/intlocal.f deleted file mode 100644 index 2dbcc88..0000000 --- a/source/unres/src_MIN/intlocal.f +++ /dev/null @@ -1,517 +0,0 @@ - subroutine integral(gamma1,gamma2,gamma3,gamma4,ity1,ity2,a1,a2, - & si1,si2,si3,si4,transp,q) - implicit none - integer ity1,ity2 - integer ilam1,ilam2,ilam3,ilam4,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4 - logical transp - double precision elocal,ele - double precision delta,delta2,sum,ene,sumene,boltz - double precision q,a1(2,2),a2(2,2),si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=20 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) gamma1,gamma2,ity1,ity2,a1,a2,si1,si2,si3,si4,transp - -cd do ilam1=-180,180,5 -cd do ilam2=-180,180,5 -cd lambda1=ilam1*conv+delta2 -cd lambda2=ilam2*conv+delta2 -cd write(2,'(2i5,2f10.5)') ilam1,ilam2,elocal(2,lambda1,lambda2), -cd & ele(lambda1,lambda2,a1,1.0d0,1.d00) -cd enddo -cd enddo -cd stop - - sum=0.0d0 - sumene=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 -cd write (2,*) ilam1,ilam2,ilam3,ilam4 -cd write (2,*) lambda1,lambda2,lambda3,lambda4 - ene= - & -elocal(ity1,lambda1,lambda2,.false.)* - & elocal(ity2,lambda3,lambda4,transp)* - & ele(si1*lambda1+gamma1,si3*lambda3+gamma3,a1)* - & ele(si2*lambda2+gamma2,si4*lambda4+gamma4,a2) -cd write (2,*) elocal(ity1,lambda1,gamma1-pi-lambda2), -cd & elocal(ity2,lambda3,gamma2-pi-lambda4), -cd & ele(lambda1,lambda2,a1,si1,si3), -cd & ele(lambda3,lambda4,a2,si2,si4) - sum=sum+ene - enddo - enddo - enddo - enddo - q=sum/(2*pi)**4*delta**4 - write (2,* )'sum',sum,' q',q - return - end -c--------------------------------------------------------------------------- - subroutine integral3(gamma1,gamma2,ity1,ity2,ity3,ity4, - & a1,koniec,q1,q2,q3,q4) - implicit none - integer ity1,ity2,ity3,ity4 - integer ilam1,ilam2,ilam3,ilam4,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,lambda1, - & lambda2,lambda3,lambda4 - logical koniec - double precision elocal,ele - double precision delta,delta2,sum1,sum2,sum3,sum4, - & ene1,ene2,ene3,ene4,boltz - double precision q1,q2,q3,q4,a1(2,2),a2(2,2) - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta - write(2,*) gamma1,gamma2,ity1,ity2,ity3,ity4,a1,koniec - -cd do ilam1=-180,180,5 -cd do ilam2=-180,180,5 -cd lambda1=ilam1*conv+delta2 -cd lambda2=ilam2*conv+delta2 -cd write(2,'(2i5,2f10.5)') ilam1,ilam2,elocal(2,lambda1,lambda2), -cd & ele(lambda1,lambda2,a1,1.0d0,1.d00) -cd enddo -cd enddo -cd stop - - sum1=0.0d0 - sum2=0.0d0 - sum3=0.0d0 - sum4=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 -cd write (2,*) ilam1,ilam2,ilam3,ilam4 -cd write (2,*) lambda1,lambda2,lambda3,lambda4 - if (.not.koniec) then - ene1= - & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)* - & elocal(ity3,lambda3,gamma2-pi-lambda4,.false.)* - & ele(lambda2,lambda4,a1) - else - ene1= - & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)* - & elocal(ity3,lambda3,lambda4,.false.)* - & ele(lambda2,-lambda4,a1) - endif - ene2= - & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)* - & elocal(ity4,lambda3,lambda4,.false.)* - & ele(lambda2,lambda3,a1) - if (.not.koniec) then - ene3= - & elocal(ity2,lambda1,lambda2,.false.)* - & elocal(ity3,lambda3,gamma2-pi-lambda4,.false.)* - & ele(lambda1,lambda4,a1) - else - ene3= - & elocal(ity2,lambda1,lambda2,.false.)* - & elocal(ity3,lambda3,lambda4,.false.)* - & ele(lambda1,-lambda4,a1) - endif - ene4= - & elocal(ity2,lambda1,lambda2,.false.)* - & elocal(ity4,lambda3,lambda4,.false.)* - & ele(lambda1,lambda3,a1) - sum1=sum1+ene1 - sum2=sum2+ene2 - sum3=sum3+ene3 - sum4=sum4+ene4 - enddo - enddo - enddo - enddo - q1=sum1/(2*pi)**4*delta**4 - q2=sum2/(2*pi)**4*delta**4 - q3=sum3/(2*pi)**4*delta**4 - q4=sum4/(2*pi)**4*delta**4 - write (2,* )'sum',sum1,sum2,sum3,sum4,' q',q1,q2,q3,q4 - return - end -c------------------------------------------------------------------------- - subroutine integral5(gamma1,gamma2,gamma3,gamma4,ity1,ity2,ity3, - & ity4,ity5,ity6,a1,a2,si1,si2,si3,si4,transp,ene1,ene2,ene3,ene4) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc5,eloc6,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,sum1,sum2,sum3,sum4, - & a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, -cd & ' gamma3=',gamma3,' gamma4=',gamma4 -cd write(2,*) ity1,ity2,ity3,ity4,ity5,ity6 -cd write(2,*) 'a1=',a1 -cd write(2,*) 'a2=',a2 -cd write(2,*) si1,si2,si3,si4,transp - - sum1=0.0d0 - sum2=0.0d0 - sum3=0.0d0 - sum4=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - do ilam5=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - lambda5=ilam5*conv+delta2 - if (transp) then - ele1=ele(lambda1,si4*lambda4,a1) - ele2=ele(lambda2,lambda3,a2) - else - ele1=ele(lambda1,lambda3,a1) - ele2=ele(lambda2,si4*lambda4,a2) - endif - eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.) - eloc5=elocal(ity5,lambda3,gamma4-pi-si4*lambda4,.false.) - pom=ele1*ele2*eloc2*eloc5 - if (si1.gt.0) then - eloc1=elocal(ity1,lambda5,gamma1-pi-lambda1,.false.) - sum1=sum1+pom*eloc1 - endif - eloc3=elocal(ity3,lambda2,lambda5,.false.) - sum2=sum2+pom*eloc3 - eloc4=elocal(ity4,lambda5,gamma3-pi-lambda3,.false.) - sum3=sum3+pom*eloc4 - if (si4.gt.0) then - eloc6=elocal(ity6,lambda4,lambda5,.false.) - sum4=sum4+pom*eloc6 - endif - enddo - enddo - enddo - enddo - enddo - pom=1.0d0/(2*pi)**5*delta**5 - ene1=sum1*pom - ene2=sum2*pom - ene3=sum3*pom - ene4=sum4*pom -c write (2,* )'sum',sum1,sum2,sum3,sum4,' q',ene1,ene2,ene3,ene4 - return - end -c------------------------------------------------------------------------- - subroutine integral_turn6(gamma1,gamma2,gamma3,gamma4,ity1,ity2, - & ity3,ity4,ity5,ity6,a1,a2,ene_turn6) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom,ene5 - double precision ene_turn6,sum5,a1(2,2),a2(2,2) - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta - write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, - & ' gamma3=',gamma3,' gamma4=',gamma4 - write(2,*) ity1,ity2,ity3,ity4,ity5,ity6 - write(2,*) 'a1=',a1 - write(2,*) 'a2=',a2 - - sum5=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - do ilam5=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - lambda5=ilam5*conv+delta2 - ele1=ele(lambda1,-lambda4,a1) - ele2=ele(lambda2,lambda3,a2) - eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.) - eloc5=elocal(ity5,lambda3,lambda4,.false.) - pom=ele1*ele2*eloc2*eloc5 - eloc3=elocal(ity3,lambda2,gamma3-pi-lambda5,.false.) - eloc4=elocal(ity4,lambda5,gamma4-pi-lambda3,.false.) - sum5=sum5+pom*eloc3*eloc4 - enddo - enddo - enddo - enddo - enddo - pom=-1.0d0/(2*pi)**5*delta**5 - ene_turn6=sum5*pom -c print *,'sum6',sum6,' ene6',ene6 - return - end -c------------------------------------------------------------------------- - subroutine integral6(gamma1,gamma2,gamma3,gamma4,ity1,ity2,ity3, - & ity4,ity5,ity6,a1,a2,si1,si2,si3,si4,transp,ene1,ene2,ene3,ene4, - & ene5,ene6) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3, - & sum4,sum5,sum6,a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, -cd & ' gamma3=',gamma3,' gamma4=',gamma4 -cd write(2,*) ity1,ity2,ity3,ity4,ity5,ity6 -cd write(2,*) 'a1=',a1 -cd write(2,*) 'a2=',a2 -cd write(2,*) si1,si2,si3,si4,transp - - sum1=0.0d0 - sum2=0.0d0 - sum3=0.0d0 - sum4=0.0d0 - sum5=0.0d0 - sum6=0.0d0 - eloc1=0.0d0 - eloc6=0.0d0 - eloc61=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - do ilam5=-180,179,iincr - do ilam6=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - lambda5=ilam5*conv+delta2 - lambda6=ilam6*conv+delta2 - if (transp) then - ele1=ele(lambda1,si4*lambda4,a1) - ele2=ele(lambda2,lambda3,a2) - else - ele1=ele(lambda1,lambda3,a1) - ele2=ele(lambda2,si4*lambda4,a2) - endif - eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.) - eloc5=elocal(ity5,lambda3,gamma4-pi-si4*lambda4,.false.) - pom=ele1*ele2*eloc2*eloc5 - if (si1.gt.0) then - eloc1=elocal(ity1,lambda5,gamma1-pi-lambda1,.false.) - endif - eloc3=elocal(ity3,lambda2,lambda6,.false.) - sum1=sum1+pom*eloc1*eloc3 - eloc4=elocal(ity4,lambda5,gamma3-pi-lambda3,.false.) - if (si4.gt.0) then - eloc6=elocal(ity6,lambda4,lambda6,.false.) - eloc61=elocal(ity6,lambda4,lambda5,.false.) - endif - sum2=sum2+pom*eloc4*eloc6 - eloc41=elocal(ity4,lambda6,gamma3-pi-lambda3,.false.) - sum3=sum3+pom*eloc1*eloc41 - sum4=sum4+pom*eloc1*eloc6 - sum5=sum5+pom*eloc3*eloc4 - sum6=sum6+pom*eloc3*eloc61 - enddo - enddo - enddo - enddo - enddo - enddo - pom=-1.0d0/(2*pi)**6*delta**6 - ene1=sum1*pom - ene2=sum2*pom - ene3=sum3*pom - ene4=sum4*pom - ene5=sum5*pom - ene6=sum6*pom -c print *,'sum6',sum6,' ene6',ene6 - return - end -c------------------------------------------------------------------------- - subroutine integral3a(gamma1,gamma2,ity1,ity2,a1,si1,ene1) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3, - & sum4,sum5,sum6,a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2 -cd write(2,*) ity1,ity2 -cd write(2,*) 'a1=',a1 -cd write(2,*) si1, - - sum1=0.0d0 - eloc1=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - ele1=ele(lambda1,si1*lambda3,a1) - eloc1=elocal(ity1,lambda1,gamma1-pi-lambda2,.false.) - if (si1.gt.0) then - eloc2=elocal(ity2,lambda2,gamma2-pi-lambda3,.false.) - else - eloc2=elocal(ity2,lambda2,lambda3,.false.) - endif - sum1=sum1+ele1*eloc1*eloc2 - enddo - enddo - enddo - pom=1.0d0/(2*pi)**3*delta**3 - ene1=sum1*pom - return - end -c------------------------------------------------------------------------- - subroutine integral4a(gamma1,gamma2,gamma3,ity1,ity2,ity3,a1,si1, - & ene1) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3, - & sum4,sum5,sum6,a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, -cd & ' gamma3=',gamma3 -cd write(2,*) ity1,ity2,ity3 -cd write(2,*) 'a1=',a1 -cd write(2,*) 'si1=',si1 - sum1=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - ele1=ele(lambda1,si1*lambda4,a1) - eloc1=elocal(ity1,lambda1,gamma1-pi-lambda2,.false.) - eloc2=elocal(ity2,lambda2,gamma2-pi-lambda3,.false.) - if (si1.gt.0) then - eloc3=elocal(ity3,lambda3,gamma3-pi-lambda4,.false.) - else - eloc3=elocal(ity3,lambda3,lambda4,.false.) - endif - sum1=sum1+ele1*eloc1*eloc2*eloc3 - enddo - enddo - enddo - enddo - pom=-1.0d0/(2*pi)**4*delta**4 - ene1=sum1*pom - return - end -c------------------------------------------------------------------------- - double precision function elocal(i,x,y,transp) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.TORSION' - integer i - double precision x,y,u(2),v(2),cu(2),dv(2),ev(2) - double precision scalar2 - logical transp - u(1)=dcos(x) - u(2)=dsin(x) - v(1)=dcos(y) - v(2)=dsin(y) - if (transp) then - call matvec2(cc(1,1,i),v,cu) - call matvec2(dd(1,1,i),u,dv) - call matvec2(ee(1,1,i),u,ev) - elocal=scalar2(b1(1,i),v)+scalar2(b2(1,i),u)+scalar2(cu,v)+ - & scalar2(dv,u)+scalar2(ev,v) - else - call matvec2(cc(1,1,i),u,cu) - call matvec2(dd(1,1,i),v,dv) - call matvec2(ee(1,1,i),v,ev) - elocal=scalar2(b1(1,i),u)+scalar2(b2(1,i),v)+scalar2(cu,u)+ - & scalar2(dv,v)+scalar2(ev,u) - endif - return - end -c------------------------------------------------------------------------- - double precision function ele(x,y,a) - implicit none - double precision x,y,a(2,2),si1,si2,u(2),v(2),av(2) - double precision scalar2 - u(1)=-cos(x) - u(2)= sin(x) - v(1)=-cos(y) - v(2)= sin(y) - call matvec2(a,v,av) - ele=scalar2(u,av) - return - end diff --git a/source/unres/src_MIN/matmult.f b/source/unres/src_MIN/matmult.f deleted file mode 100644 index e9257cf..0000000 --- a/source/unres/src_MIN/matmult.f +++ /dev/null @@ -1,18 +0,0 @@ - SUBROUTINE MATMULT(A1,A2,A3) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(3,3),A2(3,3),A3(3,3) - DIMENSION AI3(3,3) - DO 1 I=1,3 - DO 2 J=1,3 - A3IJ=0.0 - DO 3 K=1,3 - 3 A3IJ=A3IJ+A1(I,K)*A2(K,J) - AI3(I,J)=A3IJ - 2 CONTINUE - 1 CONTINUE - DO 4 I=1,3 - DO 4 J=1,3 - 4 A3(I,J)=AI3(I,J) - RETURN - END diff --git a/source/unres/src_MIN/minimize_p.F b/source/unres/src_MIN/minimize_p.F deleted file mode 100644 index 72190e8..0000000 --- a/source/unres/src_MIN/minimize_p.F +++ /dev/null @@ -1,625 +0,0 @@ - subroutine minimize(etot,x,iretcode,nfun) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) -********************************************************************* -* OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * -* the calling subprogram. * -* when d(i)=1.0, then v(35) is the length of the initial step, * -* calculated in the usual pythagorean way. * -* absolute convergence occurs when the function is within v(31) of * -* zero. unless you know the minimum value in advance, abs convg * -* is probably not useful. * -* relative convergence is when the model predicts that the function * -* will decrease by less than v(32)*abs(fun). * -********************************************************************* - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.MINIM' - common /srutu/ icall - dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) - double precision energia(0:n_ene) - external func,gradient,fdum - external func_restr,grad_restr - logical not_done,change,reduce -c common /przechowalnia/ v - - icall = 1 -C Following 3 line for diagnostics; comment out if not needed - write(iout,*) "Enter MINIMIZE liv",liv," lv",lv - write (iout,*) "Coordinates before minimization" - call intout - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit - iv(21)=0 - if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout -* 1 means to print out result - iv(22)=print_min_res -* 1 means to print out summary stats - iv(23)=print_min_stat -* 1 means to print initial x and d - iv(24)=print_min_ini -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -c v(25)=4.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo -cd print *,'Calling SUMSL' - IF (mask_r) THEN - call x2xx(x,xx,nvar_restr) - call sumsl(nvar_restr,d,xx,func_restr,grad_restr, - & iv,liv,lv,v,idum,rdum,fdum) - call xx2x(x,xx) - ELSE - call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) - ENDIF - etot=v(10) - iretcode=iv(1) -cd print *,'Exit SUMSL; return code:',iretcode,' energy:',etot - write (iout,'(/a,i4,a,f15.5/)') 'SUMSL return code:',iv(1), - & " energy",etot - call var_to_geom(nvar,x) -c call chainbuild -c call etotal(energia(0)) -c etot=energia(0) -c call enerprint(energia(0)) - nfun=iv(6) - - return - end -#ifdef MPI -c---------------------------------------------------------------------------- - subroutine ergastulum - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SETUP' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.INTERACT' - include 'COMMON.MD_' - include 'COMMON.TIME1' - double precision z(maxres6),d_a_tmp(maxres6) - double precision edum(0:n_ene),time_order(0:10) - double precision Gcopy(maxres2,maxres2) - common /przechowalnia/ Gcopy - integer icall /0/ -C Workers wait for variables and NF, and NFL from the boss - iorder=0 - do while (iorder.ge.0) -c write (*,*) 'Processor',fg_rank,' CG group',kolor, -c & ' receives order from Master' - time00=MPI_Wtime() - call MPI_Bcast(iorder,1,MPI_INTEGER,king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 - if (icall.gt.4 .and. iorder.ge.0) - & time_order(iorder)=time_order(iorder)+MPI_Wtime()-time00 - icall=icall+1 -c write (*,*) -c & 'Processor',fg_rank,' completed receive MPI_BCAST order',iorder - if (iorder.eq.0) then - call zerograd - call etotal(edum) -c write (2,*) "After etotal" -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - else if (iorder.eq.2) then - call zerograd -cmd call etotal_short(edum) -c write (2,*) "After etotal_short" -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - else if (iorder.eq.3) then - call zerograd -cmd call etotal_long(edum) -c write (2,*) "After etotal_long" -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - else if (iorder.eq.1) then - call sum_gradient -c write (2,*) "After sum_gradient" -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - else if (iorder.eq.4) then -cmd call ginv_mult(z,d_a_tmp) - else if (iorder.eq.5) then -c Setup MD things for a slave - dimen=(nct-nnt+1)+nside - dimen1=(nct-nnt)+(nct-nnt+1) - dimen3=dimen*3 -c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) - call int_bounds(dimen,igmult_start,igmult_end) - igmult_start=igmult_start-1 - call MPI_Allgather(3*igmult_start,1,MPI_INTEGER, - & ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - my_ng_count=igmult_end-igmult_start - call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1, - & MPI_INTEGER,FG_COMM,IERROR) -c write (2,*) "ng_start",(ng_start(i),i=0,nfgtasks-1) -c write (2,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1) - myginv_ng_count=maxres2*my_ng_count -c write (2,*) "igmult_start",igmult_start," igmult_end", -c & igmult_end," my_ng_count",my_ng_count -c call flush(2) - call MPI_Allgather(maxres2*igmult_start,1,MPI_INTEGER, - & nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER, - & nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR) -c write (2,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1) -c write (2,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1) -c call flush(2) -c call MPI_Barrier(FG_COMM,IERROR) - time00=MPI_Wtime() - call MPI_Scatterv(ginv(1,1),nginv_counts(0), - & nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1), - & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) -#ifdef TIMING - time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00 -#endif - do i=1,dimen - do j=1,2*my_ng_count - ginv(j,i)=gcopy(i,j) - enddo - enddo -c write (2,*) "dimen",dimen," dimen3",dimen3 -c write (2,*) "End MD setup" -c call flush(2) -c write (iout,*) "My chunk of ginv_block" -c call MATOUT2(my_ng_count,dimen3,maxres2,maxers2,ginv_block) - else if (iorder.eq.6) then - call int_from_cart1(.false.) - else if (iorder.eq.7) then - call chainbuild_cart - else if (iorder.eq.8) then - call intcartderiv - else if (iorder.eq.9) then -cmd call fricmat_mult(z,d_a_tmp) - else if (iorder.eq.10) then -cmd call setup_fricmat - endif - enddo - write (*,*) 'Processor',fg_rank,' CG group',kolor, - & ' absolute rank',myrank,' leves ERGASTULUM.' - write(*,*)'Processor',fg_rank,' wait times for respective orders', - & (' order[',i,']',time_order(i),i=0,10) - return - end -#endif -************************************************************************ - subroutine func(n,x,nf,f,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - common /chuju/ jjj - double precision energia(0:n_ene) - integer jjj - double precision ufparm - external ufparm - integer uiparm(1) - real*8 urparm(1) - dimension x(maxvar) -c if (jjj.gt.0) then -c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -c endif - nfl=nf - icg=mod(nf,2)+1 -cd print *,'func',nf,nfl,icg - call var_to_geom(n,x) - call zerograd - call chainbuild -cd write (iout,*) 'ETOTAL called from FUNC' - call etotal(energia(0)) - call sum_gradient - f=energia(0) -c if (jjj.gt.0) then -c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -c write (iout,*) 'f=',etot -c jjj=0 -c endif - return - end -************************************************************************ - subroutine func_restr(n,x,nf,f,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - common /chuju/ jjj - double precision energia(0:n_ene) - integer jjj - double precision ufparm - external ufparm - integer uiparm(1) - real*8 urparm(1) - dimension x(maxvar) -c if (jjj.gt.0) then -c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -c endif - nfl=nf - icg=mod(nf,2)+1 - call var_to_geom_restr(n,x) - call zerograd - call chainbuild -cd write (iout,*) 'ETOTAL called from FUNC' - call etotal(energia(0)) - call sum_gradient - f=energia(0) -c if (jjj.gt.0) then -c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) -c write (iout,*) 'f=',etot -c jjj=0 -c endif - return - end -c------------------------------------------------------- - subroutine x2xx(x,xx,n) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - double precision xx(maxvar),x(maxvar) - - do i=1,nvar - varall(i)=x(i) - enddo - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - xx(ig)=x(igall) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - xx(ig)=x(igall) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - xx(ig)=x(igall) - endif - endif - enddo - enddo - - n=ig - - return - end - - subroutine xx2x(x,xx) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - double precision xx(maxvar),x(maxvar) - - do i=1,nvar - x(i)=varall(i) - enddo - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - x(igall)=xx(ig) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - x(igall)=xx(ig) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - x(igall)=xx(ig) - endif - endif - enddo - enddo - - return - end - -c---------------------------------------------------------- - subroutine minim_dc(etot,iretcode,nfun) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.MINIM' - include 'COMMON.CHAIN' - dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) -c common /przechowalnia/ v - - double precision energia(0:n_ene) - external func_dc,grad_dc,fdum - logical not_done,change,reduce - double precision g(maxvar),f1 - - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit - if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout -* 1 means to print out result - iv(22)=print_min_res -* 1 means to print out summary stats - iv(23)=print_min_stat -* 1 means to print initial x and d - iv(24)=print_min_ini -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -c v(25)=4.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,6*nres - d(i)=1.0D-1 - enddo - - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - x(k)=dc(j,i) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - x(k)=dc(j,i+nres) - enddo - endif - enddo - - call sumsl(k,d,x,func_dc,grad_dc,iv,liv,lv,v,idum,rdum,fdum) - - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - dc(j,i)=x(k) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - dc(j,i+nres)=x(k) - enddo - endif - enddo - call chainbuild_cart - -cd call zerograd -cd nf=0 -cd call func_dc(k,x,nf,f,idum,rdum,fdum) -cd call grad_dc(k,x,nf,g,idum,rdum,fdum) -cd -cd do i=1,k -cd x(i)=x(i)+1.0D-5 -cd call func_dc(k,x,nf,f1,idum,rdum,fdum) -cd x(i)=x(i)-1.0D-5 -cd print '(i5,2f15.5)',i,g(i),(f1-f)/1.0D-5 -cd enddo - - etot=v(10) - iretcode=iv(1) - nfun=iv(6) - return - end - - subroutine func_dc(n,x,nf,f,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - double precision energia(0:n_ene) - double precision ufparm - external ufparm - integer uiparm(1) - real*8 urparm(1) - dimension x(maxvar) - nfl=nf -cbad icg=mod(nf,2)+1 - icg=1 - - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - dc(j,i)=x(k) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - dc(j,i+nres)=x(k) - enddo - endif - enddo - call chainbuild_cart - - call zerograd - call etotal(energia(0)) - f=energia(0) - -cd print *,'func_dc ',nf,nfl,f - - return - end - - subroutine grad_dc(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.MD_' - include 'COMMON.IOUNITS' - external ufparm - integer uiparm(1),k - double precision urparm(1) - dimension x(maxvar),g(maxvar) -c -c -c -cbad icg=mod(nf,2)+1 - icg=1 -cd print *,'grad_dc ',nf,nfl,nf-nfl+1,icg - if (nf-nfl+1) 20,30,40 - 20 call func_dc(n,x,nf,f,uiparm,urparm,ufparm) -cd print *,20 - if (nf.eq.0) return - goto 40 - 30 continue -cd print *,30 - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - dc(j,i)=x(k) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - dc(j,i+nres)=x(k) - enddo - endif - enddo - call chainbuild_cart - -C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartgrad -cd print *,40 - k=0 - do i=1,nres-1 - do j=1,3 - k=k+1 - g(k)=gcart(j,i) - enddo - enddo - do i=2,nres-1 - if (ialph(i,1).gt.0) then - do j=1,3 - k=k+1 - g(k)=gxcart(j,i) - enddo - endif - enddo - - return - end diff --git a/source/unres/src_MIN/misc.f b/source/unres/src_MIN/misc.f deleted file mode 100644 index e189839..0000000 --- a/source/unres/src_MIN/misc.f +++ /dev/null @@ -1,203 +0,0 @@ -C $Date: 1994/10/12 17:24:21 $ -C $Revision: 2.5 $ -C -C -C - logical function find_arg(ipos,line,errflag) - parameter (maxlen=80) - character*80 line - character*1 empty /' '/,equal /'='/ - logical errflag -* This function returns .TRUE., if an argument follows keyword keywd; if so -* IPOS will point to the first non-blank character of the argument. Returns -* .FALSE., if no argument follows the keyword; in this case IPOS points -* to the first non-blank character of the next keyword. - do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) - ipos=ipos+1 - enddo - errflag=.false. - if (line(ipos:ipos).eq.equal) then - find_arg=.true. - ipos=ipos+1 - do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) - ipos=ipos+1 - enddo - if (ipos.gt.maxlen) errflag=.true. - else - find_arg=.false. - endif - return - end - logical function find_group(iunit,jout,key1) - character*(*) key1 - character*80 karta,ucase - integer ilen - external ilen - logical lcom - rewind (iunit) - karta=' ' - ll=ilen(key1) - do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta)) - read (iunit,'(a)',end=10) karta - enddo - write (jout,'(2a)') '> ',karta(1:78) - find_group=.true. - return - 10 find_group=.false. - return - end - logical function iblnk(charc) - character*1 charc - integer n - n = ichar(charc) - iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq. ' ') - return - end - integer function ilen(string) - character*(*) string - logical iblnk - - ilen = len(string) -1 if ( ilen .gt. 0 ) then - if ( iblnk( string(ilen:ilen) ) ) then - ilen = ilen - 1 - goto 1 - endif - endif - return - end - integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset) - character*16 keywd,keywdset(1:nkey,0:nkey) - character*16 ucase - do i=1,narg - if (ucase(keywd).eq.keywdset(i,ikey)) then -* Match found - in_keywd_set=i - return - endif - enddo -* No match to the allowed set of keywords if this point is reached. - in_keywd_set=0 - return - end - character*(*) function lcase(string) - integer i, k, idiff - character*(*) string - character*1 c - character*40 chtmp -c - i = len(lcase) - k = len(string) - if (i .lt. k) then - k = i - if (string(k+1:) .ne. ' ') then - chtmp = string - endif - endif - idiff = ichar('a') - ichar('A') - lcase = string - do 99 i = 1, k - c = string(i:i) - if (lge(c,'A') .and. lle(c,'Z')) then - lcase(i:i) = char(ichar(c) + idiff) - endif - 99 continue - return - end - logical function lcom(ipos,karta) - character*80 karta - character koment(2) /'!','#'/ - lcom=.false. - do i=1,2 - if (karta(ipos:ipos).eq.koment(i)) lcom=.true. - enddo - return - end - logical function lower_case(ch) - character*(*) ch - lower_case=(ch.ge.'a' .and. ch.le.'z') - return - end - subroutine mykey(line,keywd,ipos,blankline,errflag) -* This subroutine seeks a non-empty substring keywd in the string LINE. -* The substring begins with the first character different from blank and -* "=" encountered right to the pointer IPOS (inclusively) and terminates -* at the character left to the first blank or "=". When the subroutine is -* exited, the pointer IPOS is moved to the position of the terminator in LINE. -* The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains -* only separators or the maximum length of the data line (80) has been reached. -* The logical variable ERRFLAG is set at .TRUE. if the string -* consists only from a "=". - parameter (maxlen=80) - character*1 empty /' '/,equal /'='/,comma /','/ - character*(*) keywd - character*80 line - logical blankline,errflag,lcom - errflag=.false. - do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen)) - ipos=ipos+1 - enddo - if (ipos.gt.maxlen .or. lcom(ipos,line) ) then -* At this point the rest of the input line turned out to contain only blanks -* or to be commented out. - blankline=.true. - return - endif - blankline=.false. - istart=ipos -* Checks whether the current char is a separator. - do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal - & .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen) - ipos=ipos+1 - enddo - iend=ipos-1 -* Error flag set to .true., if the length of the keyword was found less than 1. - if (iend.lt.istart) then - errflag=.true. - return - endif - keywd=line(istart:iend) - return - end - subroutine numstr(inum,numm) - character*10 huj /'0123456789'/ - character*(*) numm - inumm=inum - inum1=inumm/10 - inum2=inumm-10*inum1 - inumm=inum1 - numm(3:3)=huj(inum2+1:inum2+1) - inum1=inumm/10 - inum2=inumm-10*inum1 - inumm=inum1 - numm(2:2)=huj(inum2+1:inum2+1) - inum1=inumm/10 - inum2=inumm-10*inum1 - inumm=inum1 - numm(1:1)=huj(inum2+1:inum2+1) - return - end - character*(*) function ucase(string) - integer i, k, idiff - character*(*) string - character*1 c - character*40 chtmp -c - i = len(ucase) - k = len(string) - if (i .lt. k) then - k = i - if (string(k+1:) .ne. ' ') then - chtmp = string - endif - endif - idiff = ichar('a') - ichar('A') - ucase = string - do 99 i = 1, k - c = string(i:i) - if (lge(c,'a') .and. lle(c,'z')) then - ucase(i:i) = char(ichar(c) - idiff) - endif - 99 continue - return - end diff --git a/source/unres/src_MIN/parmread.F b/source/unres/src_MIN/parmread.F deleted file mode 100644 index f95bbb0..0000000 --- a/source/unres/src_MIN/parmread.F +++ /dev/null @@ -1,1006 +0,0 @@ - subroutine parmread -C -C Read the parameters of the probability distributions of the virtual-bond -C valence angles and the side chains and energy parameters. -C -C Important! Energy-term weights ARE NOT read here; they are read from the -C main input file instead, because NO defaults have yet been set for these -C parameters. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include "mpif.h" - integer IERROR -#endif - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.SCCOR' - include 'COMMON.SCROT' - include 'COMMON.FFIELD' - include 'COMMON.NAMES' - include 'COMMON.SBRIDGE' - include 'COMMON.MD_' - include 'COMMON.SETUP' - character*1 t1,t2,t3 - character*1 onelett(4) /"G","A","P","D"/ - logical lprint,LaTeX - dimension blower(3,3,maxlob) - dimension b(13) - character*3 lancuch,ucase -C -C For printing parameters after they are read set the following in the UNRES -C C-shell script: -C -C setenv PRINT_PARM YES -C -C To print parameters in LaTeX format rather than as ASCII tables: -C -C setenv LATEX YES -C - call getenv_loc("PRINT_PARM",lancuch) - lprint = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") - call getenv_loc("LATEX",lancuch) - LaTeX = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") -C - dwa16=2.0d0**(1.0d0/6.0d0) - itypro=20 -C Assign virtual-bond length - vbl=3.8D0 - vblinv=1.0D0/vbl - vblinv2=vblinv*vblinv -c -c Read the virtual-bond parameters, masses, and moments of inertia -c and Stokes' radii of the peptide group and side chains -c -#ifdef CRYST_BOND - read (ibond,*) vbldp0,akp,mp,ip,pstok - do i=1,ntyp - nbondterm(i)=1 - read (ibond,*) vbldsc0(1,i),aksc(1,i),msc(i),isc(i),restok(i) - dsc(i) = vbldsc0(1,i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - enddo -#else - read (ibond,*) junk,vbldp0,akp,rjunk,mp,ip,pstok - do i=1,ntyp - read (ibond,*) nbondterm(i),(vbldsc0(j,i),aksc(j,i),abond0(j,i), - & j=1,nbondterm(i)),msc(i),isc(i),restok(i) - dsc(i) = vbldsc0(1,i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - enddo -#endif - if (lprint) then - write(iout,'(/a/)')"Dynamic constants of the interaction sites:" - write (iout,'(a10,a3,6a10)') 'Type','N','VBL','K','A0','mass', - & 'inertia','Pstok' - write(iout,'(a10,i3,6f10.5)') "p",1,vbldp0,akp,0.0d0,mp,ip,pstok - do i=1,ntyp - write (iout,'(a10,i3,6f10.5)') restyp(i),nbondterm(i), - & vbldsc0(1,i),aksc(1,i),abond0(1,i),msc(i),isc(i),restok(i) - do j=2,nbondterm(i) - write (iout,'(13x,3f10.5)') - & vbldsc0(j,i),aksc(j,i),abond0(j,i) - enddo - enddo - endif -#ifdef CRYST_THETA -C -C Read the parameters of the probability distribution/energy expression -C of the virtual-bond valence angles theta -C - do i=1,ntyp - read (ithep,*,err=111,end=111) a0thet(i),(athet(j,i),j=1,2), - & (bthet(j,i),j=1,2) - read (ithep,*,err=111,end=111) (polthet(j,i),j=0,3) - read (ithep,*,err=111,end=111) (gthet(j,i),j=1,3) - read (ithep,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) - sigc0(i)=sigc0(i)**2 - enddo - close (ithep) - if (lprint) then - if (.not.LaTeX) then - write (iout,'(a)') - & 'Parameters of the virtual-bond valence angles:' - write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:', - & ' ATHETA0 ',' A1 ',' A2 ', - & ' B1 ',' B2 ' - do i=1,ntyp - write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, - & a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the expression for sigma(theta_c):', - & ' ALPH0 ',' ALPH1 ',' ALPH2 ', - & ' ALPH3 ',' SIGMA0C ' - do i=1,ntyp - write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, - & (polthet(j,i),j=0,3),sigc0(i) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the second gaussian:', - & ' THETA0 ',' SIGMA0 ',' G1 ', - & ' G2 ',' G3 ' - do i=1,ntyp - write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i), - & sig0(i),(gthet(j,i),j=1,3) - enddo - else - write (iout,'(a)') - & 'Parameters of the virtual-bond valence angles:' - write (iout,'(/a/9x,5a/79(1h-))') - & 'Coefficients of expansion', - & ' theta0 ',' a1*10^2 ',' a2*10^2 ', - & ' b1*10^1 ',' b2*10^1 ' - do i=1,ntyp - write(iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i), - & a0thet(i),(100*athet(j,i),j=1,2),(10*bthet(j,i),j=1,2) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the expression for sigma(theta_c):', - & ' alpha0 ',' alph1 ',' alph2 ', - & ' alhp3 ',' sigma0c ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(1pe12.3,1h&))') restyp(i), - & (polthet(j,i),j=0,3),sigc0(i) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the second gaussian:', - & ' theta0 ',' sigma0*10^2 ',' G1*10^-1', - & ' G2 ',' G3*10^1 ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),theta0(i), - & 100*sig0(i),gthet(1,i)*0.1D0,gthet(2,i),gthet(3,i)*10.0D0 - enddo - endif - endif -#else -C -C Read the parameters of Utheta determined from ab initio surfaces -C Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -C - read (ithep,*,err=111,end=111) nthetyp,ntheterm,ntheterm2, - & ntheterm3,nsingle,ndouble - nntheterm=max0(ntheterm,ntheterm2,ntheterm3) - read (ithep,*,err=111,end=111) (ithetyp(i),i=1,ntyp1) - do i=1,maxthetyp - do j=1,maxthetyp - do k=1,maxthetyp - aa0thet(i,j,k)=0.0d0 - do l=1,ntheterm - aathet(l,i,j,k)=0.0d0 - enddo - do l=1,ntheterm2 - do m=1,nsingle - bbthet(m,l,i,j,k)=0.0d0 - ccthet(m,l,i,j,k)=0.0d0 - ddthet(m,l,i,j,k)=0.0d0 - eethet(m,l,i,j,k)=0.0d0 - enddo - enddo - do l=1,ntheterm3 - do m=1,ndouble - do mm=1,ndouble - ffthet(mm,m,l,i,j,k)=0.0d0 - ggthet(mm,m,l,i,j,k)=0.0d0 - enddo - enddo - enddo - enddo - enddo - enddo - do i=1,nthetyp - do j=1,nthetyp - do k=1,nthetyp - read (ithep,'(3a)',end=111,err=111) res1,res2,res3 - read (ithep,*,end=111,err=111) aa0thet(i,j,k) - read (ithep,*,end=111,err=111)(aathet(l,i,j,k),l=1,ntheterm) - read (ithep,*,end=111,err=111) - & ((bbthet(lll,ll,i,j,k),lll=1,nsingle), - & (ccthet(lll,ll,i,j,k),lll=1,nsingle), - & (ddthet(lll,ll,i,j,k),lll=1,nsingle), - & (eethet(lll,ll,i,j,k),lll=1,nsingle),ll=1,ntheterm2) - read (ithep,*,end=111,err=111) - & (((ffthet(llll,lll,ll,i,j,k),ffthet(lll,llll,ll,i,j,k), - & ggthet(llll,lll,ll,i,j,k),ggthet(lll,llll,ll,i,j,k), - & llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) - enddo - enddo - enddo -C -C For dummy ends assign glycine-type coefficients of theta-only terms; the -C coefficients of theta-and-gamma-dependent terms are zero. -C - do i=1,nthetyp - do j=1,nthetyp - do l=1,ntheterm - aathet(l,i,j,nthetyp+1)=aathet(l,i,j,1) - aathet(l,nthetyp+1,i,j)=aathet(l,1,i,j) - enddo - aa0thet(i,j,nthetyp+1)=aa0thet(i,j,1) - aa0thet(nthetyp+1,i,j)=aa0thet(1,i,j) - enddo - do l=1,ntheterm - aathet(l,nthetyp+1,i,nthetyp+1)=aathet(l,1,i,1) - enddo - aa0thet(nthetyp+1,i,nthetyp+1)=aa0thet(1,i,1) - enddo -C -C Control printout of the coefficients of virtual-bond-angle potentials -C - if (lprint) then - write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' - do i=1,nthetyp+1 - do j=1,nthetyp+1 - do k=1,nthetyp+1 - write (iout,'(//4a)') - & 'Type ',onelett(i),onelett(j),onelett(k) - write (iout,'(//a,10x,a)') " l","a[l]" - write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k) - write (iout,'(i2,1pe15.5)') - & (l,aathet(l,i,j,k),l=1,ntheterm) - do l=1,ntheterm2 - write (iout,'(//2h m,4(9x,a,3h[m,,i1,1h]))') - & "b",l,"c",l,"d",l,"e",l - do m=1,nsingle - write (iout,'(i2,4(1pe15.5))') m, - & bbthet(m,l,i,j,k),ccthet(m,l,i,j,k), - & ddthet(m,l,i,j,k),eethet(m,l,i,j,k) - enddo - enddo - do l=1,ntheterm3 - write (iout,'(//3hm,n,4(6x,a,5h[m,n,,i1,1h]))') - & "f+",l,"f-",l,"g+",l,"g-",l - do m=2,ndouble - do n=1,m-1 - write (iout,'(i1,1x,i1,4(1pe15.5))') n,m, - & ffthet(n,m,l,i,j,k),ffthet(m,n,l,i,j,k), - & ggthet(n,m,l,i,j,k),ggthet(m,n,l,i,j,k) - enddo - enddo - enddo - enddo - enddo - enddo - call flush(iout) - endif - write (2,*) "Start reading THETA_PDB" - do i=1,ntyp - read (ithep_pdb,*,err=111,end=111) a0thet(i),(athet(j,i),j=1,2), - & (bthet(j,i),j=1,2) - read (ithep_pdb,*,err=111,end=111) (polthet(j,i),j=0,3) - read (ithep_pdb,*,err=111,end=111) (gthet(j,i),j=1,3) - read (ithep_pdb,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) - sigc0(i)=sigc0(i)**2 - enddo - write (2,*) "End reading THETA_PDB" - close (ithep_pdb) -#endif - close(ithep) -#ifdef CRYST_SC -C -C Read the parameters of the probability distribution/energy expression -C of the side chains. -C - do i=1,ntyp - read (irotam,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - if (i.ne.10) then - do j=1,nlob(i) - do k=1,3 - do l=1,3 - blower(l,k,j)=0.0D0 - enddo - enddo - enddo - bsc(1,i)=0.0D0 - read(irotam,*,end=112,err=112)(censc(k,1,i),k=1,3), - & ((blower(k,l,1),l=1,k),k=1,3) - do j=2,nlob(i) - read (irotam,*,end=112,err=112) bsc(j,i) - read (irotam,*,end=112,err=112) (censc(k,j,i),k=1,3), - & ((blower(k,l,j),l=1,k),k=1,3) - enddo - do j=1,nlob(i) - do k=1,3 - do l=1,k - akl=0.0D0 - do m=1,3 - akl=akl+blower(k,m,j)*blower(l,m,j) - enddo - gaussc(k,l,j,i)=akl - gaussc(l,k,j,i)=akl - enddo - enddo - enddo - endif - enddo - close (irotam) - if (lprint) then - write (iout,'(/a)') 'Parameters of side-chain local geometry' - do i=1,ntyp - nlobi=nlob(i) - if (nlobi.gt.0) then - if (LaTeX) then - write (iout,'(/3a,i2,a,f8.3)') 'Residue type: ',restyp(i), - & ' # of gaussian lobes:',nlobi,' dsc:',dsc(i) - write (iout,'(1h&,a,3(2h&&,f8.3,2h&&))') - & 'log h',(bsc(j,i),j=1,nlobi) - write (iout,'(1h&,a,3(1h&,f8.3,1h&,f8.3,1h&,f8.3,1h&))') - & 'x',((censc(k,j,i),k=1,3),j=1,nlobi) - do k=1,3 - write (iout,'(2h& ,5(2x,1h&,3(f7.3,1h&)))') - & ((gaussc(k,l,j,i),l=1,3),j=1,nlobi) - enddo - else - write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi) - write (iout,'(a,f10.4,4(16x,f10.4))') - & 'Center ',(bsc(j,i),j=1,nlobi) - write (iout,'(5(2x,3f8.4))') ((censc(k,j,i),k=1,3), - & j=1,nlobi) - write (iout,'(a)') - endif - endif - enddo - endif -#else -C -C Read scrot parameters for potentials determined from all-atom AM1 calculations -C added by Urszula Kozlowska 07/11/2007 -C - do i=1,ntyp - read (irotam,*,end=112,err=112) - if (i.eq.10) then - read (irotam,*,end=112,err=112) - else - do j=1,65 - read(irotam,*,end=112,err=112) sc_parmin(j,i) - enddo - endif - enddo -C -C Read the parameters of the probability distribution/energy expression -C of the side chains. -C - do i=1,ntyp - read (irotam_pdb,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - if (i.ne.10) then - do j=1,nlob(i) - do k=1,3 - do l=1,3 - blower(l,k,j)=0.0D0 - enddo - enddo - enddo - bsc(1,i)=0.0D0 - read(irotam_pdb,*,end=112,err=112)(censc(k,1,i),k=1,3), - & ((blower(k,l,1),l=1,k),k=1,3) - do j=2,nlob(i) - read (irotam_pdb,*,end=112,err=112) bsc(j,i) - read (irotam_pdb,*,end=112,err=112) (censc(k,j,i),k=1,3), - & ((blower(k,l,j),l=1,k),k=1,3) - enddo - do j=1,nlob(i) - do k=1,3 - do l=1,k - akl=0.0D0 - do m=1,3 - akl=akl+blower(k,m,j)*blower(l,m,j) - enddo - gaussc(k,l,j,i)=akl - gaussc(l,k,j,i)=akl - enddo - enddo - enddo - endif - enddo - close (irotam_pdb) -#endif - close(irotam) - -#ifdef CRYST_TOR -C -C Read torsional parameters in old format -C - read (itorp,*,end=113,err=113) ntortyp,nterm_old - if (lprint)write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old - read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) - do i=1,ntortyp - do j=1,ntortyp - read (itorp,'(a)') - do k=1,nterm_old - read (itorp,*,end=113,err=113) kk,v1(k,j,i),v2(k,j,i) - enddo - enddo - enddo - close (itorp) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,ntortyp - do j=1,ntortyp - write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) - write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) - enddo - enddo - endif -#else -C -C Read torsional parameters -C - read (itorp,*,end=113,err=113) ntortyp - read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) -c write (iout,*) 'ntortyp',ntortyp - do i=1,ntortyp - do j=1,ntortyp - read (itorp,*,end=113,err=113) nterm(i,j),nlor(i,j) - v0ij=0.0d0 - si=-1.0d0 - do k=1,nterm(i,j) - read (itorp,*,end=113,err=113) kk,v1(k,i,j),v2(k,i,j) - v0ij=v0ij+si*v1(k,i,j) - si=-si - enddo - do k=1,nlor(i,j) - read (itorp,*,end=113,err=113) kk,vlor1(k,i,j), - & vlor2(k,i,j),vlor3(k,i,j) - v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) - enddo - v0(i,j)=v0ij - enddo - enddo - close (itorp) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,ntortyp - do j=1,ntortyp - write (iout,*) 'ityp',i,' jtyp',j - write (iout,*) 'Fourier constants' - do k=1,nterm(i,j) - write (iout,'(2(1pe15.5))') v1(k,i,j),v2(k,i,j) - enddo - write (iout,*) 'Lorenz constants' - do k=1,nlor(i,j) - write (iout,'(3(1pe15.5))') - & vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) - enddo - enddo - enddo - endif -C -C 6/23/01 Read parameters for double torsionals -C - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - read (itordp,'(3a1)',end=114,err=114) t1,t2,t3 - if (t1.ne.onelett(i) .or. t2.ne.onelett(j) - & .or. t3.ne.onelett(k)) then - write (iout,*) "Error in double torsional parameter file", - & i,j,k,t1,t2,t3 -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop "Error in double torsional parameter file" - endif - read (itordp,*,end=114,err=114) ntermd_1(i,j,k), - & ntermd_2(i,j,k) - read (itordp,*,end=114,err=114) (v1c(1,l,i,j,k),l=1, - & ntermd_1(i,j,k)) - read (itordp,*,end=114,err=114) (v1s(1,l,i,j,k),l=1, - & ntermd_1(i,j,k)) - read (itordp,*,end=114,err=114) (v1c(2,l,i,j,k),l=1, - & ntermd_1(i,j,k)) - read (itordp,*,end=114,err=114) (v1s(2,l,i,j,k),l=1, - & ntermd_1(i,j,k)) - read (itordp,*,end=114,err=114) ((v2c(l,m,i,j,k), - & v2c(m,l,i,j,k),v2s(l,m,i,j,k),v2s(m,l,i,j,k), - & m=1,l-1),l=1,ntermd_2(i,j,k)) - enddo - enddo - enddo - if (lprint) then - write (iout,*) - write (iout,*) 'Constants for double torsionals' - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k, - & ' nsingle',ntermd_1(i,j,k),' ndouble',ntermd_2(i,j,k) - write (iout,*) - write (iout,*) 'Single angles:' - do l=1,ntermd_1(i,j,k) - write (iout,'(i5,2f10.5,5x,2f10.5)') l, - & v1c(1,l,i,j,k),v1s(1,l,i,j,k), - & v1c(2,l,i,j,k),v1s(2,l,i,j,k) - enddo - write (iout,*) - write (iout,*) 'Pairs of angles:' - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) - do l=1,ntermd_2(i,j,k) - write (iout,'(i5,20f10.5)') - & l,(v2c(l,m,i,j,k),m=1,ntermd_2(i,j,k)) - enddo - write (iout,*) - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) - do l=1,ntermd_2(i,j,k) - write (iout,'(i5,20f10.5)') - & l,(v2s(l,m,i,j,k),m=1,ntermd_2(i,j,k)) - enddo - write (iout,*) - enddo - enddo - enddo - endif -#endif -C -C 5/21/07 (AL) Read coefficients of the backbone-local sidechain-local -C correlation energies. -C - read (isccor,*,end=119,err=119) nterm_sccor - do i=1,20 - do j=1,20 - read (isccor,'(a)') - do k=1,nterm_sccor - read (isccor,*,end=119,err=119) kk,v1sccor(k,i,j), - & v2sccor(k,i,j) - enddo - enddo - enddo - close (isccor) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants of SCCORR:' - do i=1,20 - do j=1,20 - write (iout,*) 'ityp',i,' jtyp',j - do k=1,nterm_sccor - write (iout,'(2(1pe15.5))') v1sccor(k,i,j),v2sccor(k,i,j) - enddo - enddo - enddo - endif -C -C 9/18/99 (AL) Read coefficients of the Fourier expansion of the local -C interaction energy of the Gly, Ala, and Pro prototypes. -C - if (lprint) then - write (iout,*) - write (iout,*) "Coefficients of the cumulants" - endif - read (ifourier,*) nloctyp - do i=1,nloctyp - read (ifourier,*,end=115,err=115) - read (ifourier,*,end=115,err=115) (b(ii),ii=1,13) - if (lprint) then - write (iout,*) 'Type',i - write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii),ii=1,13) - endif - B1(1,i) = b(3) - B1(2,i) = b(5) -c b1(1,i)=0.0d0 -c b1(2,i)=0.0d0 - B1tilde(1,i) = b(3) - B1tilde(2,i) =-b(5) -c b1tilde(1,i)=0.0d0 -c b1tilde(2,i)=0.0d0 - B2(1,i) = b(2) - B2(2,i) = b(4) -c b2(1,i)=0.0d0 -c b2(2,i)=0.0d0 - CC(1,1,i)= b(7) - CC(2,2,i)=-b(7) - CC(2,1,i)= b(9) - CC(1,2,i)= b(9) -c CC(1,1,i)=0.0d0 -c CC(2,2,i)=0.0d0 -c CC(2,1,i)=0.0d0 -c CC(1,2,i)=0.0d0 - Ctilde(1,1,i)=b(7) - Ctilde(1,2,i)=b(9) - Ctilde(2,1,i)=-b(9) - Ctilde(2,2,i)=b(7) -c Ctilde(1,1,i)=0.0d0 -c Ctilde(1,2,i)=0.0d0 -c Ctilde(2,1,i)=0.0d0 -c Ctilde(2,2,i)=0.0d0 - DD(1,1,i)= b(6) - DD(2,2,i)=-b(6) - DD(2,1,i)= b(8) - DD(1,2,i)= b(8) -c DD(1,1,i)=0.0d0 -c DD(2,2,i)=0.0d0 -c DD(2,1,i)=0.0d0 -c DD(1,2,i)=0.0d0 - Dtilde(1,1,i)=b(6) - Dtilde(1,2,i)=b(8) - Dtilde(2,1,i)=-b(8) - Dtilde(2,2,i)=b(6) -c Dtilde(1,1,i)=0.0d0 -c Dtilde(1,2,i)=0.0d0 -c Dtilde(2,1,i)=0.0d0 -c Dtilde(2,2,i)=0.0d0 - EE(1,1,i)= b(10)+b(11) - EE(2,2,i)=-b(10)+b(11) - EE(2,1,i)= b(12)-b(13) - EE(1,2,i)= b(12)+b(13) -c ee(1,1,i)=1.0d0 -c ee(2,2,i)=1.0d0 -c ee(2,1,i)=0.0d0 -c ee(1,2,i)=0.0d0 -c ee(2,1,i)=ee(1,2,i) - enddo - if (lprint) then - do i=1,nloctyp - write (iout,*) 'Type',i - write (iout,*) 'B1' - write(iout,*) B1(1,i),B1(2,i) - write (iout,*) 'B2' - write(iout,*) B2(1,i),B2(2,i) - write (iout,*) 'CC' - do j=1,2 - write (iout,'(2f10.5)') CC(j,1,i),CC(j,2,i) - enddo - write(iout,*) 'DD' - do j=1,2 - write (iout,'(2f10.5)') DD(j,1,i),DD(j,2,i) - enddo - write(iout,*) 'EE' - do j=1,2 - write (iout,'(2f10.5)') EE(j,1,i),EE(j,2,i) - enddo - enddo - endif -C -C Read electrostatic-interaction parameters -C - if (lprint) then - write (iout,*) - write (iout,'(/a)') 'Electrostatic interaction constants:' - write (iout,'(1x,a,1x,a,10x,a,11x,a,11x,a,11x,a)') - & 'IT','JT','APP','BPP','AEL6','AEL3' - endif - read (ielep,*,end=116,err=116) ((epp(i,j),j=1,2),i=1,2) - read (ielep,*,end=116,err=116) ((rpp(i,j),j=1,2),i=1,2) - read (ielep,*,end=116,err=116) ((elpp6(i,j),j=1,2),i=1,2) - read (ielep,*,end=116,err=116) ((elpp3(i,j),j=1,2),i=1,2) - close (ielep) - do i=1,2 - do j=1,2 - rri=rpp(i,j)**6 - app (i,j)=epp(i,j)*rri*rri - bpp (i,j)=-2.0D0*epp(i,j)*rri - ael6(i,j)=elpp6(i,j)*4.2D0**6 - ael3(i,j)=elpp3(i,j)*4.2D0**3 - if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j), - & ael6(i,j),ael3(i,j) - enddo - enddo -C -C Read side-chain interaction parameters. -C - read (isidep,*,end=117,err=117) ipot,expon - if (ipot.lt.1 .or. ipot.gt.5) then - write (iout,'(2a)') 'Error while reading SC interaction', - & 'potential file - unknown potential type.' -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop - endif - expon2=expon/2 - if(me.eq.king) - & write(iout,'(/3a,2i3)') 'Potential is ',potname(ipot), - & ', exponents are ',expon,2*expon - goto (10,20,30,30,40) ipot -C----------------------- LJ potential --------------------------------- - 10 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJ potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,a)') 'residue','sigma' - write (iout,'(a3,6x,f10.5)') (restyp(i),sigma0(i),i=1,ntyp) - endif - goto 50 -C----------------------- LJK potential -------------------------------- - 20 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJK potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,2a)') 'residue',' sigma ',' r0 ' - write (iout,'(a3,6x,2f10.5)') (restyp(i),sigma0(i),rr0(i), - & i=1,ntyp) - endif - goto 50 -C---------------------- GB or BP potential ----------------------------- - 30 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(sigii(i),i=1,ntyp),(chip(i),i=1,ntyp), - & (alp(i),i=1,ntyp) -C For the GB potential convert sigma'**2 into chi' - if (ipot.eq.4) then - do i=1,ntyp - chip(i)=(chip(i)-1.0D0)/(chip(i)+1.0D0) - enddo - endif - if (lprint) then - write (iout,'(/a/)') 'Parameters of the BP potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,4a)') 'residue',' sigma ','s||/s_|_^2', - & ' chip ',' alph ' - write (iout,'(a3,6x,4f10.5)') (restyp(i),sigma0(i),sigii(i), - & chip(i),alp(i),i=1,ntyp) - endif - goto 50 -C--------------------- GBV potential ----------------------------------- - 40 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp),(sigii(i),i=1,ntyp), - & (chip(i),i=1,ntyp),(alp(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the GBV potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,5a)') 'residue',' sigma ',' r0 ', - & 's||/s_|_^2',' chip ',' alph ' - write (iout,'(a3,6x,5f10.5)') (restyp(i),sigma0(i),rr0(i), - & sigii(i),chip(i),alp(i),i=1,ntyp) - endif - 50 continue - close (isidep) -C----------------------------------------------------------------------- -C Calculate the "working" parameters of SC interactions. - do i=2,ntyp - do j=1,i-1 - eps(i,j)=eps(j,i) - enddo - enddo - do i=1,ntyp - do j=i,ntyp - sigma(i,j)=dsqrt(sigma0(i)**2+sigma0(j)**2) - sigma(j,i)=sigma(i,j) - rs0(i,j)=dwa16*sigma(i,j) - rs0(j,i)=rs0(i,j) - enddo - enddo - if (lprint) write (iout,'(/a/10x,7a/72(1h-))') - & 'Working parameters of the SC interactions:', - & ' a ',' b ',' augm ',' sigma ',' r0 ', - & ' chi1 ',' chi2 ' - do i=1,ntyp - do j=i,ntyp - epsij=eps(i,j) - if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then - rrij=sigma(i,j) - else - rrij=rr0(i)+rr0(j) - endif - r0(i,j)=rrij - r0(j,i)=rrij - rrij=rrij**expon - epsij=eps(i,j) - sigeps=dsign(1.0D0,epsij) - epsij=dabs(epsij) - aa(i,j)=epsij*rrij*rrij - bb(i,j)=-sigeps*epsij*rrij - aa(j,i)=aa(i,j) - bb(j,i)=bb(i,j) - if (ipot.gt.2) then - sigt1sq=sigma0(i)**2 - sigt2sq=sigma0(j)**2 - sigii1=sigii(i) - sigii2=sigii(j) - ratsig1=sigt2sq/sigt1sq - ratsig2=1.0D0/ratsig1 - chi(i,j)=(sigii1-1.0D0)/(sigii1+ratsig1) - if (j.gt.i) chi(j,i)=(sigii2-1.0D0)/(sigii2+ratsig2) - rsum_max=dsqrt(sigii1*sigt1sq+sigii2*sigt2sq) - else - rsum_max=sigma(i,j) - endif -c if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then - sigmaii(i,j)=rsum_max - sigmaii(j,i)=rsum_max -c else -c sigmaii(i,j)=r0(i,j) -c sigmaii(j,i)=r0(i,j) -c endif -cd write (iout,*) i,j,r0(i,j),sigma(i,j),rsum_max - if ((ipot.eq.2 .or. ipot.eq.5) .and. r0(i,j).gt.rsum_max) then - r_augm=sigma(i,j)*(rrij-sigma(i,j))/rrij - augm(i,j)=epsij*r_augm**(2*expon) -c augm(i,j)=0.5D0**(2*expon)*aa(i,j) - augm(j,i)=augm(i,j) - else - augm(i,j)=0.0D0 - augm(j,i)=0.0D0 - endif - if (lprint) then - write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') - & restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j), - & sigma(i,j),r0(i,j),chi(i,j),chi(j,i) - endif - enddo - enddo -#ifdef OLDSCP -C -C Define the SC-p interaction constants (hard-coded; old style) -C - do i=1,20 -C "Soft" SC-p repulsion (causes helices to be too flat, but facilitates -C helix formation) -c aad(i,1)=0.3D0*4.0D0**12 -C Following line for constants currently implemented -C "Hard" SC-p repulsion (gives correct turn spacing in helices) - aad(i,1)=1.5D0*4.0D0**12 -c aad(i,1)=0.17D0*5.6D0**12 - aad(i,2)=aad(i,1) -C "Soft" SC-p repulsion - bad(i,1)=0.0D0 -C Following line for constants currently implemented -c aad(i,1)=0.3D0*4.0D0**6 -C "Hard" SC-p repulsion - bad(i,1)=3.0D0*4.0D0**6 -c bad(i,1)=-2.0D0*0.17D0*5.6D0**6 - bad(i,2)=bad(i,1) -c aad(i,1)=0.0D0 -c aad(i,2)=0.0D0 -c bad(i,1)=1228.8D0 -c bad(i,2)=1228.8D0 - enddo -#else -C -C 8/9/01 Read the SC-p interaction constants from file -C - do i=1,ntyp - read (iscpp,*,end=118,err=118) (eps_scp(i,j),rscp(i,j),j=1,2) - enddo - do i=1,ntyp - aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12 - aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12 - bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6 - bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6 - enddo - - if (lprint) then - write (iout,*) "Parameters of SC-p interactions:" - do i=1,20 - write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1), - & eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) - enddo - endif -#endif -C -C Define the constants of the disulfide bridge -C - ebr=-5.50D0 -c -c Old arbitrary potential - commented out. -c -c dbr= 4.20D0 -c fbr= 3.30D0 -c -c Constants of the disulfide-bond potential determined based on the RHF/6-31G** -c energy surface of diethyl disulfide. -c A. Liwo and U. Kozlowska, 11/24/03 -c - D0CM = 3.78d0 - AKCM = 15.1d0 - AKTH = 11.0d0 - AKCT = 12.0d0 - V1SS =-1.08d0 - V2SS = 7.61d0 - V3SS = 13.7d0 -c akcm=0.0d0 -c akth=0.0d0 -c akct=0.0d0 -c v1ss=0.0d0 -c v2ss=0.0d0 -c v3ss=0.0d0 - - if(me.eq.king) then - write (iout,'(/a)') "Disulfide bridge parameters:" - write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr - write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm - write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct - write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss, - & ' v3ss:',v3ss - endif - return - 111 write (iout,*) "Error reading bending energy parameters." - goto 999 - 112 write (iout,*) "Error reading rotamer energy parameters." - goto 999 - 113 write (iout,*) "Error reading torsional energy parameters." - goto 999 - 114 write (iout,*) "Error reading double torsional energy parameters." - goto 999 - 115 write (iout,*) - & "Error reading cumulant (multibody energy) parameters." - goto 999 - 116 write (iout,*) "Error reading electrostatic energy parameters." - goto 999 - 117 write (iout,*) "Error reading side chain interaction parameters." - goto 999 - 118 write (iout,*) "Error reading SCp interaction parameters." - goto 999 - 119 write (iout,*) "Error reading SCCOR parameters" - 999 continue -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop - return - end - - - subroutine getenv_loc(var, val) - character(*) var, val - -#ifdef WINIFL - character(2000) line - external ilen - - open (196,file='env',status='old',readonly,shared) - iread=0 -c write(*,*)'looking for ',var -10 read(196,*,err=11,end=11)line - iread=index(line,var) -c write(*,*)iread,' ',var,' ',line - if (iread.eq.0) go to 10 -c write(*,*)'---> ',line -11 continue - if(iread.eq.0) then -c write(*,*)'CHUJ' - val='' - else - iread=iread+ilen(var)+1 - read (line(iread:),*,err=12,end=12) val -c write(*,*)'OK: ',var,' = ',val - endif - close(196) - return -12 val='' - close(196) -#elif (defined CRAY) - integer lennam,lenval,ierror -c -c getenv using a POSIX call, useful on the T3D -c Sept 1996, comment out error check on advice of H. Pritchard -c - lennam = len(var) - if(lennam.le.0) stop '--error calling getenv--' - call pxfgetenv(var,lennam,val,lenval,ierror) -c-HP- if(ierror.ne.0) stop '--error returned by pxfgetenv--' -#else - call getenv(var,val) -#endif - - return - end diff --git a/source/unres/src_MIN/pinorm.f b/source/unres/src_MIN/pinorm.f deleted file mode 100644 index 91392bf..0000000 --- a/source/unres/src_MIN/pinorm.f +++ /dev/null @@ -1,17 +0,0 @@ - double precision function pinorm(x) - implicit real*8 (a-h,o-z) -c -c this function takes an angle (in radians) and puts it in the range of -c -pi to +pi. -c - integer n - include 'COMMON.GEO' - n = x / dwapi - pinorm = x - n * dwapi - if ( pinorm .gt. pi ) then - pinorm = pinorm - dwapi - else if ( pinorm .lt. - pi ) then - pinorm = pinorm + dwapi - end if - return - end diff --git a/source/unres/src_MIN/printmat.f b/source/unres/src_MIN/printmat.f deleted file mode 100644 index be2b38f..0000000 --- a/source/unres/src_MIN/printmat.f +++ /dev/null @@ -1,16 +0,0 @@ - subroutine printmat(ldim,m,n,iout,key,a) - character*3 key(n) - double precision a(ldim,n) - do 1 i=1,n,8 - nlim=min0(i+7,n) - write (iout,1000) (key(k),k=i,nlim) - write (iout,1020) - 1000 format (/5x,8(6x,a3)) - 1020 format (/80(1h-)/) - do 2 j=1,n - write (iout,1010) key(j),(a(j,k),k=i,nlim) - 2 continue - 1 continue - 1010 format (a3,2x,8(f9.4)) - return - end diff --git a/source/unres/src_MIN/randgens.f b/source/unres/src_MIN/randgens.f deleted file mode 100644 index 0daeb35..0000000 --- a/source/unres/src_MIN/randgens.f +++ /dev/null @@ -1,99 +0,0 @@ -C $Date: 1994/10/04 16:19:52 $ -C $Revision: 2.1 $ -C -C -C See help for RANDOMV on the PSFSHARE disk to understand these -C subroutines. This is the VS Fortran version of this code. -C -C - SUBROUTINE VRND(VEC,N) - INTEGER A(250) - COMMON /VRANDD/ A, I, I147 - INTEGER LOOP,I,I147,VEC(N) - DO 23000 LOOP=1,N - I=I+1 - IF(.NOT.(I.GE.251))GOTO 23002 - I=1 -23002 CONTINUE - I147=I147+1 - IF(.NOT.(I147.GE.251))GOTO 23004 - I147=1 -23004 CONTINUE - A(I)=IEOR(A(I147),A(I)) - VEC(LOOP)=A(I) -23000 CONTINUE - RETURN - END -C -C - DOUBLE PRECISION FUNCTION RNDV(IDUM) - DOUBLE PRECISION RM1,RM2,R(99) - INTEGER IA1,IC1,M1, IA2,IC2,M2, IA3,IC3,M3, IDUM - SAVE - DATA IA1,IC1,M1/1279,351762,1664557/ - DATA IA2,IC2,M2/2011,221592,1048583/ - DATA IA3,IC3,M3/15551,6150,29101/ - IF(.NOT.(IDUM.LT.0))GOTO 23006 - IX1 = MOD(-IDUM,M1) - IX1 = MOD(IA1*IX1+IC1,M1) - IX2 = MOD(IX1,M2) - IX1 = MOD(IA1*IX1+IC1,M1) - IX3 = MOD(IX1,M3) - RM1 = 1./DBLE(M1) - RM2 = 1./DBLE(M2) - DO 23008 J = 1,99 - IX1 = MOD(IA1*IX1+IC1,M1) - IX2 = MOD(IA2*IX2+IC2,M2) - R(J) = (DBLE(IX1)+DBLE(IX2)*RM2)*RM1 -23008 CONTINUE -23006 CONTINUE - IX1 = MOD(IA1*IX1+IC1,M1) - IX2 = MOD(IA2*IX2+IC2,M2) - IX3 = MOD(IA3*IX3+IC3,M3) - J = 1+(99*IX3)/M3 - RNDV = R(J) - R(J) = (DBLE(IX1)+DBLE(IX2)*RM2)*RM1 - IDUM = IX1 - RETURN - END -C -C - SUBROUTINE VRNDST(SEED) - INTEGER A(250),LOOP,IDUM,SEED - DOUBLE PRECISION RNDV - COMMON /VRANDD/ A, I, I147 - I=0 - I147=103 - IDUM=SEED - DO 23010 LOOP=1,250 - A(LOOP)=INT(RNDV(IDUM)*2147483647) -23010 CONTINUE - RETURN - END -C -C - SUBROUTINE VRNDIN(IODEV) - INTEGER IODEV, A(250) - COMMON/VRANDD/ A, I, I147 - READ(IODEV) A, I, I147 - RETURN - END -C -C - SUBROUTINE VRNDOU(IODEV) -C This corresponds to VRNDOUT in the APFTN64 version - INTEGER IODEV, A(250) - COMMON/VRANDD/ A, I, I147 - WRITE(IODEV) A, I, I147 - RETURN - END - FUNCTION RNUNF(N) - INTEGER IRAN1(2000) - DATA FCTOR /2147483647.0D0/ -C We get only one random number, here! DR 9/1/92 - CALL VRND(IRAN1,1) - RNUNF= DBLE( IRAN1(1) ) / FCTOR -C****************************** -C write(6,*) 'rnunf in rnunf = ',rnunf - RETURN - END diff --git a/source/unres/src_MIN/readpdb.F b/source/unres/src_MIN/readpdb.F deleted file mode 100644 index eb4ba3f..0000000 --- a/source/unres/src_MIN/readpdb.F +++ /dev/null @@ -1,428 +0,0 @@ - subroutine readpdb -C Read the PDB file and convert the peptide geometry into virtual-chain -C geometry. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.NAMES' - include 'COMMON.CONTROL' - include 'COMMON.DISTFIT' - include 'COMMON.SETUP' - character*3 seq,atom,res - character*80 card - dimension sccor(3,20) - double precision e1(3),e2(3),e3(3) - logical fail - integer rescode - ibeg=1 - lsecondary=.false. - nhfrag=0 - nbfrag=0 - do i=1,10000 - read (ipdbin,'(a80)',end=10) card - if (card(:5).eq.'HELIX') then - nhfrag=nhfrag+1 - lsecondary=.true. - read(card(22:25),*) hfrag(1,nhfrag) - read(card(34:37),*) hfrag(2,nhfrag) - endif - if (card(:5).eq.'SHEET') then - nbfrag=nbfrag+1 - lsecondary=.true. - read(card(24:26),*) bfrag(1,nbfrag) - read(card(35:37),*) bfrag(2,nbfrag) -crc---------------------------------------- -crc to be corrected !!! - bfrag(3,nbfrag)=bfrag(1,nbfrag) - bfrag(4,nbfrag)=bfrag(2,nbfrag) -crc---------------------------------------- - endif - if (card(:3).eq.'END' .or. card(:3).eq.'TER') goto 10 -C Fish out the ATOM cards. - if (index(card(1:4),'ATOM').gt.0) then - read (card(14:16),'(a3)') atom - if (atom.eq.'CA' .or. atom.eq.'CH3') then -C Calculate the CM of the preceding residue. - if (ibeg.eq.0) then - if (unres_pdb) then - do j=1,3 - dc(j,ires+nres)=sccor(j,iii) - enddo - else - call sccenter(ires,iii,sccor) - endif - endif -C Start new residue. - read (card(24:26),*) ires - read (card(18:20),'(a3)') res - if (ibeg.eq.1) then - ishift=ires-1 - if (res.ne.'GLY' .and. res.ne. 'ACE') then - ishift=ishift-1 - itype(1)=21 - endif - ibeg=0 - endif - ires=ires-ishift - if (res.eq.'ACE') then - ity=10 - else - itype(ires)=rescode(ires,res,0) - endif - read(card(31:54),'(3f8.3)') (c(j,ires),j=1,3) -c if(me.eq.king.or..not.out1file) -c & write (iout,'(2i3,2x,a,3f8.3)') -c & ires,itype(ires),res,(c(j,ires),j=1,3) - iii=1 - do j=1,3 - sccor(j,iii)=c(j,ires) - enddo - else if (atom.ne.'O '.and.atom(1:1).ne.'H' .and. - & atom.ne.'N ' .and. atom.ne.'C ') then - iii=iii+1 - read(card(31:54),'(3f8.3)') (sccor(j,iii),j=1,3) - endif - endif - enddo - 10 if(me.eq.king.or..not.out1file) - & write (iout,'(a,i5)') ' Nres: ',ires -C Calculate the CM of the last side chain. - if (unres_pdb) then - do j=1,3 - dc(j,ires+nres)=sccor(j,iii) - enddo - else - call sccenter(ires,iii,sccor) - endif - nres=ires - nsup=nres - nstart_sup=1 - if (itype(nres).ne.10) then - nres=nres+1 - itype(nres)=21 - if (unres_pdb) then -C 2/15/2013 by Adam: corrected insertion of the last dummy residue - call refsys(nres-3,nres-2,nres-1,e1,e2,e3,fail) - if (fail) then - e2(1)=0.0d0 - e2(2)=1.0d0 - e2(3)=0.0d0 - endif - do j=1,3 - c(j,nres)=c(j,nres-1)-3.8d0*e2(j) - enddo - else - do j=1,3 - dcj=c(j,nres-2)-c(j,nres-3) - c(j,nres)=c(j,nres-1)+dcj - c(j,2*nres)=c(j,nres) - enddo - endif - endif - do i=2,nres-1 - do j=1,3 - c(j,i+nres)=dc(j,i) - enddo - enddo - do j=1,3 - c(j,nres+1)=c(j,1) - c(j,2*nres)=c(j,nres) - enddo - if (itype(1).eq.21) then - nsup=nsup-1 - nstart_sup=2 - if (unres_pdb) then -C 2/15/2013 by Adam: corrected insertion of the first dummy residue - call refsys(2,3,4,e1,e2,e3,fail) - if (fail) then - e2(1)=0.0d0 - e2(2)=1.0d0 - e2(3)=0.0d0 - endif - do j=1,3 - c(j,1)=c(j,2)-3.8d0*e2(j) - enddo - else - do j=1,3 - dcj=c(j,4)-c(j,3) - c(j,1)=c(j,2)-dcj - c(j,nres+1)=c(j,1) - enddo - endif - endif -C Calculate internal coordinates. - if(me.eq.king.or..not.out1file)then - write (iout,'(a)') - & "Backbone and SC coordinates as read from the PDB" - do ires=1,nres - write (iout,'(2i3,2x,a,3f8.3,5x,3f8.3)') - & ires,itype(ires),restyp(itype(ires)),(c(j,ires),j=1,3), - & (c(j,nres+ires),j=1,3) - enddo - endif - call int_from_cart(.true.,.false.) - call sc_loc_geom(.false.) - do i=1,nres - thetaref(i)=theta(i) - phiref(i)=phi(i) - enddo - do i=1,nres-1 - do j=1,3 - dc(j,i)=c(j,i+1)-c(j,i) - dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) - enddo - enddo - do i=2,nres-1 - do j=1,3 - dc(j,i+nres)=c(j,i+nres)-c(j,i) - dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) - enddo -c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3), -c & vbld_inv(i+nres) - enddo -c call chainbuild -C Copy the coordinates to reference coordinates - do i=1,2*nres - do j=1,3 - cref(j,i)=c(j,i) - enddo - enddo - - - do j=1,nbfrag - do i=1,4 - bfrag(i,j)=bfrag(i,j)-ishift - enddo - enddo - - do j=1,nhfrag - do i=1,2 - hfrag(i,j)=hfrag(i,j)-ishift - enddo - enddo - - return - end -c--------------------------------------------------------------------------- - subroutine int_from_cart(lside,lprn) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -c include "mpif.h" - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.NAMES' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - character*3 seq,atom,res - character*80 card - dimension sccor(3,20) - integer rescode - logical lside,lprn - if(me.eq.king.or..not.out1file)then - if (lprn) then - write (iout,'(/a)') - & 'Internal coordinates calculated from crystal structure.' - if (lside) then - write (iout,'(8a)') ' Res ',' dvb',' Theta', - & ' Gamma',' Dsc_id',' Dsc',' Alpha', - & ' Beta ' - else - write (iout,'(4a)') ' Res ',' dvb',' Theta', - & ' Gamma' - endif - endif - endif - do i=1,nres-1 - iti=itype(i) - if (dist(i,i+1).lt.2.0D0 .or. dist(i,i+1).gt.5.0D0) then - write (iout,'(a,i4)') 'Bad Cartesians for residue',i -ctest stop - endif - vbld(i+1)=dist(i,i+1) - vbld_inv(i+1)=1.0d0/vbld(i+1) - if (i.gt.1) theta(i+1)=alpha(i-1,i,i+1) - if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) - enddo -c if (unres_pdb) then -c if (itype(1).eq.21) then -c theta(3)=90.0d0*deg2rad -c phi(4)=180.0d0*deg2rad -c vbld(2)=3.8d0 -c vbld_inv(2)=1.0d0/vbld(2) -c endif -c if (itype(nres).eq.21) then -c theta(nres)=90.0d0*deg2rad -c phi(nres)=180.0d0*deg2rad -c vbld(nres)=3.8d0 -c vbld_inv(nres)=1.0d0/vbld(2) -c endif -c endif - if (lside) then - do i=2,nres-1 - do j=1,3 - c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))*vbld_inv(i) - & +(c(j,i+1)-c(j,i))*vbld_inv(i+1)) - enddo - iti=itype(i) - di=dist(i,nres+i) -C 9/29/12 Adam: Correction for zero SC-SC bond length - if (itype(i).ne.10 .and. itype(i).ne.21. and. di.eq.0.0d0) - & di=dsc(itype(i)) - vbld(i+nres)=di - if (itype(i).ne.10) then - vbld_inv(i+nres)=1.0d0/di - else - vbld_inv(i+nres)=0.0d0 - endif - if (iti.ne.10) then - alph(i)=alpha(nres+i,i,maxres2) - omeg(i)=beta(nres+i,i,maxres2,i+1) - endif - if(me.eq.king.or..not.out1file)then - if (lprn) - & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,vbld(i), - & rad2deg*theta(i),rad2deg*phi(i),dsc(iti),vbld(nres+i), - & rad2deg*alph(i),rad2deg*omeg(i) - endif - enddo - else if (lprn) then - do i=2,nres - iti=itype(i) - if(me.eq.king.or..not.out1file) - & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1), - & rad2deg*theta(i),rad2deg*phi(i) - enddo - endif - return - end -c------------------------------------------------------------------------------- - subroutine sc_loc_geom(lprn) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -c include "mpif.h" - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.NAMES' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - double precision x_prime(3),y_prime(3),z_prime(3) - logical lprn - do i=1,nres-1 - do j=1,3 - dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i)) - enddo - enddo - do i=2,nres-1 - if (itype(i).ne.10) then - do j=1,3 - dc_norm(j,i+nres)=vbld_inv(i+nres)*(c(j,i+nres)-c(j,i)) - enddo - else - do j=1,3 - dc_norm(j,i+nres)=0.0d0 - enddo - endif - enddo - do i=2,nres-1 - costtab(i+1) =dcos(theta(i+1)) - sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) - cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) - sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) - cosfac2=0.5d0/(1.0d0+costtab(i+1)) - cosfac=dsqrt(cosfac2) - sinfac2=0.5d0/(1.0d0-costtab(i+1)) - sinfac=dsqrt(sinfac2) - it=itype(i) - if (it.ne.10) then -c -C Compute the axes of tghe local cartesian coordinates system; store in -c x_prime, y_prime and z_prime -c - do j=1,3 - x_prime(j) = 0.00 - y_prime(j) = 0.00 - z_prime(j) = 0.00 - enddo - do j = 1,3 - x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac - y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac - enddo - call vecpr(x_prime,y_prime,z_prime) -c -C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), -C to local coordinate system. Store in xx, yy, zz. -c - xx=0.0d0 - yy=0.0d0 - zz=0.0d0 - do j = 1,3 - xx = xx + x_prime(j)*dc_norm(j,i+nres) - yy = yy + y_prime(j)*dc_norm(j,i+nres) - zz = zz + z_prime(j)*dc_norm(j,i+nres) - enddo - - xxref(i)=xx - yyref(i)=yy - zzref(i)=zz - else - xxref(i)=0.0d0 - yyref(i)=0.0d0 - zzref(i)=0.0d0 - endif - enddo - if (lprn) then - do i=2,nres - iti=itype(i) - if(me.eq.king.or..not.out1file) - & write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i), - & yyref(i),zzref(i) - enddo - endif - return - end -c--------------------------------------------------------------------------- - subroutine sccenter(ires,nscat,sccor) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - dimension sccor(3,20) - do j=1,3 - sccmj=0.0D0 - do i=1,nscat - sccmj=sccmj+sccor(j,i) - enddo - dc(j,ires)=sccmj/nscat - enddo - return - end -c--------------------------------------------------------------------------- - subroutine bond_regular - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CALC' - include 'COMMON.INTERACT' - include 'COMMON.CHAIN' - do i=1,nres-1 - vbld(i+1)=vbl - vbld_inv(i+1)=1.0d0/vbld(i+1) - vbld(i+1+nres)=dsc(itype(i+1)) - vbld_inv(i+1+nres)=dsc_inv(itype(i+1)) -c print *,vbld(i+1),vbld(i+1+nres) - enddo - return - end diff --git a/source/unres/src_MIN/readrtns_min.F b/source/unres/src_MIN/readrtns_min.F deleted file mode 100644 index 9d444cf..0000000 --- a/source/unres/src_MIN/readrtns_min.F +++ /dev/null @@ -1,1799 +0,0 @@ - subroutine readrtns - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - include 'COMMON.IOUNITS' - logical file_exist -C Read force-field parameters except weights - call parmread -C Read job setup parameters - call read_control -C Read control parameters for energy minimzation if required - if (minim) call read_minim -C Read MCM control parameters if required -c if (modecalc.eq.3 .or. modecalc.eq.6) call mcmread -C Read MD control parameters if reqjuired -c if (modecalc.eq.12) call read_MDpar -C Read MREMD control parameters if required -c if (modecalc.eq.14) then -c call read_MDpar -c call read_REMDpar -c endif -C Read MUCA control parameters if required -c if (lmuca) call read_muca -C Read CSA control parameters if required (from fort.40 if exists -C otherwise from general input file) -c if (modecalc.eq.8) then -c inquire (file="fort.40",exist=file_exist) -c if (.not.file_exist) call csaread -c endif -cfmc if (modecalc.eq.10) call mcmfread -C Read molecule information, molecule geometry, energy-term weights, and -C restraints if requested - call molread -C Print restraint information -#ifdef MPI - if (.not. out1file .or. me.eq.king) then -#endif - if (nhpb.gt.nss) - &write (iout,'(a,i5,a)') "The following",nhpb-nss, - & " distance constraints have been imposed" - do i=nss+1,nhpb - write (iout,'(3i6,f10.5)') i-nss,ihpb(i),jhpb(i),forcon(i) - enddo -#ifdef MPI - endif -#endif -c print *,"Processor",myrank," leaves READRTNS" - return - end -C------------------------------------------------------------------------------- - subroutine read_control -C -C Read contorl data -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MP - include 'mpif.h' - logical OKRandom, prng_restart - real*8 r1 -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.MCM' - include 'COMMON.HEADER' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SETUP' - COMMON /MACHSW/ KDIAG,ICORFL,IXDR - character*8 diagmeth(0:3) /'Library','EVVRSP','Givens','Jacobi'/ - character*80 ucase - character*320 controlcard - - nglob_csa=0 - eglob_csa=1d99 - nmin_csa=0 - read (INP,'(a)') titel - call card_concat(controlcard) -c out1file=index(controlcard,'OUT1FILE').gt.0 .or. fg_rank.gt.0 -c print *,"Processor",me," fg_rank",fg_rank," out1file",out1file - call reada(controlcard,'SEED',seed,0.0D0) - call random_init(seed) -C Set up the time limit (caution! The time must be input in minutes!) - read_cart=index(controlcard,'READ_CART').gt.0 - call readi(controlcard,'CONSTR_DIST',constr_dist,0) - call reada(controlcard,'TIMLIM',timlim,960.0D0) ! default 16 hours - unres_pdb = index(controlcard,'UNRES_PDB') .gt. 0 - call reada(controlcard,'SAFETY',safety,30.0D0) ! default 30 minutes - call reada(controlcard,'RMSDBC',rmsdbc,3.0D0) - call reada(controlcard,'RMSDBC1',rmsdbc1,0.5D0) - call reada(controlcard,'RMSDBC1MAX',rmsdbc1max,1.5D0) - call reada(controlcard,'RMSDBCM',rmsdbcm,3.0D0) - call reada(controlcard,'DRMS',drms,0.1D0) - if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then - write (iout,'(a,f10.1)')'RMSDBC = ',rmsdbc - write (iout,'(a,f10.1)')'RMSDBC1 = ',rmsdbc1 - write (iout,'(a,f10.1)')'RMSDBC1MAX = ',rmsdbc1max - write (iout,'(a,f10.1)')'DRMS = ',drms - write (iout,'(a,f10.1)')'RMSDBCM = ',rmsdbcm - write (iout,'(a,f10.1)') 'Time limit (min):',timlim - endif - call readi(controlcard,'NZ_START',nz_start,0) - call readi(controlcard,'NZ_END',nz_end,0) - call readi(controlcard,'IZ_SC',iz_sc,0) - timlim=60.0D0*timlim - safety = 60.0d0*safety - timem=timlim - modecalc=0 - call reada(controlcard,"T_BATH",t_bath,300.0d0) - minim=(index(controlcard,'MINIMIZE').gt.0) - dccart=(index(controlcard,'CART').gt.0) - overlapsc=(index(controlcard,'OVERLAP').gt.0) - overlapsc=.not.overlapsc - searchsc=(index(controlcard,'SEARCHSC').gt.0) - sideadd=(index(controlcard,'SIDEADD').gt.0) - energy_dec=(index(controlcard,'ENERGY_DEC').gt.0) - outpdb=(index(controlcard,'PDBOUT').gt.0) - outmol2=(index(controlcard,'MOL2OUT').gt.0) - pdbref=(index(controlcard,'PDBREF').gt.0) - refstr=pdbref .or. (index(controlcard,'REFSTR').gt.0) - indpdb=index(controlcard,'PDBSTART') - extconf=(index(controlcard,'EXTCONF').gt.0) - call readi(controlcard,'IPRINT',iprint,0) - call readi(controlcard,'MAXGEN',maxgen,10000) - call readi(controlcard,'MAXOVERLAP',maxoverlap,1000) - call readi(controlcard,"KDIAG",kdiag,0) - call readi(controlcard,"RESCALE_MODE",rescale_mode,0) - if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) - & write (iout,*) "RESCALE_MODE",rescale_mode - split_ene=index(controlcard,'SPLIT_ENE').gt.0 - if (index(controlcard,'REGULAR').gt.0.0D0) then - call reada(controlcard,'WEIDIS',weidis,0.1D0) - modecalc=1 - refstr=.true. - endif - if (index(controlcard,'CHECKGRAD').gt.0) then - modecalc=5 - if (index(controlcard,'CART').gt.0) then - icheckgrad=1 - elseif (index(controlcard,'CARINT').gt.0) then - icheckgrad=2 - else - icheckgrad=3 - endif - elseif (index(controlcard,'THREAD').gt.0) then - modecalc=2 - call readi(controlcard,'THREAD',nthread,0) - if (nthread.gt.0) then - call reada(controlcard,'WEIDIS',weidis,0.1D0) - else - if (fg_rank.eq.0) - & write (iout,'(a)')'A number has to follow the THREAD keyword.' - stop 'Error termination in Read_Control.' - endif - else if (index(controlcard,'MCMA').gt.0) then - modecalc=3 - else if (index(controlcard,'MCEE').gt.0) then - modecalc=6 - else if (index(controlcard,'MULTCONF').gt.0) then - modecalc=4 - else if (index(controlcard,'MAP').gt.0) then - modecalc=7 - call readi(controlcard,'MAP',nmap,0) - else if (index(controlcard,'CSA').gt.0) then - modecalc=8 -crc else if (index(controlcard,'ZSCORE').gt.0) then -crc -crc ZSCORE is rm from UNRES, modecalc=9 is available -crc -crc modecalc=9 -cfcm else if (index(controlcard,'MCMF').gt.0) then -cfmc modecalc=10 - else if (index(controlcard,'SOFTREG').gt.0) then - modecalc=11 - else if (index(controlcard,'CHECK_BOND').gt.0) then - modecalc=-1 - else if (index(controlcard,'TEST').gt.0) then - modecalc=-2 - else if (index(controlcard,'MD').gt.0) then - modecalc=12 - else if (index(controlcard,'RE ').gt.0) then - modecalc=14 - endif - - lmuca=index(controlcard,'MUCA').gt.0 - call readi(controlcard,'MUCADYN',mucadyn,0) - call readi(controlcard,'MUCASMOOTH',muca_smooth,0) - if (lmuca .and. (me.eq.king .or. .not.out1file )) - & then - write (iout,*) 'MUCADYN=',mucadyn - write (iout,*) 'MUCASMOOTH=',muca_smooth - endif - - iscode=index(controlcard,'ONE_LETTER') - indphi=index(controlcard,'PHI') - indback=index(controlcard,'BACK') - iranconf=index(controlcard,'RAND_CONF') - i2ndstr=index(controlcard,'USE_SEC_PRED') - gradout=index(controlcard,'GRADOUT').gt.0 - gnorm_check=index(controlcard,'GNORM_CHECK').gt.0 - - if(me.eq.king.or..not.out1file) - & write (iout,'(2a)') diagmeth(kdiag), - & ' routine used to diagonalize matrices.' - return - end -c------------------------------------------------------------------------------ - subroutine molread -C -C Read molecular data. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer error_msg -#endif - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' -c include 'COMMON.DBASE' -c include 'COMMON.THREAD' - include 'COMMON.CONTACTS' - include 'COMMON.TORCNSTR' - include 'COMMON.TIME1' - include 'COMMON.BOUNDS' -c include 'COMMON.MD' -c include 'COMMON.REMD' - include 'COMMON.SETUP' - character*4 sequence(maxres) - integer rescode - double precision x(maxvar) - character*256 pdbfile - character*320 weightcard - character*80 weightcard_t,ucase - dimension itype_pdb(maxres) - common /pizda/ itype_pdb - logical seq_comp,fail - double precision energia(0:n_ene) - integer ilen - external ilen -C -C Body -C -C Read weights of the subsequent energy terms. - - call card_concat(weightcard) - call reada(weightcard,'WLONG',wlong,1.0D0) - call reada(weightcard,'WSC',wsc,wlong) - call reada(weightcard,'WSCP',wscp,wlong) - call reada(weightcard,'WELEC',welec,1.0D0) - call reada(weightcard,'WVDWPP',wvdwpp,welec) - call reada(weightcard,'WEL_LOC',wel_loc,1.0D0) - call reada(weightcard,'WCORR4',wcorr4,0.0D0) - call reada(weightcard,'WCORR5',wcorr5,0.0D0) - call reada(weightcard,'WCORR6',wcorr6,0.0D0) - call reada(weightcard,'WTURN3',wturn3,1.0D0) - call reada(weightcard,'WTURN4',wturn4,1.0D0) - call reada(weightcard,'WTURN6',wturn6,1.0D0) - call reada(weightcard,'WSCCOR',wsccor,1.0D0) - call reada(weightcard,'WSTRAIN',wstrain,1.0D0) - call reada(weightcard,'WBOND',wbond,1.0D0) - call reada(weightcard,'WTOR',wtor,1.0D0) - call reada(weightcard,'WTORD',wtor_d,1.0D0) - call reada(weightcard,'WANG',wang,1.0D0) - call reada(weightcard,'WSCLOC',wscloc,1.0D0) - call reada(weightcard,'SCAL14',scal14,0.4D0) - call reada(weightcard,'SCALSCP',scalscp,1.0d0) - call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) - call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) - call reada(weightcard,'TEMP0',temp0,300.0d0) - if (index(weightcard,'SOFT').gt.0) ipot=6 -C 12/1/95 Added weight for the multi-body term WCORR - call reada(weightcard,'WCORRH',wcorr,1.0D0) - if (wcorr4.gt.0.0d0) wcorr=wcorr4 - weights(1)=wsc - weights(2)=wscp - weights(3)=welec - weights(4)=wcorr - weights(5)=wcorr5 - weights(6)=wcorr6 - weights(7)=wel_loc - weights(8)=wturn3 - weights(9)=wturn4 - weights(10)=wturn6 - weights(11)=wang - weights(12)=wscloc - weights(13)=wtor - weights(14)=wtor_d - weights(15)=wstrain - weights(16)=wvdwpp - weights(17)=wbond - weights(18)=scal14 - weights(21)=wsccor - - if(me.eq.king.or..not.out1file) - & write (iout,10) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor, - & wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3, - & wturn4,wturn6 - 10 format (/'Energy-term weights (unscaled):'// - & 'WSCC= ',f10.6,' (SC-SC)'/ - & 'WSCP= ',f10.6,' (SC-p)'/ - & 'WELEC= ',f10.6,' (p-p electr)'/ - & 'WVDWPP= ',f10.6,' (p-p VDW)'/ - & 'WBOND= ',f10.6,' (stretching)'/ - & 'WANG= ',f10.6,' (bending)'/ - & 'WSCLOC= ',f10.6,' (SC local)'/ - & 'WTOR= ',f10.6,' (torsional)'/ - & 'WTORD= ',f10.6,' (double torsional)'/ - & 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ - & 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ - & 'WCORR4= ',f10.6,' (multi-body 4th order)'/ - & 'WCORR5= ',f10.6,' (multi-body 5th order)'/ - & 'WCORR6= ',f10.6,' (multi-body 6th order)'/ - & 'WSCCOR= ',f10.6,' (back-scloc correlation)'/ - & 'WTURN3= ',f10.6,' (turns, 3rd order)'/ - & 'WTURN4= ',f10.6,' (turns, 4th order)'/ - & 'WTURN6= ',f10.6,' (turns, 6th order)') - if(me.eq.king.or..not.out1file)then - if (wcorr4.gt.0.0d0) then - write (iout,'(/2a/)') 'Local-electrostatic type correlation ', - & 'between contact pairs of peptide groups' - write (iout,'(2(a,f5.3/))') - & 'Cutoff on 4-6th order correlation terms: ',cutoff_corr, - & 'Range of quenching the correlation terms:',2*delt_corr - else if (wcorr.gt.0.0d0) then - write (iout,'(/2a/)') 'Hydrogen-bonding correlation ', - & 'between contact pairs of peptide groups' - endif - write (iout,'(a,f8.3)') - & 'Scaling factor of 1,4 SC-p interactions:',scal14 - write (iout,'(a,f8.3)') - & 'General scaling factor of SC-p interactions:',scalscp - endif - r0_corr=cutoff_corr-delt_corr - do i=1,20 - aad(i,1)=scalscp*aad(i,1) - aad(i,2)=scalscp*aad(i,2) - bad(i,1)=scalscp*bad(i,1) - bad(i,2)=scalscp*bad(i,2) - enddo -c call rescale_weights(t_bath) - if(me.eq.king.or..not.out1file) - & write (iout,22) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor, - & wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3, - & wturn4,wturn6 - 22 format (/'Energy-term weights (scaled):'// - & 'WSCC= ',f10.6,' (SC-SC)'/ - & 'WSCP= ',f10.6,' (SC-p)'/ - & 'WELEC= ',f10.6,' (p-p electr)'/ - & 'WVDWPP= ',f10.6,' (p-p VDW)'/ - & 'WBOND= ',f10.6,' (stretching)'/ - & 'WANG= ',f10.6,' (bending)'/ - & 'WSCLOC= ',f10.6,' (SC local)'/ - & 'WTOR= ',f10.6,' (torsional)'/ - & 'WTORD= ',f10.6,' (double torsional)'/ - & 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ - & 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ - & 'WCORR4= ',f10.6,' (multi-body 4th order)'/ - & 'WCORR5= ',f10.6,' (multi-body 5th order)'/ - & 'WCORR6= ',f10.6,' (multi-body 6th order)'/ - & 'WSCCOR= ',f10.6,' (back-scloc correlatkion)'/ - & 'WTURN3= ',f10.6,' (turns, 3rd order)'/ - & 'WTURN4= ',f10.6,' (turns, 4th order)'/ - & 'WTURN6= ',f10.6,' (turns, 6th order)') - if(me.eq.king.or..not.out1file) - & write (iout,*) "Reference temperature for weights calculation:", - & temp0 - call reada(weightcard,"D0CM",d0cm,3.78d0) - call reada(weightcard,"AKCM",akcm,15.1d0) - call reada(weightcard,"AKTH",akth,11.0d0) - call reada(weightcard,"AKCT",akct,12.0d0) - call reada(weightcard,"V1SS",v1ss,-1.08d0) - call reada(weightcard,"V2SS",v2ss,7.61d0) - call reada(weightcard,"V3SS",v3ss,13.7d0) - call reada(weightcard,"EBR",ebr,-5.50D0) - if(me.eq.king.or..not.out1file) then - write (iout,*) "Parameters of the SS-bond potential:" - write (iout,*) "D0CM",d0cm," AKCM",akcm," AKTH",akth, - & " AKCT",akct - write (iout,*) "V1SS",v1ss," V2SS",v2ss," V3SS",v3ss - write (iout,*) "EBR",ebr - print *,'indpdb=',indpdb,' pdbref=',pdbref - endif - if (indpdb.gt.0 .or. pdbref) then - read(inp,'(a)') pdbfile - if(me.eq.king.or..not.out1file) - & write (iout,'(2a)') 'PDB data will be read from file ', - & pdbfile(:ilen(pdbfile)) - open(ipdbin,file=pdbfile,status='old',err=33) - goto 34 - 33 write (iout,'(a)') 'Error opening PDB file.' - stop - 34 continue -c print *,'Begin reading pdb data' - call readpdb -c print *,'Finished reading pdb data' - if(me.eq.king.or..not.out1file) - & write (iout,'(a,i3,a,i3)')'nsup=',nsup, - & ' nstart_sup=',nstart_sup - do i=1,nres - itype_pdb(i)=itype(i) - enddo - close (ipdbin) - nnt=nstart_sup - nct=nstart_sup+nsup-1 -c call contact(.false.,ncont_ref,icont_ref,co) - - if (sideadd) then -C Following 2 lines for diagnostics; comment out if not needed - write (iout,*) "Before sideadd" - call intout - if(me.eq.king.or..not.out1file) - & write(iout,*)'Adding sidechains' - maxsi=1000 - do i=2,nres-1 - iti=itype(i) - if (iti.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(iti,theta(i+1),alph(i),omeg(i),fail) - nsi=nsi+1 - enddo - if(fail) write(iout,*)'Adding sidechain failed for res ', - & i,' after ',nsi,' trials' - endif - enddo -C 9/29/12 Adam: Recalculate coordinates with new side chain positions - call chainbuild - endif -C Following 2 lines for diagnostics; comment out if not needed - write (iout,*) "After sideadd" - call intout - endif - if (indpdb.eq.0) then -C Read sequence if not taken from the pdb file. - read (inp,*) nres -c print *,'nres=',nres - if (iscode.gt.0) then - read (inp,'(80a1)') (sequence(i)(1:1),i=1,nres) - else - read (inp,'(20(1x,a3))') (sequence(i),i=1,nres) - endif -C Convert sequence to numeric code - do i=1,nres - itype(i)=rescode(i,sequence(i),iscode) - enddo -C Assign initial virtual bond lengths - do i=2,nres - vbld(i)=vbl - vbld_inv(i)=vblinv - enddo - do i=2,nres-1 - vbld(i+nres)=dsc(itype(i)) - vbld_inv(i+nres)=dsc_inv(itype(i)) -c write (iout,*) "i",i," itype",itype(i), -c & " dsc",dsc(itype(i))," vbld",vbld(i),vbld(i+nres) - enddo - endif -c print *,nres -c print '(20i4)',(itype(i),i=1,nres) - do i=1,nres -#ifdef PROCOR - if (itype(i).eq.21 .or. itype(i+1).eq.21) then -#else - if (itype(i).eq.21) then -#endif - itel(i)=0 -#ifdef PROCOR - else if (itype(i+1).ne.20) then -#else - else if (itype(i).ne.20) then -#endif - itel(i)=1 - else - itel(i)=2 - endif - enddo - if(me.eq.king.or..not.out1file)then - write (iout,*) "ITEL" - do i=1,nres-1 - write (iout,*) i,itype(i),itel(i) - enddo - print *,'Call Read_Bridge.' - endif - call read_bridge -C 8/13/98 Set limits to generating the dihedral angles - do i=1,nres - phibound(1,i)=-pi - phibound(2,i)=pi - enddo - read (inp,*) ndih_constr - if (ndih_constr.gt.0) then - read (inp,*) ftors - read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr) - if(me.eq.king.or..not.out1file)then - write (iout,*) - & 'There are',ndih_constr,' constraints on phi angles.' - do i=1,ndih_constr - write (iout,'(i5,2f8.3)') idih_constr(i),phi0(i),drange(i) - enddo - endif - do i=1,ndih_constr - phi0(i)=deg2rad*phi0(i) - drange(i)=deg2rad*drange(i) - enddo - if(me.eq.king.or..not.out1file) - & write (iout,*) 'FTORS',ftors - do i=1,ndih_constr - ii = idih_constr(i) - phibound(1,ii) = phi0(i)-drange(i) - phibound(2,ii) = phi0(i)+drange(i) - enddo - endif - nnt=1 -#ifdef MPI - if (me.eq.king) then -#endif - write (iout,'(a)') 'Boundaries in phi angle sampling:' - do i=1,nres - write (iout,'(a3,i5,2f10.1)') - & restyp(itype(i)),i,phibound(1,i)*rad2deg,phibound(2,i)*rad2deg - enddo -#ifdef MP - endif -#endif - nct=nres -cd print *,'NNT=',NNT,' NCT=',NCT - if (itype(1).eq.21) nnt=2 - if (itype(nres).eq.21) nct=nct-1 - if (pdbref) then - if(me.eq.king.or..not.out1file) - & write (iout,'(a,i3)') 'nsup=',nsup - nstart_seq=nnt - if (nsup.le.(nct-nnt+1)) then - do i=0,nct-nnt+1-nsup - if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup),nsup)) then - nstart_seq=nnt+i - goto 111 - endif - enddo - write (iout,'(a)') - & 'Error - sequences to be superposed do not match.' - stop - else - do i=0,nsup-(nct-nnt+1) - if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),nct-nnt+1)) - & then - nstart_sup=nstart_sup+i - nsup=nct-nnt+1 - goto 111 - endif - enddo - write (iout,'(a)') - & 'Error - sequences to be superposed do not match.' - endif - 111 continue - if (nsup.eq.0) nsup=nct-nnt - if (nstart_sup.eq.0) nstart_sup=nnt - if (nstart_seq.eq.0) nstart_seq=nnt - if(me.eq.king.or..not.out1file) - & write (iout,*) 'nsup=',nsup,' nstart_sup=',nstart_sup, - & ' nstart_seq=',nstart_seq - endif -c--- Zscore rms ------- - if (nz_start.eq.0) nz_start=nnt - if (nz_end.eq.0 .and. nsup.gt.0) then - nz_end=nnt+nsup-1 - else if (nz_end.eq.0) then - nz_end=nct - endif - if(me.eq.king.or..not.out1file)then - write (iout,*) 'NZ_START=',nz_start,' NZ_END=',nz_end - write (iout,*) 'IZ_SC=',iz_sc - endif -c---------------------- - call init_int_table - if (refstr) then - if (.not.pdbref) then - call read_angles(inp,*38) - goto 39 - 38 write (iout,'(a)') 'Error reading reference structure.' -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) - stop 'Error reading reference structure' -#endif - 39 call chainbuild - call setup_var -czscore call geom_to_var(nvar,coord_exp_zs(1,1)) - nstart_sup=nnt - nstart_seq=nnt - nsup=nct-nnt+1 - do i=1,2*nres - do j=1,3 - cref(j,i)=c(j,i) - enddo - enddo -c call contact(.true.,ncont_ref,icont_ref,co) - endif -c write (iout,*) "constr_dist",constr_dist,nstart_sup,nsup - call flush(iout) - if (constr_dist.gt.0) call read_dist_constr -c write (iout,*) "After read_dist_constr nhpb",nhpb - call hpb_partition - if(me.eq.king.or..not.out1file) - & write (iout,*) 'Contact order:',co - if (pdbref) then - if(me.eq.king.or..not.out1file) - & write (2,*) 'Shifting contacts:',nstart_seq,nstart_sup - do i=1,ncont_ref - do j=1,2 - icont_ref(j,i)=icont_ref(j,i)+nstart_seq-nstart_sup - enddo - if(me.eq.king.or..not.out1file) - & write (2,*) i,' ',restyp(itype(icont_ref(1,i))),' ', - & icont_ref(1,i),' ', - & restyp(itype(icont_ref(2,i))),' ',icont_ref(2,i) - enddo - endif - endif - if (indpdb.eq.0 .and. modecalc.ne.2 .and. modecalc.ne.4 - & .and. modecalc.ne.8 .and. modecalc.ne.9 .and. - & modecalc.ne.10) then -C If input structure hasn't been supplied from the PDB file read or generate -C initial geometry. - if (iranconf.eq.0 .and. .not. extconf) then - if(me.eq.king.or..not.out1file .and.fg_rank.eq.0) - & write (iout,'(a)') 'Initial geometry will be read in.' - if (read_cart) then - read(inp,'(8f10.5)',end=36,err=36) - & ((c(l,k),l=1,3),k=1,nres), - & ((c(l,k+nres),l=1,3),k=nnt,nct) - call int_from_cart1(.false.) - do i=1,nres-1 - do j=1,3 - dc(j,i)=c(j,i+1)-c(j,i) - dc_norm(j,i)=dc_norm(j,i)*vbld_inv(i+1) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc(j,i+nres)=c(j,i+nres)-c(j,i) - dc_norm(j,i+nres)=dc_norm(j,i+nres)*vbld_inv(i+nres) - enddo - endif - enddo - return - else - call read_angles(inp,*36) - endif - goto 37 - 36 write (iout,'(a)') 'Error reading angle file.' -#ifdef MPI - call mpi_finalize( MPI_COMM_WORLD,IERR ) -#endif - stop 'Error reading angle file.' - 37 continue - else if (extconf) then - if(me.eq.king.or..not.out1file .and. fg_rank.eq.0) - & write (iout,'(a)') 'Extended chain initial geometry.' - do i=3,nres - theta(i)=90d0*deg2rad - enddo - do i=4,nres - phi(i)=180d0*deg2rad - enddo - do i=2,nres-1 - alph(i)=110d0*deg2rad - enddo - do i=2,nres-1 - omeg(i)=-120d0*deg2rad - enddo - else - if(me.eq.king.or..not.out1file) - & write (iout,'(a)') 'Random-generated initial geometry.' - - -#ifdef MPI - if (me.eq.king .or. fg_rank.eq.0 .and. ( - & modecalc.eq.12 .or. modecalc.eq.14) ) then -#endif - do itrial=1,100 - itmp=1 - call gen_rand_conf(itmp,*30) - goto 40 - 30 write (iout,*) 'Failed to generate random conformation', - & ', itrial=',itrial - write (*,*) 'Processor:',me, - & ' Failed to generate random conformation', - & ' itrial=',itrial - call intout - -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - enddo - write (iout,'(a,i3,a)') 'Processor:',me, - & ' error in generating random conformation.' - write (*,'(a,i3,a)') 'Processor:',me, - & ' error in generating random conformation.' - call flush(iout) -#ifdef MPI - call MPI_Abort(mpi_comm_world,error_msg,ierrcode) - 40 continue - endif -#else - do itrial=1,100 - itmp=1 - call gen_rand_conf(itmp,*31) - goto 40 - 31 write (iout,*) 'Failed to generate random conformation', - & ', itrial=',itrial - write (*,*) 'Failed to generate random conformation', - & ', itrial=',itrial - enddo - write (iout,'(a,i3,a)') 'Processor:',me, - & ' error in generating random conformation.' - write (*,'(a,i3,a)') 'Processor:',me, - & ' error in generating random conformation.' - stop - 40 continue -#endif - endif - elseif (modecalc.eq.4) then - read (inp,'(a)') intinname - open (intin,file=intinname,status='old',err=333) - if (me.eq.king .or. .not.out1file.and.fg_rank.eq.0) - & write (iout,'(a)') 'intinname',intinname - write (*,'(a)') 'Processor',myrank,' intinname',intinname - goto 334 - 333 write (iout,'(2a)') 'Error opening angle file ',intinname -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERR) -#endif - stop 'Error opening angle file.' - 334 continue - - endif -C Generate distance constraints, if the PDB structure is to be regularized. -c if (nthread.gt.0) then -c call read_threadbase -c endif - call setup_var - if (me.eq.king .or. .not. out1file) - & call intout - if (ns.gt.0 .and. (me.eq.king .or. .not.out1file) ) then - write (iout,'(/a,i3,a)') - & 'The chain contains',ns,' disulfide-bridging cysteines.' - write (iout,'(20i4)') (iss(i),i=1,ns) - write (iout,'(/a/)') 'Pre-formed links are:' - do i=1,nss - i1=ihpb(i)-nres - i2=jhpb(i)-nres - it1=itype(i1) - it2=itype(i2) - if (me.eq.king.or..not.out1file) - & write (iout,'(2a,i3,3a,i3,a,3f10.3)') - & restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')',dhpb(i), - & ebr,forcon(i) - enddo - write (iout,'(a)') - endif -c if (i2ndstr.gt.0) call secstrp2dihc -c call geom_to_var(nvar,x) -c call etotal(energia(0)) -c call enerprint(energia(0)) -c call briefout(0,etot) -c stop -cd write (iout,'(2(a,i3))') 'NNT',NNT,' NCT',NCT -cd write (iout,'(a)') 'Variable list:' -cd write (iout,'(i4,f10.5)') (i,rad2deg*x(i),i=1,nvar) -#ifdef MPI - if (me.eq.king .or. (fg_rank.eq.0 .and. .not.out1file)) - & write (iout,'(//80(1h*)/20x,a,i4,a/80(1h*)//)') - & 'Processor',myrank,': end reading molecular data.' -#endif - return - end -c-------------------------------------------------------------------------- - logical function seq_comp(itypea,itypeb,length) - implicit none - integer length,itypea(length),itypeb(length) - integer i - do i=1,length - if (itypea(i).ne.itypeb(i)) then - seq_comp=.false. - return - endif - enddo - seq_comp=.true. - return - end -c----------------------------------------------------------------------------- - subroutine read_bridge -C Read information about disulfide bridges. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' -c include 'COMMON.DBASE' -c include 'COMMON.THREAD' - include 'COMMON.TIME1' - include 'COMMON.SETUP' -C Read bridging residues. - read (inp,*) ns,(iss(i),i=1,ns) - print *,'ns=',ns - if(me.eq.king.or..not.out1file) - & write (iout,*) 'ns=',ns,' iss:',(iss(i),i=1,ns) -C Check whether the specified bridging residues are cystines. - do i=1,ns - if (itype(iss(i)).ne.1) then - if (me.eq.king.or..not.out1file) write (iout,'(2a,i3,a)') - & 'Do you REALLY think that the residue ',restyp(iss(i)),i, - & ' can form a disulfide bridge?!!!' - write (*,'(2a,i3,a)') - & 'Do you REALLY think that the residue ',restyp(iss(i)),i, - & ' can form a disulfide bridge?!!!' -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,ierror) - stop -#endif - endif - enddo -C Read preformed bridges. - if (ns.gt.0) then - read (inp,*) nss,(ihpb(i),jhpb(i),i=1,nss) - write (iout,*) 'nss=',nss,' ihpb,jhpb: ',(ihpb(i),jhpb(i),i=1,nss) - if (nss.gt.0) then - nhpb=nss -C Check if the residues involved in bridges are in the specified list of -C bridging residues. - do i=1,nss - do j=1,i-1 - if (ihpb(i).eq.ihpb(j).or.ihpb(i).eq.jhpb(j) - & .or.jhpb(i).eq.ihpb(j).or.jhpb(i).eq.jhpb(j)) then - write (iout,'(a,i3,a)') 'Disulfide pair',i, - & ' contains residues present in other pairs.' - write (*,'(a,i3,a)') 'Disulfide pair',i, - & ' contains residues present in other pairs.' -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,ierror) - stop -#endif - endif - enddo - do j=1,ns - if (ihpb(i).eq.iss(j)) goto 10 - enddo - write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' - 10 continue - do j=1,ns - if (jhpb(i).eq.iss(j)) goto 20 - enddo - write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' - 20 continue - dhpb(i)=dbr - forcon(i)=fbr - enddo - do i=1,nss - ihpb(i)=ihpb(i)+nres - jhpb(i)=jhpb(i)+nres - enddo - endif - endif - return - end -c---------------------------------------------------------------------------- - subroutine read_x(kanal,*) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' -c Read coordinates from input -c - read(kanal,'(8f10.5)',end=10,err=10) - & ((c(l,k),l=1,3),k=1,nres), - & ((c(l,k+nres),l=1,3),k=nnt,nct) - do j=1,3 - c(j,nres+1)=c(j,1) - c(j,2*nres)=c(j,nres) - enddo - call int_from_cart1(.false.) - do i=1,nres-1 - do j=1,3 - dc(j,i)=c(j,i+1)-c(j,i) - dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc(j,i+nres)=c(j,i+nres)-c(j,i) - dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) - enddo - endif - enddo - - return - 10 return1 - end -c------------------------------------------------------------------------------ - subroutine setup_var - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' -c include 'COMMON.DBASE' -c include 'COMMON.THREAD' - include 'COMMON.TIME1' -C Set up variable list. - ntheta=nres-2 - nphi=nres-3 - nvar=ntheta+nphi - nside=0 - do i=2,nres-1 - if (itype(i).ne.10) then - nside=nside+1 - ialph(i,1)=nvar+nside - ialph(nside,2)=i - endif - enddo - if (indphi.gt.0) then - nvar=nphi - else if (indback.gt.0) then - nvar=nphi+ntheta - else - nvar=nvar+2*nside - endif -cd write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1) - return - end -c---------------------------------------------------------------------------- - subroutine gen_dist_constr -C Generate CA distance constraints. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' -c include 'COMMON.DBASE' -c include 'COMMON.THREAD' - include 'COMMON.TIME1' - dimension itype_pdb(maxres) - common /pizda/ itype_pdb - character*2 iden -cd print *,'gen_dist_constr: nnt=',nnt,' nct=',nct -cd write (2,*) 'gen_dist_constr: nnt=',nnt,' nct=',nct, -cd & ' nstart_sup',nstart_sup,' nstart_seq',nstart_seq, -cd & ' nsup',nsup - do i=nstart_sup,nstart_sup+nsup-1 -cd write (2,*) 'i',i,' seq ',restyp(itype(i+nstart_seq-nstart_sup)), -cd & ' seq_pdb', restyp(itype_pdb(i)) - do j=i+2,nstart_sup+nsup-1 - nhpb=nhpb+1 - ihpb(nhpb)=i+nstart_seq-nstart_sup - jhpb(nhpb)=j+nstart_seq-nstart_sup - forcon(nhpb)=weidis - dhpb(nhpb)=dist(i,j) - enddo - enddo -cd write (iout,'(a)') 'Distance constraints:' -cd do i=nss+1,nhpb -cd ii=ihpb(i) -cd jj=jhpb(i) -cd iden='CA' -cd if (ii.gt.nres) then -cd iden='SC' -cd ii=ii-nres -cd jj=jj-nres -cd endif -cd write (iout,'(a,1x,a,i4,3x,a,1x,a,i4,2f10.3)') -cd & restyp(itype(ii)),iden,ii,restyp(itype(jj)),iden,jj, -cd & dhpb(i),forcon(i) -cd enddo - return - end - - subroutine read_minim - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MINIM' - include 'COMMON.IOUNITS' - character*80 ucase - character*320 minimcard - call card_concat(minimcard) - call readi(minimcard,'MAXMIN',maxmin,2000) - call readi(minimcard,'MAXFUN',maxfun,5000) - call readi(minimcard,'MINMIN',minmin,maxmin) - call readi(minimcard,'MINFUN',minfun,maxmin) - call reada(minimcard,'TOLF',tolf,1.0D-2) - call reada(minimcard,'RTOLF',rtolf,1.0D-4) - print_min_stat=min0(index(minimcard,'PRINT_MIN_STAT'),1) - print_min_res=min0(index(minimcard,'PRINT_MIN_RES'),1) - print_min_ini=min0(index(minimcard,'PRINT_MIN_INI'),1) - write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Options in energy minimization:' - write (iout,'(4(a,i5),a,1pe14.5,a,1pe14.5)') - & 'MaxMin:',MaxMin,' MaxFun:',MaxFun, - & 'MinMin:',MinMin,' MinFun:',MinFun, - & ' TolF:',TolF,' RTolF:',RTolF - return - end -c---------------------------------------------------------------------------- - subroutine read_angles(kanal,*) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' -c Read angles from input -c - read (kanal,*,err=10,end=10) (theta(i),i=3,nres) - read (kanal,*,err=10,end=10) (phi(i),i=4,nres) - read (kanal,*,err=10,end=10) (alph(i),i=2,nres-1) - read (kanal,*,err=10,end=10) (omeg(i),i=2,nres-1) - - do i=1,nres -c 9/7/01 avoid 180 deg valence angle - if (theta(i).gt.179.99d0) theta(i)=179.99d0 -c - theta(i)=deg2rad*theta(i) - phi(i)=deg2rad*phi(i) - alph(i)=deg2rad*alph(i) - omeg(i)=deg2rad*omeg(i) - enddo - return - 10 return1 - end -c---------------------------------------------------------------------------- - subroutine reada(rekord,lancuch,wartosc,default) - implicit none - character*(*) rekord,lancuch - double precision wartosc,default - integer ilen,iread - external ilen - iread=index(rekord,lancuch) - if (iread.eq.0) then - wartosc=default - return - endif - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,err=10,end=10) wartosc - return - 10 wartosc=default - return - end -c---------------------------------------------------------------------------- - subroutine readi(rekord,lancuch,wartosc,default) - implicit none - character*(*) rekord,lancuch - integer wartosc,default - integer ilen,iread - external ilen - iread=index(rekord,lancuch) - if (iread.eq.0) then - wartosc=default - return - endif - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,err=10,end=10) wartosc - return - 10 wartosc=default - return - end -c---------------------------------------------------------------------------- - subroutine multreadi(rekord,lancuch,tablica,dim,default) - implicit none - integer dim,i - integer tablica(dim),default - character*(*) rekord,lancuch - character*80 aux - integer ilen,iread - external ilen - do i=1,dim - tablica(i)=default - enddo - iread=index(rekord,lancuch(:ilen(lancuch))//"=") - if (iread.eq.0) return - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) - 10 return - end -c---------------------------------------------------------------------------- - subroutine multreada(rekord,lancuch,tablica,dim,default) - implicit none - integer dim,i - double precision tablica(dim),default - character*(*) rekord,lancuch - character*80 aux - integer ilen,iread - external ilen - do i=1,dim - tablica(i)=default - enddo - iread=index(rekord,lancuch(:ilen(lancuch))//"=") - if (iread.eq.0) return - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) - 10 return - end -c---------------------------------------------------------------------------- - subroutine openunits - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - character*16 form,nodename - integer nodelen -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' -c include 'COMMON.MD' - include 'COMMON.CONTROL' - integer lenpre,lenpot,ilen,lentmp - external ilen - character*3 out1file_text,ucase - character*3 ll - external ucase -c print *,"Processor",myrank,"fg_rank",fg_rank," entered openunits" - call getenv_loc("PREFIX",prefix) - pref_orig = prefix - call getenv_loc("POT",pot) - call getenv_loc("DIRTMP",tmpdir) - call getenv_loc("CURDIR",curdir) - call getenv_loc("OUT1FILE",out1file_text) -c print *,"Processor",myrank,"fg_rank",fg_rank," did GETENV" - out1file_text=ucase(out1file_text) - if (out1file_text(1:1).eq."Y") then - out1file=.true. - else - out1file=fg_rank.gt.0 - endif - lenpre=ilen(prefix) - lenpot=ilen(pot) - lentmp=ilen(tmpdir) - if (lentmp.gt.0) then - write (*,'(80(1h!))') - write (*,'(a,19x,a,19x,a)') "!"," A T T E N T I O N ","!" - write (*,'(80(1h!))') - write (*,*)"All output files will be on node /tmp directory." -#ifdef MPI - call MPI_GET_PROCESSOR_NAME( nodename, nodelen, IERROR ) - if (me.eq.king) then - write (*,*) "The master node is ",nodename - else if (fg_rank.eq.0) then - write (*,*) "I am the CG slave node ",nodename - else - write (*,*) "I am the FG slave node ",nodename - endif -#endif - PREFIX = tmpdir(:lentmp)//'/'//prefix(:lenpre) - lenpre = lentmp+lenpre+1 - endif - entname=prefix(:lenpre)//'_'//pot(:lenpot)//'.entr' -C Get the names and open the input files -#if defined(WINIFL) || defined(WINPGI) - open(1,file=pref_orig(:ilen(pref_orig))// - & '.inp',status='old',readonly,shared) - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -C Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old',readonly,shared) - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old',readonly,shared) -#ifndef CRYST_THETA - call getenv_loc('THETPARPDB',thetname_pdb) - open (ithep_pdb,file=thetname_pdb,status='old',readonly,shared) -#endif - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old',readonly,shared) -#ifndef CRYST_SC - call getenv_loc('ROTPARPDB',rotname_pdb) - open (irotam_pdb,file=rotname_pdb,status='old',readonly,shared) -#endif - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old',readonly,shared) - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old',readonly,shared) - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old',readonly,shared) - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old',readonly,shared) - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old', - & action='read') -c print *,"Processor",myrank," opened file 1" - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -c print *,"Processor",myrank," opened file 9" -C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -C Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old',action='read') -c print *,"Processor",myrank," opened file IBOND" - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old',action='read') -c print *,"Processor",myrank," opened file ITHEP" -#ifndef CRYST_THETA - call getenv_loc('THETPARPDB',thetname_pdb) - open (ithep_pdb,file=thetname_pdb,status='old',action='read') -#endif - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old',action='read') -c print *,"Processor",myrank," opened file IROTAM" -#ifndef CRYST_SC - call getenv_loc('ROTPARPDB',rotname_pdb) - open (irotam_pdb,file=rotname_pdb,status='old',action='read') -#endif - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old',action='read') -c print *,"Processor",myrank," opened file ITORP" - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old',action='read') -c print *,"Processor",myrank," opened file ITORDP" - call getenv_loc('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old',action='read') -c print *,"Processor",myrank," opened file ISCCOR" - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old',action='read') -c print *,"Processor",myrank," opened file IFOURIER" - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old',action='read') -c print *,"Processor",myrank," opened file IELEP" - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old',action='read') -c print *,"Processor",myrank," opened file ISIDEP" -c print *,"Processor",myrank," opened parameter files" -#elif (defined G77) - open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old') - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -C Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old') - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old') -#ifndef CRYST_THETA - call getenv_loc('THETPARPDB',thetname_pdb) - open (ithep_pdb,file=thetname_pdb,status='old') -#endif - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old') -#ifndef CRYST_SC - call getenv_loc('ROTPARPDB',rotname_pdb) - open (irotam_pdb,file=rotname_pdb,status='old') -#endif - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old') - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old') - call getenv_loc('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old') - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old') - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old') - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old') -#else - open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old', - & readonly) - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -C Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old',readonly) - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old',readonly) -#ifndef CRYST_THETA - call getenv_loc('THETPARPDB',thetname_pdb) - print *,"thetname_pdb ",thetname_pdb - open (ithep_pdb,file=thetname_pdb,status='old',readonly) - print *,ithep_pdb," opened" -#endif - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old',readonly) -#ifndef CRYST_SC - call getenv_loc('ROTPARPDB',rotname_pdb) - open (irotam_pdb,file=rotname_pdb,status='old',readonly) -#endif - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old',readonly) - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old',readonly) - call getenv_loc('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old',readonly) - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old',readonly) - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old',readonly) - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old',readonly) -#endif -#ifndef OLDSCP -C -C 8/9/01 In the newest version SCp interaction constants are read from a file -C Use -DOLDSCP to use hard-coded constants instead. -C - call getenv_loc('SCPPAR',scpname) -#if defined(WINIFL) || defined(WINPGI) - open (iscpp,file=scpname,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open (iscpp,file=scpname,status='old',action='read') -#elif (defined G77) - open (iscpp,file=scpname,status='old') -#else - open (iscpp,file=scpname,status='old',readonly) -#endif -#endif - call getenv_loc('PATTERN',patname) -#if defined(WINIFL) || defined(WINPGI) - open (icbase,file=patname,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open (icbase,file=patname,status='old',action='read') -#elif (defined G77) - open (icbase,file=patname,status='old') -#else - open (icbase,file=patname,status='old',readonly) -#endif -#ifdef MPI -C Open output file only for CG processes -c print *,"Processor",myrank," fg_rank",fg_rank - if (fg_rank.eq.0) then - - if (nodes.eq.1) then - npos=3 - else - npos = dlog10(dfloat(nodes-1))+1 - endif - if (npos.lt.3) npos=3 - write (liczba,'(i1)') npos - form = '(bz,i'//liczba(:ilen(liczba))//'.'//liczba(:ilen(liczba)) - & //')' - write (liczba,form) me - outname=prefix(:lenpre)//'.out_'//pot(:lenpot)// - & liczba(:ilen(liczba)) - intname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba)) - & //'.int' - pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba)) - & //'.pdb' - mol2name=prefix(:lenpre)//'_'//pot(:lenpot)// - & liczba(:ilen(liczba))//'.mol2' - statname=prefix(:lenpre)//'_'//pot(:lenpot)// - & liczba(:ilen(liczba))//'.stat' - if (lentmp.gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot) - & //liczba(:ilen(liczba))//'.stat') - rest2name=prefix(:ilen(prefix))//"_"//liczba(:ilen(liczba)) - & //'.rst' -c if(usampl) then -c qname=prefix(:lenpre)//'_'//pot(:lenpot)// -c & liczba(:ilen(liczba))//'.const' -c endif - - endif -#else - outname=prefix(:lenpre)//'.out_'//pot(:lenpot) - intname=prefix(:lenpre)//'_'//pot(:lenpot)//'.int' - pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//'.pdb' - mol2name=prefix(:lenpre)//'_'//pot(:lenpot)//'.mol2' - statname=prefix(:lenpre)//'_'//pot(:lenpot)//'.stat' - if (lentmp.gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot)// - & '.stat') - rest2name=prefix(:ilen(prefix))//'.rst' -c if(usampl) then -c qname=prefix(:lenpre)//'_'//pot(:lenpot)//'.const' -c endif -#endif -#if defined(AIX) || defined(PGI) - if (me.eq.king .or. .not. out1file) - & open(iout,file=outname,status='unknown') -#ifdef DEBUG - if (fg_rank.gt.0) then - write (liczba,'(i3.3)') myrank/nfgtasks - write (ll,'(bz,i3.3)') fg_rank - open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll, - & status='unknown') - endif -#endif - if(me.eq.king) then - open(igeom,file=intname,status='unknown',position='append') - open(ipdb,file=pdbname,status='unknown') - open(imol2,file=mol2name,status='unknown') - open(istat,file=statname,status='unknown',position='append') - else -c1out open(iout,file=outname,status='unknown') - endif -#else - if (me.eq.king .or. .not.out1file) - & open(iout,file=outname,status='unknown') -#ifdef DEBUG - if (fg_rank.gt.0) then - write (liczba,'(i3.3)') myrank/nfgtasks - write (ll,'(bz,i3.3)') fg_rank - open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll, - & status='unknown') - endif -#endif - if(me.eq.king) then - open(igeom,file=intname,status='unknown',access='append') - open(ipdb,file=pdbname,status='unknown') - open(imol2,file=mol2name,status='unknown') - open(istat,file=statname,status='unknown',access='append') - else -c1out open(iout,file=outname,status='unknown') - endif -#endif - csa_rbank=prefix(:lenpre)//'.CSA.rbank' - csa_seed=prefix(:lenpre)//'.CSA.seed' - csa_history=prefix(:lenpre)//'.CSA.history' - csa_bank=prefix(:lenpre)//'.CSA.bank' - csa_bank1=prefix(:lenpre)//'.CSA.bank1' - csa_alpha=prefix(:lenpre)//'.CSA.alpha' - csa_alpha1=prefix(:lenpre)//'.CSA.alpha1' -c!bankt csa_bankt=prefix(:lenpre)//'.CSA.bankt' - csa_int=prefix(:lenpre)//'.int' - csa_bank_reminimized=prefix(:lenpre)//'.CSA.bank_reminimized' - csa_native_int=prefix(:lenpre)//'.CSA.native.int' - csa_in=prefix(:lenpre)//'.CSA.in' -c print *,"Processor",myrank,"fg_rank",fg_rank," opened files" -C Write file names - if (me.eq.king)then - write (iout,'(80(1h-))') - write (iout,'(30x,a)') "FILE ASSIGNMENT" - write (iout,'(80(1h-))') - write (iout,*) "Input file : ", - & pref_orig(:ilen(pref_orig))//'.inp' - write (iout,*) "Output file : ", - & outname(:ilen(outname)) - write (iout,*) - write (iout,*) "Sidechain potential file : ", - & sidename(:ilen(sidename)) -#ifndef OLDSCP - write (iout,*) "SCp potential file : ", - & scpname(:ilen(scpname)) -#endif - write (iout,*) "Electrostatic potential file : ", - & elename(:ilen(elename)) - write (iout,*) "Cumulant coefficient file : ", - & fouriername(:ilen(fouriername)) - write (iout,*) "Torsional parameter file : ", - & torname(:ilen(torname)) - write (iout,*) "Double torsional parameter file : ", - & tordname(:ilen(tordname)) - write (iout,*) "SCCOR parameter file : ", - & sccorname(:ilen(sccorname)) - write (iout,*) "Bond & inertia constant file : ", - & bondname(:ilen(bondname)) - write (iout,*) "Bending parameter file : ", - & thetname(:ilen(thetname)) - write (iout,*) "Rotamer parameter file : ", - & rotname(:ilen(rotname)) - write (iout,*) "Threading database : ", - & patname(:ilen(patname)) - if (lentmp.ne.0) - &write (iout,*)" DIRTMP : ", - & tmpdir(:lentmp) - write (iout,'(80(1h-))') - endif - return - end -c---------------------------------------------------------------------------- - subroutine card_concat(card) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - character*(*) card - character*80 karta,ucase - external ilen - read (inp,'(a)') karta - karta=ucase(karta) - card=' ' - do while (karta(80:80).eq.'&') - card=card(:ilen(card)+1)//karta(:79) - read (inp,'(a)') karta - karta=ucase(karta) - enddo - card=card(:ilen(card)+1)//karta - return - end - - subroutine read_dist_constr - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.SBRIDGE' - integer ifrag_(2,100),ipair_(2,100) - double precision wfrag_(100),wpair_(100) - character*500 controlcard -c write (iout,*) "Calling read_dist_constr" -c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup -c call flush(iout) - call card_concat(controlcard) - call readi(controlcard,"NFRAG",nfrag_,0) - call readi(controlcard,"NPAIR",npair_,0) - call readi(controlcard,"NDIST",ndist_,0) - call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) - call multreadi(controlcard,"IFRAG",ifrag_(1,1),2*nfrag_,0) - call multreadi(controlcard,"IPAIR",ipair_(1,1),2*npair_,0) - call multreada(controlcard,"WFRAG",wfrag_(1),nfrag_,0.0d0) - call multreada(controlcard,"WPAIR",wpair_(1),npair_,0.0d0) -c write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_ -c write (iout,*) "IFRAG" -c do i=1,nfrag_ -c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) -c enddo -c write (iout,*) "IPAIR" -c do i=1,npair_ -c write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i) -c enddo - call flush(iout) - do i=1,nfrag_ - if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup - if (ifrag_(2,i).gt.nstart_sup+nsup-1) - & ifrag_(2,i)=nstart_sup+nsup-1 -c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) - call flush(iout) - if (wfrag_(i).gt.0.0d0) then - do j=ifrag_(1,i),ifrag_(2,i)-1 - do k=j+1,ifrag_(2,i) - write (iout,*) "j",j," k",k - ddjk=dist(j,k) - if (constr_dist.eq.1) then - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i) - else if (constr_dist.eq.2) then - if (ddjk.le.dist_cut) then - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i) - endif - else - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) - endif -#ifdef MPI - if (.not.out1file .or. me.eq.king) - & write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#else - write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#endif - enddo - enddo - endif - enddo - do i=1,npair_ - if (wpair_(i).gt.0.0d0) then - ii = ipair_(1,i) - jj = ipair_(2,i) - if (ii.gt.jj) then - itemp=ii - ii=jj - jj=itemp - endif - do j=ifrag_(1,ii),ifrag_(2,ii) - do k=ifrag_(1,jj),ifrag_(2,jj) - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - forcon(nhpb)=wpair_(i) - dhpb(nhpb)=dist(j,k) -#ifdef MPI - if (.not.out1file .or. me.eq.king) - & write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#else - write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#endif - enddo - enddo - endif - enddo - do i=1,ndist_ - read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),forcon(nhpb+1) - if (forcon(nhpb+1).gt.0.0d0) then - nhpb=nhpb+1 - dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) -#ifdef MPI - if (.not.out1file .or. me.eq.king) - & write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#else - write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#endif - endif - enddo - call flush(iout) - return - end -c------------------------------------------------------------------------------- -#ifdef WINIFL - subroutine flush(iu) - return - end -#endif -#ifdef AIX - subroutine flush(iu) - call flush_(iu) - return - end -#endif -c------------------------------------------------------------------------------ - subroutine copy_to_tmp(source) - include "DIMENSIONS" - include "COMMON.IOUNITS" - character*(*) source - character* 256 tmpfile - integer ilen - external ilen - logical ex - tmpfile=curdir(:ilen(curdir))//"/"//source(:ilen(source)) - inquire(file=tmpfile,exist=ex) - if (ex) then - write (*,*) "Copying ",tmpfile(:ilen(tmpfile)), - & " to temporary directory..." - write (*,*) "/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir - call system("/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir) - endif - return - end -c------------------------------------------------------------------------------ - subroutine move_from_tmp(source) - include "DIMENSIONS" - include "COMMON.IOUNITS" - character*(*) source - integer ilen - external ilen - write (*,*) "Moving ",source(:ilen(source)), - & " from temporary directory to working directory" - write (*,*) "/bin/mv "//source(:ilen(source))//" "//curdir - call system("/bin/mv "//source(:ilen(source))//" "//curdir) - return - end -c------------------------------------------------------------------------------ - subroutine random_init(seed) -C -C Initialize random number generator -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef AMD64 - integer*8 iseedi8 -#endif -#ifdef MPI - include 'mpif.h' - logical OKRandom, prng_restart - real*8 r1 - integer iseed_array(4) -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' -c include 'COMMON.THREAD' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.MCM' -c include 'COMMON.MAP' - include 'COMMON.HEADER' -c include 'COMMON.CSA' - include 'COMMON.CHAIN' -c include 'COMMON.MUCA' -c include 'COMMON.MD' - include 'COMMON.FFIELD' - include 'COMMON.SETUP' - iseed=-dint(dabs(seed)) - if (iseed.eq.0) then - write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Random seed undefined. The program will stop.' - write (*,'(/80(1h*)/20x,a/80(1h*))') - & 'Random seed undefined. The program will stop.' -#ifdef MPI - call mpi_finalize(mpi_comm_world,ierr) -#endif - stop 'Bad random seed.' - endif -#ifdef MPI - if (fg_rank.eq.0) then - seed=seed*(me+1)+1 -#ifdef AMD64 - iseedi8=dint(seed) - if(me.eq.king .or. .not. out1file) - & write (iout,*) 'MPI: node= ', me, ' iseed= ',iseedi8 - write (*,*) 'MPI: node= ', me, ' iseed= ',iseedi8 - OKRandom = prng_restart(me,iseedi8) -#else - do i=1,4 - tmp=65536.0d0**(4-i) - iseed_array(i) = dint(seed/tmp) - seed=seed-iseed_array(i)*tmp - enddo - if(me.eq.king .or. .not. out1file) - & write (iout,*) 'MPI: node= ', me, ' iseed(4)= ', - & (iseed_array(i),i=1,4) - write (*,*) 'MPI: node= ',me, ' iseed(4)= ', - & (iseed_array(i),i=1,4) - OKRandom = prng_restart(me,iseed_array) -#endif - if (OKRandom) then -c r1=ran_number(0.0D0,1.0D0) - if(me.eq.king .or. .not. out1file) - & write (iout,*) 'ran_num',r1 - if (r1.lt.0.0d0) OKRandom=.false. - endif - if (.not.OKRandom) then - write (iout,*) 'PRNG IS NOT WORKING!!!' - print *,'PRNG IS NOT WORKING!!!' - if (me.eq.0) then - call flush(iout) - call mpi_abort(mpi_comm_world,error_msg,ierr) - stop - else - write (iout,*) 'too many processors for parallel prng' - write (*,*) 'too many processors for parallel prng' - call flush(iout) - stop - endif - endif - endif -#else - call vrndst(iseed) -c write (iout,*) 'ran_num',ran_number(0.0d0,1.0d0) -#endif - return - end diff --git a/source/unres/src_MIN/refsys.f b/source/unres/src_MIN/refsys.f deleted file mode 100644 index b57c201..0000000 --- a/source/unres/src_MIN/refsys.f +++ /dev/null @@ -1,60 +0,0 @@ - subroutine refsys(i2,i3,i4,e1,e2,e3,fail) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -c this subroutine calculates unity vectors of a local reference system -c defined by atoms (i2), (i3), and (i4). the x axis is the axis from -c atom (i3) to atom (i2), and the xy plane is the plane defined by atoms -c (i2), (i3), and (i4). z axis is directed according to the sign of the -c vector product (i3)-(i2) and (i3)-(i4). sets fail to .true. if atoms -c (i2) and (i3) or (i3) and (i4) coincide or atoms (i2), (i3), and (i4) -c form a linear fragment. returns vectors e1, e2, and e3. - logical fail - double precision e1(3),e2(3),e3(3) - double precision u(3),z(3) - include 'COMMON.IOUNITS' - include "COMMON.CHAIN" - data coinc /1.0d-13/,align /1.0d-13/ - fail=.false. - s1=0.0d0 - s2=0.0d0 - do 1 i=1,3 - zi=c(i,i2)-c(i,i3) - ui=c(i,i4)-c(i,i3) - s1=s1+zi*zi - s2=s2+ui*ui - z(i)=zi - 1 u(i)=ui - s1=sqrt(s1) - s2=sqrt(s2) - if (s1.gt.coinc) goto 2 - write (iout,1000) i2,i3,i1 - fail=.true. - return - 2 if (s2.gt.coinc) goto 4 - write(iout,1000) i3,i4,i1 - fail=.true. - return - 4 s1=1.0/s1 - s2=1.0/s2 - v1=z(2)*u(3)-z(3)*u(2) - v2=z(3)*u(1)-z(1)*u(3) - v3=z(1)*u(2)-z(2)*u(1) - anorm=sqrt(v1*v1+v2*v2+v3*v3) - if (anorm.gt.align) goto 6 - write (iout,1010) i2,i3,i4,i1 - fail=.true. - return - 6 anorm=1.0/anorm - e3(1)=v1*anorm - e3(2)=v2*anorm - e3(3)=v3*anorm - e1(1)=z(1)*s1 - e1(2)=z(2)*s1 - e1(3)=z(3)*s1 - e2(1)=e1(3)*e3(2)-e1(2)*e3(3) - e2(2)=e1(1)*e3(3)-e1(3)*e3(1) - e2(3)=e1(2)*e3(1)-e1(1)*e3(2) - 1000 format (/1x,' * * * error - atoms',i4,' and',i4,' coincide.') - 1010 format (/1x,' * * * error - atoms',2(i4,2h, ),i4,' form a linear') - return - end diff --git a/source/unres/src_MIN/rescode.f b/source/unres/src_MIN/rescode.f deleted file mode 100644 index 2973ef9..0000000 --- a/source/unres/src_MIN/rescode.f +++ /dev/null @@ -1,32 +0,0 @@ - integer function rescode(iseq,nam,itype) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - character*3 nam,ucase - - if (itype.eq.0) then - - do i=1,ntyp1 - if (ucase(nam).eq.restyp(i)) then - rescode=i - return - endif - enddo - - else - - do i=1,ntyp1 - if (nam(1:1).eq.onelet(i)) then - rescode=i - return - endif - enddo - - endif - - write (iout,10) iseq,nam - stop - 10 format ('**** Error - residue',i4,' has an unresolved name ',a3) - end - diff --git a/source/unres/src_MIN/rmdd.f b/source/unres/src_MIN/rmdd.f deleted file mode 100644 index 799ab47..0000000 --- a/source/unres/src_MIN/rmdd.f +++ /dev/null @@ -1,159 +0,0 @@ -c algorithm 611, collected algorithms from acm. -c algorithm appeared in acm-trans. math. software, vol.9, no. 4, -c dec., 1983, p. 503-524. - integer function imdcon(k) -c - integer k -c -c *** return integer machine-dependent constants *** -c -c *** k = 1 means return standard output unit number. *** -c *** k = 2 means return alternate output unit number. *** -c *** k = 3 means return input unit number. *** -c (note -- k = 2, 3 are used only by test programs.) -c -c +++ port version follows... -c external i1mach -c integer i1mach -c integer mdperm(3) -c data mdperm(1)/2/, mdperm(2)/4/, mdperm(3)/1/ -c imdcon = i1mach(mdperm(k)) -c +++ end of port version +++ -c -c +++ non-port version follows... - integer mdcon(3) - data mdcon(1)/6/, mdcon(2)/8/, mdcon(3)/5/ - imdcon = mdcon(k) -c +++ end of non-port version +++ -c - 999 return -c *** last card of imdcon follows *** - end - double precision function rmdcon(k) -c -c *** return machine dependent constants used by nl2sol *** -c -c +++ comments below contain data statements for various machines. +++ -c +++ to convert to another machine, place a c in column 1 of the +++ -c +++ data statement line(s) that correspond to the current machine +++ -c +++ and remove the c from column 1 of the data statement line(s) +++ -c +++ that correspond to the new machine. +++ -c - integer k -c -c *** the constant returned depends on k... -c -c *** k = 1... smallest pos. eta such that -eta exists. -c *** k = 2... square root of eta. -c *** k = 3... unit roundoff = smallest pos. no. machep such -c *** that 1 + machep .gt. 1 .and. 1 - machep .lt. 1. -c *** k = 4... square root of machep. -c *** k = 5... square root of big (see k = 6). -c *** k = 6... largest machine no. big such that -big exists. -c - double precision big, eta, machep - integer bigi(4), etai(4), machei(4) -c/+ - double precision dsqrt -c/ - equivalence (big,bigi(1)), (eta,etai(1)), (machep,machei(1)) -c -c +++ ibm 360, ibm 370, or xerox +++ -c -c data big/z7fffffffffffffff/, eta/z0010000000000000/, -c 1 machep/z3410000000000000/ -c -c +++ data general +++ -c -c data big/0.7237005577d+76/, eta/0.5397605347d-78/, -c 1 machep/2.22044605d-16/ -c -c +++ dec 11 +++ -c -c data big/1.7d+38/, eta/2.938735878d-39/, machep/2.775557562d-17/ -c -c +++ hp3000 +++ -c -c data big/1.157920892d+77/, eta/8.636168556d-78/, -c 1 machep/5.551115124d-17/ -c -c +++ honeywell +++ -c -c data big/1.69d+38/, eta/5.9d-39/, machep/2.1680435d-19/ -c -c +++ dec10 +++ -c -c data big/"377777100000000000000000/, -c 1 eta/"002400400000000000000000/, -c 2 machep/"104400000000000000000000/ -c -c +++ burroughs +++ -c -c data big/o0777777777777777,o7777777777777777/, -c 1 eta/o1771000000000000,o7770000000000000/, -c 2 machep/o1451000000000000,o0000000000000000/ -c -c +++ control data +++ -c -c data big/37767777777777777777b,37167777777777777777b/, -c 1 eta/00014000000000000000b,00000000000000000000b/, -c 2 machep/15614000000000000000b,15010000000000000000b/ -c -c +++ prime +++ -c -c data big/1.0d+9786/, eta/1.0d-9860/, machep/1.4210855d-14/ -c -c +++ univac +++ -c -c data big/8.988d+307/, eta/1.2d-308/, machep/1.734723476d-18/ -c -c +++ vax +++ -c - data big/1.7d+38/, eta/2.939d-39/, machep/1.3877788d-17/ -c -c +++ cray 1 +++ -c -c data bigi(1)/577767777777777777777b/, -c 1 bigi(2)/000007777777777777776b/, -c 2 etai(1)/200004000000000000000b/, -c 3 etai(2)/000000000000000000000b/, -c 4 machei(1)/377224000000000000000b/, -c 5 machei(2)/000000000000000000000b/ -c -c +++ port library -- requires more than just a data statement... +++ -c -c external d1mach -c double precision d1mach, zero -c data big/0.d+0/, eta/0.d+0/, machep/0.d+0/, zero/0.d+0/ -c if (big .gt. zero) go to 1 -c big = d1mach(2) -c eta = d1mach(1) -c machep = d1mach(4) -c1 continue -c -c +++ end of port +++ -c -c------------------------------- body -------------------------------- -c - go to (10, 20, 30, 40, 50, 60), k -c - 10 rmdcon = eta - go to 999 -c - 20 rmdcon = dsqrt(256.d+0*eta)/16.d+0 - go to 999 -c - 30 rmdcon = machep - go to 999 -c - 40 rmdcon = dsqrt(machep) - go to 999 -c - 50 rmdcon = dsqrt(big/256.d+0)*16.d+0 - go to 999 -c - 60 rmdcon = big -c - 999 return -c *** last card of rmdcon follows *** - end diff --git a/source/unres/src_MIN/sc_move.F b/source/unres/src_MIN/sc_move.F deleted file mode 100644 index b6837fd..0000000 --- a/source/unres/src_MIN/sc_move.F +++ /dev/null @@ -1,823 +0,0 @@ - subroutine sc_move(n_start,n_end,n_maxtry,e_drop, - + n_fun,etot) -c Perform a quick search over side-chain arrangments (over -c residues n_start to n_end) for a given (frozen) CA trace -c Only side-chains are minimized (at most n_maxtry times each), -c not CA positions -c Stops if energy drops by e_drop, otherwise tries all residues -c in the given range -c If there is an energy drop, full minimization may be useful -c n_start, n_end CAN be modified by this routine, but only if -c out of bounds (n_start <= 1, n_end >= nres, n_start < n_end) -c NOTE: this move should never increase the energy -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.HEADER' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - -c External functions - integer iran_num - external iran_num - -c Input arguments - integer n_start,n_end,n_maxtry - double precision e_drop - -c Output arguments - integer n_fun - double precision etot - -c Local variables - double precision energy(0:n_ene) - double precision cur_alph(2:nres-1),cur_omeg(2:nres-1) - double precision orig_e,cur_e - integer n,n_steps,n_first,n_cur,n_tot,i - double precision orig_w(n_ene) - double precision wtime - - -c Set non side-chain weights to zero (minimization is faster) -c NOTE: e(2) does not actually depend on the side-chain, only CA - orig_w(2)=wscp - orig_w(3)=welec - orig_w(4)=wcorr - orig_w(5)=wcorr5 - orig_w(6)=wcorr6 - orig_w(7)=wel_loc - orig_w(8)=wturn3 - orig_w(9)=wturn4 - orig_w(10)=wturn6 - orig_w(11)=wang - orig_w(13)=wtor - orig_w(14)=wtor_d - orig_w(15)=wvdwpp - - wscp=0.D0 - welec=0.D0 - wcorr=0.D0 - wcorr5=0.D0 - wcorr6=0.D0 - wel_loc=0.D0 - wturn3=0.D0 - wturn4=0.D0 - wturn6=0.D0 - wang=0.D0 - wtor=0.D0 - wtor_d=0.D0 - wvdwpp=0.D0 - -c Make sure n_start, n_end are within proper range - if (n_start.lt.2) n_start=2 - if (n_end.gt.nres-1) n_end=nres-1 -crc if (n_start.lt.n_end) then - if (n_start.gt.n_end) then - n_start=2 - n_end=nres-1 - endif - -c Save the initial values of energy and coordinates -cd call chainbuild -cd call etotal(energy) -cd write (iout,*) 'start sc ene',energy(0) -cd call enerprint(energy(0)) -crc etot=energy(0) - n_fun=0 -crc orig_e=etot -crc cur_e=orig_e -crc do i=2,nres-1 -crc cur_alph(i)=alph(i) -crc cur_omeg(i)=omeg(i) -crc enddo - -ct wtime=MPI_WTIME() -c Try (one by one) all specified residues, starting from a -c random position in sequence -c Stop early if the energy has decreased by at least e_drop - n_tot=n_end-n_start+1 - n_first=iran_num(0,n_tot-1) - n_steps=0 - n=0 -crc do while (n.lt.n_tot .and. orig_e-etot.lt.e_drop) - do while (n.lt.n_tot) - n_cur=n_start+mod(n_first+n,n_tot) - call single_sc_move(n_cur,n_maxtry,e_drop, - + n_steps,n_fun,etot) -c If a lower energy was found, update the current structure... -crc if (etot.lt.cur_e) then -crc cur_e=etot -crc do i=2,nres-1 -crc cur_alph(i)=alph(i) -crc cur_omeg(i)=omeg(i) -crc enddo -crc else -c ...else revert to the previous one -crc etot=cur_e -crc do i=2,nres-1 -crc alph(i)=cur_alph(i) -crc omeg(i)=cur_omeg(i) -crc enddo -crc endif - n=n+1 -cd -cd call chainbuild -cd call etotal(energy) -cd print *,'running',n,energy(0) - enddo - -cd call chainbuild -cd call etotal(energy) -cd write (iout,*) 'end sc ene',energy(0) - -c Put the original weights back to calculate the full energy - wscp=orig_w(2) - welec=orig_w(3) - wcorr=orig_w(4) - wcorr5=orig_w(5) - wcorr6=orig_w(6) - wel_loc=orig_w(7) - wturn3=orig_w(8) - wturn4=orig_w(9) - wturn6=orig_w(10) - wang=orig_w(11) - wtor=orig_w(13) - wtor_d=orig_w(14) - wvdwpp=orig_w(15) - -crc n_fun=n_fun+1 -ct write (iout,*) 'sc_local time= ',MPI_WTIME()-wtime - return - end - -c------------------------------------------------------------- - - subroutine single_sc_move(res_pick,n_maxtry,e_drop, - + n_steps,n_fun,e_sc) -c Perturb one side-chain (res_pick) and minimize the -c neighbouring region, keeping all CA's and non-neighbouring -c side-chains fixed -c Try until e_drop energy improvement is achieved, or n_maxtry -c attempts have been made -c At the start, e_sc should contain the side-chain-only energy(0) -c nsteps and nfun for this move are ADDED to n_steps and n_fun -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.CHAIN' - include 'COMMON.MINIM' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - -c External functions - double precision dist - external dist - -c Input arguments - integer res_pick,n_maxtry - double precision e_drop - -c Input/Output arguments - integer n_steps,n_fun - double precision e_sc - -c Local variables - logical fail - integer i,j - integer nres_moved - integer iretcode,loc_nfun,orig_maxfun,n_try - double precision sc_dist,sc_dist_cutoff - double precision energy(0:n_ene),orig_e,cur_e - double precision evdw,escloc - double precision cur_alph(2:nres-1),cur_omeg(2:nres-1) - double precision var(maxvar) - - double precision orig_theta(1:nres),orig_phi(1:nres), - + orig_alph(1:nres),orig_omeg(1:nres) - - -c Define what is meant by "neighbouring side-chain" - sc_dist_cutoff=5.0D0 - -c Don't do glycine or ends - i=itype(res_pick) - if (i.eq.10 .or. i.eq.21) return - -c Freeze everything (later will relax only selected side-chains) - mask_r=.true. - do i=1,nres - mask_phi(i)=0 - mask_theta(i)=0 - mask_side(i)=0 - enddo - -c Find the neighbours of the side-chain to move -c and save initial variables -crc orig_e=e_sc -crc cur_e=orig_e - nres_moved=0 - do i=2,nres-1 -c Don't do glycine (itype(j)==10) - if (itype(i).ne.10) then - sc_dist=dist(nres+i,nres+res_pick) - else - sc_dist=sc_dist_cutoff - endif - if (sc_dist.lt.sc_dist_cutoff) then - nres_moved=nres_moved+1 - mask_side(i)=1 - cur_alph(i)=alph(i) - cur_omeg(i)=omeg(i) - endif - enddo - - call chainbuild - call egb1(evdw) - call esc(escloc) - e_sc=wsc*evdw+wscloc*escloc -cd call etotal(energy) -cd print *,'new ',(energy(k),k=0,n_ene) - orig_e=e_sc - cur_e=orig_e - - n_try=0 - do while (n_try.lt.n_maxtry .and. orig_e-cur_e.lt.e_drop) -c Move the selected residue (don't worry if it fails) - call gen_side(itype(res_pick),theta(res_pick+1), - + alph(res_pick),omeg(res_pick),fail) - -c Minimize the side-chains starting from the new arrangement - call geom_to_var(nvar,var) - orig_maxfun=maxfun - maxfun=7 - -crc do i=1,nres -crc orig_theta(i)=theta(i) -crc orig_phi(i)=phi(i) -crc orig_alph(i)=alph(i) -crc orig_omeg(i)=omeg(i) -crc enddo - - call minimize_sc1(e_sc,var,iretcode,loc_nfun) - -cv write(*,'(2i3,2f12.5,2i3)') -cv & res_pick,nres_moved,orig_e,e_sc-cur_e, -cv & iretcode,loc_nfun - -c$$$ if (iretcode.eq.8) then -c$$$ write(iout,*)'Coordinates just after code 8' -c$$$ call chainbuild -c$$$ call all_varout -c$$$ call flush(iout) -c$$$ do i=1,nres -c$$$ theta(i)=orig_theta(i) -c$$$ phi(i)=orig_phi(i) -c$$$ alph(i)=orig_alph(i) -c$$$ omeg(i)=orig_omeg(i) -c$$$ enddo -c$$$ write(iout,*)'Coordinates just before code 8' -c$$$ call chainbuild -c$$$ call all_varout -c$$$ call flush(iout) -c$$$ endif - - n_fun=n_fun+loc_nfun - maxfun=orig_maxfun - call var_to_geom(nvar,var) - -c If a lower energy was found, update the current structure... - if (e_sc.lt.cur_e) then -cv call chainbuild -cv call etotal(energy) -cd call egb1(evdw) -cd call esc(escloc) -cd e_sc1=wsc*evdw+wscloc*escloc -cd print *,' new',e_sc1,energy(0) -cv print *,'new ',energy(0) -cd call enerprint(energy(0)) - cur_e=e_sc - do i=2,nres-1 - if (mask_side(i).eq.1) then - cur_alph(i)=alph(i) - cur_omeg(i)=omeg(i) - endif - enddo - else -c ...else revert to the previous one - e_sc=cur_e - do i=2,nres-1 - if (mask_side(i).eq.1) then - alph(i)=cur_alph(i) - omeg(i)=cur_omeg(i) - endif - enddo - endif - n_try=n_try+1 - - enddo - n_steps=n_steps+n_try - -c Reset the minimization mask_r to false - mask_r=.false. - - return - end - -c------------------------------------------------------------- - - subroutine sc_minimize(etot,iretcode,nfun) -c Minimizes side-chains only, leaving backbone frozen -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - -c Output arguments - double precision etot - integer iretcode,nfun - -c Local variables - integer i - double precision orig_w(n_ene),energy(0:n_ene) - double precision var(maxvar) - - -c Set non side-chain weights to zero (minimization is faster) -c NOTE: e(2) does not actually depend on the side-chain, only CA - orig_w(2)=wscp - orig_w(3)=welec - orig_w(4)=wcorr - orig_w(5)=wcorr5 - orig_w(6)=wcorr6 - orig_w(7)=wel_loc - orig_w(8)=wturn3 - orig_w(9)=wturn4 - orig_w(10)=wturn6 - orig_w(11)=wang - orig_w(13)=wtor - orig_w(14)=wtor_d - - wscp=0.D0 - welec=0.D0 - wcorr=0.D0 - wcorr5=0.D0 - wcorr6=0.D0 - wel_loc=0.D0 - wturn3=0.D0 - wturn4=0.D0 - wturn6=0.D0 - wang=0.D0 - wtor=0.D0 - wtor_d=0.D0 - -c Prepare to freeze backbone - do i=1,nres - mask_phi(i)=0 - mask_theta(i)=0 - mask_side(i)=1 - enddo - -c Minimize the side-chains - mask_r=.true. - call geom_to_var(nvar,var) - call minimize(etot,var,iretcode,nfun) - call var_to_geom(nvar,var) - mask_r=.false. - -c Put the original weights back and calculate the full energy - wscp=orig_w(2) - welec=orig_w(3) - wcorr=orig_w(4) - wcorr5=orig_w(5) - wcorr6=orig_w(6) - wel_loc=orig_w(7) - wturn3=orig_w(8) - wturn4=orig_w(9) - wturn6=orig_w(10) - wang=orig_w(11) - wtor=orig_w(13) - wtor_d=orig_w(14) - - call chainbuild - call etotal(energy) - etot=energy(0) - - return - end - -c------------------------------------------------------------- - subroutine minimize_sc1(etot,x,iretcode,nfun) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.MINIM' - common /srutu/ icall - dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) - double precision energia(0:n_ene) - external func,gradient,fdum - external func_restr1,grad_restr1 - logical not_done,change,reduce - common /przechowalnia/ v - - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit -c iv(21)=iout - iv(21)=0 -* 1 means to print out result - iv(22)=0 -* 1 means to print out summary stats - iv(23)=0 -* 1 means to print initial x and d - iv(24)=0 -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -c v(25)=4.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo - IF (mask_r) THEN - call x2xx(x,xx,nvar_restr) - call sumsl(nvar_restr,d,xx,func_restr1,grad_restr1, - & iv,liv,lv,v,idum,rdum,fdum) - call xx2x(x,xx) - ELSE - call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) - ENDIF - etot=v(10) - iretcode=iv(1) - nfun=iv(6) - - return - end -************************************************************************ - subroutine func_restr1(n,x,nf,f,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - include 'COMMON.INTERACT' - include 'COMMON.TIME1' - common /chuju/ jjj - double precision energia(0:n_ene),evdw,escloc - integer jjj - double precision ufparm,e1,e2 - external ufparm - integer uiparm(1) - real*8 urparm(1) - dimension x(maxvar) - nfl=nf - icg=mod(nf,2)+1 - -#ifdef OSF -c Intercept NaNs in the coordinates, before calling etotal - x_sum=0.D0 - do i=1,n - x_sum=x_sum+x(i) - enddo - FOUND_NAN=.false. - if (x_sum.ne.x_sum) then - write(iout,*)" *** func_restr1 : Found NaN in coordinates" - f=1.0D+73 - FOUND_NAN=.true. - return - endif -#endif - - call var_to_geom_restr(n,x) - call zerograd - call chainbuild -cd write (iout,*) 'ETOTAL called from FUNC' - call egb1(evdw) - call esc(escloc) - f=wsc*evdw+wscloc*escloc -cd call etotal(energia(0)) -cd f=wsc*energia(1)+wscloc*energia(12) -cd print *,f,evdw,escloc,energia(0) -C -C Sum up the components of the Cartesian gradient. -C - do i=1,nct - do j=1,3 - gradx(j,i,icg)=wsc*gvdwx(j,i) - enddo - enddo - - return - end -c------------------------------------------------------- - subroutine grad_restr1(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - external ufparm - integer uiparm(1) - double precision urparm(1) - dimension x(maxvar),g(maxvar) - - icg=mod(nf,2)+1 - if (nf-nfl+1) 20,30,40 - 20 call func_restr1(n,x,nf,f,uiparm,urparm,ufparm) -c write (iout,*) 'grad 20' - if (nf.eq.0) return - goto 40 - 30 call var_to_geom_restr(n,x) - call chainbuild -C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartder -C -C Convert the Cartesian gradient into internal-coordinate gradient. -C - - ig=0 - ind=nres-2 - do i=2,nres-2 - IF (mask_phi(i+2).eq.1) THEN - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) - enddo - enddo - ig=ig+1 - g(ig)=gphii - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - - ind=0 - do i=1,nres-2 - IF (mask_theta(i+2).eq.1) THEN - ig=ig+1 - gthetai=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) - enddo - enddo - g(ig)=gthetai - ELSE - ind=ind+nres-1-i - ENDIF - enddo - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - galphai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - g(ig)=galphai - ENDIF - endif - enddo - - - do i=2,nres-1 - if (itype(i).ne.10) then - IF (mask_side(i).eq.1) THEN - ig=ig+1 - gomegai=0.0D0 - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ig)=gomegai - ENDIF - endif - enddo - -C -C Add the components corresponding to local energy terms. -C - - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - enddo - - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 - g(ig)=g(ig)+gloc(igall,icg) - endif - endif - enddo - enddo - -cd do i=1,ig -cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) -cd enddo - return - end -C----------------------------------------------------------------------------- - subroutine egb1(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - include 'COMMON.CONTROL' - logical lprn - evdw=0.0D0 -c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -c if (icall.eq.0) lprn=.true. - ind=0 - do i=iatsc_s,iatsc_e - - - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) - dsci_inv=dsc_inv(itypi) -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) - IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN - ind=ind+1 - itypj=itype(j) - dscj_inv=dsc_inv(itypj) - sig0ij=sigma(itypi,itypj) - chi1=chi(itypi,itypj) - chi2=chi(itypj,itypi) - chi12=chi1*chi2 - chip1=chip(itypi) - chip2=chip(itypj) - chip12=chip1*chip2 - alf1=alp(itypi) - alf2=alp(itypj) - alf12=0.5D0*(alf1+alf2) -C For diagnostics only!!! -c chi1=0.0D0 -c chi2=0.0D0 -c chi12=0.0D0 -c chip1=0.0D0 -c chip2=0.0D0 -c chip12=0.0D0 -c alf1=0.0D0 -c alf2=0.0D0 -c alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) -C Calculate angle-dependent terms of energy and contributions to their -C derivatives. - call sc_angular - sigsq=1.0D0/sigsq - sig=sig0ij*dsqrt(sigsq) - rij_shift=1.0D0/rij-sig+sig0ij -C I hate to put IF's in the loops, but here don't have another choice!!!! - if (rij_shift.le.0.0D0) then - evdw=1.0D20 -cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) - return - endif - sigder=-sig*sigsq -c--------------------------------------------------------------- - rij_shift=1.0D0/rij_shift - fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') -cd & restyp(itypi),i,restyp(itypj),j, -cd & epsi,sigm,chi1,chi2,chip1,chip2, -cd & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, -cd & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, -cd & evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij - -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad - ENDIF - enddo ! j - enddo ! iint - enddo ! i - end -C----------------------------------------------------------------------------- diff --git a/source/unres/src_MIN/sumsld.f b/source/unres/src_MIN/sumsld.f deleted file mode 100644 index 1ce7b78..0000000 --- a/source/unres/src_MIN/sumsld.f +++ /dev/null @@ -1,1446 +0,0 @@ - subroutine sumsl(n, d, x, calcf, calcg, iv, liv, lv, v, - 1 uiparm, urparm, ufparm) -c -c *** minimize general unconstrained objective function using *** -c *** analytic gradient and hessian approx. from secant update *** -c - integer n, liv, lv - integer iv(liv), uiparm(1) - double precision d(n), x(n), v(lv), urparm(1) -c dimension v(71 + n*(n+15)/2), uiparm(*), urparm(*) - external calcf, calcg, ufparm -c -c *** purpose *** -c -c this routine interacts with subroutine sumit in an attempt -c to find an n-vector x* that minimizes the (unconstrained) -c objective function computed by calcf. (often the x* found is -c a local minimizer rather than a global one.) -c -c-------------------------- parameter usage -------------------------- -c -c n........ (input) the number of variables on which f depends, i.e., -c the number of components in x. -c d........ (input/output) a scale vector such that d(i)*x(i), -c i = 1,2,...,n, are all in comparable units. -c d can strongly affect the behavior of sumsl. -c finding the best choice of d is generally a trial- -c and-error process. choosing d so that d(i)*x(i) -c has about the same value for all i often works well. -c the defaults provided by subroutine deflt (see i -c below) require the caller to supply d. -c x........ (input/output) before (initially) calling sumsl, the call- -c er should set x to an initial guess at x*. when -c sumsl returns, x contains the best point so far -c found, i.e., the one that gives the least value so -c far seen for f(x). -c calcf.... (input) a subroutine that, given x, computes f(x). calcf -c must be declared external in the calling program. -c it is invoked by -c call calcf(n, x, nf, f, uiparm, urparm, ufparm) -c when calcf is called, nf is the invocation -c count for calcf. nf is included for possible use -c with calcg. if x is out of bounds (e.g., if it -c would cause overflow in computing f(x)), then calcf -c should set nf to 0. this will cause a shorter step -c to be attempted. (if x is in bounds, then calcf -c should not change nf.) the other parameters are as -c described above and below. calcf should not change -c n, p, or x. -c calcg.... (input) a subroutine that, given x, computes g(x), the gra- -c dient of f at x. calcg must be declared external in -c the calling program. it is invoked by -c call calcg(n, x, nf, g, uiparm, urparm, ufaprm) -c when calcg is called, nf is the invocation -c count for calcf at the time f(x) was evaluated. the -c x passed to calcg is usually the one passed to calcf -c on either its most recent invocation or the one -c prior to it. if calcf saves intermediate results -c for use by calcg, then it is possible to tell from -c nf whether they are valid for the current x (or -c which copy is valid if two copies are kept). if g -c cannot be computed at x, then calcg should set nf to -c 0. in this case, sumsl will return with iv(1) = 65. -c (if g can be computed at x, then calcg should not -c changed nf.) the other parameters to calcg are as -c described above and below. calcg should not change -c n or x. -c iv....... (input/output) an integer value array of length liv (see -c below) that helps control the sumsl algorithm and -c that is used to store various intermediate quanti- -c ties. of particular interest are the initialization/ -c return code iv(1) and the entries in iv that control -c printing and limit the number of iterations and func- -c tion evaluations. see the section on iv input -c values below. -c liv...... (input) length of iv array. must be at least 60. if li -c is too small, then sumsl returns with iv(1) = 15. -c when sumsl returns, the smallest allowed value of -c liv is stored in iv(lastiv) -- see the section on -c iv output values below. (this is intended for use -c with extensions of sumsl that handle constraints.) -c lv....... (input) length of v array. must be at least 71+n*(n+15)/2. -c (at least 77+n*(n+17)/2 for smsno, at least -c 78+n*(n+12) for humsl). if lv is too small, then -c sumsl returns with iv(1) = 16. when sumsl returns, -c the smallest allowed value of lv is stored in -c iv(lastv) -- see the section on iv output values -c below. -c v........ (input/output) a floating-point value array of length l -c (see below) that helps control the sumsl algorithm -c and that is used to store various intermediate -c quantities. of particular interest are the entries -c in v that limit the length of the first step -c attempted (lmax0) and specify convergence tolerances -c (afctol, lmaxs, rfctol, sctol, xctol, xftol). -c uiparm... (input) user integer parameter array passed without change -c to calcf and calcg. -c urparm... (input) user floating-point parameter array passed without -c change to calcf and calcg. -c ufparm... (input) user external subroutine or function passed without -c change to calcf and calcg. -c -c *** iv input values (from subroutine deflt) *** -c -c iv(1)... on input, iv(1) should have a value between 0 and 14...... -c 0 and 12 mean this is a fresh start. 0 means that -c deflt(2, iv, liv, lv, v) -c is to be called to provide all default values to iv and -c v. 12 (the value that deflt assigns to iv(1)) means the -c caller has already called deflt and has possibly changed -c some iv and/or v entries to non-default values. -c 13 means deflt has been called and that sumsl (and -c sumit) should only do their storage allocation. that is, -c they should set the output components of iv that tell -c where various subarrays arrays of v begin, such as iv(g) -c (and, for humsl and humit only, iv(dtol)), and return. -c 14 means that a storage has been allocated (by a call -c with iv(1) = 13) and that the algorithm should be -c started. when called with iv(1) = 13, sumsl returns -c iv(1) = 14 unless liv or lv is too small (or n is not -c positive). default = 12. -c iv(inith).... iv(25) tells whether the hessian approximation h should -c be initialized. 1 (the default) means sumit should -c initialize h to the diagonal matrix whose i-th diagonal -c element is d(i)**2. 0 means the caller has supplied a -c cholesky factor l of the initial hessian approximation -c h = l*(l**t) in v, starting at v(iv(lmat)) = v(iv(42)) -c (and stored compactly by rows). note that iv(lmat) may -c be initialized by calling sumsl with iv(1) = 13 (see -c the iv(1) discussion above). default = 1. -c iv(mxfcal)... iv(17) gives the maximum number of function evaluations -c (calls on calcf) allowed. if this number does not suf- -c fice, then sumsl returns with iv(1) = 9. default = 200. -c iv(mxiter)... iv(18) gives the maximum number of iterations allowed. -c it also indirectly limits the number of gradient evalua- -c tions (calls on calcg) to iv(mxiter) + 1. if iv(mxiter) -c iterations do not suffice, then sumsl returns with -c iv(1) = 10. default = 150. -c iv(outlev)... iv(19) controls the number and length of iteration sum- -c mary lines printed (by itsum). iv(outlev) = 0 means do -c not print any summary lines. otherwise, print a summary -c line after each abs(iv(outlev)) iterations. if iv(outlev) -c is positive, then summary lines of length 78 (plus carri- -c age control) are printed, including the following... the -c iteration and function evaluation counts, f = the current -c function value, relative difference in function values -c achieved by the latest step (i.e., reldf = (f0-v(f))/f01, -c where f01 is the maximum of abs(v(f)) and abs(v(f0)) and -c v(f0) is the function value from the previous itera- -c tion), the relative function reduction predicted for the -c step just taken (i.e., preldf = v(preduc) / f01, where -c v(preduc) is described below), the scaled relative change -c in x (see v(reldx) below), the step parameter for the -c step just taken (stppar = 0 means a full newton step, -c between 0 and 1 means a relaxed newton step, between 1 -c and 2 means a double dogleg step, greater than 2 means -c a scaled down cauchy step -- see subroutine dbldog), the -c 2-norm of the scale vector d times the step just taken -c (see v(dstnrm) below), and npreldf, i.e., -c v(nreduc)/f01, where v(nreduc) is described below -- if -c npreldf is positive, then it is the relative function -c reduction predicted for a newton step (one with -c stppar = 0). if npreldf is negative, then it is the -c negative of the relative function reduction predicted -c for a step computed with step bound v(lmaxs) for use in -c testing for singular convergence. -c if iv(outlev) is negative, then lines of length 50 -c are printed, including only the first 6 items listed -c above (through reldx). -c default = 1. -c iv(parprt)... iv(20) = 1 means print any nondefault v values on a -c fresh start or any changed v values on a restart. -c iv(parprt) = 0 means skip this printing. default = 1. -c iv(prunit)... iv(21) is the output unit number on which all printing -c is done. iv(prunit) = 0 means suppress all printing. -c default = standard output unit (unit 6 on most systems). -c iv(solprt)... iv(22) = 1 means print out the value of x returned (as -c well as the gradient and the scale vector d). -c iv(solprt) = 0 means skip this printing. default = 1. -c iv(statpr)... iv(23) = 1 means print summary statistics upon return- -c ing. these consist of the function value, the scaled -c relative change in x caused by the most recent step (see -c v(reldx) below), the number of function and gradient -c evaluations (calls on calcf and calcg), and the relative -c function reductions predicted for the last step taken and -c for a newton step (or perhaps a step bounded by v(lmaxs) -c -- see the descriptions of preldf and npreldf under -c iv(outlev) above). -c iv(statpr) = 0 means skip this printing. -c iv(statpr) = -1 means skip this printing as well as that -c of the one-line termination reason message. default = 1. -c iv(x0prt).... iv(24) = 1 means print the initial x and scale vector d -c (on a fresh start only). iv(x0prt) = 0 means skip this -c printing. default = 1. -c -c *** (selected) iv output values *** -c -c iv(1)........ on output, iv(1) is a return code.... -c 3 = x-convergence. the scaled relative difference (see -c v(reldx)) between the current parameter vector x and -c a locally optimal parameter vector is very likely at -c most v(xctol). -c 4 = relative function convergence. the relative differ- -c ence between the current function value and its lo- -c cally optimal value is very likely at most v(rfctol). -c 5 = both x- and relative function convergence (i.e., the -c conditions for iv(1) = 3 and iv(1) = 4 both hold). -c 6 = absolute function convergence. the current function -c value is at most v(afctol) in absolute value. -c 7 = singular convergence. the hessian near the current -c iterate appears to be singular or nearly so, and a -c step of length at most v(lmaxs) is unlikely to yield -c a relative function decrease of more than v(sctol). -c 8 = false convergence. the iterates appear to be converg- -c ing to a noncritical point. this may mean that the -c convergence tolerances (v(afctol), v(rfctol), -c v(xctol)) are too small for the accuracy to which -c the function and gradient are being computed, that -c there is an error in computing the gradient, or that -c the function or gradient is discontinuous near x. -c 9 = function evaluation limit reached without other con- -c vergence (see iv(mxfcal)). -c 10 = iteration limit reached without other convergence -c (see iv(mxiter)). -c 11 = stopx returned .true. (external interrupt). see the -c usage notes below. -c 14 = storage has been allocated (after a call with -c iv(1) = 13). -c 17 = restart attempted with n changed. -c 18 = d has a negative component and iv(dtype) .le. 0. -c 19...43 = v(iv(1)) is out of range. -c 63 = f(x) cannot be computed at the initial x. -c 64 = bad parameters passed to assess (which should not -c occur). -c 65 = the gradient could not be computed at x (see calcg -c above). -c 67 = bad first parameter to deflt. -c 80 = iv(1) was out of range. -c 81 = n is not positive. -c iv(g)........ iv(28) is the starting subscript in v of the current -c gradient vector (the one corresponding to x). -c iv(lastiv)... iv(44) is the least acceptable value of liv. (it is -c only set if liv is at least 44.) -c iv(lastv).... iv(45) is the least acceptable value of lv. (it is -c only set if liv is large enough, at least iv(lastiv).) -c iv(nfcall)... iv(6) is the number of calls so far made on calcf (i.e., -c function evaluations). -c iv(ngcall)... iv(30) is the number of gradient evaluations (calls on -c calcg). -c iv(niter).... iv(31) is the number of iterations performed. -c -c *** (selected) v input values (from subroutine deflt) *** -c -c v(bias)..... v(43) is the bias parameter used in subroutine dbldog -- -c see that subroutine for details. default = 0.8. -c v(afctol)... v(31) is the absolute function convergence tolerance. -c if sumsl finds a point where the function value is less -c than v(afctol) in absolute value, and if sumsl does not -c return with iv(1) = 3, 4, or 5, then it returns with -c iv(1) = 6. this test can be turned off by setting -c v(afctol) to zero. default = max(10**-20, machep**2), -c where machep is the unit roundoff. -c v(dinit).... v(38), if nonnegative, is the value to which the scale -c vector d is initialized. default = -1. -c v(lmax0).... v(35) gives the maximum 2-norm allowed for d times the -c very first step that sumsl attempts. this parameter can -c markedly affect the performance of sumsl. -c v(lmaxs).... v(36) is used in testing for singular convergence -- if -c the function reduction predicted for a step of length -c bounded by v(lmaxs) is at most v(sctol) * abs(f0), where -c f0 is the function value at the start of the current -c iteration, and if sumsl does not return with iv(1) = 3, -c 4, 5, or 6, then it returns with iv(1) = 7. default = 1. -c v(rfctol)... v(32) is the relative function convergence tolerance. -c if the current model predicts a maximum possible function -c reduction (see v(nreduc)) of at most v(rfctol)*abs(f0) -c at the start of the current iteration, where f0 is the -c then current function value, and if the last step attempt- -c ed achieved no more than twice the predicted function -c decrease, then sumsl returns with iv(1) = 4 (or 5). -c default = max(10**-10, machep**(2/3)), where machep is -c the unit roundoff. -c v(sctol).... v(37) is the singular convergence tolerance -- see the -c description of v(lmaxs) above. -c v(tuner1)... v(26) helps decide when to check for false convergence. -c this is done if the actual function decrease from the -c current step is no more than v(tuner1) times its predict- -c ed value. default = 0.1. -c v(xctol).... v(33) is the x-convergence tolerance. if a newton step -c (see v(nreduc)) is tried that has v(reldx) .le. v(xctol) -c and if this step yields at most twice the predicted func- -c tion decrease, then sumsl returns with iv(1) = 3 (or 5). -c (see the description of v(reldx) below.) -c default = machep**0.5, where machep is the unit roundoff. -c v(xftol).... v(34) is the false convergence tolerance. if a step is -c tried that gives no more than v(tuner1) times the predict- -c ed function decrease and that has v(reldx) .le. v(xftol), -c and if sumsl does not return with iv(1) = 3, 4, 5, 6, or -c 7, then it returns with iv(1) = 8. (see the description -c of v(reldx) below.) default = 100*machep, where -c machep is the unit roundoff. -c v(*)........ deflt supplies to v a number of tuning constants, with -c which it should ordinarily be unnecessary to tinker. see -c section 17 of version 2.2 of the nl2sol usage summary -c (i.e., the appendix to ref. 1) for details on v(i), -c i = decfac, incfac, phmnfc, phmxfc, rdfcmn, rdfcmx, -c tuner2, tuner3, tuner4, tuner5. -c -c *** (selected) v output values *** -c -c v(dgnorm)... v(1) is the 2-norm of (diag(d)**-1)*g, where g is the -c most recently computed gradient. -c v(dstnrm)... v(2) is the 2-norm of diag(d)*step, where step is the -c current step. -c v(f)........ v(10) is the current function value. -c v(f0)....... v(13) is the function value at the start of the current -c iteration. -c v(nreduc)... v(6), if positive, is the maximum function reduction -c possible according to the current model, i.e., the func- -c tion reduction predicted for a newton step (i.e., -c step = -h**-1 * g, where g is the current gradient and -c h is the current hessian approximation). -c if v(nreduc) is negative, then it is the negative of -c the function reduction predicted for a step computed with -c a step bound of v(lmaxs) for use in testing for singular -c convergence. -c v(preduc)... v(7) is the function reduction predicted (by the current -c quadratic model) for the current step. this (divided by -c v(f0)) is used in testing for relative function -c convergence. -c v(reldx).... v(17) is the scaled relative change in x caused by the -c current step, computed as -c max(abs(d(i)*(x(i)-x0(i)), 1 .le. i .le. p) / -c max(d(i)*(abs(x(i))+abs(x0(i))), 1 .le. i .le. p), -c where x = x0 + step. -c -c------------------------------- notes ------------------------------- -c -c *** algorithm notes *** -c -c this routine uses a hessian approximation computed from the -c bfgs update (see ref 3). only a cholesky factor of the hessian -c approximation is stored, and this is updated using ideas from -c ref. 4. steps are computed by the double dogleg scheme described -c in ref. 2. the steps are assessed as in ref. 1. -c -c *** usage notes *** -c -c after a return with iv(1) .le. 11, it is possible to restart, -c i.e., to change some of the iv and v input values described above -c and continue the algorithm from the point where it was interrupt- -c ed. iv(1) should not be changed, nor should any entries of i -c and v other than the input values (those supplied by deflt). -c those who do not wish to write a calcg which computes the -c gradient analytically should call smsno rather than sumsl. -c smsno uses finite differences to compute an approximate gradient. -c those who would prefer to provide f and g (the function and -c gradient) by reverse communication rather than by writing subrou- -c tines calcf and calcg may call on sumit directly. see the com- -c ments at the beginning of sumit. -c those who use sumsl interactively may wish to supply their -c own stopx function, which should return .true. if the break key -c has been pressed since stopx was last invoked. this makes it -c possible to externally interrupt sumsl (which will return with -c iv(1) = 11 if stopx returns .true.). -c storage for g is allocated at the end of v. thus the caller -c may make v longer than specified above and may allow calcg to use -c elements of g beyond the first n as scratch storage. -c -c *** portability notes *** -c -c the sumsl distribution tape contains both single- and double- -c precision versions of the sumsl source code, so it should be un- -c necessary to change precisions. -c only the functions imdcon and rmdcon contain machine-dependent -c constants. to change from one machine to another, it should -c suffice to change the (few) relevant lines in these functions. -c intrinsic functions are explicitly declared. on certain com- -c puters (e.g. univac), it may be necessary to comment out these -c declarations. so that this may be done automatically by a simple -c program, such declarations are preceded by a comment having c/+ -c in columns 1-3 and blanks in columns 4-72 and are followed by -c a comment having c/ in columns 1 and 2 and blanks in columns 3-72. -c the sumsl source code is expressed in 1966 ansi standard -c fortran. it may be converted to fortran 77 by commenting out all -c lines that fall between a line having c/6 in columns 1-3 and a -c line having c/7 in columns 1-3 and by removing (i.e., replacing -c by a blank) the c in column 1 of the lines that follow the c/7 -c line and precede a line having c/ in columns 1-2 and blanks in -c columns 3-72. these changes convert some data statements into -c parameter statements, convert some variables from real to -c character*4, and make the data statements that initialize these -c variables use character strings delimited by primes instead -c of hollerith constants. (such variables and data statements -c appear only in modules itsum and parck. parameter statements -c appear nearly everywhere.) these changes also add save state- -c ments for variables given machine-dependent constants by rmdcon. -c -c *** references *** -c -c 1. dennis, j.e., gay, d.m., and welsch, r.e. (1981), algorithm 573 -- -c an adaptive nonlinear least-squares algorithm, acm trans. -c math. software 7, pp. 369-383. -c -c 2. dennis, j.e., and mei, h.h.w. (1979), two new unconstrained opti- -c mization algorithms which use function and gradient -c values, j. optim. theory applic. 28, pp. 453-482. -c -c 3. dennis, j.e., and more, j.j. (1977), quasi-newton methods, motiva- -c tion and theory, siam rev. 19, pp. 46-89. -c -c 4. goldfarb, d. (1976), factorized variable metric methods for uncon- -c strained optimization, math. comput. 30, pp. 796-811. -c -c *** general *** -c -c coded by david m. gay (winter 1980). revised summer 1982. -c this subroutine was written in connection with research -c supported in part by the national science foundation under -c grants mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, -c and mcs-7906671. -c. -c -c---------------------------- declarations --------------------------- -c - external deflt, sumit -c -c deflt... supplies default iv and v input components. -c sumit... reverse-communication routine that carries out sumsl algo- -c rithm. -c - integer g1, iv1, nf - double precision f -c -c *** subscripts for iv *** -c - integer nextv, nfcall, nfgcal, g, toobig, vneed -c -c/6 -c data nextv/47/, nfcall/6/, nfgcal/7/, g/28/, toobig/2/, vneed/4/ -c/7 - parameter (nextv=47, nfcall=6, nfgcal=7, g=28, toobig=2, vneed=4) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - iv1 = iv(1) - if (iv1 .eq. 12 .or. iv1 .eq. 13) iv(vneed) = iv(vneed) + n - if (iv1 .eq. 14) go to 10 - if (iv1 .gt. 2 .and. iv1 .lt. 12) go to 10 - g1 = 1 - if (iv1 .eq. 12) iv(1) = 13 - go to 20 -c - 10 g1 = iv(g) -c - 20 call sumit(d, f, v(g1), iv, liv, lv, n, v, x) - if (iv(1) - 2) 30, 40, 50 -c - 30 nf = iv(nfcall) - call calcf(n, x, nf, f, uiparm, urparm, ufparm) - if (nf .le. 0) iv(toobig) = 1 - go to 20 -c - 40 call calcg(n, x, iv(nfgcal), v(g1), uiparm, urparm, ufparm) - go to 20 -c - 50 if (iv(1) .ne. 14) go to 999 -c -c *** storage allocation -c - iv(g) = iv(nextv) - iv(nextv) = iv(g) + n - if (iv1 .ne. 13) go to 10 -c - 999 return -c *** last card of sumsl follows *** - end - subroutine sumit(d, fx, g, iv, liv, lv, n, v, x) -c -c *** carry out sumsl (unconstrained minimization) iterations, using -c *** double-dogleg/bfgs steps. -c -c *** parameter declarations *** -c - integer liv, lv, n - integer iv(liv) - double precision d(n), fx, g(n), v(lv), x(n) -c -c-------------------------- parameter usage -------------------------- -c -c d.... scale vector. -c fx... function value. -c g.... gradient vector. -c iv... integer value array. -c liv.. length of iv (at least 60). -c lv... length of v (at least 71 + n*(n+13)/2). -c n.... number of variables (components in x and g). -c v.... floating-point value array. -c x.... vector of parameters to be optimized. -c -c *** discussion *** -c -c parameters iv, n, v, and x are the same as the corresponding -c ones to sumsl (which see), except that v can be shorter (since -c the part of v that sumsl uses for storing g is not needed). -c moreover, compared with sumsl, iv(1) may have the two additional -c output values 1 and 2, which are explained below, as is the use -c of iv(toobig) and iv(nfgcal). the value iv(g), which is an -c output value from sumsl (and smsno), is not referenced by -c sumit or the subroutines it calls. -c fx and g need not have been initialized when sumit is called -c with iv(1) = 12, 13, or 14. -c -c iv(1) = 1 means the caller should set fx to f(x), the function value -c at x, and call sumit again, having changed none of the -c other parameters. an exception occurs if f(x) cannot be -c (e.g. if overflow would occur), which may happen because -c of an oversized step. in this case the caller should set -c iv(toobig) = iv(2) to 1, which will cause sumit to ig- -c nore fx and try a smaller step. the parameter nf that -c sumsl passes to calcf (for possible use by calcg) is a -c copy of iv(nfcall) = iv(6). -c iv(1) = 2 means the caller should set g to g(x), the gradient vector -c of f at x, and call sumit again, having changed none of -c the other parameters except possibly the scale vector d -c when iv(dtype) = 0. the parameter nf that sumsl passes -c to calcg is iv(nfgcal) = iv(7). if g(x) cannot be -c evaluated, then the caller may set iv(nfgcal) to 0, in -c which case sumit will return with iv(1) = 65. -c. -c *** general *** -c -c coded by david m. gay (december 1979). revised sept. 1982. -c this subroutine was written in connection with research supported -c in part by the national science foundation under grants -c mcs-7600324 and mcs-7906671. -c -c (see sumsl for references.) -c -c+++++++++++++++++++++++++++ declarations ++++++++++++++++++++++++++++ -c -c *** local variables *** -c - integer dg1, dummy, g01, i, k, l, lstgst, nwtst1, step1, - 1 temp1, w, x01, z - double precision t -c -c *** constants *** -c - double precision half, negone, one, onep2, zero -c -c *** no intrinsic functions *** -c -c *** external functions and subroutines *** -c - external assst, dbdog, deflt, dotprd, itsum, litvmu, livmul, - 1 ltvmul, lupdat, lvmul, parck, reldst, stopx, vaxpy, - 2 vcopy, vscopy, vvmulp, v2norm, wzbfgs - logical stopx - double precision dotprd, reldst, v2norm -c -c assst.... assesses candidate step. -c dbdog.... computes double-dogleg (candidate) step. -c deflt.... supplies default iv and v input components. -c dotprd... returns inner product of two vectors. -c itsum.... prints iteration summary and info on initial and final x. -c litvmu... multiplies inverse transpose of lower triangle times vector. -c livmul... multiplies inverse of lower triangle times vector. -c ltvmul... multiplies transpose of lower triangle times vector. -c lupdt.... updates cholesky factor of hessian approximation. -c lvmul.... multiplies lower triangle times vector. -c parck.... checks validity of input iv and v values. -c reldst... computes v(reldx) = relative step size. -c stopx.... returns .true. if the break key has been pressed. -c vaxpy.... computes scalar times one vector plus another. -c vcopy.... copies one vector to another. -c vscopy... sets all elements of a vector to a scalar. -c vvmulp... multiplies vector by vector raised to power (componentwise). -c v2norm... returns the 2-norm of a vector. -c wzbfgs... computes w and z for lupdat corresponding to bfgs update. -c -c *** subscripts for iv and v *** -c - integer afctol - integer cnvcod, dg, dgnorm, dinit, dstnrm, dst0, f, f0, fdif, - 1 gthg, gtstep, g0, incfac, inith, irc, kagqt, lmat, lmax0, - 2 lmaxs, mode, model, mxfcal, mxiter, nextv, nfcall, nfgcal, - 3 ngcall, niter, nreduc, nwtstp, preduc, radfac, radinc, - 4 radius, rad0, reldx, restor, step, stglim, stlstg, toobig, - 5 tuner4, tuner5, vneed, xirc, x0 -c -c *** iv subscript values *** -c -c/6 -c data cnvcod/55/, dg/37/, g0/48/, inith/25/, irc/29/, kagqt/33/, -c 1 mode/35/, model/5/, mxfcal/17/, mxiter/18/, nfcall/6/, -c 2 nfgcal/7/, ngcall/30/, niter/31/, nwtstp/34/, radinc/8/, -c 3 restor/9/, step/40/, stglim/11/, stlstg/41/, toobig/2/, -c 4 vneed/4/, xirc/13/, x0/43/ -c/7 - parameter (cnvcod=55, dg=37, g0=48, inith=25, irc=29, kagqt=33, - 1 mode=35, model=5, mxfcal=17, mxiter=18, nfcall=6, - 2 nfgcal=7, ngcall=30, niter=31, nwtstp=34, radinc=8, - 3 restor=9, step=40, stglim=11, stlstg=41, toobig=2, - 4 vneed=4, xirc=13, x0=43) -c/ -c -c *** v subscript values *** -c -c/6 -c data afctol/31/ -c data dgnorm/1/, dinit/38/, dstnrm/2/, dst0/3/, f/10/, f0/13/, -c 1 fdif/11/, gthg/44/, gtstep/4/, incfac/23/, lmat/42/, -c 2 lmax0/35/, lmaxs/36/, nextv/47/, nreduc/6/, preduc/7/, -c 3 radfac/16/, radius/8/, rad0/9/, reldx/17/, tuner4/29/, -c 4 tuner5/30/ -c/7 - parameter (afctol=31) - parameter (dgnorm=1, dinit=38, dstnrm=2, dst0=3, f=10, f0=13, - 1 fdif=11, gthg=44, gtstep=4, incfac=23, lmat=42, - 2 lmax0=35, lmaxs=36, nextv=47, nreduc=6, preduc=7, - 3 radfac=16, radius=8, rad0=9, reldx=17, tuner4=29, - 4 tuner5=30) -c/ -c -c/6 -c data half/0.5d+0/, negone/-1.d+0/, one/1.d+0/, onep2/1.2d+0/, -c 1 zero/0.d+0/ -c/7 - parameter (half=0.5d+0, negone=-1.d+0, one=1.d+0, onep2=1.2d+0, - 1 zero=0.d+0) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c -C Following SAVE statement inserted. - save l - i = iv(1) - if (i .eq. 1) go to 50 - if (i .eq. 2) go to 60 -c -c *** check validity of iv and v input values *** -c - if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v) - if (iv(1) .eq. 12 .or. iv(1) .eq. 13) - 1 iv(vneed) = iv(vneed) + n*(n+13)/2 - call parck(2, d, iv, liv, lv, n, v) - i = iv(1) - 2 - if (i .gt. 12) go to 999 - go to (180, 180, 180, 180, 180, 180, 120, 90, 120, 10, 10, 20), i -c -c *** storage allocation *** -c -10 l = iv(lmat) - iv(x0) = l + n*(n+1)/2 - iv(step) = iv(x0) + n - iv(stlstg) = iv(step) + n - iv(g0) = iv(stlstg) + n - iv(nwtstp) = iv(g0) + n - iv(dg) = iv(nwtstp) + n - iv(nextv) = iv(dg) + n - if (iv(1) .ne. 13) go to 20 - iv(1) = 14 - go to 999 -c -c *** initialization *** -c - 20 iv(niter) = 0 - iv(nfcall) = 1 - iv(ngcall) = 1 - iv(nfgcal) = 1 - iv(mode) = -1 - iv(model) = 1 - iv(stglim) = 1 - iv(toobig) = 0 - iv(cnvcod) = 0 - iv(radinc) = 0 - v(rad0) = zero - if (v(dinit) .ge. zero) call vscopy(n, d, v(dinit)) - if (iv(inith) .ne. 1) go to 40 -c -c *** set the initial hessian approximation to diag(d)**-2 *** -c - l = iv(lmat) - call vscopy(n*(n+1)/2, v(l), zero) - k = l - 1 - do 30 i = 1, n - k = k + i - t = d(i) - if (t .le. zero) t = one - v(k) = t - 30 continue -c -c *** compute initial function value *** -c - 40 iv(1) = 1 - go to 999 -c - 50 v(f) = fx - if (iv(mode) .ge. 0) go to 180 - iv(1) = 2 - if (iv(toobig) .eq. 0) go to 999 - iv(1) = 63 - go to 300 -c -c *** make sure gradient could be computed *** -c - 60 if (iv(nfgcal) .ne. 0) go to 70 - iv(1) = 65 - go to 300 -c - 70 dg1 = iv(dg) - call vvmulp(n, v(dg1), g, d, -1) - v(dgnorm) = v2norm(n, v(dg1)) -c -c *** test norm of gradient *** -c - if (v(dgnorm) .gt. v(afctol)) go to 75 - iv(irc) = 10 - iv(cnvcod) = iv(irc) - 4 -c - 75 if (iv(cnvcod) .ne. 0) go to 290 - if (iv(mode) .eq. 0) go to 250 -c -c *** allow first step to have scaled 2-norm at most v(lmax0) *** -c - v(radius) = v(lmax0) -c - iv(mode) = 0 -c -c -c----------------------------- main loop ----------------------------- -c -c -c *** print iteration summary, check iteration limit *** -c - 80 call itsum(d, g, iv, liv, lv, n, v, x) - 90 k = iv(niter) - if (k .lt. iv(mxiter)) go to 100 - iv(1) = 10 - go to 300 -c -c *** update radius *** -c - 100 iv(niter) = k + 1 - if(k.gt.0)v(radius) = v(radfac) * v(dstnrm) -c -c *** initialize for start of next iteration *** -c - g01 = iv(g0) - x01 = iv(x0) - v(f0) = v(f) - iv(irc) = 4 - iv(kagqt) = -1 -c -c *** copy x to x0, g to g0 *** -c - call vcopy(n, v(x01), x) - call vcopy(n, v(g01), g) -c -c *** check stopx and function evaluation limit *** -c -C AL 4/30/95 - dummy=iv(nfcall) - 110 if (.not. stopx(dummy)) go to 130 - iv(1) = 11 - go to 140 -c -c *** come here when restarting after func. eval. limit or stopx. -c - 120 if (v(f) .ge. v(f0)) go to 130 - v(radfac) = one - k = iv(niter) - go to 100 -c - 130 if (iv(nfcall) .lt. iv(mxfcal)) go to 150 - iv(1) = 9 - 140 if (v(f) .ge. v(f0)) go to 300 -c -c *** in case of stopx or function evaluation limit with -c *** improved v(f), evaluate the gradient at x. -c - iv(cnvcod) = iv(1) - go to 240 -c -c. . . . . . . . . . . . . compute candidate step . . . . . . . . . . -c - 150 step1 = iv(step) - dg1 = iv(dg) - nwtst1 = iv(nwtstp) - if (iv(kagqt) .ge. 0) go to 160 - l = iv(lmat) - call livmul(n, v(nwtst1), v(l), g) - v(nreduc) = half * dotprd(n, v(nwtst1), v(nwtst1)) - call litvmu(n, v(nwtst1), v(l), v(nwtst1)) - call vvmulp(n, v(step1), v(nwtst1), d, 1) - v(dst0) = v2norm(n, v(step1)) - call vvmulp(n, v(dg1), v(dg1), d, -1) - call ltvmul(n, v(step1), v(l), v(dg1)) - v(gthg) = v2norm(n, v(step1)) - iv(kagqt) = 0 - 160 call dbdog(v(dg1), lv, n, v(nwtst1), v(step1), v) - if (iv(irc) .eq. 6) go to 180 -c -c *** check whether evaluating f(x0 + step) looks worthwhile *** -c - if (v(dstnrm) .le. zero) go to 180 - if (iv(irc) .ne. 5) go to 170 - if (v(radfac) .le. one) go to 170 - if (v(preduc) .le. onep2 * v(fdif)) go to 180 -c -c *** compute f(x0 + step) *** -c - 170 x01 = iv(x0) - step1 = iv(step) - call vaxpy(n, x, one, v(step1), v(x01)) - iv(nfcall) = iv(nfcall) + 1 - iv(1) = 1 - iv(toobig) = 0 - go to 999 -c -c. . . . . . . . . . . . . assess candidate step . . . . . . . . . . . -c - 180 x01 = iv(x0) - v(reldx) = reldst(n, d, x, v(x01)) - call assst(iv, liv, lv, v) - step1 = iv(step) - lstgst = iv(stlstg) - if (iv(restor) .eq. 1) call vcopy(n, x, v(x01)) - if (iv(restor) .eq. 2) call vcopy(n, v(lstgst), v(step1)) - if (iv(restor) .ne. 3) go to 190 - call vcopy(n, v(step1), v(lstgst)) - call vaxpy(n, x, one, v(step1), v(x01)) - v(reldx) = reldst(n, d, x, v(x01)) -c - 190 k = iv(irc) - go to (200,230,230,230,200,210,220,220,220,220,220,220,280,250), k -c -c *** recompute step with changed radius *** -c - 200 v(radius) = v(radfac) * v(dstnrm) - go to 110 -c -c *** compute step of length v(lmaxs) for singular convergence test. -c - 210 v(radius) = v(lmaxs) - go to 150 -c -c *** convergence or false convergence *** -c - 220 iv(cnvcod) = k - 4 - if (v(f) .ge. v(f0)) go to 290 - if (iv(xirc) .eq. 14) go to 290 - iv(xirc) = 14 -c -c. . . . . . . . . . . . process acceptable step . . . . . . . . . . . -c - 230 if (iv(irc) .ne. 3) go to 240 - step1 = iv(step) - temp1 = iv(stlstg) -c -c *** set temp1 = hessian * step for use in gradient tests *** -c - l = iv(lmat) - call ltvmul(n, v(temp1), v(l), v(step1)) - call lvmul(n, v(temp1), v(l), v(temp1)) -c -c *** compute gradient *** -c - 240 iv(ngcall) = iv(ngcall) + 1 - iv(1) = 2 - go to 999 -c -c *** initializations -- g0 = g - g0, etc. *** -c - 250 g01 = iv(g0) - call vaxpy(n, v(g01), negone, v(g01), g) - step1 = iv(step) - temp1 = iv(stlstg) - if (iv(irc) .ne. 3) go to 270 -c -c *** set v(radfac) by gradient tests *** -c -c *** set temp1 = diag(d)**-1 * (hessian*step + (g(x0)-g(x))) *** -c - call vaxpy(n, v(temp1), negone, v(g01), v(temp1)) - call vvmulp(n, v(temp1), v(temp1), d, -1) -c -c *** do gradient tests *** -c - if (v2norm(n, v(temp1)) .le. v(dgnorm) * v(tuner4)) - 1 go to 260 - if (dotprd(n, g, v(step1)) - 1 .ge. v(gtstep) * v(tuner5)) go to 270 - 260 v(radfac) = v(incfac) -c -c *** update h, loop *** -c - 270 w = iv(nwtstp) - z = iv(x0) - l = iv(lmat) - call wzbfgs(v(l), n, v(step1), v(w), v(g01), v(z)) -c -c ** use the n-vectors starting at v(step1) and v(g01) for scratch.. - call lupdat(v(temp1), v(step1), v(l), v(g01), v(l), n, v(w), v(z)) - iv(1) = 2 - go to 80 -c -c. . . . . . . . . . . . . . misc. details . . . . . . . . . . . . . . -c -c *** bad parameters to assess *** -c - 280 iv(1) = 64 - go to 300 -c -c *** print summary of final iteration and other requested items *** -c - 290 iv(1) = iv(cnvcod) - iv(cnvcod) = 0 - 300 call itsum(d, g, iv, liv, lv, n, v, x) -c - 999 return -c -c *** last line of sumit follows *** - end - subroutine dbdog(dig, lv, n, nwtstp, step, v) -c -c *** compute double dogleg step *** -c -c *** parameter declarations *** -c - integer lv, n - double precision dig(n), nwtstp(n), step(n), v(lv) -c -c *** purpose *** -c -c this subroutine computes a candidate step (for use in an uncon- -c strained minimization code) by the double dogleg algorithm of -c dennis and mei (ref. 1), which is a variation on powell*s dogleg -c scheme (ref. 2, p. 95). -c -c-------------------------- parameter usage -------------------------- -c -c dig (input) diag(d)**-2 * g -- see algorithm notes. -c g (input) the current gradient vector. -c lv (input) length of v. -c n (input) number of components in dig, g, nwtstp, and step. -c nwtstp (input) negative newton step -- see algorithm notes. -c step (output) the computed step. -c v (i/o) values array, the following components of which are -c used here... -c v(bias) (input) bias for relaxed newton step, which is v(bias) of -c the way from the full newton to the fully relaxed newton -c step. recommended value = 0.8 . -c v(dgnorm) (input) 2-norm of diag(d)**-1 * g -- see algorithm notes. -c v(dstnrm) (output) 2-norm of diag(d) * step, which is v(radius) -c unless v(stppar) = 0 -- see algorithm notes. -c v(dst0) (input) 2-norm of diag(d) * nwtstp -- see algorithm notes. -c v(grdfac) (output) the coefficient of dig in the step returned -- -c step(i) = v(grdfac)*dig(i) + v(nwtfac)*nwtstp(i). -c v(gthg) (input) square-root of (dig**t) * (hessian) * dig -- see -c algorithm notes. -c v(gtstep) (output) inner product between g and step. -c v(nreduc) (output) function reduction predicted for the full newton -c step. -c v(nwtfac) (output) the coefficient of nwtstp in the step returned -- -c see v(grdfac) above. -c v(preduc) (output) function reduction predicted for the step returned. -c v(radius) (input) the trust region radius. d times the step returned -c has 2-norm v(radius) unless v(stppar) = 0. -c v(stppar) (output) code telling how step was computed... 0 means a -c full newton step. between 0 and 1 means v(stppar) of the -c way from the newton to the relaxed newton step. between -c 1 and 2 means a true double dogleg step, v(stppar) - 1 of -c the way from the relaxed newton to the cauchy step. -c greater than 2 means 1 / (v(stppar) - 1) times the cauchy -c step. -c -c------------------------------- notes ------------------------------- -c -c *** algorithm notes *** -c -c let g and h be the current gradient and hessian approxima- -c tion respectively and let d be the current scale vector. this -c routine assumes dig = diag(d)**-2 * g and nwtstp = h**-1 * g. -c the step computed is the same one would get by replacing g and h -c by diag(d)**-1 * g and diag(d)**-1 * h * diag(d)**-1, -c computing step, and translating step back to the original -c variables, i.e., premultiplying it by diag(d)**-1. -c -c *** references *** -c -c 1. dennis, j.e., and mei, h.h.w. (1979), two new unconstrained opti- -c mization algorithms which use function and gradient -c values, j. optim. theory applic. 28, pp. 453-482. -c 2. powell, m.j.d. (1970), a hybrid method for non-linear equations, -c in numerical methods for non-linear equations, edited by -c p. rabinowitz, gordon and breach, london. -c -c *** general *** -c -c coded by david m. gay. -c this subroutine was written in connection with research supported -c by the national science foundation under grants mcs-7600324 and -c mcs-7906671. -c -c------------------------ external quantities ------------------------ -c -c *** functions and subroutines called *** -c - external dotprd, v2norm - double precision dotprd, v2norm -c -c dotprd... returns inner product of two vectors. -c v2norm... returns 2-norm of a vector. -c -c *** intrinsic functions *** -c/+ - double precision dsqrt -c/ -c-------------------------- local variables -------------------------- -c - integer i - double precision cfact, cnorm, ctrnwt, ghinvg, femnsq, gnorm, - 1 nwtnrm, relax, rlambd, t, t1, t2 - double precision half, one, two, zero -c -c *** v subscripts *** -c - integer bias, dgnorm, dstnrm, dst0, grdfac, gthg, gtstep, - 1 nreduc, nwtfac, preduc, radius, stppar -c -c *** data initializations *** -c -c/6 -c data half/0.5d+0/, one/1.d+0/, two/2.d+0/, zero/0.d+0/ -c/7 - parameter (half=0.5d+0, one=1.d+0, two=2.d+0, zero=0.d+0) -c/ -c -c/6 -c data bias/43/, dgnorm/1/, dstnrm/2/, dst0/3/, grdfac/45/, -c 1 gthg/44/, gtstep/4/, nreduc/6/, nwtfac/46/, preduc/7/, -c 2 radius/8/, stppar/5/ -c/7 - parameter (bias=43, dgnorm=1, dstnrm=2, dst0=3, grdfac=45, - 1 gthg=44, gtstep=4, nreduc=6, nwtfac=46, preduc=7, - 2 radius=8, stppar=5) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - nwtnrm = v(dst0) - rlambd = one - if (nwtnrm .gt. zero) rlambd = v(radius) / nwtnrm - gnorm = v(dgnorm) - ghinvg = two * v(nreduc) - v(grdfac) = zero - v(nwtfac) = zero - if (rlambd .lt. one) go to 30 -c -c *** the newton step is inside the trust region *** -c - v(stppar) = zero - v(dstnrm) = nwtnrm - v(gtstep) = -ghinvg - v(preduc) = v(nreduc) - v(nwtfac) = -one - do 20 i = 1, n - 20 step(i) = -nwtstp(i) - go to 999 -c - 30 v(dstnrm) = v(radius) - cfact = (gnorm / v(gthg))**2 -c *** cauchy step = -cfact * g. - cnorm = gnorm * cfact - relax = one - v(bias) * (one - gnorm*cnorm/ghinvg) - if (rlambd .lt. relax) go to 50 -c -c *** step is between relaxed newton and full newton steps *** -c - v(stppar) = one - (rlambd - relax) / (one - relax) - t = -rlambd - v(gtstep) = t * ghinvg - v(preduc) = rlambd * (one - half*rlambd) * ghinvg - v(nwtfac) = t - do 40 i = 1, n - 40 step(i) = t * nwtstp(i) - go to 999 -c - 50 if (cnorm .lt. v(radius)) go to 70 -c -c *** the cauchy step lies outside the trust region -- -c *** step = scaled cauchy step *** -c - t = -v(radius) / gnorm - v(grdfac) = t - v(stppar) = one + cnorm / v(radius) - v(gtstep) = -v(radius) * gnorm - v(preduc) = v(radius)*(gnorm - half*v(radius)*(v(gthg)/gnorm)**2) - do 60 i = 1, n - 60 step(i) = t * dig(i) - go to 999 -c -c *** compute dogleg step between cauchy and relaxed newton *** -c *** femur = relaxed newton step minus cauchy step *** -c - 70 ctrnwt = cfact * relax * ghinvg / gnorm -c *** ctrnwt = inner prod. of cauchy and relaxed newton steps, -c *** scaled by gnorm**-1. - t1 = ctrnwt - gnorm*cfact**2 -c *** t1 = inner prod. of femur and cauchy step, scaled by -c *** gnorm**-1. - t2 = v(radius)*(v(radius)/gnorm) - gnorm*cfact**2 - t = relax * nwtnrm - femnsq = (t/gnorm)*t - ctrnwt - t1 -c *** femnsq = square of 2-norm of femur, scaled by gnorm**-1. - t = t2 / (t1 + dsqrt(t1**2 + femnsq*t2)) -c *** dogleg step = cauchy step + t * femur. - t1 = (t - one) * cfact - v(grdfac) = t1 - t2 = -t * relax - v(nwtfac) = t2 - v(stppar) = two - t - v(gtstep) = t1*gnorm**2 + t2*ghinvg - v(preduc) = -t1*gnorm * ((t2 + one)*gnorm) - 1 - t2 * (one + half*t2)*ghinvg - 2 - half * (v(gthg)*t1)**2 - do 80 i = 1, n - 80 step(i) = t1*dig(i) + t2*nwtstp(i) -c - 999 return -c *** last line of dbdog follows *** - end - subroutine ltvmul(n, x, l, y) -c -c *** compute x = (l**t)*y, where l is an n x n lower -c *** triangular matrix stored compactly by rows. x and y may -c *** occupy the same storage. *** -c - integer n -cal double precision x(n), l(1), y(n) - double precision x(n), l(n*(n+1)/2), y(n) -c dimension l(n*(n+1)/2) - integer i, ij, i0, j - double precision yi, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - i0 = 0 - do 20 i = 1, n - yi = y(i) - x(i) = zero - do 10 j = 1, i - ij = i0 + j - x(j) = x(j) + yi*l(ij) - 10 continue - i0 = i0 + i - 20 continue - 999 return -c *** last card of ltvmul follows *** - end - subroutine lupdat(beta, gamma, l, lambda, lplus, n, w, z) -c -c *** compute lplus = secant update of l *** -c -c *** parameter declarations *** -c - integer n -cal double precision beta(n), gamma(n), l(1), lambda(n), lplus(1), - double precision beta(n), gamma(n), l(n*(n+1)/2), lambda(n), - 1 lplus(n*(n+1)/2),w(n), z(n) -c dimension l(n*(n+1)/2), lplus(n*(n+1)/2) -c -c-------------------------- parameter usage -------------------------- -c -c beta = scratch vector. -c gamma = scratch vector. -c l (input) lower triangular matrix, stored rowwise. -c lambda = scratch vector. -c lplus (output) lower triangular matrix, stored rowwise, which may -c occupy the same storage as l. -c n (input) length of vector parameters and order of matrices. -c w (input, destroyed on output) right singular vector of rank 1 -c correction to l. -c z (input, destroyed on output) left singular vector of rank 1 -c correction to l. -c -c------------------------------- notes ------------------------------- -c -c *** application and usage restrictions *** -c -c this routine updates the cholesky factor l of a symmetric -c positive definite matrix to which a secant update is being -c applied -- it computes a cholesky factor lplus of -c l * (i + z*w**t) * (i + w*z**t) * l**t. it is assumed that w -c and z have been chosen so that the updated matrix is strictly -c positive definite. -c -c *** algorithm notes *** -c -c this code uses recurrence 3 of ref. 1 (with d(j) = 1 for all j) -c to compute lplus of the form l * (i + z*w**t) * q, where q -c is an orthogonal matrix that makes the result lower triangular. -c lplus may have some negative diagonal elements. -c -c *** references *** -c -c 1. goldfarb, d. (1976), factorized variable metric methods for uncon- -c strained optimization, math. comput. 30, pp. 796-811. -c -c *** general *** -c -c coded by david m. gay (fall 1979). -c this subroutine was written in connection with research supported -c by the national science foundation under grants mcs-7600324 and -c mcs-7906671. -c -c------------------------ external quantities ------------------------ -c -c *** intrinsic functions *** -c/+ - double precision dsqrt -c/ -c-------------------------- local variables -------------------------- -c - integer i, ij, j, jj, jp1, k, nm1, np1 - double precision a, b, bj, eta, gj, lj, lij, ljj, nu, s, theta, - 1 wj, zj - double precision one, zero -c -c *** data initializations *** -c -c/6 -c data one/1.d+0/, zero/0.d+0/ -c/7 - parameter (one=1.d+0, zero=0.d+0) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - nu = one - eta = zero - if (n .le. 1) go to 30 - nm1 = n - 1 -c -c *** temporarily store s(j) = sum over k = j+1 to n of w(k)**2 in -c *** lambda(j). -c - s = zero - do 10 i = 1, nm1 - j = n - i - s = s + w(j+1)**2 - lambda(j) = s - 10 continue -c -c *** compute lambda, gamma, and beta by goldfarb*s recurrence 3. -c - do 20 j = 1, nm1 - wj = w(j) - a = nu*z(j) - eta*wj - theta = one + a*wj - s = a*lambda(j) - lj = dsqrt(theta**2 + a*s) - if (theta .gt. zero) lj = -lj - lambda(j) = lj - b = theta*wj + s - gamma(j) = b * nu / lj - beta(j) = (a - b*eta) / lj - nu = -nu / lj - eta = -(eta + (a**2)/(theta - lj)) / lj - 20 continue - 30 lambda(n) = one + (nu*z(n) - eta*w(n))*w(n) -c -c *** update l, gradually overwriting w and z with l*w and l*z. -c - np1 = n + 1 - jj = n * (n + 1) / 2 - do 60 k = 1, n - j = np1 - k - lj = lambda(j) - ljj = l(jj) - lplus(jj) = lj * ljj - wj = w(j) - w(j) = ljj * wj - zj = z(j) - z(j) = ljj * zj - if (k .eq. 1) go to 50 - bj = beta(j) - gj = gamma(j) - ij = jj + j - jp1 = j + 1 - do 40 i = jp1, n - lij = l(ij) - lplus(ij) = lj*lij + bj*w(i) + gj*z(i) - w(i) = w(i) + lij*wj - z(i) = z(i) + lij*zj - ij = ij + i - 40 continue - 50 jj = jj - j - 60 continue -c - 999 return -c *** last card of lupdat follows *** - end - subroutine lvmul(n, x, l, y) -c -c *** compute x = l*y, where l is an n x n lower triangular -c *** matrix stored compactly by rows. x and y may occupy the same -c *** storage. *** -c - integer n -cal double precision x(n), l(1), y(n) - double precision x(n), l(n*(n+1)/2), y(n) -c dimension l(n*(n+1)/2) - integer i, ii, ij, i0, j, np1 - double precision t, zero -c/6 -c data zero/0.d+0/ -c/7 - parameter (zero=0.d+0) -c/ -c - np1 = n + 1 - i0 = n*(n+1)/2 - do 20 ii = 1, n - i = np1 - ii - i0 = i0 - i - t = zero - do 10 j = 1, i - ij = i0 + j - t = t + l(ij)*y(j) - 10 continue - x(i) = t - 20 continue - 999 return -c *** last card of lvmul follows *** - end - subroutine vvmulp(n, x, y, z, k) -c -c *** set x(i) = y(i) * z(i)**k, 1 .le. i .le. n (for k = 1 or -1) *** -c - integer n, k - double precision x(n), y(n), z(n) - integer i -c - if (k .ge. 0) go to 20 - do 10 i = 1, n - 10 x(i) = y(i) / z(i) - go to 999 -c - 20 do 30 i = 1, n - 30 x(i) = y(i) * z(i) - 999 return -c *** last card of vvmulp follows *** - end - subroutine wzbfgs (l, n, s, w, y, z) -c -c *** compute y and z for lupdat corresponding to bfgs update. -c - integer n -cal double precision l(1), s(n), w(n), y(n), z(n) - double precision l(n*(n+1)/2), s(n), w(n), y(n), z(n) -c dimension l(n*(n+1)/2) -c -c-------------------------- parameter usage -------------------------- -c -c l (i/o) cholesky factor of hessian, a lower triang. matrix stored -c compactly by rows. -c n (input) order of l and length of s, w, y, z. -c s (input) the step just taken. -c w (output) right singular vector of rank 1 correction to l. -c y (input) change in gradients corresponding to s. -c z (output) left singular vector of rank 1 correction to l. -c -c------------------------------- notes ------------------------------- -c -c *** algorithm notes *** -c -c when s is computed in certain ways, e.g. by gqtstp or -c dbldog, it is possible to save n**2/2 operations since (l**t)*s -c or l*(l**t)*s is then known. -c if the bfgs update to l*(l**t) would reduce its determinant to -c less than eps times its old value, then this routine in effect -c replaces y by theta*y + (1 - theta)*l*(l**t)*s, where theta -c (between 0 and 1) is chosen to make the reduction factor = eps. -c -c *** general *** -c -c coded by david m. gay (fall 1979). -c this subroutine was written in connection with research supported -c by the national science foundation under grants mcs-7600324 and -c mcs-7906671. -c -c------------------------ external quantities ------------------------ -c -c *** functions and subroutines called *** -c - external dotprd, livmul, ltvmul - double precision dotprd -c dotprd returns inner product of two vectors. -c livmul multiplies l**-1 times a vector. -c ltvmul multiplies l**t times a vector. -c -c *** intrinsic functions *** -c/+ - double precision dsqrt -c/ -c-------------------------- local variables -------------------------- -c - integer i - double precision cs, cy, eps, epsrt, one, shs, ys, theta -c -c *** data initializations *** -c -c/6 -c data eps/0.1d+0/, one/1.d+0/ -c/7 - parameter (eps=0.1d+0, one=1.d+0) -c/ -c -c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++ -c - call ltvmul(n, w, l, s) - shs = dotprd(n, w, w) - ys = dotprd(n, y, s) - if (ys .ge. eps*shs) go to 10 - theta = (one - eps) * shs / (shs - ys) - epsrt = dsqrt(eps) - cy = theta / (shs * epsrt) - cs = (one + (theta-one)/epsrt) / shs - go to 20 - 10 cy = one / (dsqrt(ys) * dsqrt(shs)) - cs = one / shs - 20 call livmul(n, z, l, y) - do 30 i = 1, n - 30 z(i) = cy * z(i) - cs * w(i) -c - 999 return -c *** last card of wzbfgs follows *** - end diff --git a/source/unres/src_MIN/timing.F b/source/unres/src_MIN/timing.F deleted file mode 100644 index 340ff3d..0000000 --- a/source/unres/src_MIN/timing.F +++ /dev/null @@ -1,340 +0,0 @@ -C $Date: 1994/10/05 16:41:52 $ -C $Revision: 2.2 $ -C -C -C - subroutine set_timers -c - implicit none - double precision tcpu - include 'COMMON.TIME1' -#ifdef MP - include 'mpif.h' -#endif -C Diminish the assigned time limit a little so that there is some time to -C end a batch job -c timlim=batime-150.0 -C Calculate the initial time, if it is not zero (e.g. for the SUN). - stime=tcpu() -#ifdef MPI - walltime=MPI_WTIME() - time_reduce=0.0d0 - time_allreduce=0.0d0 - time_bcast=0.0d0 - time_gather=0.0d0 - time_sendrecv=0.0d0 - time_scatter=0.0d0 - time_scatter_fmat=0.0d0 - time_scatter_ginv=0.0d0 - time_scatter_fmatmult=0.0d0 - time_scatter_ginvmult=0.0d0 - time_barrier_e=0.0d0 - time_barrier_g=0.0d0 - time_enecalc=0.0d0 - time_sumene=0.0d0 - time_lagrangian=0.0d0 - time_sumgradient=0.0d0 - time_intcartderiv=0.0d0 - time_inttocart=0.0d0 - time_ginvmult=0.0d0 - time_fricmatmult=0.0d0 - time_cartgrad=0.0d0 - time_bcastc=0.0d0 - time_bcast7=0.0d0 - time_bcastw=0.0d0 - time_intfcart=0.0d0 - time_vec=0.0d0 - time_mat=0.0d0 - time_fric=0.0d0 - time_stoch=0.0d0 - time_fricmatmult=0.0d0 - time_fsample=0.0d0 -#endif -cd print *,' in SET_TIMERS stime=',stime - return - end -C------------------------------------------------------------------------------ - logical function stopx(nf) -C This function returns .true. if one of the following reasons to exit SUMSL -C occurs. The "reason" code is stored in WHATSUP passed thru a COMMON block: -C -C... WHATSUP = 0 - go on, no reason to stop. Stopx will return .false. -C... 1 - Time up in current node; -C... 2 - STOP signal was received from another node because the -C... node's task was accomplished (parallel only); -C... -1 - STOP signal was received from another node because of error; -C... -2 - STOP signal was received from another node, because -C... the node's time was up. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - integer nf - logical ovrtim -#ifdef MP - include 'mpif.h' - include 'COMMON.INFO' -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - integer Kwita - -cd print *,'Processor',MyID,' NF=',nf -#ifndef MPI - if (ovrtim()) then -C Finish if time is up. - stopx = .true. - WhatsUp=1 -#ifdef MPL - else if (mod(nf,100).eq.0) then -C Other processors might have finished. Check this every 100th function -C evaluation. -C Master checks if any other processor has sent accepted conformation(s) to it. - if (MyID.ne.MasterID) call receive_mcm_info - if (MyID.eq.MasterID) call receive_conf -cd print *,'Processor ',MyID,' is checking STOP: nf=',nf - call recv_stop_sig(Kwita) - if (Kwita.eq.-1) then - write (iout,'(a,i4,a,i5)') 'Processor', - & MyID,' has received STOP signal in STOPX; NF=',nf - write (*,'(a,i4,a,i5)') 'Processor', - & MyID,' has received STOP signal in STOPX; NF=',nf - stopx=.true. - WhatsUp=2 - elseif (Kwita.eq.-2) then - write (iout,*) - & 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.' - write (*,*) - & 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.' - WhatsUp=-2 - stopx=.true. - else if (Kwita.eq.-3) then - write (iout,*) - & 'Processor',MyID,' received ERROR-STOP signal in SUMSL.' - write (*,*) - & 'Processor',MyID,' received ERROR-STOP signal in SUMSL.' - WhatsUp=-1 - stopx=.true. - else - stopx=.false. - WhatsUp=0 - endif -#endif - else - stopx = .false. - WhatsUp=0 - endif -#else - stopx=.false. -#endif - -#ifdef OSF -c Check for FOUND_NAN flag - if (FOUND_NAN) then - write(iout,*)" *** stopx : Found a NaN" - stopx=.true. - endif -#endif - - return - end -C-------------------------------------------------------------------------- - logical function ovrtim() - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - real*8 tcpu -#ifdef MPI - include "mpif.h" - curtim = MPI_Wtime()-walltime -#else - curtim= tcpu() -#endif -C curtim is the current time in seconds. -c write (iout,*) "curtim",curtim," timlim",timlim," safety",safety - if (curtim .ge. timlim - safety) then - if (me.eq.king .or. .not. out1file) - & write (iout,'(a,f10.2,a,f10.2,a,f10.2,a)') - & "***************** Elapsed time (",curtim, - & " s) is within the safety limit (",safety, - & " s) of the allocated time (",timlim," s). Terminating." - ovrtim=.true. - else - ovrtim=.false. - endif - return - end -************************************************************************** - double precision function tcpu() - include 'COMMON.TIME1' -#ifdef ES9000 -**************************** -C Next definition for EAGLE (ibm-es9000) - real*8 micseconds - integer rcode - tcpu=cputime(micseconds,rcode) - tcpu=(micseconds/1.0E6) - stime -**************************** -#endif -#ifdef SUN -**************************** -C Next definitions for sun - REAL*8 ECPU,ETIME,ETCPU - dimension tarray(2) - tcpu=etime(tarray) - tcpu=tarray(1) -**************************** -#endif -#ifdef KSR -**************************** -C Next definitions for ksr -C this function uses the ksr timer ALL_SECONDS from the PMON library to -C return the elapsed time in seconds - tcpu= all_seconds() - stime -**************************** -#endif -#ifdef SGI -**************************** -C Next definitions for sgi - real timar(2), etime - seconds = etime(timar) -Cd print *,'seconds=',seconds,' stime=',stime -C usrsec = timar(1) -C syssec = timar(2) - tcpu=seconds - stime -**************************** -#endif - -#ifdef LINUX -**************************** -C Next definitions for sgi - real timar(2), etime - seconds = etime(timar) -Cd print *,'seconds=',seconds,' stime=',stime -C usrsec = timar(1) -C syssec = timar(2) - tcpu=seconds - stime -**************************** -#endif - - -#ifdef CRAY -**************************** -C Next definitions for Cray -C call date(curdat) -C curdat=curdat(1:9) -C call clock(curtim) -C curtim=curtim(1:8) - cpusec = second() - tcpu=cpusec - stime -**************************** -#endif -#ifdef AIX -**************************** -C Next definitions for RS6000 - integer*4 i1,mclock - i1 = mclock() - tcpu = (i1+0.0D0)/100.0D0 -#endif -#ifdef WINPGI -**************************** -c next definitions for windows NT Digital fortran - real time_real - call cpu_time(time_real) - tcpu = time_real -#endif -#ifdef WINIFL -**************************** -c next definitions for windows NT Digital fortran - real time_real - call cpu_time(time_real) - tcpu = time_real -#endif - - return - end -C--------------------------------------------------------------------------- - subroutine dajczas(rntime,hrtime,mintime,sectime) - include 'COMMON.IOUNITS' - real*8 rntime,hrtime,mintime,sectime - hrtime=rntime/3600.0D0 - hrtime=aint(hrtime) - mintime=aint((rntime-3600.0D0*hrtime)/60.0D0) - sectime=aint((rntime-3600.0D0*hrtime-60.0D0*mintime)+0.5D0) - if (sectime.eq.60.0D0) then - sectime=0.0D0 - mintime=mintime+1.0D0 - endif - ihr=hrtime - imn=mintime - isc=sectime - write (iout,328) ihr,imn,isc - 328 FORMAT(//'***** Computation time: ',I4 ,' hours ',I2 , - 1 ' minutes ', I2 ,' seconds *****') - return - end -C--------------------------------------------------------------------------- - subroutine print_detailed_timing - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.SETUP' -c time1=MPI_WTIME() - write (iout,'(80(1h=)/a/(80(1h=)))') - & "Details of FG communication time" - write (*,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))') - & "BROADCAST:",time_bcast,"REDUCE:",time_reduce, - & "GATHER:",time_gather, - & "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv, - & "BARRIER ene",time_barrier_e, - & "BARRIER grad",time_barrier_g, - & "TOTAL:", - & time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv - write (*,*) fg_rank,myrank, - & ': Total wall clock time',time1-walltime,' sec' - write (*,*) "Processor",fg_rank,myrank, - & ": BROADCAST time",time_bcast," REDUCE time", - & time_reduce," GATHER time",time_gather," SCATTER time", - & time_scatter, - & " SCATTER fmatmult",time_scatter_fmatmult, - & " SCATTER ginvmult",time_scatter_ginvmult, - & " SCATTER fmat",time_scatter_fmat, - & " SCATTER ginv",time_scatter_ginv, - & " SENDRECV",time_sendrecv, - & " BARRIER ene",time_barrier_e, - & " BARRIER GRAD",time_barrier_g, - & " BCAST7",time_bcast7," BCASTC",time_bcastc, - & " BCASTW",time_bcastw," ALLREDUCE",time_allreduce, - & " TOTAL", - & time_bcast+time_reduce+time_gather+time_scatter+ - & time_sendrecv+time_barrier+time_bcastc - write (*,*) "Processor",fg_rank,myrank," enecalc",time_enecalc - write (*,*) "Processor",fg_rank,myrank," sumene",time_sumene - write (*,*) "Processor",fg_rank,myrank," intfromcart", - & time_intfcart - write (*,*) "Processor",fg_rank,myrank," vecandderiv", - & time_vec - write (*,*) "Processor",fg_rank,myrank," setmatrices", - & time_mat - write (*,*) "Processor",fg_rank,myrank," ginvmult", - & time_ginvmult - write (*,*) "Processor",fg_rank,myrank," fricmatmult", - & time_fricmatmult - write (*,*) "Processor",fg_rank,myrank," inttocart", - & time_inttocart - write (*,*) "Processor",fg_rank,myrank," sumgradient", - & time_sumgradient - write (*,*) "Processor",fg_rank,myrank," intcartderiv", - & time_intcartderiv - if (fg_rank.eq.0) then - write (*,*) "Processor",fg_rank,myrank," lagrangian", - & time_lagrangian - write (*,*) "Processor",fg_rank,myrank," cartgrad", - & time_cartgrad - endif - return - end diff --git a/source/unres/src_MIN/unres_min.F b/source/unres/src_MIN/unres_min.F deleted file mode 100644 index 3cdbeef..0000000 --- a/source/unres/src_MIN/unres_min.F +++ /dev/null @@ -1,272 +0,0 @@ -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C U N R E S C -C C -C Program to carry out conformational search of proteins in an united-residue C -C approximation. C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - - -#ifdef MPI - include 'mpif.h' - include 'COMMON.SETUP' -#endif - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' -c include 'COMMON.REMD' -c include 'COMMON.MD' - include 'COMMON.SBRIDGE' - double precision hrtime,mintime,sectime - character*64 text_mode_calc(-2:14) /'test', - & 'SC rotamer distribution', - & 'Energy evaluation or minimization', - & 'Regularization of PDB structure', - & 'Threading of a sequence on PDB structures', - & 'Monte Carlo (with minimization) ', - & 'Energy minimization of multiple conformations', - & 'Checking energy gradient', - & 'Entropic sampling Monte Carlo (with minimization)', - & 'Energy map', - & 'CSA calculations', - & 'Not used 9', - & 'Not used 10', - & 'Soft regularization of PDB structure', - & 'Mesoscopic molecular dynamics (MD) ', - & 'Not used 13', - & 'Replica exchange molecular dynamics (REMD)'/ - external ilen - -c call memmon_print_usage() - - call init_task - if (me.eq.king) - & write(iout,*)'### LAST MODIFIED 11/03/09 1:19PM by czarek' - if (me.eq.king) call cinfo -C Read force field parameters and job setup data - call readrtns - call flush(iout) -C - if (me.eq.king .or. .not. out1file) then - write (iout,'(2a/)') - & text_mode_calc(modecalc)(:ilen(text_mode_calc(modecalc))), - & ' calculation.' - if (minim) write (iout,'(a)') - & 'Conformations will be energy-minimized.' - write (iout,'(80(1h*)/)') - endif - call flush(iout) -#ifdef MPI - if (fg_rank.gt.0) then -C Fine-grain slaves just do energy and gradient components. - call ergastulum ! slave workhouse in Latin - else -#endif - if (modecalc.eq.0) then - call exec_eeval_or_minim - else if (modecalc.eq.5) then - call exec_checkgrad - else - write (iout,'(a)') 'This calculation type is not supported', - & ModeCalc - endif -#ifdef MPI - endif -C Finish task. - if (fg_rank.eq.0) call finish_task -c call memmon_print_usage() -#ifdef TIMING - call print_detailed_timing -#endif - call MPI_Finalize(ierr) - stop 'Bye Bye...' -#else - call dajczas(tcpu(),hrtime,mintime,sectime) - stop '********** Program terminated normally.' -#endif - end -c--------------------------------------------------------------------------- - subroutine exec_eeval_or_minim - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - common /srutu/ icall - double precision energy(0:n_ene),varia(maxvar) - double precision energy_long(0:n_ene),energy_short(0:n_ene) - if (indpdb.eq.0) call chainbuild -#ifdef MPI - time00=MPI_Wtime() -#else - time00=tcpu() -#endif - call chainbuild_cart - call etotal(energy(0)) -#ifdef MPI - time_ene=MPI_Wtime()-time00 -#else - time_ene=tcpu() -#endif - write (iout,*) "Time for energy evaluation",time_ene - print *,"after etotal" - etota = energy(0) - etot =etota - call enerprint(energy(0)) -c call hairpin(.true.,nharp,iharp) -c call secondary2(.true.) - if (minim) then - -crc overlap test - if (overlapsc) then - print *, 'Calling OVERLAP_SC' - call overlap_sc(fail) - endif - - if (searchsc) then - call sc_move(2,nres-1,10,1d10,nft_sc,etot) - print *,'SC_move',nft_sc,etot - write(iout,*) 'SC_move',nft_sc,etot - endif - - if (dccart) then - print *, 'Calling MINIM_DC' -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - call minim_dc(etot,iretcode,nfun) - else - if (indpdb.ne.0) then - call bond_regular - call chainbuild - endif - call geom_to_var(nvar,varia) - print *,'Calling MINIMIZE.' -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - call minimize(etot,varia,iretcode,nfun) - endif - print *,'SUMSL return code is',iretcode,' eval ',nfun -#ifdef MPI - evals=nfun/(MPI_WTIME()-time1) -#else - evals=nfun/(tcpu()-time1) -#endif - print *,'# eval/s',evals - print *,'refstr=',refstr -c call hairpin(.true.,nharp,iharp) -c call secondary2(.true.) - call etotal(energy(0)) - etot = energy(0) - call enerprint(energy(0)) - - call intout - call briefout(0,etot) -c if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) - write (iout,'(a,i3)') 'SUMSL return code:',iretcode - write (iout,'(a,i20)') '# of energy evaluations:',nfun+1 - write (iout,'(a,f16.3)')'# of energy evaluations/sec:',evals -c else -c print *,'refstr=',refstr -c if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) -c call briefout(0,etot) - endif - if (outpdb) call pdbout(etot,titel(:32),ipdb) - if (outmol2) call mol2out(etot,titel(:32)) - return - end - - subroutine exec_checkgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.TIME1' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' -c include 'COMMON.REMD' - include 'COMMON.MD_' - include 'COMMON.SBRIDGE' - common /srutu/ icall - double precision energy(0:max_ene) -c do i=2,nres -c vbld(i)=vbld(i)+ran_number(-0.1d0,0.1d0) -c if (itype(i).ne.10) -c & vbld(i+nres)=vbld(i+nres)+ran_number(-0.001d0,0.001d0) -c enddo - if (indpdb.eq.0) call chainbuild -c do i=0,nres -c do j=1,3 -c dc(j,i)=dc(j,i)+ran_number(-0.2d0,0.2d0) -c enddo -c enddo -c do i=1,nres-1 -c if (itype(i).ne.10) then -c do j=1,3 -c dc(j,i+nres)=dc(j,i+nres)+ran_number(-0.2d0,0.2d0) -c enddo -c endif -c enddo -c do j=1,3 -c dc(j,0)=ran_number(-0.2d0,0.2d0) -c enddo - usampl=.true. - totT=1.d0 - eq_time=0.0d0 -c call read_fragments - call chainbuild_cart - call cartprint - call intout - icall=1 - call etotal(energy(0)) - etot = energy(0) - call enerprint(energy(0)) - write (iout,*) "Uconst",Uconst," Uconst_back",uconst_back - print *,'icheckgrad=',icheckgrad - goto (10,20,30) icheckgrad - 10 call check_ecartint - return - 20 call check_cartgrad - return - 30 call check_eint - return - end diff --git a/source/wham/src-NEWSC-NEWCORR/CMakeLists.txt b/source/wham/src-NEWSC-NEWCORR/CMakeLists.txt deleted file mode 100644 index aca8eb4..0000000 --- a/source/wham/src-NEWSC-NEWCORR/CMakeLists.txt +++ /dev/null @@ -1,298 +0,0 @@ -# -# CMake project file for WHAM single chain version -# - -enable_language (Fortran) - -#================================ -# Set source file lists -#================================ -set(UNRES_WHAM_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 - pinorm.f - printmat.f - rescode.f - setup_var.f - slices.F - store_parm.F - timing.F - wham_calc1.F - readrtns_compar.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 -) - -set(UNRES_WHAM_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 - read_ref_str.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 "-mcmodel=medium -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" ) -endif (Fortran_COMPILER_NAME STREQUAL "ifort") - - -#========================================= -# Add MPI compiler flags -#========================================= -if(UNRES_WITH_MPI) - set(FFLAGS0 "${FFLAGS0} -I${MPIF_INCLUDE_DIRECTORIES}") -endif(UNRES_WITH_MPI) - -set_property(SOURCE ${UNRES_WHAM_SRC0} PROPERTY COMPILE_FLAGS ${FFLAGS0} ) - -#========================================= -# WHAM preprocesor flags -#========================================= - -set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" ) - -#========================================= -# System specific flags -#========================================= -if(${CMAKE_SYSTEM_NAME} MATCHES "Linux") - set(CPPFLAGS "${CPPFLAGS} -DLINUX") -endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux") - -#========================================= -# Compiler specific flags -#========================================= - -if (Fortran_COMPILER_NAME STREQUAL "ifort") - # Add ifort preprocessor flags - set(CPPFLAGS "${CPPFLAGS} -DPGI") -elseif (Fortran_COMPILER_NAME STREQUAL "f95") - # Add new gfortran flags - set(CPPFLAGS "${CPPFLAGS} -DG77") -elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") - # Add old gfortran flags - set(CPPFLAGS "${CPPFLAGS} -DG77") -endif (Fortran_COMPILER_NAME STREQUAL "ifort") - -#========================================= -# Add MPI preprocessor flags -#========================================= -set(CPPFLAGS "${CPPFLAGS} -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_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) - - -#======================================== -# Setting binary name -#======================================== -set(UNRES_WHAM_BIN "wham_${Fortran_COMPILER_NAME}.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 path -set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f PROPERTY COMPILE_FLAGS "${FFLAGS0} -I${CMAKE_CURRENT_SOURCE_DIR}" ) - -#========================================= -# Set full unres CSA sources -#========================================= -set(UNRES_WHAM_SRCS ${UNRES_WHAM_SRC0} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f proc_proc.c) - -#========================================= -# Build the binary -#========================================= -add_executable(UNRES_WHAM_BIN ${UNRES_WHAM_SRCS} ) -set_target_properties(UNRES_WHAM_BIN PROPERTIES OUTPUT_NAME ${UNRES_WHAM_BIN}) - -#set_property(TARGET ${UNRES_BIN} PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin/unres/MD ) -#add_dependencies (${UNRES_BIN} ${UNRES_XDRFLIB}) - -#========================================= -# Link libraries -#========================================= -# link MPI library (libmpich.a) -target_link_libraries( UNRES_WHAM_BIN ${MPIF_LIBRARIES} ) -# link libxdrf.a -target_link_libraries( UNRES_WHAM_BIN xdrf ) - -#========================================= -# TESTS -#========================================= - -#-- Copy all the data files from the test directory into the source directory -#SET(UNRES_TEST_FILES -# ala10.inp -# ) - -#FOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) -# SET (unres_test_dest "${CMAKE_CURRENT_BINARY_DIR}/${UNRES_TEST_FILE}") -# MESSAGE (STATUS " Copying ${UNRES_TEST_FILE} from ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} to ${unres_test_dest}") -# ADD_CUSTOM_COMMAND ( -# TARGET ${UNRES_BIN} -# POST_BUILD -# COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} ${unres_test_dest} -# ) -#ENDFOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) - -#========================================= -# Generate data test files -#========================================= -# test_single_ala.sh -#========================================= - -#FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh -#"#!/bin/sh -#export POT=GB -#export PREFIX=ala10 -#----------------------------------------------------------------------------- -#UNRES_BIN=./${UNRES_BIN} -#----------------------------------------------------------------------------- -#DD=${CMAKE_SOURCE_DIR}/PARAM -#export BONDPAR=$DD/bond.parm -#export THETPAR=$DD/thetaml.5parm -#export ROTPAR=$DD/scgauss.parm -#export TORPAR=$DD/torsion_631Gdp.parm -#export TORDPAR=$DD/torsion_double_631Gdp.parm -#export ELEPAR=$DD/electr_631Gdp.parm -#export SIDEPAR=$DD/sc_GB_opt.1gab_3S_qclass5no310-shan2-sc-16-10-8k -#export FOURIER=$DD/fourier_opt.parm.1igd_hc_iter3_3 -#export SCPPAR=$DD/scp.parm -#export SCCORPAR=$DD/rotcorr_AM1.parm -#export PATTERN=$DD/patterns.cart -#----------------------------------------------------------------------------- -#$UNRES_BIN -#") - -#========================================= -# ala10.inp -#========================================= - -#file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/ala10.inp -#"ala10 unblocked -#SEED=-1111333 MD ONE_LETTER rescale_mode=2 PDBOUT -#nstep=15000 ntwe=100 ntwx=1000 dt=0.1 lang=0 tbf t_bath=300 damax=1.0 & -#reset_moment=1000 reset_vel=1000 MDPDB -#WLONG=1.35279 WSCP=1.59304 WELEC=0.71534 WBOND=1.00000 WANG=1.13873 & -#WSCLOC=0.16258 WTOR=1.98599 WTORD=1.57069 WCORRH=0.42887 WCORR5=0.00000 & -#WCORR6=0.00000 WEL_LOC=0.16036 WTURN3=1.68722 WTURN4=0.66230 WTURN6=0.00000 & -#WVDWPP=0.11371 WHPB=1.00000 & -#CUTOFF=7.00000 WCORR4=0.00000 -#12 -#XAAAAAAAAAAX -# 0 -# 0 -# 90.0000 90.0000 90.0000 90.000 90.000 90.000 90.000 90.000 -# 90.0000 90.0000 -# 180.0000 180.0000 180.0000 180.000 180.000 180.000 180.000 180.000 -# 180.0000 -# 110.0000 110.0000 110.0000 100.000 110.000 100.000 110.000 110.000 -# 110.0000 110.0000 -# -120.0000 -120.0000 -120.000 -120.000 -120.000 -120.000 -120.000 -120.000 -# -120.0000 -120.0000 -#") - - -# Add tests - -#if(NOT UNRES_WITH_MPI) - -# add_test(NAME UNRES_MD_Ala10 COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh ) - -#endif(NOT UNRES_WITH_MPI) diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.ALLPARM b/source/wham/src-NEWSC-NEWCORR/COMMON.ALLPARM deleted file mode 100644 index 62d1e47..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.ALLPARM +++ /dev/null @@ -1,99 +0,0 @@ - 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,max_parm),athet_all(2,ntyp,max_parm), - & bthet_all(2,ntyp,max_parm),polthet_all(0:3,ntyp,max_parm), - & gthet_all(3,ntyp,max_parm),theta0_all(ntyp,max_parm), - & sig0_all(ntyp,max_parm),sigc0_all(ntyp,max_parm), - & aa0thet_all(maxthetyp1,maxthetyp1,maxthetyp1,max_parm), - & aathet_all(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1,max_parm), - & bbthet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & ccthet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & ddthet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & eethet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & ffthet_all(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & ggthet_all(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & dsc_all(ntyp1,max_parm),bsc_all(maxlob,ntyp,max_parm), - & censc_all(3,maxlob,ntyp,max_parm), - & gaussc_all(3,3,maxlob,ntyp,max_parm),dsc0_all(ntyp1,max_parm), - & sc_parmin_all(65,ntyp,max_parm), - & v0_all(maxtor,maxtor,max_parm), - & v1_all(maxterm,maxtor,maxtor,max_parm), - & v2_all(maxterm,maxtor,maxtor,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,max_parm), - & v1s_all(2,maxtermd_1,maxtor,maxtor,maxtor,max_parm), - & v2c_all(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor,max_parm), - & v2s_all(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor,max_parm), - & b1_all(2,maxtor,max_parm),b2_all(2,maxtor,max_parm), - & cc_all(2,2,maxtor,max_parm),dd_all(2,2,maxtor,max_parm), - & ee_all(2,2,maxtor,max_parm),ctilde_all(2,2,maxtor,max_parm), - & dtilde_all(2,2,maxtor,max_parm),b1tilde_all(2,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_all(ntyp,ntyp,max_parm),bb_all(ntyp,ntyp,max_parm), - & augm_all(ntyp,ntyp,max_parm),eps_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), - & chipp_all(ntyp,ntyp,max_parm),sigmap1_all(ntyp,ntyp,max_parm), - & sigmap2_all(ntyp,ntyp,max_parm),chis_all(ntyp,ntyp,max_parm), - & alphasur_all(4,ntyp,ntyp,max_parm), - & wstate_all(4,ntyp,ntyp,max_parm), - & nstate_all(ntyp,ntyp,max_parm), - & dhead_all(2,2,ntyp,ntyp,max_parm), - & dtail_all(2,ntyp,ntyp,max_parm), - & epshead_all(ntyp,ntyp,max_parm), - & rborn_all(ntyp,ntyp,max_parm), - & wqdip_all(2,ntyp,ntyp,max_parm),wquad_all(ntyp,ntyp,max_parm), - & alphapol_all(ntyp,ntyp,max_parm), - & alphiso_all(4,ntyp,ntyp,max_parm), - & sigiso1_all(ntyp,ntyp,max_parm), - & sigiso2_all(ntyp,ntyp,max_parm), - & epsintab_all(ntyp,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,max_parm), - & v2sccor_all(maxterm_sccor,3,ntyp,ntyp,max_parm) - integer nlob_all(ntyp1,max_parm),nlor_all(maxtor,maxtor,max_parm), - & nterm_all(maxtor,maxtor,max_parm), - & ntermd1_all(maxtor,maxtor,maxtor,max_parm), - & ntermd2_all(maxtor,maxtor,maxtor,max_parm), - & nbondterm_all(ntyp,max_parm),nthetyp_all(max_parm), - & ithetyp_all(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,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_all,ggthet_all, - & 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,b1_all,b2_all,cc_all,dd_all,ee_all, - & ctilde_all,dtilde_all,b1tilde_all,app_all,bpp_all,ael6_all, - & ael3_all,aad_all,bad_all,aa_all,bb_all,augm_all, - & eps_all,sigma_all,r0_all,chi_all,chipp_all,sigmap1_all, - & sigmap2_all, - & chis_all,alphasur_all,wstate_all,dhead_all,dtail_all, - & epshead_all, - & rborn_all,wqdip_all,wquad_all,alphapol_all,alphiso_all, - & sigiso1_all, - & sigiso2_all,epsintab_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,nstate_all diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.CHAIN b/source/wham/src-NEWSC-NEWCORR/COMMON.CHAIN deleted file mode 100644 index 07dd87e..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.CHAIN +++ /dev/null @@ -1,8 +0,0 @@ - integer nres,nres0,nsup,nstart_sup,nend_sup,nstart_seq,ishift_pdb - double precision c,cref,dc,xloc,xrot,dc_norm,t,r,prod,rt - 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),nsup,nstart_sup,nend_sup, - & nstart_seq,ishift_pdb diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.COMPAR b/source/wham/src-NEWSC-NEWCORR/COMMON.COMPAR deleted file mode 100644 index eb59ea4..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.COMPAR +++ /dev/null @@ -1,39 +0,0 @@ - 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-NEWSC-NEWCORR/COMMON.CONTACTS1 b/source/wham/src-NEWSC-NEWCORR/COMMON.CONTACTS1 deleted file mode 100644 index 04affa9..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.CONTACTS1 +++ /dev/null @@ -1,5 +0,0 @@ - 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-NEWSC-NEWCORR/COMMON.CONTROL b/source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL deleted file mode 100644 index 1178504..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL +++ /dev/null @@ -1,10 +0,0 @@ - integer iscode,indpdb,outpdb,outmol2,icomparfunc,pdbint, - & ensembles,constr_dist - logical refstr,pdbref,punch_dist,print_rms,caonly,verbose, - & merge_helices,bxfile,cxfile,histfile,entfile,zscfile, - & rmsrgymap,with_dihed_constr,check_conf,histout,energy_dec - 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,with_dihed_constr,check_conf,histout,constr_dist, - & energy_dec diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL.org b/source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL.org deleted file mode 100644 index 7dc2298..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL.org +++ /dev/null @@ -1,9 +0,0 @@ - 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-NEWSC-NEWCORR/COMMON.EMP b/source/wham/src-NEWSC-NEWCORR/COMMON.EMP deleted file mode 100644 index 5a39536..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.EMP +++ /dev/null @@ -1,126 +0,0 @@ -c! Variable Declarations -c! Charge of i-th residue, charge of j-th residue,... - INTEGER Qi, Qj, Qij, ii, jj, itypi, itypj - -c! STUFF FROM EMOMO - -c! why do *I* have to declare those guys, when it is used throughout the whole code... - REAL*8 evdw, evdw_p, evdw_m - double precision xi, yi, zi, ctail(3,2), chead(3,2) -c! FOLLOWING ARE ***NOT*** in common block!!! -c! They are here just for their declarations - REAL*8 ecl,elj,equad,epol - INTEGER istate -c! intermediates - REAL*8 c1, c2, fac, pom -c! switch in the selector choosing which electrostatic energy/gradient function to call - INTEGER isel -c! sigma factors - REAL*8 sig, sig0ij, sig1, sig2 -c! intermediates related to distance - REAL*8 rij_shift, rrij, R1, R2, RR1, RR2 -c! intermediates related to angles - REAL*8 sinth1sq, sinth2sq -c! intermediates of Fgb - REAL*8 fgb, ee, ee1, ee2, eps0, pis - -c! squares of om1, om2 and om12 (those hold cosines of angles -c! theta) - REAL*8 sqom1, sqom2, sqom12 - -c! Geometry and general stuff -c! a12sq = ai*aj from fgb which is present in Egbpol/Fgbpol, -c! Epol/Gpol and others, ee is an intermediate. -c! three dimensions for X, Y and Z Cartesians - REAL*8 a12sq - -c! square distance and cartesian distances of polar/charged heads of sidechains - REAL*8 Rhead, Rhead_distance(3), Rhead_sq -c! square distance and cartesian distances of tail(hydrophobic centre of interaction) -c! of a given pair of sidechains - REAL*8 Rtail, Rtail_distance(3) -c! intermediates used in dXhead/dXtail - REAL*8 erhead(3), ertail(3), facd1, facd2, erdxi, erdxj - -c! unit vectors used to calculate R's - REAL*8 d1sq, d2sq, d1d2 - REAL*8 d1, d2 - -c! intermediates (hold different meanining in different places) - REAL*8 bat, hawk, eagle, condor, sparrow, rosella - REAL*8 tuna(3) - -c! holds 1/eps_in - 1/eps_out which appears in EGBpol Makowski et al JPCB 2011 -c! p. 6122 - REAL*8 eps_inout_fac, eps_in - -c! DERIVATIVES -c! intermediates - Real*8 dFdR, dFdL, dFdOM1, dFdOM2, dFdOM12 -c! Kronecker Delta used for dXhead/dXtail derivatives - Real*8 kro_delta -c! Gcl - REAL*8 Gelconst - REAL*8 dGCLdR, dGCLdOM1, dGCLdOM2, dGCLdOM12 - -c! Ggbpol -c! energy - REAL*8 Egb, dGGBdFGB, dGGBdR - REAL*8 dFGBdR, alphapol1, alphapol2 - -c! Gpol - REAL*8 fgb1, fgb2 - REAL*8 dPOLdOM1, dPOLdOM2, dPOLdR1, dPOLdR2 - REAL*8 dFGBdOM1, dFGBdOM2, dFGBdR1, dFGBdR2 - REAL*8 dPOLdFGB1, dPOLdFGB2, MomoFac1, MomoFac2 - REAL*8 erhead_tail(3,2) - -c! Gisocav - REAL*8 Fisocav, dGCVdR -c! alpha parameters for Fisocav/Gisocav - REAL*8 al1, al2, al3, al4, csig - -c! Gcav -c! energy - REAL*8 Fcav -c! alphas from the equation - REAL*8 b1, b2, b3, b4 -c! intermediates - Real*8 chif, lambf, chilambf - REAL*8 top, bot, dtop, dbot, botsq - REAL*8 chis1, chis2, chis12 -c! final value - REAL*8 dCAVdOM1, dCAVdOM2, dCAVdOM12 - -c! Gquad stuff -c! intermediates - REAL*8 wqd, w1, w2, beta1 -c! final value - REAl*8 dQUADdR, dQUADdOM1, dQUADdOM2, dQUADdOM12 - -c! Glj -c! parameter, radial derivative - REAL*8 eps_head, dGLJdR - -c! Sum of states - REAL*8 BetaT, eheadtail, weightbol, sumweight -c! this thing holds intermediates and final value -c! (dimensions, gvdw(c/x)(i/j),intermediate(1) or final(2)) - REAL*8 gheadtail(3,4,2) - -c! Now Commonize what we need to - COMMON /emp/ Qi, Qj, Qij, ii, jj, itypi, itypj, xi, yi, zi - & , sqom1, sqom2, sqom12, chead, ctail - & , al1, al2, al3, al4 - & , b1, b2, b3, b4 - & , Rhead, Rhead_distance, Rtail, Rtail_distance - & , R1, R2, RR1, RR2 - & , d1sq, d2sq, d1, d2, d1d2 - & , eps_inout_fac, eps_in, wqd, eps_head, a12sq - & , chis1, chis2, chis12, sig1, sig2, sig0ij - & , BetaT - & , dFdR, dFdL, dFdOM1, dFdOM2, dFdOM12 - & , dCAVdOM1, dCAVdOM2, dCAVdOM12 - & , dGCLdOM1, dGCLdOM2, dGCLdOM12 - & , dPOLdOM1, dPOLdOM2 - & , dQUADdR, dQUADdOM1, dQUADdOM2, dQUADdOM12 \ No newline at end of file diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.ENEPS b/source/wham/src-NEWSC-NEWCORR/COMMON.ENEPS deleted file mode 100644 index eaf002e..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.ENEPS +++ /dev/null @@ -1,3 +0,0 @@ - double precision eneps_temp(2,nntyp) - integer n_ene - common /weightder/ eneps_temp,n_ene diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.ENERGIES b/source/wham/src-NEWSC-NEWCORR/COMMON.ENERGIES deleted file mode 100644 index 2d40a95..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.ENERGIES +++ /dev/null @@ -1,4 +0,0 @@ - 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-NEWSC-NEWCORR/COMMON.FREE b/source/wham/src-NEWSC-NEWCORR/COMMON.FREE deleted file mode 100644 index 3e378ca..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.FREE +++ /dev/null @@ -1,15 +0,0 @@ - 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),delta,deltrms,deltrgy,fimin, - & f(maxR,maxT_h,max_parm),beta_h(MaxT_h,max_parm) - double precision delta_T,startGridT - 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) - integer nGridT - logical replica(max_parm),umbrella(max_parm),read_iset(max_parm) - common /wham/ Kh,q0,f,beta_h,delta,deltrms,deltrgy,delta_T, - & startGridT,fimin,snk,nR, - & nRR,nT_h,nQ,stot,nparmset,maxit,rescale_mode,replica,umbrella, - & read_iset,totraj,hamil_rep,separate_parset,iparmprint,myparm, - & nGridT diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.IOUNITS b/source/wham/src-NEWSC-NEWCORR/COMMON.IOUNITS deleted file mode 100644 index 23783bb..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.IOUNITS +++ /dev/null @@ -1,51 +0,0 @@ -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 - 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 - 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 - common /parfiles/ thetname,rotname,torname,tordname,bondname, - & fouriername,elename,sidename,scpname,sccorname,patname - 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-NEWSC-NEWCORR/COMMON.MPI b/source/wham/src-NEWSC-NEWCORR/COMMON.MPI deleted file mode 100644 index 037c1c9..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.MPI +++ /dev/null @@ -1,8 +0,0 @@ - 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-NEWSC-NEWCORR/COMMON.OBCINKA b/source/wham/src-NEWSC-NEWCORR/COMMON.OBCINKA deleted file mode 100644 index e0d9c61..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.OBCINKA +++ /dev/null @@ -1,3 +0,0 @@ - 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-NEWSC-NEWCORR/COMMON.PEPTCONT b/source/wham/src-NEWSC-NEWCORR/COMMON.PEPTCONT deleted file mode 100644 index 59e05dd..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.PEPTCONT +++ /dev/null @@ -1,7 +0,0 @@ - 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-NEWSC-NEWCORR/COMMON.PROT b/source/wham/src-NEWSC-NEWCORR/COMMON.PROT deleted file mode 100644 index 054ec47..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.PROT +++ /dev/null @@ -1,2 +0,0 @@ - integer ntot(maxslice),isampl(max_parm),nslice - common /protein/ ntot,isampl,nslice diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.PROTFILES b/source/wham/src-NEWSC-NEWCORR/COMMON.PROTFILES deleted file mode 100644 index 3287326..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.PROTFILES +++ /dev/null @@ -1,10 +0,0 @@ - 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-NEWSC-NEWCORR/COMMON.VAR b/source/wham/src-NEWSC-NEWCORR/COMMON.VAR deleted file mode 100644 index 2b11894..0000000 --- a/source/wham/src-NEWSC-NEWCORR/COMMON.VAR +++ /dev/null @@ -1,17 +0,0 @@ -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, - & xxtab,yytab,zztab,tauangle,omicron - common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), - & omicron(2,maxres),tauangle(3,maxres), - & vbld(2*maxres), - & costtab(maxres), sinttab(maxres), cost2tab(maxres), - & sint2tab(maxres),xxtab(maxres),yytab(maxres), - & zztab(maxres), - & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar -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-NEWSC-NEWCORR/DIMENSIONS b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS deleted file mode 100644 index 4d9279d..0000000 --- a/source/wham/src-NEWSC-NEWCORR/DIMENSIONS +++ /dev/null @@ -1,142 +0,0 @@ -******************************************************************************** -* 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=400) -C Appr. max. number of interaction sites - integer maxres2 - 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 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=20,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 - parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) -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) diff --git a/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.COMPAR b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.COMPAR deleted file mode 100644 index 911bd4e..0000000 --- a/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.COMPAR +++ /dev/null @@ -1,25 +0,0 @@ -****************************************************************** -* -* 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-NEWSC-NEWCORR/DIMENSIONS.FREE b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE deleted file mode 100644 index 5f1a041..0000000 --- a/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE +++ /dev/null @@ -1,14 +0,0 @@ - integer Max_Parm - integer MaxQ,MaxQ1 - integer MaxR,MaxT_h - integer MaxSlice - parameter (Max_Parm=1) - parameter (MaxQ=4,MaxQ1=MaxQ+2) - parameter(MaxR=1,MaxT_h=32) - parameter(MaxSlice=40) - integer MaxN - parameter (MaxN=100) - integer MaxPrintConf - parameter (MaxPrintConf=1000) - integer Max_GridT - parameter (Max_GridT=400) diff --git a/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE.old b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE.old deleted file mode 100644 index e579dd1..0000000 --- a/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE.old +++ /dev/null @@ -1,12 +0,0 @@ - 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-NEWSC-NEWCORR/DIMENSIONS.ZSCOPT b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.ZSCOPT deleted file mode 100644 index 0d8e64b..0000000 --- a/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.ZSCOPT +++ /dev/null @@ -1,40 +0,0 @@ - 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=21,maxprot=7,maxclass=5000) - 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 = 2048) -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-NEWSC-NEWCORR/Makefile b/source/wham/src-NEWSC-NEWCORR/Makefile deleted file mode 120000 index 8453cdd..0000000 --- a/source/wham/src-NEWSC-NEWCORR/Makefile +++ /dev/null @@ -1 +0,0 @@ -Makefile_MPICH_ifort \ No newline at end of file diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile-pgi b/source/wham/src-NEWSC-NEWCORR/Makefile-pgi deleted file mode 100644 index 40cc442..0000000 --- a/source/wham/src-NEWSC-NEWCORR/Makefile-pgi +++ /dev/null @@ -1,74 +0,0 @@ -BIN = /users/adam/ZSCOREZ/bin -CC = cc -FC = mpif90 -#FC = ifc -OPT = -fast -pc 64 -tp p6 -Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 -#FFLAGS = ${OPT} -g -c -I. -I./include_unres -#FFLAGS = ${OPT} -c -C -g -I. -I./include_unres -FFLAGS = ${OPT} -c -I. -I./include_unres -LIBS = -L../../MEY_MD/src_Tc/xdrf -lxdrf -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV -CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} -Wl,-Bstatic ${objects} ${objects_compar} cinfo.o \ - ${LIBS} -o ${BIN}/wham_multparm-T-sccor - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile1_jump b/source/wham/src-NEWSC-NEWCORR/Makefile1_jump deleted file mode 100644 index 1df1586..0000000 --- a/source/wham/src-NEWSC-NEWCORR/Makefile1_jump +++ /dev/null @@ -1,60 +0,0 @@ -BIN = ../bin -CC = cc -FC = mpxlf90 -qfixed -w -OPT = -q64 -FFLAGS = -c ${OPT} -O3 -I./include_unres -LIBS = xdrf/libxdrf.o xdrf/ftocstr.o -CPPFLAGS = -WF,-DMPI -WF,-DAIX -WF,-DUNRES -WF,-DSPLITELE -WF,-DPROCOR -WF,-DISNAN - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 \ - rescode.o \ - setup_var.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ - ${LIBS} -o ${BIN}/wham_multparm1-T-procor - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_MPICH_ifort b/source/wham/src-NEWSC-NEWCORR/Makefile_MPICH_ifort deleted file mode 100644 index 9377fbb..0000000 --- a/source/wham/src-NEWSC-NEWCORR/Makefile_MPICH_ifort +++ /dev/null @@ -1,89 +0,0 @@ -INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh -BIN = /users/adam/unres/bin/wham -FC= ifort -#OPT = -mcmodel=medium -O3 -ip -w -OPT = -mcmodel=medium -g -CA -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 \ - 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 - -GABs: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCALREP -GABs: ${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_MM-KN-DEBUG-scalrep.exe - -GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DNEWCORR -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_MM-KN-NEWC.exe - -E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -DNEWCORR -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_MM-PH-NEWC.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-NEWSC-NEWCORR/Makefile_jubl b/source/wham/src-NEWSC-NEWCORR/Makefile_jubl deleted file mode 100644 index 5f37ee7..0000000 --- a/source/wham/src-NEWSC-NEWCORR/Makefile_jubl +++ /dev/null @@ -1,95 +0,0 @@ -CPPFLAGS = -WF,-DOLD_GINV \ - -WF,-DUNRES -WF,-DMPI \ - -WF,-DSPLITELE -WF,-DISNAN \ - -WF,-DAIX -WF,-DLANG0 -WF,-DPROCOR -WF,-DJUBL -#-WF,-DNOXDR -#-WF,-DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -BGLSYS = /bgl/BlueLight/ppcfloor/bglsys - -CC = /usr/bin/blrts_xlc -CPPC = /usr/bin/blrts_xlc -FC = /usr/bin/blrts_xlf90 -#-pg -g - -# try -qarch=440 first, then use -qarch=440d for 2nd FPU later on -# (SIMDization requires at least -O3) -# use -qlist -qsource with 440d and look for Parallel ASM instructions. -# -OPT= -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 -qfixed -w -qnosave -CFLAGS= -O3 -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 -FFLAGS= -c -O3 ${OPT} -I./include_unres -# -LIBS_MPI = -lmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts -LIBSF_MPI = -lmpich.rts -lfmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts - -FFLAGS1 = -c ${OPT} -O2 -FFLAGS2 = -c ${OPT} -O -FFLAGSE = -c ${OPT} -O4 - - -BIN = ${HOME}/UNRES/bin/wham_multparm-T-procor.rts -LIBS = ${LIBSF_MPI} ../src_Tc/xdrf/libxdrf.a -#LIBS = ${LIBSF_MPI} - -ARCH = LINUX -PP = /lib/cpp -P - -all: unresCSA - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -objects = \ - wham_multparm.o \ - cxread.o \ - enecalc.o \ - energy_p_new.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_ensemble.o \ - matmult.o \ - misc.o \ - mygetenv.o \ - parmread.o \ - pinorm.o \ - printmat.o \ - rescode.o \ - setup_var.o \ - store_parm.o \ - timing.o \ - wham_calc.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 - - -unresCSA: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${objects} ${objects_compar} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_jump b/source/wham/src-NEWSC-NEWCORR/Makefile_jump deleted file mode 100644 index e79c218..0000000 --- a/source/wham/src-NEWSC-NEWCORR/Makefile_jump +++ /dev/null @@ -1,69 +0,0 @@ -BIN = ../bin -CC = cc -CFLAGS = -DAIX -c -FC = mpxlf90 -qlistopt -qfixed -w -OPT = -q64 -FFLAGS = -c ${OPT} -O3 -I./include_unres -#FFLAGS = -c ${OPT} -g -C -I./include_unres -LIBS = xdrf/libxdrf.o xdrf/ftocstr.o -CPPFLAGS = -WF,-DMPI -WF,-DAIX -WF,-DUNRES -WF,-DSPLITELE -WF,-DPROCOR -WF,-DISNAN - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -.SUFFIXES: .c -.c.o: - ${CC} ${CFLAGS} $*.c - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 \ - 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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ - ${LIBS} -o ${BIN}/wham_multparm-T-procor-c1 - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix deleted file mode 100644 index d16bc8c..0000000 --- a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix +++ /dev/null @@ -1,67 +0,0 @@ -INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh -BIN = ../bin -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 -CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ - ${LIBS} -static-intel -o ${BIN}/wham_multparm-ham_rep - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI deleted file mode 100644 index bb4982d..0000000 --- a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI +++ /dev/null @@ -1,76 +0,0 @@ -INSTALL_DIR = /users/software/mpich-1.2.7p1_pgi_9.0_64bit_ssh -BIN = ../bin -CC = cc -FC = pgf90 -#FC = ifc -#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 -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV -CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o -Bstatic_pgi \ - ${LIBS} -o ${BIN}/wham_multparm-hamrep-sep - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCT-oldparm b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCT-oldparm deleted file mode 100644 index 82001ca..0000000 --- a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCT-oldparm +++ /dev/null @@ -1,76 +0,0 @@ -INSTALL_DIR = /users/software/mpich-1.2.7p1_pgi_9.0_64bit_ssh -BIN = ../bin -CC = cc -FC = pgf90 -#FC = ifc -OPT = -mcmodel=medium -Mlarge_arrays -fast -pc 64 -tp amd64 -#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 -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV -CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DCRYST_BOND -DCRYST_SC -DCRYST_THETA -DFUNCT -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o -Bstatic_pgi \ - ${LIBS} -o ${BIN}/wham_multparm-OPTERON-SCT-sccor-oldparm - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCTF-oldparm b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCTF-oldparm deleted file mode 100644 index 66ebf03..0000000 --- a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCTF-oldparm +++ /dev/null @@ -1,76 +0,0 @@ -INSTALL_DIR = /users/software/mpich-1.2.7p1_pgi_9.0_64bit_ssh -BIN = ../bin -CC = cc -FC = pgf90 -#FC = ifc -OPT = -mcmodel=medium -Mlarge_arrays -fast -pc 64 -tp amd64 -#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 -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV -CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DCRYST_BOND -DCRYST_SC -DCRYST_THETA -DFUNCTH -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} -Bstatic_pgi cinfo.o \ - ${LIBS} -o ${BIN}/wham_multparm-OPTERON-SCTF-sccor-oldparm - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-oldparm b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-oldparm deleted file mode 100644 index 1c9d56b..0000000 --- a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-oldparm +++ /dev/null @@ -1,76 +0,0 @@ -INSTALL_DIR = /usr/local/mpich-1.2.7p1_pgi64-6.2-3_ssh -BIN = ../bin -CC = cc -FC = pgf90 -#FC = ifc -OPT = -mcmodel=medium -Mlarge_arrays -fast -pc 64 -tp amd64 -#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 -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV -CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DCRYST_BOND -DCRYST_SC -DCRYST_THETA -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ - ${LIBS} -o ${BIN}/wham_multparm-OPTERON-SCTF-sccor-oldparm - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/a.sh b/source/wham/src-NEWSC-NEWCORR/a.sh deleted file mode 100644 index 00b1548..0000000 --- a/source/wham/src-NEWSC-NEWCORR/a.sh +++ /dev/null @@ -1,9 +0,0 @@ -a=1 -echo $a -while [ $a -lt 10 ] -do - a=`expr $a + 1` -done -echo $a -b=`expr $a / 5` -echo a=$a b=$b diff --git a/source/wham/src-NEWSC-NEWCORR/angnorm.f b/source/wham/src-NEWSC-NEWCORR/angnorm.f deleted file mode 100644 index 2d17942..0000000 --- a/source/wham/src-NEWSC-NEWCORR/angnorm.f +++ /dev/null @@ -1,439 +0,0 @@ - subroutine add_angpair(ici,icj,nang_pair,iang_pair) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - integer ici,icj,nang_pair,iang_pair(2,maxres) - integer i,ian1,ian2 -c write (iout,*) "add_angpair: ici",ici," icj",icj, -c & " nang_pair",nang_pair - ian1=ici+2 - if (ian1.lt.4 .or. ian1.gt.nres) return - ian2=icj+2 -c write (iout,*) "ian1",ian1," ian2",ian2 - if (ian2.lt.4 .or. ian2.gt.nres) return - do i=1,nang_pair - if (ian1.eq.iang_pair(1,i) .and. ian2.eq.iang_pair(2,i)) return - enddo - nang_pair=nang_pair+1 - iang_pair(1,nang_pair)=ian1 - iang_pair(2,nang_pair)=ian2 - return - end -c------------------------------------------------------------------------- - subroutine angnorm(jfrag,ishif1,ishif2,diffang_max,angn,fract, - & lprn) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'DIMENSIONS.COMPAR' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.COMPAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - double precision pinorm,deltang - logical lprn - if (lprn) write (iout,'(80(1h*))') - angn=0.0d0 - nn = 0 - fract = 1.0d0 - npart = npiece(jfrag,1) - nn4 = nstart_sup+3 - nne = min0(nend_sup,nres) - if (lprn) write (iout,*) "nn4",nn4," nne",nne - do i=1,npart - nbeg = ifrag(1,i,jfrag) + 3 - ishif1 - if (nbeg.lt.nn4) nbeg=nn4 - nend = ifrag(2,i,jfrag) + 1 - ishif2 - if (nend.gt.nne) nend=nne - if (nend.ge.nbeg) then - nn = nn + nend - nbeg + 1 - if (lprn) write (iout,*) "i=",i," nbeg",nbeg," nend",nend, - & " nn",nn," ishift1",ishif1," ishift2",ishif2 - if (lprn) write (iout,*) "angles" - longest=0 - ll = 0 - do j=nbeg,nend -c deltang = pinorm(phi(j)-phi_ref(j+ishif1)) - deltang=spherang(phi_ref(j+ishif1),theta_ref(j-1+ishif1), - & theta_ref(j+ishif1),phi(j),theta(j-1),theta(j)) - if (dabs(deltang).gt.diffang_max) then - if (ll.gt.longest) longest = ll - ll = 0 - else - ll=ll+1 - endif - if (ll.gt.longest) longest = ll - if (lprn) write (iout,'(i5,3f10.5)')j,rad2deg*phi(j), - & rad2deg*phi_ref(j+ishif1),rad2deg*deltang - angn=angn+dabs(deltang) - enddo - longest=longest+3 - ff = dfloat(longest)/dfloat(nend - nbeg + 4) - if (lprn) write (iout,*)"segment",i," longest fragment within", - & diffang_max*rad2deg,":",longest," fraction",ff - if (ff.lt.fract) fract = ff - endif - enddo - if (nn.gt.0) then - angn = angn/nn - else - angn = dwapi - endif - if (lprn) write (iout,*) "nn",nn," norm",rad2deg*angn, - & " fract",fract - return - end -c------------------------------------------------------------------------- - subroutine angnorm2(jfrag,ishif1,ishif2,ncont,icont,lprn, - & diffang_max,anorm,fract) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'DIMENSIONS.COMPAR' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.COMPAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - integer ncont,icont(2,ncont),longest - double precision anorm,diffang_max,fract - integer npiece_c,ifrag_c(2,maxpiece),ishift_c(maxpiece) - double precision pinorm - logical lprn - if (lprn) write (iout,'(80(1h*))') -c -c Determine the segments for which angles will be compared -c - nn4 = nstart_sup+3 - nne = min0(nend_sup,nres) - if (lprn) write (iout,*) "nn4",nn4," nne",nne - npart=npiece(jfrag,1) - npiece_c=0 - do i=1,npart -c write (iout,*) "i",i," ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) - if (icont(1,ncont).lt.ifrag(1,i,jfrag) .or. - & icont(1,1).gt.ifrag(2,i,jfrag)) goto 11 - jstart=1 - do while (jstart.lt.ncont .and. - & icont(1,jstart).lt.ifrag(1,i,jfrag)) -c write (iout,*) "jstart",jstart," icont",icont(1,jstart), -c & " ifrag",ifrag(1,i,jfrag) - jstart=jstart+1 - enddo -c write (iout,*) "jstart",jstart," icont",icont(1,jstart), -c & " ifrag",ifrag(1,i,jfrag) - if (icont(1,jstart).lt.ifrag(1,i,jfrag)) goto 11 - npiece_c=npiece_c+1 - ic1=icont(1,jstart) - ifrag_c(1,npiece_c)=icont(1,jstart) - jend=ncont - do while (jend.gt.1 .and. icont(1,jend).gt.ifrag(2,i,jfrag)) -c write (iout,*) "jend",jend," icont",icont(1,jend), -c & " ifrag",ifrag(2,i,jfrag) - jend=jend-1 - enddo -c write (iout,*) "jend",jend," icont",icont(1,jend), -c & " ifrag",ifrag(2,i,jfrag) - ic2=icont(1,jend) - ifrag_c(2,npiece_c)=icont(1,jend)+1 - ishift_c(npiece_c)=ishif1 -c write (iout,*) "1: i",i," jstart:",jstart," jend",jend, -c & " ic1",ic1," ic2",ic2, -c & " ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) - 11 continue - if (ncont.eq.1 .or. icont(2,ncont).gt.icont(2,1)) then - idi=1 - else - idi=-1 - endif -c write (iout,*) "idi",idi - if (idi.eq.1) then - if (icont(2,1).gt.ifrag(2,i,jfrag) .or. - & icont(2,ncont).lt.ifrag(1,i,jfrag)) goto 12 - jstart=1 - do while (jstart.lt.ncont .and. - & icont(2,jstart).lt.ifrag(1,i,jfrag)) -c write (iout,*) "jstart",jstart," icont",icont(2,jstart), -c & " ifrag",ifrag(1,i,jfrag) - jstart=jstart+1 - enddo -c write (iout,*) "jstart",jstart," icont",icont(2,jstart), -c & " ifrag",ifrag(1,i,jfrag) - if (icont(2,jstart).lt.ifrag(1,i,jfrag)) goto 12 - npiece_c=npiece_c+1 - ic1=icont(2,jstart) - ifrag_c(2,npiece_c)=icont(2,jstart)+1 - jend=ncont - do while (jend.gt.1 .and. icont(2,jend).gt.ifrag(2,i,jfrag)) -c write (iout,*) "jend",jend," icont",icont(2,jend), -c & " ifrag",ifrag(2,i,jfrag) - jend=jend-1 - enddo -c write (iout,*) "jend",jend," icont",icont(2,jend), -c & " ifrag",ifrag(2,i,jfrag) - else if (idi.eq.-1) then - if (icont(2,ncont).gt.ifrag(2,i,jfrag) .or. - & icont(2,1).lt.ifrag(1,i,jfrag)) goto 12 - jstart=ncont - do while (jstart.gt.ncont .and. - & icont(2,jstart).lt.ifrag(1,i,jfrag)) -c write (iout,*) "jstart",jstart," icont",icont(2,jstart), -c & " ifrag",ifrag(1,i,jfrag) - jstart=jstart-1 - enddo -c write (iout,*) "jstart",jstart," icont",icont(2,jstart), -c & " ifrag",ifrag(1,i,jfrag) - if (icont(2,jstart).lt.ifrag(1,i,jfrag)) goto 12 - npiece_c=npiece_c+1 - ic1=icont(2,jstart) - ifrag_c(2,npiece_c)=icont(2,jstart)+1 - jend=1 - do while (jend.lt.ncont .and. - & icont(2,jend).gt.ifrag(2,i,jfrag)) -c write (iout,*) "jend",jend," icont",icont(2,jend), -c & " ifrag",ifrag(2,i,jfrag) - jend=jend+1 - enddo -c write (iout,*) "jend",jend," icont",icont(2,jend), -c & " ifrag",ifrag(2,i,jfrag) - endif - ic2=icont(2,jend) - if (ic2.lt.ic1) then - iic = ic1 - ic1 = ic2 - ic2 = iic - endif -c write (iout,*) "2: i",i," ic1",ic1," ic2",ic2, -c & " jstart:",jstart," jend",jend, -c & " ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) - ifrag_c(1,npiece_c)=ic1 - ifrag_c(2,npiece_c)=ic2+1 - ishift_c(npiece_c)=ishif2 - 12 continue - enddo - if (lprn) then - write (iout,*) "Before merge: npiece_c",npiece_c - do i=1,npiece_c - write (iout,*) ifrag_c(1,i),ifrag_c(2,i),ishift_c(i) - enddo - endif -c -c Merge overlapping segments (e.g., avoid splitting helices) -c - i=1 - do while (i .lt. npiece_c) - if (ishift_c(i).eq.ishift_c(i+1) .and. - & ifrag_c(2,i).gt.ifrag_c(1,i+1)) then - ifrag_c(2,i)=ifrag_c(2,i+1) - do j=i+1,npiece_c - ishift_c(j)=ishift_c(j+1) - ifrag_c(1,j)=ifrag_c(1,j+1) - ifrag_c(2,j)=ifrag_c(2,j+1) - enddo - npiece_c=npiece_c-1 - else - i=i+1 - endif - enddo - if (lprn) then - write (iout,*) "After merge: npiece_c",npiece_c - do i=1,npiece_c - write (iout,*) ifrag_c(1,i),ifrag_c(2,i),ishift_c(i) - enddo - endif -c -c Compare angles -c - angn=0.0d0 - anorm=0 - nn = 0 - fract = 1.0d0 - npart = npiece_c - do i=1,npart - ishifc=ishift_c(i) - nbeg = ifrag_c(1,i) + 3 - ishifc - if (nbeg.lt.nn4) nbeg=nn4 - nend = ifrag_c(2,i) - ishifc + 1 - if (nend.gt.nne) nend=nne - if (nend.ge.nbeg) then - nn = nn + nend - nbeg + 1 - if (lprn) write (iout,*) "i=",i," nbeg",nbeg," nend",nend, - & " nn",nn," ishifc",ishifc - if (lprn) write (iout,*) "angles" - longest=0 - ll = 0 - do j=nbeg,nend -c deltang = pinorm(phi(j)-phi_ref(j+ishifc)) - deltang=spherang(phi_ref(j+ishifc),theta_ref(j-1+ishifc), - & theta_ref(j+ishifc),phi(j),theta(j-1),theta(j)) - if (dabs(deltang).gt.diffang_max) then - if (ll.gt.longest) longest = ll - ll = 0 - else - ll=ll+1 - endif - if (ll.gt.longest) longest = ll - if (lprn) write (iout,'(i5,3f10.5)')j,rad2deg*phi(j), - & rad2deg*phi_ref(j+ishifc),rad2deg*deltang - angn=angn+dabs(deltang) - enddo - longest=longest+3 - ff = dfloat(longest)/dfloat(nend - nbeg + 4) - if (lprn) write (iout,*)"segment",i," longest fragment within", - & diffang_max*rad2deg,":",longest," fraction",ff - if (ff.lt.fract) fract = ff - endif - enddo - if (nn.gt.0) anorm = angn/nn - if (lprn) write (iout,*) "nn",nn," norm",anorm," fract:",fract - return - end -c------------------------------------------------------------------------- - double precision function angnorm1(nang_pair,iang_pair,lprn) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'DIMENSIONS.COMPAR' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.COMPAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - logical lprn - integer nang_pair,iang_pair(2,maxres) - double precision pinorm - angn=0.0d0 - if (lprn) write (iout,'(80(1h*))') - if (lprn) write (iout,*) "nang_pair",nang_pair - if (lprn) write (iout,*) "angles" - do j=1,nang_pair - ia1 = iang_pair(1,j) - ia2 = iang_pair(2,j) -c deltang = pinorm(phi(ia1)-phi_ref(ia2)) - deltang=spherang(phi_ref(ia2),theta_ref(ia2-1), - & theta_ref(ia2),phi(ia2),theta(ia2-1),theta(ia2)) - if (lprn) write (iout,'(3i5,3f10.5)')j,ia1,ia2,rad2deg*phi(ia1), - & rad2deg*phi_ref(ia2),rad2deg*deltang - angn=angn+dabs(deltang) - enddo - if (lprn) - &write (iout,*)"nang_pair",nang_pair," angn",rad2deg*angn/nang_pair - angnorm1 = angn/nang_pair - return - end -c------------------------------------------------------------------------------ - subroutine angnorm12(diff) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'DIMENSIONS.COMPAR' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.COMPAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - double precision pinorm - diff=0.0d0 - nn4 = nstart_sup+3 - nne = min0(nend_sup,nres) -c do j=nn4-1,nne -c diff = diff+rad2deg*dabs(pinorm(theta(j)-theta_ref(j))) -c enddo - do j=nn4,nne -c diff = diff+rad2deg*dabs(pinorm(phi(j)-phi_ref(j))) - diff=diff+spherang(phi_ref(j),theta_ref(j-1), - & theta_ref(j),phi(j),theta(j-1),theta(j)) - enddo - return - end -c-------------------------------------------------------------------------------- - double precision function spherang(gam1,theta11,theta12, - & gam2,theta21,theta22) - implicit none - double precision gam1,theta11,theta12,gam2,theta21,theta22, - & x1,x2,xmed,f1,f2,fmed - double precision tolx /1.0d-4/, tolf /1.0d-4/ - double precision sumcos - double precision arcos,pinorm,sumangp - integer it,maxit /100/ -c Calculate the difference of the angles of two superposed 4-redidue fragments -c -c O P -c \ / -c O'--C--C -c \ -c P' -c -c The fragment O'-C-C-P' is rotated by angle fi about the C-C axis -c to achieve the minimum difference between the O'-C-O and P-C-P angles; -c the sum of these angles is the difference returned by the function. -c -c 4/28/04 AL -c If thetas match, take the difference of gamma and exit. - if (dabs(theta11-theta12).lt.tolx - & .and. dabs(theta21-theta22).lt.tolx) then - spherang=dabs(pinorm(gam2-gam1)) - return - endif -c If the gammas are the same, take the difference of thetas and exit. - x1=0.0d0 - x2=0.5d0*pinorm(gam2-gam1) - if (dabs(x2) .lt. tolx) then - spherang=dabs(theta11-theta21)+dabs(theta12-theta22) - return - else if (x2.lt.0.0d0) then - x1=x2 - x2=0.0d0 - endif -c Else apply regula falsi method to compute optimum overlap of the terminal Calphas - f1=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,x1) - f2=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,x2) - do it=1,maxit - xmed=x1-f1*(x2-x1)/(f2-f1) - fmed=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,xmed) -c write (*,*) 'it',it,' xmed ',xmed,' fmed ',fmed - if ( (dabs(xmed-x1).lt.tolx .or. dabs(x2-xmed).lt.tolx) - & .and. dabs(fmed).lt.tolf ) then - x1=xmed - f1=fmed - goto 10 - else if ( fmed*f1.lt.0.0d0 ) then - x2=xmed - f2=fmed - else - x1=xmed - f1=fmed - endif - enddo - 10 continue - spherang=arcos(dcos(theta11)*dcos(theta12) - & +dsin(theta11)*dsin(theta12)*dcos(x1))+ - & arcos(dcos(theta21)*dcos(theta22)+ - & dsin(theta21)*dsin(theta22)*dcos(gam2-gam1+x1)) - return - end -c-------------------------------------------------------------------------------- - double precision function sumangp(gam1,theta11,theta12,gam2, - & theta21,theta22,fi) - implicit none - double precision gam1,theta11,theta12,gam2,theta21,theta22,fi, - & cost11,cost12,cost21,cost22,sint11,sint12,sint21,sint22,cosd1, - & cosd2 -c derivarive of the sum of the difference of the angles of a 4-residue fragment. - double precision arcos - cost11=dcos(theta11) - cost12=dcos(theta12) - cost21=dcos(theta21) - cost22=dcos(theta22) - sint11=dsin(theta11) - sint12=dsin(theta12) - sint21=dsin(theta21) - sint22=dsin(theta22) - cosd1=cost11*cost12+sint11*sint12*dcos(fi) - cosd2=cost21*cost22+sint21*sint22*dcos(gam2-gam1+fi) - sumangp=sint11*sint12*dsin(fi)/dsqrt(1.0d0-cosd1*cosd1) - & +sint21*sint22*dsin(gam2-gam1+fi)/dsqrt(1.0d0-cosd2*cosd2) - return - end diff --git a/source/wham/src-NEWSC-NEWCORR/arcos.f b/source/wham/src-NEWSC-NEWCORR/arcos.f deleted file mode 100644 index 69810ea..0000000 --- a/source/wham/src-NEWSC-NEWCORR/arcos.f +++ /dev/null @@ -1,9 +0,0 @@ - FUNCTION ARCOS(X) - implicit real*8 (a-h,o-z) - include 'COMMON.GEO' - IF (DABS(X).LT.1.0D0) GOTO 1 - ARCOS=0.5D0*(PI+DSIGN(1.0D0,X)*PI) - RETURN - 1 ARCOS=DACOS(X) - RETURN - END diff --git a/source/wham/src-NEWSC-NEWCORR/bxread.F b/source/wham/src-NEWSC-NEWCORR/bxread.F deleted file mode 100644 index c459499..0000000 --- a/source/wham/src-NEWSC-NEWCORR/bxread.F +++ /dev/null @@ -1,89 +0,0 @@ - subroutine bxread(nazwa,islice,ii,jj,kk,ll,mm,iR,ib,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.PROTFILES" - include "COMMON.NAMES" - include "COMMON.VAR" - include "COMMON.GEO" - include "COMMON.ENEPS" - include "COMMON.PROT" - include "COMMON.INTERACT" - include "COMMON.FREE" - include "COMMON.SBRIDGE" - real*4 csingle(3,maxres2) - character*64 nazwa,bprotfile_temp - character*3 liczba - integer i,is,ie,j,ii,jj,k,kk,l,ll,mm,if - integer nrec,nlines,iscor,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(0:maxprocs-1) - integer iparm,ib,iib,ir,nprop,nthr,nrec_slice - double precision etot,time - logical lerr - nrec_slice=(rec_end(iR,ib,iparm)-rec_start(iR,ib,iparm)+1)/nslice - is=rec_start(iR,ib,iparm)+(islice-1)*nrec_slice - ie=rec_start(iR,ib,iparm)+islice*nrec_slice-1 - write (iout,*) "bxread: islice",islice," nslice",nslice, - & " nrec_slice",nrec_slice - write (iout,*) "is",is," ie",ie,"rec_start", - & rec_start(iR,ib,iparm)," rec_end",rec_end(iR,ib,iparm) - do i=is,ie - read(ientin,rec=i+1,err=101) - & ((csingle(l,k),l=1,3),k=1,nres), - & ((csingle(l,k+nres),l=1,3),k=nnt,nct), - & nss,(ihpb(k),jhpb(k),k=1,nss), - & eini,efree,rmsdev,(prop(j),j=1,nQ),iscor - ii=ii+1 - kk=kk+1 - if (mod(kk,isampl(iparm)).eq.0) then - jj=jj+1 - write(ientout,rec=jj) - & ((csingle(l,k),l=1,3),k=1,nres), - & ((csingle(l,k+nres),l=1,3),k=nnt,nct), - & nss,(ihpb(k),jhpb(k),k=1,nss), - & eini,efree,rmsdev,(prop(j),j=1,nQ),iR,ib,iparm -#ifdef DEBUG - do i=1,2*nres - do j=1,3 - c(j,i)=csingle(j,i) - enddo - enddo - call int_from_cart1(.false.) - write (iout,*) "Writing conformation, record",jj - write (iout,*) "Cartesian coordinates" - write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) - write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) - write (iout,*) "Internal coordinates" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) - write (iout,'(f10.5,i5)') rmsdev,iscor -#endif - endif - enddo - 101 continue - close(ientin) - write (iout,*) ii," conformations read from DA file ", - & nazwa(:ilen(nazwa)) - write (iout,*) kk," conformations read so far, slice",islice - write (iout,*) jj," conformations stored so far, slice",islice - - return - end diff --git a/source/wham/src-NEWSC-NEWCORR/cartder.f b/source/wham/src-NEWSC-NEWCORR/cartder.f deleted file mode 100644 index ed14f18..0000000 --- a/source/wham/src-NEWSC-NEWCORR/cartder.f +++ /dev/null @@ -1,306 +0,0 @@ - subroutine cartder - implicit real*8 (a-h,o-z) -*********************************************************************** -* This subroutine calculates the derivatives of the consecutive virtual -* bond vectors and the SC vectors in the virtual-bond angles theta and -* virtual-torsional angles phi, as well as the derivatives of SC vectors -* in the angles alpha and omega, describing the location of a side chain -* in its local coordinate system. -* -* The derivatives are stored in the following arrays: -* -* DDCDV - the derivatives of virtual-bond vectors DC in theta and phi. -* The structure is as follows: -* -* dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0, 0, 0 -* dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4) -* . . . . . . . . . . . . . . . . . . -* dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4) -* . -* . -* . -* dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N) -* -* DXDV - the derivatives of the side-chain vectors in theta and phi. -* The structure is same as above. -* -* DCDS - the derivatives of the side chain vectors in the local spherical -* andgles alph and omega: -* -* dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2) -* dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3) -* . -* . -* . -* dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1) -* -* Version of March '95, based on an early version of November '91. -* -*********************************************************************** - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - dimension drt(3,3,maxres),rdt(3,3,maxres),dp(3,3),temp(3,3), - & fromto(3,3,maxdim),prordt(3,3,maxres),prodrt(3,3,maxres) - dimension xx(3),xx1(3) -* get the position of the jth ijth fragment of the chain coordinate system -* in the fromto array. - indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 -* -* calculate the derivatives of transformation matrix elements in theta -* - do i=1,nres-2 - rdt(1,1,i)=-rt(1,2,i) - rdt(1,2,i)= rt(1,1,i) - rdt(1,3,i)= 0.0d0 - rdt(2,1,i)=-rt(2,2,i) - rdt(2,2,i)= rt(2,1,i) - rdt(2,3,i)= 0.0d0 - rdt(3,1,i)=-rt(3,2,i) - rdt(3,2,i)= rt(3,1,i) - rdt(3,3,i)= 0.0d0 - enddo -* -* derivatives in phi -* - do i=2,nres-2 - drt(1,1,i)= 0.0d0 - drt(1,2,i)= 0.0d0 - drt(1,3,i)= 0.0d0 - drt(2,1,i)= rt(3,1,i) - drt(2,2,i)= rt(3,2,i) - drt(2,3,i)= rt(3,3,i) - drt(3,1,i)=-rt(2,1,i) - drt(3,2,i)=-rt(2,2,i) - drt(3,3,i)=-rt(2,3,i) - enddo -* -* generate the matrix products of type r(i)t(i)...r(j)t(j) -* - do i=2,nres-2 - ind=indmat(i,i+1) - do k=1,3 - do l=1,3 - temp(k,l)=rt(k,l,i) - enddo - enddo - do k=1,3 - do l=1,3 - fromto(k,l,ind)=temp(k,l) - enddo - enddo - do j=i+1,nres-2 - ind=indmat(i,j+1) - do k=1,3 - do l=1,3 - dpkl=0.0d0 - do m=1,3 - dpkl=dpkl+temp(k,m)*rt(m,l,j) - enddo - dp(k,l)=dpkl - fromto(k,l,ind)=dpkl - enddo - enddo - do k=1,3 - do l=1,3 - temp(k,l)=dp(k,l) - enddo - enddo - enddo - enddo -* -* Calculate derivatives. -* - ind1=0 - do i=1,nres-2 - ind1=ind1+1 -* -* Derivatives of DC(i+1) in theta(i+2) -* - do j=1,3 - do k=1,2 - dpjk=0.0D0 - do l=1,3 - dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) - enddo - dp(j,k)=dpjk - prordt(j,k,i)=dp(j,k) - enddo - dp(j,3)=0.0D0 - dcdv(j,ind1)=vbl*dp(j,1) - enddo -* -* Derivatives of SC(i+1) in theta(i+2) -* - xx1(1)=-0.5D0*xloc(2,i+1) - xx1(2)= 0.5D0*xloc(1,i+1) - do j=1,3 - xj=0.0D0 - do k=1,2 - xj=xj+r(j,k,i)*xx1(k) - enddo - xx(j)=xj - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i)*xx(k) - enddo - dxdv(j,ind1)=rj - enddo -* -* Derivatives of SC(i+1) in theta(i+3). The have to be handled differently -* than the other off-diagonal derivatives. -* - do j=1,3 - dxoiij=0.0D0 - do k=1,3 - dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) - enddo - dxdv(j,ind1+1)=dxoiij - enddo -cd print *,ind1+1,(dxdv(j,ind1+1),j=1,3) -* -* Derivatives of DC(i+1) in phi(i+2) -* - do j=1,3 - do k=1,3 - dpjk=0.0 - do l=2,3 - dpjk=dpjk+prod(j,l,i)*drt(l,k,i) - enddo - dp(j,k)=dpjk - prodrt(j,k,i)=dp(j,k) - enddo - dcdv(j+3,ind1)=vbl*dp(j,1) - enddo -* -* Derivatives of SC(i+1) in phi(i+2) -* - xx(1)= 0.0D0 - xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i) - xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i) - do j=1,3 - rj=0.0D0 - do k=2,3 - rj=rj+prod(j,k,i)*xx(k) - enddo - dxdv(j+3,ind1)=-rj - enddo -* -* Derivatives of SC(i+1) in phi(i+3). -* - do j=1,3 - dxoiij=0.0D0 - do k=1,3 - dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) - enddo - dxdv(j+3,ind1+1)=dxoiij - enddo -* -* Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru -* theta(nres) and phi(i+3) thru phi(nres). -* - do j=i+1,nres-2 - ind1=ind1+1 - ind=indmat(i+1,j+1) -cd print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 - do k=1,3 - do l=1,3 - tempkl=0.0D0 - do m=1,2 - tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind) - enddo - temp(k,l)=tempkl - enddo - enddo -cd print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3) -cd print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3) -cd print '(9f8.3)',((temp(k,l),l=1,3),k=1,3) -* Derivatives of virtual-bond vectors in theta - do k=1,3 - dcdv(k,ind1)=vbl*temp(k,1) - enddo -cd print '(3f8.3)',(dcdv(k,ind1),k=1,3) -* Derivatives of SC vectors in theta - do k=1,3 - dxoijk=0.0D0 - do l=1,3 - dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) - enddo - dxdv(k,ind1+1)=dxoijk - enddo -* -*--- Calculate the derivatives in phi -* - do k=1,3 - do l=1,3 - tempkl=0.0D0 - do m=1,3 - tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind) - enddo - temp(k,l)=tempkl - enddo - enddo - do k=1,3 - dcdv(k+3,ind1)=vbl*temp(k,1) - enddo - do k=1,3 - dxoijk=0.0D0 - do l=1,3 - dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) - enddo - dxdv(k+3,ind1+1)=dxoijk - enddo - enddo - enddo -* -* Derivatives in alpha and omega: -* - do i=2,nres-1 - dsci=dsc(itype(i)) - alphi=alph(i) - omegi=omeg(i) -cd print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - temp(1,1)=-dsci*sinalphi - temp(2,1)= dsci*cosalphi*cosomegi - temp(3,1)=-dsci*cosalphi*sinomegi - temp(1,2)=0.0D0 - temp(2,2)=-dsci*sinalphi*sinomegi - temp(3,2)=-dsci*sinalphi*cosomegi - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - jjj=0 -cd print *,((temp(l,k),l=1,3),k=1,2) - do j=1,2 - xp=temp(1,j) - yp=temp(2,j) - xxp= xp*cost2+yp*sint2 - yyp=-xp*sint2+yp*cost2 - zzp=temp(3,j) - xx(1)=xxp - xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) - xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) - do k=1,3 - dj=0.0D0 - do l=1,3 - dj=dj+prod(k,l,i-1)*xx(l) - enddo - dxds(jjj+k,i)=dj - enddo - jjj=jjj+3 - enddo - enddo - return - end - diff --git a/source/wham/src-NEWSC-NEWCORR/cartprint.f b/source/wham/src-NEWSC-NEWCORR/cartprint.f deleted file mode 100644 index fd8ffe3..0000000 --- a/source/wham/src-NEWSC-NEWCORR/cartprint.f +++ /dev/null @@ -1,20 +0,0 @@ - subroutine cartprint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - write (iout,100) - do i=1,nres - write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i), - & c(3,i),c(1,nres+i),c(2,nres+i),c(3,nres+i) - enddo - 100 format (//' alpha-carbon coordinates ', - & ' centroid coordinates'/ - 1 ' ', 6X,'X',11X,'Y',11X,'Z', - & 10X,'X',11X,'Y',11X,'Z') - 110 format (a,'(',i3,')',6f12.5) - return - end diff --git a/source/wham/src-NEWSC-NEWCORR/chainbuild.F b/source/wham/src-NEWSC-NEWCORR/chainbuild.F deleted file mode 100644 index 4c9f32f..0000000 --- a/source/wham/src-NEWSC-NEWCORR/chainbuild.F +++ /dev/null @@ -1,281 +0,0 @@ - subroutine chainbuild -C -C Build the virtual polypeptide chain. Side-chain centroids are moveable. -C As of 2/17/95. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - logical lprn -C Set lprn=.true. for debugging - lprn = .false. -C -C Define the origin and orientation of the coordinate system and locate the -C first three CA's and SC(2). -C - call orig_frame -* -* Build the alpha-carbon chain. -* - do i=4,nres - call locate_next_res(i) - enddo -C -C First and last SC must coincide with the corresponding CA. -C - do j=1,3 - dc(j,nres+1)=0.0D0 - dc_norm(j,nres+1)=0.0D0 - dc(j,nres+nres)=0.0D0 - dc_norm(j,nres+nres)=0.0D0 - c(j,nres+1)=c(j,1) - c(j,nres+nres)=c(j,nres) - enddo -* -* Temporary diagnosis -* - if (lprn) then - - call cartprint - write (iout,'(/a)') 'Recalculated internal coordinates' - do i=2,nres-1 - do j=1,3 - c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) - enddo - be=0.0D0 - if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i) - be1=rad2deg*beta(nres+i,i,maxres2,i+1) - alfai=0.0D0 - if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i) - write (iout,1212) restyp(itype(i)),i,dist(i-1,i), - & alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,maxres2),be1 - enddo - 1212 format (a3,'(',i3,')',2(f10.5,2f10.2)) - - endif - - return - end -c------------------------------------------------------------------------- - subroutine orig_frame -C -C Define the origin and orientation of the coordinate system and locate -C the first three atoms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - cost=dcos(theta(3)) - sint=dsin(theta(3)) - t(1,1,1)=-cost - t(1,2,1)=-sint - t(1,3,1)= 0.0D0 - t(2,1,1)=-sint - t(2,2,1)= cost - t(2,3,1)= 0.0D0 - t(3,1,1)= 0.0D0 - t(3,2,1)= 0.0D0 - t(3,3,1)= 1.0D0 - r(1,1,1)= 1.0D0 - r(1,2,1)= 0.0D0 - r(1,3,1)= 0.0D0 - r(2,1,1)= 0.0D0 - r(2,2,1)= 1.0D0 - r(2,3,1)= 0.0D0 - r(3,1,1)= 0.0D0 - r(3,2,1)= 0.0D0 - r(3,3,1)= 1.0D0 - do i=1,3 - do j=1,3 - rt(i,j,1)=t(i,j,1) - enddo - enddo - do i=1,3 - do j=1,3 - prod(i,j,1)=0.0D0 - prod(i,j,2)=t(i,j,1) - enddo - prod(i,i,1)=1.0D0 - enddo - c(1,1)=0.0D0 - c(2,1)=0.0D0 - c(3,1)=0.0D0 - c(1,2)=vbld(2) - c(2,2)=0.0D0 - c(3,2)=0.0D0 - dc(1,1)=vbld(2) - dc(2,1)=0.0D0 - dc(3,1)=0.0D0 - dc_norm(1,1)=1.0D0 - dc_norm(2,1)=0.0D0 - dc_norm(3,1)=0.0D0 - do j=1,3 - dc_norm(j,2)=prod(j,1,2) - dc(j,2)=vbld(3)*prod(j,1,2) - c(j,3)=c(j,2)+dc(j,2) - enddo - call locate_side_chain(2) - return - end -c----------------------------------------------------------------------------- - subroutine locate_next_res(i) -C -C Locate CA(i) and SC(i-1) -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' -C -C Define the rotation matrices corresponding to CA(i) -C -#ifdef OSF - theti=theta(i) - icrc=0 - call proc_proc(theti,icrc) - if(icrc.eq.1)theti=100.0 - phii=phi(i) - icrc=0 - call proc_proc(phii,icrc) - if(icrc.eq.1)phii=180.0 -#else - theti=theta(i) - phii=phi(i) -#endif - cost=dcos(theti) - sint=dsin(theti) - cosphi=dcos(phii) - sinphi=dsin(phii) -* Define the matrices of the rotation about the virtual-bond valence angles -* theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this -* program), R(i,j,k), and, the cumulative matrices of rotation RT - t(1,1,i-2)=-cost - t(1,2,i-2)=-sint - t(1,3,i-2)= 0.0D0 - t(2,1,i-2)=-sint - t(2,2,i-2)= cost - t(2,3,i-2)= 0.0D0 - t(3,1,i-2)= 0.0D0 - t(3,2,i-2)= 0.0D0 - t(3,3,i-2)= 1.0D0 - r(1,1,i-2)= 1.0D0 - r(1,2,i-2)= 0.0D0 - r(1,3,i-2)= 0.0D0 - r(2,1,i-2)= 0.0D0 - r(2,2,i-2)=-cosphi - r(2,3,i-2)= sinphi - r(3,1,i-2)= 0.0D0 - r(3,2,i-2)= sinphi - r(3,3,i-2)= cosphi - rt(1,1,i-2)=-cost - rt(1,2,i-2)=-sint - rt(1,3,i-2)=0.0D0 - rt(2,1,i-2)=sint*cosphi - rt(2,2,i-2)=-cost*cosphi - rt(2,3,i-2)=sinphi - rt(3,1,i-2)=-sint*sinphi - rt(3,2,i-2)=cost*sinphi - rt(3,3,i-2)=cosphi - call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1)) - do j=1,3 - dc_norm(j,i-1)=prod(j,1,i-1) - dc(j,i-1)=vbld(i)*prod(j,1,i-1) - c(j,i)=c(j,i-1)+dc(j,i-1) - enddo -cd print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3) -C -C Now calculate the coordinates of SC(i-1) -C - call locate_side_chain(i-1) - return - end -c----------------------------------------------------------------------------- - subroutine locate_side_chain(i) -C -C Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - dimension xx(3) - -c dsci=dsc(itype(i)) -c dsci_inv=dsc_inv(itype(i)) - dsci=vbld(i+nres) - dsci_inv=vbld_inv(i+nres) -#ifdef OSF - alphi=alph(i) - omegi=omeg(i) -c detecting NaNQ - icrc=0 - call proc_proc(alphi,icrc) - if(icrc.eq.1)alphi=100.0 - icrc=0 - call proc_proc(omegi,icrc) - if(icrc.eq.1)omegi=-100.0 -#else - alphi=alph(i) - omegi=omeg(i) -#endif - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - xp= dsci*cosalphi - yp= dsci*sinalphi*cosomegi - zp=-dsci*sinalphi*sinomegi -* Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its -* X-axis aligned with the vector DC(*,i) - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - xx(1)= xp*cost2+yp*sint2 - xx(2)=-xp*sint2+yp*cost2 - xx(3)= zp -cd print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i, -cd & xp,yp,zp,(xx(k),k=1,3) - do j=1,3 - xloc(j,i)=xx(j) - enddo -* Bring the SC vectors to the common coordinate system. - xx(1)=xloc(1,i) - xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1) - xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1) - do j=1,3 - xrot(j,i)=xx(j) - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i-1)*xx(k) - enddo - dc(j,nres+i)=rj - dc_norm(j,nres+i)=rj*dsci_inv - c(j,nres+i)=c(j,i)+rj - enddo - return - end diff --git a/source/wham/src-NEWSC-NEWCORR/chainbuild.f b/source/wham/src-NEWSC-NEWCORR/chainbuild.f deleted file mode 100644 index 26afd44..0000000 --- a/source/wham/src-NEWSC-NEWCORR/chainbuild.f +++ /dev/null @@ -1,258 +0,0 @@ - subroutine chainbuild -C -C Build the virtual polypeptide chain. Side-chain centroids are moveable. -C As of 2/17/95. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - logical lprn -C Set lprn=.true. for debugging - lprn = .false. -C -C Define the origin and orientation of the coordinate system and locate the -C first three CA's and SC(2). -C - call orig_frame -* -* Build the alpha-carbon chain. -* - do i=4,nres - call locate_next_res(i) - enddo -C -C First and last SC must coincide with the corresponding CA. -C - do j=1,3 - dc(j,nres+1)=0.0D0 - dc_norm(j,nres+1)=0.0D0 - dc(j,nres+nres)=0.0D0 - dc_norm(j,nres+nres)=0.0D0 - c(j,nres+1)=c(j,1) - c(j,nres+nres)=c(j,nres) - enddo -* -* Temporary diagnosis -* - if (lprn) then - - call cartprint - write (iout,'(/a)') 'Recalculated internal coordinates' - do i=2,nres-1 - do j=1,3 - c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) - enddo - be=0.0D0 - if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i) - be1=rad2deg*beta(nres+i,i,maxres2,i+1) - alfai=0.0D0 - if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i) - write (iout,1212) restyp(itype(i)),i,dist(i-1,i), - & alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,maxres2),be1 - enddo - 1212 format (a3,'(',i3,')',2(f10.5,2f10.2)) - - endif - - return - end -c------------------------------------------------------------------------- - subroutine orig_frame -C -C Define the origin and orientation of the coordinate system and locate -C the first three atoms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - cost=dcos(theta(3)) - sint=dsin(theta(3)) - t(1,1,1)=-cost - t(1,2,1)=-sint - t(1,3,1)= 0.0D0 - t(2,1,1)=-sint - t(2,2,1)= cost - t(2,3,1)= 0.0D0 - t(3,1,1)= 0.0D0 - t(3,2,1)= 0.0D0 - t(3,3,1)= 1.0D0 - r(1,1,1)= 1.0D0 - r(1,2,1)= 0.0D0 - r(1,3,1)= 0.0D0 - r(2,1,1)= 0.0D0 - r(2,2,1)= 1.0D0 - r(2,3,1)= 0.0D0 - r(3,1,1)= 0.0D0 - r(3,2,1)= 0.0D0 - r(3,3,1)= 1.0D0 - do i=1,3 - do j=1,3 - rt(i,j,1)=t(i,j,1) - enddo - enddo - do i=1,3 - do j=1,3 - prod(i,j,1)=0.0D0 - prod(i,j,2)=t(i,j,1) - enddo - prod(i,i,1)=1.0D0 - enddo - c(1,1)=0.0D0 - c(2,1)=0.0D0 - c(3,1)=0.0D0 - c(1,2)=vbld(2) - c(2,2)=0.0D0 - c(3,2)=0.0D0 - dc(1,1)=vbld(2) - dc(2,1)=0.0D0 - dc(3,1)=0.0D0 - dc_norm(1,1)=1.0D0 - dc_norm(2,1)=0.0D0 - dc_norm(3,1)=0.0D0 - do j=1,3 - dc_norm(j,2)=prod(j,1,2) - dc(j,2)=vbld(3)*prod(j,1,2) - c(j,3)=c(j,2)+dc(j,2) - enddo - call locate_side_chain(2) - return - end -c----------------------------------------------------------------------------- - subroutine locate_next_res(i) -C -C Locate CA(i) and SC(i-1) -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' -C -C Define the rotation matrices corresponding to CA(i) -C - theti=theta(i) - phii=phi(i) - cost=dcos(theti) - sint=dsin(theti) - cosphi=dcos(phii) - sinphi=dsin(phii) -* Define the matrices of the rotation about the virtual-bond valence angles -* theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this -* program), R(i,j,k), and, the cumulative matrices of rotation RT - t(1,1,i-2)=-cost - t(1,2,i-2)=-sint - t(1,3,i-2)= 0.0D0 - t(2,1,i-2)=-sint - t(2,2,i-2)= cost - t(2,3,i-2)= 0.0D0 - t(3,1,i-2)= 0.0D0 - t(3,2,i-2)= 0.0D0 - t(3,3,i-2)= 1.0D0 - r(1,1,i-2)= 1.0D0 - r(1,2,i-2)= 0.0D0 - r(1,3,i-2)= 0.0D0 - r(2,1,i-2)= 0.0D0 - r(2,2,i-2)=-cosphi - r(2,3,i-2)= sinphi - r(3,1,i-2)= 0.0D0 - r(3,2,i-2)= sinphi - r(3,3,i-2)= cosphi - rt(1,1,i-2)=-cost - rt(1,2,i-2)=-sint - rt(1,3,i-2)=0.0D0 - rt(2,1,i-2)=sint*cosphi - rt(2,2,i-2)=-cost*cosphi - rt(2,3,i-2)=sinphi - rt(3,1,i-2)=-sint*sinphi - rt(3,2,i-2)=cost*sinphi - rt(3,3,i-2)=cosphi - call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1)) - do j=1,3 - dc_norm(j,i-1)=prod(j,1,i-1) - dc(j,i-1)=vbld(i)*prod(j,1,i-1) - c(j,i)=c(j,i-1)+dc(j,i-1) - enddo -cd print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3) -C -C Now calculate the coordinates of SC(i-1) -C - call locate_side_chain(i-1) - return - end -c----------------------------------------------------------------------------- - subroutine locate_side_chain(i) -C -C Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - dimension xx(3) - -c dsci=dsc(itype(i)) -c dsci_inv=dsc_inv(itype(i)) - dsci=vbld(i+nres) - dsci_inv=vbld_inv(i+nres) - alphi=alph(i) - omegi=omeg(i) - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - xp= dsci*cosalphi - yp= dsci*sinalphi*cosomegi - zp=-dsci*sinalphi*sinomegi -* Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its -* X-axis aligned with the vector DC(*,i) - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - xx(1)= xp*cost2+yp*sint2 - xx(2)=-xp*sint2+yp*cost2 - xx(3)= zp -cd print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i, -cd & xp,yp,zp,(xx(k),k=1,3) - do j=1,3 - xloc(j,i)=xx(j) - enddo -* Bring the SC vectors to the common coordinate system. - xx(1)=xloc(1,i) - xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1) - xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1) - do j=1,3 - xrot(j,i)=xx(j) - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i-1)*xx(k) - enddo - dc(j,nres+i)=rj - dc_norm(j,nres+i)=rj*dsci_inv - c(j,nres+i)=c(j,i)+rj - enddo - return - end diff --git a/source/wham/src-NEWSC-NEWCORR/compinfo.c b/source/wham/src-NEWSC-NEWCORR/compinfo.c deleted file mode 100644 index e28f686..0000000 --- a/source/wham/src-NEWSC-NEWCORR/compinfo.c +++ /dev/null @@ -1,82 +0,0 @@ -#include -#include -#include -#include -#include - -main() -{ -FILE *in, *in1, *out; -int i,j,k,iv1,iv2,iv3; -char *p1,buf[500],buf1[500],buf2[100],buf3[100]; -struct utsname Name; -time_t Tp; - -in=fopen("cinfo.f","r"); -out=fopen("cinfo.f.new","w"); -if (fgets(buf,498,in) != NULL) - fprintf(out,"C DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C\n"); -if (fgets(buf,498,in) != NULL) - sscanf(&buf[1],"%d %d %d",&iv1,&iv2,&iv3); -iv3++; -fprintf(out,"C %d %d %d\n",iv1,iv2,iv3); -fprintf(out," subroutine cinfo\n"); -fprintf(out," include 'COMMON.IOUNITS'\n"); -fprintf(out," write(iout,*)'++++ Compile info ++++'\n"); -fprintf(out," write(iout,*)'Version %d.%-d build %d'\n",iv1,iv2,iv3); -uname(&Name); -time(&Tp); -system("whoami > tmptmp"); -in1=fopen("tmptmp","r"); -if (fscanf(in1,"%s",buf1) != EOF) -{ -p1=ctime(&Tp); -p1[strlen(p1)-1]='\0'; -fprintf(out," write(iout,*)'compiled %s'\n",p1); -fprintf(out," write(iout,*)'compiled by %s@%s'\n",buf1,Name.nodename); -fprintf(out," write(iout,*)'OS name: %s '\n",Name.sysname); -fprintf(out," write(iout,*)'OS release: %s '\n",Name.release); -fprintf(out," write(iout,*)'OS version:',\n"); -fprintf(out," & ' %s '\n",Name.version); -fprintf(out," write(iout,*)'flags:'\n"); -} -system("rm tmptmp"); -fclose(in1); -in1=fopen("Makefile","r"); -while(fgets(buf,498,in1) != NULL) - { - if((p1=strchr(buf,'=')) != NULL && buf[0] != '#') - { - buf[strlen(buf)-1]='\0'; - if(strlen(buf) > 49) - { - buf[47]='\0'; - strcat(buf,"..."); - } - else - { - while(buf[strlen(buf)-1]=='\\') - { - strcat(buf,"\\"); - fprintf(out," write(iout,*)'%s'\n",buf); - if (fgets(buf,498,in1) != NULL) - buf[strlen(buf)-1]='\0'; - if(strlen(buf) > 49) - { - buf[47]='\0'; - strcat(buf,"..."); - } - } - } - - fprintf(out," write(iout,*)'%s'\n",buf); - } - } -fprintf(out," write(iout,*)'++++ End of compile info ++++'\n"); -fprintf(out," return\n"); -fprintf(out," end\n"); -fclose(out); -fclose(in1); -fclose(in); -system("mv cinfo.f.new cinfo.f"); -} diff --git a/source/wham/src-NEWSC-NEWCORR/conf_compar.F b/source/wham/src-NEWSC-NEWCORR/conf_compar.F deleted file mode 100644 index 4b49345..0000000 --- a/source/wham/src-NEWSC-NEWCORR/conf_compar.F +++ /dev/null @@ -1,374 +0,0 @@ - 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) - integer isecstr(maxres) - integer itemp(maxfrag) - character*4 liczba - double precision Epot -c print *,"Enter conf_compar",jcon - call angnorm12(rmsang) -c Level 1: check secondary and supersecondary structure - call elecont(lprn,ncont,icont,nnt,nct) - call secondary2(lprn,.false.,ncont,icont,isecstr) - call contact(lprn,ncontsc,icontsc,nnt,nct) - if (lprn) write(iout,*) "Assigning electrostatic contacts" - call contacts_between_fragments(lprn,3,ncont,icont,ncont_frag, - & icont_frag) - if (lprn) write(iout,*) "Assigning sidechain contacts" - call contacts_between_fragments(lprn,3,ncontsc,icontsc, - & nsccont_frag,isccont_frag) - 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 - rmsfrag(j,1)=rmscalc(0,1,j,jcon,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" - ncnat=ncont_frag_ref(ind) -c write (iout,*) "before match_contact:",nc_fragm(j,1), -c & nc_req_setf(j,1) - call match_secondary(j,isecstr,nsec_match,lprn) - if (lprn) write (iout,*) "Fragment",j," nsec_match", - & nsec_match," length",len_frag(j,1)," min_len", - & frac_sec*len_frag(j,1) - if (nsec_match.lt.frac_sec*len_frag(j,1)) then - iclass(j,1)=0 - if (lprn) write (iout,*) "Fragment",j, - & " has incorrect secondary structure" - else - iclass(j,1)=1 - if (lprn) write (iout,*) "Fragment",j, - & " has correct secondary structure" - endif - if (ielecont(j,1).gt.0) then - call match_contact(ishif1,ishif2,nc_match,ncon_match, - & ncont_frag_ref(ind),icont_frag_ref(1,1,ind), - & ncont_frag(ind),icont_frag(1,1,ind), - & j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1), - & nc_req_setf(j,1),istruct(j),.true.,lprn) - else if (isccont(j,1).gt.0) then - call match_contact(ishif1,ishif2,nc_match,ncon_match, - & nsccont_frag_ref(ind),isccont_frag_ref(1,1,ind), - & nsccont_frag(ind),isccont_frag(1,1,ind), - & j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1), - & nc_req_setf(j,1),istruct(j),.true.,lprn) - else if (iloc(j).gt.0) then -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),.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) - 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(-ishiff,1,j,jcon,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(ishiff,1,j,jcon,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,.false.,lprn) - ishif=ishif1 - if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 - if (nc_match.gt.0) then - if (ishif.eq.0) then - iclass_con=2 - else - iclass_con=1 - endif - endif - ncont_nat(1,j,i)=nc_match - ncont_nat(2,j,i)=ncon_match - ishifft_con=ishif - else if (i.eq.2 .and. isccont(j,i).gt.0) then - iclass_con=0 - ishifft_con=0 - if (lprn) write (iout,*) - & "Comparing sidechain contact map: fragments", - & ipiece(1,j,i),ipiece(2,j,i)," ind",ind - call match_contact(ishif1,ishif2,nc_match,ncon_match, - & nsccont_frag_ref(ind),isccont_frag_ref(1,1,ind), - & nsccont_frag(ind),isccont_frag(1,1,ind), - & j,n_shift(1,j,i),n_shift(2,j,i),nc_fragm(j,i), - & nc_req_setf(j,i),2,.false.,lprn) - ishif=ishif1 - if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 - if (nc_match.gt.0) then - if (ishif.eq.0) then - iclass_con=2 - else - iclass_con=1 - endif - endif - ncont_nat(1,j,i)=nc_match - ncont_nat(2,j,i)=ncon_match - ishifft_con=ishif - else if (i.eq.2) then - iclass_con=2 - ishifft_con=0 - endif - if (i.eq.2) qfrag(j,2)=qwolynes(2,j) - if (lprn) write (iout,*) - & "Comparing rms: fragments", - & (ipiece(k,j,i),k=1,npiece(j,i)) - rmsfrag(j,i)=rmscalc(0,i,j,jcon,lprn) - if (irms(j,i).gt.0) then - iclass_rms=0 - ishifft_rms=0 - if (lprn) write (iout,*) "rms",rmsfrag(j,i) -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(-ishif,i,j,jcon,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(ishif,i,j,jcon,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 - rms_nat=rmsnat(jcon) - qnat=qwolynes(0,0) -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-NEWSC-NEWCORR/cont_frag.f b/source/wham/src-NEWSC-NEWCORR/cont_frag.f deleted file mode 100644 index 63a7717..0000000 --- a/source/wham/src-NEWSC-NEWCORR/cont_frag.f +++ /dev/null @@ -1,99 +0,0 @@ - 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-NEWSC-NEWCORR/contact.f b/source/wham/src-NEWSC-NEWCORR/contact.f deleted file mode 100644 index 5b05d57..0000000 --- a/source/wham/src-NEWSC-NEWCORR/contact.f +++ /dev/null @@ -1,171 +0,0 @@ - subroutine contact(lprint,ncont,icont,ist,ien) - 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 - 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=itype(i) - do j=i+kkk,ien - itj=itype(j) - itypi=iti - itypj=itj - xj = c(1,nres+j)-c(1,nres+i) - yj = c(2,nres+j)-c(2,nres+i) - zj = c(3,nres+j)-c(3,nres+i) - dxi = dc_norm(1,nres+i) - dyi = dc_norm(2,nres+i) - dzi = dc_norm(3,nres+i) - dxj = dc_norm(1,nres+j) - dyj = dc_norm(2,nres+j) - dzj = dc_norm(3,nres+j) - do k=1,3 - a(k)=dc(k,nres+i) - b(k)=dc(k,nres+j) - enddo -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(it1,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-NEWSC-NEWCORR/contfunc.f b/source/wham/src-NEWSC-NEWCORR/contfunc.f deleted file mode 100644 index 7aed575..0000000 --- a/source/wham/src-NEWSC-NEWCORR/contfunc.f +++ /dev/null @@ -1,96 +0,0 @@ - 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-NEWSC-NEWCORR/cxread.F b/source/wham/src-NEWSC-NEWCORR/cxread.F deleted file mode 100644 index 0735f11..0000000 --- a/source/wham/src-NEWSC-NEWCORR/cxread.F +++ /dev/null @@ -1,336 +0,0 @@ - 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' -#ifdef MPI - include "mpif.h" - include "COMMON.MPI" -#endif - 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 - character*4 lt_bath - character*256 pdbfilename - character*50 tytul - 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)) -#ifdef DEBUG - write (iout,*) "ii",ii," itraj",itraj," it",it -#endif - call xdrffloat_(ixdrf, rtime, iret) - call xdrffloat_(ixdrf, rpotE, iret) -#ifdef DEBUG - write (iout,*) "rtime",rtime," rpotE",rpotE," iret",iret -#endif - call flush(iout) - call xdrffloat_(ixdrf, ruconst, iret) - call xdrffloat_(ixdrf, rt_bath, iret) - call xdrfint_(ixdrf, nss, iret) -#ifdef DEBUG - write (iout,*) "ruconst",ruconst," rt_bath",rt_bath," nss",nss -#endif - do j=1,nss - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) - enddo - call xdrfint_(ixdrf, nprop, iret) - if (umbrella(iparm) .or. read_iset(iparm) .or. hamil_rep) - & call xdrfint(ixdrf, iset, iret) - do i=1,nprop - call xdrffloat_(ixdrf, rprop(i), iret) - enddo -#else -#ifdef DEBUG - write (iout,*) "ii",ii," itraj",itraj," it",it -#endif - call xdrffloat(ixdrf, rtime, iret) - call xdrffloat(ixdrf, rpotE, iret) -#ifdef DEBUG - write (iout,*) "rtime",rtime," rpotE",rpotE," iret",iret -#endif - call flush(iout) - call xdrffloat(ixdrf, ruconst, iret) - call xdrffloat(ixdrf, rt_bath, iret) - call xdrfint(ixdrf, nss, iret) -#ifdef DEBUG - write (iout,*) "ruconst",ruconst," rt_bath",rt_bath," nss",nss -#endif - 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 - 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)) - 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 - - if (islice.gt.0 .and. islice.le.nslice .and. (.not.separate_parset - & .or. iset.eq.myparm)) then - ii=ii+1 - kk(islice)=kk(islice)+1 - mm(islice)=mm(islice)+1 - if (mod(nstep(itraj),isampl(iparm)).eq.0 .and. - & conf_check(ll(islice)+1,1)) then - if (replica(iparm)) then - rt_bath=1.0d0/(rt_bath*1.987D-3) - do i=1,nT_h(iparm) - if (abs(real(beta_h(i,iparm))-rt_bath).lt.1.0e-4) then - iib = i - goto 22 - endif - enddo - 22 continue - if (i.gt.nT_h(iparm)) then - write (iout,*) "Error - temperature of conformation", - & ii,1.0d0/(rt_bath*1.987D-3), - & " does not match any of the list" - write (iout,*) - & 1.0d0/(rt_bath*1.987D-3), - & (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) - call flush(iout) -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 -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 - 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 PDBOUT -#ifdef MPI - if (me.eq.Master) then -#endif - write (iout,*) "PDBOUT" - write (iout,*) "temperature",1.0d0/(rt_bath*1.987D-3) - call flush(iout) - write (lt_bath,'(f4.0)') 1.0d0/(rt_bath*1.987D-3) - write (iout,*) "lt_bath ",lt_bath - pdbfilename=prefix(:ilen(prefix))//"_"//lt_bath//"pdb" - write (iout,*) "pdb ",pdbfilename - call flush(iout) - open(ipdb,file=pdbfilename,position="append") -c write (tytul,'("Conformation",i10," T=",f5.1)') -c & kk(islice),rt_bath - call pdbout(kk(islice),1.0d0/(rt_bath*1.987D-3), - & efree+0.0d0,rpotE+0.0d0,efree+0.0d0,rmsdev+0.0d0) - close(ipdb) -#ifdef MPI - endif -#endif -#endif -#ifdef DEBUG - call int_from_cart1(.false.) - write (iout,*) "Writing conformation, record",ll(islice) - write (iout,*) "Cartesian coordinates" - write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) - write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) - write (iout,*) "Internal coordinates" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) -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-NEWSC-NEWCORR/cxread.F.org b/source/wham/src-NEWSC-NEWCORR/cxread.F.org deleted file mode 100644 index 80bc1a0..0000000 --- a/source/wham/src-NEWSC-NEWCORR/cxread.F.org +++ /dev/null @@ -1,248 +0,0 @@ - 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-NEWSC-NEWCORR/define_pairs.f b/source/wham/src-NEWSC-NEWCORR/define_pairs.f deleted file mode 100644 index 00866a8..0000000 --- a/source/wham/src-NEWSC-NEWCORR/define_pairs.f +++ /dev/null @@ -1,120 +0,0 @@ - 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-NEWSC-NEWCORR/elecont.f b/source/wham/src-NEWSC-NEWCORR/elecont.f deleted file mode 100644 index 1eff2f1..0000000 --- a/source/wham/src-NEWSC-NEWCORR/elecont.f +++ /dev/null @@ -1,207 +0,0 @@ - subroutine elecont(lprint,ncont,icont,ist,ien) - implicit none - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'DIMENSIONS.COMPAR' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.NAMES' - include 'COMMON.LOCAL' - logical lprint - integer i,j,k,ist,ien,iteli,itelj,ind,i1,i2,it1,it2,ic1,ic2 - 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 - 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) - 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 - xi=c(1,i) - yi=c(2,i) - zi=c(3,i) - dxi=c(1,i+1)-c(1,i) - dyi=c(2,i+1)-c(2,i) - dzi=c(3,i+1)-c(3,i) - xmedi=xi+0.5*dxi - ymedi=yi+0.5*dyi - zmedi=zi+0.5*dzi - do 4 j=i+2,ien-1 - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - if (iteli.eq.2 .and. itelj.eq.2) goto 4 - aaa=appc(iteli,itelj) - bbb=bppc(iteli,itelj) - ael6i=ael6c(iteli,itelj) - ael3i=ael3c(iteli,itelj) - dxj=c(1,j+1)-c(1,j) - dyj=c(2,j+1)-c(2,j) - dzj=c(3,j+1)-c(3,j) - xj=c(1,j)+0.5*dxj-xmedi - yj=c(2,j)+0.5*dyj-ymedi - zj=c(3,j)+0.5*dzj-zmedi - rrmij=1.0/(xj*xj+yj*yj+zj*zj) - rmij=sqrt(rrmij) - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - vrmij=vblinv*rmij - cosa=(dxi*dxj+dyi*dyj+dzi*dzj)*vblinv2 - cosb=(xj*dxi+yj*dyi+zj*dzi)*vrmij - cosg=(xj*dxj+yj*dyj+zj*dzj)*vrmij - fac=cosa-3.0*cosb*cosg - ev1=aaa*r6ij*r6ij - ev2=bbb*r6ij - fac3=ael6i*r6ij - fac4=ael3i*r3ij - evdwij=ev1+ev2 - el1=fac3*(4.0+fac*fac-3.0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - eesij=el1+el2 - if (j.gt.i+2 .and. eesij.le.elcutoff .or. - & j.eq.i+2 .and. eesij.le.elecutoff_14) then - ncont=ncont+1 - icont(1,ncont)=i - icont(2,ncont)=j - econt(ncont)=eesij - endif - ees=ees+eesij - evdw=evdw+evdwij - 4 continue - 1 continue - if (lprint) then - write (iout,*) 'Total average electrostatic energy: ',ees - write (iout,*) 'VDW energy between peptide-group centers: ',evdw - write (iout,*) - write (iout,*) 'Electrostatic contacts before pruning: ' - do i=1,ncont - i1=icont(1,i) - i2=icont(2,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4,f10.5)') - & i,restyp(it1),i1,restyp(it2),i2,econt(i) - enddo - endif -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-NEWSC-NEWCORR/enecalc1.F b/source/wham/src-NEWSC-NEWCORR/enecalc1.F deleted file mode 100644 index c9f4de8..0000000 --- a/source/wham/src-NEWSC-NEWCORR/enecalc1.F +++ /dev/null @@ -1,780 +0,0 @@ - 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 - double precision tole /1.0d-1/ - integer i,itj,ii,iii,j,k,l,licz - integer ir,ib,ipar,iparm - integer iscor,islice - real*4 csingle(3,maxres2) - double precision energ - 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 - write (iout,*) "enecalc: nparmset ",nparmset -#ifdef MPI - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - snk_p(i,ib,iparm)=0 - enddo - enddo - enddo - do i=indstart(me1),indend(me1) -#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 - q(nQ+1,iii+1)=rmsnat(iii+1) - 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,*) "Calling ETOTAL" - call etotal(energia(0),fT,beta_h(ib,iparm)) -#ifdef DEBUG - write (iout,*) "Conformation",i - call enerprint(energia(0),fT) -c write (iout,'(2i5,21f8.2)') i,iparm,(energia(k),k=1,21) -c write (iout,*) "ftors",ftors -c call intout -#endif - if (energia(0).ge.1.0d20) then - write (iout,*) "NaNs detected in some of the energy", - & " components for conformation",ii+1 - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" -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)).gt.tole) then - if (errmsg_count.le.maxerrmsg_count) then - write (iout,'(2a,2e15.5,a,2i8,a,f8.1)') - & "Warning: energy differs remarkably from ", - & " the value read in: ",energia(0),eini," point", - & iii+1,indstart(me1)+iii," T", - & 1.0d0/(1.987D-3*beta_h(ib,ipar)) - 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 - potE(iii+1,iparm)=energia(0) - do k=1,21 - 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 - call enerprint(energia(0),fT) - 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) - write(liczba,'(bz,i3.3)') me - nazwa="test"//liczba//".pdb" - write (iout,*) "pdb file",nazwa - open (ipdb,file=nazwa,position="append") - call pdbout(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev) - close(ipdb) -#endif - endif - - enddo ! iparm - - iii=iii+1 - if (q(1,iii).le.0.0d0 .and. indpdb.gt.0) q(1,iii)=qwolynes(0,0) - write (ientout,rec=iii) - & ((csingle(l,k),l=1,3),k=1,nres), - & ((csingle(l,k+nres),l=1,3),k=nnt,nct), - & nss,(ihpb(k),jhpb(k),k=1,nss), - & potE(iii,ipar),efree,rmsdev,(q(k,iii),k=1,nQ),iR,ib,ipar -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(me)=iii - write (iout,*) "Me",me," scount",scount(me) - call flush(iout) -c Master gathers updated numbers of conformations written by all procs. - call MPI_AllGather( scount(me), 1, MPI_INTEGER, scount(0), 1, - & MPI_INTEGER, WHAM_COMM, IERROR) - indstart(0)=1 - indend(0)=scount(0) - do i=1, Nprocs-1 - indstart(i)=indend(i-1)+1 - indend(i)=indstart(i)+scount(i)-1 - enddo - write (iout,*) - write (iout,*) "Revised conformation counts" - do i=0,nprocs1-1 - write (iout,'(a,i5,a,i7,a,i7,a,i7)') - & "Processor",i," indstart",indstart(i), - & " indend",indend(i)," count",scount(i) - enddo - call flush(iout) - call MPI_AllReduce(snk_p(1,1,1),snk(1,1,1,islice), - & MaxR*MaxT_h*nParmSet, - & MPI_INTEGER,MPI_SUM,WHAM_COMM,IERROR) -#endif - stot(islice)=0 - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - stot(islice)=stot(islice)+snk(i,ib,iparm,islice) - enddo - enddo - enddo - write (iout,*) "Revised SNK" - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - write (iout,'("Param",i3," Temp",f6.1,3x,32i8)') - & iparm,1.0d0/(1.987D-3*beta_h(ib,iparm)), - & (snk(i,ib,iparm,islice),i=1,nR(ib,iparm)) - write (iout,*) "snk_p",(snk_p(i,ib,iparm),i=1,nR(ib,iparm)) - enddo - enddo - write (iout,'("Total",i10)') stot(islice) - call flush(iout) - 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" - 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 - 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 - if (indpdb.gt.0) then - call conf_compar(i,.false.,.true.) - endif - 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 - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) - enddo - call xdrffloat_(ixdrf,real(eini),iret) - call xdrffloat_(ixdrf,real(efree),iret) - call xdrffloat_(ixdrf,real(rmsdev),iret) - call xdrfint_(ixdrf,iscor,iret) -#else - call xdrf3dfcoord(ixdrf, xoord, itmp, prec, iret) - - call xdrfint(ixdrf, nss, iret) - do j=1,nss - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - enddo - call xdrffloat(ixdrf,real(eini),iret) - call xdrffloat(ixdrf,real(efree),iret) - call xdrffloat(ixdrf,real(rmsdev),iret) - call xdrfint(ixdrf,iscor,iret) -#endif - - return - end -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 - if (.not.check_conf) then - conf_check=.true. - return - endif - call int_from_cart1(.false.) - do j=nnt+1,nct - if (vbld(j).lt.2.0d0 .or. vbld(j).gt.5.0d0) then - if (iprint.gt.0) - & write (iout,*) "Bad CA-CA bond length",j," ",vbld(j), - & " for conformation",ii - if (iprint.gt.1) then - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - endif - if (iprint.gt.0) write (iout,*) - & "This conformation WILL NOT be added to the database." - conf_check=.false. - return - endif - enddo - do j=nnt,nct - itj=itype(j) - if (itype(j).ne.10 .and. (vbld(nres+j)-dsc(itj)).gt.2.0d0) then - if (iprint.gt.0) - & write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j), - & " for conformation",ii - if (iprint.gt.1) then - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - endif - if (iprint.gt.0) write (iout,*) - & "This conformation WILL NOT be added to the database." - conf_check=.false. - return - endif - enddo - do j=3,nres - if (theta(j).le.0.0d0) then - if (iprint.gt.0) - & write (iout,*) "Zero theta angle(s) in conformation",ii - if (iprint.gt.1) then - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - endif - if (iprint.gt.0) write (iout,*) - & "This conformation WILL NOT be added to the database." - conf_check=.false. - return - endif - if (theta(j).gt.179.97*deg2rad) theta(j)=179.97*deg2rad - enddo - conf_check=.true. -c write (iout,*) "conf_check passed",ii - return - end diff --git a/source/wham/src-NEWSC-NEWCORR/energy_p_new.F b/source/wham/src-NEWSC-NEWCORR/energy_p_new.F deleted file mode 100644 index 0ee066f..0000000 --- a/source/wham/src-NEWSC-NEWCORR/energy_p_new.F +++ /dev/null @@ -1,9221 +0,0 @@ - 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) -#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' - 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,106) ipot -C Lennard-Jones potential. - 101 call elj(evdw,evdw_t) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk(evdw,evdw_t) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp(evdw,evdw_t) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb(evdw,evdw_t) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv(evdw,evdw_t) - goto 107 -C New SC-SC potential - 106 call emomo(evdw,evdw_p,evdw_m) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 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) -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) -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 write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t -#ifdef SPLITELE - 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+nss*ebr+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 -#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+nss*ebr+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 -#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 -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 - 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) - 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) - enddo -#else - do i=1,nct - do j=1,3 - 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) - 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) - 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) - & +wsccor*fact(1)*gsccor_loc(i) - enddo - endif - 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' - 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) -#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,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)'/ - & '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,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)'/ - & '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 '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' - 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 - evdw_t=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) - if (bb(itypi,itypj).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 (r.< -c! om = omega, sqom = om^2 - sqom1 = om1 * om1 - sqom2 = om2 * om2 - sqom12 = om12 * om12 - -c! now we calculate EGB - Gey-Berne -c! It will be summed up in evdwij and saved in evdw - sigsq = 1.0D0 / sigsq - sig = sig0ij * dsqrt(sigsq) -c! rij_shift = 1.0D0 / rij - sig + sig0ij - rij_shift = Rtail - sig + sig0ij -c write (2,*) "Rtal",Rtail," sig",sig," sigsq",sigsq, -c & " sig0ij",sig0ij -c write (2,*) "rij_shift",rij_shift - IF (rij_shift.le.0.0D0) THEN - evdw = 1.0D20 - RETURN - END IF - sigder = -sig * sigsq - rij_shift = 1.0D0 / rij_shift - fac = rij_shift**expon - c1 = fac * fac * aa(itypi,itypj) -#ifdef SCALREP -! Scale down the repulsive term for 1,4 interactions. - if (iabs(j-i).le.4) c1 = 0.01d0 * c1 -#endif -c! c1 = 0.0d0 - c2 = fac * bb(itypi,itypj) -c! c2 = 0.0d0 -c write (2,*) "eps1",eps1," eps2rt",eps2rt," eps3rt",eps3rt, -c & " c1",c1," c2",c2 - evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) - eps2der = eps3rt * evdwij - eps3der = eps2rt * evdwij -c! evdwij = 4.0d0 * eps2rt * eps3rt * evdwij - evdwij = eps2rt * eps3rt * evdwij -c! evdwij = 0.0d0 -c! write (*,*) "Gey Berne = ", evdwij -#ifdef TSCSC - IF (bb(itypi,itypj).gt.0) THEN - evdw_p = evdw_p + evdwij - ELSE - evdw_m = evdw_m + evdwij - END IF -#else - evdw = evdw - & + evdwij -#endif -c!------------------------------------------------------------------- -c! Calculate some components of GGB - c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 - fac = -expon * (c1 + evdwij) * rij_shift - sigder = fac * sigder -c! fac = rij * fac -c! Calculate distance derivative -c! gg(1) = xj * fac -c! gg(2) = yj * fac -c! gg(3) = zj * fac - gg(1) = fac - gg(2) = fac - gg(3) = fac -c! write (*,*) "gg(1) = ", gg(1) -c! write (*,*) "gg(2) = ", gg(2) -c! write (*,*) "gg(3) = ", gg(3) -c! The angular derivatives of GGB are brought together in sc_grad -c!------------------------------------------------------------------- -c! Fcav -c! -c! Catch gly-gly interactions to skip calculation of something that -c! does not exist - - IF (itypi.eq.10.and.itypj.eq.10) THEN - Fcav = 0.0d0 - dFdR = 0.0d0 - dCAVdOM1 = 0.0d0 - dCAVdOM2 = 0.0d0 - dCAVdOM12 = 0.0d0 - ELSE - -c! we are not 2 glycines, so we calculate Fcav (and maybe more) - fac = chis1 * sqom1 + chis2 * sqom2 - & - 2.0d0 * chis12 * om1 * om2 * om12 -c! we will use pom later in Gcav, so dont mess with it! - pom = 1.0d0 - chis1 * chis2 * sqom12 - - Lambf = (1.0d0 - (fac / pom)) - Lambf = dsqrt(Lambf) - - - sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0) -c! write (*,*) "sparrow = ", sparrow - Chif = Rtail * sparrow - ChiLambf = Chif * Lambf - eagle = dsqrt(ChiLambf) - bat = ChiLambf ** 11.0d0 - - top = b1 * ( eagle + b2 * ChiLambf - b3 ) - bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0) - botsq = bot * bot - -c! write (*,*) "sig1 = ",sig1 -c! write (*,*) "sig2 = ",sig2 -c! write (*,*) "Rtail = ",Rtail -c! write (*,*) "sparrow = ",sparrow -c! write (*,*) "Chis1 = ", chis1 -c! write (*,*) "Chis2 = ", chis2 -c! write (*,*) "Chis12 = ", chis12 -c! write (*,*) "om1 = ", om1 -c! write (*,*) "om2 = ", om2 -c! write (*,*) "om12 = ", om12 -c! write (*,*) "sqom1 = ", sqom1 -c! write (*,*) "sqom2 = ", sqom2 -c! write (*,*) "sqom12 = ", sqom12 -c! write (*,*) "Lambf = ",Lambf -c! write (*,*) "b1 = ",b1 -c! write (*,*) "b2 = ",b2 -c! write (*,*) "b3 = ",b3 -c! write (*,*) "b4 = ",b4 -c! write (*,*) "top = ",top -c! write (*,*) "bot = ",bot - Fcav = top / bot -c! Fcav = 0.0d0 -c! write (*,*) "Fcav = ", Fcav -c!------------------------------------------------------------------- -c! derivative of Fcav is Gcav... -c!--------------------------------------------------- - - dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf)) - dbot = 12.0d0 * b4 * bat * Lambf - dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow -c! dFdR = 0.0d0 -c! write (*,*) "dFcav/dR = ", dFdR - - dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif)) - dbot = 12.0d0 * b4 * bat * Chif - eagle = Lambf * pom - dFdOM1 = -(chis1 * om1 - chis12 * om2 * om12) / (eagle) - dFdOM2 = -(chis2 * om2 - chis12 * om1 * om12) / (eagle) - dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) - & * (chis2 * om2 * om12 - om1) / (eagle * pom) - - dFdL = ((dtop * bot - top * dbot) / botsq) -c! dFdL = 0.0d0 - dCAVdOM1 = dFdL * ( dFdOM1 ) - dCAVdOM2 = dFdL * ( dFdOM2 ) - dCAVdOM12 = dFdL * ( dFdOM12 ) -c! write (*,*) "dFcav/dOM1 = ", dCAVdOM1 -c! write (*,*) "dFcav/dOM2 = ", dCAVdOM2 -c! write (*,*) "dFcav/dOM12 = ", dCAVdOM12 -c! write (*,*) "" -c!------------------------------------------------------------------- -c! Finally, add the distance derivatives of GB and Fcav to gvdwc -c! Pom is used here to project the gradient vector into -c! cartesian coordinates and at the same time contains -c! dXhb/dXsc derivative (for charged amino acids -c! location of hydrophobic centre of interaction is not -c! the same as geometric centre of side chain, this -c! derivative takes that into account) -c! derivatives of omega angles will be added in sc_grad - - DO k= 1, 3 - ertail(k) = Rtail_distance(k)/Rtail - END DO - erdxi = scalar( ertail(1), dC_norm(1,i+nres) ) - erdxj = scalar( ertail(1), dC_norm(1,j+nres) ) - facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres) - facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres) - DO k = 1, 3 -c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) -c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) - pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres)) - gvdwx(k,i) = gvdwx(k,i) - & - (( dFdR + gg(k) ) * pom) -c! & - ( dFdR * pom ) - pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres)) - gvdwx(k,j) = gvdwx(k,j) - & + (( dFdR + gg(k) ) * pom) -c! & + ( dFdR * pom ) - - gvdwc(k,i) = gvdwc(k,i) - & - (( dFdR + gg(k) ) * ertail(k)) -c! & - ( dFdR * ertail(k)) - - gvdwc(k,j) = gvdwc(k,j) - & + (( dFdR + gg(k) ) * ertail(k)) -c! & + ( dFdR * ertail(k)) - - gg(k) = 0.0d0 -c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) -c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) - END DO - -c!------------------------------------------------------------------- -c! Compute head-head and head-tail energies for each state - - isel = iabs(Qi) + iabs(Qj) - IF (isel.eq.0) THEN -c! No charges - do nothing - eheadtail = 0.0d0 - - ELSE IF (isel.eq.4) THEN -c! Calculate dipole-dipole interactions - CALL edd(ecl) - eheadtail = ECL - - ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN -c! Charge-nonpolar interactions - CALL eqn(epol) - eheadtail = epol - - ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN -c! Nonpolar-charge interactions - CALL enq(epol) - eheadtail = epol - - ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN -c! Charge-dipole interactions - CALL eqd(ecl, elj, epol) - eheadtail = ECL + elj + epol - - ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN -c! Dipole-charge interactions - CALL edq(ecl, elj, epol) - eheadtail = ECL + elj + epol - - ELSE IF ((isel.eq.2.and. - & iabs(Qi).eq.1).and. - & nstate(itypi,itypj).eq.1) THEN -c! Same charge-charge interaction ( +/+ or -/- ) - CALL eqq(Ecl,Egb,Epol,Fisocav,Elj) - eheadtail = ECL + Egb + Epol + Fisocav + Elj - - ELSE IF ((isel.eq.2.and. - & iabs(Qi).eq.1).and. - & nstate(itypi,itypj).ne.1) THEN -c! Different charge-charge interaction ( +/- or -/+ ) - CALL energy_quad - & (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) - END IF - END IF ! this endif ends the "catch the gly-gly" at the beggining of Fcav -c! write (*,*) "evdw = ", evdw -c! write (*,*) "Fcav = ", Fcav -c! write (*,*) "eheadtail = ", eheadtail - evdw = evdw - & + Fcav - & + eheadtail - - IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') - & restyp(itype(i)),i,restyp(itype(j)),j, - & 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj, - & Equad,evdwij+Fcav+eheadtail,evdw -c IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)') -c & restyp(itype(i)),i,restyp(itype(j)),j, -c & 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj, -c & Equad,evdwij+Fcav+eheadtail,evdw -#IFDEF CHECK_MOMO - evdw = 0.0d0 - END DO ! troll -#ENDIF - -c!------------------------------------------------------------------- -c! As all angular derivatives are done, now we sum them up, -c! then transform and project into cartesian vectors and add to gvdwc -c! We call sc_grad always, with the exception of +/- interaction. -c! This is because energy_quad subroutine needs to handle -c! this job in his own way. -c! This IS probably not very efficient and SHOULD be optimised -c! but it will require major restructurization of emomo -c! so it will be left as it is for now -c! write (*,*) 'troll1, nstate =', nstate (itypi,itypj) - IF (nstate(itypi,itypj).eq.1) THEN -#ifdef TSCSC - IF (bb(itypi,itypj).gt.0) THEN - CALL sc_grad - ELSE - CALL sc_grad_T - END IF -#else - CALL sc_grad -#endif - END IF -c!------------------------------------------------------------------- -c! NAPISY KONCOWE - END DO ! j - END DO ! iint - END DO ! i - if (energy_dec) write (iout,*) "evdw before exiting emomo:",evdw -c write (iout,*) "Number of loop steps in EGB:",ind -c energy_dec=.false. - RETURN - END SUBROUTINE emomo -c! END OF MOMO - - -C----------------------------------------------------------------------------- - - - SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar, facd3, facd4, federmaus, adler -c! Epol and Gpol analytical parameters - alphapol1 = alphapol(itypi,itypj) - alphapol2 = alphapol(itypj,itypi) -c! Fisocav and Gisocav analytical parameters - al1 = alphiso(1,itypi,itypj) - al2 = alphiso(2,itypi,itypj) - al3 = alphiso(3,itypi,itypj) - al4 = alphiso(4,itypi,itypj) - csig = (1.0d0 - & / dsqrt(sigiso1(itypi, itypj)**2.0d0 - & + sigiso2(itypi,itypj)**2.0d0)) -c! - pis = sig0head(itypi,itypj) - eps_head = epshead(itypi,itypj) - Rhead_sq = Rhead * Rhead -c! R1 - distance between head of ith side chain and tail of jth sidechain -c! R2 - distance between head of jth side chain and tail of ith sidechain - R1 = 0.0d0 - R2 = 0.0d0 - DO k = 1, 3 -c! Calculate head-to-tail distances needed by Epol - R1=R1+(ctail(k,2)-chead(k,1))**2 - R2=R2+(chead(k,2)-ctail(k,1))**2 - END DO -c! Pitagoras - R1 = dsqrt(R1) - R2 = dsqrt(R2) - -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,1,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,1,itypi,itypj))**2)) - -c!------------------------------------------------------------------- -c! Coulomb electrostatic interaction - Ecl = (332.0d0 * Qij) / Rhead -c! derivative of Ecl is Gcl... - dGCLdR = (-332.0d0 * Qij ) / Rhead_sq - dGCLdOM1 = 0.0d0 - dGCLdOM2 = 0.0d0 - dGCLdOM12 = 0.0d0 -c!------------------------------------------------------------------- -c! Generalised Born Solvent Polarization -c! Charged head polarizes the solvent - ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) - Fgb = sqrt( ( Rhead_sq ) + a12sq * ee) - Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb -c! Derivative of Egb is Ggb... - dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb) - dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) ) - & / ( 2.0d0 * Fgb ) - dGGBdR = dGGBdFGB * dFGBdR -c!------------------------------------------------------------------- -c! Fisocav - isotropic cavity creation term -c! or "how much energy it costs to put charged head in water" - pom = Rhead * csig - top = al1 * (dsqrt(pom) + al2 * pom - al3) - bot = (1.0d0 + al4 * pom**12.0d0) - botsq = bot * bot - FisoCav = top / bot -c! write (*,*) "Rhead = ",Rhead -c! write (*,*) "csig = ",csig -c! write (*,*) "pom = ",pom -c! write (*,*) "al1 = ",al1 -c! write (*,*) "al2 = ",al2 -c! write (*,*) "al3 = ",al3 -c! write (*,*) "al4 = ",al4 -c! write (*,*) "top = ",top -c! write (*,*) "bot = ",bot -c! Derivative of Fisocav is GCV... - dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) - dbot = 12.0d0 * al4 * pom ** 11.0d0 - dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig -c!------------------------------------------------------------------- -c! Epol -c! Polarization energy - charged heads polarize hydrophobic "neck" - MomoFac1 = (1.0d0 - chi1 * sqom2) - MomoFac2 = (1.0d0 - chi2 * sqom1) - RR1 = ( R1 * R1 ) / MomoFac1 - RR2 = ( R2 * R2 ) / MomoFac2 - ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) - ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) - fgb1 = sqrt( RR1 + a12sq * ee1 ) - fgb2 = sqrt( RR2 + a12sq * ee2 ) - epol = 332.0d0 * eps_inout_fac * ( - & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) -c! epol = 0.0d0 -c write (*,*) "eps_inout_fac = ",eps_inout_fac -c write (*,*) "alphapol1 = ", alphapol1 -c write (*,*) "alphapol2 = ", alphapol2 -c write (*,*) "fgb1 = ", fgb1 -c write (*,*) "fgb2 = ", fgb2 -c write (*,*) "epol = ", epol -c! derivative of Epol is Gpol... - dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) - & / (fgb1 ** 5.0d0) - dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) - & / (fgb2 ** 5.0d0) - dFGBdR1 = ( (R1 / MomoFac1) - & * ( 2.0d0 - (0.5d0 * ee1) ) ) - & / ( 2.0d0 * fgb1 ) - dFGBdR2 = ( (R2 / MomoFac2) - & * ( 2.0d0 - (0.5d0 * ee2) ) ) - & / ( 2.0d0 * fgb2 ) - dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) - & * ( 2.0d0 - 0.5d0 * ee1) ) - & / ( 2.0d0 * fgb1 ) - dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) - & * ( 2.0d0 - 0.5d0 * ee2) ) - & / ( 2.0d0 * fgb2 ) - dPOLdR1 = dPOLdFGB1 * dFGBdR1 -c! dPOLdR1 = 0.0d0 - dPOLdR2 = dPOLdFGB2 * dFGBdR2 -c! dPOLdR2 = 0.0d0 - dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 -c! dPOLdOM1 = 0.0d0 - dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 -c! dPOLdOM2 = 0.0d0 -c!------------------------------------------------------------------- -c! Elj -c! Lennard-Jones 6-12 interaction between heads - pom = (pis / Rhead)**6.0d0 - Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) -c! derivative of Elj is Glj - dGLJdR = 4.0d0 * eps_head - & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) - & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) -c!------------------------------------------------------------------- -c! Return the results -c! These things do the dRdX derivatives, that is -c! allow us to change what we see from function that changes with -c! distance to function that changes with LOCATION (of the interaction -c! site) - DO k = 1, 3 - erhead(k) = Rhead_distance(k)/Rhead - erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) - erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) - END DO - - erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) - erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) - bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) - federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) - eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) - adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) - facd1 = d1 * vbld_inv(i+nres) - facd2 = d2 * vbld_inv(j+nres) - facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) - facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) - -c! Now we add appropriate partial derivatives (one in each dimension) - DO k = 1, 3 - hawk = (erhead_tail(k,1) + - & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) - condor = (erhead_tail(k,2) + - & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) - - pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) - gvdwx(k,i) = gvdwx(k,i) - & - dGCLdR * pom - & - dGGBdR * pom - & - dGCVdR * pom - & - dPOLdR1 * hawk - & - dPOLdR2 * (erhead_tail(k,2) - & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) - & - dGLJdR * pom - - pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) - gvdwx(k,j) = gvdwx(k,j) - & + dGCLdR * pom - & + dGGBdR * pom - & + dGCVdR * pom - & + dPOLdR1 * (erhead_tail(k,1) - & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) - & + dPOLdR2 * condor - & + dGLJdR * pom - - gvdwc(k,i) = gvdwc(k,i) - & - dGCLdR * erhead(k) - & - dGGBdR * erhead(k) - & - dGCVdR * erhead(k) - & - dPOLdR1 * erhead_tail(k,1) - & - dPOLdR2 * erhead_tail(k,2) - & - dGLJdR * erhead(k) - - gvdwc(k,j) = gvdwc(k,j) - & + dGCLdR * erhead(k) - & + dGGBdR * erhead(k) - & + dGCVdR * erhead(k) - & + dPOLdR1 * erhead_tail(k,1) - & + dPOLdR2 * erhead_tail(k,2) - & + dGLJdR * erhead(k) - - END DO - RETURN - END SUBROUTINE eqq -c!------------------------------------------------------------------- - SUBROUTINE energy_quad - &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar - double precision ener(4) - double precision dcosom1(3),dcosom2(3) -c! used in Epol derivatives - double precision facd3, facd4 - double precision federmaus, adler -c! Epol and Gpol analytical parameters - alphapol1 = alphapol(itypi,itypj) - alphapol2 = alphapol(itypj,itypi) -c! Fisocav and Gisocav analytical parameters - al1 = alphiso(1,itypi,itypj) - al2 = alphiso(2,itypi,itypj) - al3 = alphiso(3,itypi,itypj) - al4 = alphiso(4,itypi,itypj) - csig = (1.0d0 - & / dsqrt(sigiso1(itypi, itypj)**2.0d0 - & + sigiso2(itypi,itypj)**2.0d0)) -c! - w1 = wqdip(1,itypi,itypj) - w2 = wqdip(2,itypi,itypj) - pis = sig0head(itypi,itypj) - eps_head = epshead(itypi,itypj) -c! First things first: -c! We need to do sc_grad's job with GB and Fcav - eom1 = - & eps2der * eps2rt_om1 - & - 2.0D0 * alf1 * eps3der - & + sigder * sigsq_om1 - & + dCAVdOM1 - eom2 = - & eps2der * eps2rt_om2 - & + 2.0D0 * alf2 * eps3der - & + sigder * sigsq_om2 - & + dCAVdOM2 - eom12 = - & evdwij * eps1_om12 - & + eps2der * eps2rt_om12 - & - 2.0D0 * alf12 * eps3der - & + sigder *sigsq_om12 - & + dCAVdOM12 -c! now some magical transformations to project gradient into -c! three cartesian vectors - 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)) - gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k) -c! this acts on hydrophobic center of interaction - 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 -c! this acts on Calpha - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - END DO -c! sc_grad is done, now we will compute - eheadtail = 0.0d0 - eom1 = 0.0d0 - eom2 = 0.0d0 - eom12 = 0.0d0 - -c! ENERGY DEBUG -c! ii = 1 -c! jj = 1 -c! d1 = dhead(1, 1, itypi, itypj) -c! d2 = dhead(2, 1, itypi, itypj) -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,ii,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,jj,itypi,itypj))**2)) -c! Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2)) -c! END OF ENERGY DEBUG -c************************************************************* - DO istate = 1, nstate(itypi,itypj) -c************************************************************* - IF (istate.ne.1) THEN - IF (istate.lt.3) THEN - ii = 1 - ELSE - ii = 2 - END IF - jj = istate/ii - d1 = dhead(1,ii,itypi,itypj) - d2 = dhead(2,jj,itypi,itypj) - DO k = 1,3 - chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) - chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) - Rhead_distance(k) = chead(k,2) - chead(k,1) - END DO -c! pitagoras (root of sum of squares) - Rhead = dsqrt( - & (Rhead_distance(1)*Rhead_distance(1)) - & + (Rhead_distance(2)*Rhead_distance(2)) - & + (Rhead_distance(3)*Rhead_distance(3))) - END IF - Rhead_sq = Rhead * Rhead - -c! R1 - distance between head of ith side chain and tail of jth sidechain -c! R2 - distance between head of jth side chain and tail of ith sidechain - R1 = 0.0d0 - R2 = 0.0d0 - DO k = 1, 3 -c! Calculate head-to-tail distances - R1=R1+(ctail(k,2)-chead(k,1))**2 - R2=R2+(chead(k,2)-ctail(k,1))**2 - END DO -c! Pitagoras - R1 = dsqrt(R1) - R2 = dsqrt(R2) - -c! ENERGY DEBUG -c! write (*,*) "istate = ", istate -c! write (*,*) "ii = ", ii -c! write (*,*) "jj = ", jj -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,ii,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,jj,itypi,itypj))**2)) -c! Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2)) -c! Rhead_sq = Rhead * Rhead -c! write (*,*) "d1 = ",d1 -c! write (*,*) "d2 = ",d2 -c! write (*,*) "R1 = ",R1 -c! write (*,*) "R2 = ",R2 -c! write (*,*) "Rhead = ",Rhead -c! END OF ENERGY DEBUG - -c!------------------------------------------------------------------- -c! Coulomb electrostatic interaction - Ecl = (332.0d0 * Qij) / (Rhead * eps_in) -c! Ecl = 0.0d0 -c! write (*,*) "Ecl = ", Ecl -c! derivative of Ecl is Gcl... - dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in) -c! dGCLdR = 0.0d0 - dGCLdOM1 = 0.0d0 - dGCLdOM2 = 0.0d0 - dGCLdOM12 = 0.0d0 -c!------------------------------------------------------------------- -c! Generalised Born Solvent Polarization - ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) - Fgb = sqrt( ( Rhead_sq ) + a12sq * ee) - Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb -c! Egb = 0.0d0 -c! write (*,*) "a1*a2 = ", a12sq -c! write (*,*) "Rhead = ", Rhead -c! write (*,*) "Rhead_sq = ", Rhead_sq -c! write (*,*) "ee = ", ee -c! write (*,*) "Fgb = ", Fgb -c! write (*,*) "fac = ", eps_inout_fac -c! write (*,*) "Qij = ", Qij -c! write (*,*) "Egb = ", Egb -c! Derivative of Egb is Ggb... -c! dFGBdR is used by Quad's later... - dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb) - dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) ) - & / ( 2.0d0 * Fgb ) - dGGBdR = dGGBdFGB * dFGBdR -c! dGGBdR = 0.0d0 -c!------------------------------------------------------------------- -c! Fisocav - isotropic cavity creation term - pom = Rhead * csig - top = al1 * (dsqrt(pom) + al2 * pom - al3) - bot = (1.0d0 + al4 * pom**12.0d0) - botsq = bot * bot - FisoCav = top / bot -c! FisoCav = 0.0d0 -c! write (*,*) "pom = ",pom -c! write (*,*) "al1 = ",al1 -c! write (*,*) "al2 = ",al2 -c! write (*,*) "al3 = ",al3 -c! write (*,*) "al4 = ",al4 -c! write (*,*) "top = ",top -c! write (*,*) "bot = ",bot -c! write (*,*) "Fisocav = ", Fisocav - -c! Derivative of Fisocav is GCV... - dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) - dbot = 12.0d0 * al4 * pom ** 11.0d0 - dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig -c! dGCVdR = 0.0d0 -c!------------------------------------------------------------------- -c! Polarization energy -c! Epol - MomoFac1 = (1.0d0 - chi1 * sqom2) - MomoFac2 = (1.0d0 - chi2 * sqom1) - RR1 = ( R1 * R1 ) / MomoFac1 - RR2 = ( R2 * R2 ) / MomoFac2 - ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) - ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) - fgb1 = sqrt( RR1 + a12sq * ee1 ) - fgb2 = sqrt( RR2 + a12sq * ee2 ) - epol = 332.0d0 * eps_inout_fac * ( - & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) -c! epol = 0.0d0 -c! derivative of Epol is Gpol... - dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) - & / (fgb1 ** 5.0d0) - dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) - & / (fgb2 ** 5.0d0) - dFGBdR1 = ( (R1 / MomoFac1) - & * ( 2.0d0 - (0.5d0 * ee1) ) ) - & / ( 2.0d0 * fgb1 ) - dFGBdR2 = ( (R2 / MomoFac2) - & * ( 2.0d0 - (0.5d0 * ee2) ) ) - & / ( 2.0d0 * fgb2 ) - dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) - & * ( 2.0d0 - 0.5d0 * ee1) ) - & / ( 2.0d0 * fgb1 ) - dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) - & * ( 2.0d0 - 0.5d0 * ee2) ) - & / ( 2.0d0 * fgb2 ) - dPOLdR1 = dPOLdFGB1 * dFGBdR1 -c! dPOLdR1 = 0.0d0 - dPOLdR2 = dPOLdFGB2 * dFGBdR2 -c! dPOLdR2 = 0.0d0 - dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 -c! dPOLdOM1 = 0.0d0 - dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 -c! dPOLdOM2 = 0.0d0 -c!------------------------------------------------------------------- -c! Elj - pom = (pis / Rhead)**6.0d0 - Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) -c! Elj = 0.0d0 -c! derivative of Elj is Glj - dGLJdR = 4.0d0 * eps_head - & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) - & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) -c! dGLJdR = 0.0d0 -c!------------------------------------------------------------------- -c! Equad - IF (Wqd.ne.0.0d0) THEN - Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) - & - 37.5d0 * ( sqom1 + sqom2 ) - & + 157.5d0 * ( sqom1 * sqom2 ) - & - 45.0d0 * om1*om2*om12 - fac = -( Wqd / (2.0d0 * Fgb**5.0d0) ) - Equad = fac * Beta1 -c! Equad = 0.0d0 -c! derivative of Equad... - dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR -c! dQUADdR = 0.0d0 - dQUADdOM1 = fac - & * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12) -c! dQUADdOM1 = 0.0d0 - dQUADdOM2 = fac - & * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12) -c! dQUADdOM2 = 0.0d0 - dQUADdOM12 = fac - & * ( 6.0d0*om12 - 45.0d0*om1*om2 ) -c! dQUADdOM12 = 0.0d0 - ELSE - Beta1 = 0.0d0 - Equad = 0.0d0 - END IF -c!------------------------------------------------------------------- -c! Return the results -c! Angular stuff - eom1 = dPOLdOM1 + dQUADdOM1 - eom2 = dPOLdOM2 + dQUADdOM2 - eom12 = dQUADdOM12 -c! now some magical transformations to project gradient into -c! three cartesian vectors - 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)) - tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k) - END DO -c! Radial stuff - DO k = 1, 3 - erhead(k) = Rhead_distance(k)/Rhead - erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) - erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) - END DO - erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) - erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) - bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) - federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) - eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) - adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) - facd1 = d1 * vbld_inv(i+nres) - facd2 = d2 * vbld_inv(j+nres) - facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) - facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) -c! Throw the results into gheadtail which holds gradients -c! for each micro-state - DO k = 1, 3 - hawk = erhead_tail(k,1) + - & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)) - condor = erhead_tail(k,2) + - & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)) - - pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) -c! this acts on hydrophobic center of interaction - gheadtail(k,1,1) = gheadtail(k,1,1) - & - dGCLdR * pom - & - dGGBdR * pom - & - dGCVdR * pom - & - dPOLdR1 * hawk - & - dPOLdR2 * (erhead_tail(k,2) - & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) - & - dGLJdR * pom - & - dQUADdR * pom - & - tuna(k) - & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv - - pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) -c! this acts on hydrophobic center of interaction - gheadtail(k,2,1) = gheadtail(k,2,1) - & + dGCLdR * pom - & + dGGBdR * pom - & + dGCVdR * pom - & + dPOLdR1 * (erhead_tail(k,1) - & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) - & + dPOLdR2 * condor - & + dGLJdR * pom - & + dQUADdR * pom - & + tuna(k) - & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - -c! this acts on Calpha - gheadtail(k,3,1) = gheadtail(k,3,1) - & - dGCLdR * erhead(k) - & - dGGBdR * erhead(k) - & - dGCVdR * erhead(k) - & - dPOLdR1 * erhead_tail(k,1) - & - dPOLdR2 * erhead_tail(k,2) - & - dGLJdR * erhead(k) - & - dQUADdR * erhead(k) - & - tuna(k) - -c! this acts on Calpha - gheadtail(k,4,1) = gheadtail(k,4,1) - & + dGCLdR * erhead(k) - & + dGGBdR * erhead(k) - & + dGCVdR * erhead(k) - & + dPOLdR1 * erhead_tail(k,1) - & + dPOLdR2 * erhead_tail(k,2) - & + dGLJdR * erhead(k) - & + dQUADdR * erhead(k) - & + tuna(k) - END DO -c! write(*,*) "ECL = ", Ecl -c! write(*,*) "Egb = ", Egb -c! write(*,*) "Epol = ", Epol -c! write(*,*) "Fisocav = ", Fisocav -c! write(*,*) "Elj = ", Elj -c! write(*,*) "Equad = ", Equad -c! write(*,*) "wstate = ", wstate(istate,itypi,itypj) -c! write(*,*) "eheadtail = ", eheadtail -c! write(*,*) "TROLL = ", dexp(-betaT * ener(istate)) -c! write(*,*) "dGCLdR = ", dGCLdR -c! write(*,*) "dGGBdR = ", dGGBdR -c! write(*,*) "dGCVdR = ", dGCVdR -c! write(*,*) "dPOLdR1 = ", dPOLdR1 -c! write(*,*) "dPOLdR2 = ", dPOLdR2 -c! write(*,*) "dGLJdR = ", dGLJdR -c! write(*,*) "dQUADdR = ", dQUADdR -c! write(*,*) "tuna(",k,") = ", tuna(k) - ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad - eheadtail = eheadtail - & + wstate(istate, itypi, itypj) - & * dexp(-betaT * ener(istate)) -c! foreach cartesian dimension - DO k = 1, 3 -c! foreach of two gvdwx and gvdwc - DO l = 1, 4 - gheadtail(k,l,2) = gheadtail(k,l,2) - & + wstate( istate, itypi, itypj ) - & * dexp(-betaT * ener(istate)) - & * gheadtail(k,l,1) - gheadtail(k,l,1) = 0.0d0 - END DO - END DO - END DO -c! Here ended the gigantic DO istate = 1, 4, which starts -c! at the beggining of the subroutine - - DO k = 1, 3 - DO l = 1, 4 - gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail - END DO - gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2) - gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2) - gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2) - gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2) - DO l = 1, 4 - gheadtail(k,l,1) = 0.0d0 - gheadtail(k,l,2) = 0.0d0 - END DO - END DO - eheadtail = (-dlog(eheadtail)) / betaT - dPOLdOM1 = 0.0d0 - dPOLdOM2 = 0.0d0 - dQUADdOM1 = 0.0d0 - dQUADdOM2 = 0.0d0 - dQUADdOM12 = 0.0d0 - RETURN - END SUBROUTINE energy_quad - - -c!------------------------------------------------------------------- - - - SUBROUTINE eqn(Epol) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar, facd4, federmaus - alphapol1 = alphapol(itypi,itypj) -c! R1 - distance between head of ith side chain and tail of jth sidechain - R1 = 0.0d0 - DO k = 1, 3 -c! Calculate head-to-tail distances - R1=R1+(ctail(k,2)-chead(k,1))**2 - END DO -c! Pitagoras - R1 = dsqrt(R1) - -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,1,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,1,itypi,itypj))**2)) -c-------------------------------------------------------------------- -c Polarization energy -c Epol - MomoFac1 = (1.0d0 - chi1 * sqom2) - RR1 = R1 * R1 / MomoFac1 - ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) - fgb1 = sqrt( RR1 + a12sq * ee1) - epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) -c! epol = 0.0d0 -c!------------------------------------------------------------------ -c! derivative of Epol is Gpol... - dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) - & / (fgb1 ** 5.0d0) - dFGBdR1 = ( (R1 / MomoFac1) - & * ( 2.0d0 - (0.5d0 * ee1) ) ) - & / ( 2.0d0 * fgb1 ) - dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) - & * (2.0d0 - 0.5d0 * ee1) ) - & / (2.0d0 * fgb1) - dPOLdR1 = dPOLdFGB1 * dFGBdR1 -c! dPOLdR1 = 0.0d0 - dPOLdOM1 = 0.0d0 - dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 -c! dPOLdOM2 = 0.0d0 -c!------------------------------------------------------------------- -c! Return the results -c! (see comments in Eqq) - DO k = 1, 3 - erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) - END DO - bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) - federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) - facd1 = d1 * vbld_inv(i+nres) - facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) - - DO k = 1, 3 - hawk = (erhead_tail(k,1) + - & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) - - gvdwx(k,i) = gvdwx(k,i) - & - dPOLdR1 * hawk - gvdwx(k,j) = gvdwx(k,j) - & + dPOLdR1 * (erhead_tail(k,1) - & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) - - gvdwc(k,i) = gvdwc(k,i) - & - dPOLdR1 * erhead_tail(k,1) - gvdwc(k,j) = gvdwc(k,j) - & + dPOLdR1 * erhead_tail(k,1) - - END DO - RETURN - END SUBROUTINE eqn - - -c!------------------------------------------------------------------- - - - - SUBROUTINE enq(Epol) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar, facd3, adler - alphapol2 = alphapol(itypj,itypi) -c! R2 - distance between head of jth side chain and tail of ith sidechain - R2 = 0.0d0 - DO k = 1, 3 -c! Calculate head-to-tail distances - R2=R2+(chead(k,2)-ctail(k,1))**2 - END DO -c! Pitagoras - R2 = dsqrt(R2) - -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,1,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,1,itypi,itypj))**2)) -c------------------------------------------------------------------------ -c Polarization energy - MomoFac2 = (1.0d0 - chi2 * sqom1) - RR2 = R2 * R2 / MomoFac2 - ee2 = exp(-(RR2 / (4.0d0 * a12sq))) - fgb2 = sqrt(RR2 + a12sq * ee2) - epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) -c! epol = 0.0d0 -c!------------------------------------------------------------------- -c! derivative of Epol is Gpol... - dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) - & / (fgb2 ** 5.0d0) - dFGBdR2 = ( (R2 / MomoFac2) - & * ( 2.0d0 - (0.5d0 * ee2) ) ) - & / (2.0d0 * fgb2) - dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) - & * (2.0d0 - 0.5d0 * ee2) ) - & / (2.0d0 * fgb2) - dPOLdR2 = dPOLdFGB2 * dFGBdR2 -c! dPOLdR2 = 0.0d0 - dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 -c! dPOLdOM1 = 0.0d0 - dPOLdOM2 = 0.0d0 -c!------------------------------------------------------------------- -c! Return the results -c! (See comments in Eqq) - DO k = 1, 3 - erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) - END DO - eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) - adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) - facd2 = d2 * vbld_inv(j+nres) - facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) - DO k = 1, 3 - condor = (erhead_tail(k,2) - & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) - - gvdwx(k,i) = gvdwx(k,i) - & - dPOLdR2 * (erhead_tail(k,2) - & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) - gvdwx(k,j) = gvdwx(k,j) - & + dPOLdR2 * condor - - gvdwc(k,i) = gvdwc(k,i) - & - dPOLdR2 * erhead_tail(k,2) - gvdwc(k,j) = gvdwc(k,j) - & + dPOLdR2 * erhead_tail(k,2) - - END DO - RETURN - END SUBROUTINE enq - - -c!------------------------------------------------------------------- - - - SUBROUTINE eqd(Ecl,Elj,Epol) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar, facd4, federmaus - alphapol1 = alphapol(itypi,itypj) - w1 = wqdip(1,itypi,itypj) - w2 = wqdip(2,itypi,itypj) - pis = sig0head(itypi,itypj) - eps_head = epshead(itypi,itypj) -c!------------------------------------------------------------------- -c! R1 - distance between head of ith side chain and tail of jth sidechain - R1 = 0.0d0 - DO k = 1, 3 -c! Calculate head-to-tail distances - R1=R1+(ctail(k,2)-chead(k,1))**2 - END DO -c! Pitagoras - R1 = dsqrt(R1) - -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,1,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,1,itypi,itypj))**2)) - -c!------------------------------------------------------------------- -c! ecl - sparrow = w1 * Qi * om1 - hawk = w2 * Qi * Qi * (1.0d0 - sqom2) - Ecl = sparrow / Rhead**2.0d0 - & - hawk / Rhead**4.0d0 -c!------------------------------------------------------------------- -c! derivative of ecl is Gcl -c! dF/dr part - dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 - & + 4.0d0 * hawk / Rhead**5.0d0 -c! dF/dom1 - dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) -c! dF/dom2 - dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) -c-------------------------------------------------------------------- -c Polarization energy -c Epol - MomoFac1 = (1.0d0 - chi1 * sqom2) - RR1 = R1 * R1 / MomoFac1 - ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) - fgb1 = sqrt( RR1 + a12sq * ee1) - epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) -c! epol = 0.0d0 -c!------------------------------------------------------------------ -c! derivative of Epol is Gpol... - dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) - & / (fgb1 ** 5.0d0) - dFGBdR1 = ( (R1 / MomoFac1) - & * ( 2.0d0 - (0.5d0 * ee1) ) ) - & / ( 2.0d0 * fgb1 ) - dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) - & * (2.0d0 - 0.5d0 * ee1) ) - & / (2.0d0 * fgb1) - dPOLdR1 = dPOLdFGB1 * dFGBdR1 -c! dPOLdR1 = 0.0d0 - dPOLdOM1 = 0.0d0 - dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 -c! dPOLdOM2 = 0.0d0 -c!------------------------------------------------------------------- -c! Elj - pom = (pis / Rhead)**6.0d0 - Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) -c! derivative of Elj is Glj - dGLJdR = 4.0d0 * eps_head - & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) - & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) -c!------------------------------------------------------------------- -c! Return the results - DO k = 1, 3 - erhead(k) = Rhead_distance(k)/Rhead - erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) - END DO - - erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) - erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) - bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) - federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) - facd1 = d1 * vbld_inv(i+nres) - facd2 = d2 * vbld_inv(j+nres) - facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) - - DO k = 1, 3 - hawk = (erhead_tail(k,1) + - & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) - - pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) - gvdwx(k,i) = gvdwx(k,i) - & - dGCLdR * pom - & - dPOLdR1 * hawk - & - dGLJdR * pom - - pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) - gvdwx(k,j) = gvdwx(k,j) - & + dGCLdR * pom - & + dPOLdR1 * (erhead_tail(k,1) - & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) - & + dGLJdR * pom - - - gvdwc(k,i) = gvdwc(k,i) - & - dGCLdR * erhead(k) - & - dPOLdR1 * erhead_tail(k,1) - & - dGLJdR * erhead(k) - - gvdwc(k,j) = gvdwc(k,j) - & + dGCLdR * erhead(k) - & + dPOLdR1 * erhead_tail(k,1) - & + dGLJdR * erhead(k) - - END DO - RETURN - END SUBROUTINE eqd - - -c!------------------------------------------------------------------- - - - SUBROUTINE edq(Ecl,Elj,Epol) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar, facd3, adler - alphapol2 = alphapol(itypj,itypi) - w1 = wqdip(1,itypi,itypj) - w2 = wqdip(2,itypi,itypj) - pis = sig0head(itypi,itypj) - eps_head = epshead(itypi,itypj) -c!------------------------------------------------------------------- -c! R2 - distance between head of jth side chain and tail of ith sidechain - R2 = 0.0d0 - DO k = 1, 3 -c! Calculate head-to-tail distances - R2=R2+(chead(k,2)-ctail(k,1))**2 - END DO -c! Pitagoras - R2 = dsqrt(R2) - -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,1,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,1,itypi,itypj))**2)) - - -c!------------------------------------------------------------------- -c! ecl - sparrow = w1 * Qi * om1 - hawk = w2 * Qi * Qi * (1.0d0 - sqom2) - ECL = sparrow / Rhead**2.0d0 - & - hawk / Rhead**4.0d0 -c!------------------------------------------------------------------- -c! derivative of ecl is Gcl -c! dF/dr part - dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 - & + 4.0d0 * hawk / Rhead**5.0d0 -c! dF/dom1 - dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) -c! dF/dom2 - dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) -c-------------------------------------------------------------------- -c Polarization energy -c Epol - MomoFac2 = (1.0d0 - chi2 * sqom1) - RR2 = R2 * R2 / MomoFac2 - ee2 = exp(-(RR2 / (4.0d0 * a12sq))) - fgb2 = sqrt(RR2 + a12sq * ee2) - epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) -c! epol = 0.0d0 -c! derivative of Epol is Gpol... - dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) - & / (fgb2 ** 5.0d0) - dFGBdR2 = ( (R2 / MomoFac2) - & * ( 2.0d0 - (0.5d0 * ee2) ) ) - & / (2.0d0 * fgb2) - dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) - & * (2.0d0 - 0.5d0 * ee2) ) - & / (2.0d0 * fgb2) - dPOLdR2 = dPOLdFGB2 * dFGBdR2 -c! dPOLdR2 = 0.0d0 - dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 -c! dPOLdOM1 = 0.0d0 - dPOLdOM2 = 0.0d0 -c!------------------------------------------------------------------- -c! Elj - pom = (pis / Rhead)**6.0d0 - Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) -c! derivative of Elj is Glj - dGLJdR = 4.0d0 * eps_head - & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) - & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) -c!------------------------------------------------------------------- -c! Return the results -c! (see comments in Eqq) - DO k = 1, 3 - erhead(k) = Rhead_distance(k)/Rhead - erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) - END DO - erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) - erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) - eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) - adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) - facd1 = d1 * vbld_inv(i+nres) - facd2 = d2 * vbld_inv(j+nres) - facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) - - DO k = 1, 3 - condor = (erhead_tail(k,2) - & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) - - pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) - gvdwx(k,i) = gvdwx(k,i) - & - dGCLdR * pom - & - dPOLdR2 * (erhead_tail(k,2) - & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) - & - dGLJdR * pom - - pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) - gvdwx(k,j) = gvdwx(k,j) - & + dGCLdR * pom - & + dPOLdR2 * condor - & + dGLJdR * pom - - - gvdwc(k,i) = gvdwc(k,i) - & - dGCLdR * erhead(k) - & - dPOLdR2 * erhead_tail(k,2) - & - dGLJdR * erhead(k) - - gvdwc(k,j) = gvdwc(k,j) - & + dGCLdR * erhead(k) - & + dPOLdR2 * erhead_tail(k,2) - & + dGLJdR * erhead(k) - - END DO - RETURN - END SUBROUTINE edq - - -C-------------------------------------------------------------------- - - - SUBROUTINE edd(ECL) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar -c! csig = sigiso(itypi,itypj) - w1 = wqdip(1,itypi,itypj) - w2 = wqdip(2,itypi,itypj) -c!------------------------------------------------------------------- -c! ECL - fac = (om12 - 3.0d0 * om1 * om2) - c1 = (w1 / (Rhead**3.0d0)) * fac - c2 = (w2 / Rhead ** 6.0d0) - & * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) - ECL = c1 - c2 -c! write (*,*) "w1 = ", w1 -c! write (*,*) "w2 = ", w2 -c! write (*,*) "om1 = ", om1 -c! write (*,*) "om2 = ", om2 -c! write (*,*) "om12 = ", om12 -c! write (*,*) "fac = ", fac -c! write (*,*) "c1 = ", c1 -c! write (*,*) "c2 = ", c2 -c! write (*,*) "Ecl = ", Ecl -c! write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0) -c! write (*,*) "c2_2 = ", -c! & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) -c!------------------------------------------------------------------- -c! dervative of ECL is GCL... -c! dECL/dr - c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0) - c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) - & * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2)) - dGCLdR = c1 - c2 -c! dECL/dom1 - c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0) - c2 = (-6.0d0 * w2) / (Rhead**6.0d0) - & * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 ) - dGCLdOM1 = c1 - c2 -c! dECL/dom2 - c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0) - c2 = (-6.0d0 * w2) / (Rhead**6.0d0) - & * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 ) - dGCLdOM2 = c1 - c2 -c! dECL/dom12 - c1 = w1 / (Rhead ** 3.0d0) - c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0 - dGCLdOM12 = c1 - c2 -c!------------------------------------------------------------------- -c! Return the results -c! (see comments in Eqq) - DO k= 1, 3 - erhead(k) = Rhead_distance(k)/Rhead - END DO - erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) - erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) - facd1 = d1 * vbld_inv(i+nres) - facd2 = d2 * vbld_inv(j+nres) - DO k = 1, 3 - - pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) - gvdwx(k,i) = gvdwx(k,i) - & - dGCLdR * pom - pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) - gvdwx(k,j) = gvdwx(k,j) - & + dGCLdR * pom - - gvdwc(k,i) = gvdwc(k,i) - & - dGCLdR * erhead(k) - gvdwc(k,j) = gvdwc(k,j) - & + dGCLdR * erhead(k) - END DO - RETURN - END SUBROUTINE edd - - -c!------------------------------------------------------------------- - - - SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol) - IMPLICIT NONE -c! maxres - INCLUDE 'DIMENSIONS' -c! itypi, itypj, i, j, k, l, chead, - INCLUDE 'COMMON.CALC' -c! c, nres, dc_norm - INCLUDE 'COMMON.CHAIN' -c! gradc, gradx - INCLUDE 'COMMON.DERIV' -c! electrostatic gradients-specific variables - INCLUDE 'COMMON.EMP' -c! wquad, dhead, alphiso, alphasur, rborn, epsintab - INCLUDE 'COMMON.INTERACT' -c! io for debug, disable it in final builds - INCLUDE 'COMMON.IOUNITS' -c!------------------------------------------------------------------- -c! Variable Init - -c! what amino acid is the aminoacid j'th? - itypj = itype(j) -c! 1/(Gas Constant * Thermostate temperature) = BetaT -c! ENABLE THIS LINE WHEN USING CHECKGRAD!!! - BetaT = 1.0d0 / (298 * 1.987d-3) -c! Gay-berne var's - sig0ij = sigma( itypi,itypj ) - chi1 = chi( itypi, itypj ) - chi2 = chi( itypj, itypi ) - chi12 = chi1 * chi2 - chip1 = chipp( itypi, itypj ) - chip2 = chipp( itypj, itypi ) - chip12 = chip1 * chip2 -c! write (2,*) "elgrad types",itypi,itypj, -c! & " chi1",chi1," chi2",chi2," chi12",chi12, -c! & " chip1",chip1," chip2",chip2," chip12",chip12 -c! not used by momo potential, but needed by sc_angular which is shared -c! by all energy_potential subroutines - alf1 = 0.0d0 - alf2 = 0.0d0 - alf12 = 0.0d0 -c! location, location, location - 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 ) -c! distance from center of chain(?) to polar/charged head -c! write (*,*) "istate = ", 1 -c! write (*,*) "ii = ", 1 -c! write (*,*) "jj = ", 1 - d1 = dhead(1, 1, itypi, itypj) - d2 = dhead(2, 1, itypi, itypj) -c! ai*aj from Fgb - a12sq = rborn(itypi,itypj) * rborn(itypj,itypi) -c! a12sq = a12sq * a12sq -c! charge of amino acid itypi is... - Qi = icharge(itypi) - Qj = icharge(itypj) - Qij = Qi * Qj -c! chis1,2,12 - chis1 = chis(itypi,itypj) - chis2 = chis(itypj,itypi) - chis12 = chis1 * chis2 - sig1 = sigmap1(itypi,itypj) - sig2 = sigmap2(itypi,itypj) -c! write (*,*) "sig1 = ", sig1 -c! write (*,*) "sig2 = ", sig2 -c! alpha factors from Fcav/Gcav - b1 = alphasur(1,itypi,itypj) - b2 = alphasur(2,itypi,itypj) - b3 = alphasur(3,itypi,itypj) - b4 = alphasur(4,itypi,itypj) -c! used to determine whether we want to do quadrupole calculations - wqd = wquad(itypi, itypj) -c! used by Fgb - eps_in = epsintab(itypi,itypj) - eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) -c! write (*,*) "eps_inout_fac = ", eps_inout_fac -c!------------------------------------------------------------------- -c! tail location and distance calculations - Rtail = 0.0d0 - DO k = 1, 3 - ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i) - ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j) - END DO -c! tail distances will be themselves usefull elswhere -c1 (in Gcav, for example) - Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 ) - Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 ) - Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 ) - Rtail = dsqrt( - & (Rtail_distance(1)*Rtail_distance(1)) - & + (Rtail_distance(2)*Rtail_distance(2)) - & + (Rtail_distance(3)*Rtail_distance(3))) -c!------------------------------------------------------------------- -c! Calculate location and distance between polar heads -c! distance between heads -c! for each one of our three dimensional space... - DO k = 1,3 -c! location of polar head is computed by taking hydrophobic centre -c! and moving by a d1 * dc_norm vector -c! see unres publications for very informative images - chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) - chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) -c! distance -c! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) -c! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) - Rhead_distance(k) = chead(k,2) - chead(k,1) - END DO -c! pitagoras (root of sum of squares) - Rhead = dsqrt( - & (Rhead_distance(1)*Rhead_distance(1)) - & + (Rhead_distance(2)*Rhead_distance(2)) - & + (Rhead_distance(3)*Rhead_distance(3))) -c!------------------------------------------------------------------- -c! zero everything that should be zero'ed - Egb = 0.0d0 - ECL = 0.0d0 - Elj = 0.0d0 - Equad = 0.0d0 - Epol = 0.0d0 - eheadtail = 0.0d0 - dGCLdOM1 = 0.0d0 - dGCLdOM2 = 0.0d0 - dGCLdOM12 = 0.0d0 - dPOLdOM1 = 0.0d0 - dPOLdOM2 = 0.0d0 - RETURN - END SUBROUTINE elgrad_init -c!------------------------------------------------------------------- - subroutine sc_angular -C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2, -C om12. Called by ebp, egb, and egbv. - implicit none - include 'COMMON.CALC' - include 'COMMON.IOUNITS' - erij(1)=xj*rij - erij(2)=yj*rij - erij(3)=zj*rij - om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) - om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) - om12=dxi*dxj+dyi*dyj+dzi*dzj -c! om1 = 0.0d0 -c! om2 = 0.0d0 -c! om12 = 0.0d0 - chiom12=chi12*om12 -C Calculate eps1(om12) and its derivative in om12 - faceps1=1.0D0-om12*chiom12 - faceps1_inv=1.0D0/faceps1 - eps1=dsqrt(faceps1_inv) -c write (2,*) "chi1",chi1," chi2",chi2," chi12",chi12 -c write (2,*) "fsceps1",faceps1," faceps1_inv",faceps1_inv, -c & " eps1",eps1 -C Following variable is eps1*deps1/dom12 - eps1_om12=faceps1_inv*chiom12 -c diagnostics only -c faceps1_inv=om12 -c eps1=om12 -c eps1_om12=1.0d0 -c write (iout,*) "om12",om12," eps1",eps1 -C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2, -C and om12. - om1om2=om1*om2 - chiom1=chi1*om1 - chiom2=chi2*om2 - facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12 - sigsq=1.0D0-facsig*faceps1_inv -c write (2,*) "om1",om1," om2",om2," om1om2",om1om2, -c & " chiom1",chiom1, -c & " chiom2",chiom2," facsig",facsig," sigsq",sigsq - sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv - sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv - sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2 -c diagnostics only -c sigsq=1.0d0 -c sigsq_om1=0.0d0 -c sigsq_om2=0.0d0 -c sigsq_om12=0.0d0 -c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12 -c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv, -c & " eps1",eps1 -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 write (iout,*) "chipom1",chipom1," chipom2",chipom2, -c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv -C Following variable is the square root of eps2 - eps2rt=1.0D0-facp1*facp_inv -C Following three variables are the derivatives of the square root of eps -C in om1, om2, and om12. - eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv - eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv - eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2 -C Evaluate the "asymmetric" factor in the VDW constant, eps3 -c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular -c! Or frankly, we should restructurize the whole energy section - eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12 -c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt -c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2, -c & " eps2rt_om12",eps2rt_om12 -C Calculate whole angle-dependent part of epsilon and contributions -C to its derivatives - return - end -C---------------------------------------------------------------------------- - subroutine sc_grad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.CALC' - double precision dcosom1(3),dcosom2(3) - eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 - eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 - eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 - & -2.0D0*alf12*eps3der+sigder*sigsq_om12 - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - do k=1,3 - gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k) - enddo - 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 -C -C Calculate the components of the gradient in DC and X -C - do k=i,j-1 - do l=1,3 - gvdwc(l,k)=gvdwc(l,k)+gg(l) - enddo - enddo - return - end -c------------------------------------------------------------------------------ - subroutine vec_and_deriv - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.VECTORS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2) -C Compute the local reference systems. For reference system (i), the -C X-axis points from CA(i) to CA(i+1), the Y axis is in the -C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane. - do i=1,nres-1 -c if (i.eq.nres-1 .or. itel(i+1).eq.0) then - if (i.eq.nres-1) then -C Case of the last full residue -C Compute the Z-axis - call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i)) - costh=dcos(pi-theta(nres)) - fac=1.0d0/dsqrt(1.0d0-costh*costh) - do k=1,3 - uz(k,i)=fac*uz(k,i) - enddo - if (calc_grad) then -C Compute the derivatives of uz - uzder(1,1,1)= 0.0d0 - uzder(2,1,1)=-dc_norm(3,i-1) - uzder(3,1,1)= dc_norm(2,i-1) - uzder(1,2,1)= dc_norm(3,i-1) - uzder(2,2,1)= 0.0d0 - uzder(3,2,1)=-dc_norm(1,i-1) - uzder(1,3,1)=-dc_norm(2,i-1) - uzder(2,3,1)= dc_norm(1,i-1) - uzder(3,3,1)= 0.0d0 - uzder(1,1,2)= 0.0d0 - uzder(2,1,2)= dc_norm(3,i) - uzder(3,1,2)=-dc_norm(2,i) - uzder(1,2,2)=-dc_norm(3,i) - uzder(2,2,2)= 0.0d0 - uzder(3,2,2)= dc_norm(1,i) - uzder(1,3,2)= dc_norm(2,i) - uzder(2,3,2)=-dc_norm(1,i) - uzder(3,3,2)= 0.0d0 - endif -C Compute the Y-axis - facy=fac - do k=1,3 - uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i)) - enddo - if (calc_grad) then -C Compute the derivatives of uy - do j=1,3 - do k=1,3 - uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) - & -dc_norm(k,i)*dc_norm(j,i-1) - uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) - enddo - uyder(j,j,1)=uyder(j,j,1)-costh - uyder(j,j,2)=1.0d0+uyder(j,j,2) - enddo - do j=1,2 - do k=1,3 - do l=1,3 - uygrad(l,k,j,i)=uyder(l,k,j) - uzgrad(l,k,j,i)=uzder(l,k,j) - enddo - enddo - enddo - call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) - call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) - call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) - call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) - endif - else -C Other residues -C Compute the Z-axis - call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i)) - costh=dcos(pi-theta(i+2)) - fac=1.0d0/dsqrt(1.0d0-costh*costh) - do k=1,3 - uz(k,i)=fac*uz(k,i) - enddo - if (calc_grad) then -C Compute the derivatives of uz - uzder(1,1,1)= 0.0d0 - uzder(2,1,1)=-dc_norm(3,i+1) - uzder(3,1,1)= dc_norm(2,i+1) - uzder(1,2,1)= dc_norm(3,i+1) - uzder(2,2,1)= 0.0d0 - uzder(3,2,1)=-dc_norm(1,i+1) - uzder(1,3,1)=-dc_norm(2,i+1) - uzder(2,3,1)= dc_norm(1,i+1) - uzder(3,3,1)= 0.0d0 - uzder(1,1,2)= 0.0d0 - uzder(2,1,2)= dc_norm(3,i) - uzder(3,1,2)=-dc_norm(2,i) - uzder(1,2,2)=-dc_norm(3,i) - uzder(2,2,2)= 0.0d0 - uzder(3,2,2)= dc_norm(1,i) - uzder(1,3,2)= dc_norm(2,i) - uzder(2,3,2)=-dc_norm(1,i) - uzder(3,3,2)= 0.0d0 - endif -C Compute the Y-axis - facy=fac - do k=1,3 - uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) - enddo - if (calc_grad) then -C Compute the derivatives of uy - do j=1,3 - do k=1,3 - uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) - & -dc_norm(k,i)*dc_norm(j,i+1) - uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) - enddo - uyder(j,j,1)=uyder(j,j,1)-costh - uyder(j,j,2)=1.0d0+uyder(j,j,2) - enddo - do j=1,2 - do k=1,3 - do l=1,3 - uygrad(l,k,j,i)=uyder(l,k,j) - uzgrad(l,k,j,i)=uzder(l,k,j) - enddo - enddo - enddo - call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) - call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) - call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) - call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) - endif - endif - enddo - if (calc_grad) then - do i=1,nres-1 - vbld_inv_temp(1)=vbld_inv(i+1) - if (i.lt.nres-1) then - vbld_inv_temp(2)=vbld_inv(i+2) - else - vbld_inv_temp(2)=vbld_inv(i) - endif - do j=1,2 - do k=1,3 - do l=1,3 - uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i) - uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i) - enddo - enddo - enddo - enddo - endif - return - end -C----------------------------------------------------------------------------- - subroutine vec_and_deriv_test - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.VECTORS' - dimension uyder(3,3,2),uzder(3,3,2) -C Compute the local reference systems. For reference system (i), the -C X-axis points from CA(i) to CA(i+1), the Y axis is in the -C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane. - do i=1,nres-1 - if (i.eq.nres-1) then -C Case of the last full residue -C Compute the Z-axis - call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i)) - costh=dcos(pi-theta(nres)) - fac=1.0d0/dsqrt(1.0d0-costh*costh) -c write (iout,*) 'fac',fac, -c & 1.0d0/dsqrt(scalar(uz(1,i),uz(1,i))) - fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i))) - do k=1,3 - uz(k,i)=fac*uz(k,i) - enddo -C Compute the derivatives of uz - uzder(1,1,1)= 0.0d0 - uzder(2,1,1)=-dc_norm(3,i-1) - uzder(3,1,1)= dc_norm(2,i-1) - uzder(1,2,1)= dc_norm(3,i-1) - uzder(2,2,1)= 0.0d0 - uzder(3,2,1)=-dc_norm(1,i-1) - uzder(1,3,1)=-dc_norm(2,i-1) - uzder(2,3,1)= dc_norm(1,i-1) - uzder(3,3,1)= 0.0d0 - uzder(1,1,2)= 0.0d0 - uzder(2,1,2)= dc_norm(3,i) - uzder(3,1,2)=-dc_norm(2,i) - uzder(1,2,2)=-dc_norm(3,i) - uzder(2,2,2)= 0.0d0 - uzder(3,2,2)= dc_norm(1,i) - uzder(1,3,2)= dc_norm(2,i) - uzder(2,3,2)=-dc_norm(1,i) - uzder(3,3,2)= 0.0d0 -C Compute the Y-axis - do k=1,3 - uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i)) - enddo - facy=fac - facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))* - & (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2- - & scalar(dc_norm(1,i),dc_norm(1,i-1))**2)) - do k=1,3 -c uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) - uy(k,i)= -c & facy*( - & dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i)) - & -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i) -c & ) - enddo -c write (iout,*) 'facy',facy, -c & 1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) - facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) - do k=1,3 - uy(k,i)=facy*uy(k,i) - enddo -C Compute the derivatives of uy - do j=1,3 - do k=1,3 - uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) - & -dc_norm(k,i)*dc_norm(j,i-1) - uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) - enddo -c uyder(j,j,1)=uyder(j,j,1)-costh -c uyder(j,j,2)=1.0d0+uyder(j,j,2) - uyder(j,j,1)=uyder(j,j,1) - & -scalar(dc_norm(1,i),dc_norm(1,i-1)) - uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i)) - & +uyder(j,j,2) - enddo - do j=1,2 - do k=1,3 - do l=1,3 - uygrad(l,k,j,i)=uyder(l,k,j) - uzgrad(l,k,j,i)=uzder(l,k,j) - enddo - enddo - enddo - call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) - call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) - call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) - call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) - else -C Other residues -C Compute the Z-axis - call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i)) - costh=dcos(pi-theta(i+2)) - fac=1.0d0/dsqrt(1.0d0-costh*costh) - fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i))) - do k=1,3 - uz(k,i)=fac*uz(k,i) - enddo -C Compute the derivatives of uz - uzder(1,1,1)= 0.0d0 - uzder(2,1,1)=-dc_norm(3,i+1) - uzder(3,1,1)= dc_norm(2,i+1) - uzder(1,2,1)= dc_norm(3,i+1) - uzder(2,2,1)= 0.0d0 - uzder(3,2,1)=-dc_norm(1,i+1) - uzder(1,3,1)=-dc_norm(2,i+1) - uzder(2,3,1)= dc_norm(1,i+1) - uzder(3,3,1)= 0.0d0 - uzder(1,1,2)= 0.0d0 - uzder(2,1,2)= dc_norm(3,i) - uzder(3,1,2)=-dc_norm(2,i) - uzder(1,2,2)=-dc_norm(3,i) - uzder(2,2,2)= 0.0d0 - uzder(3,2,2)= dc_norm(1,i) - uzder(1,3,2)= dc_norm(2,i) - uzder(2,3,2)=-dc_norm(1,i) - uzder(3,3,2)= 0.0d0 -C Compute the Y-axis - facy=fac - facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))* - & (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2- - & scalar(dc_norm(1,i),dc_norm(1,i+1))**2)) - do k=1,3 -c uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) - uy(k,i)= -c & facy*( - & dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i)) - & -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i) -c & ) - enddo -c write (iout,*) 'facy',facy, -c & 1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) - facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) - do k=1,3 - uy(k,i)=facy*uy(k,i) - enddo -C Compute the derivatives of uy - do j=1,3 - do k=1,3 - uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) - & -dc_norm(k,i)*dc_norm(j,i+1) - uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) - enddo -c uyder(j,j,1)=uyder(j,j,1)-costh -c uyder(j,j,2)=1.0d0+uyder(j,j,2) - uyder(j,j,1)=uyder(j,j,1) - & -scalar(dc_norm(1,i),dc_norm(1,i+1)) - uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i)) - & +uyder(j,j,2) - enddo - do j=1,2 - do k=1,3 - do l=1,3 - uygrad(l,k,j,i)=uyder(l,k,j) - uzgrad(l,k,j,i)=uzder(l,k,j) - enddo - enddo - enddo - call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) - call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) - call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) - call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) - endif - enddo - do i=1,nres-1 - do j=1,2 - do k=1,3 - do l=1,3 - uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i) - uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i) - enddo - enddo - enddo - enddo - return - end -C----------------------------------------------------------------------------- - subroutine check_vecgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - 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) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - double precision auxvec(2),auxmat(2,2) -C -C Compute the virtual-bond-torsional-angle dependent quantities needed -C to calculate the el-loc multibody terms of various order. -C -#ifdef NEWCORR - do i=3,nres+1 - if (i.gt. nnt+2 .and. i.lt.nct+2) then - iti = itortyp(itype(i-2)) - else - iti=ntortyp+1 - endif - if (i.gt. nnt+1 .and. i.lt.nct+1) then - iti1 = itortyp(itype(i-1)) - else - iti1=ntortyp+1 - endif - b1(1,i-2)=bnew1(1,1,iti)*sin(theta(i-1)/2.0) - & +bnew1(2,1,iti)*sin(theta(i-1)) - & +bnew1(3,1,iti)*cos(theta(i-1)/2.0) - b2(1,i-2)=bnew2(1,1,iti)*sin(theta(i-1)/2.0) - & +bnew2(2,1,iti)*sin(theta(i-1)) - & +bnew2(3,1,iti)*cos(theta(i-1)/2.0) - b1(2,i-2)=bnew1(1,2,iti) - b2(2,i-2)=bnew2(1,2,iti) - EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1)) - EE(1,2,i-2)=eeold(1,2,iti) - EE(2,1,i-2)=eeold(2,1,iti) - EE(2,2,i-2)=eeold(2,2,iti) - b1tilde(1,i-2)=b1(1,i-2) - b1tilde(2,i-2)=-b1(2,i-2) - enddo -#endif - do i=3,nres+1 - if (i .lt. nres+1) then - sin1=dsin(phi(i)) - cos1=dcos(phi(i)) - sintab(i-2)=sin1 - costab(i-2)=cos1 - obrot(1,i-2)=cos1 - obrot(2,i-2)=sin1 - sin2=dsin(2*phi(i)) - cos2=dcos(2*phi(i)) - sintab2(i-2)=sin2 - costab2(i-2)=cos2 - obrot2(1,i-2)=cos2 - obrot2(2,i-2)=sin2 - Ug(1,1,i-2)=-cos1 - Ug(1,2,i-2)=-sin1 - Ug(2,1,i-2)=-sin1 - Ug(2,2,i-2)= cos1 - Ug2(1,1,i-2)=-cos2 - Ug2(1,2,i-2)=-sin2 - Ug2(2,1,i-2)=-sin2 - Ug2(2,2,i-2)= cos2 - else - costab(i-2)=1.0d0 - sintab(i-2)=0.0d0 - obrot(1,i-2)=1.0d0 - obrot(2,i-2)=0.0d0 - obrot2(1,i-2)=0.0d0 - obrot2(2,i-2)=0.0d0 - Ug(1,1,i-2)=1.0d0 - Ug(1,2,i-2)=0.0d0 - Ug(2,1,i-2)=0.0d0 - Ug(2,2,i-2)=1.0d0 - Ug2(1,1,i-2)=0.0d0 - Ug2(1,2,i-2)=0.0d0 - 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 - obrot_der(1,i-2)=-sin1 - obrot_der(2,i-2)= cos1 - Ugder(1,1,i-2)= sin1 - Ugder(1,2,i-2)=-cos1 - Ugder(2,1,i-2)=-cos1 - Ugder(2,2,i-2)=-sin1 - dwacos2=cos2+cos2 - dwasin2=sin2+sin2 - obrot2_der(1,i-2)=-dwasin2 - obrot2_der(2,i-2)= dwacos2 - Ug2der(1,1,i-2)= dwasin2 - Ug2der(1,2,i-2)=-dwacos2 - Ug2der(2,1,i-2)=-dwacos2 - Ug2der(2,2,i-2)=-dwasin2 - else - obrot_der(1,i-2)=0.0d0 - obrot_der(2,i-2)=0.0d0 - Ugder(1,1,i-2)=0.0d0 - Ugder(1,2,i-2)=0.0d0 - Ugder(2,1,i-2)=0.0d0 - Ugder(2,2,i-2)=0.0d0 - obrot2_der(1,i-2)=0.0d0 - obrot2_der(2,i-2)=0.0d0 - Ug2der(1,1,i-2)=0.0d0 - Ug2der(1,2,i-2)=0.0d0 - Ug2der(2,1,i-2)=0.0d0 - Ug2der(2,2,i-2)=0.0d0 - endif - if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then - iti = itortyp(itype(i-2)) - else - iti=ntortyp+1 - endif - if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then - iti1 = itortyp(itype(i-1)) - else - iti1=ntortyp+1 - endif -cd write (iout,*) '*******i',i,' iti1',iti -cd write (iout,*) 'b1',b1(:,iti) -cd write (iout,*) 'b2',b2(:,iti) -cd write (iout,*) 'Ug',Ug(:,:,i-2) - if (i .gt. iatel_s+2) then - call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2)) - call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2)) - call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2)) - call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2)) - call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2)) - call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2)) - call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2)) - else - do k=1,2 - Ub2(k,i-2)=0.0d0 - Ctobr(k,i-2)=0.0d0 - Dtobr2(k,i-2)=0.0d0 - do l=1,2 - EUg(l,k,i-2)=0.0d0 - CUg(l,k,i-2)=0.0d0 - DUg(l,k,i-2)=0.0d0 - DtUg2(l,k,i-2)=0.0d0 - enddo - enddo - endif - call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2)) - call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2)) - call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2)) - call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2)) - call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2)) - call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2)) - call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2)) - do k=1,2 - muder(k,i-2)=Ub2der(k,i-2) - enddo - if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then - iti1 = itortyp(itype(i-1)) - else - iti1=ntortyp+1 - endif - do k=1,2 - mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1) - enddo -C Vectors and matrices dependent on a single virtual-bond dihedral. - call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1)) - call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2)) - call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2)) - call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2)) - call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2)) - call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2)) - call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2)) - call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2)) - call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2)) -cd write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2), -cd & ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2) - enddo -C Matrices dependent on two consecutive virtual-bond dihedrals. -C The order of matrices is from left to right. - do i=2,nres-1 - call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i)) - call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i)) - call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i)) - call transpose2(DtUg2(1,1,i-1),auxmat(1,1)) - call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i)) - call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i)) - call transpose2(DtUg2der(1,1,i-1),auxmat(1,1)) - call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i)) - enddo -cd do i=1,nres -cd iti = itortyp(itype(i)) -cd write (iout,*) i -cd do j=1,2 -cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)') -cd & (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2) -cd enddo -cd enddo - return - end -C-------------------------------------------------------------------------- - subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) -C -C This subroutine calculates the average interaction energy and its gradient -C in the virtual-bond vectors between non-adjacent peptide groups, based on -C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. -C The potential depends both on the distance of peptide-group centers and on -C the orientation of the CA-CA virtual bonds. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), - & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) - double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), - & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) - common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1 -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions - double precision scal_el /0.5d0/ -C 12/13/98 -C 13-go grudnia roku pamietnego... - double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, - & 0.0d0,1.0d0,0.0d0, - & 0.0d0,0.0d0,1.0d0/ -cd write(iout,*) 'In EELEC' -cd do i=1,nloctyp -cd write(iout,*) 'Type',i -cd write(iout,*) 'B1',B1(:,i) -cd write(iout,*) 'B2',B2(:,i) -cd write(iout,*) 'CC',CC(:,:,i) -cd write(iout,*) 'DD',DD(:,:,i) -cd write(iout,*) 'EE',EE(:,:,i) -cd enddo -cd call check_vecgrad -cd stop - if (icheckgrad.eq.1) then - do i=1,nres-1 - fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) - do k=1,3 - dc_norm(k,i)=dc(k,i)*fac - enddo -c write (iout,*) 'i',i,' fac',fac - enddo - endif - if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. - & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then -cd if (wel_loc.gt.0.0d0) then - if (icheckgrad.eq.1) then - call vec_and_deriv_test - else - call vec_and_deriv - endif - call set_matrices - endif -cd do i=1,nres-1 -cd write (iout,*) 'i=',i -cd do k=1,3 -cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) -cd enddo -cd do k=1,3 -cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') -cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) -cd enddo -cd enddo - num_conti_hb=0 - ees=0.0D0 - evdw1=0.0D0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 - ind=0 - do i=1,nres - num_cont_hb(i)=0 - enddo -cd print '(a)','Enter EELEC' -cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e - do i=1,nres - gel_loc_loc(i)=0.0d0 - gcorr_loc(i)=0.0d0 - enddo - do i=iatel_s,iatel_e - if (itel(i).eq.0) goto 1215 - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 -c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) - do j=ielstart(i),ielend(i) - if (itel(j).eq.0) goto 1216 - 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) -C Diagnostics only!!! -c aaa=0.0D0 -c bbb=0.0D0 -c ael6i=0.0D0 -c ael3i=0.0D0 -C End diagnostics - ael6i=ael6(iteli,itelj) - ael3i=ael3(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - rmij=1.0D0/rij - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj - cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij - cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij - fac=cosa-3.0D0*cosb*cosg - ev1=aaa*r6ij*r6ij -c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - fac3=ael6i*r6ij - fac4=ael3i*r3ij - evdwij=ev1+ev2 - el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - eesij=el1+el2 -c write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij -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 -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 -C -C Calculate contributions to the Cartesian gradient. -C -#ifdef SPLITELE - facvdw=-6*rrmij*(ev1+evdwij) - facel=-3*rrmij*(el1+eesij) - fac1=fac - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij - if (calc_grad) then -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=facel*xj - ggg(2)=facel*yj - ggg(3)=facel*zj - do k=1,3 - ghalf=0.5D0*ggg(k) - gelc(k,i)=gelc(k,i)+ghalf - gelc(k,j)=gelc(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* - do k=i+1,j-1 - do l=1,3 - gelc(l,k)=gelc(l,k)+ggg(l) - enddo - enddo - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - do k=1,3 - ghalf=0.5D0*ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)+ghalf - gvdwpp(k,j)=gvdwpp(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* - do k=i+1,j-1 - do l=1,3 - gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) - enddo - enddo -#else - facvdw=ev1+evdwij - facel=el1+eesij - fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij - if (calc_grad) then -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=fac*xj - ggg(2)=fac*yj - ggg(3)=fac*zj - do k=1,3 - ghalf=0.5D0*ggg(k) - gelc(k,i)=gelc(k,i)+ghalf - gelc(k,j)=gelc(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* - do k=i+1,j-1 - do l=1,3 - gelc(l,k)=gelc(l,k)+ggg(l) - enddo - enddo -#endif -* -* Angular part -* - ecosa=2.0D0*fac3*fac1+fac4 - fac4=-3.0D0*fac4 - fac3=-6.0D0*fac3 - ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) - ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo -cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), -cd & (dcosg(k),k=1,3) - do k=1,3 - ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) - enddo - do k=1,3 - ghalf=0.5D0*ggg(k) - gelc(k,i)=gelc(k,i)+ghalf - & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gelc(k,j)=gelc(k,j)+ghalf - & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - enddo - do k=i+1,j-1 - do l=1,3 - gelc(l,k)=gelc(l,k)+ggg(l) - enddo - enddo - endif - - IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 - & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -C -C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction -C energy of a peptide unit is assumed in the form of a second-order -C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. -C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms -C are computed for EVERY pair of non-contiguous peptide groups. -C - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - kkk=0 - do k=1,2 - do l=1,2 - kkk=kkk+1 - muij(kkk)=mu(k,i)*mu(l,j) - enddo - enddo -cd write (iout,*) 'EELEC: i',i,' j',j -cd write (iout,*) 'j',j,' j1',j1,' j2',j2 -cd write(iout,*) 'muij',muij - ury=scalar(uy(1,i),erij) - urz=scalar(uz(1,i),erij) - vry=scalar(uy(1,j),erij) - vrz=scalar(uz(1,j),erij) - a22=scalar(uy(1,i),uy(1,j))-3*ury*vry - a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz - a32=scalar(uz(1,i),uy(1,j))-3*urz*vry - a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz -C For diagnostics only -cd a22=1.0d0 -cd a23=1.0d0 -cd a32=1.0d0 -cd a33=1.0d0 - fac=dsqrt(-ael6i)*r3ij -cd write (2,*) 'fac=',fac -C For diagnostics only -cd fac=1.0d0 - a22=a22*fac - a23=a23*fac - a32=a32*fac - a33=a33*fac -cd write (iout,'(4i5,4f10.5)') -cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 -cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij -cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3), -cd & (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3) -cd write (iout,'(4f10.5)') -cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)), -cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j)) -cd write (iout,'(4f10.5)') ury,urz,vry,vrz -cd write (iout,'(2i3,9f10.5/)') i,j, -cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij - if (calc_grad) then -C Derivatives of the elements of A in virtual-bond vectors - call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) -cd do k=1,3 -cd do l=1,3 -cd erder(k,l)=0.0d0 -cd enddo -cd enddo - 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 -cd do k=1,3 -cd do l=1,3 -cd uryg(k,l)=0.0d0 -cd urzg(k,l)=0.0d0 -cd vryg(k,l)=0.0d0 -cd vrzg(k,l)=0.0d0 -cd enddo -cd enddo -C Compute radial contributions to the gradient - facr=-3.0d0*rrmij - a22der=a22*facr - a23der=a23*facr - a32der=a32*facr - a33der=a33*facr -cd a22der=0.0d0 -cd a23der=0.0d0 -cd a32der=0.0d0 -cd a33der=0.0d0 - agg(1,1)=a22der*xj - agg(2,1)=a22der*yj - agg(3,1)=a22der*zj - agg(1,2)=a23der*xj - agg(2,2)=a23der*yj - agg(3,2)=a23der*zj - agg(1,3)=a32der*xj - agg(2,3)=a32der*yj - agg(3,3)=a32der*zj - agg(1,4)=a33der*xj - agg(2,4)=a33der*yj - agg(3,4)=a33der*zj -C Add the contributions coming from er - fac3=-3.0d0*fac - do k=1,3 - agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) - agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) - agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) - agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) - enddo - do k=1,3 -C Derivatives in DC(i) - ghalf1=0.5d0*agg(k,1) - ghalf2=0.5d0*agg(k,2) - ghalf3=0.5d0*agg(k,3) - ghalf4=0.5d0*agg(k,4) - aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) - & -3.0d0*uryg(k,2)*vry)+ghalf1 - aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) - & -3.0d0*uryg(k,2)*vrz)+ghalf2 - aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) - & -3.0d0*urzg(k,2)*vry)+ghalf3 - aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) - & -3.0d0*urzg(k,2)*vrz)+ghalf4 -C Derivatives in DC(i+1) - aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) - & -3.0d0*uryg(k,3)*vry)+agg(k,1) - aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) - & -3.0d0*uryg(k,3)*vrz)+agg(k,2) - aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) - & -3.0d0*urzg(k,3)*vry)+agg(k,3) - aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) - & -3.0d0*urzg(k,3)*vrz)+agg(k,4) -C Derivatives in DC(j) - aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) - & -3.0d0*vryg(k,2)*ury)+ghalf1 - aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) - & -3.0d0*vrzg(k,2)*ury)+ghalf2 - aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) - & -3.0d0*vryg(k,2)*urz)+ghalf3 - aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) - & -3.0d0*vrzg(k,2)*urz)+ghalf4 -C Derivatives in DC(j+1) or DC(nres-1) - aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) - & -3.0d0*vryg(k,3)*ury) - aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) - & -3.0d0*vrzg(k,3)*ury) - aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) - & -3.0d0*vryg(k,3)*urz) - aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) - & -3.0d0*vrzg(k,3)*urz) -cd aggi(k,1)=ghalf1 -cd aggi(k,2)=ghalf2 -cd aggi(k,3)=ghalf3 -cd aggi(k,4)=ghalf4 -C Derivatives in DC(i+1) -cd aggi1(k,1)=agg(k,1) -cd aggi1(k,2)=agg(k,2) -cd aggi1(k,3)=agg(k,3) -cd aggi1(k,4)=agg(k,4) -C Derivatives in DC(j) -cd aggj(k,1)=ghalf1 -cd aggj(k,2)=ghalf2 -cd aggj(k,3)=ghalf3 -cd aggj(k,4)=ghalf4 -C Derivatives in DC(j+1) -cd aggj1(k,1)=0.0d0 -cd aggj1(k,2)=0.0d0 -cd aggj1(k,3)=0.0d0 -cd aggj1(k,4)=0.0d0 - if (j.eq.nres-1 .and. i.lt.j-2) then - do l=1,4 - aggj1(k,l)=aggj1(k,l)+agg(k,l) -cd aggj1(k,l)=agg(k,l) - enddo - endif - enddo - endif -c goto 11111 -C Check the loc-el terms by numerical integration - acipa(1,1)=a22 - acipa(1,2)=a23 - acipa(2,1)=a32 - acipa(2,2)=a33 - a22=-a22 - a23=-a23 - do l=1,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - if (j.lt.nres-1) then - a22=-a22 - a32=-a32 - do l=1,3,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - else - a22=-a22 - a23=-a23 - a32=-a32 - a33=-a33 - do l=1,4 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - endif - ENDIF ! WCORR -11111 continue - 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 -cd write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) - eel_loc=eel_loc+eel_loc_ij -C Partial derivatives in virtual-bond dihedral angles gamma - if (calc_grad) then - if (i.gt.1) - & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ - & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) - & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j) - gel_loc_loc(j-1)=gel_loc_loc(j-1)+ - & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) - & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j) -cd call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij) -cd write(iout,*) 'agg ',agg -cd write(iout,*) 'aggi ',aggi -cd write(iout,*) 'aggi1',aggi1 -cd write(iout,*) 'aggj ',aggj -cd write(iout,*) 'aggj1',aggj1 - -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) - enddo - do k=i+2,j2 - do l=1,3 - gel_loc(l,k)=gel_loc(l,k)+ggg(l) - enddo - enddo -C Remaining derivatives of eello - do l=1,3 - gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ - & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4) - gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ - & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) - gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ - & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) - gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ - & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) - enddo - endif - ENDIF - if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then -C Contributions from turns - a_temp(1,1)=a22 - a_temp(1,2)=a23 - a_temp(2,1)=a32 - a_temp(2,2)=a33 - call eturn34(i,j,eello_turn3,eello_turn4) - endif -C Change 12/26/95 to calculate four-body contributions to H-bonding energy - if (j.gt.i+1 .and. num_conti.le.maxconts) then -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 - IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. - & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el -C terms. - d_cont(num_conti,i)=rij -cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij -C --- Electrostatic-interaction matrix --- - a_chuj(1,1,num_conti,i)=a22 - a_chuj(1,2,num_conti,i)=a23 - a_chuj(2,1,num_conti,i)=a32 - a_chuj(2,2,num_conti,i)=a33 -C --- Gradient of rij - do kkk=1,3 - grij_hb_cont(kkk,num_conti,i)=erij(kkk) - enddo -c if (i.eq.1) then -c a_chuj(1,1,num_conti,i)=-0.61d0 -c a_chuj(1,2,num_conti,i)= 0.4d0 -c a_chuj(2,1,num_conti,i)= 0.65d0 -c a_chuj(2,2,num_conti,i)= 0.50d0 -c else if (i.eq.2) then -c a_chuj(1,1,num_conti,i)= 0.0d0 -c a_chuj(1,2,num_conti,i)= 0.0d0 -c a_chuj(2,1,num_conti,i)= 0.0d0 -c a_chuj(2,2,num_conti,i)= 0.0d0 -c endif -C --- and its gradients -cd write (iout,*) 'i',i,' j',j -cd do kkk=1,3 -cd write (iout,*) 'iii 1 kkk',kkk -cd write (iout,*) agg(kkk,:) -cd enddo -cd do kkk=1,3 -cd write (iout,*) 'iii 2 kkk',kkk -cd write (iout,*) aggi(kkk,:) -cd enddo -cd do kkk=1,3 -cd write (iout,*) 'iii 3 kkk',kkk -cd write (iout,*) aggi1(kkk,:) -cd enddo -cd do kkk=1,3 -cd write (iout,*) 'iii 4 kkk',kkk -cd write (iout,*) aggj(kkk,:) -cd enddo -cd do kkk=1,3 -cd write (iout,*) 'iii 5 kkk',kkk -cd write (iout,*) aggj1(kkk,:) -cd 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) -c do mm=1,5 -c a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0 -c enddo - enddo - enddo - enddo - ENDIF - IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN -C Calculate contact energies - cosa4=4.0D0*cosa - wij=cosa-3.0D0*cosb*cosg - cosbg1=cosb+cosg - cosbg2=cosb-cosg -c fac3=dsqrt(-ael6i)/r0ij**3 - fac3=dsqrt(-ael6i)*r3ij - ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) - ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) -c ees0mij=0.0D0 - ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) - ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) -C Diagnostics. Comment out or remove after debugging! -c ees0p(num_conti,i)=0.5D0*fac3*ees0pij -c ees0m(num_conti,i)=0.5D0*fac3*ees0mij -c ees0m(num_conti,i)=0.0D0 -C End diagnostics. -c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, -c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont - facont_hb(num_conti,i)=fcont - if (calc_grad) then -C Angular derivatives of the contact function - ees0pij1=fac3/ees0pij - ees0mij1=fac3/ees0mij - fac3p=-3.0D0*fac3*rrmij - ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) - ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) -c ees0mij1=0.0D0 - ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) - ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) - ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) - ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) - ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) - ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) - ecosap=ecosa1+ecosa2 - ecosbp=ecosb1+ecosb2 - ecosgp=ecosg1+ecosg2 - ecosam=ecosa1-ecosa2 - ecosbm=ecosb1-ecosb2 - ecosgm=ecosg1-ecosg2 -C Diagnostics -c ecosap=ecosa1 -c ecosbp=ecosb1 -c ecosgp=ecosg1 -c ecosam=0.0D0 -c ecosbm=0.0D0 -c ecosgm=0.0D0 -C End diagnostics - fprimcont=fprimcont/rij -cd facont_hb(num_conti,i)=1.0D0 -C Following line is for diagnostics. -cd fprimcont=0.0D0 - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo - do k=1,3 - gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) - gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) - enddo - gggp(1)=gggp(1)+ees0pijp*xj - gggp(2)=gggp(2)+ees0pijp*yj - gggp(3)=gggp(3)+ees0pijp*zj - gggm(1)=gggm(1)+ees0mijp*xj - gggm(2)=gggm(2)+ees0mijp*yj - gggm(3)=gggm(3)+ees0mijp*zj -C Derivatives due to the contact function - gacont_hbr(1,num_conti,i)=fprimcont*xj - gacont_hbr(2,num_conti,i)=fprimcont*yj - gacont_hbr(3,num_conti,i)=fprimcont*zj - do k=1,3 - ghalfp=0.5D0*gggp(k) - ghalfm=0.5D0*gggm(k) - gacontp_hb1(k,num_conti,i)=ghalfp - & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontp_hb2(k,num_conti,i)=ghalfp - & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontp_hb3(k,num_conti,i)=gggp(k) - gacontm_hb1(k,num_conti,i)=ghalfm - & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontm_hb2(k,num_conti,i)=ghalfm - & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontm_hb3(k,num_conti,i)=gggm(k) - enddo - endif -C Diagnostics. Comment out or remove after debugging! -cdiag do k=1,3 -cdiag gacontp_hb1(k,num_conti,i)=0.0D0 -cdiag gacontp_hb2(k,num_conti,i)=0.0D0 -cdiag gacontp_hb3(k,num_conti,i)=0.0D0 -cdiag gacontm_hb1(k,num_conti,i)=0.0D0 -cdiag gacontm_hb2(k,num_conti,i)=0.0D0 -cdiag gacontm_hb3(k,num_conti,i)=0.0D0 -cdiag enddo - ENDIF ! wcorr - endif ! num_conti.le.maxconts - endif ! fcont.gt.0 - endif ! j.gt.i+1 - 1216 continue - enddo ! j - num_cont_hb(i)=num_conti - 1215 continue - enddo ! i -cd do i=1,nres -cd write (iout,'(i3,3f10.5,5x,3f10.5)') -cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) -cd enddo -c 12/7/99 Adam eello_turn3 will be considered as a separate energy term -ccc eel_loc=eel_loc+eello_turn3 - return - end -C----------------------------------------------------------------------------- - subroutine eturn34(i,j,eello_turn3,eello_turn4) -C Third- and fourth-order contributions from turns - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - dimension ggg(3) - double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2), - & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2), - & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2) - double precision agg(3,4),aggi(3,4),aggi1(3,4), - & aggj(3,4),aggj1(3,4),a_temp(2,2) - common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2 - if (j.eq.i+2) then -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C Third-order contributions -C -C (i+2)o----(i+3) -C | | -C | | -C (i+1)o----i -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd call checkint_turn3(i,a_temp,eello_turn3_num) - call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1)) - call transpose2(auxmat(1,1),auxmat1(1,1)) - call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) - eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) -cd write (2,*) 'i,',i,' j',j,'eello_turn3', -cd & 0.5d0*(pizda(1,1)+pizda(2,2)), -cd & ' eello_turn3_num',4*eello_turn3_num - if (calc_grad) then -C Derivatives in gamma(i) - call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1)) - call transpose2(auxmat2(1,1),pizda(1,1)) - call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1)) - gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2)) -C Derivatives in gamma(i+1) - call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1)) - call transpose2(auxmat2(1,1),pizda(1,1)) - call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1)) - gel_loc_turn3(i+1)=gel_loc_turn3(i+1) - & +0.5d0*(pizda(1,1)+pizda(2,2)) -C Cartesian derivatives - do l=1,3 - a_temp(1,1)=aggi(l,1) - a_temp(1,2)=aggi(l,2) - a_temp(2,1)=aggi(l,3) - a_temp(2,2)=aggi(l,4) - call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) - gcorr3_turn(l,i)=gcorr3_turn(l,i) - & +0.5d0*(pizda(1,1)+pizda(2,2)) - a_temp(1,1)=aggi1(l,1) - a_temp(1,2)=aggi1(l,2) - a_temp(2,1)=aggi1(l,3) - a_temp(2,2)=aggi1(l,4) - call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) - gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) - & +0.5d0*(pizda(1,1)+pizda(2,2)) - a_temp(1,1)=aggj(l,1) - a_temp(1,2)=aggj(l,2) - a_temp(2,1)=aggj(l,3) - a_temp(2,2)=aggj(l,4) - call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) - gcorr3_turn(l,j)=gcorr3_turn(l,j) - & +0.5d0*(pizda(1,1)+pizda(2,2)) - a_temp(1,1)=aggj1(l,1) - a_temp(1,2)=aggj1(l,2) - a_temp(2,1)=aggj1(l,3) - a_temp(2,2)=aggj1(l,4) - call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) - gcorr3_turn(l,j1)=gcorr3_turn(l,j1) - & +0.5d0*(pizda(1,1)+pizda(2,2)) - enddo - endif - else if (j.eq.i+3) then -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C Fourth-order contributions -C -C (i+3)o----(i+4) -C / | -C (i+2)o | -C \ | -C (i+1)o----i -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd call checkint_turn4(i,a_temp,eello_turn4_num) - iti1=itortyp(itype(i+1)) - iti2=itortyp(itype(i+2)) - iti3=itortyp(itype(i+3)) - call transpose2(EUg(1,1,i+1),e1t(1,1)) - call transpose2(Eug(1,1,i+2),e2t(1,1)) - call transpose2(Eug(1,1,i+3),e3t(1,1)) - call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) - call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) - call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) - call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - eello_turn4=eello_turn4-(s1+s2+s3) -cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3), -cd & ' eello_turn4_num',8*eello_turn4_num -C Derivatives in gamma(i) - if (calc_grad) then - call transpose2(EUgder(1,1,i+1),e1tder(1,1)) - call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) -C Derivatives in gamma(i+1) - call transpose2(EUgder(1,1,i+2),e2tder(1,1)) - call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1)) - call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) -C Derivatives in gamma(i+2) - call transpose2(EUgder(1,1,i+3),e3tder(1,1)) - call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1)) - call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) -C Cartesian derivatives -C Derivatives of this turn contributions in DC(i+2) - if (j.lt.nres-1) then - do l=1,3 - a_temp(1,1)=agg(l,1) - a_temp(1,2)=agg(l,2) - a_temp(2,1)=agg(l,3) - a_temp(2,2)=agg(l,4) - call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) - call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) - call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) - call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - ggg(l)=-(s1+s2+s3) - gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3) - enddo - endif -C Remaining derivatives of this turn contribution - do l=1,3 - a_temp(1,1)=aggi(l,1) - a_temp(1,2)=aggi(l,2) - a_temp(2,1)=aggi(l,3) - a_temp(2,2)=aggi(l,4) - call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) - call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) - call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) - call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) - a_temp(1,1)=aggi1(l,1) - a_temp(1,2)=aggi1(l,2) - a_temp(2,1)=aggi1(l,3) - a_temp(2,2)=aggi1(l,4) - call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) - call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) - call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) - call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) - a_temp(1,1)=aggj(l,1) - a_temp(1,2)=aggj(l,2) - a_temp(2,1)=aggj(l,3) - a_temp(2,2)=aggj(l,4) - call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) - call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) - call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) - call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) - a_temp(1,1)=aggj1(l,1) - a_temp(1,2)=aggj1(l,2) - a_temp(2,1)=aggj1(l,3) - a_temp(2,2)=aggj1(l,4) - call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) - call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) - call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) - call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) - enddo - endif - endif - return - end -C----------------------------------------------------------------------------- - subroutine vecpr(u,v,w) - implicit real*8(a-h,o-z) - dimension u(3),v(3),w(3) - w(1)=u(2)*v(3)-u(3)*v(2) - w(2)=-u(1)*v(3)+u(3)*v(1) - w(3)=u(1)*v(2)-u(2)*v(1) - return - end -C----------------------------------------------------------------------------- - subroutine unormderiv(u,ugrad,unorm,ungrad) -C This subroutine computes the derivatives of a normalized vector u, given -C the derivatives computed without normalization conditions, ugrad. Returns -C ungrad. - implicit none - double precision u(3),ugrad(3,3),unorm,ungrad(3,3) - double precision vec(3) - double precision scalar - integer i,j -c write (2,*) 'ugrad',ugrad -c write (2,*) 'u',u - do i=1,3 - vec(i)=scalar(ugrad(1,i),u(1)) - enddo -c write (2,*) 'vec',vec - do i=1,3 - do j=1,3 - ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm - enddo - enddo -c write (2,*) 'ungrad',ungrad - return - end -C----------------------------------------------------------------------------- - subroutine escp(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -c write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e, -c & ' scal14',scal14 - do i=iatscp_s,iatscp_e - iteli=itel(i) -c write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i), -c & " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) - if (iteli.eq.0) goto 1225 - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+e1+e2 - endif - evdwij=e1+e2 -c write (iout,*) i,j,evdwij - evdw2=evdw2+evdwij - if (calc_grad) then -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac - if (j.lt.i) then -cd write (iout,*) 'ji' - 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' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - dimension ggg(3) - ehpb=0.0D0 -cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr -cd write(iout,*)'link_start=',link_start,' link_end=',link_end - if (link_end.eq.0) return - do i=link_start,link_end -C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a -C CA-CA distance used in regularization of structure. - ii=ihpb(i) - jj=jhpb(i) -C iii and jjj point to the residues for which the distance is assigned. - if (ii.gt.nres) then - iii=ii-nres - jjj=jj-nres - else - iii=ii - jjj=jj - endif -c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, -c & dhpb(i),dhpb1(i),forcon(i) -C 24/11/03 AL: SS bridges handled separately because of introducing a specific -C distance and angle dependent SS bond potential. - if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then - call ssbond_ene(iii,jjj,eij) - ehpb=ehpb+2*eij -cd write (iout,*) "eij",eij - else if (ii.gt.nres .and. jj.gt.nres) then -c Restraints from contact prediction - dd=dist(ii,jj) - if (dhpb1(i).gt.0.0d0) then - ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd -c write (iout,*) "beta nmr", -c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - else - dd=dist(ii,jj) - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -c write (iout,*) "beta reg",dd,waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd - endif - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - do k=1,3 - ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) - ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) - enddo - else -C Calculate the distance between the two points and its difference from the -C target distance. - dd=dist(ii,jj) - if (dhpb1(i).gt.0.0d0) then - ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd -c write (iout,*) "alph nmr", -c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - else - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -c write (iout,*) "alpha reg",dd,waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd - endif -cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, -cd & ' waga=',waga,' fac=',fac - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo -cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) -C If this is a SC-SC distance, we need to calculate the contributions to the -C Cartesian gradient in the SC vectors (ghpbx). - if (iii.lt.ii) then - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - endif - do k=1,3 - ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) - ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) - enddo - endif - enddo - ehpb=0.5D0*ehpb - return - end -C-------------------------------------------------------------------------- - subroutine ssbond_ene(i,j,eij) -C -C Calculate the distance and angle dependent SS-bond potential energy -C using a free-energy function derived based on RHF/6-31G** ab initio -C calculations of diethyl disulfide. -C -C A. Liwo and U. Kozlowska, 11/24/03 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include '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=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=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 '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 - do i=nnt+1,nct - diff = vbld(i)-vbldp0 -c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff - estr=estr+diff*diff - do j=1,3 - gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) - enddo - enddo - estr=0.5d0*AKP*estr -c -c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included -c - do i=nnt,nct - iti=itype(i) - if (iti.ne.10) then - nbi=nbondterm(iti) - if (nbi.eq.1) then - diff=vbld(i+nres)-vbldsc0(1,iti) -c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, -c & AKSC(1,iti),AKSC(1,iti)*diff*diff - estr=estr+0.5d0*AKSC(1,iti)*diff*diff - do j=1,3 - gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) - enddo - else - do j=1,nbi - diff=vbld(i+nres)-vbldsc0(j,iti) - ud(j)=aksc(j,iti)*diff - u(j)=abond0(j,iti)+0.5d0*ud(j)*diff - enddo - uprod=u(1) - do j=2,nbi - uprod=uprod*u(j) - enddo - usum=0.0d0 - usumsqder=0.0d0 - do j=1,nbi - uprod1=1.0d0 - uprod2=1.0d0 - do k=1,nbi - if (k.ne.j) then - uprod1=uprod1*u(k) - uprod2=uprod2*u(k)*u(k) - endif - enddo - usum=usum+uprod1 - usumsqder=usumsqder+ud(j)*uprod2 - enddo -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) -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) -c if (i.gt.ithet_start .and. -c & (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215 -c if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then -c phii=phi(i) -c y(1)=dcos(phii) -c y(2)=dsin(phii) -c else -c y(1)=0.0D0 -c y(2)=0.0D0 -c endif -c if (i.lt.nres .and. itel(i).ne.0) then -c phii1=phi(i+1) -c z(1)=dcos(phii1) -c z(2)=dsin(phii1) -c else -c z(1)=0.0D0 -c z(2)=0.0D0 -c endif - if (i.gt.3) then -#ifdef OSF - phii=phi(i) - icrc=0 - 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 - if (i.lt.nres) then -#ifdef OSF - phii1=phi(i+1) - icrc=0 - 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) - 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 -#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' - 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 - dethetai=0.0d0 - dephii=0.0d0 - dephii1=0.0d0 - theti2=0.5d0*theta(i) - ityp2=ithetyp(itype(i-1)) - do k=1,nntheterm - coskt(k)=dcos(k*theti2) - sinkt(k)=dsin(k*theti2) - enddo - if (i.gt.3) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - ityp1=ithetyp(itype(i-2)) - do k=1,nsingle - cosph1(k)=dcos(k*phii) - sinph1(k)=dsin(k*phii) - enddo - else - phii=0.0d0 - ityp1=nthetyp+1 - do k=1,nsingle - cosph1(k)=0.0d0 - sinph1(k)=0.0d0 - enddo - endif - if (i.lt.nres) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) -#else - phii1=phi(i+1) -#endif - ityp3=ithetyp(itype(i)) - do k=1,nsingle - cosph2(k)=dcos(k*phii1) - sinph2(k)=dsin(k*phii1) - enddo - else - phii1=0.0d0 - ityp3=nthetyp+1 - do k=1,nsingle - cosph2(k)=0.0d0 - sinph2(k)=0.0d0 - enddo - endif -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) - do k=1,ndouble - do l=1,k-1 - ccl=cosph1(l)*cosph2(k-l) - ssl=sinph1(l)*sinph2(k-l) - scl=sinph1(l)*cosph2(k-l) - csl=cosph1(l)*sinph2(k-l) - cosph1ph2(l,k)=ccl-ssl - cosph1ph2(k,l)=ccl+ssl - sinph1ph2(l,k)=scl+csl - sinph1ph2(k,l)=scl-csl - enddo - enddo - if (lprn) then - write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, - & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 - write (iout,*) "coskt and sinkt" - do k=1,nntheterm - write (iout,*) k,coskt(k),sinkt(k) - enddo - endif - do k=1,ntheterm - ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k) - dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3) - & *coskt(k) - if (lprn) - & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), - & " ethetai",ethetai - enddo - if (lprn) then - write (iout,*) "cosph and sinph" - do k=1,nsingle - write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) - enddo - write (iout,*) "cosph1ph2 and sinph2ph2" - do k=2,ndouble - do l=1,k-1 - write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), - & sinph1ph2(l,k),sinph1ph2(k,l) - enddo - enddo - write(iout,*) "ethetai",ethetai - endif - do m=1,ntheterm2 - do k=1,nsingle - aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k) - & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k) - & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k) - & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*aux*coskt(m) - dephii=dephii+k*sinkt(m)*( - & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)- - & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) - dephii1=dephii1+k*sinkt(m)*( - & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- - & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) - if (lprn) - & write (iout,*) "m",m," k",k," bbthet", - & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", - & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", - & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", - & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai - enddo - enddo - if (lprn) - & write(iout,*) "ethetai",ethetai - do m=1,ntheterm3 - do k=2,ndouble - do l=1,k-1 - aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*coskt(m)*aux - dephii=dephii+l*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)- - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - dephii1=dephii1+(k-l)*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)- - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - if (lprn) then - write (iout,*) "m",m," k",k," l",l," ffthet", - & ffthet(l,k,m,ityp1,ityp2,ityp3), - & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", - & ggthet(l,k,m,ityp1,ityp2,ityp3), - & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai - write (iout,*) cosph1ph2(l,k)*sinkt(m), - & cosph1ph2(k,l)*sinkt(m), - & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) - endif - enddo - enddo - enddo -10 continue - if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') - & i,theta(i)*rad2deg,phii*rad2deg, - & phii1*rad2deg,ethetai - etheta=etheta+ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 - gloc(nphi+i-2,icg)=wang*dethetai - enddo - return - end -#endif -#ifdef CRYST_SC -c----------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include '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) -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,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 -#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 - costtab(i+1) =dcos(theta(i+1)) - sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) - cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) - sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) - cosfac2=0.5d0/(1.0d0+costtab(i+1)) - cosfac=dsqrt(cosfac2) - sinfac2=0.5d0/(1.0d0-costtab(i+1)) - sinfac=dsqrt(sinfac2) - it=itype(i) - if (it.eq.10) goto 1 -c -C Compute the axes of tghe local cartesian coordinates system; store in -c x_prime, y_prime and z_prime -c - do j=1,3 - x_prime(j) = 0.00 - y_prime(j) = 0.00 - z_prime(j) = 0.00 - enddo -C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), -C & dc_norm(3,i+nres) - do j = 1,3 - x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac - y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac - enddo - do j = 1,3 - z_prime(j) = -uz(j,i-1) - enddo -c write (2,*) "i",i -c write (2,*) "x_prime",(x_prime(j),j=1,3) -c write (2,*) "y_prime",(y_prime(j),j=1,3) -c write (2,*) "z_prime",(z_prime(j),j=1,3) -c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), -c & " xy",scalar(x_prime(1),y_prime(1)), -c & " xz",scalar(x_prime(1),z_prime(1)), -c & " yy",scalar(y_prime(1),y_prime(1)), -c & " yz",scalar(y_prime(1),z_prime(1)), -c & " zz",scalar(z_prime(1),z_prime(1)) -c -C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), -C to local coordinate system. Store in xx, yy, zz. -c - xx=0.0d0 - yy=0.0d0 - zz=0.0d0 - do j = 1,3 - xx = xx + x_prime(j)*dc_norm(j,i+nres) - yy = yy + y_prime(j)*dc_norm(j,i+nres) - zz = zz + z_prime(j)*dc_norm(j,i+nres) - enddo - - xxtab(i)=xx - yytab(i)=yy - zztab(i)=zz -C -C Compute the energy of the ith side cbain -C -c write (2,*) "xx",xx," yy",yy," zz",zz - it=itype(i) - do j = 1,65 - x(j) = sc_parmin(j,it) - enddo -#ifdef CHECK_COORD -Cc diagnostics - remove later - xx1 = dcos(alph(2)) - yy1 = dsin(alph(2))*dcos(omeg(2)) - zz1 = -dsin(alph(2))*dsin(omeg(2)) - write(2,'(3f8.1,3f9.3,1x,3f9.3)') - & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, - & xx1,yy1,zz1 -C," --- ", xx_w,yy_w,zz_w -c end diagnostics -#endif - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) - & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) -c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, -c & sumene4, -c & dscp1,dscp2,sumene -c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - escloc = escloc + sumene -c write (2,*) "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)*dC_norm(j,i+nres) - dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres) - enddo - - dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) - dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) - dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) -c - dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) - dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) - enddo - - do k=1,3 - dXX_Ctab(k,i)=dXX_Ci(k) - dXX_C1tab(k,i)=dXX_Ci1(k) - dYY_Ctab(k,i)=dYY_Ci(k) - dYY_C1tab(k,i)=dYY_Ci1(k) - dZZ_Ctab(k,i)=dZZ_Ci(k) - dZZ_C1tab(k,i)=dZZ_Ci1(k) - dXX_XYZtab(k,i)=dXX_XYZ(k) - dYY_XYZtab(k,i)=dYY_XYZ(k) - dZZ_XYZtab(k,i)=dZZ_XYZ(k) - enddo - - do k = 1,3 -c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", -c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) -c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", -c & dyy_ci(k)," dzz_ci",dzz_ci(k) -c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", -c & dt_dci(k) -c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", -c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) - gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) - & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) - gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) - & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) - gsclocx(k,i)= de_dxx*dxx_XYZ(k) - & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) - enddo -c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), -c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) - -C to check gradient call subroutine check_grad - - 1 continue - enddo - return - end -#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,edihcnstr,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 - 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*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,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 (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*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*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - edihi=0.25d0*ftors*difi**4 - 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 - edihi=0.25d0*ftors*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 '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*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 '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",itau_start,itau_end,nterm_sccor - esccor=0.0D0 - do i=itau_start,itau_end - esccor_ii=0.0D0 - isccori=isccortyp(itype(i-2)) - isccori1=isccortyp(itype(i-1)) - phii=phi(i) -cccc Added 9 May 2012 -cc Tauangle is torsional engle depending on the value of first digit -c(see comment below) -cc Omicron is flat angle depending on the value of first digit -c(see comment below) - - - do intertyp=1,3 !intertyp -cc Added 09 May 2012 (Adasko) -cc Intertyp means interaction type of backbone mainchain correlation: -c 1 = SC...Ca...Ca...Ca -c 2 = Ca...Ca...Ca...SC -c 3 = SC...Ca...Ca...SCi - gloci=0.0D0 - if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. - & (itype(i-1).eq.10).or.(itype(i-2).eq.21).or. - & (itype(i-1).eq.21))) - & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) - & .or.(itype(i-2).eq.21))) - & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. - & (itype(i-1).eq.21)))) cycle - if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle - if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21)) - & cycle - do j=1,nterm_sccor(isccori,isccori1) - v1ij=v1sccor(j,intertyp,isccori,isccori1) - v2ij=v2sccor(j,intertyp,isccori,isccori1) - cosphi=dcos(j*tauangle(intertyp,i)) - sinphi=dsin(j*tauangle(intertyp,i)) - esccor=esccor+v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci -c write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi -c &gloc_sc(intertyp,i-3,icg) - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1sccor(j,intertyp,itori,itori1),j=1,6) - & ,(v2sccor(j,intertyp,itori,itori1),j=1,6) - gsccor_loc(i-3)=gsccor_loc(i-3)+gloci - enddo !intertyp - enddo -c do i=1,nres -c write (iout,*) "W@T@F", gloc_sc(1,i,icg),gloc(i,icg) -c enddo - return - end -c------------------------------------------------------------------------------ - subroutine multibody(ecorr) -C This subroutine calculates multi-body contributions to energy following -C the idea of Skolnick et al. If side chains I and J make a contact and -C at the same time side chains I+1 and J+1 make a contact, an extra -C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - -C Set lprn=.true. for debugging - lprn=.false. - - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(i2,20(1x,i2,f10.5))') - & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) - enddo - endif - ecorr=0.0D0 - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo - do i=nnt,nct-2 - - DO ISHIFT = 3,4 - - i1=i+ishift - num_conti=num_cont(i) - num_conti1=num_cont(i1) - do jj=1,num_conti - j=jcont(jj,i) - do kk=1,num_conti1 - j1=jcont(kk,i1) - if (j1.eq.j+ishift .or. j1.eq.j-ishift) then -cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, -cd & ' ishift=',ishift -C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) - endif ! j1==j+-ishift - enddo ! kk - enddo ! jj - - ENDDO ! ISHIFT - - enddo ! i - return - end -c------------------------------------------------------------------------------ - double precision function esccorr(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont(jj,i) - ekl=facont(kk,k) -cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl -C Calculate the multi-body contribution to energy. -C Calculate multi-body contributions to the gradient. -cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), -cd & k,l,(gacont(m,kk,k),m=1,3) - do m=1,3 - gx(m) =ekl*gacont(m,jj,i) - gx1(m)=eij*gacont(m,kk,k) - gradxorr(m,i)=gradxorr(m,i)-gx(m) - gradxorr(m,j)=gradxorr(m,j)+gx(m) - gradxorr(m,k)=gradxorr(m,k)-gx1(m) - gradxorr(m,l)=gradxorr(m,l)+gx1(m) - enddo - do m=i,j-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) - enddo - enddo - do m=k,l-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) - enddo - enddo - esccorr=-eij*ekl - return - end -c------------------------------------------------------------------------------ -#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 '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' - 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 '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' - 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 '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' - 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 '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' - logical swap - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxvec2(1),auxmat1(2,2) - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C \ /l\ /j\ / C -C \ / \ / \ / C -C o| o | | o |o C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l -C AL 7/4/01 s1 would occur in the sixth-order moment, -C but not in a cluster cumulant -#ifdef MOMENT - s1=dip(1,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph2=-(s1+s2+s3+s4) -#else - eello6_graph2=-(s2+s3+s4) -#endif -c eello6_graph2=-s3 - 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 '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' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C j|/k\| / |/k\|l / C -C / \ / / \ / C -C / o / o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. - iti=itortyp(itype(i)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -#ifdef MOMENT - s1=dip(4,jj,i)*dip(4,kk,k) -#endif - call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#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 -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o \ o \ C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. -cd write (2,*) 'eello_graph4: wturn6',wturn6 - iti=itortyp(itype(i)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - if (k.lt.nres-1) then - itk1=itortyp(itype(k+1)) - else - itk1=ntortyp+1 - endif - itl=itortyp(itype(l)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l -cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, -cd & ' itl',itl,' itl1',itl1 -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dip(3,kk,k) - else - s1=dip(2,jj,j)*dip(2,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph4=-(s1+s2+s3+s4) -#else - eello6_graph4=-(s2+s3+s4) -#endif - 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 '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' - 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 - diff --git a/source/wham/src-NEWSC-NEWCORR/energy_p_new.F.org b/source/wham/src-NEWSC-NEWCORR/energy_p_new.F.org deleted file mode 100644 index 8f99a16..0000000 --- a/source/wham/src-NEWSC-NEWCORR/energy_p_new.F.org +++ /dev/null @@ -1,6452 +0,0 @@ - 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-NEWSC-NEWCORR/fitsq.f b/source/wham/src-NEWSC-NEWCORR/fitsq.f deleted file mode 100644 index 17d92ee..0000000 --- a/source/wham/src-NEWSC-NEWCORR/fitsq.f +++ /dev/null @@ -1,352 +0,0 @@ - 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-NEWSC-NEWCORR/geomout.F b/source/wham/src-NEWSC-NEWCORR/geomout.F deleted file mode 100644 index d52e23e..0000000 --- a/source/wham/src-NEWSC-NEWCORR/geomout.F +++ /dev/null @@ -1,167 +0,0 @@ - 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 - 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 - do i=nnt,nct - ires=i-nnt+1 - iatom=iatom+1 - ica(i)=iatom - iti=itype(i) - write (ipdb,10) iatom,restyp(iti),ires,(c(j,i),j=1,3) - if (iti.ne.10) then - iatom=iatom+1 - write (ipdb,20) iatom,restyp(iti),ires,(c(j,nres+i),j=1,3) - endif - enddo - write (ipdb,'(a)') 'TER' - do i=nnt,nct-1 - if (itype(i).eq.10) then - write (ipdb,30) ica(i),ica(i+1) - else - write (ipdb,30) ica(i),ica(i+1),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))+1,ica(jhpb(i))+1 - enddo - write (ipdb,'(a)') "END" - 10 FORMAT ('ATOM',I7,' CA ',A3,I6,4X,3F8.3) - 20 FORMAT ('ATOM',I7,' CB ',A3,I6,4X,3F8.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 - write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 - 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 - 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-NEWSC-NEWCORR/gnmr1.f b/source/wham/src-NEWSC-NEWCORR/gnmr1.f deleted file mode 100644 index 905e746..0000000 --- a/source/wham/src-NEWSC-NEWCORR/gnmr1.f +++ /dev/null @@ -1,43 +0,0 @@ - double precision function gnmr1(y,ymin,ymax) - implicit none - double precision y,ymin,ymax - double precision wykl /4.0d0/ - if (y.lt.ymin) then - gnmr1=(ymin-y)**wykl/wykl - else if (y.gt.ymax) then - gnmr1=(y-ymax)**wykl/wykl - else - gnmr1=0.0d0 - endif - return - end -c------------------------------------------------------------------------------ - double precision function gnmr1prim(y,ymin,ymax) - implicit none - double precision y,ymin,ymax - double precision wykl /4.0d0/ - if (y.lt.ymin) then - gnmr1prim=-(ymin-y)**(wykl-1) - else if (y.gt.ymax) then - gnmr1prim=(y-ymax)**(wykl-1) - else - gnmr1prim=0.0d0 - endif - return - end -c------------------------------------------------------------------------------ - double precision function harmonic(y,ymax) - implicit none - double precision y,ymax - double precision wykl /2.0d0/ - harmonic=(y-ymax)**wykl - return - end -c------------------------------------------------------------------------------- - double precision function harmonicprim(y,ymax) - double precision y,ymin,ymax - double precision wykl /2.0d0/ - harmonicprim=(y-ymax)*wykl - return - end -c--------------------------------------------------------------------------------- diff --git a/source/wham/src-NEWSC-NEWCORR/icant.f b/source/wham/src-NEWSC-NEWCORR/icant.f deleted file mode 100644 index 8dc1ec1..0000000 --- a/source/wham/src-NEWSC-NEWCORR/icant.f +++ /dev/null @@ -1,9 +0,0 @@ - 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-NEWSC-NEWCORR/include_unres/COMMON.CALC b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CALC deleted file mode 100644 index 67b4bb9..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CALC +++ /dev/null @@ -1,15 +0,0 @@ - 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-NEWSC-NEWCORR/include_unres/COMMON.CONTACTS b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTACTS deleted file mode 100644 index d07a0f0..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTACTS +++ /dev/null @@ -1,68 +0,0 @@ -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/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTPAR b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTPAR deleted file mode 100644 index 97a73eb..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTPAR +++ /dev/null @@ -1,3 +0,0 @@ - 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-NEWSC-NEWCORR/include_unres/COMMON.DERIV b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.DERIV deleted file mode 100644 index 79f8630..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.DERIV +++ /dev/null @@ -1,30 +0,0 @@ - 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/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FFIELD b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FFIELD deleted file mode 100644 index 8292679..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FFIELD +++ /dev/null @@ -1,29 +0,0 @@ -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, - & r0_corr - 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,weights(max_ene), - & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp - common /potentials/ potname(6) - 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 6 - MM; Momo's physics-based potentials -C------------------------------------------------------------------------ diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FRAG b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FRAG deleted file mode 100644 index ee151f5..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FRAG +++ /dev/null @@ -1,5 +0,0 @@ - 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-NEWSC-NEWCORR/include_unres/COMMON.GEO b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.GEO deleted file mode 100644 index 8cfbbde..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.GEO +++ /dev/null @@ -1,2 +0,0 @@ - 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-NEWSC-NEWCORR/include_unres/COMMON.HEADER b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.HEADER deleted file mode 100644 index 7154812..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.HEADER +++ /dev/null @@ -1,2 +0,0 @@ - character*80 titel - common /header/ titel diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.INTERACT b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.INTERACT deleted file mode 100644 index 9adbda4..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.INTERACT +++ /dev/null @@ -1,38 +0,0 @@ - double precision aa,bb,augm,aad,bad,app,bpp,ael6,ael3, - & chis,alphasur,sigmap1,sigmap2,alphiso,rborn,sigiso1,sigiso2, - & sig0head,epshead,wquad,dhead,dtail,wqdip,alphapol,wstate, - & epsintab,eps_out - - 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,nstate,icharge,expon,expon2 - common /interact/aa(ntyp,ntyp),bb(ntyp,ntyp),augm(ntyp,ntyp), - & chis(ntyp,ntyp),alphasur(4,ntyp,ntyp),sigmap1(ntyp,ntyp), - & sigmap2(ntyp,ntyp),alphiso(4,ntyp,ntyp),alphapol(ntyp,ntyp), - & rborn(ntyp,ntyp),sigiso1(ntyp,ntyp),sigiso2(ntyp,ntyp), - & epshead(ntyp,ntyp),wquad(ntyp,ntyp),dhead(2,2,ntyp,ntyp), - & dtail(2,ntyp,ntyp),wqdip(2,ntyp,ntyp),epsintab(ntyp,ntyp), - & eps_out,wstate(4,ntyp,ntyp),sig0head(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, - & nstate(ntyp,ntyp) -C 12/1/95 Array EPS included in the COMMON block. - double precision eps,sigma,sigmaii,rs0,chi,chip,chip0,alp,sigma0, - & sigii,rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp, - & chipp,eps_orig - common /body/eps(ntyp,ntyp),sigma(0:ntyp,0:ntyp), - & sigmaii(ntyp,ntyp), - & rs0(ntyp,ntyp),chi(ntyp,ntyp),chipp(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(20,2),rscp(20,2),eps_orig(ntyp,ntyp),icharge(ntyp) -c 12/5/03 modified 09/18/03 Bond stretching parameters. - double precision vbldp0,vbldsc0,akp,aksc,abond0 - integer nbondterm - common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp, - & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp),nbondterm(ntyp) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.LOCAL b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.LOCAL deleted file mode 100644 index a248d99..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.LOCAL +++ /dev/null @@ -1,36 +0,0 @@ - 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,itau_start,itau_end -C Parameters of the virtual-bond-angle probability distribution - common /thetas/ a0thet(ntyp),athet(2,ntyp),bthet(2,ntyp), - & polthet(0:3,ntyp),gthet(3,ntyp),theta0(ntyp),sig0(ntyp), - & sigc0(ntyp) -C Parameters of ab initio-derived potential of virtual-bond-angle bending - integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, - & ithetyp(ntyp1),nntheterm - double precision aa0thet(maxthetyp1,maxthetyp1,maxthetyp1), - & aathet(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1), - & bbthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ccthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ddthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & eethet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ffthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1), - & ggthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1) - common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet, - & ffthet, - & ggthet,ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle, - & ndouble,nntheterm -C Parameters of the side-chain probability distribution - common /sclocal/ dsc(ntyp1),dsc_inv(ntyp1),bsc(maxlob,ntyp), - & censc(3,maxlob,ntyp),gaussc(3,3,maxlob,ntyp),dsc0(ntyp1), - & nlob(ntyp1) -C 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,itau_start,itau_end -C Inverses of the actual virtual bond lengths - common /invlen/ vbld_inv(maxres2) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.MINIM b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.MINIM deleted file mode 100644 index b231b47..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.MINIM +++ /dev/null @@ -1,3 +0,0 @@ - double precision tolf,rtolf - integer maxfun,maxmin - common /minimm/ tolf,rtolf,maxfun,maxmin diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.NAMES b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.NAMES deleted file mode 100644 index a266339..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.NAMES +++ /dev/null @@ -1,7 +0,0 @@ - character*3 restyp - character*1 onelet - common /names/ restyp(ntyp+1),onelet(ntyp+1) - character*10 ename,wname - integer nprint_ene,print_order - common /namterm/ ename(max_ene),wname(max_ene),nprint_ene, - & print_order(max_ene) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SBRIDGE b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SBRIDGE deleted file mode 100644 index 7bba010..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SBRIDGE +++ /dev/null @@ -1,10 +0,0 @@ - double precision ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss,dhpb, - & dhpb1,forcon,weidis - integer ns,nss,nfree,iss,ihpb,jhpb,nhpb,link_start,link_end, - & ibecarb - common /sbridge/ ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss,ns,nss, - & nfree,iss(maxss) - common /links/ dhpb(maxdim),dhpb1(maxdim),forcon(maxdim), - & ihpb(maxdim),jhpb(maxdim),ibecarb(maxdim),nhpb - common /restraints/ weidis - common /links_split/ link_start,link_end diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCCOR b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCCOR deleted file mode 100644 index 28d748a..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCCOR +++ /dev/null @@ -1,18 +0,0 @@ -cc Parameters of the SCCOR term - double precision v1sccor,v2sccor,vlor1sccor, - & vlor2sccor,vlor3sccor,gloc_sc, - & dcostau,dsintau,dtauangle,dcosomicron, - & domicron,v0sccor - integer nterm_sccor,isccortyp,nsccortyp,nlor_sccor - common /sccor/ v1sccor(maxterm_sccor,3,20,20), - & v2sccor(maxterm_sccor,3,20,20), - & v0sccor(ntyp,ntyp), - & vlor1sccor(maxterm_sccor,20,20), - & vlor2sccor(maxterm_sccor,20,20), - & vlor3sccor(maxterm_sccor,20,20),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),isccortyp(ntyp),nsccortyp, - & nlor_sccor(ntyp,ntyp) - diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCROT b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCROT deleted file mode 100644 index 2da7b8f..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCROT +++ /dev/null @@ -1,3 +0,0 @@ -C Parameters of the SC rotamers (local) term - double precision sc_parmin - common/scrot/sc_parmin(maxsccoef,20) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TIME1 b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TIME1 deleted file mode 100644 index f7f4849..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TIME1 +++ /dev/null @@ -1,13 +0,0 @@ - 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-NEWSC-NEWCORR/include_unres/COMMON.TORCNSTR b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORCNSTR deleted file mode 100644 index f8fc3a1..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORCNSTR +++ /dev/null @@ -1,5 +0,0 @@ - integer ndih_constr,idih_constr(maxdih_constr) - integer ndih_nconstr,idih_nconstr(maxdih_constr) - double precision phi0(maxdih_constr),drange(maxdih_constr),ftors - common /torcnstr/ phi0,drange,ftors,ndih_constr,idih_constr, - & ndih_nconstr,idih_nconstr diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORSION b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORSION deleted file mode 100644 index f4ba10b..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORSION +++ /dev/null @@ -1,29 +0,0 @@ -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, - & bnew1,bnew2,eenew,eeold - integer nloctyp - common/fourier/ b1(2,maxtor),b2(2,maxtor), - & bnew1(3,2,maxtor),bnew2(3,2,maxtor), - & cc(2,2,maxtor), - & dd(2,2,maxtor),eeold(2,2,maxtor),eenew(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/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VAR b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VAR deleted file mode 100644 index d560c87..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VAR +++ /dev/null @@ -1,21 +0,0 @@ -C Store the geometric variables in the following COMMON block. - integer ntheta,nphi,nside,nvar,Origin,nstore,ialph,ivar, - & mask_theta,mask_phi,mask_side - double precision theta,phi,alph,omeg,varsave,esave,varall,vbld, - & thetaref,phiref,costtab,sinttab,cost2tab,sint2tab, - & xxtab,yytab,zztab,xxref,yyref,zzref - common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), - & omicron(2,maxres),tauangle(3,maxres), - & vbld(2*maxres),thetaref(maxres),phiref(maxres), - & costtab(maxres), sinttab(maxres), cost2tab(maxres), - & sint2tab(maxres),xxtab(maxres),yytab(maxres), - & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres), - & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar -C Store the angles and variables corresponding to old conformations (for use -C in MCM). - common /oldgeo/ varsave(maxvar,maxsave),esave(maxsave), - & Origin(maxsave),nstore -C freeze some variables - logical mask_r - common /restr/ varall(maxvar),mask_r,mask_theta(maxres), - & mask_phi(maxres),mask_side(maxres) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VECTORS b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VECTORS deleted file mode 100644 index d880c24..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VECTORS +++ /dev/null @@ -1,3 +0,0 @@ - common /vectors/ uy(3,maxres),uz(3,maxres), - & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres) - diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.WEIGHTS b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.WEIGHTS deleted file mode 100644 index d7e6e23..0000000 --- a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.WEIGHTS +++ /dev/null @@ -1,22 +0,0 @@ - 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:20,2),epscp_up(0:20,2),rscp_low(0:20,2), - & rscp_up(0:20,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:20,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-NEWSC-NEWCORR/initialize_p.F b/source/wham/src-NEWSC-NEWCORR/initialize_p.F deleted file mode 100644 index 7ac8109..0000000 --- a/source/wham/src-NEWSC-NEWCORR/initialize_p.F +++ /dev/null @@ -1,577 +0,0 @@ - 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 - 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 -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 -#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.INTERACT' - 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','MM'/ - data ename / - & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ", - & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ", - & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB","EVDWPP", - & "EVDW2_14","ESTR","ESCCOR","EDIHC","EVDW_T"/ - data wname / - & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", - & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD", - & "WHPB","WVDWPP","WSCP14","WBOND","WSCCOR","WDIHC","WSC"/ - data ww0 /1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0, - & 1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,0.4d0,1.0d0,1.0d0, - & 0.0d0,0.0/ - data nprint_ene /21/ - data print_order /1,2,3,18,11,12,13,14,4,5,6,7,8,9,10,19, - & 16,15,17,20,21/ -c Dielectric constant of water - data eps_out /80.0d0/ - 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 - call int_bounds(nres-3,itau_start,itau_end) - itau_start=itau_start+3 - itau_end=itau_end+3 - if (lprint) then - write (iout,*) 'Processor:',MyID, - & ' loc_start',loc_start,' loc_end',loc_end, - & ' ithet_start',ithet_start,' ithet_end',ithet_end, - & ' iphi_start',iphi_start,' iphi_end',iphi_end - write (*,*) 'Processor:',MyID, - & ' loc_start',loc_start,' loc_end',loc_end, - & ' ithet_start',ithet_start,' ithet_end',ithet_end, - & ' iphi_start',iphi_start,' iphi_end',iphi_end - endif - if (fgprocs.gt.1 .and. MyID.eq.BossID) then - write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ', - & nele_int_tot,' electrostatic and ',nscp_int_tot, - & ' SC-p interactions','were distributed among',fgprocs, - & ' fine-grain processors.' - endif -#else - loc_start=2 - loc_end=nres-1 - ithet_start=3 - ithet_end=nres - iphi_start=nnt+3 - iphi_end=nct - itau_start=4 - itau_end=nres -#endif - return - end -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-NEWSC-NEWCORR/initialize_p.F.org b/source/wham/src-NEWSC-NEWCORR/initialize_p.F.org deleted file mode 100644 index 3e7d056..0000000 --- a/source/wham/src-NEWSC-NEWCORR/initialize_p.F.org +++ /dev/null @@ -1,571 +0,0 @@ - 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-NEWSC-NEWCORR/int_from_cart.f b/source/wham/src-NEWSC-NEWCORR/int_from_cart.f deleted file mode 100644 index c0cd6e7..0000000 --- a/source/wham/src-NEWSC-NEWCORR/int_from_cart.f +++ /dev/null @@ -1,66 +0,0 @@ - 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-NEWSC-NEWCORR/intcor.f b/source/wham/src-NEWSC-NEWCORR/intcor.f deleted file mode 100644 index 04cbbbc..0000000 --- a/source/wham/src-NEWSC-NEWCORR/intcor.f +++ /dev/null @@ -1,94 +0,0 @@ -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-NEWSC-NEWCORR/make_ensemble1.F b/source/wham/src-NEWSC-NEWCORR/make_ensemble1.F deleted file mode 100644 index 5d7b750..0000000 --- a/source/wham/src-NEWSC-NEWCORR/make_ensemble1.F +++ /dev/null @@ -1,375 +0,0 @@ - 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.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, - & ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3, - & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor,tt - 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) - 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) -#ifdef SPLITELE - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees - & +wvdwpp*evdw1 - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc - & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#else - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 - & +ft(1)*welec*(ees+evdw1) - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr - & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#endif -#ifdef 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) - 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-NEWSC-NEWCORR/match_contact.f b/source/wham/src-NEWSC-NEWCORR/match_contact.f deleted file mode 100644 index 3ec2036..0000000 --- a/source/wham/src-NEWSC-NEWCORR/match_contact.f +++ /dev/null @@ -1,339 +0,0 @@ - subroutine match_contact(ishif1,ishif2,nc_match,nc_match1_max, - & ncont_ref,icont_ref,ncont,icont,jfrag,n_shif1,n_shif2, - & nc_frac,nc_req_set,istr,llocal,lprn) - 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 - 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,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,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,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,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,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,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",-is,-js," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=-is - ishif2=-js - return - endif - call ncont_match(nc_match,nc_match1,is,js,ncont_ref, - & icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",is,js," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=is - ishif2=js - return - endif -c - call ncont_match(nc_match,nc_match1,-js,-is,ncont_ref, - & icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",-js,-is," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=-js - ishif2=-is - return - endif -c - call ncont_match(nc_match,nc_match1,js,is,ncont_ref, - & icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",js,is," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=js - ishif2=is - return - endif - endif -c - if (is+js.le.n_shif1) then - call ncont_match(nc_match,nc_match1,-is,js,ncont_ref, - & icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",-is,js," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=-is - ishif2=js - return - endif -c - call ncont_match(nc_match,nc_match1,js,-is,ncont_ref, - & icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",js,-is," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=js - ishif2=-is - return - endif - endif -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,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",-is,-is," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=-is - ishif2=-is - return - endif - call ncont_match(nc_match,nc_match1,is,is,ncont_ref, - & icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",is,is," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=is - ishif2=is - return - endif - enddo - endif -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,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) -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) write (iout,'(80(1h*))') - 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, - & lprn) - if (lprn) write (iout,*) "diffang:",diffang*rad2deg, - & " ang_cut:",ang_cut(jfrag)*rad2deg," fract",fract - if (diffang.le.ang_cut(jfrag) .and. fract.ge.frac_min(jfrag)) - & then - nc_match=1 - else - nc_match=0 - endif - return - endif - nang_pair=0 - do i=1,ncont - ic1=icont(1,i)+ishif1 - ic2=icont(2,i)+ishif2 -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) - 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,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) - 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(j).eq.isec_ref(j) .or. -c & isecstr(j).eq.0 .and. isec_ref(j).eq.1 .or. - & isec_ref(j).eq.0 .and. isecstr(j).eq.1) - & nsec_match=nsec_match+1 - enddo - enddo - return - end diff --git a/source/wham/src-NEWSC-NEWCORR/matmult.f b/source/wham/src-NEWSC-NEWCORR/matmult.f deleted file mode 100644 index e9257cf..0000000 --- a/source/wham/src-NEWSC-NEWCORR/matmult.f +++ /dev/null @@ -1,18 +0,0 @@ - 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-NEWSC-NEWCORR/misc.f b/source/wham/src-NEWSC-NEWCORR/misc.f deleted file mode 100644 index e189839..0000000 --- a/source/wham/src-NEWSC-NEWCORR/misc.f +++ /dev/null @@ -1,203 +0,0 @@ -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-NEWSC-NEWCORR/molread_zs.F b/source/wham/src-NEWSC-NEWCORR/molread_zs.F deleted file mode 100644 index 431680d..0000000 --- a/source/wham/src-NEWSC-NEWCORR/molread_zs.F +++ /dev/null @@ -1,378 +0,0 @@ - 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' - character*4 sequence(maxres) - integer rescode - double precision x(maxvar) - character*320 controlcard,ucase - dimension itype_pdb(maxres) - logical seq_comp - call card_concat(controlcard,.true.) - call reada(controlcard,'SCAL14',scal14,0.4d0) - call reada(controlcard,'SCALSCP',scalscp,1.0d0) - call reada(controlcard,'CUTOFF',cutoff_corr,7.0d0) - call reada(controlcard,'DELT_CORR',delt_corr,0.5d0) - r0_corr=cutoff_corr-delt_corr - 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.21 .or. itype(i+1).eq.21) then -#else - if (itype(i).eq.21) then -#endif - itel(i)=0 -#ifdef PROCOR - else if (itype(i+1).ne.20) then -#else - else if (itype(i).ne.20) then -#endif - itel(i)=1 - else - itel(i)=2 - endif - enddo - call read_bridge - - if (with_dihed_constr) then - - read (inp,*) ndih_constr - if (ndih_constr.gt.0) then - read (inp,*) ftors - write (iout,*) 'FTORS',ftors - read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr) - write (iout,*) - & 'There are',ndih_constr,' constraints on phi angles.' - do i=1,ndih_constr - write (iout,'(i5,2f8.3)') idih_constr(i),phi0(i),drange(i) - enddo - do i=1,ndih_constr - phi0(i)=deg2rad*phi0(i) - drange(i)=deg2rad*drange(i) - enddo - endif - - endif - - nnt=1 - nct=nres - if (itype(1).eq.21) nnt=2 - if (itype(nres).eq.21) nct=nct-1 - write(iout,*) 'NNT=',NNT,' NCT=',NCT -c Read distance restraints - if (constr_dist.gt.0) then - if (refstr) call read_ref_structure(*11) - call read_dist_constr - call hpb_partition - 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) - write (iout,'(/a/)') 'Pre-formed links are:' - do i=1,nss - i1=ihpb(i)-nres - i2=jhpb(i)-nres - it1=itype(i1) - it2=itype(i2) - write (iout,'(2a,i3,3a,i3,a,3f10.3)') - & restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')', - & dhpb(i),ebr,forcon(i) - enddo - endif - write (iout,'(a)') - return - 11 stop "Error reading reference structure" - 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(iss(i)),i, - & ' can form a disulfide bridge?!!!' - write (*,'(2a,i3,a)') - & 'Do you REALLY think that the residue ',restyp(iss(i)),i, - & ' can form a disulfide bridge?!!!' - 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_dist_constr - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.SBRIDGE' - integer ifrag_(2,100),ipair_(2,100) - double precision wfrag_(100),wpair_(100) - character*500 controlcard -c write (iout,*) "Calling read_dist_constr" -c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup -c call flush(iout) - call card_concat(controlcard,.true.) - call readi(controlcard,"NFRAG",nfrag_,0) - call readi(controlcard,"NPAIR",npair_,0) - call readi(controlcard,"NDIST",ndist_,0) - call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) - call multreadi(controlcard,"IFRAG",ifrag_(1,1),2*nfrag_,0) - call multreadi(controlcard,"IPAIR",ipair_(1,1),2*npair_,0) - call multreada(controlcard,"WFRAG",wfrag_(1),nfrag_,0.0d0) - call multreada(controlcard,"WPAIR",wpair_(1),npair_,0.0d0) - write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_ - write (iout,*) "IFRAG" - do i=1,nfrag_ - write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) - enddo - write (iout,*) "IPAIR" - do i=1,npair_ - write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i) - enddo - call flush(iout) - if (.not.refstr .and. nfrag_.gt.0) then - write (iout,*) - & "ERROR: no reference structure to compute distance restraints" - write (iout,*) - & "Restraints must be specified explicitly (NDIST=number)" - stop - endif - if (nfrag_.lt.2 .and. npair_.gt.0) then - write (iout,*) "ERROR: Less than 2 fragments specified", - & " but distance restraints between pairs requested" - stop - endif - call flush(iout) - do i=1,nfrag_ - if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup - if (ifrag_(2,i).gt.nstart_sup+nsup-1) - & ifrag_(2,i)=nstart_sup+nsup-1 -c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) - call flush(iout) - if (wfrag_(i).gt.0.0d0) then - do j=ifrag_(1,i),ifrag_(2,i)-1 - do k=j+1,ifrag_(2,i) - write (iout,*) "j",j," k",k - ddjk=dist(j,k) - if (constr_dist.eq.1) then - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i) - else if (constr_dist.eq.2) then - if (ddjk.le.dist_cut) then - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i) - endif - else - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) - endif - write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) - enddo - enddo - endif - enddo - do i=1,npair_ - if (wpair_(i).gt.0.0d0) then - ii = ipair_(1,i) - jj = ipair_(2,i) - if (ii.gt.jj) then - itemp=ii - ii=jj - jj=itemp - endif - do j=ifrag_(1,ii),ifrag_(2,ii) - do k=ifrag_(1,jj),ifrag_(2,jj) - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - forcon(nhpb)=wpair_(i) - dhpb(nhpb)=dist(j,k) - write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) - enddo - enddo - endif - enddo - do i=1,ndist_ - read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(i),dhpb1(i), - & ibecarb(i),forcon(nhpb+1) - if (forcon(nhpb+1).gt.0.0d0) then - nhpb=nhpb+1 - if (ibecarb(i).gt.0) then - ihpb(i)=ihpb(i)+nres - jhpb(i)=jhpb(i)+nres - endif - if (dhpb(nhpb).eq.0.0d0) - & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) - endif - enddo - do i=1,nhpb - write (iout,'(a,3i5,2f8.2,i2,f10.1)') "+dist.constr ", - & i,ihpb(i),jhpb(i),dhpb(i),dhpb1(i),ibecarb(i),forcon(i) - enddo - call flush(iout) - return - end diff --git a/source/wham/src-NEWSC-NEWCORR/mygetenv.F b/source/wham/src-NEWSC-NEWCORR/mygetenv.F deleted file mode 100644 index b5ea4a2..0000000 --- a/source/wham/src-NEWSC-NEWCORR/mygetenv.F +++ /dev/null @@ -1,55 +0,0 @@ - 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-NEWSC-NEWCORR/mysort.f b/source/wham/src-NEWSC-NEWCORR/mysort.f deleted file mode 100644 index cb1bbe7..0000000 --- a/source/wham/src-NEWSC-NEWCORR/mysort.f +++ /dev/null @@ -1,52 +0,0 @@ - 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-NEWSC-NEWCORR/odlodc.f b/source/wham/src-NEWSC-NEWCORR/odlodc.f deleted file mode 100644 index c18ac72..0000000 --- a/source/wham/src-NEWSC-NEWCORR/odlodc.f +++ /dev/null @@ -1,55 +0,0 @@ - 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-NEWSC-NEWCORR/openunits.F b/source/wham/src-NEWSC-NEWCORR/openunits.F deleted file mode 100644 index b9f54b7..0000000 --- a/source/wham/src-NEWSC-NEWCORR/openunits.F +++ /dev/null @@ -1,105 +0,0 @@ - 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) - open (ibond,file=bondname,status='old') - call mygetenv('THETPAR',thetname) - open (ithep,file=thetname,status='old') - call mygetenv('ROTPAR',rotname) - open (irotam,file=rotname,status='old') - call mygetenv('TORPAR',torname) - open (itorp,file=torname,status='old') - call mygetenv('TORDPAR',tordname) - open (itordp,file=tordname,status='old') - call mygetenv('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old') - call mygetenv('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old') - call mygetenv('ELEPAR',elename) - open (ielep,file=elename,status='old') - call mygetenv('SIDEPAR',sidename) - open (isidep,file=sidename,status='old') - call mygetenv('SIDEP',sidepname) - open (isidep1,file=sidepname,status="old") -#ifndef OLDSCP -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,'(80(1h-))') - write (iout,*) - return - end - diff --git a/source/wham/src-NEWSC-NEWCORR/parmread.F b/source/wham/src-NEWSC-NEWCORR/parmread.F deleted file mode 100644 index ba6ec3e..0000000 --- a/source/wham/src-NEWSC-NEWCORR/parmread.F +++ /dev/null @@ -1,1164 +0,0 @@ - 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' - character*1 t1,t2,t3 - character*1 onelett(4) /"G","A","P","D"/ - 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 -C -C Body -C -C Set LPRINT=.TRUE. for debugging - dwa16=2.0d0**(1.0d0/6.0d0) - lprint=.true. - 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 - - 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) - wstrain=ww(15) - wbond=ww(18) - wsccor=ww(19) - - 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) - open (itordp,file=tordname_t,status='old') - rewind(itordp) - call reads(controlcard,"SCCORAR",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=110,err=110) vbldp0,akp - do i=1,ntyp - nbondterm(i)=1 - read (ibond,*,end=110,err=110) 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=110,err=110) ijunk,vbldp0,akp,rjunk - do i=1,ntyp - read (ibond,*,end=110,err=110) 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 -#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),j=1,2), - & (bthet(j,i),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 - 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),j=1,2),(10*bthet(j,i),j=1,2) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the expression for sigma(theta_c):', - & ' alpha0 ',' alph1 ',' alph2 ', - & ' alhp3 ',' sigma0c ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(1pe12.3,1h&))') restyp(i), - & (polthet(j,i),j=0,3),sigc0(i) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the second gaussian:', - & ' theta0 ',' sigma0*10^2 ',' G1*10^-1', - & ' G2 ',' G3*10^1 ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),theta0(i), - & 100*sig0(i),gthet(1,i)*0.1D0,gthet(2,i),gthet(3,i)*10.0D0 - enddo - endif -#else -C -C Read the parameters of Utheta determined from ab initio surfaces -C Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -C - read (ithep,*,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=1,maxthetyp - do j=1,maxthetyp - do k=1,maxthetyp - aa0thet(i,j,k)=0.0d0 - do l=1,ntheterm - aathet(l,i,j,k)=0.0d0 - enddo - do l=1,ntheterm2 - do m=1,nsingle - bbthet(m,l,i,j,k)=0.0d0 - ccthet(m,l,i,j,k)=0.0d0 - ddthet(m,l,i,j,k)=0.0d0 - eethet(m,l,i,j,k)=0.0d0 - enddo - enddo - do l=1,ntheterm3 - do m=1,ndouble - do mm=1,ndouble - ffthet(mm,m,l,i,j,k)=0.0d0 - ggthet(mm,m,l,i,j,k)=0.0d0 - enddo - enddo - enddo - enddo - enddo - enddo - do i=1,nthetyp - do j=1,nthetyp - do k=1,nthetyp - read (ithep,'(3a)',end=111,err=111) res1,res2,res3 - read (ithep,*,end=111,err=111) aa0thet(i,j,k) - read (ithep,*,end=111,err=111)(aathet(l,i,j,k),l=1,ntheterm) - read (ithep,*,end=111,err=111) - & ((bbthet(lll,ll,i,j,k),lll=1,nsingle), - & (ccthet(lll,ll,i,j,k),lll=1,nsingle), - & (ddthet(lll,ll,i,j,k),lll=1,nsingle), - & (eethet(lll,ll,i,j,k),lll=1,nsingle),ll=1,ntheterm2) - read (ithep,*,end=111,err=111) - & (((ffthet(llll,lll,ll,i,j,k),ffthet(lll,llll,ll,i,j,k), - & ggthet(llll,lll,ll,i,j,k),ggthet(lll,llll,ll,i,j,k), - & llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) - enddo - enddo - enddo -C -C For dummy ends assign glycine-type coefficients of theta-only terms; the -C coefficients of theta-and-gamma-dependent terms are zero. -C - do i=1,nthetyp - do j=1,nthetyp - do l=1,ntheterm - aathet(l,i,j,nthetyp+1)=aathet(l,i,j,1) - aathet(l,nthetyp+1,i,j)=aathet(l,1,i,j) - enddo - aa0thet(i,j,nthetyp+1)=aa0thet(i,j,1) - aa0thet(nthetyp+1,i,j)=aa0thet(1,i,j) - enddo - do l=1,ntheterm - aathet(l,nthetyp+1,i,nthetyp+1)=aathet(l,1,i,1) - enddo - aa0thet(nthetyp+1,i,nthetyp+1)=aa0thet(1,i,1) - enddo -C -C Control printout of the coefficients of virtual-bond-angle potentials -C - if (lprint) then - write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' - do i=1,nthetyp+1 - do j=1,nthetyp+1 - do k=1,nthetyp+1 - write (iout,'(//4a)') - & 'Type ',onelett(i),onelett(j),onelett(k) - write (iout,'(//a,10x,a)') " l","a[l]" - write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k) - write (iout,'(i2,1pe15.5)') - & (l,aathet(l,i,j,k),l=1,ntheterm) - do l=1,ntheterm2 - write (iout,'(//2h m,4(9x,a,3h[m,i1,1h]))') - & "b",l,"c",l,"d",l,"e",l - do m=1,nsingle - write (iout,'(i2,4(1pe15.5))') m, - & bbthet(m,l,i,j,k),ccthet(m,l,i,j,k), - & ddthet(m,l,i,j,k),eethet(m,l,i,j,k) - enddo - enddo - do l=1,ntheterm3 - write (iout,'(//3hm,n,4(6x,a,5h[m,n,i1,1h]))') - & "f+",l,"f-",l,"g+",l,"g-",l - do m=2,ndouble - do n=1,m-1 - write (iout,'(i1,1x,i1,4(1pe15.5))') n,m, - & ffthet(n,m,l,i,j,k),ffthet(m,n,l,i,j,k), - & ggthet(n,m,l,i,j,k),ggthet(m,n,l,i,j,k) - enddo - enddo - enddo - enddo - enddo - enddo - call flush(iout) - endif -#endif - -#ifdef CRYST_SC -C -C Read the parameters of the probability distribution/energy expression -C of the side chains. -C - do i=1,ntyp - read (irotam,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - if (i.ne.10) then - do j=1,nlob(i) - do k=1,3 - do l=1,3 - blower(l,k,j)=0.0D0 - enddo - enddo - enddo - bsc(1,i)=0.0D0 - read(irotam,*,end=112,err=112)(censc(k,1,i),k=1,3), - & ((blower(k,l,1),l=1,k),k=1,3) - do j=2,nlob(i) - read (irotam,*,end=112,err=112) bsc(j,i) - read (irotam,*,end=112,err=112) (censc(k,j,i),k=1,3), - & ((blower(k,l,j),l=1,k),k=1,3) - enddo - do j=1,nlob(i) - do k=1,3 - do l=1,k - akl=0.0D0 - do m=1,3 - akl=akl+blower(k,m,j)*blower(l,m,j) - enddo - gaussc(k,l,j,i)=akl - gaussc(l,k,j,i)=akl - enddo - enddo - enddo - endif - enddo - close (irotam) - if (lprint) then - write (iout,'(/a)') 'Parameters of side-chain local geometry' - do i=1,ntyp - nlobi=nlob(i) - if (nlobi.gt.0) then - 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) -#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 - read (itorp,*,end=113,err=113) ntortyp - read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) - write (iout,*) 'ntortyp',ntortyp - do i=1,ntortyp - do j=1,ntortyp - read (itorp,*,end=113,err=113) nterm(i,j),nlor(i,j) - v0ij=0.0d0 - si=-1.0d0 - do k=1,nterm(i,j) - read (itorp,*,end=113,err=113) kk,v1(k,i,j),v2(k,i,j) - v0ij=v0ij+si*v1(k,i,j) - si=-si - enddo - do k=1,nlor(i,j) - read (itorp,*,end=113,err=113) kk,vlor1(k,i,j),vlor2(k,i,j), - & vlor3(k,i,j) - v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) - enddo - v0(i,j)=v0ij - enddo - enddo - close (itorp) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,ntortyp - do j=1,ntortyp - write (iout,*) 'ityp',i,' jtyp',j - write (iout,*) 'Fourier constants' - do k=1,nterm(i,j) - write (iout,'(2(1pe15.5))') v1(k,i,j),v2(k,i,j) - enddo - write (iout,*) 'Lorenz constants' - do k=1,nlor(i,j) - write (iout,'(3(1pe15.5))') - & vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) - enddo - enddo - enddo - endif -C -C 6/23/01 Read parameters for double torsionals -C - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - read (itordp,'(3a1)',end=112,err=112) t1,t2,t3 - if (t1.ne.onelett(i) .or. t2.ne.onelett(j) - & .or. t3.ne.onelett(k)) then - write (iout,*) "Error in double torsional parameter file", - & i,j,k,t1,t2,t3 - stop "Error in double torsional parameter file" - endif - read (itordp,*,end=114,err=114) ntermd_1(i,j,k), - & ntermd_2(i,j,k) - read (itordp,*,end=114,err=114) (v1c(1,l,i,j,k), - & l=1,ntermd_1(i,j,k)) - read (itordp,*,end=114,err=114) (v1s(1,l,i,j,k),l=1, - & ntermd_1(i,j,k)) - read (itordp,*,end=114,err=114) (v1c(2,l,i,j,k), - & l=1,ntermd_1(i,j,k)) - read (itordp,*,end=114,err=114) (v1s(2,l,i,j,k),l=1, - & ntermd_1(i,j,k)) - read (itordp,*,end=114,err=114) ((v2c(l,m,i,j,k), - & v2c(m,l,i,j,k), - & v2s(l,m,i,j,k),v2s(m,l,i,j,k),m=1,l-1),l=1,ntermd_2(i,j,k)) - enddo - enddo - enddo - if (lprint) then - write (iout,*) - write (iout,*) 'Constants for double torsionals' - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k, - & ' nsingle',ntermd_1(i,j,k),' ndouble',ntermd_2(i,j,k) - write (iout,*) - write (iout,*) 'Single angles:' - do l=1,ntermd_1(i,j,k) - write (iout,'(i5,2f10.5,5x,2f10.5)') l, - & v1c(1,l,i,j,k),v1s(1,l,i,j,k), - & v1c(2,l,i,j,k),v1s(2,l,i,j,k) - enddo - write (iout,*) - write (iout,*) 'Pairs of angles:' - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) - do l=1,ntermd_2(i,j,k) - write (iout,'(i5,20f10.5)') - & l,(v2c(l,m,i,j,k),m=1,ntermd_2(i,j,k)) - enddo - write (iout,*) - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) - do l=1,ntermd_2(i,j,k) - write (iout,'(i5,20f10.5)') - & l,(v2s(l,m,i,j,k),m=1,ntermd_2(i,j,k)) - enddo - write (iout,*) - enddo - enddo - enddo - endif -#endif -C Read of Side-chain backbone correlation parameters -C Modified 11 May 2012 by Adasko -CCC -C - read (isccor,*,end=119,err=119) nsccortyp - read (isccor,*,end=119,err=119) (isccortyp(i),i=1,ntyp) -c write (iout,*) 'ntortyp',ntortyp - maxinter=3 -cc maxinter is maximum interaction sites - do l=1,maxinter - do i=1,nsccortyp - do j=1,nsccortyp - read (isccor,*,end=119,err=119) nterm_sccor(i,j), - & nlor_sccor(i,j) - v0ijsccor=0.0d0 - si=-1.0d0 - do k=1,nterm_sccor(i,j) - read (isccor,*,end=119,err=119) kk,v1sccor(k,l,i,j) - & ,v2sccor(k,l,i,j) - v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) - si=-si - enddo - do k=1,nlor_sccor(i,j) - read (isccor,*,end=119,err=119) kk,vlor1sccor(k,i,j), - & vlor2sccor(k,i,j),vlor3sccor(k,i,j) - v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ - &(1+vlor3sccor(k,i,j)**2) - enddo - v0sccor(i,j)=v0ijsccor - enddo - enddo - enddo - close (isccor) - - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,nsccortyp - do j=1,nsccortyp - write (iout,*) 'ityp',i,' jtyp',j - write (iout,*) 'Fourier constants' - do k=1,nterm_sccor(i,j) - write(iout,'(2(1pe15.5))')(v1sccor(k,l,i,j),v2sccor(k,l,i,j), - & l=1,maxinter) - enddo - write (iout,*) 'Lorenz constants' - do k=1,nlor_sccor(i,j) - write (iout,'(3(1pe15.5))') - & vlor1sccor(k,i,j),vlor2sccor(k,i,j),vlor3sccor(k,i,j) - enddo - enddo - enddo - endif - -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 - do i=1,nloctyp - read (ifourier,*,end=115,err=115) - read (ifourier,*,end=115,err=115) (b(ii,i),ii=1,13) -#ifdef NEWCORR - read (ifourier,*,end=115,err=115) (bnew1(ii,1,i),ii=1,3) - read (ifourier,*,end=115,err=115) (bnew2(ii,1,i),ii=1,3) - read (ifourier,*,end=115,err=115) (bnew1(ii,2,i),ii=1,1) - read (ifourier,*,end=115,err=115) (bnew2(ii,2,i),ii=1,1) - read (ifourier,*,end=115,err=115) (eenew(ii,i),ii=1,1) -#endif - if (lprint) then - write (iout,*) 'Type',i - write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii,i),ii=1,13) - endif -#ifdef NEWCORR - B1(1,i) = b(3,i) - B1(2,i) = b(5,i) - B1tilde(1,i) = b(3,i) - B1tilde(2,i) =-b(5,i) - B2(1,i) = b(2,i) - B2(2,i) = b(4,i) -#endif - CC(1,1,i)= b(7,i) - CC(2,2,i)=-b(7,i) - CC(2,1,i)= b(9,i) - CC(1,2,i)= b(9,i) - Ctilde(1,1,i)=b(7,i) - Ctilde(1,2,i)=b(9,i) - Ctilde(2,1,i)=-b(9,i) - Ctilde(2,2,i)=b(7,i) - DD(1,1,i)= b(6,i) - DD(2,2,i)=-b(6,i) - DD(2,1,i)= b(8,i) - DD(1,2,i)= b(8,i) - Dtilde(1,1,i)=b(6,i) - Dtilde(1,2,i)=b(8,i) - Dtilde(2,1,i)=-b(8,i) - Dtilde(2,2,i)=b(6,i) -#ifdef NEWCORR - 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) -#else - EE(1,1,i)= b(10,i)+b(11,i) - EE(2,2,i)=-b(10,i)+b(11,i) - EE(2,1,i)= b(12,i)-b(13,i) - EE(1,2,i)= b(12,i)+b(13,i) -#endif - enddo - if (lprint) then - do i=1,nloctyp - write (iout,*) 'Type',i - write (iout,*) 'B1' -c write (iout,'(f10.5)') B1(:,i) - write(iout,*) B1(1,i),B1(2,i) - write (iout,*) 'B2' -c write (iout,'(f10.5)') B2(:,i) - write(iout,*) B2(1,i),B2(2,i) - write (iout,*) 'CC' - do j=1,2 - write (iout,'(2f10.5)') CC(j,1,i),CC(j,2,i) - enddo - write(iout,*) 'DD' - do j=1,2 - write (iout,'(2f10.5)') DD(j,1,i),DD(j,2,i) - enddo - write(iout,*) 'EE' - do j=1,2 - write (iout,'(2f10.5)') EE(j,1,i),EE(j,2,i) - enddo - enddo - endif -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.6) 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,50) 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 60 -C----------------------- LJK potential -------------------------------- - 20 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJK potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,2a)') 'residue',' sigma ',' r0 ' - write (iout,'(a3,6x,2f10.5)') (restyp(i),sigma0(i),rr0(i), - & i=1,ntyp) - endif - goto 60 -C---------------------- GB or BP potential ----------------------------- - 30 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(sigii(i),i=1,ntyp),(chip0(i),i=1,ntyp), - & (alp(i),i=1,ntyp) -C For the GB potential convert sigma'**2 into chi' - if (ipot.eq.4) then - do i=1,ntyp - chip(i)=(chip0(i)-1.0D0)/(chip0(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 60 -C--------------------- GBV potential ----------------------------------- - 40 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp),(sigii(i),i=1,ntyp), - & (chip(i),i=1,ntyp),(alp(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the GBV potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,5a)') 'residue',' sigma ',' r0 ', - & 's||/s_|_^2',' chip ',' alph ' - write (iout,'(a3,6x,5f10.5)') (restyp(i),sigma0(i),rr0(i), - & sigii(i),chip(i),alp(i),i=1,ntyp) - endif - goto 60 -C--------------------- Momo potential ----------------------------------- - - 50 continue - - read (isidep,*,end=116,err=116) (icharge(i),i=1,ntyp) -c write (2,*) "icharge",(icharge(i),i=1,ntyp) - do i=1,ntyp - do j=1,i -c! write (*,*) "Im in ", i, " ", j - read(isidep,*,end=116,err=116) - & eps(i,j),sigma(i,j),chi(i,j),chi(j,i),chipp(i,j),chipp(j,i), - & (alphasur(k,i,j),k=1,4),sigmap1(i,j),sigmap2(i,j), - & chis(i,j),chis(j,i), - & nstate(i,j),(wstate(k,i,j),k=1,4), - & dhead(1,1,i,j), - & dhead(1,2,i,j), - & dhead(2,1,i,j), - & dhead(2,2,i,j), - & dtail(1,i,j),dtail(2,i,j), - & epshead(i,j),sig0head(i,j), - & rborn(i,j),rborn(j,i), - & (wqdip(k,i,j),k=1,2),wquad(i,j), - & alphapol(i,j),alphapol(j,i), - & (alphiso(k,i,j),k=1,4),sigiso1(i,j),sigiso2(i,j),epsintab(i,j) - END DO - END DO -c! write (*,*) "nstate gly-gly", nstate(10,10) -c! THIS LOOP FILLS PARAMETERS FOR PAIRS OF AA's NOT EXPLICITLY -c! DEFINED IN SCPARM.MOMO. IT DOES SO BY TAKING THEM FROM SYMMETRIC -c! PAIR, FOR EG. IF ARG-HIS IS BLANK, IT WILL TAKE PARAMETERS -c! FROM HIS-ARG. -c! -c! DISABLE IT AT >>YOUR OWN PERIL<< -c! - DO i = 1, ntyp - DO j = i+1, ntyp - eps(i,j) = eps(j,i) - sigma(i,j) = sigma(j,i) - nstate(i,j) = nstate(j,i) - sigmap1(i,j) = sigmap1(j,i) - sigmap2(i,j) = sigmap2(j,i) - sigiso1(i,j) = sigiso1(j,i) - sigiso2(i,j) = sigiso2(j,i) - - DO k = 1, 4 - alphasur(k,i,j) = alphasur(k,j,i) - wstate(k,i,j) = wstate(k,j,i) - alphiso(k,i,j) = alphiso(k,j,i) - END DO - - dhead(2,1,i,j) = dhead(1,1,j,i) - dhead(2,2,i,j) = dhead(1,2,j,i) - dhead(1,1,i,j) = dhead(2,1,j,i) - dhead(1,2,i,j) = dhead(2,2,j,i) - dtail(1,i,j) = dtail(1,j,i) - dtail(2,i,j) = dtail(2,j,i) -c! DO k = 1, 2 -c! DO l = 1, 2 -c! write (*,*) "dhead(k,l,j,i) = ", dhead(k,l,j,i) -c! write (*,*) "dhead(k,l,i,j) = ", dhead(k,l,i,j) -c! dhead(l,k,i,j) = dhead(k,l,j,i) -c! END DO -c! END DO - - epshead(i,j) = epshead(j,i) - sig0head(i,j) = sig0head(j,i) - - DO k = 1, 2 - wqdip(k,i,j) = wqdip(k,j,i) - END DO - - wquad(i,j) = wquad(j,i) - epsintab(i,j) = epsintab(j,i) - - END DO - END DO - - if (.not.lprint) goto 70 - write (iout,'(a)') - & "Parameters of the new physics-based SC-SC interaction potential" - write (iout,'(/7a)') 'Residues',' epsGB',' rGB', - & ' chi1GB',' chi2GB',' chip1GB',' chip2GB' - do i=1,ntyp - do j=1,i - write (iout,'(2(a3,1x),1pe10.3,5(0pf10.3))') - & restyp(i),restyp(j),eps(i,j),sigma(i,j),chi(i,j),chi(j,i), - & chipp(i,j),chipp(j,i) - enddo - enddo - write (iout,'(/9a)') 'Residues',' alphasur1',' alphasur2', - & ' alphasur3',' alphasur4',' sigmap1',' sigmap2', - & ' chis1',' chis2' - do i=1,ntyp - do j=1,i - write (iout,'(2(a3,1x),8(0pf10.3))') - & restyp(i),restyp(j),(alphasur(k,i,j),k=1,4), - & sigmap1(i,j),sigmap2(j,i),chis(i,j),chis(j,i) - enddo - enddo - write (iout,'(/14a)') 'Residues',' nst ',' wst1', - & ' wst2',' wst3',' wst4',' dh11',' dh21', - & ' dh12',' dh22',' dt1',' dt2',' epsh1', - & ' sigh' - do i=1,ntyp - do j=1,i - write (iout,'(2(a3,1x),i3,4f8.3,6f7.2,f9.5,f7.2)') - & restyp(i),restyp(j),nstate(i,j),(wstate(k,i,j),k=1,4), - & ((dhead(l,k,i,j),l=1,2),k=1,2),dtail(1,i,j),dtail(2,i,j), - & epshead(i,j),sig0head(i,j) - enddo - enddo - write (iout,'(/12a)') 'Residues',' ch1',' ch2', - & ' rborn1',' rborn2',' wqdip1',' wqdip2', - & ' wquad' - do i=1,ntyp - do j=1,i - write (iout,'(2(a3,1x),2i4,5f10.3)') - & restyp(i),restyp(j),icharge(i),icharge(j), - & rborn(i,j),rborn(j,i),(wqdip(k,i,j),k=1,2),wquad(i,j) - enddo - enddo - write (iout,'(/12a)') 'Residues', - & ' alphpol1', - & ' alphpol2',' alphiso1',' alpiso2', - & ' alpiso3',' alpiso4',' sigiso1',' sigiso2', - & ' epsin' - do i=1,ntyp - do j=1,i - write (iout,'(2(a3,1x),11f10.3)') - & restyp(i),restyp(j),alphapol(i,j),alphapol(j,i), - & (alphiso(k,i,j),k=1,4),sigiso1(i,j),sigiso2(j,i), - & epsintab(i,j) - enddo - enddo - goto 70 - - 60 continue - close (isidep) -C----------------------------------------------------------------------- -C Calculate the "working" parameters of SC interactions. - - IF (ipot.LT.6) THEN - 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 - END IF - - 70 continue - write (iout,*) "IPOT=",ipot - if (lprint) write (iout,'(/a/10x,7a/72(1h-))') - & 'Working parameters of the SC interactions:', - & ' a ',' b ',' augm ',' sigma ',' r0 ', - & ' chi1 ',' chi2 ' - do i=1,ntyp - do j=i,ntyp - epsij=eps(i,j) - if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4 .or. ipot.eq.6 ) THEN - rrij=sigma(i,j) - else - rrij=rr0(i)+rr0(j) - endif - r0(i,j)=rrij - r0(j,i)=rrij - rrij=rrij**expon - epsij=eps(i,j) - sigeps=dsign(1.0D0,epsij) - epsij=dabs(epsij) - aa(i,j)=epsij*rrij*rrij - bb(i,j)=-sigeps*epsij*rrij - aa(j,i)=aa(i,j) - bb(j,i)=bb(i,j) - IF ((ipot.gt.2).AND.(ipot.LT.6)) 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 - if (ipot.lt.6) then - write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') - & restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j), - & sigma(i,j),r0(i,j),chi(i,j),chi(j,i) - else - write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3),2i3,10f8.4, - & i3,40f10.4)') - & restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j), - & sigma(i,j),r0(i,j),chi(i,j),chi(j,i), - & icharge(i),icharge(j),chipp(i,j),chipp(j,i), - & (alphasur(k,i,j),k=1,4),sigmap1(i,j),sigmap2(j,i), - & chis(i,j),chis(j,i), - & nstate(i,j),(wstate(k,i,j),k=1,4), - & ((dhead(l,k,i,j),l=1,2),k=1,2),dtail(1,i,j),dtail(2,i,j), - & epshead(i,j),sig0head(i,j), - & rborn(i,j),(wqdip(k,i,j),k=1,2),wquad(i,j), - & alphapol(i,j),alphapol(j,i), - & (alphiso(k,i,j),k=1,4),sigiso1(i,j),sigiso2(i,j) - - endif - 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 - ebr=-5.50D0 -c -c Old arbitrary potential - commented out. -c -c dbr= 4.20D0 -c fbr= 3.30D0 -c -c Constants of the disulfide-bond potential determined based on the RHF/6-31G** -c energy surface of diethyl disulfide. -c A. Liwo and U. Kozlowska, 11/24/03 -c - D0CM = 3.78d0 - AKCM = 15.1d0 - AKTH = 11.0d0 - AKCT = 12.0d0 - V1SS =-1.08d0 - V2SS = 7.61d0 - V3SS = 13.7d0 - - if (lprint) then - write (iout,'(/a)') "Disulfide bridge parameters:" - write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr - write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm - write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct - write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss, - & ' v3ss:',v3ss - endif - return - 110 write (iout,*) "Error reading bond energy parameters." - goto 999 - 111 write (iout,*) "Error reading bending energy parameters." - goto 999 - 112 write (iout,*) "Error reading rotamer energy parameters." - goto 999 - 113 write (iout,*) "Error reading torsional energy parameters." - goto 999 - 114 write (iout,*) "Error reading double torsional energy parameters." - goto 999 - 115 write (iout,*) - & "Error reading cumulant (multibody energy) parameters." - goto 999 - 116 write (iout,*) "Error reading electrostatic energy parameters." - goto 999 - 117 write (iout,*) "Error reading side chain interaction parameters." - goto 999 - 118 write (iout,*) "Error reading SCp interaction parameters." - goto 999 - 119 write (iout,*) "Error reading SCCOR parameters" - 999 continue -#ifdef MPI - call MPI_Finalize(Ierror) -#endif - stop - end diff --git a/source/wham/src-NEWSC-NEWCORR/pinorm.f b/source/wham/src-NEWSC-NEWCORR/pinorm.f deleted file mode 100644 index 91392bf..0000000 --- a/source/wham/src-NEWSC-NEWCORR/pinorm.f +++ /dev/null @@ -1,17 +0,0 @@ - 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-NEWSC-NEWCORR/printmat.f b/source/wham/src-NEWSC-NEWCORR/printmat.f deleted file mode 100644 index be2b38f..0000000 --- a/source/wham/src-NEWSC-NEWCORR/printmat.f +++ /dev/null @@ -1,16 +0,0 @@ - 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-NEWSC-NEWCORR/proc_cont.f b/source/wham/src-NEWSC-NEWCORR/proc_cont.f deleted file mode 100644 index 9269496..0000000 --- a/source/wham/src-NEWSC-NEWCORR/proc_cont.f +++ /dev/null @@ -1,156 +0,0 @@ - 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-NEWSC-NEWCORR/proc_proc.c b/source/wham/src-NEWSC-NEWCORR/proc_proc.c deleted file mode 100644 index 01c6bba..0000000 --- a/source/wham/src-NEWSC-NEWCORR/proc_proc.c +++ /dev/null @@ -1,124 +0,0 @@ -#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; - -sscanf(buf,"%d",&j); -*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-NEWSC-NEWCORR/promienie.f b/source/wham/src-NEWSC-NEWCORR/promienie.f deleted file mode 100644 index 12a2e80..0000000 --- a/source/wham/src-NEWSC-NEWCORR/promienie.f +++ /dev/null @@ -1,46 +0,0 @@ - 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.21) then - dsc_inv(i)=0.0d0 - else - dsc_inv(i)=1.0d0/dsc(i) - endif - enddo - return - end diff --git a/source/wham/src-NEWSC-NEWCORR/qwolynes.f b/source/wham/src-NEWSC-NEWCORR/qwolynes.f deleted file mode 100644 index 97b5efb..0000000 --- a/source/wham/src-NEWSC-NEWCORR/qwolynes.f +++ /dev/null @@ -1,186 +0,0 @@ - double precision function qwolynes(ilevel,jfrag) - implicit none - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'DIMENSIONS.COMPAR' - include 'COMMON.IOUNITS' - include 'COMMON.COMPAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - integer ilevel,jfrag - integer i,j,jl,k,l,il,kl,nl,np,ip,kp - integer nsep /3/ - 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 - qq = 0.0d0 - if (ilevel.eq.0) then - if (lprn) write (iout,*) "Q computed for whole molecule" - nl=0 - do il=nnt+nsep,nct - do jl=nnt,il-nsep - dij=0.0d0 - dijCM=0.0d0 - d0ij=0.0d0 - d0ijCM=0.0d0 - qqij=0.0d0 - qqijCM=0.0d0 - nl=nl+1 - d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ - & (cref(2,jl)-cref(2,il))**2+ - & (cref(3,jl)-cref(3,il))**2) - dij=dist(il,jl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,jl+nres)-cref(1,il+nres))**2+ - & (cref(2,jl+nres)-cref(2,il+nres))**2+ - & (cref(3,jl+nres)-cref(3,il+nres))**2) - dijCM=dist(il+nres,jl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - 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 (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(il,jl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,jl+nres)-cref(1,il+nres))**2+ - & (cref(2,jl+nres)-cref(2,il+nres))**2+ - & (cref(3,jl+nres)-cref(3,il+nres))**2) - dijCM=dist(il+nres,jl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - if (lprn) then - write (iout,*) "i",i," j",j," il",il," jl",jl, - & " itype",itype(il),itype(jl) - write (iout,*)"d0ij",d0ij," dij",dij," d0ijCM",d0ijCM, - & " dijCM",dijCM," qqij",qqij," qqijCM",qqijCM - endif - endif - enddo - enddo - qq = qq/nl - if (lprn) write (iout,*) "nl",nl," qq",qq - else if (ilevel.eq.2) then - np=npiece(jfrag,ilevel) - nl=0 - do i=2,np - ip=ipiece(i,jfrag,ilevel) - do j=1,nlist_frag(ip) - il=list_frag(j,ip) - do k=1,i-1 - kp=ipiece(k,jfrag,ilevel) - do l=1,nlist_frag(kp) - kl=list_frag(l,kp) - if (iabs(kl-il).gt.nsep) then - nl=nl+1 - dij=0.0d0 - dijCM=0.0d0 - d0ij=0.0d0 - d0ijCM=0.0d0 - qqij=0.0d0 - qqijCM=0.0d0 - d0ij=dsqrt((cref(1,kl)-cref(1,il))**2+ - & (cref(2,kl)-cref(2,il))**2+ - & (cref(3,kl)-cref(3,il))**2) - dij=dist(il,kl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(kl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,kl+nres)-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(il+nres,kl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/ - & (sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - if (lprn) then - write (iout,*) "i",i," j",j," k",k," l",l," il",il, - & " kl",kl," itype",itype(il),itype(kl) - write (iout,*) " d0ij",d0ij," dij",dij," d0ijCM", - & d0ijCM," dijCM",dijCM," qqij",qqij," qqijCM",qqijCM - endif - endif - enddo ! l - enddo ! k - enddo ! j - enddo ! i - qq = qq/nl - if (lprn) write (iout,*) "nl",nl," qq",qq - else - write (iout,*)"Error: Q can be computed only for level 1 and 2." - endif - 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-NEWSC-NEWCORR/read_ref_str.F b/source/wham/src-NEWSC-NEWCORR/read_ref_str.F deleted file mode 100644 index 4b56181..0000000 --- a/source/wham/src-NEWSC-NEWCORR/read_ref_str.F +++ /dev/null @@ -1,165 +0,0 @@ - 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 ilen - external ilen -C - nres0=nres - write (iout,*) "pdbref",pdbref - if (pdbref) then - read(inp,'(a)') pdbfile - write (iout,'(2a,1h.)') 'PDB data will be read from file ', - & pdbfile(:ilen(pdbfile)) - open(ipdbin,file=pdbfile,status='old',err=33) - goto 34 - 33 write (iout,'(a)') 'Error opening PDB file.' - 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_ref(j) - theta_ref(j+i)=theta_ref(j) - alph_ref(j+i)=alph_ref(j) - omeg_ref(j+i)=omeg_ref(j) - enddo -#ifdef DEBUG - do j=nnt,nct - write (iout,'(i5,3f10.5,5x,3f10.5)') - & j,(cref(k,j),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 - 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 print *,"Calling contact" - call contact(.true.,ncont_ref,icont_ref(1,1), - & nstart_sup,nend_sup) -c print *,"Calling elecont" - call elecont(.true.,ncont_pept_ref, - & icont_pept_ref(1,1), - & nstart_sup,nend_sup) - write (iout,'(a,i3,a,i3,a,i3,a)') - & 'Number of residues to be superposed:',nsup, - & ' (from residue',nstart_sup,' to residue', - & nend_sup,').' - return - end diff --git a/source/wham/src-NEWSC-NEWCORR/readpdb.f b/source/wham/src-NEWSC-NEWCORR/readpdb.f deleted file mode 100644 index 0b82476..0000000 --- a/source/wham/src-NEWSC-NEWCORR/readpdb.f +++ /dev/null @@ -1,219 +0,0 @@ - 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' - character*3 seq,atom,res - character*80 card - double precision sccor(3,20) - integer i,j,iii,ibeg,ishift,ishift1,ity,ires,ires_old - double precision dcj - integer rescode - ibeg=1 - ishift1=0 - do i=1,10000 - read (ipdbin,'(a80)',end=10) card - if (card(:3).eq.'END' .or. card(:3).eq.'TER') goto 10 -C Fish out the ATOM cards. - if (index(card(1:4),'ATOM').gt.0) then - read (card(14:16),'(a3)') atom - if (atom.eq.'CA' .or. atom.eq.'CH3') then -C Calculate the CM of the preceding residue. - if (ibeg.eq.0) call sccenter(ires,iii,sccor) -C Start new residue. - ires_old=ires+ishift-ishift1 - read (card(23:26),*) ires -c print *,"ires_old",ires_old," ires",ires - if (card(27:27).eq."A" .or. card(27:27).eq."B") then -c ishift1=ishift1+1 - endif - read (card(18:20),'(a3)') res - if (ibeg.eq.1) then - ishift=ires-1 - if (res.ne.'GLY' .and. res.ne. 'ACE') then - ishift=ishift-1 - itype(1)=21 - endif - ibeg=0 - else - ishift=ishift+ires-ires_old-1 - endif - ires=ires-ishift+ishift1 - 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) - 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 -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 ') 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 the CM of the last side chain. - call sccenter(ires,iii,sccor) - nres=ires - nsup=nres - nstart_sup=1 - if (itype(nres).ne.10) then - nres=nres+1 - itype(nres)=21 - 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 - 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 - 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 -C Copy the coordinates to reference coordinates - do i=1,2*nres - do j=1,3 - cref(j,i)=c(j,i) - enddo - enddo -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,ires+nres),j=1,3) - enddo - call flush(iout) - call int_from_cart(.true.,.true.) - do i=1,nres - phi_ref(i)=phi(i) - theta_ref(i)=theta(i) - alph_ref(i)=alph(i) - omeg_ref(i)=omeg(i) - enddo - 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,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) - 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.21 .and. itype(i).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 - 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.21) then - do j=1,3 - c(j,1)=c(j,2)+(c(j,3)-c(j,4)) - enddo - endif - if (itype(nres).eq.21) 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/wham/src-NEWSC-NEWCORR/readrtns.F b/source/wham/src-NEWSC-NEWCORR/readrtns.F deleted file mode 100644 index 006c111..0000000 --- a/source/wham/src-NEWSC-NEWCORR/readrtns.F +++ /dev/null @@ -1,779 +0,0 @@ - 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) - 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 - energy_dec=index(controlcard,"ENERGY_DEC").gt.0 - 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) - 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 readi(controlcard,"NGRIDT",NGridT,400) - call reada(controlcard,"STARTGRIDT",StartGridT,200.0d0) - call reada(controlcard,"DELTA_T",Delta_T,1.0d0) - call reada(controlcard,"DELTRGY",deltrgy,5.0d-2) - call readi(controlcard,"RESCALE",rescale_mode,1) - check_conf=index(controlcard,"NO_CHECK_CONF").eq.0 - 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 - call readi(controlcard,'CONSTR_DIST',constr_dist,0) - write (iout,*) "with_dihed_constr ",with_dihed_constr, - & " CONSTR_DIST",constr_dist - refstr = index(controlcard,'REFSTR').gt.0 - pdbref = index(controlcard,'PDBREF').gt.0 - call flush(iout) - 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) - 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 - 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-NEWSC-NEWCORR/readrtns.F.org b/source/wham/src-NEWSC-NEWCORR/readrtns.F.org deleted file mode 100644 index 1fa6e46..0000000 --- a/source/wham/src-NEWSC-NEWCORR/readrtns.F.org +++ /dev/null @@ -1,691 +0,0 @@ - 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-NEWSC-NEWCORR/readrtns_compar.F b/source/wham/src-NEWSC-NEWCORR/readrtns_compar.F deleted file mode 100644 index 8e03f15..0000000 --- a/source/wham/src-NEWSC-NEWCORR/readrtns_compar.F +++ /dev/null @@ -1,160 +0,0 @@ - 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) - 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-NEWSC-NEWCORR/rescode.f b/source/wham/src-NEWSC-NEWCORR/rescode.f deleted file mode 100644 index b516fed..0000000 --- a/source/wham/src-NEWSC-NEWCORR/rescode.f +++ /dev/null @@ -1,32 +0,0 @@ - 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=1,ntyp1 - if (ucase(nam).eq.restyp(i)) then - rescode=i - return - endif - enddo - - else - - do i=1,ntyp1 - if (nam(1:1).eq.onelet(i)) then - rescode=i - return - endif - enddo - - endif - - write (iout,10) iseq,nam - stop - 10 format ('**** Error - residue',i4,' has an unresolved name ',a3) - end - diff --git a/source/wham/src-NEWSC-NEWCORR/rmscalc.f b/source/wham/src-NEWSC-NEWCORR/rmscalc.f deleted file mode 100644 index 70d9425..0000000 --- a/source/wham/src-NEWSC-NEWCORR/rmscalc.f +++ /dev/null @@ -1,156 +0,0 @@ - double precision function rmscalc(ishif,i,j,jcon,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' - 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 - if (lprn) then - write (iout,*) "i",i," j",j," jcont",jcon," ishif",ishif - write (iout,*) "npiece",npiece(j,i) - endif - ii=0 - do l=1,nres - iadded(l)=.false. - enddo - do k=1,npiece(j,i) - if (i.eq.1) then - if (lprn) - & write (iout,*) "Level 1: j=",j,"k=",k," adding fragment", - & ifrag(1,k,j),ifrag(2,k,j) - call cprep(ifrag(1,k,j),ifrag(2,k,j),ishif,ii) -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) - & write (iout,*) "Level",i,": j=",j,"k=",k," kk=",kk, - & " l=",l," adding fragment", - & ifrag(1,l,kk),ifrag(2,l,kk) - call cprep(ifrag(1,l,kk),ifrag(2,l,kk),ishif,ii) - enddo - endif - enddo - if (lprn) then - do k=1,ii - 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 - endif - call fitsq(rms,cc(1,1),creff(1,1),ii,przes,obrot,non_conv) - if (non_conv) then - print *,'Error: FITSQ non-convergent, jcon',jcon - rmscalc=1.0d2 - else if (rms.lt.-1.0d-6) then - print *,'Error: rms^2 = ',rms,jcon - rmscalc = 1.0d2 - else if (rms.ge.1.0d-6 .and. rms.lt.0) then - rmscalc=0.0d0 - else - rmscalc = dsqrt(rms) - endif - return - end -c------------------------------------------------------------------------- - subroutine cprep(if1,if2,ishif,ii) - 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' - 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 -c write (iout,*) "Calling cprep" - do l=if1,if2 -c write (iout,*) "l",l," iadded",iadded(l) - if (l+ishif.gt.1 .and. l+ishif.le.nres .and. .not.iadded(l)) - & then - ii=ii+1 - iadded(l)=.true. - inumber(1,ii)=l - inumber(2,ii)=l+ishif - do m=1,3 - creff(m,ii)=cref(m,l) - cc(m,ii)=c(m,l+ishif) - enddo - endif - enddo - return - end -c------------------------------------------------------------------------- - double precision function rmsnat(jcon) - 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' - double precision przes(3),obrot(3,3) - logical non_conv - integer ishif,i,j - call fitsq(rms,c(1,nstart_sup),cref(1,nstart_sup),nsup, - & przes,obrot,non_conv) - if (non_conv) then - print *,'Error: FITSQ non-convergent, jcon',jcon - rmsnat=1.0d2 - else if (rms.lt.-1.0d-6) then - print *,'Error: rms^2 = ',rms,jcon - rmsnat = 1.0d2 - else if (rms.ge.1.0d-6 .and. rms.lt.0) then - rmsnat=0.0d0 - else - rmsnat = dsqrt(rms) - endif - return - end -c----------------------------------------------------------------------------- - double precision function gyrate(jcon) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.INTERACT' - include 'COMMON.CHAIN' - double precision cen(3),rg - - do j=1,3 - cen(j)=0.0d0 - enddo - - do i=nnt,nct - do j=1,3 - cen(j)=cen(j)+c(j,i) - enddo - enddo - do j=1,3 - cen(j)=cen(j)/dble(nct-nnt+1) - enddo - rg = 0.0d0 - do i = nnt, nct - do j=1,3 - rg = rg + (c(j,i)-cen(j))**2 - enddo - end do - gyrate = dsqrt(rg/dble(nct-nnt+1)) - return - end diff --git a/source/wham/src-NEWSC-NEWCORR/secondary.f b/source/wham/src-NEWSC-NEWCORR/secondary.f deleted file mode 100644 index 9c9bc7d..0000000 --- a/source/wham/src-NEWSC-NEWCORR/secondary.f +++ /dev/null @@ -1,713 +0,0 @@ - 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:' - do j=1,nbfrag - write(iout,*) 'beta ',(bfrag(i,j),i=1,4) - enddo - - do j=1,nhfrag - write(iout,*) 'helix ',(hfrag(i,j),i=1,2) - enddo - - endif - - 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-NEWSC-NEWCORR/setup_var.f b/source/wham/src-NEWSC-NEWCORR/setup_var.f deleted file mode 100644 index f052400..0000000 --- a/source/wham/src-NEWSC-NEWCORR/setup_var.f +++ /dev/null @@ -1,31 +0,0 @@ - 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-NEWSC-NEWCORR/slices.F b/source/wham/src-NEWSC-NEWCORR/slices.F deleted file mode 100644 index b22ea13..0000000 --- a/source/wham/src-NEWSC-NEWCORR/slices.F +++ /dev/null @@ -1,80 +0,0 @@ - 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-NEWSC-NEWCORR/store_parm.F b/source/wham/src-NEWSC-NEWCORR/store_parm.F deleted file mode 100644 index 0ededff..0000000 --- a/source/wham/src-NEWSC-NEWCORR/store_parm.F +++ /dev/null @@ -1,547 +0,0 @@ - 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,j,k,l,m,mm,iparm - -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 -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=1,ntyp - a0thet_all(i,iparm)=a0thet(i) - do j=1,2 - athet_all(j,i,iparm)=athet(j,i) - bthet_all(j,i,iparm)=bthet(j,i) - 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=1,ntyp1 - ithetyp_all(i,iparm)=ithetyp(i) - enddo - do i=1,maxthetyp1 - do j=1,maxthetyp1 - do k=1,maxthetyp1 - aa0thet_all(i,j,k,iparm)=aa0thet(i,j,k) - do l=1,ntheterm - aathet_all(l,i,j,k,iparm)=aathet(l,i,j,k) - enddo - do l=1,ntheterm2 - do m=1,nsingle - bbthet_all(m,l,i,j,k,iparm)=bbthet(m,l,i,j,k) - ccthet_all(m,l,i,j,k,iparm)=ccthet(m,l,i,j,k) - ddthet_all(m,l,i,j,k,iparm)=ddthet(m,l,i,j,k) - eethet_all(m,l,i,j,k,iparm)=eethet(m,l,i,j,k) - enddo - enddo - do l=1,ntheterm3 - do m=1,ndouble - do mm=1,ndouble - ffthet_all(mm,m,l,i,j,k,iparm)=ffthet(mm,m,l,i,j,k) - ggthet_all(mm,m,l,i,j,k,iparm)=ggthet(mm,m,l,i,j,k) - enddo - enddo - enddo - enddo - enddo - enddo -#endif -#ifdef CRYST_SC -c Store the sidechain rotamer parameters - do i=1,ntyp - nlob_all(i,iparm)=nlob(i) - do j=1,nlob(i) - bsc_all(j,i,iparm)=bsc(j,i) - 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 i=1,ntortyp - do j=1,ntortyp - v0_all(i,j,iparm)=v0(i,j) - nterm_all(i,j,iparm)=nterm(i,j) - nlor_all(i,j,iparm)=nlor(i,j) - do k=1,nterm(i,j) - v1_all(k,i,j,iparm)=v1(k,i,j) - v2_all(k,i,j,iparm)=v2(i,i,j) - enddo - do k=1,nlor(i,j) - 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 -c Store the double torsional parameters - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - ntermd1_all(i,j,k,iparm)=ntermd_1(i,j,k) - ntermd2_all(i,j,k,iparm)=ntermd_2(i,j,k) - do l=1,ntermd_1(i,j,k) - v1c_all(1,l,i,j,k,iparm)=v1c(1,l,i,j,k) - v1c_all(2,l,i,j,k,iparm)=v1c(2,l,i,j,k) - v2c_all(1,l,i,j,k,iparm)=v2c(1,l,i,j,k) - v2c_all(2,l,i,j,k,iparm)=v2c(2,l,i,j,k) - enddo - do l=1,ntermd_2(i,j,k) - do m=1,ntermd_2(i,j,k) - v2s_all(l,m,i,j,k,iparm)=v2s(l,m,i,j,k) - enddo - enddo - enddo - enddo - enddo -c Store parameters of the cumulants - do i=1,nloctyp - do j=1,2 - b1_all(j,i,iparm)=b1(j,i) - b1tilde_all(j,i,iparm)=b1tilde(j,i) - b2_all(j,i,iparm)=b2(j,i) - enddo - do j=1,2 - do k=1,2 - cc_all(k,j,i,iparm)=cc(k,j,i) - ctilde_all(k,j,i,iparm)=ctilde(k,j,i) - dd_all(k,j,i,iparm)=dd(k,j,i) - dtilde_all(k,j,i,iparm)=dtilde(k,j,i) - ee_all(k,j,i,iparm)=ee(k,j,i) - enddo - enddo - enddo -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_all(j,i,iparm)=aa(j,i) - bb_all(j,i,iparm)=bb(j,i) - r0_all(j,i,iparm)=r0(j,i) - sigma_all(j,i,iparm)=sigma(j,i) - chi_all(j,i,iparm)=chi(j,i) - chipp_all(j,i,iparm)=chipp(j,i) - augm_all(j,i,iparm)=augm(j,i) - eps_all(j,i,iparm)=eps(j,i) - sigmap1_all(j,i,iparm)=sigmap1(j,i) - sigmap2_all(j,i,iparm)=sigmap2(j,i) - chis_all(j,i,iparm)=chis(j,i) - do k=1,4 - alphasur_all(k,j,i,iparm)=alphasur(k,j,i) - wstate_all(k,j,i,iparm)=wstate(k,j,i) - enddo - nstate_all(j,i,iparm)=nstate(j,i) - do k=1,2 - do l=1,2 - dhead_all(l,k,j,i,iparm)=dhead(l,k,j,i) - enddo - enddo - do k=1,2 - dtail_all(k,j,i,iparm)=dtail(k,j,i) - enddo - epshead_all(j,i,iparm)=epshead(j,i) - rborn_all(j,i,iparm)=rborn(j,i) - do k=1,2 - wqdip_all(k,j,i,iparm)=wqdip(k,j,i) - enddo - wquad_all(j,i,iparm)=wquad(j,i) - alphapol_all(j,i,iparm)=alphapol(j,i) - do k=1,4 - alphiso_all(k,j,i,iparm)=alphiso(k,j,i) - enddo - sigiso1_all(j,i,iparm)=sigiso1(j,i) - sigiso2_all(j,i,iparm)=sigiso2(j,i) - epsintab_all(j,i,iparm)=epsintab(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=1,nsccortyp - do j=1,nsccortyp - - nterm_sccor_all(j,i,iparm)=nterm_sccor(j,i) - 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,j,k,l,m,mm,iparm - -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) -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=1,ntyp - a0thet(i)=a0thet_all(i,iparm) - do j=1,2 - athet(j,i)=athet_all(j,i,iparm) - bthet(j,i)=bthet_all(j,i,iparm) - 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=1,ntyp1 - ithetyp(i)=ithetyp_all(i,iparm) - enddo - do i=1,maxthetyp1 - do j=1,maxthetyp1 - do k=1,maxthetyp1 - aa0thet(i,j,k)=aa0thet_all(i,j,k,iparm) - do l=1,ntheterm - aathet(l,i,j,k)=aathet_all(l,i,j,k,iparm) - enddo - do l=1,ntheterm2 - do m=1,nsingle - bbthet(m,l,i,j,k)=bbthet_all(m,l,i,j,k,iparm) - ccthet(m,l,i,j,k)=ccthet_all(m,l,i,j,k,iparm) - ddthet(m,l,i,j,k)=ddthet_all(m,l,i,j,k,iparm) - eethet(m,l,i,j,k)=eethet_all(m,l,i,j,k,iparm) - enddo - enddo - do l=1,ntheterm3 - do m=1,ndouble - do mm=1,ndouble - ffthet(mm,m,l,i,j,k)=ffthet_all(mm,m,l,i,j,k,iparm) - ggthet(mm,m,l,i,j,k)=ggthet_all(mm,m,l,i,j,k,iparm) - enddo - enddo - enddo - enddo - enddo - enddo -#endif -c Restore the sidechain rotamer parameters -#ifdef CRYST_SC - do i=1,ntyp - nlob(i)=nlob_all(i,iparm) - do j=1,nlob(i) - bsc(j,i)=bsc_all(j,i,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 i=1,ntortyp - do j=1,ntortyp - v0(i,j)=v0_all(i,j,iparm) - nterm(i,j)=nterm_all(i,j,iparm) - nlor(i,j)=nlor_all(i,j,iparm) - do k=1,nterm(i,j) - v1(k,i,j)=v1_all(k,i,j,iparm) - v2(i,i,j)=v2_all(k,i,j,iparm) - enddo - do k=1,nlor(i,j) - 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 -c Restore the double torsional parameters - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - ntermd_1(i,j,k)=ntermd1_all(i,j,k,iparm) - ntermd_2(i,j,k)=ntermd2_all(i,j,k,iparm) - do l=1,ntermd_1(i,j,k) - v1c(1,l,i,j,k)=v1c_all(1,l,i,j,k,iparm) - v1c(2,l,i,j,k)=v1c_all(2,l,i,j,k,iparm) - v2c(1,l,i,j,k)=v2c_all(1,l,i,j,k,iparm) - v2c(2,l,i,j,k)=v2c_all(2,l,i,j,k,iparm) - enddo - do l=1,ntermd_2(i,j,k) - do m=1,ntermd_2(i,j,k) - v2s(l,m,i,j,k)=v2s_all(l,m,i,j,k,iparm) - enddo - enddo - enddo - enddo - enddo -c Restore parameters of the cumulants - do i=1,nloctyp - do j=1,2 - b1(j,i)=b1_all(j,i,iparm) - b1tilde(j,i)=b1tilde_all(j,i,iparm) - b2(j,i)=b2_all(j,i,iparm) - enddo - do j=1,2 - do k=1,2 - cc(k,j,i)=cc_all(k,j,i,iparm) - ctilde(k,j,i)=ctilde_all(k,j,i,iparm) - dd(k,j,i)=dd_all(k,j,i,iparm) - dtilde(k,j,i)=dtilde_all(k,j,i,iparm) - ee(k,j,i)=ee_all(k,j,i,iparm) - enddo - enddo - enddo -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(j,i)=aa_all(j,i,iparm) - bb(j,i)=bb_all(j,i,iparm) - r0(j,i)=r0_all(j,i,iparm) - sigma(j,i)=sigma_all(j,i,iparm) - chi(j,i)=chi_all(j,i,iparm) - chipp(j,i)=chipp_all(j,i,iparm) - augm(j,i)=augm_all(j,i,iparm) - eps(j,i)=eps_all(j,i,iparm) - sigmap1(j,i)=sigmap1_all(j,i,iparm) - sigmap2(j,i)=sigmap2_all(j,i,iparm) - chis(j,i)=chis_all(j,i,iparm) - do k=1,4 - alphasur(k,j,i)=alphasur_all(k,j,i,iparm) - wstate(k,j,i)=wstate_all(k,j,i,iparm) - enddo - nstate(j,i)=nstate_all(j,i,iparm) - do k=1,2 - do l=1,2 - dhead(l,k,j,i)=dhead_all(l,k,j,i,iparm) - enddo - enddo - do k=1,2 - dtail(k,j,i)=dtail_all(k,j,i,iparm) - enddo - epshead(j,i)=epshead_all(j,i,iparm) - rborn(j,i)=rborn_all(j,i,iparm) - do k=1,2 - wqdip(k,j,i)=wqdip_all(k,j,i,iparm) - enddo - wquad(j,i)=wquad_all(j,i,iparm) - alphapol(j,i)=alphapol_all(j,i,iparm) - do k=1,4 - alphiso(k,j,i)=alphiso_all(k,j,i,iparm) - enddo - sigiso1(j,i)=sigiso1_all(j,i,iparm) - sigiso2(j,i)=sigiso2_all(j,i,iparm) - epsintab(j,i)=epsintab_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=1,nsccortyp - do j=1,nsccortyp - - nterm_sccor(j,i)=nterm_sccor_all(j,i,iparm) -c do i=1,20 -c do j=1,20 - 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-NEWSC-NEWCORR/timing.F b/source/wham/src-NEWSC-NEWCORR/timing.F deleted file mode 100644 index 1012457..0000000 --- a/source/wham/src-NEWSC-NEWCORR/timing.F +++ /dev/null @@ -1,163 +0,0 @@ -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-NEWSC-NEWCORR/wham_calc1.F b/source/wham/src-NEWSC-NEWCORR/wham_calc1.F deleted file mode 100644 index 57a41d3..0000000 --- a/source/wham/src-NEWSC-NEWCORR/wham_calc1.F +++ /dev/null @@ -1,1454 +0,0 @@ - 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 MaxBinRms,MaxBinRgy - parameter (MaxBinRms=100,MaxBinRgy=100) - integer MaxHdim -c parameter (MaxHdim=200000) - parameter (MaxHdim=100) - integer maxinde - parameter (maxinde=100) -#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" - integer MaxPoint,MaxPointProc - parameter (MaxPoint=MaxStr, - & MaxPointProc=MaxStr_Proc) - double precision finorm_max,potfac,entmin,entmax,expfac,vf - double precision entfac_min,entfac_min_t - 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), - & fi_p_min(MaxR,MaxT_h,Max_Parm) - double precision sumW_p(0:Max_GridT,Max_Parm), - & sumE_p(0:Max_GridT,Max_Parm),sumEsq_p(0:Max_GridT,Max_Parm), - & sumQ_p(MaxQ1,0:Max_GridT,Max_Parm), - & sumQsq_p(MaxQ1,0:Max_GridT,Max_Parm), - & sumEQ_p(MaxQ1,0:Max_GridT,Max_Parm), - & sumEprim_p(MaxQ1,0:Max_GridT,Max_Parm), - & sumEbis_p(0:Max_GridT,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_all(maxT_h,Max_Parm),entmin_p,entmax_p - integer histent_p(0:2000) - logical lprint /.true./ -#endif - 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), - & fi_min(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_all(maxT_h,Max_Parm),potEmin,potEmin_min,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/, - & 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 - - 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 (iout,*) "Enter WHAM_calc" - call flush(iout) - 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 - do i=1,nParmset - do j=1,nT_h(i) - potEmin_all(j,i)=1.0d10 - enddo - enddo - rgymin=1.0d10 - rmsmin=1.0d10 - rgymax=0.0d0 - rmsmax=0.0d0 - do t=0,MaxN - htot(t)=0 - enddo -#ifdef MPI - do i=1,scount(me1) -#else - do i=1,ntot(islice) -#endif - 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 - if (ind_point(i).lt.0 .or. ind_point(i).gt.MaxHdim) then - write (iout,*) "Error - index exceeds range for point",i, - & " q=",q(j,i)," ind",ind_point(i) -#ifdef MPI - write (iout,*) "Processor",me1 - call flush(iout) - call MPI_Abort(MPI_COMM_WORLD, Ierror, Errcode ) -#endif - stop - endif - enddo ! j - if (ind_point(i).gt.tmax) tmax=ind_point(i) - htot(ind_point(i))=htot(ind_point(i))+1 -#ifdef DEBUG - write (iout,*) "i",i,"q",(q(j,i),j=1,nQ)," ind",ind_point(i), - & " htot",htot(ind_point(i)) - call flush(iout) -#endif - enddo ! i - call flush(iout) - - nbin=nbin1**nQ-1 - write (iout,'(a)') "Numbers of counts in Q bins" - do t=0,tmax - if (htot(t).gt.0) then - write (iout,'(i15,$)') t - 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(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) - rgymin=rgymin_t - rgymax=rgymax_t - rmsmin=rmsmin_t - rmsmax=rmsmax_t -#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,21) -#endif - call restore_parm(iparm) -#ifdef DEBUG - write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc, - & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc, - & wtor_d,wsccor,wbond -#endif - do ib=1,nT_h(iparm) - 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) -#ifdef DEBUG - write (iout,'(3i5,6f5.2,14f12.3)') i,ib,iparm,(ft(l),l=1,6), - & evdw+evdw_t,evdw2,ees,evdw1,ecorr,eel_loc,estr,ebe,escloc, - & etors,etors_d,eello_turn3,eello_turn4,esccor -#endif - -#ifdef SPLITELE - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees - & +wvdwpp*evdw1 - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc - & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#else - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 - & +ft(1)*welec*(ees+evdw1) - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr - & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#endif -#ifdef DEBUG - write (iout,*) i,iparm,1.0d0/(beta_h(ib,iparm)*1.987D-3), - & etot -#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 - v(i,kk,ib,iparm)= - & -beta_h(ib,iparm)*(etot+Econstr) -#ifdef DEBUG - write (iout,'(4i5,4e15.5)') i,kk,ib,iparm, - & etot,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" - entfac_min=1.0d10 -#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 - if (entfac(t).lt.entfac_min) entfac_min=entfac(t) -#ifdef DEBUG - write (iout,*) t,"vmax",vmax," denom",denom,"entfac",entfac(t) -#endif - enddo -c#ifdef MPI -c write (iout,*) "entfac_min before AllReduce",entfac_min -c call MPI_AllReduce(entfac_min,entfac_min_t,1, -c & MPI_DOUBLE_PRECISION,MPI_MAX,WHAM_COMM,IERROR) -c entfac_min=entfac_min_t -c write (iout,*) "entfac_min after AllReduce",entfac_min -c#endif -c#ifdef MPI -c do t=1,scount(me) -c entfac(t)=entfac(t)-entfac_min -c enddo -c#else -c do t=1,ntot(islice) -c entfac(t)=entfac(t)-entfac_min -c enddo -c#endif - do iparm=1,nParmSet - do iib=1,nT_h(iparm) - do ii=1,nR(iib,iparm) -#ifdef MPI - fi_p_min(ii,iib,iparm)=-1.0d10 - do t=1,scount(me) - aux=v(t,ii,iib,iparm)+entfac(t) - if (aux.gt.fi_p_min(ii,iib,iparm)) - & fi_p_min(ii,iib,iparm)=aux - enddo -#else - do t=1,ntot(islice) - aux=v(t,ii,iib,iparm)+entfac(t) - if (aux.gt.fi_min(ii,iib,iparm)) - & fi_min(ii,iib,iparm)=aux - enddo -#endif - enddo ! ii - enddo ! iib - enddo ! iparm -#ifdef MPI -#ifdef DEBUG - write (iout,*) "fi_min before AllReduce" - do i=1,nParmSet - do j=1,nT_h(i) - write (iout,*) (i,j,k,fi_p_min(k,j,i),k=1,nR(j,i)) - enddo - enddo -#endif - call MPI_AllReduce(fi_p_min,fi_min,MaxR*MaxT_h*nParmSet, - & MPI_DOUBLE_PRECISION,MPI_MAX,WHAM_COMM,IERROR) -#ifdef DEBUG - write (iout,*) "fi_min after AllReduce" - do i=1,nParmSet - do j=1,nT_h(i) - write (iout,*) (i,j,k,fi_min(k,j,i),k=1,nR(j,i)) - enddo - enddo -#endif -#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)-fi_min(ii,iib,iparm)) -#ifdef DEBUG - write (iout,'(4i5,4e15.5)') t,ii,iib,iparm, - & v(t,ii,iib,iparm),entfac(t),fi_min(ii,iib,iparm), - & 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)-fi_min(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(iparm) - 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 -#ifdef DEBUG - write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet, - & maxR*MaxT_h*nParmSet - write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD, - & " WHAM_COMM",WHAM_COMM -#endif - 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))-fi_min(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. - -C Determine the minimum free energies -#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,21) -#endif - call restore_parm(iparm) -#ifdef DEBUG - write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc, - & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc, - & wtor_d,wsccor,wbond -#endif - do ib=1,nT_h(iparm) - 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) -#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,edihcnstr -#endif - -#ifdef SPLITELE - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees - & +wvdwpp*evdw1 - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc - & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#else - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 - & +ft(1)*welec*(ees+evdw1) - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr - & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#endif -c write (iout,*) "i",i," ib",ib, -c & " temp",1.0d0/(1.987d-3*beta_h(ib,iparm))," etot",etot, -c & " entfac",entfac(i) - etot=etot-entfac(i)/beta_h(ib,iparm) - if(etot.lt.potEmin_all(ib,iparm)) potEmin_all(ib,iparm)=etot -c write (iout,*) "efree",etot," potEmin",potEmin_all(ib,iparm) - enddo ! ib - enddo ! iparm - enddo ! i -#ifdef DEBUG - write (iout,*) "The potEmin array before reduction" - do i=1,nParmSet - write (iout,*) "Parameter set",i - do j=1,nT_h(i) - write (iout,*) j,PotEmin_all(j,i) - enddo - enddo - write (iout,*) "potEmin_min",potEmin_min -#endif -#ifdef MPI -C Determine the minimum energes for all parameter sets and temperatures - call MPI_AllReduce(potEmin_all(1,1),potEmin_t_all(1,1), - & maxT_h*nParmSet,MPI_DOUBLE_PRECISION,MPI_MIN,WHAM_COMM,IERROR) - do i=1,nParmSet - do j=1,nT_h(i) - potEmin_all(j,i)=potEmin_t_all(j,i) - enddo - enddo -#endif - potEmin_min=potEmin_all(1,1) - do i=1,nParmSet - do j=1,nT_h(i) - if (potEmin_all(j,i).lt.potEmin_min) - & potEmin_min=potEmin_all(j,i) - enddo - enddo -#ifdef DEBUG - write (iout,*) "The potEmin array" - do i=1,nParmSet - write (iout,*) "Parameter set",i - do j=1,nT_h(i) - write (iout,*) j,PotEmin_all(j,i) - enddo - enddo - write (iout,*) "potEmin_min",potEmin_min -#endif - -#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 - 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) - 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) - if (betaT.ge.beta_h(1,iparm)) then - potEmin=potEmin_all(1,iparm) -c write(iout,*) "first",temper,potEmin - else if (betaT.lt.beta_h(nT_h(iparm),iparm)) then - potEmin=potEmin_all(nT_h(iparm),iparm) -c write (iout,*) "last",temper,potEmin - else - do l=1,nT_h(iparm)-1 - if (betaT.le.beta_h(l,iparm) .and. - & betaT.gt.beta_h(l+1,iparm)) then - potEmin=potEmin_all(l,iparm) -c write (iout,*) "l",l, -c & betaT,1.0d0/(1.987D-3*beta_h(l,iparm)), -c & 1.0d0/(1.987D-3*beta_h(l+1,iparm)),temper,potEmin - exit - endif - enddo - endif -c write (iout,*) ib," PotEmin",potEmin -#ifdef SPLITELE - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees - & +wvdwpp*evdw1 - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc - & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr - 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 -#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 - 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 - weight=dexp(-betaT*(etot-potEmin)+entfac(t)) -#ifdef DEBUG - write (iout,*) "iparm",iparm," t",t," temper",temper, - & " etot",etot," entfac",entfac(t), - & " efree",etot-entfac(t)/betaT," potEmin",potEmin, - & " boltz",-betaT*(etot-potEmin)+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) - potEmin=potEmin_all(ib,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) - potEmin=potEmin_all(ib,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 - betaT=1.0d0/(1.987D-3*(startGridT+i*delta_T)) - if (betaT.ge.beta_h(1,iparm)) then - potEmin=potEmin_all(1,iparm) - else if (betaT.lt.beta_h(nT_h(iparm),iparm)) then - potEmin=potEmin_all(nT_h(iparm),iparm) - else - do l=1,nT_h(iparm)-1 - if (betaT.le.beta_h(l,iparm) .and. - & betaT.gt.beta_h(l+1,iparm)) then - potEmin=potEmin_all(l,iparm) - exit - endif - enddo - endif - 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,*) - 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 - end diff --git a/source/wham/src-NEWSC-NEWCORR/wham_calc1.F.safe b/source/wham/src-NEWSC-NEWCORR/wham_calc1.F.safe deleted file mode 100644 index f51dcc4..0000000 --- a/source/wham/src-NEWSC-NEWCORR/wham_calc1.F.safe +++ /dev/null @@ -1,1195 +0,0 @@ - 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) - integer MaxHdim -c parameter (MaxHdim=200000) - 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" - 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 - 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 - - 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 -#ifdef MPI - do i=1,scount(me1) -#else - do i=1,ntot(islice) -#endif - do j=1,nParmSet - if (potE(i,j).le.potEmin) potEmin=potE(i,j) - enddo - if (q(nQ+1,i).lt.rmsmin) rmsmin=q(nQ+1,i) - if (q(nQ+1,i).gt.rmsmax) rmsmax=q(nQ+1,i) - if (q(nQ+2,i).lt.rgymin) rgymin=q(nQ+2,i) - if (q(nQ+2,i).gt.rgymax) rgymax=q(nQ+2,i) - ind_point(i)=0 - do j=nQ,1,-1 - ind=(q(j,i)-dmin+1.0d-8)/delta - if (j.eq.1) then - ind_point(i)=ind_point(i)+ind - else - ind_point(i)=ind_point(i)+nbin1**(j-1)*ind - endif -c write (iout,*) "i",i," j",j," q",q(j,i)," ind_point", -c & ind_point(i) - call flush(iout) - if (ind_point(i).lt.0 .or. ind_point(i).gt.MaxHdim) then - write (iout,*) "Error - index exceeds range for point",i, - & " q=",q(j,i)," ind",ind_point(i) -#ifdef MPI - write (iout,*) "Processor",me1 - call flush(iout) - call MPI_Abort(MPI_COMM_WORLD, Ierror, Errcode ) -#endif - stop - endif - enddo ! j - if (ind_point(i).gt.tmax) tmax=ind_point(i) - htot(ind_point(i))=htot(ind_point(i))+1 -#ifdef DEBUG - write (iout,*) "i",i,"q",(q(j,i),j=1,nQ)," ind",ind_point(i), - & " htot",htot(ind_point(i)) - call flush(iout) -#endif - enddo ! i - call flush(iout) - - nbin=nbin1**nQ-1 - write (iout,'(a)') "Numbers of counts in Q bins" - do t=0,tmax - if (htot(t).gt.0) then - write (iout,'(i15,$)') t - 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) - potEmin=potEmin_t/2 - rgymin=rgymin_t - rgymax=rgymax_t - rmsmin=rmsmin_t - rmsmax=rmsmax_t - write (iout,*) "potEmin",potEmin -#endif - rmsmin=deltrms*dint(rmsmin/deltrms) - rmsmax=deltrms*dint(rmsmax/deltrms) - rgymin=deltrms*dint(rgymin/deltrgy) - rgymax=deltrms*dint(rgymax/deltrgy) - nbin_rms=(rmsmax-rmsmin)/deltrms - nbin_rgy=(rgymax-rgymin)/deltrgy - write (iout,*) "rmsmin",rmsmin," rmsmax",rmsmax," rgymin",rgymin, - & " rgymax",rgymax," nbin_rms",nbin_rms," nbin_rgy",nbin_rgy - nFi=0 - do i=1,nParmSet - do j=1,nT_h(i) - nFi=nFi+nR(j,i) - enddo - enddo - write (iout,*) "nFi",nFi -! Compute the Boltzmann factor corresponing to restrain potentials in different -! simulations. -#ifdef MPI - do i=1,scount(me1) -#else - do i=1,ntot(islice) -#endif -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,21) -#endif - call restore_parm(iparm) -#ifdef DEBUG - write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc, - & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc, - & wtor_d,wsccor,wbond -#endif - do ib=1,nT_h(iparm) - 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) -#ifdef DEBUG - write (iout,'(3i5,6f5.2,14f12.3)') i,ib,iparm,(ft(l),l=1,6), - & evdw+evdw_t,evdw2,ees,evdw1,ecorr,eel_loc,estr,ebe,escloc, - & etors,etors_d,eello_turn3,eello_turn4,esccor -#endif - -#ifdef SPLITELE - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees - & +wvdwpp*evdw1 - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc - & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#else - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 - & +ft(1)*welec*(ees+evdw1) - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr - & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#endif -#ifdef 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 - v(i,kk,ib,iparm)= - & -beta_h(ib,iparm)*(etot-potEmin+Econstr) -#ifdef DEBUG - write (iout,'(4i5,4e15.5)') i,kk,ib,iparm, - & etot,potEmin,etot-potEmin,v(i,kk,ib,iparm) -#endif - enddo ! kk - enddo ! ib - enddo ! iparm - enddo ! i -! Simple iteration to calculate free energies corresponding to all simulation -! runs. - do iter=1,maxit - -! Compute new free-energy values corresponding to the righ-hand side of the -! equation and their derivatives. - write (iout,*) "------------------------fi" -#ifdef MPI - do t=1,scount(me1) -#else - do t=1,ntot(islice) -#endif - vmax=-1.0d+20 - do i=1,nParmSet - do k=1,nT_h(i) - do l=1,nR(k,i) - vf=v(t,l,k,i)+f(l,k,i) - if (vf.gt.vmax) vmax=vf - enddo - enddo - enddo - denom=0.0d0 - do i=1,nParmSet - do k=1,nT_h(i) - do l=1,nR(k,i) - aux=f(l,k,i)+v(t,l,k,i)-vmax - if (aux.gt.-200.0d0) - & denom=denom+snk(l,k,i,islice)*dexp(aux) - enddo - enddo - enddo - entfac(t)=-dlog(denom)-vmax -#ifdef DEBUG - write (iout,*) t,"vmax",vmax," denom",denom,"entfac",entfac(t) -#endif - enddo - do iparm=1,nParmSet - do iib=1,nT_h(iparm) - do ii=1,nR(iib,iparm) -#ifdef MPI - fi_p(ii,iib,iparm)=0.0d0 - do t=1,scount(me) - fi_p(ii,iib,iparm)=fi_p(ii,iib,iparm) - & +dexp(v(t,ii,iib,iparm)+entfac(t)) -#ifdef DEBUG - write (iout,'(4i5,3e15.5)') t,ii,iib,iparm, - & v(t,ii,iib,iparm),entfac(t),fi_p(ii,iib,iparm) -#endif - enddo -#else - fi(ii,iib,iparm)=0.0d0 - do t=1,ntot(islice) - fi(ii,iib,iparm)=fi(ii,iib,iparm) - & +dexp(v(t,ii,iib,iparm)+entfac(t)) - enddo -#endif - enddo ! ii - enddo ! iib - enddo ! iparm - -#ifdef MPI -#ifdef DEBUG - write (iout,*) "fi before MPI_Reduce me",me,' master',master - do iparm=1,nParmSet - do ib=1,nT_h(nparmset) - write (iout,*) "iparm",iparm," ib",ib - write (iout,*) "beta=",beta_h(ib,iparm) - write (iout,'(8e15.5)') (fi_p(i,ib,iparm),i=1,nR(ib,iparm)) - enddo - enddo -#endif - write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet, - & maxR*MaxT_h*nParmSet - write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD, - & " WHAM_COMM",WHAM_COMM - call MPI_Reduce(fi_p(1,1,1),fi(1,1,1),maxR*MaxT_h*nParmSet, - & MPI_DOUBLE_PRECISION, - & MPI_SUM,Master,WHAM_COMM,IERROR) -#ifdef DEBUG - write (iout,*) "fi after MPI_Reduce nparmset",nparmset - do iparm=1,nParmSet - write (iout,*) "iparm",iparm - do ib=1,nT_h(iparm) - write (iout,*) "beta=",beta_h(ib,iparm) - write (iout,'(8e15.5)') (fi(i,ib,iparm),i=1,nR(ib,iparm)) - enddo - enddo -#endif - if (me1.eq.Master) then -#endif - avefi=0.0d0 - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - fi(i,ib,iparm)=-dlog(fi(i,ib,iparm)) - avefi=avefi+fi(i,ib,iparm) - enddo - enddo - enddo - avefi=avefi/nFi - do iparm=1,nParmSet - write (iout,*) "Parameter set",iparm - do ib =1,nT_h(iparm) - write (iout,*) "beta=",beta_h(ib,iparm) - do i=1,nR(ib,iparm) - fi(i,ib,iparm)=fi(i,ib,iparm)-avefi - enddo - write (iout,'(8f10.5)') (fi(i,ib,iparm),i=1,nR(ib,iparm)) - write (iout,'(8f10.5)') (f(i,ib,iparm),i=1,nR(ib,iparm)) - enddo - enddo - -! Compute the norm of free-energy increments. - finorm=0.0d0 - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - finorm=finorm+dabs(fi(i,ib,iparm)-f(i,ib,iparm)) - f(i,ib,iparm)=fi(i,ib,iparm) - enddo - enddo - enddo - - write (iout,*) 'Iteration',iter,' finorm',finorm - -#ifdef MPI - endif - call MPI_Bcast(f(1,1,1),MaxR*MaxT_h*nParmSet, - & MPI_DOUBLE_PRECISION,Master, - & WHAM_COMM,IERROR) - call MPI_Bcast(finorm,1,MPI_DOUBLE_PRECISION,Master, - & WHAM_COMM,IERROR) -#endif -! Exit, if the increment norm is smaller than pre-assigned tolerance. - if (finorm.lt.fimin) then - write (iout,*) 'Iteration converged' - goto 20 - endif - - enddo ! iter - - 20 continue -! Now, put together the histograms from all simulations, in order to get the -! unbiased total histogram. -#ifdef MPI - do t=0,tmax - hfin_ent_p(t)=0.0d0 - enddo -#else - do t=0,tmax - hfin_ent(t)=0.0d0 - enddo -#endif - write (iout,*) "--------------hist" -#ifdef MPI - do iparm=1,nParmSet - do i=0,nGridT - sumW_p(i,iparm)=0.0d0 - sumE_p(i,iparm)=0.0d0 - sumEbis_p(i,iparm)=0.0d0 - sumEsq_p(i,iparm)=0.0d0 - do j=1,nQ+2 - sumQ_p(j,i,iparm)=0.0d0 - sumQsq_p(j,i,iparm)=0.0d0 - sumEQ_p(j,i,iparm)=0.0d0 - enddo - enddo - enddo - upindE_p=0 -#else - do iparm=1,nParmSet - do i=0,nGridT - sumW(i,iparm)=0.0d0 - sumE(i,iparm)=0.0d0 - sumEbis(i,iparm)=0.0d0 - sumEsq(i,iparm)=0.0d0 - do j=1,nQ+2 - sumQ(j,i,iparm)=0.0d0 - sumQsq(j,i,iparm)=0.0d0 - sumEQ(j,i,iparm)=0.0d0 - enddo - enddo - enddo - upindE=0 -#endif -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) - edihcnstr=0.0d0 - 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 - 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 - 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 -#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 - 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 - weight=dexp(-betaT*(etot-potEmin)+entfac(t)) -#define DEBUG -#ifdef DEBUG - write (iout,*) "iparm",iparm," t",t," betaT",betaT, - & " etot",etot," entfac",entfac(t), - & " weight",weight," ebis",ebis -#endif -#undef DEBUG - 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,*) - 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 - - end diff --git a/source/wham/src-NEWSC-NEWCORR/wham_multparm.F b/source/wham/src-NEWSC-NEWCORR/wham_multparm.F deleted file mode 100644 index 003b6b4..0000000 --- a/source/wham/src-NEWSC-NEWCORR/wham_multparm.F +++ /dev/null @@ -1,277 +0,0 @@ - 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 - call read_general_data(*10) - call flush(iout) - call molread(*10) - call flush(iout) -#ifdef MPI - write (iout,*) "Calling proc_groups" - call proc_groups - write (iout,*) "proc_groups exited" - call flush(iout) -#endif -#ifdef SCALREP - write (iout,*) "1,4 SCSC repulsive interactions sacled down by 10" -#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) - write (iout,*) "Finished READ_EFREE" - call flush(iout) - call read_protein_data(*10) - write (iout,*) "Finished READ_PROTEIN_DATA" - call flush(iout) - if (indpdb.gt.0) then - call promienie - call read_compar - call read_ref_structure(*10) - call proc_cont - call fragment_list - endif - write (iout,*) "Begin read_database" - call flush(iout) - call read_database(*10) - write (iout,*) "Finished read_database" - call flush(iout) - if (separate_parset) nparmset=1 - do islice=1,nslice - if (ntot(islice).gt.0) then -#ifdef MPI - call work_partition(islice,.true.) - write (iout,*) "work_partition OK" - call flush(iout) -#endif - call enecalc(islice,*10) - write (iout,*) "enecalc OK" - call flush(iout) - write (iout,*) "Calling WHAM_calc" - 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-NEWSC-NEWCORR/xdrf b/source/wham/src-NEWSC-NEWCORR/xdrf deleted file mode 120000 index 26825c5..0000000 --- a/source/wham/src-NEWSC-NEWCORR/xdrf +++ /dev/null @@ -1 +0,0 @@ -../../lib/xdrf \ No newline at end of file diff --git a/source/wham/src-NEWSC-NEWCORR/xread.F b/source/wham/src-NEWSC-NEWCORR/xread.F deleted file mode 100644 index ac35de1..0000000 --- a/source/wham/src-NEWSC-NEWCORR/xread.F +++ /dev/null @@ -1,187 +0,0 @@ - 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 diff --git a/source/wham/src-NEWSC/CMakeLists.txt b/source/wham/src-NEWSC/CMakeLists.txt deleted file mode 100755 index aca8eb4..0000000 --- a/source/wham/src-NEWSC/CMakeLists.txt +++ /dev/null @@ -1,298 +0,0 @@ -# -# CMake project file for WHAM single chain version -# - -enable_language (Fortran) - -#================================ -# Set source file lists -#================================ -set(UNRES_WHAM_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 - pinorm.f - printmat.f - rescode.f - setup_var.f - slices.F - store_parm.F - timing.F - wham_calc1.F - readrtns_compar.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 -) - -set(UNRES_WHAM_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 - read_ref_str.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 "-mcmodel=medium -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" ) -endif (Fortran_COMPILER_NAME STREQUAL "ifort") - - -#========================================= -# Add MPI compiler flags -#========================================= -if(UNRES_WITH_MPI) - set(FFLAGS0 "${FFLAGS0} -I${MPIF_INCLUDE_DIRECTORIES}") -endif(UNRES_WITH_MPI) - -set_property(SOURCE ${UNRES_WHAM_SRC0} PROPERTY COMPILE_FLAGS ${FFLAGS0} ) - -#========================================= -# WHAM preprocesor flags -#========================================= - -set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" ) - -#========================================= -# System specific flags -#========================================= -if(${CMAKE_SYSTEM_NAME} MATCHES "Linux") - set(CPPFLAGS "${CPPFLAGS} -DLINUX") -endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux") - -#========================================= -# Compiler specific flags -#========================================= - -if (Fortran_COMPILER_NAME STREQUAL "ifort") - # Add ifort preprocessor flags - set(CPPFLAGS "${CPPFLAGS} -DPGI") -elseif (Fortran_COMPILER_NAME STREQUAL "f95") - # Add new gfortran flags - set(CPPFLAGS "${CPPFLAGS} -DG77") -elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") - # Add old gfortran flags - set(CPPFLAGS "${CPPFLAGS} -DG77") -endif (Fortran_COMPILER_NAME STREQUAL "ifort") - -#========================================= -# Add MPI preprocessor flags -#========================================= -set(CPPFLAGS "${CPPFLAGS} -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_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) - - -#======================================== -# Setting binary name -#======================================== -set(UNRES_WHAM_BIN "wham_${Fortran_COMPILER_NAME}.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 path -set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f PROPERTY COMPILE_FLAGS "${FFLAGS0} -I${CMAKE_CURRENT_SOURCE_DIR}" ) - -#========================================= -# Set full unres CSA sources -#========================================= -set(UNRES_WHAM_SRCS ${UNRES_WHAM_SRC0} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f proc_proc.c) - -#========================================= -# Build the binary -#========================================= -add_executable(UNRES_WHAM_BIN ${UNRES_WHAM_SRCS} ) -set_target_properties(UNRES_WHAM_BIN PROPERTIES OUTPUT_NAME ${UNRES_WHAM_BIN}) - -#set_property(TARGET ${UNRES_BIN} PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin/unres/MD ) -#add_dependencies (${UNRES_BIN} ${UNRES_XDRFLIB}) - -#========================================= -# Link libraries -#========================================= -# link MPI library (libmpich.a) -target_link_libraries( UNRES_WHAM_BIN ${MPIF_LIBRARIES} ) -# link libxdrf.a -target_link_libraries( UNRES_WHAM_BIN xdrf ) - -#========================================= -# TESTS -#========================================= - -#-- Copy all the data files from the test directory into the source directory -#SET(UNRES_TEST_FILES -# ala10.inp -# ) - -#FOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) -# SET (unres_test_dest "${CMAKE_CURRENT_BINARY_DIR}/${UNRES_TEST_FILE}") -# MESSAGE (STATUS " Copying ${UNRES_TEST_FILE} from ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} to ${unres_test_dest}") -# ADD_CUSTOM_COMMAND ( -# TARGET ${UNRES_BIN} -# POST_BUILD -# COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} ${unres_test_dest} -# ) -#ENDFOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) - -#========================================= -# Generate data test files -#========================================= -# test_single_ala.sh -#========================================= - -#FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh -#"#!/bin/sh -#export POT=GB -#export PREFIX=ala10 -#----------------------------------------------------------------------------- -#UNRES_BIN=./${UNRES_BIN} -#----------------------------------------------------------------------------- -#DD=${CMAKE_SOURCE_DIR}/PARAM -#export BONDPAR=$DD/bond.parm -#export THETPAR=$DD/thetaml.5parm -#export ROTPAR=$DD/scgauss.parm -#export TORPAR=$DD/torsion_631Gdp.parm -#export TORDPAR=$DD/torsion_double_631Gdp.parm -#export ELEPAR=$DD/electr_631Gdp.parm -#export SIDEPAR=$DD/sc_GB_opt.1gab_3S_qclass5no310-shan2-sc-16-10-8k -#export FOURIER=$DD/fourier_opt.parm.1igd_hc_iter3_3 -#export SCPPAR=$DD/scp.parm -#export SCCORPAR=$DD/rotcorr_AM1.parm -#export PATTERN=$DD/patterns.cart -#----------------------------------------------------------------------------- -#$UNRES_BIN -#") - -#========================================= -# ala10.inp -#========================================= - -#file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/ala10.inp -#"ala10 unblocked -#SEED=-1111333 MD ONE_LETTER rescale_mode=2 PDBOUT -#nstep=15000 ntwe=100 ntwx=1000 dt=0.1 lang=0 tbf t_bath=300 damax=1.0 & -#reset_moment=1000 reset_vel=1000 MDPDB -#WLONG=1.35279 WSCP=1.59304 WELEC=0.71534 WBOND=1.00000 WANG=1.13873 & -#WSCLOC=0.16258 WTOR=1.98599 WTORD=1.57069 WCORRH=0.42887 WCORR5=0.00000 & -#WCORR6=0.00000 WEL_LOC=0.16036 WTURN3=1.68722 WTURN4=0.66230 WTURN6=0.00000 & -#WVDWPP=0.11371 WHPB=1.00000 & -#CUTOFF=7.00000 WCORR4=0.00000 -#12 -#XAAAAAAAAAAX -# 0 -# 0 -# 90.0000 90.0000 90.0000 90.000 90.000 90.000 90.000 90.000 -# 90.0000 90.0000 -# 180.0000 180.0000 180.0000 180.000 180.000 180.000 180.000 180.000 -# 180.0000 -# 110.0000 110.0000 110.0000 100.000 110.000 100.000 110.000 110.000 -# 110.0000 110.0000 -# -120.0000 -120.0000 -120.000 -120.000 -120.000 -120.000 -120.000 -120.000 -# -120.0000 -120.0000 -#") - - -# Add tests - -#if(NOT UNRES_WITH_MPI) - -# add_test(NAME UNRES_MD_Ala10 COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh ) - -#endif(NOT UNRES_WITH_MPI) diff --git a/source/wham/src-NEWSC/COMMON.ALLPARM b/source/wham/src-NEWSC/COMMON.ALLPARM deleted file mode 100755 index 62d1e47..0000000 --- a/source/wham/src-NEWSC/COMMON.ALLPARM +++ /dev/null @@ -1,99 +0,0 @@ - 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,max_parm),athet_all(2,ntyp,max_parm), - & bthet_all(2,ntyp,max_parm),polthet_all(0:3,ntyp,max_parm), - & gthet_all(3,ntyp,max_parm),theta0_all(ntyp,max_parm), - & sig0_all(ntyp,max_parm),sigc0_all(ntyp,max_parm), - & aa0thet_all(maxthetyp1,maxthetyp1,maxthetyp1,max_parm), - & aathet_all(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1,max_parm), - & bbthet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & ccthet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & ddthet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & eethet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & ffthet_all(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & ggthet_all(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & dsc_all(ntyp1,max_parm),bsc_all(maxlob,ntyp,max_parm), - & censc_all(3,maxlob,ntyp,max_parm), - & gaussc_all(3,3,maxlob,ntyp,max_parm),dsc0_all(ntyp1,max_parm), - & sc_parmin_all(65,ntyp,max_parm), - & v0_all(maxtor,maxtor,max_parm), - & v1_all(maxterm,maxtor,maxtor,max_parm), - & v2_all(maxterm,maxtor,maxtor,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,max_parm), - & v1s_all(2,maxtermd_1,maxtor,maxtor,maxtor,max_parm), - & v2c_all(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor,max_parm), - & v2s_all(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor,max_parm), - & b1_all(2,maxtor,max_parm),b2_all(2,maxtor,max_parm), - & cc_all(2,2,maxtor,max_parm),dd_all(2,2,maxtor,max_parm), - & ee_all(2,2,maxtor,max_parm),ctilde_all(2,2,maxtor,max_parm), - & dtilde_all(2,2,maxtor,max_parm),b1tilde_all(2,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_all(ntyp,ntyp,max_parm),bb_all(ntyp,ntyp,max_parm), - & augm_all(ntyp,ntyp,max_parm),eps_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), - & chipp_all(ntyp,ntyp,max_parm),sigmap1_all(ntyp,ntyp,max_parm), - & sigmap2_all(ntyp,ntyp,max_parm),chis_all(ntyp,ntyp,max_parm), - & alphasur_all(4,ntyp,ntyp,max_parm), - & wstate_all(4,ntyp,ntyp,max_parm), - & nstate_all(ntyp,ntyp,max_parm), - & dhead_all(2,2,ntyp,ntyp,max_parm), - & dtail_all(2,ntyp,ntyp,max_parm), - & epshead_all(ntyp,ntyp,max_parm), - & rborn_all(ntyp,ntyp,max_parm), - & wqdip_all(2,ntyp,ntyp,max_parm),wquad_all(ntyp,ntyp,max_parm), - & alphapol_all(ntyp,ntyp,max_parm), - & alphiso_all(4,ntyp,ntyp,max_parm), - & sigiso1_all(ntyp,ntyp,max_parm), - & sigiso2_all(ntyp,ntyp,max_parm), - & epsintab_all(ntyp,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,max_parm), - & v2sccor_all(maxterm_sccor,3,ntyp,ntyp,max_parm) - integer nlob_all(ntyp1,max_parm),nlor_all(maxtor,maxtor,max_parm), - & nterm_all(maxtor,maxtor,max_parm), - & ntermd1_all(maxtor,maxtor,maxtor,max_parm), - & ntermd2_all(maxtor,maxtor,maxtor,max_parm), - & nbondterm_all(ntyp,max_parm),nthetyp_all(max_parm), - & ithetyp_all(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,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_all,ggthet_all, - & 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,b1_all,b2_all,cc_all,dd_all,ee_all, - & ctilde_all,dtilde_all,b1tilde_all,app_all,bpp_all,ael6_all, - & ael3_all,aad_all,bad_all,aa_all,bb_all,augm_all, - & eps_all,sigma_all,r0_all,chi_all,chipp_all,sigmap1_all, - & sigmap2_all, - & chis_all,alphasur_all,wstate_all,dhead_all,dtail_all, - & epshead_all, - & rborn_all,wqdip_all,wquad_all,alphapol_all,alphiso_all, - & sigiso1_all, - & sigiso2_all,epsintab_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,nstate_all diff --git a/source/wham/src-NEWSC/COMMON.CHAIN b/source/wham/src-NEWSC/COMMON.CHAIN deleted file mode 100755 index 07dd87e..0000000 --- a/source/wham/src-NEWSC/COMMON.CHAIN +++ /dev/null @@ -1,8 +0,0 @@ - integer nres,nres0,nsup,nstart_sup,nend_sup,nstart_seq,ishift_pdb - double precision c,cref,dc,xloc,xrot,dc_norm,t,r,prod,rt - 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),nsup,nstart_sup,nend_sup, - & nstart_seq,ishift_pdb diff --git a/source/wham/src-NEWSC/COMMON.COMPAR b/source/wham/src-NEWSC/COMMON.COMPAR deleted file mode 100755 index eb59ea4..0000000 --- a/source/wham/src-NEWSC/COMMON.COMPAR +++ /dev/null @@ -1,39 +0,0 @@ - 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-NEWSC/COMMON.CONTACTS1 b/source/wham/src-NEWSC/COMMON.CONTACTS1 deleted file mode 100755 index 04affa9..0000000 --- a/source/wham/src-NEWSC/COMMON.CONTACTS1 +++ /dev/null @@ -1,5 +0,0 @@ - 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-NEWSC/COMMON.CONTROL b/source/wham/src-NEWSC/COMMON.CONTROL deleted file mode 100755 index 1178504..0000000 --- a/source/wham/src-NEWSC/COMMON.CONTROL +++ /dev/null @@ -1,10 +0,0 @@ - integer iscode,indpdb,outpdb,outmol2,icomparfunc,pdbint, - & ensembles,constr_dist - logical refstr,pdbref,punch_dist,print_rms,caonly,verbose, - & merge_helices,bxfile,cxfile,histfile,entfile,zscfile, - & rmsrgymap,with_dihed_constr,check_conf,histout,energy_dec - 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,with_dihed_constr,check_conf,histout,constr_dist, - & energy_dec diff --git a/source/wham/src-NEWSC/COMMON.CONTROL.org b/source/wham/src-NEWSC/COMMON.CONTROL.org deleted file mode 100755 index 7dc2298..0000000 --- a/source/wham/src-NEWSC/COMMON.CONTROL.org +++ /dev/null @@ -1,9 +0,0 @@ - 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-NEWSC/COMMON.EMP b/source/wham/src-NEWSC/COMMON.EMP deleted file mode 100755 index 5a39536..0000000 --- a/source/wham/src-NEWSC/COMMON.EMP +++ /dev/null @@ -1,126 +0,0 @@ -c! Variable Declarations -c! Charge of i-th residue, charge of j-th residue,... - INTEGER Qi, Qj, Qij, ii, jj, itypi, itypj - -c! STUFF FROM EMOMO - -c! why do *I* have to declare those guys, when it is used throughout the whole code... - REAL*8 evdw, evdw_p, evdw_m - double precision xi, yi, zi, ctail(3,2), chead(3,2) -c! FOLLOWING ARE ***NOT*** in common block!!! -c! They are here just for their declarations - REAL*8 ecl,elj,equad,epol - INTEGER istate -c! intermediates - REAL*8 c1, c2, fac, pom -c! switch in the selector choosing which electrostatic energy/gradient function to call - INTEGER isel -c! sigma factors - REAL*8 sig, sig0ij, sig1, sig2 -c! intermediates related to distance - REAL*8 rij_shift, rrij, R1, R2, RR1, RR2 -c! intermediates related to angles - REAL*8 sinth1sq, sinth2sq -c! intermediates of Fgb - REAL*8 fgb, ee, ee1, ee2, eps0, pis - -c! squares of om1, om2 and om12 (those hold cosines of angles -c! theta) - REAL*8 sqom1, sqom2, sqom12 - -c! Geometry and general stuff -c! a12sq = ai*aj from fgb which is present in Egbpol/Fgbpol, -c! Epol/Gpol and others, ee is an intermediate. -c! three dimensions for X, Y and Z Cartesians - REAL*8 a12sq - -c! square distance and cartesian distances of polar/charged heads of sidechains - REAL*8 Rhead, Rhead_distance(3), Rhead_sq -c! square distance and cartesian distances of tail(hydrophobic centre of interaction) -c! of a given pair of sidechains - REAL*8 Rtail, Rtail_distance(3) -c! intermediates used in dXhead/dXtail - REAL*8 erhead(3), ertail(3), facd1, facd2, erdxi, erdxj - -c! unit vectors used to calculate R's - REAL*8 d1sq, d2sq, d1d2 - REAL*8 d1, d2 - -c! intermediates (hold different meanining in different places) - REAL*8 bat, hawk, eagle, condor, sparrow, rosella - REAL*8 tuna(3) - -c! holds 1/eps_in - 1/eps_out which appears in EGBpol Makowski et al JPCB 2011 -c! p. 6122 - REAL*8 eps_inout_fac, eps_in - -c! DERIVATIVES -c! intermediates - Real*8 dFdR, dFdL, dFdOM1, dFdOM2, dFdOM12 -c! Kronecker Delta used for dXhead/dXtail derivatives - Real*8 kro_delta -c! Gcl - REAL*8 Gelconst - REAL*8 dGCLdR, dGCLdOM1, dGCLdOM2, dGCLdOM12 - -c! Ggbpol -c! energy - REAL*8 Egb, dGGBdFGB, dGGBdR - REAL*8 dFGBdR, alphapol1, alphapol2 - -c! Gpol - REAL*8 fgb1, fgb2 - REAL*8 dPOLdOM1, dPOLdOM2, dPOLdR1, dPOLdR2 - REAL*8 dFGBdOM1, dFGBdOM2, dFGBdR1, dFGBdR2 - REAL*8 dPOLdFGB1, dPOLdFGB2, MomoFac1, MomoFac2 - REAL*8 erhead_tail(3,2) - -c! Gisocav - REAL*8 Fisocav, dGCVdR -c! alpha parameters for Fisocav/Gisocav - REAL*8 al1, al2, al3, al4, csig - -c! Gcav -c! energy - REAL*8 Fcav -c! alphas from the equation - REAL*8 b1, b2, b3, b4 -c! intermediates - Real*8 chif, lambf, chilambf - REAL*8 top, bot, dtop, dbot, botsq - REAL*8 chis1, chis2, chis12 -c! final value - REAL*8 dCAVdOM1, dCAVdOM2, dCAVdOM12 - -c! Gquad stuff -c! intermediates - REAL*8 wqd, w1, w2, beta1 -c! final value - REAl*8 dQUADdR, dQUADdOM1, dQUADdOM2, dQUADdOM12 - -c! Glj -c! parameter, radial derivative - REAL*8 eps_head, dGLJdR - -c! Sum of states - REAL*8 BetaT, eheadtail, weightbol, sumweight -c! this thing holds intermediates and final value -c! (dimensions, gvdw(c/x)(i/j),intermediate(1) or final(2)) - REAL*8 gheadtail(3,4,2) - -c! Now Commonize what we need to - COMMON /emp/ Qi, Qj, Qij, ii, jj, itypi, itypj, xi, yi, zi - & , sqom1, sqom2, sqom12, chead, ctail - & , al1, al2, al3, al4 - & , b1, b2, b3, b4 - & , Rhead, Rhead_distance, Rtail, Rtail_distance - & , R1, R2, RR1, RR2 - & , d1sq, d2sq, d1, d2, d1d2 - & , eps_inout_fac, eps_in, wqd, eps_head, a12sq - & , chis1, chis2, chis12, sig1, sig2, sig0ij - & , BetaT - & , dFdR, dFdL, dFdOM1, dFdOM2, dFdOM12 - & , dCAVdOM1, dCAVdOM2, dCAVdOM12 - & , dGCLdOM1, dGCLdOM2, dGCLdOM12 - & , dPOLdOM1, dPOLdOM2 - & , dQUADdR, dQUADdOM1, dQUADdOM2, dQUADdOM12 \ No newline at end of file diff --git a/source/wham/src-NEWSC/COMMON.ENEPS b/source/wham/src-NEWSC/COMMON.ENEPS deleted file mode 100755 index eaf002e..0000000 --- a/source/wham/src-NEWSC/COMMON.ENEPS +++ /dev/null @@ -1,3 +0,0 @@ - double precision eneps_temp(2,nntyp) - integer n_ene - common /weightder/ eneps_temp,n_ene diff --git a/source/wham/src-NEWSC/COMMON.ENERGIES b/source/wham/src-NEWSC/COMMON.ENERGIES deleted file mode 100755 index 2d40a95..0000000 --- a/source/wham/src-NEWSC/COMMON.ENERGIES +++ /dev/null @@ -1,4 +0,0 @@ - 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-NEWSC/COMMON.FREE b/source/wham/src-NEWSC/COMMON.FREE deleted file mode 100755 index 3e378ca..0000000 --- a/source/wham/src-NEWSC/COMMON.FREE +++ /dev/null @@ -1,15 +0,0 @@ - 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),delta,deltrms,deltrgy,fimin, - & f(maxR,maxT_h,max_parm),beta_h(MaxT_h,max_parm) - double precision delta_T,startGridT - 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) - integer nGridT - logical replica(max_parm),umbrella(max_parm),read_iset(max_parm) - common /wham/ Kh,q0,f,beta_h,delta,deltrms,deltrgy,delta_T, - & startGridT,fimin,snk,nR, - & nRR,nT_h,nQ,stot,nparmset,maxit,rescale_mode,replica,umbrella, - & read_iset,totraj,hamil_rep,separate_parset,iparmprint,myparm, - & nGridT diff --git a/source/wham/src-NEWSC/COMMON.IOUNITS b/source/wham/src-NEWSC/COMMON.IOUNITS deleted file mode 100755 index 23783bb..0000000 --- a/source/wham/src-NEWSC/COMMON.IOUNITS +++ /dev/null @@ -1,51 +0,0 @@ -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 - 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 - 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 - common /parfiles/ thetname,rotname,torname,tordname,bondname, - & fouriername,elename,sidename,scpname,sccorname,patname - 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-NEWSC/COMMON.MPI b/source/wham/src-NEWSC/COMMON.MPI deleted file mode 100755 index 037c1c9..0000000 --- a/source/wham/src-NEWSC/COMMON.MPI +++ /dev/null @@ -1,8 +0,0 @@ - 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-NEWSC/COMMON.OBCINKA b/source/wham/src-NEWSC/COMMON.OBCINKA deleted file mode 100755 index e0d9c61..0000000 --- a/source/wham/src-NEWSC/COMMON.OBCINKA +++ /dev/null @@ -1,3 +0,0 @@ - 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-NEWSC/COMMON.PEPTCONT b/source/wham/src-NEWSC/COMMON.PEPTCONT deleted file mode 100755 index 59e05dd..0000000 --- a/source/wham/src-NEWSC/COMMON.PEPTCONT +++ /dev/null @@ -1,7 +0,0 @@ - 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-NEWSC/COMMON.PROT b/source/wham/src-NEWSC/COMMON.PROT deleted file mode 100755 index 054ec47..0000000 --- a/source/wham/src-NEWSC/COMMON.PROT +++ /dev/null @@ -1,2 +0,0 @@ - integer ntot(maxslice),isampl(max_parm),nslice - common /protein/ ntot,isampl,nslice diff --git a/source/wham/src-NEWSC/COMMON.PROTFILES b/source/wham/src-NEWSC/COMMON.PROTFILES deleted file mode 100755 index 3287326..0000000 --- a/source/wham/src-NEWSC/COMMON.PROTFILES +++ /dev/null @@ -1,10 +0,0 @@ - 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-NEWSC/COMMON.VAR b/source/wham/src-NEWSC/COMMON.VAR deleted file mode 100755 index 2b11894..0000000 --- a/source/wham/src-NEWSC/COMMON.VAR +++ /dev/null @@ -1,17 +0,0 @@ -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, - & xxtab,yytab,zztab,tauangle,omicron - common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), - & omicron(2,maxres),tauangle(3,maxres), - & vbld(2*maxres), - & costtab(maxres), sinttab(maxres), cost2tab(maxres), - & sint2tab(maxres),xxtab(maxres),yytab(maxres), - & zztab(maxres), - & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar -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-NEWSC/DIMENSIONS b/source/wham/src-NEWSC/DIMENSIONS deleted file mode 100755 index 4d9279d..0000000 --- a/source/wham/src-NEWSC/DIMENSIONS +++ /dev/null @@ -1,142 +0,0 @@ -******************************************************************************** -* 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=400) -C Appr. max. number of interaction sites - integer maxres2 - 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 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=20,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 - parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) -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) diff --git a/source/wham/src-NEWSC/DIMENSIONS.COMPAR b/source/wham/src-NEWSC/DIMENSIONS.COMPAR deleted file mode 100755 index 911bd4e..0000000 --- a/source/wham/src-NEWSC/DIMENSIONS.COMPAR +++ /dev/null @@ -1,25 +0,0 @@ -****************************************************************** -* -* 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-NEWSC/DIMENSIONS.FREE b/source/wham/src-NEWSC/DIMENSIONS.FREE deleted file mode 100755 index 5f1a041..0000000 --- a/source/wham/src-NEWSC/DIMENSIONS.FREE +++ /dev/null @@ -1,14 +0,0 @@ - integer Max_Parm - integer MaxQ,MaxQ1 - integer MaxR,MaxT_h - integer MaxSlice - parameter (Max_Parm=1) - parameter (MaxQ=4,MaxQ1=MaxQ+2) - parameter(MaxR=1,MaxT_h=32) - parameter(MaxSlice=40) - integer MaxN - parameter (MaxN=100) - integer MaxPrintConf - parameter (MaxPrintConf=1000) - integer Max_GridT - parameter (Max_GridT=400) diff --git a/source/wham/src-NEWSC/DIMENSIONS.FREE.old b/source/wham/src-NEWSC/DIMENSIONS.FREE.old deleted file mode 100755 index e579dd1..0000000 --- a/source/wham/src-NEWSC/DIMENSIONS.FREE.old +++ /dev/null @@ -1,12 +0,0 @@ - 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-NEWSC/DIMENSIONS.ZSCOPT b/source/wham/src-NEWSC/DIMENSIONS.ZSCOPT deleted file mode 100755 index 0d8e64b..0000000 --- a/source/wham/src-NEWSC/DIMENSIONS.ZSCOPT +++ /dev/null @@ -1,40 +0,0 @@ - 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=21,maxprot=7,maxclass=5000) - 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 = 2048) -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-NEWSC/Makefile b/source/wham/src-NEWSC/Makefile deleted file mode 100755 index 8b92f57..0000000 --- a/source/wham/src-NEWSC/Makefile +++ /dev/null @@ -1,89 +0,0 @@ -INSTALL_DIR = /users/local/mpi64/mpich-1.2.7p1 -BIN = /users/adam/bin -FC= ifort -OPT = -mcmodel=medium -O3 -ip -w -#OPT = -mcmodel=medium -g -CA -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 \ - 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 - -GABs: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCALREP -GABs: ${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_MM-KN-DEBUG-scalrep.exe - -GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -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_MM-KN-DEBUG.exe - -E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -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_MM-PH.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-NEWSC/Makefile-pgi b/source/wham/src-NEWSC/Makefile-pgi deleted file mode 100755 index 40cc442..0000000 --- a/source/wham/src-NEWSC/Makefile-pgi +++ /dev/null @@ -1,74 +0,0 @@ -BIN = /users/adam/ZSCOREZ/bin -CC = cc -FC = mpif90 -#FC = ifc -OPT = -fast -pc 64 -tp p6 -Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 -#FFLAGS = ${OPT} -g -c -I. -I./include_unres -#FFLAGS = ${OPT} -c -C -g -I. -I./include_unres -FFLAGS = ${OPT} -c -I. -I./include_unres -LIBS = -L../../MEY_MD/src_Tc/xdrf -lxdrf -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV -CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} -Wl,-Bstatic ${objects} ${objects_compar} cinfo.o \ - ${LIBS} -o ${BIN}/wham_multparm-T-sccor - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC/Makefile1_jump b/source/wham/src-NEWSC/Makefile1_jump deleted file mode 100755 index 1df1586..0000000 --- a/source/wham/src-NEWSC/Makefile1_jump +++ /dev/null @@ -1,60 +0,0 @@ -BIN = ../bin -CC = cc -FC = mpxlf90 -qfixed -w -OPT = -q64 -FFLAGS = -c ${OPT} -O3 -I./include_unres -LIBS = xdrf/libxdrf.o xdrf/ftocstr.o -CPPFLAGS = -WF,-DMPI -WF,-DAIX -WF,-DUNRES -WF,-DSPLITELE -WF,-DPROCOR -WF,-DISNAN - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 \ - rescode.o \ - setup_var.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ - ${LIBS} -o ${BIN}/wham_multparm1-T-procor - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC/Makefile_MPICH_ifort b/source/wham/src-NEWSC/Makefile_MPICH_ifort deleted file mode 100755 index 8b92f57..0000000 --- a/source/wham/src-NEWSC/Makefile_MPICH_ifort +++ /dev/null @@ -1,89 +0,0 @@ -INSTALL_DIR = /users/local/mpi64/mpich-1.2.7p1 -BIN = /users/adam/bin -FC= ifort -OPT = -mcmodel=medium -O3 -ip -w -#OPT = -mcmodel=medium -g -CA -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 \ - 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 - -GABs: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCALREP -GABs: ${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_MM-KN-DEBUG-scalrep.exe - -GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ - -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -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_MM-KN-DEBUG.exe - -E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -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_MM-PH.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-NEWSC/Makefile_jubl b/source/wham/src-NEWSC/Makefile_jubl deleted file mode 100755 index 5f37ee7..0000000 --- a/source/wham/src-NEWSC/Makefile_jubl +++ /dev/null @@ -1,95 +0,0 @@ -CPPFLAGS = -WF,-DOLD_GINV \ - -WF,-DUNRES -WF,-DMPI \ - -WF,-DSPLITELE -WF,-DISNAN \ - -WF,-DAIX -WF,-DLANG0 -WF,-DPROCOR -WF,-DJUBL -#-WF,-DNOXDR -#-WF,-DPROCOR -## -DMOMENT -#-DCO_BIAS -#-DCRYST_TOR -#-DDEBUG - -BGLSYS = /bgl/BlueLight/ppcfloor/bglsys - -CC = /usr/bin/blrts_xlc -CPPC = /usr/bin/blrts_xlc -FC = /usr/bin/blrts_xlf90 -#-pg -g - -# try -qarch=440 first, then use -qarch=440d for 2nd FPU later on -# (SIMDization requires at least -O3) -# use -qlist -qsource with 440d and look for Parallel ASM instructions. -# -OPT= -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 -qfixed -w -qnosave -CFLAGS= -O3 -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 -FFLAGS= -c -O3 ${OPT} -I./include_unres -# -LIBS_MPI = -lmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts -LIBSF_MPI = -lmpich.rts -lfmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts - -FFLAGS1 = -c ${OPT} -O2 -FFLAGS2 = -c ${OPT} -O -FFLAGSE = -c ${OPT} -O4 - - -BIN = ${HOME}/UNRES/bin/wham_multparm-T-procor.rts -LIBS = ${LIBSF_MPI} ../src_Tc/xdrf/libxdrf.a -#LIBS = ${LIBSF_MPI} - -ARCH = LINUX -PP = /lib/cpp -P - -all: unresCSA - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - - -objects = \ - wham_multparm.o \ - cxread.o \ - enecalc.o \ - energy_p_new.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_ensemble.o \ - matmult.o \ - misc.o \ - mygetenv.o \ - parmread.o \ - pinorm.o \ - printmat.o \ - rescode.o \ - setup_var.o \ - store_parm.o \ - timing.o \ - wham_calc.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 - - -unresCSA: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo | true - ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${objects} ${objects_compar} cinfo.o ${LIBS} -o ${BIN} - - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC/Makefile_jump b/source/wham/src-NEWSC/Makefile_jump deleted file mode 100755 index e79c218..0000000 --- a/source/wham/src-NEWSC/Makefile_jump +++ /dev/null @@ -1,69 +0,0 @@ -BIN = ../bin -CC = cc -CFLAGS = -DAIX -c -FC = mpxlf90 -qlistopt -qfixed -w -OPT = -q64 -FFLAGS = -c ${OPT} -O3 -I./include_unres -#FFLAGS = -c ${OPT} -g -C -I./include_unres -LIBS = xdrf/libxdrf.o xdrf/ftocstr.o -CPPFLAGS = -WF,-DMPI -WF,-DAIX -WF,-DUNRES -WF,-DSPLITELE -WF,-DPROCOR -WF,-DISNAN - -.SUFFIXES: .F -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -.SUFFIXES: .c -.c.o: - ${CC} ${CFLAGS} $*.c - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 \ - 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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ - ${LIBS} -o ${BIN}/wham_multparm-T-procor-c1 - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC/Makefile_matrix b/source/wham/src-NEWSC/Makefile_matrix deleted file mode 100755 index d16bc8c..0000000 --- a/source/wham/src-NEWSC/Makefile_matrix +++ /dev/null @@ -1,67 +0,0 @@ -INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh -BIN = ../bin -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 -CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ - ${LIBS} -static-intel -o ${BIN}/wham_multparm-ham_rep - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC/Makefile_matrix_PGI b/source/wham/src-NEWSC/Makefile_matrix_PGI deleted file mode 100755 index bb4982d..0000000 --- a/source/wham/src-NEWSC/Makefile_matrix_PGI +++ /dev/null @@ -1,76 +0,0 @@ -INSTALL_DIR = /users/software/mpich-1.2.7p1_pgi_9.0_64bit_ssh -BIN = ../bin -CC = cc -FC = pgf90 -#FC = ifc -#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 -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV -CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o -Bstatic_pgi \ - ${LIBS} -o ${BIN}/wham_multparm-hamrep-sep - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC/Makefile_matrix_PGI-SCT-oldparm b/source/wham/src-NEWSC/Makefile_matrix_PGI-SCT-oldparm deleted file mode 100755 index 82001ca..0000000 --- a/source/wham/src-NEWSC/Makefile_matrix_PGI-SCT-oldparm +++ /dev/null @@ -1,76 +0,0 @@ -INSTALL_DIR = /users/software/mpich-1.2.7p1_pgi_9.0_64bit_ssh -BIN = ../bin -CC = cc -FC = pgf90 -#FC = ifc -OPT = -mcmodel=medium -Mlarge_arrays -fast -pc 64 -tp amd64 -#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 -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV -CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DCRYST_BOND -DCRYST_SC -DCRYST_THETA -DFUNCT -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o -Bstatic_pgi \ - ${LIBS} -o ${BIN}/wham_multparm-OPTERON-SCT-sccor-oldparm - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC/Makefile_matrix_PGI-SCTF-oldparm b/source/wham/src-NEWSC/Makefile_matrix_PGI-SCTF-oldparm deleted file mode 100755 index 66ebf03..0000000 --- a/source/wham/src-NEWSC/Makefile_matrix_PGI-SCTF-oldparm +++ /dev/null @@ -1,76 +0,0 @@ -INSTALL_DIR = /users/software/mpich-1.2.7p1_pgi_9.0_64bit_ssh -BIN = ../bin -CC = cc -FC = pgf90 -#FC = ifc -OPT = -mcmodel=medium -Mlarge_arrays -fast -pc 64 -tp amd64 -#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 -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV -CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DCRYST_BOND -DCRYST_SC -DCRYST_THETA -DFUNCTH -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} -Bstatic_pgi cinfo.o \ - ${LIBS} -o ${BIN}/wham_multparm-OPTERON-SCTF-sccor-oldparm - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC/Makefile_matrix_PGI-oldparm b/source/wham/src-NEWSC/Makefile_matrix_PGI-oldparm deleted file mode 100755 index 1c9d56b..0000000 --- a/source/wham/src-NEWSC/Makefile_matrix_PGI-oldparm +++ /dev/null @@ -1,76 +0,0 @@ -INSTALL_DIR = /usr/local/mpich-1.2.7p1_pgi64-6.2-3_ssh -BIN = ../bin -CC = cc -FC = pgf90 -#FC = ifc -OPT = -mcmodel=medium -Mlarge_arrays -fast -pc 64 -tp amd64 -#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 -#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV -CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DCRYST_BOND -DCRYST_SC -DCRYST_THETA -#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI -#CPPFLAGS = -DMPI -DLINUX -DUNRES - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} $*.F - -all: make_dbase - -objects = \ - wham_multparm.o \ - bxread.o \ - xread.o \ - cxread.o \ - enecalc1.o \ - energy_p_new.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 - -make_dbase: ${objects} ${objects_compar} - cc -o compinfo compinfo.c - ./compinfo - ${FC} -c ${FFLAGS} cinfo.f - $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ - ${LIBS} -o ${BIN}/wham_multparm-OPTERON-SCTF-sccor-oldparm - -clean: - /bin/rm *.o diff --git a/source/wham/src-NEWSC/a.sh b/source/wham/src-NEWSC/a.sh deleted file mode 100755 index 00b1548..0000000 --- a/source/wham/src-NEWSC/a.sh +++ /dev/null @@ -1,9 +0,0 @@ -a=1 -echo $a -while [ $a -lt 10 ] -do - a=`expr $a + 1` -done -echo $a -b=`expr $a / 5` -echo a=$a b=$b diff --git a/source/wham/src-NEWSC/angnorm.f b/source/wham/src-NEWSC/angnorm.f deleted file mode 100755 index 2d17942..0000000 --- a/source/wham/src-NEWSC/angnorm.f +++ /dev/null @@ -1,439 +0,0 @@ - subroutine add_angpair(ici,icj,nang_pair,iang_pair) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - integer ici,icj,nang_pair,iang_pair(2,maxres) - integer i,ian1,ian2 -c write (iout,*) "add_angpair: ici",ici," icj",icj, -c & " nang_pair",nang_pair - ian1=ici+2 - if (ian1.lt.4 .or. ian1.gt.nres) return - ian2=icj+2 -c write (iout,*) "ian1",ian1," ian2",ian2 - if (ian2.lt.4 .or. ian2.gt.nres) return - do i=1,nang_pair - if (ian1.eq.iang_pair(1,i) .and. ian2.eq.iang_pair(2,i)) return - enddo - nang_pair=nang_pair+1 - iang_pair(1,nang_pair)=ian1 - iang_pair(2,nang_pair)=ian2 - return - end -c------------------------------------------------------------------------- - subroutine angnorm(jfrag,ishif1,ishif2,diffang_max,angn,fract, - & lprn) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'DIMENSIONS.COMPAR' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.COMPAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - double precision pinorm,deltang - logical lprn - if (lprn) write (iout,'(80(1h*))') - angn=0.0d0 - nn = 0 - fract = 1.0d0 - npart = npiece(jfrag,1) - nn4 = nstart_sup+3 - nne = min0(nend_sup,nres) - if (lprn) write (iout,*) "nn4",nn4," nne",nne - do i=1,npart - nbeg = ifrag(1,i,jfrag) + 3 - ishif1 - if (nbeg.lt.nn4) nbeg=nn4 - nend = ifrag(2,i,jfrag) + 1 - ishif2 - if (nend.gt.nne) nend=nne - if (nend.ge.nbeg) then - nn = nn + nend - nbeg + 1 - if (lprn) write (iout,*) "i=",i," nbeg",nbeg," nend",nend, - & " nn",nn," ishift1",ishif1," ishift2",ishif2 - if (lprn) write (iout,*) "angles" - longest=0 - ll = 0 - do j=nbeg,nend -c deltang = pinorm(phi(j)-phi_ref(j+ishif1)) - deltang=spherang(phi_ref(j+ishif1),theta_ref(j-1+ishif1), - & theta_ref(j+ishif1),phi(j),theta(j-1),theta(j)) - if (dabs(deltang).gt.diffang_max) then - if (ll.gt.longest) longest = ll - ll = 0 - else - ll=ll+1 - endif - if (ll.gt.longest) longest = ll - if (lprn) write (iout,'(i5,3f10.5)')j,rad2deg*phi(j), - & rad2deg*phi_ref(j+ishif1),rad2deg*deltang - angn=angn+dabs(deltang) - enddo - longest=longest+3 - ff = dfloat(longest)/dfloat(nend - nbeg + 4) - if (lprn) write (iout,*)"segment",i," longest fragment within", - & diffang_max*rad2deg,":",longest," fraction",ff - if (ff.lt.fract) fract = ff - endif - enddo - if (nn.gt.0) then - angn = angn/nn - else - angn = dwapi - endif - if (lprn) write (iout,*) "nn",nn," norm",rad2deg*angn, - & " fract",fract - return - end -c------------------------------------------------------------------------- - subroutine angnorm2(jfrag,ishif1,ishif2,ncont,icont,lprn, - & diffang_max,anorm,fract) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'DIMENSIONS.COMPAR' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.COMPAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - integer ncont,icont(2,ncont),longest - double precision anorm,diffang_max,fract - integer npiece_c,ifrag_c(2,maxpiece),ishift_c(maxpiece) - double precision pinorm - logical lprn - if (lprn) write (iout,'(80(1h*))') -c -c Determine the segments for which angles will be compared -c - nn4 = nstart_sup+3 - nne = min0(nend_sup,nres) - if (lprn) write (iout,*) "nn4",nn4," nne",nne - npart=npiece(jfrag,1) - npiece_c=0 - do i=1,npart -c write (iout,*) "i",i," ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) - if (icont(1,ncont).lt.ifrag(1,i,jfrag) .or. - & icont(1,1).gt.ifrag(2,i,jfrag)) goto 11 - jstart=1 - do while (jstart.lt.ncont .and. - & icont(1,jstart).lt.ifrag(1,i,jfrag)) -c write (iout,*) "jstart",jstart," icont",icont(1,jstart), -c & " ifrag",ifrag(1,i,jfrag) - jstart=jstart+1 - enddo -c write (iout,*) "jstart",jstart," icont",icont(1,jstart), -c & " ifrag",ifrag(1,i,jfrag) - if (icont(1,jstart).lt.ifrag(1,i,jfrag)) goto 11 - npiece_c=npiece_c+1 - ic1=icont(1,jstart) - ifrag_c(1,npiece_c)=icont(1,jstart) - jend=ncont - do while (jend.gt.1 .and. icont(1,jend).gt.ifrag(2,i,jfrag)) -c write (iout,*) "jend",jend," icont",icont(1,jend), -c & " ifrag",ifrag(2,i,jfrag) - jend=jend-1 - enddo -c write (iout,*) "jend",jend," icont",icont(1,jend), -c & " ifrag",ifrag(2,i,jfrag) - ic2=icont(1,jend) - ifrag_c(2,npiece_c)=icont(1,jend)+1 - ishift_c(npiece_c)=ishif1 -c write (iout,*) "1: i",i," jstart:",jstart," jend",jend, -c & " ic1",ic1," ic2",ic2, -c & " ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) - 11 continue - if (ncont.eq.1 .or. icont(2,ncont).gt.icont(2,1)) then - idi=1 - else - idi=-1 - endif -c write (iout,*) "idi",idi - if (idi.eq.1) then - if (icont(2,1).gt.ifrag(2,i,jfrag) .or. - & icont(2,ncont).lt.ifrag(1,i,jfrag)) goto 12 - jstart=1 - do while (jstart.lt.ncont .and. - & icont(2,jstart).lt.ifrag(1,i,jfrag)) -c write (iout,*) "jstart",jstart," icont",icont(2,jstart), -c & " ifrag",ifrag(1,i,jfrag) - jstart=jstart+1 - enddo -c write (iout,*) "jstart",jstart," icont",icont(2,jstart), -c & " ifrag",ifrag(1,i,jfrag) - if (icont(2,jstart).lt.ifrag(1,i,jfrag)) goto 12 - npiece_c=npiece_c+1 - ic1=icont(2,jstart) - ifrag_c(2,npiece_c)=icont(2,jstart)+1 - jend=ncont - do while (jend.gt.1 .and. icont(2,jend).gt.ifrag(2,i,jfrag)) -c write (iout,*) "jend",jend," icont",icont(2,jend), -c & " ifrag",ifrag(2,i,jfrag) - jend=jend-1 - enddo -c write (iout,*) "jend",jend," icont",icont(2,jend), -c & " ifrag",ifrag(2,i,jfrag) - else if (idi.eq.-1) then - if (icont(2,ncont).gt.ifrag(2,i,jfrag) .or. - & icont(2,1).lt.ifrag(1,i,jfrag)) goto 12 - jstart=ncont - do while (jstart.gt.ncont .and. - & icont(2,jstart).lt.ifrag(1,i,jfrag)) -c write (iout,*) "jstart",jstart," icont",icont(2,jstart), -c & " ifrag",ifrag(1,i,jfrag) - jstart=jstart-1 - enddo -c write (iout,*) "jstart",jstart," icont",icont(2,jstart), -c & " ifrag",ifrag(1,i,jfrag) - if (icont(2,jstart).lt.ifrag(1,i,jfrag)) goto 12 - npiece_c=npiece_c+1 - ic1=icont(2,jstart) - ifrag_c(2,npiece_c)=icont(2,jstart)+1 - jend=1 - do while (jend.lt.ncont .and. - & icont(2,jend).gt.ifrag(2,i,jfrag)) -c write (iout,*) "jend",jend," icont",icont(2,jend), -c & " ifrag",ifrag(2,i,jfrag) - jend=jend+1 - enddo -c write (iout,*) "jend",jend," icont",icont(2,jend), -c & " ifrag",ifrag(2,i,jfrag) - endif - ic2=icont(2,jend) - if (ic2.lt.ic1) then - iic = ic1 - ic1 = ic2 - ic2 = iic - endif -c write (iout,*) "2: i",i," ic1",ic1," ic2",ic2, -c & " jstart:",jstart," jend",jend, -c & " ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) - ifrag_c(1,npiece_c)=ic1 - ifrag_c(2,npiece_c)=ic2+1 - ishift_c(npiece_c)=ishif2 - 12 continue - enddo - if (lprn) then - write (iout,*) "Before merge: npiece_c",npiece_c - do i=1,npiece_c - write (iout,*) ifrag_c(1,i),ifrag_c(2,i),ishift_c(i) - enddo - endif -c -c Merge overlapping segments (e.g., avoid splitting helices) -c - i=1 - do while (i .lt. npiece_c) - if (ishift_c(i).eq.ishift_c(i+1) .and. - & ifrag_c(2,i).gt.ifrag_c(1,i+1)) then - ifrag_c(2,i)=ifrag_c(2,i+1) - do j=i+1,npiece_c - ishift_c(j)=ishift_c(j+1) - ifrag_c(1,j)=ifrag_c(1,j+1) - ifrag_c(2,j)=ifrag_c(2,j+1) - enddo - npiece_c=npiece_c-1 - else - i=i+1 - endif - enddo - if (lprn) then - write (iout,*) "After merge: npiece_c",npiece_c - do i=1,npiece_c - write (iout,*) ifrag_c(1,i),ifrag_c(2,i),ishift_c(i) - enddo - endif -c -c Compare angles -c - angn=0.0d0 - anorm=0 - nn = 0 - fract = 1.0d0 - npart = npiece_c - do i=1,npart - ishifc=ishift_c(i) - nbeg = ifrag_c(1,i) + 3 - ishifc - if (nbeg.lt.nn4) nbeg=nn4 - nend = ifrag_c(2,i) - ishifc + 1 - if (nend.gt.nne) nend=nne - if (nend.ge.nbeg) then - nn = nn + nend - nbeg + 1 - if (lprn) write (iout,*) "i=",i," nbeg",nbeg," nend",nend, - & " nn",nn," ishifc",ishifc - if (lprn) write (iout,*) "angles" - longest=0 - ll = 0 - do j=nbeg,nend -c deltang = pinorm(phi(j)-phi_ref(j+ishifc)) - deltang=spherang(phi_ref(j+ishifc),theta_ref(j-1+ishifc), - & theta_ref(j+ishifc),phi(j),theta(j-1),theta(j)) - if (dabs(deltang).gt.diffang_max) then - if (ll.gt.longest) longest = ll - ll = 0 - else - ll=ll+1 - endif - if (ll.gt.longest) longest = ll - if (lprn) write (iout,'(i5,3f10.5)')j,rad2deg*phi(j), - & rad2deg*phi_ref(j+ishifc),rad2deg*deltang - angn=angn+dabs(deltang) - enddo - longest=longest+3 - ff = dfloat(longest)/dfloat(nend - nbeg + 4) - if (lprn) write (iout,*)"segment",i," longest fragment within", - & diffang_max*rad2deg,":",longest," fraction",ff - if (ff.lt.fract) fract = ff - endif - enddo - if (nn.gt.0) anorm = angn/nn - if (lprn) write (iout,*) "nn",nn," norm",anorm," fract:",fract - return - end -c------------------------------------------------------------------------- - double precision function angnorm1(nang_pair,iang_pair,lprn) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'DIMENSIONS.COMPAR' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.COMPAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - logical lprn - integer nang_pair,iang_pair(2,maxres) - double precision pinorm - angn=0.0d0 - if (lprn) write (iout,'(80(1h*))') - if (lprn) write (iout,*) "nang_pair",nang_pair - if (lprn) write (iout,*) "angles" - do j=1,nang_pair - ia1 = iang_pair(1,j) - ia2 = iang_pair(2,j) -c deltang = pinorm(phi(ia1)-phi_ref(ia2)) - deltang=spherang(phi_ref(ia2),theta_ref(ia2-1), - & theta_ref(ia2),phi(ia2),theta(ia2-1),theta(ia2)) - if (lprn) write (iout,'(3i5,3f10.5)')j,ia1,ia2,rad2deg*phi(ia1), - & rad2deg*phi_ref(ia2),rad2deg*deltang - angn=angn+dabs(deltang) - enddo - if (lprn) - &write (iout,*)"nang_pair",nang_pair," angn",rad2deg*angn/nang_pair - angnorm1 = angn/nang_pair - return - end -c------------------------------------------------------------------------------ - subroutine angnorm12(diff) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'DIMENSIONS.COMPAR' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.COMPAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - double precision pinorm - diff=0.0d0 - nn4 = nstart_sup+3 - nne = min0(nend_sup,nres) -c do j=nn4-1,nne -c diff = diff+rad2deg*dabs(pinorm(theta(j)-theta_ref(j))) -c enddo - do j=nn4,nne -c diff = diff+rad2deg*dabs(pinorm(phi(j)-phi_ref(j))) - diff=diff+spherang(phi_ref(j),theta_ref(j-1), - & theta_ref(j),phi(j),theta(j-1),theta(j)) - enddo - return - end -c-------------------------------------------------------------------------------- - double precision function spherang(gam1,theta11,theta12, - & gam2,theta21,theta22) - implicit none - double precision gam1,theta11,theta12,gam2,theta21,theta22, - & x1,x2,xmed,f1,f2,fmed - double precision tolx /1.0d-4/, tolf /1.0d-4/ - double precision sumcos - double precision arcos,pinorm,sumangp - integer it,maxit /100/ -c Calculate the difference of the angles of two superposed 4-redidue fragments -c -c O P -c \ / -c O'--C--C -c \ -c P' -c -c The fragment O'-C-C-P' is rotated by angle fi about the C-C axis -c to achieve the minimum difference between the O'-C-O and P-C-P angles; -c the sum of these angles is the difference returned by the function. -c -c 4/28/04 AL -c If thetas match, take the difference of gamma and exit. - if (dabs(theta11-theta12).lt.tolx - & .and. dabs(theta21-theta22).lt.tolx) then - spherang=dabs(pinorm(gam2-gam1)) - return - endif -c If the gammas are the same, take the difference of thetas and exit. - x1=0.0d0 - x2=0.5d0*pinorm(gam2-gam1) - if (dabs(x2) .lt. tolx) then - spherang=dabs(theta11-theta21)+dabs(theta12-theta22) - return - else if (x2.lt.0.0d0) then - x1=x2 - x2=0.0d0 - endif -c Else apply regula falsi method to compute optimum overlap of the terminal Calphas - f1=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,x1) - f2=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,x2) - do it=1,maxit - xmed=x1-f1*(x2-x1)/(f2-f1) - fmed=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,xmed) -c write (*,*) 'it',it,' xmed ',xmed,' fmed ',fmed - if ( (dabs(xmed-x1).lt.tolx .or. dabs(x2-xmed).lt.tolx) - & .and. dabs(fmed).lt.tolf ) then - x1=xmed - f1=fmed - goto 10 - else if ( fmed*f1.lt.0.0d0 ) then - x2=xmed - f2=fmed - else - x1=xmed - f1=fmed - endif - enddo - 10 continue - spherang=arcos(dcos(theta11)*dcos(theta12) - & +dsin(theta11)*dsin(theta12)*dcos(x1))+ - & arcos(dcos(theta21)*dcos(theta22)+ - & dsin(theta21)*dsin(theta22)*dcos(gam2-gam1+x1)) - return - end -c-------------------------------------------------------------------------------- - double precision function sumangp(gam1,theta11,theta12,gam2, - & theta21,theta22,fi) - implicit none - double precision gam1,theta11,theta12,gam2,theta21,theta22,fi, - & cost11,cost12,cost21,cost22,sint11,sint12,sint21,sint22,cosd1, - & cosd2 -c derivarive of the sum of the difference of the angles of a 4-residue fragment. - double precision arcos - cost11=dcos(theta11) - cost12=dcos(theta12) - cost21=dcos(theta21) - cost22=dcos(theta22) - sint11=dsin(theta11) - sint12=dsin(theta12) - sint21=dsin(theta21) - sint22=dsin(theta22) - cosd1=cost11*cost12+sint11*sint12*dcos(fi) - cosd2=cost21*cost22+sint21*sint22*dcos(gam2-gam1+fi) - sumangp=sint11*sint12*dsin(fi)/dsqrt(1.0d0-cosd1*cosd1) - & +sint21*sint22*dsin(gam2-gam1+fi)/dsqrt(1.0d0-cosd2*cosd2) - return - end diff --git a/source/wham/src-NEWSC/arcos.f b/source/wham/src-NEWSC/arcos.f deleted file mode 100755 index 69810ea..0000000 --- a/source/wham/src-NEWSC/arcos.f +++ /dev/null @@ -1,9 +0,0 @@ - FUNCTION ARCOS(X) - implicit real*8 (a-h,o-z) - include 'COMMON.GEO' - IF (DABS(X).LT.1.0D0) GOTO 1 - ARCOS=0.5D0*(PI+DSIGN(1.0D0,X)*PI) - RETURN - 1 ARCOS=DACOS(X) - RETURN - END diff --git a/source/wham/src-NEWSC/bxread.F b/source/wham/src-NEWSC/bxread.F deleted file mode 100755 index c459499..0000000 --- a/source/wham/src-NEWSC/bxread.F +++ /dev/null @@ -1,89 +0,0 @@ - subroutine bxread(nazwa,islice,ii,jj,kk,ll,mm,iR,ib,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.PROTFILES" - include "COMMON.NAMES" - include "COMMON.VAR" - include "COMMON.GEO" - include "COMMON.ENEPS" - include "COMMON.PROT" - include "COMMON.INTERACT" - include "COMMON.FREE" - include "COMMON.SBRIDGE" - real*4 csingle(3,maxres2) - character*64 nazwa,bprotfile_temp - character*3 liczba - integer i,is,ie,j,ii,jj,k,kk,l,ll,mm,if - integer nrec,nlines,iscor,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(0:maxprocs-1) - integer iparm,ib,iib,ir,nprop,nthr,nrec_slice - double precision etot,time - logical lerr - nrec_slice=(rec_end(iR,ib,iparm)-rec_start(iR,ib,iparm)+1)/nslice - is=rec_start(iR,ib,iparm)+(islice-1)*nrec_slice - ie=rec_start(iR,ib,iparm)+islice*nrec_slice-1 - write (iout,*) "bxread: islice",islice," nslice",nslice, - & " nrec_slice",nrec_slice - write (iout,*) "is",is," ie",ie,"rec_start", - & rec_start(iR,ib,iparm)," rec_end",rec_end(iR,ib,iparm) - do i=is,ie - read(ientin,rec=i+1,err=101) - & ((csingle(l,k),l=1,3),k=1,nres), - & ((csingle(l,k+nres),l=1,3),k=nnt,nct), - & nss,(ihpb(k),jhpb(k),k=1,nss), - & eini,efree,rmsdev,(prop(j),j=1,nQ),iscor - ii=ii+1 - kk=kk+1 - if (mod(kk,isampl(iparm)).eq.0) then - jj=jj+1 - write(ientout,rec=jj) - & ((csingle(l,k),l=1,3),k=1,nres), - & ((csingle(l,k+nres),l=1,3),k=nnt,nct), - & nss,(ihpb(k),jhpb(k),k=1,nss), - & eini,efree,rmsdev,(prop(j),j=1,nQ),iR,ib,iparm -#ifdef DEBUG - do i=1,2*nres - do j=1,3 - c(j,i)=csingle(j,i) - enddo - enddo - call int_from_cart1(.false.) - write (iout,*) "Writing conformation, record",jj - write (iout,*) "Cartesian coordinates" - write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) - write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) - write (iout,*) "Internal coordinates" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) - write (iout,'(f10.5,i5)') rmsdev,iscor -#endif - endif - enddo - 101 continue - close(ientin) - write (iout,*) ii," conformations read from DA file ", - & nazwa(:ilen(nazwa)) - write (iout,*) kk," conformations read so far, slice",islice - write (iout,*) jj," conformations stored so far, slice",islice - - return - end diff --git a/source/wham/src-NEWSC/cartder.f b/source/wham/src-NEWSC/cartder.f deleted file mode 100755 index ed14f18..0000000 --- a/source/wham/src-NEWSC/cartder.f +++ /dev/null @@ -1,306 +0,0 @@ - subroutine cartder - implicit real*8 (a-h,o-z) -*********************************************************************** -* This subroutine calculates the derivatives of the consecutive virtual -* bond vectors and the SC vectors in the virtual-bond angles theta and -* virtual-torsional angles phi, as well as the derivatives of SC vectors -* in the angles alpha and omega, describing the location of a side chain -* in its local coordinate system. -* -* The derivatives are stored in the following arrays: -* -* DDCDV - the derivatives of virtual-bond vectors DC in theta and phi. -* The structure is as follows: -* -* dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0, 0, 0 -* dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4) -* . . . . . . . . . . . . . . . . . . -* dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4) -* . -* . -* . -* dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N) -* -* DXDV - the derivatives of the side-chain vectors in theta and phi. -* The structure is same as above. -* -* DCDS - the derivatives of the side chain vectors in the local spherical -* andgles alph and omega: -* -* dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2) -* dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3) -* . -* . -* . -* dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1) -* -* Version of March '95, based on an early version of November '91. -* -*********************************************************************** - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - dimension drt(3,3,maxres),rdt(3,3,maxres),dp(3,3),temp(3,3), - & fromto(3,3,maxdim),prordt(3,3,maxres),prodrt(3,3,maxres) - dimension xx(3),xx1(3) -* get the position of the jth ijth fragment of the chain coordinate system -* in the fromto array. - indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 -* -* calculate the derivatives of transformation matrix elements in theta -* - do i=1,nres-2 - rdt(1,1,i)=-rt(1,2,i) - rdt(1,2,i)= rt(1,1,i) - rdt(1,3,i)= 0.0d0 - rdt(2,1,i)=-rt(2,2,i) - rdt(2,2,i)= rt(2,1,i) - rdt(2,3,i)= 0.0d0 - rdt(3,1,i)=-rt(3,2,i) - rdt(3,2,i)= rt(3,1,i) - rdt(3,3,i)= 0.0d0 - enddo -* -* derivatives in phi -* - do i=2,nres-2 - drt(1,1,i)= 0.0d0 - drt(1,2,i)= 0.0d0 - drt(1,3,i)= 0.0d0 - drt(2,1,i)= rt(3,1,i) - drt(2,2,i)= rt(3,2,i) - drt(2,3,i)= rt(3,3,i) - drt(3,1,i)=-rt(2,1,i) - drt(3,2,i)=-rt(2,2,i) - drt(3,3,i)=-rt(2,3,i) - enddo -* -* generate the matrix products of type r(i)t(i)...r(j)t(j) -* - do i=2,nres-2 - ind=indmat(i,i+1) - do k=1,3 - do l=1,3 - temp(k,l)=rt(k,l,i) - enddo - enddo - do k=1,3 - do l=1,3 - fromto(k,l,ind)=temp(k,l) - enddo - enddo - do j=i+1,nres-2 - ind=indmat(i,j+1) - do k=1,3 - do l=1,3 - dpkl=0.0d0 - do m=1,3 - dpkl=dpkl+temp(k,m)*rt(m,l,j) - enddo - dp(k,l)=dpkl - fromto(k,l,ind)=dpkl - enddo - enddo - do k=1,3 - do l=1,3 - temp(k,l)=dp(k,l) - enddo - enddo - enddo - enddo -* -* Calculate derivatives. -* - ind1=0 - do i=1,nres-2 - ind1=ind1+1 -* -* Derivatives of DC(i+1) in theta(i+2) -* - do j=1,3 - do k=1,2 - dpjk=0.0D0 - do l=1,3 - dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) - enddo - dp(j,k)=dpjk - prordt(j,k,i)=dp(j,k) - enddo - dp(j,3)=0.0D0 - dcdv(j,ind1)=vbl*dp(j,1) - enddo -* -* Derivatives of SC(i+1) in theta(i+2) -* - xx1(1)=-0.5D0*xloc(2,i+1) - xx1(2)= 0.5D0*xloc(1,i+1) - do j=1,3 - xj=0.0D0 - do k=1,2 - xj=xj+r(j,k,i)*xx1(k) - enddo - xx(j)=xj - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i)*xx(k) - enddo - dxdv(j,ind1)=rj - enddo -* -* Derivatives of SC(i+1) in theta(i+3). The have to be handled differently -* than the other off-diagonal derivatives. -* - do j=1,3 - dxoiij=0.0D0 - do k=1,3 - dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) - enddo - dxdv(j,ind1+1)=dxoiij - enddo -cd print *,ind1+1,(dxdv(j,ind1+1),j=1,3) -* -* Derivatives of DC(i+1) in phi(i+2) -* - do j=1,3 - do k=1,3 - dpjk=0.0 - do l=2,3 - dpjk=dpjk+prod(j,l,i)*drt(l,k,i) - enddo - dp(j,k)=dpjk - prodrt(j,k,i)=dp(j,k) - enddo - dcdv(j+3,ind1)=vbl*dp(j,1) - enddo -* -* Derivatives of SC(i+1) in phi(i+2) -* - xx(1)= 0.0D0 - xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i) - xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i) - do j=1,3 - rj=0.0D0 - do k=2,3 - rj=rj+prod(j,k,i)*xx(k) - enddo - dxdv(j+3,ind1)=-rj - enddo -* -* Derivatives of SC(i+1) in phi(i+3). -* - do j=1,3 - dxoiij=0.0D0 - do k=1,3 - dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) - enddo - dxdv(j+3,ind1+1)=dxoiij - enddo -* -* Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru -* theta(nres) and phi(i+3) thru phi(nres). -* - do j=i+1,nres-2 - ind1=ind1+1 - ind=indmat(i+1,j+1) -cd print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 - do k=1,3 - do l=1,3 - tempkl=0.0D0 - do m=1,2 - tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind) - enddo - temp(k,l)=tempkl - enddo - enddo -cd print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3) -cd print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3) -cd print '(9f8.3)',((temp(k,l),l=1,3),k=1,3) -* Derivatives of virtual-bond vectors in theta - do k=1,3 - dcdv(k,ind1)=vbl*temp(k,1) - enddo -cd print '(3f8.3)',(dcdv(k,ind1),k=1,3) -* Derivatives of SC vectors in theta - do k=1,3 - dxoijk=0.0D0 - do l=1,3 - dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) - enddo - dxdv(k,ind1+1)=dxoijk - enddo -* -*--- Calculate the derivatives in phi -* - do k=1,3 - do l=1,3 - tempkl=0.0D0 - do m=1,3 - tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind) - enddo - temp(k,l)=tempkl - enddo - enddo - do k=1,3 - dcdv(k+3,ind1)=vbl*temp(k,1) - enddo - do k=1,3 - dxoijk=0.0D0 - do l=1,3 - dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) - enddo - dxdv(k+3,ind1+1)=dxoijk - enddo - enddo - enddo -* -* Derivatives in alpha and omega: -* - do i=2,nres-1 - dsci=dsc(itype(i)) - alphi=alph(i) - omegi=omeg(i) -cd print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - temp(1,1)=-dsci*sinalphi - temp(2,1)= dsci*cosalphi*cosomegi - temp(3,1)=-dsci*cosalphi*sinomegi - temp(1,2)=0.0D0 - temp(2,2)=-dsci*sinalphi*sinomegi - temp(3,2)=-dsci*sinalphi*cosomegi - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - jjj=0 -cd print *,((temp(l,k),l=1,3),k=1,2) - do j=1,2 - xp=temp(1,j) - yp=temp(2,j) - xxp= xp*cost2+yp*sint2 - yyp=-xp*sint2+yp*cost2 - zzp=temp(3,j) - xx(1)=xxp - xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) - xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) - do k=1,3 - dj=0.0D0 - do l=1,3 - dj=dj+prod(k,l,i-1)*xx(l) - enddo - dxds(jjj+k,i)=dj - enddo - jjj=jjj+3 - enddo - enddo - return - end - diff --git a/source/wham/src-NEWSC/cartprint.f b/source/wham/src-NEWSC/cartprint.f deleted file mode 100755 index fd8ffe3..0000000 --- a/source/wham/src-NEWSC/cartprint.f +++ /dev/null @@ -1,20 +0,0 @@ - subroutine cartprint - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - write (iout,100) - do i=1,nres - write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i), - & c(3,i),c(1,nres+i),c(2,nres+i),c(3,nres+i) - enddo - 100 format (//' alpha-carbon coordinates ', - & ' centroid coordinates'/ - 1 ' ', 6X,'X',11X,'Y',11X,'Z', - & 10X,'X',11X,'Y',11X,'Z') - 110 format (a,'(',i3,')',6f12.5) - return - end diff --git a/source/wham/src-NEWSC/chainbuild.F b/source/wham/src-NEWSC/chainbuild.F deleted file mode 100755 index 4c9f32f..0000000 --- a/source/wham/src-NEWSC/chainbuild.F +++ /dev/null @@ -1,281 +0,0 @@ - subroutine chainbuild -C -C Build the virtual polypeptide chain. Side-chain centroids are moveable. -C As of 2/17/95. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - logical lprn -C Set lprn=.true. for debugging - lprn = .false. -C -C Define the origin and orientation of the coordinate system and locate the -C first three CA's and SC(2). -C - call orig_frame -* -* Build the alpha-carbon chain. -* - do i=4,nres - call locate_next_res(i) - enddo -C -C First and last SC must coincide with the corresponding CA. -C - do j=1,3 - dc(j,nres+1)=0.0D0 - dc_norm(j,nres+1)=0.0D0 - dc(j,nres+nres)=0.0D0 - dc_norm(j,nres+nres)=0.0D0 - c(j,nres+1)=c(j,1) - c(j,nres+nres)=c(j,nres) - enddo -* -* Temporary diagnosis -* - if (lprn) then - - call cartprint - write (iout,'(/a)') 'Recalculated internal coordinates' - do i=2,nres-1 - do j=1,3 - c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) - enddo - be=0.0D0 - if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i) - be1=rad2deg*beta(nres+i,i,maxres2,i+1) - alfai=0.0D0 - if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i) - write (iout,1212) restyp(itype(i)),i,dist(i-1,i), - & alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,maxres2),be1 - enddo - 1212 format (a3,'(',i3,')',2(f10.5,2f10.2)) - - endif - - return - end -c------------------------------------------------------------------------- - subroutine orig_frame -C -C Define the origin and orientation of the coordinate system and locate -C the first three atoms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - cost=dcos(theta(3)) - sint=dsin(theta(3)) - t(1,1,1)=-cost - t(1,2,1)=-sint - t(1,3,1)= 0.0D0 - t(2,1,1)=-sint - t(2,2,1)= cost - t(2,3,1)= 0.0D0 - t(3,1,1)= 0.0D0 - t(3,2,1)= 0.0D0 - t(3,3,1)= 1.0D0 - r(1,1,1)= 1.0D0 - r(1,2,1)= 0.0D0 - r(1,3,1)= 0.0D0 - r(2,1,1)= 0.0D0 - r(2,2,1)= 1.0D0 - r(2,3,1)= 0.0D0 - r(3,1,1)= 0.0D0 - r(3,2,1)= 0.0D0 - r(3,3,1)= 1.0D0 - do i=1,3 - do j=1,3 - rt(i,j,1)=t(i,j,1) - enddo - enddo - do i=1,3 - do j=1,3 - prod(i,j,1)=0.0D0 - prod(i,j,2)=t(i,j,1) - enddo - prod(i,i,1)=1.0D0 - enddo - c(1,1)=0.0D0 - c(2,1)=0.0D0 - c(3,1)=0.0D0 - c(1,2)=vbld(2) - c(2,2)=0.0D0 - c(3,2)=0.0D0 - dc(1,1)=vbld(2) - dc(2,1)=0.0D0 - dc(3,1)=0.0D0 - dc_norm(1,1)=1.0D0 - dc_norm(2,1)=0.0D0 - dc_norm(3,1)=0.0D0 - do j=1,3 - dc_norm(j,2)=prod(j,1,2) - dc(j,2)=vbld(3)*prod(j,1,2) - c(j,3)=c(j,2)+dc(j,2) - enddo - call locate_side_chain(2) - return - end -c----------------------------------------------------------------------------- - subroutine locate_next_res(i) -C -C Locate CA(i) and SC(i-1) -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' -C -C Define the rotation matrices corresponding to CA(i) -C -#ifdef OSF - theti=theta(i) - icrc=0 - call proc_proc(theti,icrc) - if(icrc.eq.1)theti=100.0 - phii=phi(i) - icrc=0 - call proc_proc(phii,icrc) - if(icrc.eq.1)phii=180.0 -#else - theti=theta(i) - phii=phi(i) -#endif - cost=dcos(theti) - sint=dsin(theti) - cosphi=dcos(phii) - sinphi=dsin(phii) -* Define the matrices of the rotation about the virtual-bond valence angles -* theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this -* program), R(i,j,k), and, the cumulative matrices of rotation RT - t(1,1,i-2)=-cost - t(1,2,i-2)=-sint - t(1,3,i-2)= 0.0D0 - t(2,1,i-2)=-sint - t(2,2,i-2)= cost - t(2,3,i-2)= 0.0D0 - t(3,1,i-2)= 0.0D0 - t(3,2,i-2)= 0.0D0 - t(3,3,i-2)= 1.0D0 - r(1,1,i-2)= 1.0D0 - r(1,2,i-2)= 0.0D0 - r(1,3,i-2)= 0.0D0 - r(2,1,i-2)= 0.0D0 - r(2,2,i-2)=-cosphi - r(2,3,i-2)= sinphi - r(3,1,i-2)= 0.0D0 - r(3,2,i-2)= sinphi - r(3,3,i-2)= cosphi - rt(1,1,i-2)=-cost - rt(1,2,i-2)=-sint - rt(1,3,i-2)=0.0D0 - rt(2,1,i-2)=sint*cosphi - rt(2,2,i-2)=-cost*cosphi - rt(2,3,i-2)=sinphi - rt(3,1,i-2)=-sint*sinphi - rt(3,2,i-2)=cost*sinphi - rt(3,3,i-2)=cosphi - call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1)) - do j=1,3 - dc_norm(j,i-1)=prod(j,1,i-1) - dc(j,i-1)=vbld(i)*prod(j,1,i-1) - c(j,i)=c(j,i-1)+dc(j,i-1) - enddo -cd print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3) -C -C Now calculate the coordinates of SC(i-1) -C - call locate_side_chain(i-1) - return - end -c----------------------------------------------------------------------------- - subroutine locate_side_chain(i) -C -C Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - dimension xx(3) - -c dsci=dsc(itype(i)) -c dsci_inv=dsc_inv(itype(i)) - dsci=vbld(i+nres) - dsci_inv=vbld_inv(i+nres) -#ifdef OSF - alphi=alph(i) - omegi=omeg(i) -c detecting NaNQ - icrc=0 - call proc_proc(alphi,icrc) - if(icrc.eq.1)alphi=100.0 - icrc=0 - call proc_proc(omegi,icrc) - if(icrc.eq.1)omegi=-100.0 -#else - alphi=alph(i) - omegi=omeg(i) -#endif - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - xp= dsci*cosalphi - yp= dsci*sinalphi*cosomegi - zp=-dsci*sinalphi*sinomegi -* Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its -* X-axis aligned with the vector DC(*,i) - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - xx(1)= xp*cost2+yp*sint2 - xx(2)=-xp*sint2+yp*cost2 - xx(3)= zp -cd print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i, -cd & xp,yp,zp,(xx(k),k=1,3) - do j=1,3 - xloc(j,i)=xx(j) - enddo -* Bring the SC vectors to the common coordinate system. - xx(1)=xloc(1,i) - xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1) - xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1) - do j=1,3 - xrot(j,i)=xx(j) - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i-1)*xx(k) - enddo - dc(j,nres+i)=rj - dc_norm(j,nres+i)=rj*dsci_inv - c(j,nres+i)=c(j,i)+rj - enddo - return - end diff --git a/source/wham/src-NEWSC/chainbuild.f b/source/wham/src-NEWSC/chainbuild.f deleted file mode 100755 index 26afd44..0000000 --- a/source/wham/src-NEWSC/chainbuild.f +++ /dev/null @@ -1,258 +0,0 @@ - subroutine chainbuild -C -C Build the virtual polypeptide chain. Side-chain centroids are moveable. -C As of 2/17/95. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - logical lprn -C Set lprn=.true. for debugging - lprn = .false. -C -C Define the origin and orientation of the coordinate system and locate the -C first three CA's and SC(2). -C - call orig_frame -* -* Build the alpha-carbon chain. -* - do i=4,nres - call locate_next_res(i) - enddo -C -C First and last SC must coincide with the corresponding CA. -C - do j=1,3 - dc(j,nres+1)=0.0D0 - dc_norm(j,nres+1)=0.0D0 - dc(j,nres+nres)=0.0D0 - dc_norm(j,nres+nres)=0.0D0 - c(j,nres+1)=c(j,1) - c(j,nres+nres)=c(j,nres) - enddo -* -* Temporary diagnosis -* - if (lprn) then - - call cartprint - write (iout,'(/a)') 'Recalculated internal coordinates' - do i=2,nres-1 - do j=1,3 - c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) - enddo - be=0.0D0 - if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i) - be1=rad2deg*beta(nres+i,i,maxres2,i+1) - alfai=0.0D0 - if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i) - write (iout,1212) restyp(itype(i)),i,dist(i-1,i), - & alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,maxres2),be1 - enddo - 1212 format (a3,'(',i3,')',2(f10.5,2f10.2)) - - endif - - return - end -c------------------------------------------------------------------------- - subroutine orig_frame -C -C Define the origin and orientation of the coordinate system and locate -C the first three atoms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - cost=dcos(theta(3)) - sint=dsin(theta(3)) - t(1,1,1)=-cost - t(1,2,1)=-sint - t(1,3,1)= 0.0D0 - t(2,1,1)=-sint - t(2,2,1)= cost - t(2,3,1)= 0.0D0 - t(3,1,1)= 0.0D0 - t(3,2,1)= 0.0D0 - t(3,3,1)= 1.0D0 - r(1,1,1)= 1.0D0 - r(1,2,1)= 0.0D0 - r(1,3,1)= 0.0D0 - r(2,1,1)= 0.0D0 - r(2,2,1)= 1.0D0 - r(2,3,1)= 0.0D0 - r(3,1,1)= 0.0D0 - r(3,2,1)= 0.0D0 - r(3,3,1)= 1.0D0 - do i=1,3 - do j=1,3 - rt(i,j,1)=t(i,j,1) - enddo - enddo - do i=1,3 - do j=1,3 - prod(i,j,1)=0.0D0 - prod(i,j,2)=t(i,j,1) - enddo - prod(i,i,1)=1.0D0 - enddo - c(1,1)=0.0D0 - c(2,1)=0.0D0 - c(3,1)=0.0D0 - c(1,2)=vbld(2) - c(2,2)=0.0D0 - c(3,2)=0.0D0 - dc(1,1)=vbld(2) - dc(2,1)=0.0D0 - dc(3,1)=0.0D0 - dc_norm(1,1)=1.0D0 - dc_norm(2,1)=0.0D0 - dc_norm(3,1)=0.0D0 - do j=1,3 - dc_norm(j,2)=prod(j,1,2) - dc(j,2)=vbld(3)*prod(j,1,2) - c(j,3)=c(j,2)+dc(j,2) - enddo - call locate_side_chain(2) - return - end -c----------------------------------------------------------------------------- - subroutine locate_next_res(i) -C -C Locate CA(i) and SC(i-1) -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' -C -C Define the rotation matrices corresponding to CA(i) -C - theti=theta(i) - phii=phi(i) - cost=dcos(theti) - sint=dsin(theti) - cosphi=dcos(phii) - sinphi=dsin(phii) -* Define the matrices of the rotation about the virtual-bond valence angles -* theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this -* program), R(i,j,k), and, the cumulative matrices of rotation RT - t(1,1,i-2)=-cost - t(1,2,i-2)=-sint - t(1,3,i-2)= 0.0D0 - t(2,1,i-2)=-sint - t(2,2,i-2)= cost - t(2,3,i-2)= 0.0D0 - t(3,1,i-2)= 0.0D0 - t(3,2,i-2)= 0.0D0 - t(3,3,i-2)= 1.0D0 - r(1,1,i-2)= 1.0D0 - r(1,2,i-2)= 0.0D0 - r(1,3,i-2)= 0.0D0 - r(2,1,i-2)= 0.0D0 - r(2,2,i-2)=-cosphi - r(2,3,i-2)= sinphi - r(3,1,i-2)= 0.0D0 - r(3,2,i-2)= sinphi - r(3,3,i-2)= cosphi - rt(1,1,i-2)=-cost - rt(1,2,i-2)=-sint - rt(1,3,i-2)=0.0D0 - rt(2,1,i-2)=sint*cosphi - rt(2,2,i-2)=-cost*cosphi - rt(2,3,i-2)=sinphi - rt(3,1,i-2)=-sint*sinphi - rt(3,2,i-2)=cost*sinphi - rt(3,3,i-2)=cosphi - call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1)) - do j=1,3 - dc_norm(j,i-1)=prod(j,1,i-1) - dc(j,i-1)=vbld(i)*prod(j,1,i-1) - c(j,i)=c(j,i-1)+dc(j,i-1) - enddo -cd print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3) -C -C Now calculate the coordinates of SC(i-1) -C - call locate_side_chain(i-1) - return - end -c----------------------------------------------------------------------------- - subroutine locate_side_chain(i) -C -C Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.INTERACT' - dimension xx(3) - -c dsci=dsc(itype(i)) -c dsci_inv=dsc_inv(itype(i)) - dsci=vbld(i+nres) - dsci_inv=vbld_inv(i+nres) - alphi=alph(i) - omegi=omeg(i) - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - xp= dsci*cosalphi - yp= dsci*sinalphi*cosomegi - zp=-dsci*sinalphi*sinomegi -* Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its -* X-axis aligned with the vector DC(*,i) - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - xx(1)= xp*cost2+yp*sint2 - xx(2)=-xp*sint2+yp*cost2 - xx(3)= zp -cd print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i, -cd & xp,yp,zp,(xx(k),k=1,3) - do j=1,3 - xloc(j,i)=xx(j) - enddo -* Bring the SC vectors to the common coordinate system. - xx(1)=xloc(1,i) - xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1) - xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1) - do j=1,3 - xrot(j,i)=xx(j) - enddo - do j=1,3 - rj=0.0D0 - do k=1,3 - rj=rj+prod(j,k,i-1)*xx(k) - enddo - dc(j,nres+i)=rj - dc_norm(j,nres+i)=rj*dsci_inv - c(j,nres+i)=c(j,i)+rj - enddo - return - end diff --git a/source/wham/src-NEWSC/compinfo.c b/source/wham/src-NEWSC/compinfo.c deleted file mode 100755 index e28f686..0000000 --- a/source/wham/src-NEWSC/compinfo.c +++ /dev/null @@ -1,82 +0,0 @@ -#include -#include -#include -#include -#include - -main() -{ -FILE *in, *in1, *out; -int i,j,k,iv1,iv2,iv3; -char *p1,buf[500],buf1[500],buf2[100],buf3[100]; -struct utsname Name; -time_t Tp; - -in=fopen("cinfo.f","r"); -out=fopen("cinfo.f.new","w"); -if (fgets(buf,498,in) != NULL) - fprintf(out,"C DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C\n"); -if (fgets(buf,498,in) != NULL) - sscanf(&buf[1],"%d %d %d",&iv1,&iv2,&iv3); -iv3++; -fprintf(out,"C %d %d %d\n",iv1,iv2,iv3); -fprintf(out," subroutine cinfo\n"); -fprintf(out," include 'COMMON.IOUNITS'\n"); -fprintf(out," write(iout,*)'++++ Compile info ++++'\n"); -fprintf(out," write(iout,*)'Version %d.%-d build %d'\n",iv1,iv2,iv3); -uname(&Name); -time(&Tp); -system("whoami > tmptmp"); -in1=fopen("tmptmp","r"); -if (fscanf(in1,"%s",buf1) != EOF) -{ -p1=ctime(&Tp); -p1[strlen(p1)-1]='\0'; -fprintf(out," write(iout,*)'compiled %s'\n",p1); -fprintf(out," write(iout,*)'compiled by %s@%s'\n",buf1,Name.nodename); -fprintf(out," write(iout,*)'OS name: %s '\n",Name.sysname); -fprintf(out," write(iout,*)'OS release: %s '\n",Name.release); -fprintf(out," write(iout,*)'OS version:',\n"); -fprintf(out," & ' %s '\n",Name.version); -fprintf(out," write(iout,*)'flags:'\n"); -} -system("rm tmptmp"); -fclose(in1); -in1=fopen("Makefile","r"); -while(fgets(buf,498,in1) != NULL) - { - if((p1=strchr(buf,'=')) != NULL && buf[0] != '#') - { - buf[strlen(buf)-1]='\0'; - if(strlen(buf) > 49) - { - buf[47]='\0'; - strcat(buf,"..."); - } - else - { - while(buf[strlen(buf)-1]=='\\') - { - strcat(buf,"\\"); - fprintf(out," write(iout,*)'%s'\n",buf); - if (fgets(buf,498,in1) != NULL) - buf[strlen(buf)-1]='\0'; - if(strlen(buf) > 49) - { - buf[47]='\0'; - strcat(buf,"..."); - } - } - } - - fprintf(out," write(iout,*)'%s'\n",buf); - } - } -fprintf(out," write(iout,*)'++++ End of compile info ++++'\n"); -fprintf(out," return\n"); -fprintf(out," end\n"); -fclose(out); -fclose(in1); -fclose(in); -system("mv cinfo.f.new cinfo.f"); -} diff --git a/source/wham/src-NEWSC/conf_compar.F b/source/wham/src-NEWSC/conf_compar.F deleted file mode 100755 index 4b49345..0000000 --- a/source/wham/src-NEWSC/conf_compar.F +++ /dev/null @@ -1,374 +0,0 @@ - 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) - integer isecstr(maxres) - integer itemp(maxfrag) - character*4 liczba - double precision Epot -c print *,"Enter conf_compar",jcon - call angnorm12(rmsang) -c Level 1: check secondary and supersecondary structure - call elecont(lprn,ncont,icont,nnt,nct) - call secondary2(lprn,.false.,ncont,icont,isecstr) - call contact(lprn,ncontsc,icontsc,nnt,nct) - if (lprn) write(iout,*) "Assigning electrostatic contacts" - call contacts_between_fragments(lprn,3,ncont,icont,ncont_frag, - & icont_frag) - if (lprn) write(iout,*) "Assigning sidechain contacts" - call contacts_between_fragments(lprn,3,ncontsc,icontsc, - & nsccont_frag,isccont_frag) - 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 - rmsfrag(j,1)=rmscalc(0,1,j,jcon,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" - ncnat=ncont_frag_ref(ind) -c write (iout,*) "before match_contact:",nc_fragm(j,1), -c & nc_req_setf(j,1) - call match_secondary(j,isecstr,nsec_match,lprn) - if (lprn) write (iout,*) "Fragment",j," nsec_match", - & nsec_match," length",len_frag(j,1)," min_len", - & frac_sec*len_frag(j,1) - if (nsec_match.lt.frac_sec*len_frag(j,1)) then - iclass(j,1)=0 - if (lprn) write (iout,*) "Fragment",j, - & " has incorrect secondary structure" - else - iclass(j,1)=1 - if (lprn) write (iout,*) "Fragment",j, - & " has correct secondary structure" - endif - if (ielecont(j,1).gt.0) then - call match_contact(ishif1,ishif2,nc_match,ncon_match, - & ncont_frag_ref(ind),icont_frag_ref(1,1,ind), - & ncont_frag(ind),icont_frag(1,1,ind), - & j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1), - & nc_req_setf(j,1),istruct(j),.true.,lprn) - else if (isccont(j,1).gt.0) then - call match_contact(ishif1,ishif2,nc_match,ncon_match, - & nsccont_frag_ref(ind),isccont_frag_ref(1,1,ind), - & nsccont_frag(ind),isccont_frag(1,1,ind), - & j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1), - & nc_req_setf(j,1),istruct(j),.true.,lprn) - else if (iloc(j).gt.0) then -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),.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) - 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(-ishiff,1,j,jcon,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(ishiff,1,j,jcon,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,.false.,lprn) - ishif=ishif1 - if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 - if (nc_match.gt.0) then - if (ishif.eq.0) then - iclass_con=2 - else - iclass_con=1 - endif - endif - ncont_nat(1,j,i)=nc_match - ncont_nat(2,j,i)=ncon_match - ishifft_con=ishif - else if (i.eq.2 .and. isccont(j,i).gt.0) then - iclass_con=0 - ishifft_con=0 - if (lprn) write (iout,*) - & "Comparing sidechain contact map: fragments", - & ipiece(1,j,i),ipiece(2,j,i)," ind",ind - call match_contact(ishif1,ishif2,nc_match,ncon_match, - & nsccont_frag_ref(ind),isccont_frag_ref(1,1,ind), - & nsccont_frag(ind),isccont_frag(1,1,ind), - & j,n_shift(1,j,i),n_shift(2,j,i),nc_fragm(j,i), - & nc_req_setf(j,i),2,.false.,lprn) - ishif=ishif1 - if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 - if (nc_match.gt.0) then - if (ishif.eq.0) then - iclass_con=2 - else - iclass_con=1 - endif - endif - ncont_nat(1,j,i)=nc_match - ncont_nat(2,j,i)=ncon_match - ishifft_con=ishif - else if (i.eq.2) then - iclass_con=2 - ishifft_con=0 - endif - if (i.eq.2) qfrag(j,2)=qwolynes(2,j) - if (lprn) write (iout,*) - & "Comparing rms: fragments", - & (ipiece(k,j,i),k=1,npiece(j,i)) - rmsfrag(j,i)=rmscalc(0,i,j,jcon,lprn) - if (irms(j,i).gt.0) then - iclass_rms=0 - ishifft_rms=0 - if (lprn) write (iout,*) "rms",rmsfrag(j,i) -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(-ishif,i,j,jcon,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(ishif,i,j,jcon,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 - rms_nat=rmsnat(jcon) - qnat=qwolynes(0,0) -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-NEWSC/cont_frag.f b/source/wham/src-NEWSC/cont_frag.f deleted file mode 100755 index 63a7717..0000000 --- a/source/wham/src-NEWSC/cont_frag.f +++ /dev/null @@ -1,99 +0,0 @@ - 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-NEWSC/contact.f b/source/wham/src-NEWSC/contact.f deleted file mode 100755 index 5b05d57..0000000 --- a/source/wham/src-NEWSC/contact.f +++ /dev/null @@ -1,171 +0,0 @@ - subroutine contact(lprint,ncont,icont,ist,ien) - 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 - 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=itype(i) - do j=i+kkk,ien - itj=itype(j) - itypi=iti - itypj=itj - xj = c(1,nres+j)-c(1,nres+i) - yj = c(2,nres+j)-c(2,nres+i) - zj = c(3,nres+j)-c(3,nres+i) - dxi = dc_norm(1,nres+i) - dyi = dc_norm(2,nres+i) - dzi = dc_norm(3,nres+i) - dxj = dc_norm(1,nres+j) - dyj = dc_norm(2,nres+j) - dzj = dc_norm(3,nres+j) - do k=1,3 - a(k)=dc(k,nres+i) - b(k)=dc(k,nres+j) - enddo -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(it1,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-NEWSC/contfunc.f b/source/wham/src-NEWSC/contfunc.f deleted file mode 100755 index 7aed575..0000000 --- a/source/wham/src-NEWSC/contfunc.f +++ /dev/null @@ -1,96 +0,0 @@ - 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-NEWSC/cxread.F b/source/wham/src-NEWSC/cxread.F deleted file mode 100755 index 0735f11..0000000 --- a/source/wham/src-NEWSC/cxread.F +++ /dev/null @@ -1,336 +0,0 @@ - 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' -#ifdef MPI - include "mpif.h" - include "COMMON.MPI" -#endif - 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 - character*4 lt_bath - character*256 pdbfilename - character*50 tytul - 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)) -#ifdef DEBUG - write (iout,*) "ii",ii," itraj",itraj," it",it -#endif - call xdrffloat_(ixdrf, rtime, iret) - call xdrffloat_(ixdrf, rpotE, iret) -#ifdef DEBUG - write (iout,*) "rtime",rtime," rpotE",rpotE," iret",iret -#endif - call flush(iout) - call xdrffloat_(ixdrf, ruconst, iret) - call xdrffloat_(ixdrf, rt_bath, iret) - call xdrfint_(ixdrf, nss, iret) -#ifdef DEBUG - write (iout,*) "ruconst",ruconst," rt_bath",rt_bath," nss",nss -#endif - do j=1,nss - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) - enddo - call xdrfint_(ixdrf, nprop, iret) - if (umbrella(iparm) .or. read_iset(iparm) .or. hamil_rep) - & call xdrfint(ixdrf, iset, iret) - do i=1,nprop - call xdrffloat_(ixdrf, rprop(i), iret) - enddo -#else -#ifdef DEBUG - write (iout,*) "ii",ii," itraj",itraj," it",it -#endif - call xdrffloat(ixdrf, rtime, iret) - call xdrffloat(ixdrf, rpotE, iret) -#ifdef DEBUG - write (iout,*) "rtime",rtime," rpotE",rpotE," iret",iret -#endif - call flush(iout) - call xdrffloat(ixdrf, ruconst, iret) - call xdrffloat(ixdrf, rt_bath, iret) - call xdrfint(ixdrf, nss, iret) -#ifdef DEBUG - write (iout,*) "ruconst",ruconst," rt_bath",rt_bath," nss",nss -#endif - 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 - 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)) - 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 - - if (islice.gt.0 .and. islice.le.nslice .and. (.not.separate_parset - & .or. iset.eq.myparm)) then - ii=ii+1 - kk(islice)=kk(islice)+1 - mm(islice)=mm(islice)+1 - if (mod(nstep(itraj),isampl(iparm)).eq.0 .and. - & conf_check(ll(islice)+1,1)) then - if (replica(iparm)) then - rt_bath=1.0d0/(rt_bath*1.987D-3) - do i=1,nT_h(iparm) - if (abs(real(beta_h(i,iparm))-rt_bath).lt.1.0e-4) then - iib = i - goto 22 - endif - enddo - 22 continue - if (i.gt.nT_h(iparm)) then - write (iout,*) "Error - temperature of conformation", - & ii,1.0d0/(rt_bath*1.987D-3), - & " does not match any of the list" - write (iout,*) - & 1.0d0/(rt_bath*1.987D-3), - & (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) - call flush(iout) -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 -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 - 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 PDBOUT -#ifdef MPI - if (me.eq.Master) then -#endif - write (iout,*) "PDBOUT" - write (iout,*) "temperature",1.0d0/(rt_bath*1.987D-3) - call flush(iout) - write (lt_bath,'(f4.0)') 1.0d0/(rt_bath*1.987D-3) - write (iout,*) "lt_bath ",lt_bath - pdbfilename=prefix(:ilen(prefix))//"_"//lt_bath//"pdb" - write (iout,*) "pdb ",pdbfilename - call flush(iout) - open(ipdb,file=pdbfilename,position="append") -c write (tytul,'("Conformation",i10," T=",f5.1)') -c & kk(islice),rt_bath - call pdbout(kk(islice),1.0d0/(rt_bath*1.987D-3), - & efree+0.0d0,rpotE+0.0d0,efree+0.0d0,rmsdev+0.0d0) - close(ipdb) -#ifdef MPI - endif -#endif -#endif -#ifdef DEBUG - call int_from_cart1(.false.) - write (iout,*) "Writing conformation, record",ll(islice) - write (iout,*) "Cartesian coordinates" - write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) - write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) - write (iout,*) "Internal coordinates" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) -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-NEWSC/cxread.F.org b/source/wham/src-NEWSC/cxread.F.org deleted file mode 100755 index 80bc1a0..0000000 --- a/source/wham/src-NEWSC/cxread.F.org +++ /dev/null @@ -1,248 +0,0 @@ - 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-NEWSC/define_pairs.f b/source/wham/src-NEWSC/define_pairs.f deleted file mode 100755 index 00866a8..0000000 --- a/source/wham/src-NEWSC/define_pairs.f +++ /dev/null @@ -1,120 +0,0 @@ - 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-NEWSC/elecont.f b/source/wham/src-NEWSC/elecont.f deleted file mode 100755 index 1eff2f1..0000000 --- a/source/wham/src-NEWSC/elecont.f +++ /dev/null @@ -1,207 +0,0 @@ - subroutine elecont(lprint,ncont,icont,ist,ien) - implicit none - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'DIMENSIONS.COMPAR' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.NAMES' - include 'COMMON.LOCAL' - logical lprint - integer i,j,k,ist,ien,iteli,itelj,ind,i1,i2,it1,it2,ic1,ic2 - 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 - 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) - 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 - xi=c(1,i) - yi=c(2,i) - zi=c(3,i) - dxi=c(1,i+1)-c(1,i) - dyi=c(2,i+1)-c(2,i) - dzi=c(3,i+1)-c(3,i) - xmedi=xi+0.5*dxi - ymedi=yi+0.5*dyi - zmedi=zi+0.5*dzi - do 4 j=i+2,ien-1 - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - if (iteli.eq.2 .and. itelj.eq.2) goto 4 - aaa=appc(iteli,itelj) - bbb=bppc(iteli,itelj) - ael6i=ael6c(iteli,itelj) - ael3i=ael3c(iteli,itelj) - dxj=c(1,j+1)-c(1,j) - dyj=c(2,j+1)-c(2,j) - dzj=c(3,j+1)-c(3,j) - xj=c(1,j)+0.5*dxj-xmedi - yj=c(2,j)+0.5*dyj-ymedi - zj=c(3,j)+0.5*dzj-zmedi - rrmij=1.0/(xj*xj+yj*yj+zj*zj) - rmij=sqrt(rrmij) - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - vrmij=vblinv*rmij - cosa=(dxi*dxj+dyi*dyj+dzi*dzj)*vblinv2 - cosb=(xj*dxi+yj*dyi+zj*dzi)*vrmij - cosg=(xj*dxj+yj*dyj+zj*dzj)*vrmij - fac=cosa-3.0*cosb*cosg - ev1=aaa*r6ij*r6ij - ev2=bbb*r6ij - fac3=ael6i*r6ij - fac4=ael3i*r3ij - evdwij=ev1+ev2 - el1=fac3*(4.0+fac*fac-3.0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - eesij=el1+el2 - if (j.gt.i+2 .and. eesij.le.elcutoff .or. - & j.eq.i+2 .and. eesij.le.elecutoff_14) then - ncont=ncont+1 - icont(1,ncont)=i - icont(2,ncont)=j - econt(ncont)=eesij - endif - ees=ees+eesij - evdw=evdw+evdwij - 4 continue - 1 continue - if (lprint) then - write (iout,*) 'Total average electrostatic energy: ',ees - write (iout,*) 'VDW energy between peptide-group centers: ',evdw - write (iout,*) - write (iout,*) 'Electrostatic contacts before pruning: ' - do i=1,ncont - i1=icont(1,i) - i2=icont(2,i) - it1=itype(i1) - it2=itype(i2) - write (iout,'(i3,2x,a,i4,2x,a,i4,f10.5)') - & i,restyp(it1),i1,restyp(it2),i2,econt(i) - enddo - endif -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-NEWSC/enecalc1.F b/source/wham/src-NEWSC/enecalc1.F deleted file mode 100755 index c9f4de8..0000000 --- a/source/wham/src-NEWSC/enecalc1.F +++ /dev/null @@ -1,780 +0,0 @@ - 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 - double precision tole /1.0d-1/ - integer i,itj,ii,iii,j,k,l,licz - integer ir,ib,ipar,iparm - integer iscor,islice - real*4 csingle(3,maxres2) - double precision energ - 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 - write (iout,*) "enecalc: nparmset ",nparmset -#ifdef MPI - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - snk_p(i,ib,iparm)=0 - enddo - enddo - enddo - do i=indstart(me1),indend(me1) -#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 - q(nQ+1,iii+1)=rmsnat(iii+1) - 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,*) "Calling ETOTAL" - call etotal(energia(0),fT,beta_h(ib,iparm)) -#ifdef DEBUG - write (iout,*) "Conformation",i - call enerprint(energia(0),fT) -c write (iout,'(2i5,21f8.2)') i,iparm,(energia(k),k=1,21) -c write (iout,*) "ftors",ftors -c call intout -#endif - if (energia(0).ge.1.0d20) then - write (iout,*) "NaNs detected in some of the energy", - & " components for conformation",ii+1 - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" -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)).gt.tole) then - if (errmsg_count.le.maxerrmsg_count) then - write (iout,'(2a,2e15.5,a,2i8,a,f8.1)') - & "Warning: energy differs remarkably from ", - & " the value read in: ",energia(0),eini," point", - & iii+1,indstart(me1)+iii," T", - & 1.0d0/(1.987D-3*beta_h(ib,ipar)) - 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 - potE(iii+1,iparm)=energia(0) - do k=1,21 - 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 - call enerprint(energia(0),fT) - 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) - write(liczba,'(bz,i3.3)') me - nazwa="test"//liczba//".pdb" - write (iout,*) "pdb file",nazwa - open (ipdb,file=nazwa,position="append") - call pdbout(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev) - close(ipdb) -#endif - endif - - enddo ! iparm - - iii=iii+1 - if (q(1,iii).le.0.0d0 .and. indpdb.gt.0) q(1,iii)=qwolynes(0,0) - write (ientout,rec=iii) - & ((csingle(l,k),l=1,3),k=1,nres), - & ((csingle(l,k+nres),l=1,3),k=nnt,nct), - & nss,(ihpb(k),jhpb(k),k=1,nss), - & potE(iii,ipar),efree,rmsdev,(q(k,iii),k=1,nQ),iR,ib,ipar -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(me)=iii - write (iout,*) "Me",me," scount",scount(me) - call flush(iout) -c Master gathers updated numbers of conformations written by all procs. - call MPI_AllGather( scount(me), 1, MPI_INTEGER, scount(0), 1, - & MPI_INTEGER, WHAM_COMM, IERROR) - indstart(0)=1 - indend(0)=scount(0) - do i=1, Nprocs-1 - indstart(i)=indend(i-1)+1 - indend(i)=indstart(i)+scount(i)-1 - enddo - write (iout,*) - write (iout,*) "Revised conformation counts" - do i=0,nprocs1-1 - write (iout,'(a,i5,a,i7,a,i7,a,i7)') - & "Processor",i," indstart",indstart(i), - & " indend",indend(i)," count",scount(i) - enddo - call flush(iout) - call MPI_AllReduce(snk_p(1,1,1),snk(1,1,1,islice), - & MaxR*MaxT_h*nParmSet, - & MPI_INTEGER,MPI_SUM,WHAM_COMM,IERROR) -#endif - stot(islice)=0 - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - stot(islice)=stot(islice)+snk(i,ib,iparm,islice) - enddo - enddo - enddo - write (iout,*) "Revised SNK" - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - write (iout,'("Param",i3," Temp",f6.1,3x,32i8)') - & iparm,1.0d0/(1.987D-3*beta_h(ib,iparm)), - & (snk(i,ib,iparm,islice),i=1,nR(ib,iparm)) - write (iout,*) "snk_p",(snk_p(i,ib,iparm),i=1,nR(ib,iparm)) - enddo - enddo - write (iout,'("Total",i10)') stot(islice) - call flush(iout) - 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" - 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 - 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 - if (indpdb.gt.0) then - call conf_compar(i,.false.,.true.) - endif - 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 - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) - enddo - call xdrffloat_(ixdrf,real(eini),iret) - call xdrffloat_(ixdrf,real(efree),iret) - call xdrffloat_(ixdrf,real(rmsdev),iret) - call xdrfint_(ixdrf,iscor,iret) -#else - call xdrf3dfcoord(ixdrf, xoord, itmp, prec, iret) - - call xdrfint(ixdrf, nss, iret) - do j=1,nss - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) - enddo - call xdrffloat(ixdrf,real(eini),iret) - call xdrffloat(ixdrf,real(efree),iret) - call xdrffloat(ixdrf,real(rmsdev),iret) - call xdrfint(ixdrf,iscor,iret) -#endif - - return - end -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 - if (.not.check_conf) then - conf_check=.true. - return - endif - call int_from_cart1(.false.) - do j=nnt+1,nct - if (vbld(j).lt.2.0d0 .or. vbld(j).gt.5.0d0) then - if (iprint.gt.0) - & write (iout,*) "Bad CA-CA bond length",j," ",vbld(j), - & " for conformation",ii - if (iprint.gt.1) then - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - endif - if (iprint.gt.0) write (iout,*) - & "This conformation WILL NOT be added to the database." - conf_check=.false. - return - endif - enddo - do j=nnt,nct - itj=itype(j) - if (itype(j).ne.10 .and. (vbld(nres+j)-dsc(itj)).gt.2.0d0) then - if (iprint.gt.0) - & write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j), - & " for conformation",ii - if (iprint.gt.1) then - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - endif - if (iprint.gt.0) write (iout,*) - & "This conformation WILL NOT be added to the database." - conf_check=.false. - return - endif - enddo - do j=3,nres - if (theta(j).le.0.0d0) then - if (iprint.gt.0) - & write (iout,*) "Zero theta angle(s) in conformation",ii - if (iprint.gt.1) then - write (iout,*) "The Cartesian geometry is:" - write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) - write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - write (iout,*) "The internal geometry is:" - write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) - write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) - write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) - write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) - write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) - write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) - endif - if (iprint.gt.0) write (iout,*) - & "This conformation WILL NOT be added to the database." - conf_check=.false. - return - endif - if (theta(j).gt.179.97*deg2rad) theta(j)=179.97*deg2rad - enddo - conf_check=.true. -c write (iout,*) "conf_check passed",ii - return - end diff --git a/source/wham/src-NEWSC/energy_p_new.F b/source/wham/src-NEWSC/energy_p_new.F deleted file mode 100755 index 113d499..0000000 --- a/source/wham/src-NEWSC/energy_p_new.F +++ /dev/null @@ -1,9193 +0,0 @@ - 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) -#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' - 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,106) ipot -C Lennard-Jones potential. - 101 call elj(evdw,evdw_t) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk(evdw,evdw_t) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp(evdw,evdw_t) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb(evdw,evdw_t) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv(evdw,evdw_t) - goto 107 -C New SC-SC potential - 106 call emomo(evdw,evdw_p,evdw_m) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 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) -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) -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 write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t -#ifdef SPLITELE - 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+nss*ebr+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 -#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+nss*ebr+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 -#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 -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 - 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) - 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) - enddo -#else - do i=1,nct - do j=1,3 - 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) - 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) - 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) - & +wsccor*fact(1)*gsccor_loc(i) - enddo - endif - 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' - 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) -#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,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)'/ - & '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,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)'/ - & '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 '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' - 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 - evdw_t=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) - if (bb(itypi,itypj).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 (r.< -c! om = omega, sqom = om^2 - sqom1 = om1 * om1 - sqom2 = om2 * om2 - sqom12 = om12 * om12 - -c! now we calculate EGB - Gey-Berne -c! It will be summed up in evdwij and saved in evdw - sigsq = 1.0D0 / sigsq - sig = sig0ij * dsqrt(sigsq) -c! rij_shift = 1.0D0 / rij - sig + sig0ij - rij_shift = Rtail - sig + sig0ij -c write (2,*) "Rtal",Rtail," sig",sig," sigsq",sigsq, -c & " sig0ij",sig0ij -c write (2,*) "rij_shift",rij_shift - IF (rij_shift.le.0.0D0) THEN - evdw = 1.0D20 - RETURN - END IF - sigder = -sig * sigsq - rij_shift = 1.0D0 / rij_shift - fac = rij_shift**expon - c1 = fac * fac * aa(itypi,itypj) -#ifdef SCALREP -! Scale down the repulsive term for 1,4 interactions. - if (iabs(j-i).le.4) c1 = 0.01d0 * c1 -#endif -c! c1 = 0.0d0 - c2 = fac * bb(itypi,itypj) -c! c2 = 0.0d0 -c write (2,*) "eps1",eps1," eps2rt",eps2rt," eps3rt",eps3rt, -c & " c1",c1," c2",c2 - evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) - eps2der = eps3rt * evdwij - eps3der = eps2rt * evdwij -c! evdwij = 4.0d0 * eps2rt * eps3rt * evdwij - evdwij = eps2rt * eps3rt * evdwij -c! evdwij = 0.0d0 -c! write (*,*) "Gey Berne = ", evdwij -#ifdef TSCSC - IF (bb(itypi,itypj).gt.0) THEN - evdw_p = evdw_p + evdwij - ELSE - evdw_m = evdw_m + evdwij - END IF -#else - evdw = evdw - & + evdwij -#endif -c!------------------------------------------------------------------- -c! Calculate some components of GGB - c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 - fac = -expon * (c1 + evdwij) * rij_shift - sigder = fac * sigder -c! fac = rij * fac -c! Calculate distance derivative -c! gg(1) = xj * fac -c! gg(2) = yj * fac -c! gg(3) = zj * fac - gg(1) = fac - gg(2) = fac - gg(3) = fac -c! write (*,*) "gg(1) = ", gg(1) -c! write (*,*) "gg(2) = ", gg(2) -c! write (*,*) "gg(3) = ", gg(3) -c! The angular derivatives of GGB are brought together in sc_grad -c!------------------------------------------------------------------- -c! Fcav -c! -c! Catch gly-gly interactions to skip calculation of something that -c! does not exist - - IF (itypi.eq.10.and.itypj.eq.10) THEN - Fcav = 0.0d0 - dFdR = 0.0d0 - dCAVdOM1 = 0.0d0 - dCAVdOM2 = 0.0d0 - dCAVdOM12 = 0.0d0 - ELSE - -c! we are not 2 glycines, so we calculate Fcav (and maybe more) - fac = chis1 * sqom1 + chis2 * sqom2 - & - 2.0d0 * chis12 * om1 * om2 * om12 -c! we will use pom later in Gcav, so dont mess with it! - pom = 1.0d0 - chis1 * chis2 * sqom12 - - Lambf = (1.0d0 - (fac / pom)) - Lambf = dsqrt(Lambf) - - - sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0) -c! write (*,*) "sparrow = ", sparrow - Chif = Rtail * sparrow - ChiLambf = Chif * Lambf - eagle = dsqrt(ChiLambf) - bat = ChiLambf ** 11.0d0 - - top = b1 * ( eagle + b2 * ChiLambf - b3 ) - bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0) - botsq = bot * bot - -c! write (*,*) "sig1 = ",sig1 -c! write (*,*) "sig2 = ",sig2 -c! write (*,*) "Rtail = ",Rtail -c! write (*,*) "sparrow = ",sparrow -c! write (*,*) "Chis1 = ", chis1 -c! write (*,*) "Chis2 = ", chis2 -c! write (*,*) "Chis12 = ", chis12 -c! write (*,*) "om1 = ", om1 -c! write (*,*) "om2 = ", om2 -c! write (*,*) "om12 = ", om12 -c! write (*,*) "sqom1 = ", sqom1 -c! write (*,*) "sqom2 = ", sqom2 -c! write (*,*) "sqom12 = ", sqom12 -c! write (*,*) "Lambf = ",Lambf -c! write (*,*) "b1 = ",b1 -c! write (*,*) "b2 = ",b2 -c! write (*,*) "b3 = ",b3 -c! write (*,*) "b4 = ",b4 -c! write (*,*) "top = ",top -c! write (*,*) "bot = ",bot - Fcav = top / bot -c! Fcav = 0.0d0 -c! write (*,*) "Fcav = ", Fcav -c!------------------------------------------------------------------- -c! derivative of Fcav is Gcav... -c!--------------------------------------------------- - - dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf)) - dbot = 12.0d0 * b4 * bat * Lambf - dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow -c! dFdR = 0.0d0 -c! write (*,*) "dFcav/dR = ", dFdR - - dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif)) - dbot = 12.0d0 * b4 * bat * Chif - eagle = Lambf * pom - dFdOM1 = -(chis1 * om1 - chis12 * om2 * om12) / (eagle) - dFdOM2 = -(chis2 * om2 - chis12 * om1 * om12) / (eagle) - dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) - & * (chis2 * om2 * om12 - om1) / (eagle * pom) - - dFdL = ((dtop * bot - top * dbot) / botsq) -c! dFdL = 0.0d0 - dCAVdOM1 = dFdL * ( dFdOM1 ) - dCAVdOM2 = dFdL * ( dFdOM2 ) - dCAVdOM12 = dFdL * ( dFdOM12 ) -c! write (*,*) "dFcav/dOM1 = ", dCAVdOM1 -c! write (*,*) "dFcav/dOM2 = ", dCAVdOM2 -c! write (*,*) "dFcav/dOM12 = ", dCAVdOM12 -c! write (*,*) "" -c!------------------------------------------------------------------- -c! Finally, add the distance derivatives of GB and Fcav to gvdwc -c! Pom is used here to project the gradient vector into -c! cartesian coordinates and at the same time contains -c! dXhb/dXsc derivative (for charged amino acids -c! location of hydrophobic centre of interaction is not -c! the same as geometric centre of side chain, this -c! derivative takes that into account) -c! derivatives of omega angles will be added in sc_grad - - DO k= 1, 3 - ertail(k) = Rtail_distance(k)/Rtail - END DO - erdxi = scalar( ertail(1), dC_norm(1,i+nres) ) - erdxj = scalar( ertail(1), dC_norm(1,j+nres) ) - facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres) - facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres) - DO k = 1, 3 -c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) -c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) - pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres)) - gvdwx(k,i) = gvdwx(k,i) - & - (( dFdR + gg(k) ) * pom) -c! & - ( dFdR * pom ) - pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres)) - gvdwx(k,j) = gvdwx(k,j) - & + (( dFdR + gg(k) ) * pom) -c! & + ( dFdR * pom ) - - gvdwc(k,i) = gvdwc(k,i) - & - (( dFdR + gg(k) ) * ertail(k)) -c! & - ( dFdR * ertail(k)) - - gvdwc(k,j) = gvdwc(k,j) - & + (( dFdR + gg(k) ) * ertail(k)) -c! & + ( dFdR * ertail(k)) - - gg(k) = 0.0d0 -c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) -c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) - END DO - -c!------------------------------------------------------------------- -c! Compute head-head and head-tail energies for each state - - isel = iabs(Qi) + iabs(Qj) - IF (isel.eq.0) THEN -c! No charges - do nothing - eheadtail = 0.0d0 - - ELSE IF (isel.eq.4) THEN -c! Calculate dipole-dipole interactions - CALL edd(ecl) - eheadtail = ECL - - ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN -c! Charge-nonpolar interactions - CALL eqn(epol) - eheadtail = epol - - ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN -c! Nonpolar-charge interactions - CALL enq(epol) - eheadtail = epol - - ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN -c! Charge-dipole interactions - CALL eqd(ecl, elj, epol) - eheadtail = ECL + elj + epol - - ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN -c! Dipole-charge interactions - CALL edq(ecl, elj, epol) - eheadtail = ECL + elj + epol - - ELSE IF ((isel.eq.2.and. - & iabs(Qi).eq.1).and. - & nstate(itypi,itypj).eq.1) THEN -c! Same charge-charge interaction ( +/+ or -/- ) - CALL eqq(Ecl,Egb,Epol,Fisocav,Elj) - eheadtail = ECL + Egb + Epol + Fisocav + Elj - - ELSE IF ((isel.eq.2.and. - & iabs(Qi).eq.1).and. - & nstate(itypi,itypj).ne.1) THEN -c! Different charge-charge interaction ( +/- or -/+ ) - CALL energy_quad - & (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) - END IF - END IF ! this endif ends the "catch the gly-gly" at the beggining of Fcav -c! write (*,*) "evdw = ", evdw -c! write (*,*) "Fcav = ", Fcav -c! write (*,*) "eheadtail = ", eheadtail - evdw = evdw - & + Fcav - & + eheadtail - - IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') - & restyp(itype(i)),i,restyp(itype(j)),j, - & 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj, - & Equad,evdwij+Fcav+eheadtail,evdw -c IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)') -c & restyp(itype(i)),i,restyp(itype(j)),j, -c & 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj, -c & Equad,evdwij+Fcav+eheadtail,evdw -#IFDEF CHECK_MOMO - evdw = 0.0d0 - END DO ! troll -#ENDIF - -c!------------------------------------------------------------------- -c! As all angular derivatives are done, now we sum them up, -c! then transform and project into cartesian vectors and add to gvdwc -c! We call sc_grad always, with the exception of +/- interaction. -c! This is because energy_quad subroutine needs to handle -c! this job in his own way. -c! This IS probably not very efficient and SHOULD be optimised -c! but it will require major restructurization of emomo -c! so it will be left as it is for now -c! write (*,*) 'troll1, nstate =', nstate (itypi,itypj) - IF (nstate(itypi,itypj).eq.1) THEN -#ifdef TSCSC - IF (bb(itypi,itypj).gt.0) THEN - CALL sc_grad - ELSE - CALL sc_grad_T - END IF -#else - CALL sc_grad -#endif - END IF -c!------------------------------------------------------------------- -c! NAPISY KONCOWE - END DO ! j - END DO ! iint - END DO ! i - if (energy_dec) write (iout,*) "evdw before exiting emomo:",evdw -c write (iout,*) "Number of loop steps in EGB:",ind -c energy_dec=.false. - RETURN - END SUBROUTINE emomo -c! END OF MOMO - - -C----------------------------------------------------------------------------- - - - SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar, facd3, facd4, federmaus, adler -c! Epol and Gpol analytical parameters - alphapol1 = alphapol(itypi,itypj) - alphapol2 = alphapol(itypj,itypi) -c! Fisocav and Gisocav analytical parameters - al1 = alphiso(1,itypi,itypj) - al2 = alphiso(2,itypi,itypj) - al3 = alphiso(3,itypi,itypj) - al4 = alphiso(4,itypi,itypj) - csig = (1.0d0 - & / dsqrt(sigiso1(itypi, itypj)**2.0d0 - & + sigiso2(itypi,itypj)**2.0d0)) -c! - pis = sig0head(itypi,itypj) - eps_head = epshead(itypi,itypj) - Rhead_sq = Rhead * Rhead -c! R1 - distance between head of ith side chain and tail of jth sidechain -c! R2 - distance between head of jth side chain and tail of ith sidechain - R1 = 0.0d0 - R2 = 0.0d0 - DO k = 1, 3 -c! Calculate head-to-tail distances needed by Epol - R1=R1+(ctail(k,2)-chead(k,1))**2 - R2=R2+(chead(k,2)-ctail(k,1))**2 - END DO -c! Pitagoras - R1 = dsqrt(R1) - R2 = dsqrt(R2) - -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,1,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,1,itypi,itypj))**2)) - -c!------------------------------------------------------------------- -c! Coulomb electrostatic interaction - Ecl = (332.0d0 * Qij) / Rhead -c! derivative of Ecl is Gcl... - dGCLdR = (-332.0d0 * Qij ) / Rhead_sq - dGCLdOM1 = 0.0d0 - dGCLdOM2 = 0.0d0 - dGCLdOM12 = 0.0d0 -c!------------------------------------------------------------------- -c! Generalised Born Solvent Polarization -c! Charged head polarizes the solvent - ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) - Fgb = sqrt( ( Rhead_sq ) + a12sq * ee) - Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb -c! Derivative of Egb is Ggb... - dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb) - dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) ) - & / ( 2.0d0 * Fgb ) - dGGBdR = dGGBdFGB * dFGBdR -c!------------------------------------------------------------------- -c! Fisocav - isotropic cavity creation term -c! or "how much energy it costs to put charged head in water" - pom = Rhead * csig - top = al1 * (dsqrt(pom) + al2 * pom - al3) - bot = (1.0d0 + al4 * pom**12.0d0) - botsq = bot * bot - FisoCav = top / bot -c! write (*,*) "Rhead = ",Rhead -c! write (*,*) "csig = ",csig -c! write (*,*) "pom = ",pom -c! write (*,*) "al1 = ",al1 -c! write (*,*) "al2 = ",al2 -c! write (*,*) "al3 = ",al3 -c! write (*,*) "al4 = ",al4 -c! write (*,*) "top = ",top -c! write (*,*) "bot = ",bot -c! Derivative of Fisocav is GCV... - dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) - dbot = 12.0d0 * al4 * pom ** 11.0d0 - dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig -c!------------------------------------------------------------------- -c! Epol -c! Polarization energy - charged heads polarize hydrophobic "neck" - MomoFac1 = (1.0d0 - chi1 * sqom2) - MomoFac2 = (1.0d0 - chi2 * sqom1) - RR1 = ( R1 * R1 ) / MomoFac1 - RR2 = ( R2 * R2 ) / MomoFac2 - ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) - ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) - fgb1 = sqrt( RR1 + a12sq * ee1 ) - fgb2 = sqrt( RR2 + a12sq * ee2 ) - epol = 332.0d0 * eps_inout_fac * ( - & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) -c! epol = 0.0d0 -c write (*,*) "eps_inout_fac = ",eps_inout_fac -c write (*,*) "alphapol1 = ", alphapol1 -c write (*,*) "alphapol2 = ", alphapol2 -c write (*,*) "fgb1 = ", fgb1 -c write (*,*) "fgb2 = ", fgb2 -c write (*,*) "epol = ", epol -c! derivative of Epol is Gpol... - dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) - & / (fgb1 ** 5.0d0) - dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) - & / (fgb2 ** 5.0d0) - dFGBdR1 = ( (R1 / MomoFac1) - & * ( 2.0d0 - (0.5d0 * ee1) ) ) - & / ( 2.0d0 * fgb1 ) - dFGBdR2 = ( (R2 / MomoFac2) - & * ( 2.0d0 - (0.5d0 * ee2) ) ) - & / ( 2.0d0 * fgb2 ) - dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) - & * ( 2.0d0 - 0.5d0 * ee1) ) - & / ( 2.0d0 * fgb1 ) - dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) - & * ( 2.0d0 - 0.5d0 * ee2) ) - & / ( 2.0d0 * fgb2 ) - dPOLdR1 = dPOLdFGB1 * dFGBdR1 -c! dPOLdR1 = 0.0d0 - dPOLdR2 = dPOLdFGB2 * dFGBdR2 -c! dPOLdR2 = 0.0d0 - dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 -c! dPOLdOM1 = 0.0d0 - dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 -c! dPOLdOM2 = 0.0d0 -c!------------------------------------------------------------------- -c! Elj -c! Lennard-Jones 6-12 interaction between heads - pom = (pis / Rhead)**6.0d0 - Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) -c! derivative of Elj is Glj - dGLJdR = 4.0d0 * eps_head - & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) - & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) -c!------------------------------------------------------------------- -c! Return the results -c! These things do the dRdX derivatives, that is -c! allow us to change what we see from function that changes with -c! distance to function that changes with LOCATION (of the interaction -c! site) - DO k = 1, 3 - erhead(k) = Rhead_distance(k)/Rhead - erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) - erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) - END DO - - erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) - erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) - bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) - federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) - eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) - adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) - facd1 = d1 * vbld_inv(i+nres) - facd2 = d2 * vbld_inv(j+nres) - facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) - facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) - -c! Now we add appropriate partial derivatives (one in each dimension) - DO k = 1, 3 - hawk = (erhead_tail(k,1) + - & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) - condor = (erhead_tail(k,2) + - & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) - - pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) - gvdwx(k,i) = gvdwx(k,i) - & - dGCLdR * pom - & - dGGBdR * pom - & - dGCVdR * pom - & - dPOLdR1 * hawk - & - dPOLdR2 * (erhead_tail(k,2) - & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) - & - dGLJdR * pom - - pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) - gvdwx(k,j) = gvdwx(k,j) - & + dGCLdR * pom - & + dGGBdR * pom - & + dGCVdR * pom - & + dPOLdR1 * (erhead_tail(k,1) - & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) - & + dPOLdR2 * condor - & + dGLJdR * pom - - gvdwc(k,i) = gvdwc(k,i) - & - dGCLdR * erhead(k) - & - dGGBdR * erhead(k) - & - dGCVdR * erhead(k) - & - dPOLdR1 * erhead_tail(k,1) - & - dPOLdR2 * erhead_tail(k,2) - & - dGLJdR * erhead(k) - - gvdwc(k,j) = gvdwc(k,j) - & + dGCLdR * erhead(k) - & + dGGBdR * erhead(k) - & + dGCVdR * erhead(k) - & + dPOLdR1 * erhead_tail(k,1) - & + dPOLdR2 * erhead_tail(k,2) - & + dGLJdR * erhead(k) - - END DO - RETURN - END SUBROUTINE eqq -c!------------------------------------------------------------------- - SUBROUTINE energy_quad - &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar - double precision ener(4) - double precision dcosom1(3),dcosom2(3) -c! used in Epol derivatives - double precision facd3, facd4 - double precision federmaus, adler -c! Epol and Gpol analytical parameters - alphapol1 = alphapol(itypi,itypj) - alphapol2 = alphapol(itypj,itypi) -c! Fisocav and Gisocav analytical parameters - al1 = alphiso(1,itypi,itypj) - al2 = alphiso(2,itypi,itypj) - al3 = alphiso(3,itypi,itypj) - al4 = alphiso(4,itypi,itypj) - csig = (1.0d0 - & / dsqrt(sigiso1(itypi, itypj)**2.0d0 - & + sigiso2(itypi,itypj)**2.0d0)) -c! - w1 = wqdip(1,itypi,itypj) - w2 = wqdip(2,itypi,itypj) - pis = sig0head(itypi,itypj) - eps_head = epshead(itypi,itypj) -c! First things first: -c! We need to do sc_grad's job with GB and Fcav - eom1 = - & eps2der * eps2rt_om1 - & - 2.0D0 * alf1 * eps3der - & + sigder * sigsq_om1 - & + dCAVdOM1 - eom2 = - & eps2der * eps2rt_om2 - & + 2.0D0 * alf2 * eps3der - & + sigder * sigsq_om2 - & + dCAVdOM2 - eom12 = - & evdwij * eps1_om12 - & + eps2der * eps2rt_om12 - & - 2.0D0 * alf12 * eps3der - & + sigder *sigsq_om12 - & + dCAVdOM12 -c! now some magical transformations to project gradient into -c! three cartesian vectors - 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)) - gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k) -c! this acts on hydrophobic center of interaction - 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 -c! this acts on Calpha - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - END DO -c! sc_grad is done, now we will compute - eheadtail = 0.0d0 - eom1 = 0.0d0 - eom2 = 0.0d0 - eom12 = 0.0d0 - -c! ENERGY DEBUG -c! ii = 1 -c! jj = 1 -c! d1 = dhead(1, 1, itypi, itypj) -c! d2 = dhead(2, 1, itypi, itypj) -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,ii,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,jj,itypi,itypj))**2)) -c! Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2)) -c! END OF ENERGY DEBUG -c************************************************************* - DO istate = 1, nstate(itypi,itypj) -c************************************************************* - IF (istate.ne.1) THEN - IF (istate.lt.3) THEN - ii = 1 - ELSE - ii = 2 - END IF - jj = istate/ii - d1 = dhead(1,ii,itypi,itypj) - d2 = dhead(2,jj,itypi,itypj) - DO k = 1,3 - chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) - chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) - Rhead_distance(k) = chead(k,2) - chead(k,1) - END DO -c! pitagoras (root of sum of squares) - Rhead = dsqrt( - & (Rhead_distance(1)*Rhead_distance(1)) - & + (Rhead_distance(2)*Rhead_distance(2)) - & + (Rhead_distance(3)*Rhead_distance(3))) - END IF - Rhead_sq = Rhead * Rhead - -c! R1 - distance between head of ith side chain and tail of jth sidechain -c! R2 - distance between head of jth side chain and tail of ith sidechain - R1 = 0.0d0 - R2 = 0.0d0 - DO k = 1, 3 -c! Calculate head-to-tail distances - R1=R1+(ctail(k,2)-chead(k,1))**2 - R2=R2+(chead(k,2)-ctail(k,1))**2 - END DO -c! Pitagoras - R1 = dsqrt(R1) - R2 = dsqrt(R2) - -c! ENERGY DEBUG -c! write (*,*) "istate = ", istate -c! write (*,*) "ii = ", ii -c! write (*,*) "jj = ", jj -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,ii,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,jj,itypi,itypj))**2)) -c! Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2)) -c! Rhead_sq = Rhead * Rhead -c! write (*,*) "d1 = ",d1 -c! write (*,*) "d2 = ",d2 -c! write (*,*) "R1 = ",R1 -c! write (*,*) "R2 = ",R2 -c! write (*,*) "Rhead = ",Rhead -c! END OF ENERGY DEBUG - -c!------------------------------------------------------------------- -c! Coulomb electrostatic interaction - Ecl = (332.0d0 * Qij) / (Rhead * eps_in) -c! Ecl = 0.0d0 -c! write (*,*) "Ecl = ", Ecl -c! derivative of Ecl is Gcl... - dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in) -c! dGCLdR = 0.0d0 - dGCLdOM1 = 0.0d0 - dGCLdOM2 = 0.0d0 - dGCLdOM12 = 0.0d0 -c!------------------------------------------------------------------- -c! Generalised Born Solvent Polarization - ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) - Fgb = sqrt( ( Rhead_sq ) + a12sq * ee) - Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb -c! Egb = 0.0d0 -c! write (*,*) "a1*a2 = ", a12sq -c! write (*,*) "Rhead = ", Rhead -c! write (*,*) "Rhead_sq = ", Rhead_sq -c! write (*,*) "ee = ", ee -c! write (*,*) "Fgb = ", Fgb -c! write (*,*) "fac = ", eps_inout_fac -c! write (*,*) "Qij = ", Qij -c! write (*,*) "Egb = ", Egb -c! Derivative of Egb is Ggb... -c! dFGBdR is used by Quad's later... - dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb) - dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) ) - & / ( 2.0d0 * Fgb ) - dGGBdR = dGGBdFGB * dFGBdR -c! dGGBdR = 0.0d0 -c!------------------------------------------------------------------- -c! Fisocav - isotropic cavity creation term - pom = Rhead * csig - top = al1 * (dsqrt(pom) + al2 * pom - al3) - bot = (1.0d0 + al4 * pom**12.0d0) - botsq = bot * bot - FisoCav = top / bot -c! FisoCav = 0.0d0 -c! write (*,*) "pom = ",pom -c! write (*,*) "al1 = ",al1 -c! write (*,*) "al2 = ",al2 -c! write (*,*) "al3 = ",al3 -c! write (*,*) "al4 = ",al4 -c! write (*,*) "top = ",top -c! write (*,*) "bot = ",bot -c! write (*,*) "Fisocav = ", Fisocav - -c! Derivative of Fisocav is GCV... - dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) - dbot = 12.0d0 * al4 * pom ** 11.0d0 - dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig -c! dGCVdR = 0.0d0 -c!------------------------------------------------------------------- -c! Polarization energy -c! Epol - MomoFac1 = (1.0d0 - chi1 * sqom2) - MomoFac2 = (1.0d0 - chi2 * sqom1) - RR1 = ( R1 * R1 ) / MomoFac1 - RR2 = ( R2 * R2 ) / MomoFac2 - ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) - ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) - fgb1 = sqrt( RR1 + a12sq * ee1 ) - fgb2 = sqrt( RR2 + a12sq * ee2 ) - epol = 332.0d0 * eps_inout_fac * ( - & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) -c! epol = 0.0d0 -c! derivative of Epol is Gpol... - dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) - & / (fgb1 ** 5.0d0) - dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) - & / (fgb2 ** 5.0d0) - dFGBdR1 = ( (R1 / MomoFac1) - & * ( 2.0d0 - (0.5d0 * ee1) ) ) - & / ( 2.0d0 * fgb1 ) - dFGBdR2 = ( (R2 / MomoFac2) - & * ( 2.0d0 - (0.5d0 * ee2) ) ) - & / ( 2.0d0 * fgb2 ) - dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) - & * ( 2.0d0 - 0.5d0 * ee1) ) - & / ( 2.0d0 * fgb1 ) - dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) - & * ( 2.0d0 - 0.5d0 * ee2) ) - & / ( 2.0d0 * fgb2 ) - dPOLdR1 = dPOLdFGB1 * dFGBdR1 -c! dPOLdR1 = 0.0d0 - dPOLdR2 = dPOLdFGB2 * dFGBdR2 -c! dPOLdR2 = 0.0d0 - dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 -c! dPOLdOM1 = 0.0d0 - dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 -c! dPOLdOM2 = 0.0d0 -c!------------------------------------------------------------------- -c! Elj - pom = (pis / Rhead)**6.0d0 - Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) -c! Elj = 0.0d0 -c! derivative of Elj is Glj - dGLJdR = 4.0d0 * eps_head - & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) - & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) -c! dGLJdR = 0.0d0 -c!------------------------------------------------------------------- -c! Equad - IF (Wqd.ne.0.0d0) THEN - Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) - & - 37.5d0 * ( sqom1 + sqom2 ) - & + 157.5d0 * ( sqom1 * sqom2 ) - & - 45.0d0 * om1*om2*om12 - fac = -( Wqd / (2.0d0 * Fgb**5.0d0) ) - Equad = fac * Beta1 -c! Equad = 0.0d0 -c! derivative of Equad... - dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR -c! dQUADdR = 0.0d0 - dQUADdOM1 = fac - & * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12) -c! dQUADdOM1 = 0.0d0 - dQUADdOM2 = fac - & * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12) -c! dQUADdOM2 = 0.0d0 - dQUADdOM12 = fac - & * ( 6.0d0*om12 - 45.0d0*om1*om2 ) -c! dQUADdOM12 = 0.0d0 - ELSE - Beta1 = 0.0d0 - Equad = 0.0d0 - END IF -c!------------------------------------------------------------------- -c! Return the results -c! Angular stuff - eom1 = dPOLdOM1 + dQUADdOM1 - eom2 = dPOLdOM2 + dQUADdOM2 - eom12 = dQUADdOM12 -c! now some magical transformations to project gradient into -c! three cartesian vectors - 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)) - tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k) - END DO -c! Radial stuff - DO k = 1, 3 - erhead(k) = Rhead_distance(k)/Rhead - erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) - erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) - END DO - erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) - erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) - bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) - federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) - eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) - adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) - facd1 = d1 * vbld_inv(i+nres) - facd2 = d2 * vbld_inv(j+nres) - facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) - facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) -c! Throw the results into gheadtail which holds gradients -c! for each micro-state - DO k = 1, 3 - hawk = erhead_tail(k,1) + - & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)) - condor = erhead_tail(k,2) + - & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)) - - pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) -c! this acts on hydrophobic center of interaction - gheadtail(k,1,1) = gheadtail(k,1,1) - & - dGCLdR * pom - & - dGGBdR * pom - & - dGCVdR * pom - & - dPOLdR1 * hawk - & - dPOLdR2 * (erhead_tail(k,2) - & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) - & - dGLJdR * pom - & - dQUADdR * pom - & - tuna(k) - & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv - - pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) -c! this acts on hydrophobic center of interaction - gheadtail(k,2,1) = gheadtail(k,2,1) - & + dGCLdR * pom - & + dGGBdR * pom - & + dGCVdR * pom - & + dPOLdR1 * (erhead_tail(k,1) - & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) - & + dPOLdR2 * condor - & + dGLJdR * pom - & + dQUADdR * pom - & + tuna(k) - & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - -c! this acts on Calpha - gheadtail(k,3,1) = gheadtail(k,3,1) - & - dGCLdR * erhead(k) - & - dGGBdR * erhead(k) - & - dGCVdR * erhead(k) - & - dPOLdR1 * erhead_tail(k,1) - & - dPOLdR2 * erhead_tail(k,2) - & - dGLJdR * erhead(k) - & - dQUADdR * erhead(k) - & - tuna(k) - -c! this acts on Calpha - gheadtail(k,4,1) = gheadtail(k,4,1) - & + dGCLdR * erhead(k) - & + dGGBdR * erhead(k) - & + dGCVdR * erhead(k) - & + dPOLdR1 * erhead_tail(k,1) - & + dPOLdR2 * erhead_tail(k,2) - & + dGLJdR * erhead(k) - & + dQUADdR * erhead(k) - & + tuna(k) - END DO -c! write(*,*) "ECL = ", Ecl -c! write(*,*) "Egb = ", Egb -c! write(*,*) "Epol = ", Epol -c! write(*,*) "Fisocav = ", Fisocav -c! write(*,*) "Elj = ", Elj -c! write(*,*) "Equad = ", Equad -c! write(*,*) "wstate = ", wstate(istate,itypi,itypj) -c! write(*,*) "eheadtail = ", eheadtail -c! write(*,*) "TROLL = ", dexp(-betaT * ener(istate)) -c! write(*,*) "dGCLdR = ", dGCLdR -c! write(*,*) "dGGBdR = ", dGGBdR -c! write(*,*) "dGCVdR = ", dGCVdR -c! write(*,*) "dPOLdR1 = ", dPOLdR1 -c! write(*,*) "dPOLdR2 = ", dPOLdR2 -c! write(*,*) "dGLJdR = ", dGLJdR -c! write(*,*) "dQUADdR = ", dQUADdR -c! write(*,*) "tuna(",k,") = ", tuna(k) - ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad - eheadtail = eheadtail - & + wstate(istate, itypi, itypj) - & * dexp(-betaT * ener(istate)) -c! foreach cartesian dimension - DO k = 1, 3 -c! foreach of two gvdwx and gvdwc - DO l = 1, 4 - gheadtail(k,l,2) = gheadtail(k,l,2) - & + wstate( istate, itypi, itypj ) - & * dexp(-betaT * ener(istate)) - & * gheadtail(k,l,1) - gheadtail(k,l,1) = 0.0d0 - END DO - END DO - END DO -c! Here ended the gigantic DO istate = 1, 4, which starts -c! at the beggining of the subroutine - - DO k = 1, 3 - DO l = 1, 4 - gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail - END DO - gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2) - gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2) - gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2) - gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2) - DO l = 1, 4 - gheadtail(k,l,1) = 0.0d0 - gheadtail(k,l,2) = 0.0d0 - END DO - END DO - eheadtail = (-dlog(eheadtail)) / betaT - dPOLdOM1 = 0.0d0 - dPOLdOM2 = 0.0d0 - dQUADdOM1 = 0.0d0 - dQUADdOM2 = 0.0d0 - dQUADdOM12 = 0.0d0 - RETURN - END SUBROUTINE energy_quad - - -c!------------------------------------------------------------------- - - - SUBROUTINE eqn(Epol) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar, facd4, federmaus - alphapol1 = alphapol(itypi,itypj) -c! R1 - distance between head of ith side chain and tail of jth sidechain - R1 = 0.0d0 - DO k = 1, 3 -c! Calculate head-to-tail distances - R1=R1+(ctail(k,2)-chead(k,1))**2 - END DO -c! Pitagoras - R1 = dsqrt(R1) - -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,1,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,1,itypi,itypj))**2)) -c-------------------------------------------------------------------- -c Polarization energy -c Epol - MomoFac1 = (1.0d0 - chi1 * sqom2) - RR1 = R1 * R1 / MomoFac1 - ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) - fgb1 = sqrt( RR1 + a12sq * ee1) - epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) -c! epol = 0.0d0 -c!------------------------------------------------------------------ -c! derivative of Epol is Gpol... - dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) - & / (fgb1 ** 5.0d0) - dFGBdR1 = ( (R1 / MomoFac1) - & * ( 2.0d0 - (0.5d0 * ee1) ) ) - & / ( 2.0d0 * fgb1 ) - dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) - & * (2.0d0 - 0.5d0 * ee1) ) - & / (2.0d0 * fgb1) - dPOLdR1 = dPOLdFGB1 * dFGBdR1 -c! dPOLdR1 = 0.0d0 - dPOLdOM1 = 0.0d0 - dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 -c! dPOLdOM2 = 0.0d0 -c!------------------------------------------------------------------- -c! Return the results -c! (see comments in Eqq) - DO k = 1, 3 - erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) - END DO - bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) - federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) - facd1 = d1 * vbld_inv(i+nres) - facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) - - DO k = 1, 3 - hawk = (erhead_tail(k,1) + - & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) - - gvdwx(k,i) = gvdwx(k,i) - & - dPOLdR1 * hawk - gvdwx(k,j) = gvdwx(k,j) - & + dPOLdR1 * (erhead_tail(k,1) - & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) - - gvdwc(k,i) = gvdwc(k,i) - & - dPOLdR1 * erhead_tail(k,1) - gvdwc(k,j) = gvdwc(k,j) - & + dPOLdR1 * erhead_tail(k,1) - - END DO - RETURN - END SUBROUTINE eqn - - -c!------------------------------------------------------------------- - - - - SUBROUTINE enq(Epol) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar, facd3, adler - alphapol2 = alphapol(itypj,itypi) -c! R2 - distance between head of jth side chain and tail of ith sidechain - R2 = 0.0d0 - DO k = 1, 3 -c! Calculate head-to-tail distances - R2=R2+(chead(k,2)-ctail(k,1))**2 - END DO -c! Pitagoras - R2 = dsqrt(R2) - -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,1,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,1,itypi,itypj))**2)) -c------------------------------------------------------------------------ -c Polarization energy - MomoFac2 = (1.0d0 - chi2 * sqom1) - RR2 = R2 * R2 / MomoFac2 - ee2 = exp(-(RR2 / (4.0d0 * a12sq))) - fgb2 = sqrt(RR2 + a12sq * ee2) - epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) -c! epol = 0.0d0 -c!------------------------------------------------------------------- -c! derivative of Epol is Gpol... - dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) - & / (fgb2 ** 5.0d0) - dFGBdR2 = ( (R2 / MomoFac2) - & * ( 2.0d0 - (0.5d0 * ee2) ) ) - & / (2.0d0 * fgb2) - dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) - & * (2.0d0 - 0.5d0 * ee2) ) - & / (2.0d0 * fgb2) - dPOLdR2 = dPOLdFGB2 * dFGBdR2 -c! dPOLdR2 = 0.0d0 - dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 -c! dPOLdOM1 = 0.0d0 - dPOLdOM2 = 0.0d0 -c!------------------------------------------------------------------- -c! Return the results -c! (See comments in Eqq) - DO k = 1, 3 - erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) - END DO - eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) - adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) - facd2 = d2 * vbld_inv(j+nres) - facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) - DO k = 1, 3 - condor = (erhead_tail(k,2) - & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) - - gvdwx(k,i) = gvdwx(k,i) - & - dPOLdR2 * (erhead_tail(k,2) - & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) - gvdwx(k,j) = gvdwx(k,j) - & + dPOLdR2 * condor - - gvdwc(k,i) = gvdwc(k,i) - & - dPOLdR2 * erhead_tail(k,2) - gvdwc(k,j) = gvdwc(k,j) - & + dPOLdR2 * erhead_tail(k,2) - - END DO - RETURN - END SUBROUTINE enq - - -c!------------------------------------------------------------------- - - - SUBROUTINE eqd(Ecl,Elj,Epol) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar, facd4, federmaus - alphapol1 = alphapol(itypi,itypj) - w1 = wqdip(1,itypi,itypj) - w2 = wqdip(2,itypi,itypj) - pis = sig0head(itypi,itypj) - eps_head = epshead(itypi,itypj) -c!------------------------------------------------------------------- -c! R1 - distance between head of ith side chain and tail of jth sidechain - R1 = 0.0d0 - DO k = 1, 3 -c! Calculate head-to-tail distances - R1=R1+(ctail(k,2)-chead(k,1))**2 - END DO -c! Pitagoras - R1 = dsqrt(R1) - -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,1,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,1,itypi,itypj))**2)) - -c!------------------------------------------------------------------- -c! ecl - sparrow = w1 * Qi * om1 - hawk = w2 * Qi * Qi * (1.0d0 - sqom2) - Ecl = sparrow / Rhead**2.0d0 - & - hawk / Rhead**4.0d0 -c!------------------------------------------------------------------- -c! derivative of ecl is Gcl -c! dF/dr part - dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 - & + 4.0d0 * hawk / Rhead**5.0d0 -c! dF/dom1 - dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) -c! dF/dom2 - dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) -c-------------------------------------------------------------------- -c Polarization energy -c Epol - MomoFac1 = (1.0d0 - chi1 * sqom2) - RR1 = R1 * R1 / MomoFac1 - ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) - fgb1 = sqrt( RR1 + a12sq * ee1) - epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) -c! epol = 0.0d0 -c!------------------------------------------------------------------ -c! derivative of Epol is Gpol... - dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) - & / (fgb1 ** 5.0d0) - dFGBdR1 = ( (R1 / MomoFac1) - & * ( 2.0d0 - (0.5d0 * ee1) ) ) - & / ( 2.0d0 * fgb1 ) - dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) - & * (2.0d0 - 0.5d0 * ee1) ) - & / (2.0d0 * fgb1) - dPOLdR1 = dPOLdFGB1 * dFGBdR1 -c! dPOLdR1 = 0.0d0 - dPOLdOM1 = 0.0d0 - dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 -c! dPOLdOM2 = 0.0d0 -c!------------------------------------------------------------------- -c! Elj - pom = (pis / Rhead)**6.0d0 - Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) -c! derivative of Elj is Glj - dGLJdR = 4.0d0 * eps_head - & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) - & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) -c!------------------------------------------------------------------- -c! Return the results - DO k = 1, 3 - erhead(k) = Rhead_distance(k)/Rhead - erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) - END DO - - erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) - erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) - bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) - federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) - facd1 = d1 * vbld_inv(i+nres) - facd2 = d2 * vbld_inv(j+nres) - facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) - - DO k = 1, 3 - hawk = (erhead_tail(k,1) + - & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) - - pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) - gvdwx(k,i) = gvdwx(k,i) - & - dGCLdR * pom - & - dPOLdR1 * hawk - & - dGLJdR * pom - - pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) - gvdwx(k,j) = gvdwx(k,j) - & + dGCLdR * pom - & + dPOLdR1 * (erhead_tail(k,1) - & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) - & + dGLJdR * pom - - - gvdwc(k,i) = gvdwc(k,i) - & - dGCLdR * erhead(k) - & - dPOLdR1 * erhead_tail(k,1) - & - dGLJdR * erhead(k) - - gvdwc(k,j) = gvdwc(k,j) - & + dGCLdR * erhead(k) - & + dPOLdR1 * erhead_tail(k,1) - & + dGLJdR * erhead(k) - - END DO - RETURN - END SUBROUTINE eqd - - -c!------------------------------------------------------------------- - - - SUBROUTINE edq(Ecl,Elj,Epol) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar, facd3, adler - alphapol2 = alphapol(itypj,itypi) - w1 = wqdip(1,itypi,itypj) - w2 = wqdip(2,itypi,itypj) - pis = sig0head(itypi,itypj) - eps_head = epshead(itypi,itypj) -c!------------------------------------------------------------------- -c! R2 - distance between head of jth side chain and tail of ith sidechain - R2 = 0.0d0 - DO k = 1, 3 -c! Calculate head-to-tail distances - R2=R2+(chead(k,2)-ctail(k,1))**2 - END DO -c! Pitagoras - R2 = dsqrt(R2) - -c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) -c! & +dhead(1,1,itypi,itypj))**2)) -c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) -c! & +dhead(2,1,itypi,itypj))**2)) - - -c!------------------------------------------------------------------- -c! ecl - sparrow = w1 * Qi * om1 - hawk = w2 * Qi * Qi * (1.0d0 - sqom2) - ECL = sparrow / Rhead**2.0d0 - & - hawk / Rhead**4.0d0 -c!------------------------------------------------------------------- -c! derivative of ecl is Gcl -c! dF/dr part - dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 - & + 4.0d0 * hawk / Rhead**5.0d0 -c! dF/dom1 - dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) -c! dF/dom2 - dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) -c-------------------------------------------------------------------- -c Polarization energy -c Epol - MomoFac2 = (1.0d0 - chi2 * sqom1) - RR2 = R2 * R2 / MomoFac2 - ee2 = exp(-(RR2 / (4.0d0 * a12sq))) - fgb2 = sqrt(RR2 + a12sq * ee2) - epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) -c! epol = 0.0d0 -c! derivative of Epol is Gpol... - dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) - & / (fgb2 ** 5.0d0) - dFGBdR2 = ( (R2 / MomoFac2) - & * ( 2.0d0 - (0.5d0 * ee2) ) ) - & / (2.0d0 * fgb2) - dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) - & * (2.0d0 - 0.5d0 * ee2) ) - & / (2.0d0 * fgb2) - dPOLdR2 = dPOLdFGB2 * dFGBdR2 -c! dPOLdR2 = 0.0d0 - dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 -c! dPOLdOM1 = 0.0d0 - dPOLdOM2 = 0.0d0 -c!------------------------------------------------------------------- -c! Elj - pom = (pis / Rhead)**6.0d0 - Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) -c! derivative of Elj is Glj - dGLJdR = 4.0d0 * eps_head - & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) - & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) -c!------------------------------------------------------------------- -c! Return the results -c! (see comments in Eqq) - DO k = 1, 3 - erhead(k) = Rhead_distance(k)/Rhead - erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) - END DO - erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) - erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) - eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) - adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) - facd1 = d1 * vbld_inv(i+nres) - facd2 = d2 * vbld_inv(j+nres) - facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) - - DO k = 1, 3 - condor = (erhead_tail(k,2) - & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) - - pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) - gvdwx(k,i) = gvdwx(k,i) - & - dGCLdR * pom - & - dPOLdR2 * (erhead_tail(k,2) - & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) - & - dGLJdR * pom - - pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) - gvdwx(k,j) = gvdwx(k,j) - & + dGCLdR * pom - & + dPOLdR2 * condor - & + dGLJdR * pom - - - gvdwc(k,i) = gvdwc(k,i) - & - dGCLdR * erhead(k) - & - dPOLdR2 * erhead_tail(k,2) - & - dGLJdR * erhead(k) - - gvdwc(k,j) = gvdwc(k,j) - & + dGCLdR * erhead(k) - & + dPOLdR2 * erhead_tail(k,2) - & + dGLJdR * erhead(k) - - END DO - RETURN - END SUBROUTINE edq - - -C-------------------------------------------------------------------- - - - SUBROUTINE edd(ECL) - IMPLICIT NONE - INCLUDE 'DIMENSIONS' - INCLUDE 'DIMENSIONS.ZSCOPT' - INCLUDE 'COMMON.CALC' - INCLUDE 'COMMON.CHAIN' - INCLUDE 'COMMON.CONTROL' - INCLUDE 'COMMON.DERIV' - INCLUDE 'COMMON.EMP' - INCLUDE 'COMMON.GEO' - INCLUDE 'COMMON.INTERACT' - INCLUDE 'COMMON.IOUNITS' - INCLUDE 'COMMON.LOCAL' - INCLUDE 'COMMON.NAMES' - INCLUDE 'COMMON.VAR' - double precision scalar -c! csig = sigiso(itypi,itypj) - w1 = wqdip(1,itypi,itypj) - w2 = wqdip(2,itypi,itypj) -c!------------------------------------------------------------------- -c! ECL - fac = (om12 - 3.0d0 * om1 * om2) - c1 = (w1 / (Rhead**3.0d0)) * fac - c2 = (w2 / Rhead ** 6.0d0) - & * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) - ECL = c1 - c2 -c! write (*,*) "w1 = ", w1 -c! write (*,*) "w2 = ", w2 -c! write (*,*) "om1 = ", om1 -c! write (*,*) "om2 = ", om2 -c! write (*,*) "om12 = ", om12 -c! write (*,*) "fac = ", fac -c! write (*,*) "c1 = ", c1 -c! write (*,*) "c2 = ", c2 -c! write (*,*) "Ecl = ", Ecl -c! write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0) -c! write (*,*) "c2_2 = ", -c! & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) -c!------------------------------------------------------------------- -c! dervative of ECL is GCL... -c! dECL/dr - c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0) - c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) - & * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2)) - dGCLdR = c1 - c2 -c! dECL/dom1 - c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0) - c2 = (-6.0d0 * w2) / (Rhead**6.0d0) - & * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 ) - dGCLdOM1 = c1 - c2 -c! dECL/dom2 - c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0) - c2 = (-6.0d0 * w2) / (Rhead**6.0d0) - & * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 ) - dGCLdOM2 = c1 - c2 -c! dECL/dom12 - c1 = w1 / (Rhead ** 3.0d0) - c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0 - dGCLdOM12 = c1 - c2 -c!------------------------------------------------------------------- -c! Return the results -c! (see comments in Eqq) - DO k= 1, 3 - erhead(k) = Rhead_distance(k)/Rhead - END DO - erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) - erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) - facd1 = d1 * vbld_inv(i+nres) - facd2 = d2 * vbld_inv(j+nres) - DO k = 1, 3 - - pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) - gvdwx(k,i) = gvdwx(k,i) - & - dGCLdR * pom - pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) - gvdwx(k,j) = gvdwx(k,j) - & + dGCLdR * pom - - gvdwc(k,i) = gvdwc(k,i) - & - dGCLdR * erhead(k) - gvdwc(k,j) = gvdwc(k,j) - & + dGCLdR * erhead(k) - END DO - RETURN - END SUBROUTINE edd - - -c!------------------------------------------------------------------- - - - SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol) - IMPLICIT NONE -c! maxres - INCLUDE 'DIMENSIONS' -c! itypi, itypj, i, j, k, l, chead, - INCLUDE 'COMMON.CALC' -c! c, nres, dc_norm - INCLUDE 'COMMON.CHAIN' -c! gradc, gradx - INCLUDE 'COMMON.DERIV' -c! electrostatic gradients-specific variables - INCLUDE 'COMMON.EMP' -c! wquad, dhead, alphiso, alphasur, rborn, epsintab - INCLUDE 'COMMON.INTERACT' -c! io for debug, disable it in final builds - INCLUDE 'COMMON.IOUNITS' -c!------------------------------------------------------------------- -c! Variable Init - -c! what amino acid is the aminoacid j'th? - itypj = itype(j) -c! 1/(Gas Constant * Thermostate temperature) = BetaT -c! ENABLE THIS LINE WHEN USING CHECKGRAD!!! - BetaT = 1.0d0 / (298 * 1.987d-3) -c! Gay-berne var's - sig0ij = sigma( itypi,itypj ) - chi1 = chi( itypi, itypj ) - chi2 = chi( itypj, itypi ) - chi12 = chi1 * chi2 - chip1 = chipp( itypi, itypj ) - chip2 = chipp( itypj, itypi ) - chip12 = chip1 * chip2 -c! write (2,*) "elgrad types",itypi,itypj, -c! & " chi1",chi1," chi2",chi2," chi12",chi12, -c! & " chip1",chip1," chip2",chip2," chip12",chip12 -c! not used by momo potential, but needed by sc_angular which is shared -c! by all energy_potential subroutines - alf1 = 0.0d0 - alf2 = 0.0d0 - alf12 = 0.0d0 -c! location, location, location - 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 ) -c! distance from center of chain(?) to polar/charged head -c! write (*,*) "istate = ", 1 -c! write (*,*) "ii = ", 1 -c! write (*,*) "jj = ", 1 - d1 = dhead(1, 1, itypi, itypj) - d2 = dhead(2, 1, itypi, itypj) -c! ai*aj from Fgb - a12sq = rborn(itypi,itypj) * rborn(itypj,itypi) -c! a12sq = a12sq * a12sq -c! charge of amino acid itypi is... - Qi = icharge(itypi) - Qj = icharge(itypj) - Qij = Qi * Qj -c! chis1,2,12 - chis1 = chis(itypi,itypj) - chis2 = chis(itypj,itypi) - chis12 = chis1 * chis2 - sig1 = sigmap1(itypi,itypj) - sig2 = sigmap2(itypi,itypj) -c! write (*,*) "sig1 = ", sig1 -c! write (*,*) "sig2 = ", sig2 -c! alpha factors from Fcav/Gcav - b1 = alphasur(1,itypi,itypj) - b2 = alphasur(2,itypi,itypj) - b3 = alphasur(3,itypi,itypj) - b4 = alphasur(4,itypi,itypj) -c! used to determine whether we want to do quadrupole calculations - wqd = wquad(itypi, itypj) -c! used by Fgb - eps_in = epsintab(itypi,itypj) - eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) -c! write (*,*) "eps_inout_fac = ", eps_inout_fac -c!------------------------------------------------------------------- -c! tail location and distance calculations - Rtail = 0.0d0 - DO k = 1, 3 - ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i) - ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j) - END DO -c! tail distances will be themselves usefull elswhere -c1 (in Gcav, for example) - Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 ) - Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 ) - Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 ) - Rtail = dsqrt( - & (Rtail_distance(1)*Rtail_distance(1)) - & + (Rtail_distance(2)*Rtail_distance(2)) - & + (Rtail_distance(3)*Rtail_distance(3))) -c!------------------------------------------------------------------- -c! Calculate location and distance between polar heads -c! distance between heads -c! for each one of our three dimensional space... - DO k = 1,3 -c! location of polar head is computed by taking hydrophobic centre -c! and moving by a d1 * dc_norm vector -c! see unres publications for very informative images - chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) - chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) -c! distance -c! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) -c! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) - Rhead_distance(k) = chead(k,2) - chead(k,1) - END DO -c! pitagoras (root of sum of squares) - Rhead = dsqrt( - & (Rhead_distance(1)*Rhead_distance(1)) - & + (Rhead_distance(2)*Rhead_distance(2)) - & + (Rhead_distance(3)*Rhead_distance(3))) -c!------------------------------------------------------------------- -c! zero everything that should be zero'ed - Egb = 0.0d0 - ECL = 0.0d0 - Elj = 0.0d0 - Equad = 0.0d0 - Epol = 0.0d0 - eheadtail = 0.0d0 - dGCLdOM1 = 0.0d0 - dGCLdOM2 = 0.0d0 - dGCLdOM12 = 0.0d0 - dPOLdOM1 = 0.0d0 - dPOLdOM2 = 0.0d0 - RETURN - END SUBROUTINE elgrad_init -c!------------------------------------------------------------------- - subroutine sc_angular -C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2, -C om12. Called by ebp, egb, and egbv. - implicit none - include 'COMMON.CALC' - include 'COMMON.IOUNITS' - erij(1)=xj*rij - erij(2)=yj*rij - erij(3)=zj*rij - om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) - om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) - om12=dxi*dxj+dyi*dyj+dzi*dzj -c! om1 = 0.0d0 -c! om2 = 0.0d0 -c! om12 = 0.0d0 - chiom12=chi12*om12 -C Calculate eps1(om12) and its derivative in om12 - faceps1=1.0D0-om12*chiom12 - faceps1_inv=1.0D0/faceps1 - eps1=dsqrt(faceps1_inv) -c write (2,*) "chi1",chi1," chi2",chi2," chi12",chi12 -c write (2,*) "fsceps1",faceps1," faceps1_inv",faceps1_inv, -c & " eps1",eps1 -C Following variable is eps1*deps1/dom12 - eps1_om12=faceps1_inv*chiom12 -c diagnostics only -c faceps1_inv=om12 -c eps1=om12 -c eps1_om12=1.0d0 -c write (iout,*) "om12",om12," eps1",eps1 -C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2, -C and om12. - om1om2=om1*om2 - chiom1=chi1*om1 - chiom2=chi2*om2 - facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12 - sigsq=1.0D0-facsig*faceps1_inv -c write (2,*) "om1",om1," om2",om2," om1om2",om1om2, -c & " chiom1",chiom1, -c & " chiom2",chiom2," facsig",facsig," sigsq",sigsq - sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv - sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv - sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2 -c diagnostics only -c sigsq=1.0d0 -c sigsq_om1=0.0d0 -c sigsq_om2=0.0d0 -c sigsq_om12=0.0d0 -c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12 -c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv, -c & " eps1",eps1 -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 write (iout,*) "chipom1",chipom1," chipom2",chipom2, -c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv -C Following variable is the square root of eps2 - eps2rt=1.0D0-facp1*facp_inv -C Following three variables are the derivatives of the square root of eps -C in om1, om2, and om12. - eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv - eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv - eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2 -C Evaluate the "asymmetric" factor in the VDW constant, eps3 -c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular -c! Or frankly, we should restructurize the whole energy section - eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12 -c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt -c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2, -c & " eps2rt_om12",eps2rt_om12 -C Calculate whole angle-dependent part of epsilon and contributions -C to its derivatives - return - end -C---------------------------------------------------------------------------- - subroutine sc_grad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.CALC' - double precision dcosom1(3),dcosom2(3) - eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 - eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 - eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 - & -2.0D0*alf12*eps3der+sigder*sigsq_om12 - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - do k=1,3 - gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k) - enddo - 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 -C -C Calculate the components of the gradient in DC and X -C - do k=i,j-1 - do l=1,3 - gvdwc(l,k)=gvdwc(l,k)+gg(l) - enddo - enddo - return - end -c------------------------------------------------------------------------------ - subroutine vec_and_deriv - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.VECTORS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2) -C Compute the local reference systems. For reference system (i), the -C X-axis points from CA(i) to CA(i+1), the Y axis is in the -C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane. - do i=1,nres-1 -c if (i.eq.nres-1 .or. itel(i+1).eq.0) then - if (i.eq.nres-1) then -C Case of the last full residue -C Compute the Z-axis - call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i)) - costh=dcos(pi-theta(nres)) - fac=1.0d0/dsqrt(1.0d0-costh*costh) - do k=1,3 - uz(k,i)=fac*uz(k,i) - enddo - if (calc_grad) then -C Compute the derivatives of uz - uzder(1,1,1)= 0.0d0 - uzder(2,1,1)=-dc_norm(3,i-1) - uzder(3,1,1)= dc_norm(2,i-1) - uzder(1,2,1)= dc_norm(3,i-1) - uzder(2,2,1)= 0.0d0 - uzder(3,2,1)=-dc_norm(1,i-1) - uzder(1,3,1)=-dc_norm(2,i-1) - uzder(2,3,1)= dc_norm(1,i-1) - uzder(3,3,1)= 0.0d0 - uzder(1,1,2)= 0.0d0 - uzder(2,1,2)= dc_norm(3,i) - uzder(3,1,2)=-dc_norm(2,i) - uzder(1,2,2)=-dc_norm(3,i) - uzder(2,2,2)= 0.0d0 - uzder(3,2,2)= dc_norm(1,i) - uzder(1,3,2)= dc_norm(2,i) - uzder(2,3,2)=-dc_norm(1,i) - uzder(3,3,2)= 0.0d0 - endif -C Compute the Y-axis - facy=fac - do k=1,3 - uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i)) - enddo - if (calc_grad) then -C Compute the derivatives of uy - do j=1,3 - do k=1,3 - uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) - & -dc_norm(k,i)*dc_norm(j,i-1) - uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) - enddo - uyder(j,j,1)=uyder(j,j,1)-costh - uyder(j,j,2)=1.0d0+uyder(j,j,2) - enddo - do j=1,2 - do k=1,3 - do l=1,3 - uygrad(l,k,j,i)=uyder(l,k,j) - uzgrad(l,k,j,i)=uzder(l,k,j) - enddo - enddo - enddo - call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) - call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) - call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) - call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) - endif - else -C Other residues -C Compute the Z-axis - call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i)) - costh=dcos(pi-theta(i+2)) - fac=1.0d0/dsqrt(1.0d0-costh*costh) - do k=1,3 - uz(k,i)=fac*uz(k,i) - enddo - if (calc_grad) then -C Compute the derivatives of uz - uzder(1,1,1)= 0.0d0 - uzder(2,1,1)=-dc_norm(3,i+1) - uzder(3,1,1)= dc_norm(2,i+1) - uzder(1,2,1)= dc_norm(3,i+1) - uzder(2,2,1)= 0.0d0 - uzder(3,2,1)=-dc_norm(1,i+1) - uzder(1,3,1)=-dc_norm(2,i+1) - uzder(2,3,1)= dc_norm(1,i+1) - uzder(3,3,1)= 0.0d0 - uzder(1,1,2)= 0.0d0 - uzder(2,1,2)= dc_norm(3,i) - uzder(3,1,2)=-dc_norm(2,i) - uzder(1,2,2)=-dc_norm(3,i) - uzder(2,2,2)= 0.0d0 - uzder(3,2,2)= dc_norm(1,i) - uzder(1,3,2)= dc_norm(2,i) - uzder(2,3,2)=-dc_norm(1,i) - uzder(3,3,2)= 0.0d0 - endif -C Compute the Y-axis - facy=fac - do k=1,3 - uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) - enddo - if (calc_grad) then -C Compute the derivatives of uy - do j=1,3 - do k=1,3 - uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) - & -dc_norm(k,i)*dc_norm(j,i+1) - uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) - enddo - uyder(j,j,1)=uyder(j,j,1)-costh - uyder(j,j,2)=1.0d0+uyder(j,j,2) - enddo - do j=1,2 - do k=1,3 - do l=1,3 - uygrad(l,k,j,i)=uyder(l,k,j) - uzgrad(l,k,j,i)=uzder(l,k,j) - enddo - enddo - enddo - call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) - call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) - call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) - call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) - endif - endif - enddo - if (calc_grad) then - do i=1,nres-1 - vbld_inv_temp(1)=vbld_inv(i+1) - if (i.lt.nres-1) then - vbld_inv_temp(2)=vbld_inv(i+2) - else - vbld_inv_temp(2)=vbld_inv(i) - endif - do j=1,2 - do k=1,3 - do l=1,3 - uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i) - uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i) - enddo - enddo - enddo - enddo - endif - return - end -C----------------------------------------------------------------------------- - subroutine vec_and_deriv_test - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.VECTORS' - dimension uyder(3,3,2),uzder(3,3,2) -C Compute the local reference systems. For reference system (i), the -C X-axis points from CA(i) to CA(i+1), the Y axis is in the -C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane. - do i=1,nres-1 - if (i.eq.nres-1) then -C Case of the last full residue -C Compute the Z-axis - call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i)) - costh=dcos(pi-theta(nres)) - fac=1.0d0/dsqrt(1.0d0-costh*costh) -c write (iout,*) 'fac',fac, -c & 1.0d0/dsqrt(scalar(uz(1,i),uz(1,i))) - fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i))) - do k=1,3 - uz(k,i)=fac*uz(k,i) - enddo -C Compute the derivatives of uz - uzder(1,1,1)= 0.0d0 - uzder(2,1,1)=-dc_norm(3,i-1) - uzder(3,1,1)= dc_norm(2,i-1) - uzder(1,2,1)= dc_norm(3,i-1) - uzder(2,2,1)= 0.0d0 - uzder(3,2,1)=-dc_norm(1,i-1) - uzder(1,3,1)=-dc_norm(2,i-1) - uzder(2,3,1)= dc_norm(1,i-1) - uzder(3,3,1)= 0.0d0 - uzder(1,1,2)= 0.0d0 - uzder(2,1,2)= dc_norm(3,i) - uzder(3,1,2)=-dc_norm(2,i) - uzder(1,2,2)=-dc_norm(3,i) - uzder(2,2,2)= 0.0d0 - uzder(3,2,2)= dc_norm(1,i) - uzder(1,3,2)= dc_norm(2,i) - uzder(2,3,2)=-dc_norm(1,i) - uzder(3,3,2)= 0.0d0 -C Compute the Y-axis - do k=1,3 - uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i)) - enddo - facy=fac - facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))* - & (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2- - & scalar(dc_norm(1,i),dc_norm(1,i-1))**2)) - do k=1,3 -c uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) - uy(k,i)= -c & facy*( - & dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i)) - & -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i) -c & ) - enddo -c write (iout,*) 'facy',facy, -c & 1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) - facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) - do k=1,3 - uy(k,i)=facy*uy(k,i) - enddo -C Compute the derivatives of uy - do j=1,3 - do k=1,3 - uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) - & -dc_norm(k,i)*dc_norm(j,i-1) - uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) - enddo -c uyder(j,j,1)=uyder(j,j,1)-costh -c uyder(j,j,2)=1.0d0+uyder(j,j,2) - uyder(j,j,1)=uyder(j,j,1) - & -scalar(dc_norm(1,i),dc_norm(1,i-1)) - uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i)) - & +uyder(j,j,2) - enddo - do j=1,2 - do k=1,3 - do l=1,3 - uygrad(l,k,j,i)=uyder(l,k,j) - uzgrad(l,k,j,i)=uzder(l,k,j) - enddo - enddo - enddo - call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) - call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) - call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) - call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) - else -C Other residues -C Compute the Z-axis - call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i)) - costh=dcos(pi-theta(i+2)) - fac=1.0d0/dsqrt(1.0d0-costh*costh) - fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i))) - do k=1,3 - uz(k,i)=fac*uz(k,i) - enddo -C Compute the derivatives of uz - uzder(1,1,1)= 0.0d0 - uzder(2,1,1)=-dc_norm(3,i+1) - uzder(3,1,1)= dc_norm(2,i+1) - uzder(1,2,1)= dc_norm(3,i+1) - uzder(2,2,1)= 0.0d0 - uzder(3,2,1)=-dc_norm(1,i+1) - uzder(1,3,1)=-dc_norm(2,i+1) - uzder(2,3,1)= dc_norm(1,i+1) - uzder(3,3,1)= 0.0d0 - uzder(1,1,2)= 0.0d0 - uzder(2,1,2)= dc_norm(3,i) - uzder(3,1,2)=-dc_norm(2,i) - uzder(1,2,2)=-dc_norm(3,i) - uzder(2,2,2)= 0.0d0 - uzder(3,2,2)= dc_norm(1,i) - uzder(1,3,2)= dc_norm(2,i) - uzder(2,3,2)=-dc_norm(1,i) - uzder(3,3,2)= 0.0d0 -C Compute the Y-axis - facy=fac - facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))* - & (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2- - & scalar(dc_norm(1,i),dc_norm(1,i+1))**2)) - do k=1,3 -c uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) - uy(k,i)= -c & facy*( - & dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i)) - & -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i) -c & ) - enddo -c write (iout,*) 'facy',facy, -c & 1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) - facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) - do k=1,3 - uy(k,i)=facy*uy(k,i) - enddo -C Compute the derivatives of uy - do j=1,3 - do k=1,3 - uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) - & -dc_norm(k,i)*dc_norm(j,i+1) - uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) - enddo -c uyder(j,j,1)=uyder(j,j,1)-costh -c uyder(j,j,2)=1.0d0+uyder(j,j,2) - uyder(j,j,1)=uyder(j,j,1) - & -scalar(dc_norm(1,i),dc_norm(1,i+1)) - uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i)) - & +uyder(j,j,2) - enddo - do j=1,2 - do k=1,3 - do l=1,3 - uygrad(l,k,j,i)=uyder(l,k,j) - uzgrad(l,k,j,i)=uzder(l,k,j) - enddo - enddo - enddo - call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) - call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) - call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) - call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) - endif - enddo - do i=1,nres-1 - do j=1,2 - do k=1,3 - do l=1,3 - uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i) - uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i) - enddo - enddo - enddo - enddo - return - end -C----------------------------------------------------------------------------- - subroutine check_vecgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - 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) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - double precision auxvec(2),auxmat(2,2) -C -C Compute the virtual-bond-torsional-angle dependent quantities needed -C to calculate the el-loc multibody terms of various order. -C - do i=3,nres+1 - if (i .lt. nres+1) then - sin1=dsin(phi(i)) - cos1=dcos(phi(i)) - sintab(i-2)=sin1 - costab(i-2)=cos1 - obrot(1,i-2)=cos1 - obrot(2,i-2)=sin1 - sin2=dsin(2*phi(i)) - cos2=dcos(2*phi(i)) - sintab2(i-2)=sin2 - costab2(i-2)=cos2 - obrot2(1,i-2)=cos2 - obrot2(2,i-2)=sin2 - Ug(1,1,i-2)=-cos1 - Ug(1,2,i-2)=-sin1 - Ug(2,1,i-2)=-sin1 - Ug(2,2,i-2)= cos1 - Ug2(1,1,i-2)=-cos2 - Ug2(1,2,i-2)=-sin2 - Ug2(2,1,i-2)=-sin2 - Ug2(2,2,i-2)= cos2 - else - costab(i-2)=1.0d0 - sintab(i-2)=0.0d0 - obrot(1,i-2)=1.0d0 - obrot(2,i-2)=0.0d0 - obrot2(1,i-2)=0.0d0 - obrot2(2,i-2)=0.0d0 - Ug(1,1,i-2)=1.0d0 - Ug(1,2,i-2)=0.0d0 - Ug(2,1,i-2)=0.0d0 - Ug(2,2,i-2)=1.0d0 - Ug2(1,1,i-2)=0.0d0 - Ug2(1,2,i-2)=0.0d0 - 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 - obrot_der(1,i-2)=-sin1 - obrot_der(2,i-2)= cos1 - Ugder(1,1,i-2)= sin1 - Ugder(1,2,i-2)=-cos1 - Ugder(2,1,i-2)=-cos1 - Ugder(2,2,i-2)=-sin1 - dwacos2=cos2+cos2 - dwasin2=sin2+sin2 - obrot2_der(1,i-2)=-dwasin2 - obrot2_der(2,i-2)= dwacos2 - Ug2der(1,1,i-2)= dwasin2 - Ug2der(1,2,i-2)=-dwacos2 - Ug2der(2,1,i-2)=-dwacos2 - Ug2der(2,2,i-2)=-dwasin2 - else - obrot_der(1,i-2)=0.0d0 - obrot_der(2,i-2)=0.0d0 - Ugder(1,1,i-2)=0.0d0 - Ugder(1,2,i-2)=0.0d0 - Ugder(2,1,i-2)=0.0d0 - Ugder(2,2,i-2)=0.0d0 - obrot2_der(1,i-2)=0.0d0 - obrot2_der(2,i-2)=0.0d0 - Ug2der(1,1,i-2)=0.0d0 - Ug2der(1,2,i-2)=0.0d0 - Ug2der(2,1,i-2)=0.0d0 - Ug2der(2,2,i-2)=0.0d0 - endif - if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then - iti = itortyp(itype(i-2)) - else - iti=ntortyp+1 - endif - if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then - iti1 = itortyp(itype(i-1)) - else - iti1=ntortyp+1 - endif -cd write (iout,*) '*******i',i,' iti1',iti -cd write (iout,*) 'b1',b1(:,iti) -cd write (iout,*) 'b2',b2(:,iti) -cd write (iout,*) 'Ug',Ug(:,:,i-2) - if (i .gt. iatel_s+2) then - call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2)) - call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2)) - call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2)) - call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2)) - call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2)) - call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2)) - call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2)) - else - do k=1,2 - Ub2(k,i-2)=0.0d0 - Ctobr(k,i-2)=0.0d0 - Dtobr2(k,i-2)=0.0d0 - do l=1,2 - EUg(l,k,i-2)=0.0d0 - CUg(l,k,i-2)=0.0d0 - DUg(l,k,i-2)=0.0d0 - DtUg2(l,k,i-2)=0.0d0 - enddo - enddo - endif - call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2)) - call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2)) - call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2)) - call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2)) - call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2)) - call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2)) - call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2)) - do k=1,2 - muder(k,i-2)=Ub2der(k,i-2) - enddo - if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then - iti1 = itortyp(itype(i-1)) - else - iti1=ntortyp+1 - endif - do k=1,2 - mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1) - enddo -C Vectors and matrices dependent on a single virtual-bond dihedral. - call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1)) - call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2)) - call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2)) - call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2)) - call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2)) - call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2)) - call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2)) - call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2)) - call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2)) -cd write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2), -cd & ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2) - enddo -C Matrices dependent on two consecutive virtual-bond dihedrals. -C The order of matrices is from left to right. - do i=2,nres-1 - call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i)) - call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i)) - call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i)) - call transpose2(DtUg2(1,1,i-1),auxmat(1,1)) - call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i)) - call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i)) - call transpose2(DtUg2der(1,1,i-1),auxmat(1,1)) - call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i)) - enddo -cd do i=1,nres -cd iti = itortyp(itype(i)) -cd write (iout,*) i -cd do j=1,2 -cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)') -cd & (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2) -cd enddo -cd enddo - return - end -C-------------------------------------------------------------------------- - subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) -C -C This subroutine calculates the average interaction energy and its gradient -C in the virtual-bond vectors between non-adjacent peptide groups, based on -C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. -C The potential depends both on the distance of peptide-group centers and on -C the orientation of the CA-CA virtual bonds. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), - & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) - double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), - & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) - common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1 -c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions - double precision scal_el /0.5d0/ -C 12/13/98 -C 13-go grudnia roku pamietnego... - double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, - & 0.0d0,1.0d0,0.0d0, - & 0.0d0,0.0d0,1.0d0/ -cd write(iout,*) 'In EELEC' -cd do i=1,nloctyp -cd write(iout,*) 'Type',i -cd write(iout,*) 'B1',B1(:,i) -cd write(iout,*) 'B2',B2(:,i) -cd write(iout,*) 'CC',CC(:,:,i) -cd write(iout,*) 'DD',DD(:,:,i) -cd write(iout,*) 'EE',EE(:,:,i) -cd enddo -cd call check_vecgrad -cd stop - if (icheckgrad.eq.1) then - do i=1,nres-1 - fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) - do k=1,3 - dc_norm(k,i)=dc(k,i)*fac - enddo -c write (iout,*) 'i',i,' fac',fac - enddo - endif - if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. - & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then -cd if (wel_loc.gt.0.0d0) then - if (icheckgrad.eq.1) then - call vec_and_deriv_test - else - call vec_and_deriv - endif - call set_matrices - endif -cd do i=1,nres-1 -cd write (iout,*) 'i=',i -cd do k=1,3 -cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) -cd enddo -cd do k=1,3 -cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') -cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) -cd enddo -cd enddo - num_conti_hb=0 - ees=0.0D0 - evdw1=0.0D0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 - ind=0 - do i=1,nres - num_cont_hb(i)=0 - enddo -cd print '(a)','Enter EELEC' -cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e - do i=1,nres - gel_loc_loc(i)=0.0d0 - gcorr_loc(i)=0.0d0 - enddo - do i=iatel_s,iatel_e - if (itel(i).eq.0) goto 1215 - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 -c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) - do j=ielstart(i),ielend(i) - if (itel(j).eq.0) goto 1216 - 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) -C Diagnostics only!!! -c aaa=0.0D0 -c bbb=0.0D0 -c ael6i=0.0D0 -c ael3i=0.0D0 -C End diagnostics - ael6i=ael6(iteli,itelj) - ael3i=ael3(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - rmij=1.0D0/rij - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj - cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij - cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij - fac=cosa-3.0D0*cosb*cosg - ev1=aaa*r6ij*r6ij -c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - fac3=ael6i*r6ij - fac4=ael3i*r3ij - evdwij=ev1+ev2 - el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - eesij=el1+el2 -c write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij -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 -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 -C -C Calculate contributions to the Cartesian gradient. -C -#ifdef SPLITELE - facvdw=-6*rrmij*(ev1+evdwij) - facel=-3*rrmij*(el1+eesij) - fac1=fac - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij - if (calc_grad) then -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=facel*xj - ggg(2)=facel*yj - ggg(3)=facel*zj - do k=1,3 - ghalf=0.5D0*ggg(k) - gelc(k,i)=gelc(k,i)+ghalf - gelc(k,j)=gelc(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* - do k=i+1,j-1 - do l=1,3 - gelc(l,k)=gelc(l,k)+ggg(l) - enddo - enddo - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - do k=1,3 - ghalf=0.5D0*ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)+ghalf - gvdwpp(k,j)=gvdwpp(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* - do k=i+1,j-1 - do l=1,3 - gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) - enddo - enddo -#else - facvdw=ev1+evdwij - facel=el1+eesij - fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij - if (calc_grad) then -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=fac*xj - ggg(2)=fac*yj - ggg(3)=fac*zj - do k=1,3 - ghalf=0.5D0*ggg(k) - gelc(k,i)=gelc(k,i)+ghalf - gelc(k,j)=gelc(k,j)+ghalf - enddo -* -* Loop over residues i+1 thru j-1. -* - do k=i+1,j-1 - do l=1,3 - gelc(l,k)=gelc(l,k)+ggg(l) - enddo - enddo -#endif -* -* Angular part -* - ecosa=2.0D0*fac3*fac1+fac4 - fac4=-3.0D0*fac4 - fac3=-6.0D0*fac3 - ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) - ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo -cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), -cd & (dcosg(k),k=1,3) - do k=1,3 - ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) - enddo - do k=1,3 - ghalf=0.5D0*ggg(k) - gelc(k,i)=gelc(k,i)+ghalf - & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gelc(k,j)=gelc(k,j)+ghalf - & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - enddo - do k=i+1,j-1 - do l=1,3 - gelc(l,k)=gelc(l,k)+ggg(l) - enddo - enddo - endif - - IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 - & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -C -C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction -C energy of a peptide unit is assumed in the form of a second-order -C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. -C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms -C are computed for EVERY pair of non-contiguous peptide groups. -C - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - kkk=0 - do k=1,2 - do l=1,2 - kkk=kkk+1 - muij(kkk)=mu(k,i)*mu(l,j) - enddo - enddo -cd write (iout,*) 'EELEC: i',i,' j',j -cd write (iout,*) 'j',j,' j1',j1,' j2',j2 -cd write(iout,*) 'muij',muij - ury=scalar(uy(1,i),erij) - urz=scalar(uz(1,i),erij) - vry=scalar(uy(1,j),erij) - vrz=scalar(uz(1,j),erij) - a22=scalar(uy(1,i),uy(1,j))-3*ury*vry - a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz - a32=scalar(uz(1,i),uy(1,j))-3*urz*vry - a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz -C For diagnostics only -cd a22=1.0d0 -cd a23=1.0d0 -cd a32=1.0d0 -cd a33=1.0d0 - fac=dsqrt(-ael6i)*r3ij -cd write (2,*) 'fac=',fac -C For diagnostics only -cd fac=1.0d0 - a22=a22*fac - a23=a23*fac - a32=a32*fac - a33=a33*fac -cd write (iout,'(4i5,4f10.5)') -cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 -cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij -cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3), -cd & (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3) -cd write (iout,'(4f10.5)') -cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)), -cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j)) -cd write (iout,'(4f10.5)') ury,urz,vry,vrz -cd write (iout,'(2i3,9f10.5/)') i,j, -cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij - if (calc_grad) then -C Derivatives of the elements of A in virtual-bond vectors - call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) -cd do k=1,3 -cd do l=1,3 -cd erder(k,l)=0.0d0 -cd enddo -cd enddo - 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 -cd do k=1,3 -cd do l=1,3 -cd uryg(k,l)=0.0d0 -cd urzg(k,l)=0.0d0 -cd vryg(k,l)=0.0d0 -cd vrzg(k,l)=0.0d0 -cd enddo -cd enddo -C Compute radial contributions to the gradient - facr=-3.0d0*rrmij - a22der=a22*facr - a23der=a23*facr - a32der=a32*facr - a33der=a33*facr -cd a22der=0.0d0 -cd a23der=0.0d0 -cd a32der=0.0d0 -cd a33der=0.0d0 - agg(1,1)=a22der*xj - agg(2,1)=a22der*yj - agg(3,1)=a22der*zj - agg(1,2)=a23der*xj - agg(2,2)=a23der*yj - agg(3,2)=a23der*zj - agg(1,3)=a32der*xj - agg(2,3)=a32der*yj - agg(3,3)=a32der*zj - agg(1,4)=a33der*xj - agg(2,4)=a33der*yj - agg(3,4)=a33der*zj -C Add the contributions coming from er - fac3=-3.0d0*fac - do k=1,3 - agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) - agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) - agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) - agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) - enddo - do k=1,3 -C Derivatives in DC(i) - ghalf1=0.5d0*agg(k,1) - ghalf2=0.5d0*agg(k,2) - ghalf3=0.5d0*agg(k,3) - ghalf4=0.5d0*agg(k,4) - aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) - & -3.0d0*uryg(k,2)*vry)+ghalf1 - aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) - & -3.0d0*uryg(k,2)*vrz)+ghalf2 - aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) - & -3.0d0*urzg(k,2)*vry)+ghalf3 - aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) - & -3.0d0*urzg(k,2)*vrz)+ghalf4 -C Derivatives in DC(i+1) - aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) - & -3.0d0*uryg(k,3)*vry)+agg(k,1) - aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) - & -3.0d0*uryg(k,3)*vrz)+agg(k,2) - aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) - & -3.0d0*urzg(k,3)*vry)+agg(k,3) - aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) - & -3.0d0*urzg(k,3)*vrz)+agg(k,4) -C Derivatives in DC(j) - aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) - & -3.0d0*vryg(k,2)*ury)+ghalf1 - aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) - & -3.0d0*vrzg(k,2)*ury)+ghalf2 - aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) - & -3.0d0*vryg(k,2)*urz)+ghalf3 - aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) - & -3.0d0*vrzg(k,2)*urz)+ghalf4 -C Derivatives in DC(j+1) or DC(nres-1) - aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) - & -3.0d0*vryg(k,3)*ury) - aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) - & -3.0d0*vrzg(k,3)*ury) - aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) - & -3.0d0*vryg(k,3)*urz) - aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) - & -3.0d0*vrzg(k,3)*urz) -cd aggi(k,1)=ghalf1 -cd aggi(k,2)=ghalf2 -cd aggi(k,3)=ghalf3 -cd aggi(k,4)=ghalf4 -C Derivatives in DC(i+1) -cd aggi1(k,1)=agg(k,1) -cd aggi1(k,2)=agg(k,2) -cd aggi1(k,3)=agg(k,3) -cd aggi1(k,4)=agg(k,4) -C Derivatives in DC(j) -cd aggj(k,1)=ghalf1 -cd aggj(k,2)=ghalf2 -cd aggj(k,3)=ghalf3 -cd aggj(k,4)=ghalf4 -C Derivatives in DC(j+1) -cd aggj1(k,1)=0.0d0 -cd aggj1(k,2)=0.0d0 -cd aggj1(k,3)=0.0d0 -cd aggj1(k,4)=0.0d0 - if (j.eq.nres-1 .and. i.lt.j-2) then - do l=1,4 - aggj1(k,l)=aggj1(k,l)+agg(k,l) -cd aggj1(k,l)=agg(k,l) - enddo - endif - enddo - endif -c goto 11111 -C Check the loc-el terms by numerical integration - acipa(1,1)=a22 - acipa(1,2)=a23 - acipa(2,1)=a32 - acipa(2,2)=a33 - a22=-a22 - a23=-a23 - do l=1,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - if (j.lt.nres-1) then - a22=-a22 - a32=-a32 - do l=1,3,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - else - a22=-a22 - a23=-a23 - a32=-a32 - a33=-a33 - do l=1,4 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - endif - ENDIF ! WCORR -11111 continue - 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 -cd write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) - eel_loc=eel_loc+eel_loc_ij -C Partial derivatives in virtual-bond dihedral angles gamma - if (calc_grad) then - if (i.gt.1) - & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ - & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) - & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j) - gel_loc_loc(j-1)=gel_loc_loc(j-1)+ - & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) - & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j) -cd call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij) -cd write(iout,*) 'agg ',agg -cd write(iout,*) 'aggi ',aggi -cd write(iout,*) 'aggi1',aggi1 -cd write(iout,*) 'aggj ',aggj -cd write(iout,*) 'aggj1',aggj1 - -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) - enddo - do k=i+2,j2 - do l=1,3 - gel_loc(l,k)=gel_loc(l,k)+ggg(l) - enddo - enddo -C Remaining derivatives of eello - do l=1,3 - gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ - & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4) - gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ - & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) - gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ - & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) - gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ - & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) - enddo - endif - ENDIF - if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then -C Contributions from turns - a_temp(1,1)=a22 - a_temp(1,2)=a23 - a_temp(2,1)=a32 - a_temp(2,2)=a33 - call eturn34(i,j,eello_turn3,eello_turn4) - endif -C Change 12/26/95 to calculate four-body contributions to H-bonding energy - if (j.gt.i+1 .and. num_conti.le.maxconts) then -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 - IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. - & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el -C terms. - d_cont(num_conti,i)=rij -cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij -C --- Electrostatic-interaction matrix --- - a_chuj(1,1,num_conti,i)=a22 - a_chuj(1,2,num_conti,i)=a23 - a_chuj(2,1,num_conti,i)=a32 - a_chuj(2,2,num_conti,i)=a33 -C --- Gradient of rij - do kkk=1,3 - grij_hb_cont(kkk,num_conti,i)=erij(kkk) - enddo -c if (i.eq.1) then -c a_chuj(1,1,num_conti,i)=-0.61d0 -c a_chuj(1,2,num_conti,i)= 0.4d0 -c a_chuj(2,1,num_conti,i)= 0.65d0 -c a_chuj(2,2,num_conti,i)= 0.50d0 -c else if (i.eq.2) then -c a_chuj(1,1,num_conti,i)= 0.0d0 -c a_chuj(1,2,num_conti,i)= 0.0d0 -c a_chuj(2,1,num_conti,i)= 0.0d0 -c a_chuj(2,2,num_conti,i)= 0.0d0 -c endif -C --- and its gradients -cd write (iout,*) 'i',i,' j',j -cd do kkk=1,3 -cd write (iout,*) 'iii 1 kkk',kkk -cd write (iout,*) agg(kkk,:) -cd enddo -cd do kkk=1,3 -cd write (iout,*) 'iii 2 kkk',kkk -cd write (iout,*) aggi(kkk,:) -cd enddo -cd do kkk=1,3 -cd write (iout,*) 'iii 3 kkk',kkk -cd write (iout,*) aggi1(kkk,:) -cd enddo -cd do kkk=1,3 -cd write (iout,*) 'iii 4 kkk',kkk -cd write (iout,*) aggj(kkk,:) -cd enddo -cd do kkk=1,3 -cd write (iout,*) 'iii 5 kkk',kkk -cd write (iout,*) aggj1(kkk,:) -cd 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) -c do mm=1,5 -c a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0 -c enddo - enddo - enddo - enddo - ENDIF - IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN -C Calculate contact energies - cosa4=4.0D0*cosa - wij=cosa-3.0D0*cosb*cosg - cosbg1=cosb+cosg - cosbg2=cosb-cosg -c fac3=dsqrt(-ael6i)/r0ij**3 - fac3=dsqrt(-ael6i)*r3ij - ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) - ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) -c ees0mij=0.0D0 - ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) - ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) -C Diagnostics. Comment out or remove after debugging! -c ees0p(num_conti,i)=0.5D0*fac3*ees0pij -c ees0m(num_conti,i)=0.5D0*fac3*ees0mij -c ees0m(num_conti,i)=0.0D0 -C End diagnostics. -c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, -c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont - facont_hb(num_conti,i)=fcont - if (calc_grad) then -C Angular derivatives of the contact function - ees0pij1=fac3/ees0pij - ees0mij1=fac3/ees0mij - fac3p=-3.0D0*fac3*rrmij - ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) - ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) -c ees0mij1=0.0D0 - ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) - ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) - ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) - ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) - ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) - ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) - ecosap=ecosa1+ecosa2 - ecosbp=ecosb1+ecosb2 - ecosgp=ecosg1+ecosg2 - ecosam=ecosa1-ecosa2 - ecosbm=ecosb1-ecosb2 - ecosgm=ecosg1-ecosg2 -C Diagnostics -c ecosap=ecosa1 -c ecosbp=ecosb1 -c ecosgp=ecosg1 -c ecosam=0.0D0 -c ecosbm=0.0D0 -c ecosgm=0.0D0 -C End diagnostics - fprimcont=fprimcont/rij -cd facont_hb(num_conti,i)=1.0D0 -C Following line is for diagnostics. -cd fprimcont=0.0D0 - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo - do k=1,3 - gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) - gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) - enddo - gggp(1)=gggp(1)+ees0pijp*xj - gggp(2)=gggp(2)+ees0pijp*yj - gggp(3)=gggp(3)+ees0pijp*zj - gggm(1)=gggm(1)+ees0mijp*xj - gggm(2)=gggm(2)+ees0mijp*yj - gggm(3)=gggm(3)+ees0mijp*zj -C Derivatives due to the contact function - gacont_hbr(1,num_conti,i)=fprimcont*xj - gacont_hbr(2,num_conti,i)=fprimcont*yj - gacont_hbr(3,num_conti,i)=fprimcont*zj - do k=1,3 - ghalfp=0.5D0*gggp(k) - ghalfm=0.5D0*gggm(k) - gacontp_hb1(k,num_conti,i)=ghalfp - & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontp_hb2(k,num_conti,i)=ghalfp - & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontp_hb3(k,num_conti,i)=gggp(k) - gacontm_hb1(k,num_conti,i)=ghalfm - & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontm_hb2(k,num_conti,i)=ghalfm - & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontm_hb3(k,num_conti,i)=gggm(k) - enddo - endif -C Diagnostics. Comment out or remove after debugging! -cdiag do k=1,3 -cdiag gacontp_hb1(k,num_conti,i)=0.0D0 -cdiag gacontp_hb2(k,num_conti,i)=0.0D0 -cdiag gacontp_hb3(k,num_conti,i)=0.0D0 -cdiag gacontm_hb1(k,num_conti,i)=0.0D0 -cdiag gacontm_hb2(k,num_conti,i)=0.0D0 -cdiag gacontm_hb3(k,num_conti,i)=0.0D0 -cdiag enddo - ENDIF ! wcorr - endif ! num_conti.le.maxconts - endif ! fcont.gt.0 - endif ! j.gt.i+1 - 1216 continue - enddo ! j - num_cont_hb(i)=num_conti - 1215 continue - enddo ! i -cd do i=1,nres -cd write (iout,'(i3,3f10.5,5x,3f10.5)') -cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) -cd enddo -c 12/7/99 Adam eello_turn3 will be considered as a separate energy term -ccc eel_loc=eel_loc+eello_turn3 - return - end -C----------------------------------------------------------------------------- - subroutine eturn34(i,j,eello_turn3,eello_turn4) -C Third- and fourth-order contributions from turns - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - dimension ggg(3) - double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2), - & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2), - & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2) - double precision agg(3,4),aggi(3,4),aggi1(3,4), - & aggj(3,4),aggj1(3,4),a_temp(2,2) - common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2 - if (j.eq.i+2) then -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C Third-order contributions -C -C (i+2)o----(i+3) -C | | -C | | -C (i+1)o----i -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd call checkint_turn3(i,a_temp,eello_turn3_num) - call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1)) - call transpose2(auxmat(1,1),auxmat1(1,1)) - call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) - eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) -cd write (2,*) 'i,',i,' j',j,'eello_turn3', -cd & 0.5d0*(pizda(1,1)+pizda(2,2)), -cd & ' eello_turn3_num',4*eello_turn3_num - if (calc_grad) then -C Derivatives in gamma(i) - call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1)) - call transpose2(auxmat2(1,1),pizda(1,1)) - call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1)) - gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2)) -C Derivatives in gamma(i+1) - call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1)) - call transpose2(auxmat2(1,1),pizda(1,1)) - call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1)) - gel_loc_turn3(i+1)=gel_loc_turn3(i+1) - & +0.5d0*(pizda(1,1)+pizda(2,2)) -C Cartesian derivatives - do l=1,3 - a_temp(1,1)=aggi(l,1) - a_temp(1,2)=aggi(l,2) - a_temp(2,1)=aggi(l,3) - a_temp(2,2)=aggi(l,4) - call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) - gcorr3_turn(l,i)=gcorr3_turn(l,i) - & +0.5d0*(pizda(1,1)+pizda(2,2)) - a_temp(1,1)=aggi1(l,1) - a_temp(1,2)=aggi1(l,2) - a_temp(2,1)=aggi1(l,3) - a_temp(2,2)=aggi1(l,4) - call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) - gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) - & +0.5d0*(pizda(1,1)+pizda(2,2)) - a_temp(1,1)=aggj(l,1) - a_temp(1,2)=aggj(l,2) - a_temp(2,1)=aggj(l,3) - a_temp(2,2)=aggj(l,4) - call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) - gcorr3_turn(l,j)=gcorr3_turn(l,j) - & +0.5d0*(pizda(1,1)+pizda(2,2)) - a_temp(1,1)=aggj1(l,1) - a_temp(1,2)=aggj1(l,2) - a_temp(2,1)=aggj1(l,3) - a_temp(2,2)=aggj1(l,4) - call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) - gcorr3_turn(l,j1)=gcorr3_turn(l,j1) - & +0.5d0*(pizda(1,1)+pizda(2,2)) - enddo - endif - else if (j.eq.i+3) then -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C Fourth-order contributions -C -C (i+3)o----(i+4) -C / | -C (i+2)o | -C \ | -C (i+1)o----i -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd call checkint_turn4(i,a_temp,eello_turn4_num) - iti1=itortyp(itype(i+1)) - iti2=itortyp(itype(i+2)) - iti3=itortyp(itype(i+3)) - call transpose2(EUg(1,1,i+1),e1t(1,1)) - call transpose2(Eug(1,1,i+2),e2t(1,1)) - call transpose2(Eug(1,1,i+3),e3t(1,1)) - call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) - call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) - call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) - call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - eello_turn4=eello_turn4-(s1+s2+s3) -cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3), -cd & ' eello_turn4_num',8*eello_turn4_num -C Derivatives in gamma(i) - if (calc_grad) then - call transpose2(EUgder(1,1,i+1),e1tder(1,1)) - call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) -C Derivatives in gamma(i+1) - call transpose2(EUgder(1,1,i+2),e2tder(1,1)) - call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1)) - call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) -C Derivatives in gamma(i+2) - call transpose2(EUgder(1,1,i+3),e3tder(1,1)) - call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1)) - call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) -C Cartesian derivatives -C Derivatives of this turn contributions in DC(i+2) - if (j.lt.nres-1) then - do l=1,3 - a_temp(1,1)=agg(l,1) - a_temp(1,2)=agg(l,2) - a_temp(2,1)=agg(l,3) - a_temp(2,2)=agg(l,4) - call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) - call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) - call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) - call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - ggg(l)=-(s1+s2+s3) - gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3) - enddo - endif -C Remaining derivatives of this turn contribution - do l=1,3 - a_temp(1,1)=aggi(l,1) - a_temp(1,2)=aggi(l,2) - a_temp(2,1)=aggi(l,3) - a_temp(2,2)=aggi(l,4) - call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) - call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) - call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) - call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) - a_temp(1,1)=aggi1(l,1) - a_temp(1,2)=aggi1(l,2) - a_temp(2,1)=aggi1(l,3) - a_temp(2,2)=aggi1(l,4) - call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) - call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) - call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) - call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) - a_temp(1,1)=aggj(l,1) - a_temp(1,2)=aggj(l,2) - a_temp(2,1)=aggj(l,3) - a_temp(2,2)=aggj(l,4) - call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) - call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) - call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) - call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) - a_temp(1,1)=aggj1(l,1) - a_temp(1,2)=aggj1(l,2) - a_temp(2,1)=aggj1(l,3) - a_temp(2,2)=aggj1(l,4) - call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) - call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) - call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) - call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) - call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) - call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) - s3=0.5d0*(pizda(1,1)+pizda(2,2)) - gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) - enddo - endif - endif - return - end -C----------------------------------------------------------------------------- - subroutine vecpr(u,v,w) - implicit real*8(a-h,o-z) - dimension u(3),v(3),w(3) - w(1)=u(2)*v(3)-u(3)*v(2) - w(2)=-u(1)*v(3)+u(3)*v(1) - w(3)=u(1)*v(2)-u(2)*v(1) - return - end -C----------------------------------------------------------------------------- - subroutine unormderiv(u,ugrad,unorm,ungrad) -C This subroutine computes the derivatives of a normalized vector u, given -C the derivatives computed without normalization conditions, ugrad. Returns -C ungrad. - implicit none - double precision u(3),ugrad(3,3),unorm,ungrad(3,3) - double precision vec(3) - double precision scalar - integer i,j -c write (2,*) 'ugrad',ugrad -c write (2,*) 'u',u - do i=1,3 - vec(i)=scalar(ugrad(1,i),u(1)) - enddo -c write (2,*) 'vec',vec - do i=1,3 - do j=1,3 - ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm - enddo - enddo -c write (2,*) 'ungrad',ungrad - return - end -C----------------------------------------------------------------------------- - subroutine escp(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -c write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e, -c & ' scal14',scal14 - do i=iatscp_s,iatscp_e - iteli=itel(i) -c write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i), -c & " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) - if (iteli.eq.0) goto 1225 - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+e1+e2 - endif - evdwij=e1+e2 -c write (iout,*) i,j,evdwij - evdw2=evdw2+evdwij - if (calc_grad) then -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac - if (j.lt.i) then -cd write (iout,*) 'ji' - 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' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - dimension ggg(3) - ehpb=0.0D0 -cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr -cd write(iout,*)'link_start=',link_start,' link_end=',link_end - if (link_end.eq.0) return - do i=link_start,link_end -C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a -C CA-CA distance used in regularization of structure. - ii=ihpb(i) - jj=jhpb(i) -C iii and jjj point to the residues for which the distance is assigned. - if (ii.gt.nres) then - iii=ii-nres - jjj=jj-nres - else - iii=ii - jjj=jj - endif -c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, -c & dhpb(i),dhpb1(i),forcon(i) -C 24/11/03 AL: SS bridges handled separately because of introducing a specific -C distance and angle dependent SS bond potential. - if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then - call ssbond_ene(iii,jjj,eij) - ehpb=ehpb+2*eij -cd write (iout,*) "eij",eij - else if (ii.gt.nres .and. jj.gt.nres) then -c Restraints from contact prediction - dd=dist(ii,jj) - if (dhpb1(i).gt.0.0d0) then - ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd -c write (iout,*) "beta nmr", -c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - else - dd=dist(ii,jj) - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -c write (iout,*) "beta reg",dd,waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd - endif - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - do k=1,3 - ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) - ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) - enddo - else -C Calculate the distance between the two points and its difference from the -C target distance. - dd=dist(ii,jj) - if (dhpb1(i).gt.0.0d0) then - ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd -c write (iout,*) "alph nmr", -c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - else - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -c write (iout,*) "alpha reg",dd,waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd - endif -cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, -cd & ' waga=',waga,' fac=',fac - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo -cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) -C If this is a SC-SC distance, we need to calculate the contributions to the -C Cartesian gradient in the SC vectors (ghpbx). - if (iii.lt.ii) then - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - endif - do k=1,3 - ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) - ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) - enddo - endif - enddo - ehpb=0.5D0*ehpb - return - end -C-------------------------------------------------------------------------- - subroutine ssbond_ene(i,j,eij) -C -C Calculate the distance and angle dependent SS-bond potential energy -C using a free-energy function derived based on RHF/6-31G** ab initio -C calculations of diethyl disulfide. -C -C A. Liwo and U. Kozlowska, 11/24/03 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include '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=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=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 '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 - do i=nnt+1,nct - diff = vbld(i)-vbldp0 -c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff - estr=estr+diff*diff - do j=1,3 - gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) - enddo - enddo - estr=0.5d0*AKP*estr -c -c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included -c - do i=nnt,nct - iti=itype(i) - if (iti.ne.10) then - nbi=nbondterm(iti) - if (nbi.eq.1) then - diff=vbld(i+nres)-vbldsc0(1,iti) -c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, -c & AKSC(1,iti),AKSC(1,iti)*diff*diff - estr=estr+0.5d0*AKSC(1,iti)*diff*diff - do j=1,3 - gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) - enddo - else - do j=1,nbi - diff=vbld(i+nres)-vbldsc0(j,iti) - ud(j)=aksc(j,iti)*diff - u(j)=abond0(j,iti)+0.5d0*ud(j)*diff - enddo - uprod=u(1) - do j=2,nbi - uprod=uprod*u(j) - enddo - usum=0.0d0 - usumsqder=0.0d0 - do j=1,nbi - uprod1=1.0d0 - uprod2=1.0d0 - do k=1,nbi - if (k.ne.j) then - uprod1=uprod1*u(k) - uprod2=uprod2*u(k)*u(k) - endif - enddo - usum=usum+uprod1 - usumsqder=usumsqder+ud(j)*uprod2 - enddo -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) -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) -c if (i.gt.ithet_start .and. -c & (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215 -c if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then -c phii=phi(i) -c y(1)=dcos(phii) -c y(2)=dsin(phii) -c else -c y(1)=0.0D0 -c y(2)=0.0D0 -c endif -c if (i.lt.nres .and. itel(i).ne.0) then -c phii1=phi(i+1) -c z(1)=dcos(phii1) -c z(2)=dsin(phii1) -c else -c z(1)=0.0D0 -c z(2)=0.0D0 -c endif - if (i.gt.3) then -#ifdef OSF - phii=phi(i) - icrc=0 - 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 - if (i.lt.nres) then -#ifdef OSF - phii1=phi(i+1) - icrc=0 - 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) - 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 -#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' - 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 - dethetai=0.0d0 - dephii=0.0d0 - dephii1=0.0d0 - theti2=0.5d0*theta(i) - ityp2=ithetyp(itype(i-1)) - do k=1,nntheterm - coskt(k)=dcos(k*theti2) - sinkt(k)=dsin(k*theti2) - enddo - if (i.gt.3) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - ityp1=ithetyp(itype(i-2)) - do k=1,nsingle - cosph1(k)=dcos(k*phii) - sinph1(k)=dsin(k*phii) - enddo - else - phii=0.0d0 - ityp1=nthetyp+1 - do k=1,nsingle - cosph1(k)=0.0d0 - sinph1(k)=0.0d0 - enddo - endif - if (i.lt.nres) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) -#else - phii1=phi(i+1) -#endif - ityp3=ithetyp(itype(i)) - do k=1,nsingle - cosph2(k)=dcos(k*phii1) - sinph2(k)=dsin(k*phii1) - enddo - else - phii1=0.0d0 - ityp3=nthetyp+1 - do k=1,nsingle - cosph2(k)=0.0d0 - sinph2(k)=0.0d0 - enddo - endif -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) - do k=1,ndouble - do l=1,k-1 - ccl=cosph1(l)*cosph2(k-l) - ssl=sinph1(l)*sinph2(k-l) - scl=sinph1(l)*cosph2(k-l) - csl=cosph1(l)*sinph2(k-l) - cosph1ph2(l,k)=ccl-ssl - cosph1ph2(k,l)=ccl+ssl - sinph1ph2(l,k)=scl+csl - sinph1ph2(k,l)=scl-csl - enddo - enddo - if (lprn) then - write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, - & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 - write (iout,*) "coskt and sinkt" - do k=1,nntheterm - write (iout,*) k,coskt(k),sinkt(k) - enddo - endif - do k=1,ntheterm - ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k) - dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3) - & *coskt(k) - if (lprn) - & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), - & " ethetai",ethetai - enddo - if (lprn) then - write (iout,*) "cosph and sinph" - do k=1,nsingle - write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) - enddo - write (iout,*) "cosph1ph2 and sinph2ph2" - do k=2,ndouble - do l=1,k-1 - write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), - & sinph1ph2(l,k),sinph1ph2(k,l) - enddo - enddo - write(iout,*) "ethetai",ethetai - endif - do m=1,ntheterm2 - do k=1,nsingle - aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k) - & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k) - & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k) - & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*aux*coskt(m) - dephii=dephii+k*sinkt(m)*( - & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)- - & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) - dephii1=dephii1+k*sinkt(m)*( - & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- - & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) - if (lprn) - & write (iout,*) "m",m," k",k," bbthet", - & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", - & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", - & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", - & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai - enddo - enddo - if (lprn) - & write(iout,*) "ethetai",ethetai - do m=1,ntheterm3 - do k=2,ndouble - do l=1,k-1 - aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*coskt(m)*aux - dephii=dephii+l*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)- - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - dephii1=dephii1+(k-l)*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)- - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - if (lprn) then - write (iout,*) "m",m," k",k," l",l," ffthet", - & ffthet(l,k,m,ityp1,ityp2,ityp3), - & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", - & ggthet(l,k,m,ityp1,ityp2,ityp3), - & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai - write (iout,*) cosph1ph2(l,k)*sinkt(m), - & cosph1ph2(k,l)*sinkt(m), - & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) - endif - enddo - enddo - enddo -10 continue - if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') - & i,theta(i)*rad2deg,phii*rad2deg, - & phii1*rad2deg,ethetai - etheta=etheta+ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 - gloc(nphi+i-2,icg)=wang*dethetai - enddo - return - end -#endif -#ifdef CRYST_SC -c----------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include '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) -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,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 -#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 - costtab(i+1) =dcos(theta(i+1)) - sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) - cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) - sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) - cosfac2=0.5d0/(1.0d0+costtab(i+1)) - cosfac=dsqrt(cosfac2) - sinfac2=0.5d0/(1.0d0-costtab(i+1)) - sinfac=dsqrt(sinfac2) - it=itype(i) - if (it.eq.10) goto 1 -c -C Compute the axes of tghe local cartesian coordinates system; store in -c x_prime, y_prime and z_prime -c - do j=1,3 - x_prime(j) = 0.00 - y_prime(j) = 0.00 - z_prime(j) = 0.00 - enddo -C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), -C & dc_norm(3,i+nres) - do j = 1,3 - x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac - y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac - enddo - do j = 1,3 - z_prime(j) = -uz(j,i-1) - enddo -c write (2,*) "i",i -c write (2,*) "x_prime",(x_prime(j),j=1,3) -c write (2,*) "y_prime",(y_prime(j),j=1,3) -c write (2,*) "z_prime",(z_prime(j),j=1,3) -c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), -c & " xy",scalar(x_prime(1),y_prime(1)), -c & " xz",scalar(x_prime(1),z_prime(1)), -c & " yy",scalar(y_prime(1),y_prime(1)), -c & " yz",scalar(y_prime(1),z_prime(1)), -c & " zz",scalar(z_prime(1),z_prime(1)) -c -C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), -C to local coordinate system. Store in xx, yy, zz. -c - xx=0.0d0 - yy=0.0d0 - zz=0.0d0 - do j = 1,3 - xx = xx + x_prime(j)*dc_norm(j,i+nres) - yy = yy + y_prime(j)*dc_norm(j,i+nres) - zz = zz + z_prime(j)*dc_norm(j,i+nres) - enddo - - xxtab(i)=xx - yytab(i)=yy - zztab(i)=zz -C -C Compute the energy of the ith side cbain -C -c write (2,*) "xx",xx," yy",yy," zz",zz - it=itype(i) - do j = 1,65 - x(j) = sc_parmin(j,it) - enddo -#ifdef CHECK_COORD -Cc diagnostics - remove later - xx1 = dcos(alph(2)) - yy1 = dsin(alph(2))*dcos(omeg(2)) - zz1 = -dsin(alph(2))*dsin(omeg(2)) - write(2,'(3f8.1,3f9.3,1x,3f9.3)') - & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, - & xx1,yy1,zz1 -C," --- ", xx_w,yy_w,zz_w -c end diagnostics -#endif - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) - & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) -c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, -c & sumene4, -c & dscp1,dscp2,sumene -c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - escloc = escloc + sumene -c write (2,*) "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)*dC_norm(j,i+nres) - dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres) - enddo - - dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) - dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) - dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) -c - dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) - dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) - enddo - - do k=1,3 - dXX_Ctab(k,i)=dXX_Ci(k) - dXX_C1tab(k,i)=dXX_Ci1(k) - dYY_Ctab(k,i)=dYY_Ci(k) - dYY_C1tab(k,i)=dYY_Ci1(k) - dZZ_Ctab(k,i)=dZZ_Ci(k) - dZZ_C1tab(k,i)=dZZ_Ci1(k) - dXX_XYZtab(k,i)=dXX_XYZ(k) - dYY_XYZtab(k,i)=dYY_XYZ(k) - dZZ_XYZtab(k,i)=dZZ_XYZ(k) - enddo - - do k = 1,3 -c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", -c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) -c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", -c & dyy_ci(k)," dzz_ci",dzz_ci(k) -c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", -c & dt_dci(k) -c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", -c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) - gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) - & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) - gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) - & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) - gsclocx(k,i)= de_dxx*dxx_XYZ(k) - & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) - enddo -c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), -c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) - -C to check gradient call subroutine check_grad - - 1 continue - enddo - return - end -#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,edihcnstr,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 - 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*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,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 (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*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*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - edihi=0.25d0*ftors*difi**4 - 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 - edihi=0.25d0*ftors*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 '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*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 '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",itau_start,itau_end,nterm_sccor - esccor=0.0D0 - do i=itau_start,itau_end - esccor_ii=0.0D0 - isccori=isccortyp(itype(i-2)) - isccori1=isccortyp(itype(i-1)) - phii=phi(i) -cccc Added 9 May 2012 -cc Tauangle is torsional engle depending on the value of first digit -c(see comment below) -cc Omicron is flat angle depending on the value of first digit -c(see comment below) - - - do intertyp=1,3 !intertyp -cc Added 09 May 2012 (Adasko) -cc Intertyp means interaction type of backbone mainchain correlation: -c 1 = SC...Ca...Ca...Ca -c 2 = Ca...Ca...Ca...SC -c 3 = SC...Ca...Ca...SCi - gloci=0.0D0 - if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. - & (itype(i-1).eq.10).or.(itype(i-2).eq.21).or. - & (itype(i-1).eq.21))) - & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) - & .or.(itype(i-2).eq.21))) - & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. - & (itype(i-1).eq.21)))) cycle - if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle - if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21)) - & cycle - do j=1,nterm_sccor(isccori,isccori1) - v1ij=v1sccor(j,intertyp,isccori,isccori1) - v2ij=v2sccor(j,intertyp,isccori,isccori1) - cosphi=dcos(j*tauangle(intertyp,i)) - sinphi=dsin(j*tauangle(intertyp,i)) - esccor=esccor+v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci -c write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi -c &gloc_sc(intertyp,i-3,icg) - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1sccor(j,intertyp,itori,itori1),j=1,6) - & ,(v2sccor(j,intertyp,itori,itori1),j=1,6) - gsccor_loc(i-3)=gsccor_loc(i-3)+gloci - enddo !intertyp - enddo -c do i=1,nres -c write (iout,*) "W@T@F", gloc_sc(1,i,icg),gloc(i,icg) -c enddo - return - end -c------------------------------------------------------------------------------ - subroutine multibody(ecorr) -C This subroutine calculates multi-body contributions to energy following -C the idea of Skolnick et al. If side chains I and J make a contact and -C at the same time side chains I+1 and J+1 make a contact, an extra -C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - -C Set lprn=.true. for debugging - lprn=.false. - - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(i2,20(1x,i2,f10.5))') - & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) - enddo - endif - ecorr=0.0D0 - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo - do i=nnt,nct-2 - - DO ISHIFT = 3,4 - - i1=i+ishift - num_conti=num_cont(i) - num_conti1=num_cont(i1) - do jj=1,num_conti - j=jcont(jj,i) - do kk=1,num_conti1 - j1=jcont(kk,i1) - if (j1.eq.j+ishift .or. j1.eq.j-ishift) then -cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, -cd & ' ishift=',ishift -C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) - endif ! j1==j+-ishift - enddo ! kk - enddo ! jj - - ENDDO ! ISHIFT - - enddo ! i - return - end -c------------------------------------------------------------------------------ - double precision function esccorr(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont(jj,i) - ekl=facont(kk,k) -cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl -C Calculate the multi-body contribution to energy. -C Calculate multi-body contributions to the gradient. -cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), -cd & k,l,(gacont(m,kk,k),m=1,3) - do m=1,3 - gx(m) =ekl*gacont(m,jj,i) - gx1(m)=eij*gacont(m,kk,k) - gradxorr(m,i)=gradxorr(m,i)-gx(m) - gradxorr(m,j)=gradxorr(m,j)+gx(m) - gradxorr(m,k)=gradxorr(m,k)-gx1(m) - gradxorr(m,l)=gradxorr(m,l)+gx1(m) - enddo - do m=i,j-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) - enddo - enddo - do m=k,l-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) - enddo - enddo - esccorr=-eij*ekl - return - end -c------------------------------------------------------------------------------ -#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 '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' - 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 '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' - 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 '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' - 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 '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' - logical swap - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxvec2(1),auxmat1(2,2) - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C \ /l\ /j\ / C -C \ / \ / \ / C -C o| o | | o |o C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l -C AL 7/4/01 s1 would occur in the sixth-order moment, -C but not in a cluster cumulant -#ifdef MOMENT - s1=dip(1,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph2=-(s1+s2+s3+s4) -#else - eello6_graph2=-(s2+s3+s4) -#endif -c eello6_graph2=-s3 - 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 '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' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C j|/k\| / |/k\|l / C -C / \ / / \ / C -C / o / o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. - iti=itortyp(itype(i)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -#ifdef MOMENT - s1=dip(4,jj,i)*dip(4,kk,k) -#endif - call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#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 -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o \ o \ C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. -cd write (2,*) 'eello_graph4: wturn6',wturn6 - iti=itortyp(itype(i)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - if (k.lt.nres-1) then - itk1=itortyp(itype(k+1)) - else - itk1=ntortyp+1 - endif - itl=itortyp(itype(l)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l -cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, -cd & ' itl',itl,' itl1',itl1 -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dip(3,kk,k) - else - s1=dip(2,jj,j)*dip(2,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph4=-(s1+s2+s3+s4) -#else - eello6_graph4=-(s2+s3+s4) -#endif - 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 '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' - 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 - diff --git a/source/wham/src-NEWSC/energy_p_new.F.org b/source/wham/src-NEWSC/energy_p_new.F.org deleted file mode 100755 index 8f99a16..0000000 --- a/source/wham/src-NEWSC/energy_p_new.F.org +++ /dev/null @@ -1,6452 +0,0 @@ - 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-NEWSC/fitsq.f b/source/wham/src-NEWSC/fitsq.f deleted file mode 100755 index 17d92ee..0000000 --- a/source/wham/src-NEWSC/fitsq.f +++ /dev/null @@ -1,352 +0,0 @@ - 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-NEWSC/geomout.F b/source/wham/src-NEWSC/geomout.F deleted file mode 100755 index d52e23e..0000000 --- a/source/wham/src-NEWSC/geomout.F +++ /dev/null @@ -1,167 +0,0 @@ - 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 - 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 - do i=nnt,nct - ires=i-nnt+1 - iatom=iatom+1 - ica(i)=iatom - iti=itype(i) - write (ipdb,10) iatom,restyp(iti),ires,(c(j,i),j=1,3) - if (iti.ne.10) then - iatom=iatom+1 - write (ipdb,20) iatom,restyp(iti),ires,(c(j,nres+i),j=1,3) - endif - enddo - write (ipdb,'(a)') 'TER' - do i=nnt,nct-1 - if (itype(i).eq.10) then - write (ipdb,30) ica(i),ica(i+1) - else - write (ipdb,30) ica(i),ica(i+1),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))+1,ica(jhpb(i))+1 - enddo - write (ipdb,'(a)') "END" - 10 FORMAT ('ATOM',I7,' CA ',A3,I6,4X,3F8.3) - 20 FORMAT ('ATOM',I7,' CB ',A3,I6,4X,3F8.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 - write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 - 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 - 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-NEWSC/gnmr1.f b/source/wham/src-NEWSC/gnmr1.f deleted file mode 100755 index 905e746..0000000 --- a/source/wham/src-NEWSC/gnmr1.f +++ /dev/null @@ -1,43 +0,0 @@ - double precision function gnmr1(y,ymin,ymax) - implicit none - double precision y,ymin,ymax - double precision wykl /4.0d0/ - if (y.lt.ymin) then - gnmr1=(ymin-y)**wykl/wykl - else if (y.gt.ymax) then - gnmr1=(y-ymax)**wykl/wykl - else - gnmr1=0.0d0 - endif - return - end -c------------------------------------------------------------------------------ - double precision function gnmr1prim(y,ymin,ymax) - implicit none - double precision y,ymin,ymax - double precision wykl /4.0d0/ - if (y.lt.ymin) then - gnmr1prim=-(ymin-y)**(wykl-1) - else if (y.gt.ymax) then - gnmr1prim=(y-ymax)**(wykl-1) - else - gnmr1prim=0.0d0 - endif - return - end -c------------------------------------------------------------------------------ - double precision function harmonic(y,ymax) - implicit none - double precision y,ymax - double precision wykl /2.0d0/ - harmonic=(y-ymax)**wykl - return - end -c------------------------------------------------------------------------------- - double precision function harmonicprim(y,ymax) - double precision y,ymin,ymax - double precision wykl /2.0d0/ - harmonicprim=(y-ymax)*wykl - return - end -c--------------------------------------------------------------------------------- diff --git a/source/wham/src-NEWSC/icant.f b/source/wham/src-NEWSC/icant.f deleted file mode 100755 index 8dc1ec1..0000000 --- a/source/wham/src-NEWSC/icant.f +++ /dev/null @@ -1,9 +0,0 @@ - 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-NEWSC/include_unres/COMMON.CALC b/source/wham/src-NEWSC/include_unres/COMMON.CALC deleted file mode 100755 index 67b4bb9..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.CALC +++ /dev/null @@ -1,15 +0,0 @@ - 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-NEWSC/include_unres/COMMON.CONTACTS b/source/wham/src-NEWSC/include_unres/COMMON.CONTACTS deleted file mode 100755 index d07a0f0..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.CONTACTS +++ /dev/null @@ -1,68 +0,0 @@ -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/wham/src-NEWSC/include_unres/COMMON.CONTPAR b/source/wham/src-NEWSC/include_unres/COMMON.CONTPAR deleted file mode 100755 index 97a73eb..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.CONTPAR +++ /dev/null @@ -1,3 +0,0 @@ - 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-NEWSC/include_unres/COMMON.DERIV b/source/wham/src-NEWSC/include_unres/COMMON.DERIV deleted file mode 100755 index 79f8630..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.DERIV +++ /dev/null @@ -1,30 +0,0 @@ - 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/wham/src-NEWSC/include_unres/COMMON.FFIELD b/source/wham/src-NEWSC/include_unres/COMMON.FFIELD deleted file mode 100755 index 8292679..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.FFIELD +++ /dev/null @@ -1,29 +0,0 @@ -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, - & r0_corr - 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,weights(max_ene), - & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp - common /potentials/ potname(6) - 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 6 - MM; Momo's physics-based potentials -C------------------------------------------------------------------------ diff --git a/source/wham/src-NEWSC/include_unres/COMMON.FRAG b/source/wham/src-NEWSC/include_unres/COMMON.FRAG deleted file mode 100755 index ee151f5..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.FRAG +++ /dev/null @@ -1,5 +0,0 @@ - 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-NEWSC/include_unres/COMMON.GEO b/source/wham/src-NEWSC/include_unres/COMMON.GEO deleted file mode 100755 index 8cfbbde..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.GEO +++ /dev/null @@ -1,2 +0,0 @@ - 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-NEWSC/include_unres/COMMON.HEADER b/source/wham/src-NEWSC/include_unres/COMMON.HEADER deleted file mode 100755 index 7154812..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.HEADER +++ /dev/null @@ -1,2 +0,0 @@ - character*80 titel - common /header/ titel diff --git a/source/wham/src-NEWSC/include_unres/COMMON.INTERACT b/source/wham/src-NEWSC/include_unres/COMMON.INTERACT deleted file mode 100755 index 9adbda4..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.INTERACT +++ /dev/null @@ -1,38 +0,0 @@ - double precision aa,bb,augm,aad,bad,app,bpp,ael6,ael3, - & chis,alphasur,sigmap1,sigmap2,alphiso,rborn,sigiso1,sigiso2, - & sig0head,epshead,wquad,dhead,dtail,wqdip,alphapol,wstate, - & epsintab,eps_out - - 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,nstate,icharge,expon,expon2 - common /interact/aa(ntyp,ntyp),bb(ntyp,ntyp),augm(ntyp,ntyp), - & chis(ntyp,ntyp),alphasur(4,ntyp,ntyp),sigmap1(ntyp,ntyp), - & sigmap2(ntyp,ntyp),alphiso(4,ntyp,ntyp),alphapol(ntyp,ntyp), - & rborn(ntyp,ntyp),sigiso1(ntyp,ntyp),sigiso2(ntyp,ntyp), - & epshead(ntyp,ntyp),wquad(ntyp,ntyp),dhead(2,2,ntyp,ntyp), - & dtail(2,ntyp,ntyp),wqdip(2,ntyp,ntyp),epsintab(ntyp,ntyp), - & eps_out,wstate(4,ntyp,ntyp),sig0head(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, - & nstate(ntyp,ntyp) -C 12/1/95 Array EPS included in the COMMON block. - double precision eps,sigma,sigmaii,rs0,chi,chip,chip0,alp,sigma0, - & sigii,rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp, - & chipp,eps_orig - common /body/eps(ntyp,ntyp),sigma(0:ntyp,0:ntyp), - & sigmaii(ntyp,ntyp), - & rs0(ntyp,ntyp),chi(ntyp,ntyp),chipp(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(20,2),rscp(20,2),eps_orig(ntyp,ntyp),icharge(ntyp) -c 12/5/03 modified 09/18/03 Bond stretching parameters. - double precision vbldp0,vbldsc0,akp,aksc,abond0 - integer nbondterm - common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp, - & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp),nbondterm(ntyp) diff --git a/source/wham/src-NEWSC/include_unres/COMMON.LOCAL b/source/wham/src-NEWSC/include_unres/COMMON.LOCAL deleted file mode 100755 index a248d99..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.LOCAL +++ /dev/null @@ -1,36 +0,0 @@ - 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,itau_start,itau_end -C Parameters of the virtual-bond-angle probability distribution - common /thetas/ a0thet(ntyp),athet(2,ntyp),bthet(2,ntyp), - & polthet(0:3,ntyp),gthet(3,ntyp),theta0(ntyp),sig0(ntyp), - & sigc0(ntyp) -C Parameters of ab initio-derived potential of virtual-bond-angle bending - integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, - & ithetyp(ntyp1),nntheterm - double precision aa0thet(maxthetyp1,maxthetyp1,maxthetyp1), - & aathet(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1), - & bbthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ccthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ddthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & eethet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ffthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1), - & ggthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1) - common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet, - & ffthet, - & ggthet,ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle, - & ndouble,nntheterm -C Parameters of the side-chain probability distribution - common /sclocal/ dsc(ntyp1),dsc_inv(ntyp1),bsc(maxlob,ntyp), - & censc(3,maxlob,ntyp),gaussc(3,3,maxlob,ntyp),dsc0(ntyp1), - & nlob(ntyp1) -C 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,itau_start,itau_end -C Inverses of the actual virtual bond lengths - common /invlen/ vbld_inv(maxres2) diff --git a/source/wham/src-NEWSC/include_unres/COMMON.MINIM b/source/wham/src-NEWSC/include_unres/COMMON.MINIM deleted file mode 100755 index b231b47..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.MINIM +++ /dev/null @@ -1,3 +0,0 @@ - double precision tolf,rtolf - integer maxfun,maxmin - common /minimm/ tolf,rtolf,maxfun,maxmin diff --git a/source/wham/src-NEWSC/include_unres/COMMON.NAMES b/source/wham/src-NEWSC/include_unres/COMMON.NAMES deleted file mode 100755 index a266339..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.NAMES +++ /dev/null @@ -1,7 +0,0 @@ - character*3 restyp - character*1 onelet - common /names/ restyp(ntyp+1),onelet(ntyp+1) - character*10 ename,wname - integer nprint_ene,print_order - common /namterm/ ename(max_ene),wname(max_ene),nprint_ene, - & print_order(max_ene) diff --git a/source/wham/src-NEWSC/include_unres/COMMON.SBRIDGE b/source/wham/src-NEWSC/include_unres/COMMON.SBRIDGE deleted file mode 100755 index 7bba010..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.SBRIDGE +++ /dev/null @@ -1,10 +0,0 @@ - double precision ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss,dhpb, - & dhpb1,forcon,weidis - integer ns,nss,nfree,iss,ihpb,jhpb,nhpb,link_start,link_end, - & ibecarb - common /sbridge/ ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss,ns,nss, - & nfree,iss(maxss) - common /links/ dhpb(maxdim),dhpb1(maxdim),forcon(maxdim), - & ihpb(maxdim),jhpb(maxdim),ibecarb(maxdim),nhpb - common /restraints/ weidis - common /links_split/ link_start,link_end diff --git a/source/wham/src-NEWSC/include_unres/COMMON.SCCOR b/source/wham/src-NEWSC/include_unres/COMMON.SCCOR deleted file mode 100755 index 28d748a..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.SCCOR +++ /dev/null @@ -1,18 +0,0 @@ -cc Parameters of the SCCOR term - double precision v1sccor,v2sccor,vlor1sccor, - & vlor2sccor,vlor3sccor,gloc_sc, - & dcostau,dsintau,dtauangle,dcosomicron, - & domicron,v0sccor - integer nterm_sccor,isccortyp,nsccortyp,nlor_sccor - common /sccor/ v1sccor(maxterm_sccor,3,20,20), - & v2sccor(maxterm_sccor,3,20,20), - & v0sccor(ntyp,ntyp), - & vlor1sccor(maxterm_sccor,20,20), - & vlor2sccor(maxterm_sccor,20,20), - & vlor3sccor(maxterm_sccor,20,20),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),isccortyp(ntyp),nsccortyp, - & nlor_sccor(ntyp,ntyp) - diff --git a/source/wham/src-NEWSC/include_unres/COMMON.SCROT b/source/wham/src-NEWSC/include_unres/COMMON.SCROT deleted file mode 100755 index 2da7b8f..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.SCROT +++ /dev/null @@ -1,3 +0,0 @@ -C Parameters of the SC rotamers (local) term - double precision sc_parmin - common/scrot/sc_parmin(maxsccoef,20) diff --git a/source/wham/src-NEWSC/include_unres/COMMON.TIME1 b/source/wham/src-NEWSC/include_unres/COMMON.TIME1 deleted file mode 100755 index f7f4849..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.TIME1 +++ /dev/null @@ -1,13 +0,0 @@ - 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-NEWSC/include_unres/COMMON.TORCNSTR b/source/wham/src-NEWSC/include_unres/COMMON.TORCNSTR deleted file mode 100755 index f8fc3a1..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.TORCNSTR +++ /dev/null @@ -1,5 +0,0 @@ - integer ndih_constr,idih_constr(maxdih_constr) - integer ndih_nconstr,idih_nconstr(maxdih_constr) - double precision phi0(maxdih_constr),drange(maxdih_constr),ftors - common /torcnstr/ phi0,drange,ftors,ndih_constr,idih_constr, - & ndih_nconstr,idih_nconstr diff --git a/source/wham/src-NEWSC/include_unres/COMMON.TORSION b/source/wham/src-NEWSC/include_unres/COMMON.TORSION deleted file mode 100755 index 8a12451..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.TORSION +++ /dev/null @@ -1,25 +0,0 @@ -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/wham/src-NEWSC/include_unres/COMMON.VAR b/source/wham/src-NEWSC/include_unres/COMMON.VAR deleted file mode 100755 index d560c87..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.VAR +++ /dev/null @@ -1,21 +0,0 @@ -C Store the geometric variables in the following COMMON block. - integer ntheta,nphi,nside,nvar,Origin,nstore,ialph,ivar, - & mask_theta,mask_phi,mask_side - double precision theta,phi,alph,omeg,varsave,esave,varall,vbld, - & thetaref,phiref,costtab,sinttab,cost2tab,sint2tab, - & xxtab,yytab,zztab,xxref,yyref,zzref - common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), - & omicron(2,maxres),tauangle(3,maxres), - & vbld(2*maxres),thetaref(maxres),phiref(maxres), - & costtab(maxres), sinttab(maxres), cost2tab(maxres), - & sint2tab(maxres),xxtab(maxres),yytab(maxres), - & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres), - & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar -C Store the angles and variables corresponding to old conformations (for use -C in MCM). - common /oldgeo/ varsave(maxvar,maxsave),esave(maxsave), - & Origin(maxsave),nstore -C freeze some variables - logical mask_r - common /restr/ varall(maxvar),mask_r,mask_theta(maxres), - & mask_phi(maxres),mask_side(maxres) diff --git a/source/wham/src-NEWSC/include_unres/COMMON.VECTORS b/source/wham/src-NEWSC/include_unres/COMMON.VECTORS deleted file mode 100755 index d880c24..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.VECTORS +++ /dev/null @@ -1,3 +0,0 @@ - common /vectors/ uy(3,maxres),uz(3,maxres), - & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres) - diff --git a/source/wham/src-NEWSC/include_unres/COMMON.WEIGHTS b/source/wham/src-NEWSC/include_unres/COMMON.WEIGHTS deleted file mode 100755 index d7e6e23..0000000 --- a/source/wham/src-NEWSC/include_unres/COMMON.WEIGHTS +++ /dev/null @@ -1,22 +0,0 @@ - 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:20,2),epscp_up(0:20,2),rscp_low(0:20,2), - & rscp_up(0:20,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:20,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-NEWSC/initialize_p.F b/source/wham/src-NEWSC/initialize_p.F deleted file mode 100755 index 7ac8109..0000000 --- a/source/wham/src-NEWSC/initialize_p.F +++ /dev/null @@ -1,577 +0,0 @@ - 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 - 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 -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 -#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.INTERACT' - 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','MM'/ - data ename / - & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ", - & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ", - & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB","EVDWPP", - & "EVDW2_14","ESTR","ESCCOR","EDIHC","EVDW_T"/ - data wname / - & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", - & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD", - & "WHPB","WVDWPP","WSCP14","WBOND","WSCCOR","WDIHC","WSC"/ - data ww0 /1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0, - & 1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,0.4d0,1.0d0,1.0d0, - & 0.0d0,0.0/ - data nprint_ene /21/ - data print_order /1,2,3,18,11,12,13,14,4,5,6,7,8,9,10,19, - & 16,15,17,20,21/ -c Dielectric constant of water - data eps_out /80.0d0/ - 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 - call int_bounds(nres-3,itau_start,itau_end) - itau_start=itau_start+3 - itau_end=itau_end+3 - if (lprint) then - write (iout,*) 'Processor:',MyID, - & ' loc_start',loc_start,' loc_end',loc_end, - & ' ithet_start',ithet_start,' ithet_end',ithet_end, - & ' iphi_start',iphi_start,' iphi_end',iphi_end - write (*,*) 'Processor:',MyID, - & ' loc_start',loc_start,' loc_end',loc_end, - & ' ithet_start',ithet_start,' ithet_end',ithet_end, - & ' iphi_start',iphi_start,' iphi_end',iphi_end - endif - if (fgprocs.gt.1 .and. MyID.eq.BossID) then - write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ', - & nele_int_tot,' electrostatic and ',nscp_int_tot, - & ' SC-p interactions','were distributed among',fgprocs, - & ' fine-grain processors.' - endif -#else - loc_start=2 - loc_end=nres-1 - ithet_start=3 - ithet_end=nres - iphi_start=nnt+3 - iphi_end=nct - itau_start=4 - itau_end=nres -#endif - return - end -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-NEWSC/initialize_p.F.org b/source/wham/src-NEWSC/initialize_p.F.org deleted file mode 100755 index 3e7d056..0000000 --- a/source/wham/src-NEWSC/initialize_p.F.org +++ /dev/null @@ -1,571 +0,0 @@ - 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-NEWSC/int_from_cart.f b/source/wham/src-NEWSC/int_from_cart.f deleted file mode 100755 index c0cd6e7..0000000 --- a/source/wham/src-NEWSC/int_from_cart.f +++ /dev/null @@ -1,66 +0,0 @@ - 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-NEWSC/intcor.f b/source/wham/src-NEWSC/intcor.f deleted file mode 100755 index 04cbbbc..0000000 --- a/source/wham/src-NEWSC/intcor.f +++ /dev/null @@ -1,94 +0,0 @@ -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-NEWSC/make_ensemble1.F b/source/wham/src-NEWSC/make_ensemble1.F deleted file mode 100755 index 5d7b750..0000000 --- a/source/wham/src-NEWSC/make_ensemble1.F +++ /dev/null @@ -1,375 +0,0 @@ - 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.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, - & ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3, - & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor,tt - 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) - 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) -#ifdef SPLITELE - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees - & +wvdwpp*evdw1 - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc - & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#else - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 - & +ft(1)*welec*(ees+evdw1) - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr - & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#endif -#ifdef 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) - 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-NEWSC/match_contact.f b/source/wham/src-NEWSC/match_contact.f deleted file mode 100755 index 3ec2036..0000000 --- a/source/wham/src-NEWSC/match_contact.f +++ /dev/null @@ -1,339 +0,0 @@ - subroutine match_contact(ishif1,ishif2,nc_match,nc_match1_max, - & ncont_ref,icont_ref,ncont,icont,jfrag,n_shif1,n_shif2, - & nc_frac,nc_req_set,istr,llocal,lprn) - 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 - 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,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,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,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,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,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,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",-is,-js," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=-is - ishif2=-js - return - endif - call ncont_match(nc_match,nc_match1,is,js,ncont_ref, - & icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",is,js," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=is - ishif2=js - return - endif -c - call ncont_match(nc_match,nc_match1,-js,-is,ncont_ref, - & icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",-js,-is," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=-js - ishif2=-is - return - endif -c - call ncont_match(nc_match,nc_match1,js,is,ncont_ref, - & icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",js,is," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=js - ishif2=is - return - endif - endif -c - if (is+js.le.n_shif1) then - call ncont_match(nc_match,nc_match1,-is,js,ncont_ref, - & icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",-is,js," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=-is - ishif2=js - return - endif -c - call ncont_match(nc_match,nc_match1,js,-is,ncont_ref, - & icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",js,-is," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=js - ishif2=-is - return - endif - endif -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,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",-is,-is," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=-is - ishif2=-is - return - endif - call ncont_match(nc_match,nc_match1,is,is,ncont_ref, - & icont_ref,ncont,icont,jfrag,llocal,lprn) - if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 - if (lprn .and. nc_match.gt.0) write (iout,*) - & "Shift:",is,is," nc_match1",nc_match1, - & " nc_match=",nc_match," req'd",nc_req - if (nc_match.ge.nc_req) then - ishif1=is - ishif2=is - return - endif - enddo - endif -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,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) -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) write (iout,'(80(1h*))') - 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, - & lprn) - if (lprn) write (iout,*) "diffang:",diffang*rad2deg, - & " ang_cut:",ang_cut(jfrag)*rad2deg," fract",fract - if (diffang.le.ang_cut(jfrag) .and. fract.ge.frac_min(jfrag)) - & then - nc_match=1 - else - nc_match=0 - endif - return - endif - nang_pair=0 - do i=1,ncont - ic1=icont(1,i)+ishif1 - ic2=icont(2,i)+ishif2 -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) - 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,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) - 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(j).eq.isec_ref(j) .or. -c & isecstr(j).eq.0 .and. isec_ref(j).eq.1 .or. - & isec_ref(j).eq.0 .and. isecstr(j).eq.1) - & nsec_match=nsec_match+1 - enddo - enddo - return - end diff --git a/source/wham/src-NEWSC/matmult.f b/source/wham/src-NEWSC/matmult.f deleted file mode 100755 index e9257cf..0000000 --- a/source/wham/src-NEWSC/matmult.f +++ /dev/null @@ -1,18 +0,0 @@ - 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-NEWSC/misc.f b/source/wham/src-NEWSC/misc.f deleted file mode 100755 index e189839..0000000 --- a/source/wham/src-NEWSC/misc.f +++ /dev/null @@ -1,203 +0,0 @@ -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-NEWSC/molread_zs.F b/source/wham/src-NEWSC/molread_zs.F deleted file mode 100755 index 431680d..0000000 --- a/source/wham/src-NEWSC/molread_zs.F +++ /dev/null @@ -1,378 +0,0 @@ - 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' - character*4 sequence(maxres) - integer rescode - double precision x(maxvar) - character*320 controlcard,ucase - dimension itype_pdb(maxres) - logical seq_comp - call card_concat(controlcard,.true.) - call reada(controlcard,'SCAL14',scal14,0.4d0) - call reada(controlcard,'SCALSCP',scalscp,1.0d0) - call reada(controlcard,'CUTOFF',cutoff_corr,7.0d0) - call reada(controlcard,'DELT_CORR',delt_corr,0.5d0) - r0_corr=cutoff_corr-delt_corr - 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.21 .or. itype(i+1).eq.21) then -#else - if (itype(i).eq.21) then -#endif - itel(i)=0 -#ifdef PROCOR - else if (itype(i+1).ne.20) then -#else - else if (itype(i).ne.20) then -#endif - itel(i)=1 - else - itel(i)=2 - endif - enddo - call read_bridge - - if (with_dihed_constr) then - - read (inp,*) ndih_constr - if (ndih_constr.gt.0) then - read (inp,*) ftors - write (iout,*) 'FTORS',ftors - read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr) - write (iout,*) - & 'There are',ndih_constr,' constraints on phi angles.' - do i=1,ndih_constr - write (iout,'(i5,2f8.3)') idih_constr(i),phi0(i),drange(i) - enddo - do i=1,ndih_constr - phi0(i)=deg2rad*phi0(i) - drange(i)=deg2rad*drange(i) - enddo - endif - - endif - - nnt=1 - nct=nres - if (itype(1).eq.21) nnt=2 - if (itype(nres).eq.21) nct=nct-1 - write(iout,*) 'NNT=',NNT,' NCT=',NCT -c Read distance restraints - if (constr_dist.gt.0) then - if (refstr) call read_ref_structure(*11) - call read_dist_constr - call hpb_partition - 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) - write (iout,'(/a/)') 'Pre-formed links are:' - do i=1,nss - i1=ihpb(i)-nres - i2=jhpb(i)-nres - it1=itype(i1) - it2=itype(i2) - write (iout,'(2a,i3,3a,i3,a,3f10.3)') - & restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')', - & dhpb(i),ebr,forcon(i) - enddo - endif - write (iout,'(a)') - return - 11 stop "Error reading reference structure" - 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(iss(i)),i, - & ' can form a disulfide bridge?!!!' - write (*,'(2a,i3,a)') - & 'Do you REALLY think that the residue ',restyp(iss(i)),i, - & ' can form a disulfide bridge?!!!' - 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_dist_constr - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.SBRIDGE' - integer ifrag_(2,100),ipair_(2,100) - double precision wfrag_(100),wpair_(100) - character*500 controlcard -c write (iout,*) "Calling read_dist_constr" -c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup -c call flush(iout) - call card_concat(controlcard,.true.) - call readi(controlcard,"NFRAG",nfrag_,0) - call readi(controlcard,"NPAIR",npair_,0) - call readi(controlcard,"NDIST",ndist_,0) - call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) - call multreadi(controlcard,"IFRAG",ifrag_(1,1),2*nfrag_,0) - call multreadi(controlcard,"IPAIR",ipair_(1,1),2*npair_,0) - call multreada(controlcard,"WFRAG",wfrag_(1),nfrag_,0.0d0) - call multreada(controlcard,"WPAIR",wpair_(1),npair_,0.0d0) - write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_ - write (iout,*) "IFRAG" - do i=1,nfrag_ - write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) - enddo - write (iout,*) "IPAIR" - do i=1,npair_ - write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i) - enddo - call flush(iout) - if (.not.refstr .and. nfrag_.gt.0) then - write (iout,*) - & "ERROR: no reference structure to compute distance restraints" - write (iout,*) - & "Restraints must be specified explicitly (NDIST=number)" - stop - endif - if (nfrag_.lt.2 .and. npair_.gt.0) then - write (iout,*) "ERROR: Less than 2 fragments specified", - & " but distance restraints between pairs requested" - stop - endif - call flush(iout) - do i=1,nfrag_ - if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup - if (ifrag_(2,i).gt.nstart_sup+nsup-1) - & ifrag_(2,i)=nstart_sup+nsup-1 -c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) - call flush(iout) - if (wfrag_(i).gt.0.0d0) then - do j=ifrag_(1,i),ifrag_(2,i)-1 - do k=j+1,ifrag_(2,i) - write (iout,*) "j",j," k",k - ddjk=dist(j,k) - if (constr_dist.eq.1) then - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i) - else if (constr_dist.eq.2) then - if (ddjk.le.dist_cut) then - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i) - endif - else - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) - endif - write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) - enddo - enddo - endif - enddo - do i=1,npair_ - if (wpair_(i).gt.0.0d0) then - ii = ipair_(1,i) - jj = ipair_(2,i) - if (ii.gt.jj) then - itemp=ii - ii=jj - jj=itemp - endif - do j=ifrag_(1,ii),ifrag_(2,ii) - do k=ifrag_(1,jj),ifrag_(2,jj) - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - forcon(nhpb)=wpair_(i) - dhpb(nhpb)=dist(j,k) - write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) - enddo - enddo - endif - enddo - do i=1,ndist_ - read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(i),dhpb1(i), - & ibecarb(i),forcon(nhpb+1) - if (forcon(nhpb+1).gt.0.0d0) then - nhpb=nhpb+1 - if (ibecarb(i).gt.0) then - ihpb(i)=ihpb(i)+nres - jhpb(i)=jhpb(i)+nres - endif - if (dhpb(nhpb).eq.0.0d0) - & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) - endif - enddo - do i=1,nhpb - write (iout,'(a,3i5,2f8.2,i2,f10.1)') "+dist.constr ", - & i,ihpb(i),jhpb(i),dhpb(i),dhpb1(i),ibecarb(i),forcon(i) - enddo - call flush(iout) - return - end diff --git a/source/wham/src-NEWSC/mygetenv.F b/source/wham/src-NEWSC/mygetenv.F deleted file mode 100755 index b5ea4a2..0000000 --- a/source/wham/src-NEWSC/mygetenv.F +++ /dev/null @@ -1,55 +0,0 @@ - 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-NEWSC/mysort.f b/source/wham/src-NEWSC/mysort.f deleted file mode 100755 index cb1bbe7..0000000 --- a/source/wham/src-NEWSC/mysort.f +++ /dev/null @@ -1,52 +0,0 @@ - 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-NEWSC/odlodc.f b/source/wham/src-NEWSC/odlodc.f deleted file mode 100755 index c18ac72..0000000 --- a/source/wham/src-NEWSC/odlodc.f +++ /dev/null @@ -1,55 +0,0 @@ - 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-NEWSC/openunits.F b/source/wham/src-NEWSC/openunits.F deleted file mode 100755 index b9f54b7..0000000 --- a/source/wham/src-NEWSC/openunits.F +++ /dev/null @@ -1,105 +0,0 @@ - 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) - open (ibond,file=bondname,status='old') - call mygetenv('THETPAR',thetname) - open (ithep,file=thetname,status='old') - call mygetenv('ROTPAR',rotname) - open (irotam,file=rotname,status='old') - call mygetenv('TORPAR',torname) - open (itorp,file=torname,status='old') - call mygetenv('TORDPAR',tordname) - open (itordp,file=tordname,status='old') - call mygetenv('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old') - call mygetenv('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old') - call mygetenv('ELEPAR',elename) - open (ielep,file=elename,status='old') - call mygetenv('SIDEPAR',sidename) - open (isidep,file=sidename,status='old') - call mygetenv('SIDEP',sidepname) - open (isidep1,file=sidepname,status="old") -#ifndef OLDSCP -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,'(80(1h-))') - write (iout,*) - return - end - diff --git a/source/wham/src-NEWSC/parmread.F b/source/wham/src-NEWSC/parmread.F deleted file mode 100755 index baa4a05..0000000 --- a/source/wham/src-NEWSC/parmread.F +++ /dev/null @@ -1,1108 +0,0 @@ - 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' - character*1 t1,t2,t3 - character*1 onelett(4) /"G","A","P","D"/ - 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 -C -C Body -C -C Set LPRINT=.TRUE. for debugging - dwa16=2.0d0**(1.0d0/6.0d0) - lprint=.true. - 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 - - 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) - wstrain=ww(15) - wbond=ww(18) - wsccor=ww(19) - - 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) - open (itordp,file=tordname_t,status='old') - rewind(itordp) - call reads(controlcard,"SCCORAR",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,*) vbldp0,akp - do i=1,ntyp - nbondterm(i)=1 - read (ibond,*) vbldsc0(1,i),aksc(1,i) - dsc(i) = vbldsc0(1,i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - enddo -#else - read (ibond,*) ijunk,vbldp0,akp,rjunk - do i=1,ntyp - read (ibond,*) nbondterm(i),(vbldsc0(j,i),aksc(j,i),abond0(j,i), - & j=1,nbondterm(i)) - dsc(i) = vbldsc0(1,i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - enddo -#endif - if (lprint) then - write(iout,'(/a/)')"Force constants virtual bonds:" - write (iout,'(a10,a3,6a10)') 'Type','N','VBL','K', - & 'inertia','Pstok' - write(iout,'(a10,i3,6f10.5)') "p",1,vbldp0,akp,0.0d0 - do i=1,ntyp - write (iout,'(a10,i3,6f10.5)') restyp(i),nbondterm(i), - & vbldsc0(1,i),aksc(1,i),abond0(1,i) - do j=2,nbondterm(i) - write (iout,'(13x,3f10.5)') - & vbldsc0(j,i),aksc(j,i),abond0(j,i) - enddo - enddo - endif -#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,*) a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2) - read (ithep,*) (polthet(j,i),j=0,3) - read (ithep,*) (gthet(j,i),j=1,3) - read (ithep,*) theta0(i),sig0(i),sigc0(i) - sigc0(i)=sigc0(i)**2 - 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),j=1,2),(10*bthet(j,i),j=1,2) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the expression for sigma(theta_c):', - & ' alpha0 ',' alph1 ',' alph2 ', - & ' alhp3 ',' sigma0c ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(1pe12.3,1h&))') restyp(i), - & (polthet(j,i),j=0,3),sigc0(i) - enddo - write (iout,'(/a/9x,5a/79(1h-))') - & 'Parameters of the second gaussian:', - & ' theta0 ',' sigma0*10^2 ',' G1*10^-1', - & ' G2 ',' G3*10^1 ' - do i=1,ntyp - write (iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),theta0(i), - & 100*sig0(i),gthet(1,i)*0.1D0,gthet(2,i),gthet(3,i)*10.0D0 - enddo - endif -#else -C -C Read the parameters of Utheta determined from ab initio surfaces -C Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -C - read (ithep,*) nthetyp,ntheterm,ntheterm2, - & ntheterm3,nsingle,ndouble - nntheterm=max0(ntheterm,ntheterm2,ntheterm3) - read (ithep,*) (ithetyp(i),i=1,ntyp1) - do i=1,maxthetyp - do j=1,maxthetyp - do k=1,maxthetyp - aa0thet(i,j,k)=0.0d0 - do l=1,ntheterm - aathet(l,i,j,k)=0.0d0 - enddo - do l=1,ntheterm2 - do m=1,nsingle - bbthet(m,l,i,j,k)=0.0d0 - ccthet(m,l,i,j,k)=0.0d0 - ddthet(m,l,i,j,k)=0.0d0 - eethet(m,l,i,j,k)=0.0d0 - enddo - enddo - do l=1,ntheterm3 - do m=1,ndouble - do mm=1,ndouble - ffthet(mm,m,l,i,j,k)=0.0d0 - ggthet(mm,m,l,i,j,k)=0.0d0 - enddo - enddo - enddo - enddo - enddo - enddo - do i=1,nthetyp - do j=1,nthetyp - do k=1,nthetyp - read (ithep,'(3a)') res1,res2,res3 - read (ithep,*) aa0thet(i,j,k) - read (ithep,*)(aathet(l,i,j,k),l=1,ntheterm) - read (ithep,*) - & ((bbthet(lll,ll,i,j,k),lll=1,nsingle), - & (ccthet(lll,ll,i,j,k),lll=1,nsingle), - & (ddthet(lll,ll,i,j,k),lll=1,nsingle), - & (eethet(lll,ll,i,j,k),lll=1,nsingle),ll=1,ntheterm2) - read (ithep,*) - & (((ffthet(llll,lll,ll,i,j,k),ffthet(lll,llll,ll,i,j,k), - & ggthet(llll,lll,ll,i,j,k),ggthet(lll,llll,ll,i,j,k), - & llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) - enddo - enddo - enddo -C -C For dummy ends assign glycine-type coefficients of theta-only terms; the -C coefficients of theta-and-gamma-dependent terms are zero. -C - do i=1,nthetyp - do j=1,nthetyp - do l=1,ntheterm - aathet(l,i,j,nthetyp+1)=aathet(l,i,j,1) - aathet(l,nthetyp+1,i,j)=aathet(l,1,i,j) - enddo - aa0thet(i,j,nthetyp+1)=aa0thet(i,j,1) - aa0thet(nthetyp+1,i,j)=aa0thet(1,i,j) - enddo - do l=1,ntheterm - aathet(l,nthetyp+1,i,nthetyp+1)=aathet(l,1,i,1) - enddo - aa0thet(nthetyp+1,i,nthetyp+1)=aa0thet(1,i,1) - enddo -C -C Control printout of the coefficients of virtual-bond-angle potentials -C - if (lprint) then - write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' - do i=1,nthetyp+1 - do j=1,nthetyp+1 - do k=1,nthetyp+1 - write (iout,'(//4a)') - & 'Type ',onelett(i),onelett(j),onelett(k) - write (iout,'(//a,10x,a)') " l","a[l]" - write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k) - write (iout,'(i2,1pe15.5)') - & (l,aathet(l,i,j,k),l=1,ntheterm) - do l=1,ntheterm2 - write (iout,'(//2h m,4(9x,a,3h[m,i1,1h]))') - & "b",l,"c",l,"d",l,"e",l - do m=1,nsingle - write (iout,'(i2,4(1pe15.5))') m, - & bbthet(m,l,i,j,k),ccthet(m,l,i,j,k), - & ddthet(m,l,i,j,k),eethet(m,l,i,j,k) - enddo - enddo - do l=1,ntheterm3 - write (iout,'(//3hm,n,4(6x,a,5h[m,n,i1,1h]))') - & "f+",l,"f-",l,"g+",l,"g-",l - do m=2,ndouble - do n=1,m-1 - write (iout,'(i1,1x,i1,4(1pe15.5))') n,m, - & ffthet(n,m,l,i,j,k),ffthet(m,n,l,i,j,k), - & ggthet(n,m,l,i,j,k),ggthet(m,n,l,i,j,k) - enddo - enddo - enddo - enddo - enddo - enddo - call flush(iout) - endif -#endif - -#ifdef CRYST_SC -C -C Read the parameters of the probability distribution/energy expression -C of the side chains. -C - do i=1,ntyp - read (irotam,'(3x,i3,f8.3)') nlob(i),dsc(i) - if (i.eq.10) then - dsc_inv(i)=0.0D0 - else - dsc_inv(i)=1.0D0/dsc(i) - endif - if (i.ne.10) then - do j=1,nlob(i) - do k=1,3 - do l=1,3 - blower(l,k,j)=0.0D0 - enddo - enddo - enddo - bsc(1,i)=0.0D0 - read(irotam,*)(censc(k,1,i),k=1,3),((blower(k,l,1),l=1,k),k=1,3) - do j=2,nlob(i) - read (irotam,*) bsc(j,i) - read (irotam,*) (censc(k,j,i),k=1,3), - & ((blower(k,l,j),l=1,k),k=1,3) - enddo - do j=1,nlob(i) - do k=1,3 - do l=1,k - akl=0.0D0 - do m=1,3 - akl=akl+blower(k,m,j)*blower(l,m,j) - enddo - gaussc(k,l,j,i)=akl - gaussc(l,k,j,i)=akl - enddo - enddo - enddo - endif - enddo - close (irotam) - if (lprint) then - write (iout,'(/a)') 'Parameters of side-chain local geometry' - do i=1,ntyp - nlobi=nlob(i) - if (nlobi.gt.0) then - 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,*) - if (i.eq.10) then - read (irotam,*) - else - do j=1,65 - read(irotam,*) sc_parmin(j,i) - enddo - endif - enddo -#endif - close(irotam) -#ifdef CRYST_TOR -C -C Read torsional parameters in old format -C - read (itorp,*) ntortyp,nterm_old - write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old - read (itorp,*) (itortyp(i),i=1,ntyp) - do i=1,ntortyp - do j=1,ntortyp - read (itorp,'(a)') - do k=1,nterm_old - read (itorp,*) kk,v1(k,j,i),v2(k,j,i) - enddo - enddo - enddo - close (itorp) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,ntortyp - do j=1,ntortyp - write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) - write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) - enddo - enddo - endif - - -#else -C -C Read torsional parameters -C - read (itorp,*) ntortyp - read (itorp,*) (itortyp(i),i=1,ntyp) - write (iout,*) 'ntortyp',ntortyp - do i=1,ntortyp - do j=1,ntortyp - read (itorp,*) nterm(i,j),nlor(i,j) - v0ij=0.0d0 - si=-1.0d0 - do k=1,nterm(i,j) - read (itorp,*) kk,v1(k,i,j),v2(k,i,j) - v0ij=v0ij+si*v1(k,i,j) - si=-si - enddo - do k=1,nlor(i,j) - read (itorp,*) kk,vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) - v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) - enddo - v0(i,j)=v0ij - enddo - enddo - close (itorp) - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,ntortyp - do j=1,ntortyp - write (iout,*) 'ityp',i,' jtyp',j - write (iout,*) 'Fourier constants' - do k=1,nterm(i,j) - write (iout,'(2(1pe15.5))') v1(k,i,j),v2(k,i,j) - enddo - write (iout,*) 'Lorenz constants' - do k=1,nlor(i,j) - write (iout,'(3(1pe15.5))') - & vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) - enddo - enddo - enddo - endif -C -C 6/23/01 Read parameters for double torsionals -C - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - read (itordp,'(3a1)') t1,t2,t3 - if (t1.ne.onelett(i) .or. t2.ne.onelett(j) - & .or. t3.ne.onelett(k)) then - write (iout,*) "Error in double torsional parameter file", - & i,j,k,t1,t2,t3 - stop "Error in double torsional parameter file" - endif - read (itordp,*) ntermd_1(i,j,k),ntermd_2(i,j,k) - read (itordp,*) (v1c(1,l,i,j,k),l=1,ntermd_1(i,j,k)) - read (itordp,*) (v1s(1,l,i,j,k),l=1,ntermd_1(i,j,k)) - read (itordp,*) (v1c(2,l,i,j,k),l=1,ntermd_1(i,j,k)) - read (itordp,*) (v1s(2,l,i,j,k),l=1,ntermd_1(i,j,k)) - read (itordp,*) ((v2c(l,m,i,j,k),v2c(m,l,i,j,k), - & v2s(l,m,i,j,k),v2s(m,l,i,j,k),m=1,l-1),l=1,ntermd_2(i,j,k)) - enddo - enddo - enddo - if (lprint) then - write (iout,*) - write (iout,*) 'Constants for double torsionals' - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k, - & ' nsingle',ntermd_1(i,j,k),' ndouble',ntermd_2(i,j,k) - write (iout,*) - write (iout,*) 'Single angles:' - do l=1,ntermd_1(i,j,k) - write (iout,'(i5,2f10.5,5x,2f10.5)') l, - & v1c(1,l,i,j,k),v1s(1,l,i,j,k), - & v1c(2,l,i,j,k),v1s(2,l,i,j,k) - enddo - write (iout,*) - write (iout,*) 'Pairs of angles:' - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) - do l=1,ntermd_2(i,j,k) - write (iout,'(i5,20f10.5)') - & l,(v2c(l,m,i,j,k),m=1,ntermd_2(i,j,k)) - enddo - write (iout,*) - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) - do l=1,ntermd_2(i,j,k) - write (iout,'(i5,20f10.5)') - & l,(v2s(l,m,i,j,k),m=1,ntermd_2(i,j,k)) - enddo - write (iout,*) - enddo - enddo - enddo - endif -#endif -C Read of Side-chain backbone correlation parameters -C Modified 11 May 2012 by Adasko -CCC -C - read (isccor,*) nsccortyp - read (isccor,*) (isccortyp(i),i=1,ntyp) -c write (iout,*) 'ntortyp',ntortyp - maxinter=3 -cc maxinter is maximum interaction sites - do l=1,maxinter - do i=1,nsccortyp - do j=1,nsccortyp - read (isccor,*) nterm_sccor(i,j),nlor_sccor(i,j) - v0ijsccor=0.0d0 - si=-1.0d0 - - do k=1,nterm_sccor(i,j) - read (isccor,*) kk,v1sccor(k,l,i,j) - & ,v2sccor(k,l,i,j) - v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) - si=-si - enddo - do k=1,nlor_sccor(i,j) - read (isccor,*) kk,vlor1sccor(k,i,j), - & vlor2sccor(k,i,j),vlor3sccor(k,i,j) - v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ - &(1+vlor3sccor(k,i,j)**2) - enddo - v0sccor(i,j)=v0ijsccor - enddo - enddo - enddo - close (isccor) - - if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,nsccortyp - do j=1,nsccortyp - write (iout,*) 'ityp',i,' jtyp',j - write (iout,*) 'Fourier constants' - do k=1,nterm_sccor(i,j) - write(iout,'(2(1pe15.5))')(v1sccor(k,l,i,j),v2sccor(k,l,i,j), - & l=1,maxinter) - enddo - write (iout,*) 'Lorenz constants' - do k=1,nlor_sccor(i,j) - write (iout,'(3(1pe15.5))') - & vlor1sccor(k,i,j),vlor2sccor(k,i,j),vlor3sccor(k,i,j) - enddo - enddo - enddo - endif - -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,*) nloctyp - do i=1,nloctyp - read (ifourier,*) - read (ifourier,*) (b(ii,i),ii=1,13) - if (lprint) then - write (iout,*) 'Type',i - write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii,i),ii=1,13) - endif - B1(1,i) = b(3,i) - B1(2,i) = b(5,i) - B1tilde(1,i) = b(3,i) - B1tilde(2,i) =-b(5,i) - B2(1,i) = b(2,i) - B2(2,i) = b(4,i) - CC(1,1,i)= b(7,i) - CC(2,2,i)=-b(7,i) - CC(2,1,i)= b(9,i) - CC(1,2,i)= b(9,i) - Ctilde(1,1,i)=b(7,i) - Ctilde(1,2,i)=b(9,i) - Ctilde(2,1,i)=-b(9,i) - Ctilde(2,2,i)=b(7,i) - DD(1,1,i)= b(6,i) - DD(2,2,i)=-b(6,i) - DD(2,1,i)= b(8,i) - DD(1,2,i)= b(8,i) - Dtilde(1,1,i)=b(6,i) - Dtilde(1,2,i)=b(8,i) - Dtilde(2,1,i)=-b(8,i) - Dtilde(2,2,i)=b(6,i) - EE(1,1,i)= b(10,i)+b(11,i) - EE(2,2,i)=-b(10,i)+b(11,i) - EE(2,1,i)= b(12,i)-b(13,i) - EE(1,2,i)= b(12,i)+b(13,i) - enddo - if (lprint) then - do i=1,nloctyp - write (iout,*) 'Type',i - write (iout,*) 'B1' -c write (iout,'(f10.5)') B1(:,i) - write(iout,*) B1(1,i),B1(2,i) - write (iout,*) 'B2' -c write (iout,'(f10.5)') B2(:,i) - write(iout,*) B2(1,i),B2(2,i) - write (iout,*) 'CC' - do j=1,2 - write (iout,'(2f10.5)') CC(j,1,i),CC(j,2,i) - enddo - write(iout,*) 'DD' - do j=1,2 - write (iout,'(2f10.5)') DD(j,1,i),DD(j,2,i) - enddo - write(iout,*) 'EE' - do j=1,2 - write (iout,'(2f10.5)') EE(j,1,i),EE(j,2,i) - enddo - enddo - endif -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,*) ((epp(i,j),j=1,2),i=1,2) - read (ielep,*) ((rpp(i,j),j=1,2),i=1,2) - read (ielep,*) ((elpp6(i,j),j=1,2),i=1,2) - read (ielep,*) ((elpp3(i,j),j=1,2),i=1,2) - close (ielep) - do i=1,2 - do j=1,2 - rri=rpp(i,j)**6 - app (i,j)=epp(i,j)*rri*rri - bpp (i,j)=-2.0D0*epp(i,j)*rri - ael6(i,j)=elpp6(i,j)*4.2D0**6 - ael3(i,j)=elpp3(i,j)*4.2D0**3 - if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j), - & ael6(i,j),ael3(i,j) - enddo - enddo -C -C Read side-chain interaction parameters. -C - read (isidep,*) ipot,expon - if (ipot.lt.1 .or. ipot.gt.6) 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,50) ipot -C----------------------- LJ potential --------------------------------- - 10 read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp),(sigma0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJ potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,a)') 'residue','sigma' - write (iout,'(a3,6x,f10.5)') (restyp(i),sigma0(i),i=1,ntyp) - endif - goto 60 -C----------------------- LJK potential -------------------------------- - 20 read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the LJK potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,2a)') 'residue',' sigma ',' r0 ' - write (iout,'(a3,6x,2f10.5)') (restyp(i),sigma0(i),rr0(i), - & i=1,ntyp) - endif - goto 60 -C---------------------- GB or BP potential ----------------------------- - 30 read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(sigii(i),i=1,ntyp),(chip0(i),i=1,ntyp), - & (alp(i),i=1,ntyp) -C For the GB potential convert sigma'**2 into chi' - if (ipot.eq.4) then - do i=1,ntyp - chip(i)=(chip0(i)-1.0D0)/(chip0(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 60 -C--------------------- GBV potential ----------------------------------- - 40 read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp),(sigii(i),i=1,ntyp), - & (chip(i),i=1,ntyp),(alp(i),i=1,ntyp) - if (lprint) then - write (iout,'(/a/)') 'Parameters of the GBV potential:' - write (iout,'(a/)') 'The epsilon array:' - call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) - write (iout,'(/a)') 'One-body parameters:' - write (iout,'(a,4x,5a)') 'residue',' sigma ',' r0 ', - & 's||/s_|_^2',' chip ',' alph ' - write (iout,'(a3,6x,5f10.5)') (restyp(i),sigma0(i),rr0(i), - & sigii(i),chip(i),alp(i),i=1,ntyp) - endif - goto 60 -C--------------------- Momo potential ----------------------------------- - - 50 continue - - read (isidep,*) (icharge(i),i=1,ntyp) -c write (2,*) "icharge",(icharge(i),i=1,ntyp) - do i=1,ntyp - do j=1,i -c! write (*,*) "Im in ", i, " ", j - read(isidep,*) - & eps(i,j),sigma(i,j),chi(i,j),chi(j,i),chipp(i,j),chipp(j,i), - & (alphasur(k,i,j),k=1,4),sigmap1(i,j),sigmap2(i,j), - & chis(i,j),chis(j,i), - & nstate(i,j),(wstate(k,i,j),k=1,4), - & dhead(1,1,i,j), - & dhead(1,2,i,j), - & dhead(2,1,i,j), - & dhead(2,2,i,j), - & dtail(1,i,j),dtail(2,i,j), - & epshead(i,j),sig0head(i,j), - & rborn(i,j),rborn(j,i), - & (wqdip(k,i,j),k=1,2),wquad(i,j), - & alphapol(i,j),alphapol(j,i), - & (alphiso(k,i,j),k=1,4),sigiso1(i,j),sigiso2(i,j),epsintab(i,j) - END DO - END DO -c! write (*,*) "nstate gly-gly", nstate(10,10) -c! THIS LOOP FILLS PARAMETERS FOR PAIRS OF AA's NOT EXPLICITLY -c! DEFINED IN SCPARM.MOMO. IT DOES SO BY TAKING THEM FROM SYMMETRIC -c! PAIR, FOR EG. IF ARG-HIS IS BLANK, IT WILL TAKE PARAMETERS -c! FROM HIS-ARG. -c! -c! DISABLE IT AT >>YOUR OWN PERIL<< -c! - DO i = 1, ntyp - DO j = i+1, ntyp - eps(i,j) = eps(j,i) - sigma(i,j) = sigma(j,i) - nstate(i,j) = nstate(j,i) - sigmap1(i,j) = sigmap1(j,i) - sigmap2(i,j) = sigmap2(j,i) - sigiso1(i,j) = sigiso1(j,i) - sigiso2(i,j) = sigiso2(j,i) - - DO k = 1, 4 - alphasur(k,i,j) = alphasur(k,j,i) - wstate(k,i,j) = wstate(k,j,i) - alphiso(k,i,j) = alphiso(k,j,i) - END DO - - dhead(2,1,i,j) = dhead(1,1,j,i) - dhead(2,2,i,j) = dhead(1,2,j,i) - dhead(1,1,i,j) = dhead(2,1,j,i) - dhead(1,2,i,j) = dhead(2,2,j,i) - dtail(1,i,j) = dtail(1,j,i) - dtail(2,i,j) = dtail(2,j,i) -c! DO k = 1, 2 -c! DO l = 1, 2 -c! write (*,*) "dhead(k,l,j,i) = ", dhead(k,l,j,i) -c! write (*,*) "dhead(k,l,i,j) = ", dhead(k,l,i,j) -c! dhead(l,k,i,j) = dhead(k,l,j,i) -c! END DO -c! END DO - - epshead(i,j) = epshead(j,i) - sig0head(i,j) = sig0head(j,i) - - DO k = 1, 2 - wqdip(k,i,j) = wqdip(k,j,i) - END DO - - wquad(i,j) = wquad(j,i) - epsintab(i,j) = epsintab(j,i) - - END DO - END DO - - if (.not.lprint) goto 70 - write (iout,'(a)') - & "Parameters of the new physics-based SC-SC interaction potential" - write (iout,'(/7a)') 'Residues',' epsGB',' rGB', - & ' chi1GB',' chi2GB',' chip1GB',' chip2GB' - do i=1,ntyp - do j=1,i - write (iout,'(2(a3,1x),1pe10.3,5(0pf10.3))') - & restyp(i),restyp(j),eps(i,j),sigma(i,j),chi(i,j),chi(j,i), - & chipp(i,j),chipp(j,i) - enddo - enddo - write (iout,'(/9a)') 'Residues',' alphasur1',' alphasur2', - & ' alphasur3',' alphasur4',' sigmap1',' sigmap2', - & ' chis1',' chis2' - do i=1,ntyp - do j=1,i - write (iout,'(2(a3,1x),8(0pf10.3))') - & restyp(i),restyp(j),(alphasur(k,i,j),k=1,4), - & sigmap1(i,j),sigmap2(j,i),chis(i,j),chis(j,i) - enddo - enddo - write (iout,'(/14a)') 'Residues',' nst ',' wst1', - & ' wst2',' wst3',' wst4',' dh11',' dh21', - & ' dh12',' dh22',' dt1',' dt2',' epsh1', - & ' sigh' - do i=1,ntyp - do j=1,i - write (iout,'(2(a3,1x),i3,4f8.3,6f7.2,f9.5,f7.2)') - & restyp(i),restyp(j),nstate(i,j),(wstate(k,i,j),k=1,4), - & ((dhead(l,k,i,j),l=1,2),k=1,2),dtail(1,i,j),dtail(2,i,j), - & epshead(i,j),sig0head(i,j) - enddo - enddo - write (iout,'(/12a)') 'Residues',' ch1',' ch2', - & ' rborn1',' rborn2',' wqdip1',' wqdip2', - & ' wquad' - do i=1,ntyp - do j=1,i - write (iout,'(2(a3,1x),2i4,5f10.3)') - & restyp(i),restyp(j),icharge(i),icharge(j), - & rborn(i,j),rborn(j,i),(wqdip(k,i,j),k=1,2),wquad(i,j) - enddo - enddo - write (iout,'(/12a)') 'Residues', - & ' alphpol1', - & ' alphpol2',' alphiso1',' alpiso2', - & ' alpiso3',' alpiso4',' sigiso1',' sigiso2', - & ' epsin' - do i=1,ntyp - do j=1,i - write (iout,'(2(a3,1x),11f10.3)') - & restyp(i),restyp(j),alphapol(i,j),alphapol(j,i), - & (alphiso(k,i,j),k=1,4),sigiso1(i,j),sigiso2(j,i), - & epsintab(i,j) - enddo - enddo - goto 70 - - 60 continue - close (isidep) -C----------------------------------------------------------------------- -C Calculate the "working" parameters of SC interactions. - - IF (ipot.LT.6) THEN - 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 - END IF - - 70 continue - write (iout,*) "IPOT=",ipot - if (lprint) write (iout,'(/a/10x,7a/72(1h-))') - & 'Working parameters of the SC interactions:', - & ' a ',' b ',' augm ',' sigma ',' r0 ', - & ' chi1 ',' chi2 ' - do i=1,ntyp - do j=i,ntyp - epsij=eps(i,j) - if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4 .or. ipot.eq.6 ) THEN - rrij=sigma(i,j) - else - rrij=rr0(i)+rr0(j) - endif - r0(i,j)=rrij - r0(j,i)=rrij - rrij=rrij**expon - epsij=eps(i,j) - sigeps=dsign(1.0D0,epsij) - epsij=dabs(epsij) - aa(i,j)=epsij*rrij*rrij - bb(i,j)=-sigeps*epsij*rrij - aa(j,i)=aa(i,j) - bb(j,i)=bb(i,j) - IF ((ipot.gt.2).AND.(ipot.LT.6)) 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 - if (ipot.lt.6) then - write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') - & restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j), - & sigma(i,j),r0(i,j),chi(i,j),chi(j,i) - else - write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3),2i3,10f8.4, - & i3,40f10.4)') - & restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j), - & sigma(i,j),r0(i,j),chi(i,j),chi(j,i), - & icharge(i),icharge(j),chipp(i,j),chipp(j,i), - & (alphasur(k,i,j),k=1,4),sigmap1(i,j),sigmap2(j,i), - & chis(i,j),chis(j,i), - & nstate(i,j),(wstate(k,i,j),k=1,4), - & ((dhead(l,k,i,j),l=1,2),k=1,2),dtail(1,i,j),dtail(2,i,j), - & epshead(i,j),sig0head(i,j), - & rborn(i,j),(wqdip(k,i,j),k=1,2),wquad(i,j), - & alphapol(i,j),alphapol(j,i), - & (alphiso(k,i,j),k=1,4),sigiso1(i,j),sigiso2(i,j) - - endif - 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,*) (eps_scp(i,j),rscp(i,j),j=1,2) - enddo - do i=1,ntyp - aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12 - aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12 - bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6 - bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6 - enddo - - if (lprint) then - write (iout,*) "Parameters of SC-p interactions:" - do i=1,20 - write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1), - & eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) - enddo - endif -#endif -C -C Define the constants of the disulfide bridge -C - ebr=-5.50D0 -c -c Old arbitrary potential - commented out. -c -c dbr= 4.20D0 -c fbr= 3.30D0 -c -c Constants of the disulfide-bond potential determined based on the RHF/6-31G** -c energy surface of diethyl disulfide. -c A. Liwo and U. Kozlowska, 11/24/03 -c - D0CM = 3.78d0 - AKCM = 15.1d0 - AKTH = 11.0d0 - AKCT = 12.0d0 - V1SS =-1.08d0 - V2SS = 7.61d0 - V3SS = 13.7d0 - - if (lprint) then - write (iout,'(/a)') "Disulfide bridge parameters:" - write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr - write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm - write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct - write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss, - & ' v3ss:',v3ss - endif - return - end diff --git a/source/wham/src-NEWSC/pinorm.f b/source/wham/src-NEWSC/pinorm.f deleted file mode 100755 index 91392bf..0000000 --- a/source/wham/src-NEWSC/pinorm.f +++ /dev/null @@ -1,17 +0,0 @@ - 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-NEWSC/printmat.f b/source/wham/src-NEWSC/printmat.f deleted file mode 100755 index be2b38f..0000000 --- a/source/wham/src-NEWSC/printmat.f +++ /dev/null @@ -1,16 +0,0 @@ - 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-NEWSC/proc_cont.f b/source/wham/src-NEWSC/proc_cont.f deleted file mode 100755 index 9269496..0000000 --- a/source/wham/src-NEWSC/proc_cont.f +++ /dev/null @@ -1,156 +0,0 @@ - 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-NEWSC/proc_proc.c b/source/wham/src-NEWSC/proc_proc.c deleted file mode 100755 index 01c6bba..0000000 --- a/source/wham/src-NEWSC/proc_proc.c +++ /dev/null @@ -1,124 +0,0 @@ -#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; - -sscanf(buf,"%d",&j); -*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-NEWSC/promienie.f b/source/wham/src-NEWSC/promienie.f deleted file mode 100755 index 12a2e80..0000000 --- a/source/wham/src-NEWSC/promienie.f +++ /dev/null @@ -1,46 +0,0 @@ - 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.21) then - dsc_inv(i)=0.0d0 - else - dsc_inv(i)=1.0d0/dsc(i) - endif - enddo - return - end diff --git a/source/wham/src-NEWSC/qwolynes.f b/source/wham/src-NEWSC/qwolynes.f deleted file mode 100755 index 97b5efb..0000000 --- a/source/wham/src-NEWSC/qwolynes.f +++ /dev/null @@ -1,186 +0,0 @@ - double precision function qwolynes(ilevel,jfrag) - implicit none - include 'DIMENSIONS' - include 'DIMENSIONS.ZSCOPT' - include 'DIMENSIONS.COMPAR' - include 'COMMON.IOUNITS' - include 'COMMON.COMPAR' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - integer ilevel,jfrag - integer i,j,jl,k,l,il,kl,nl,np,ip,kp - integer nsep /3/ - 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 - qq = 0.0d0 - if (ilevel.eq.0) then - if (lprn) write (iout,*) "Q computed for whole molecule" - nl=0 - do il=nnt+nsep,nct - do jl=nnt,il-nsep - dij=0.0d0 - dijCM=0.0d0 - d0ij=0.0d0 - d0ijCM=0.0d0 - qqij=0.0d0 - qqijCM=0.0d0 - nl=nl+1 - d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ - & (cref(2,jl)-cref(2,il))**2+ - & (cref(3,jl)-cref(3,il))**2) - dij=dist(il,jl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,jl+nres)-cref(1,il+nres))**2+ - & (cref(2,jl+nres)-cref(2,il+nres))**2+ - & (cref(3,jl+nres)-cref(3,il+nres))**2) - dijCM=dist(il+nres,jl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - 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 (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(il,jl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(jl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,jl+nres)-cref(1,il+nres))**2+ - & (cref(2,jl+nres)-cref(2,il+nres))**2+ - & (cref(3,jl+nres)-cref(3,il+nres))**2) - dijCM=dist(il+nres,jl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - if (lprn) then - write (iout,*) "i",i," j",j," il",il," jl",jl, - & " itype",itype(il),itype(jl) - write (iout,*)"d0ij",d0ij," dij",dij," d0ijCM",d0ijCM, - & " dijCM",dijCM," qqij",qqij," qqijCM",qqijCM - endif - endif - enddo - enddo - qq = qq/nl - if (lprn) write (iout,*) "nl",nl," qq",qq - else if (ilevel.eq.2) then - np=npiece(jfrag,ilevel) - nl=0 - do i=2,np - ip=ipiece(i,jfrag,ilevel) - do j=1,nlist_frag(ip) - il=list_frag(j,ip) - do k=1,i-1 - kp=ipiece(k,jfrag,ilevel) - do l=1,nlist_frag(kp) - kl=list_frag(l,kp) - if (iabs(kl-il).gt.nsep) then - nl=nl+1 - dij=0.0d0 - dijCM=0.0d0 - d0ij=0.0d0 - d0ijCM=0.0d0 - qqij=0.0d0 - qqijCM=0.0d0 - d0ij=dsqrt((cref(1,kl)-cref(1,il))**2+ - & (cref(2,kl)-cref(2,il))**2+ - & (cref(3,kl)-cref(3,il))**2) - dij=dist(il,kl) - qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) - if (itype(il).ne.10 .or. itype(kl).ne.10) then - nl=nl+1 - d0ijCM=dsqrt( - & (cref(1,kl+nres)-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(il+nres,kl+nres) - qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/ - & (sigm(d0ijCM)))**2) - endif - qq = qq+qqij+qqijCM - if (lprn) then - write (iout,*) "i",i," j",j," k",k," l",l," il",il, - & " kl",kl," itype",itype(il),itype(kl) - write (iout,*) " d0ij",d0ij," dij",dij," d0ijCM", - & d0ijCM," dijCM",dijCM," qqij",qqij," qqijCM",qqijCM - endif - endif - enddo ! l - enddo ! k - enddo ! j - enddo ! i - qq = qq/nl - if (lprn) write (iout,*) "nl",nl," qq",qq - else - write (iout,*)"Error: Q can be computed only for level 1 and 2." - endif - 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-NEWSC/read_ref_str.F b/source/wham/src-NEWSC/read_ref_str.F deleted file mode 100755 index 4b56181..0000000 --- a/source/wham/src-NEWSC/read_ref_str.F +++ /dev/null @@ -1,165 +0,0 @@ - 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 ilen - external ilen -C - nres0=nres - write (iout,*) "pdbref",pdbref - if (pdbref) then - read(inp,'(a)') pdbfile - write (iout,'(2a,1h.)') 'PDB data will be read from file ', - & pdbfile(:ilen(pdbfile)) - open(ipdbin,file=pdbfile,status='old',err=33) - goto 34 - 33 write (iout,'(a)') 'Error opening PDB file.' - 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_ref(j) - theta_ref(j+i)=theta_ref(j) - alph_ref(j+i)=alph_ref(j) - omeg_ref(j+i)=omeg_ref(j) - enddo -#ifdef DEBUG - do j=nnt,nct - write (iout,'(i5,3f10.5,5x,3f10.5)') - & j,(cref(k,j),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 - 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 print *,"Calling contact" - call contact(.true.,ncont_ref,icont_ref(1,1), - & nstart_sup,nend_sup) -c print *,"Calling elecont" - call elecont(.true.,ncont_pept_ref, - & icont_pept_ref(1,1), - & nstart_sup,nend_sup) - write (iout,'(a,i3,a,i3,a,i3,a)') - & 'Number of residues to be superposed:',nsup, - & ' (from residue',nstart_sup,' to residue', - & nend_sup,').' - return - end diff --git a/source/wham/src-NEWSC/readpdb.f b/source/wham/src-NEWSC/readpdb.f deleted file mode 100755 index 0b82476..0000000 --- a/source/wham/src-NEWSC/readpdb.f +++ /dev/null @@ -1,219 +0,0 @@ - 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' - character*3 seq,atom,res - character*80 card - double precision sccor(3,20) - integer i,j,iii,ibeg,ishift,ishift1,ity,ires,ires_old - double precision dcj - integer rescode - ibeg=1 - ishift1=0 - do i=1,10000 - read (ipdbin,'(a80)',end=10) card - if (card(:3).eq.'END' .or. card(:3).eq.'TER') goto 10 -C Fish out the ATOM cards. - if (index(card(1:4),'ATOM').gt.0) then - read (card(14:16),'(a3)') atom - if (atom.eq.'CA' .or. atom.eq.'CH3') then -C Calculate the CM of the preceding residue. - if (ibeg.eq.0) call sccenter(ires,iii,sccor) -C Start new residue. - ires_old=ires+ishift-ishift1 - read (card(23:26),*) ires -c print *,"ires_old",ires_old," ires",ires - if (card(27:27).eq."A" .or. card(27:27).eq."B") then -c ishift1=ishift1+1 - endif - read (card(18:20),'(a3)') res - if (ibeg.eq.1) then - ishift=ires-1 - if (res.ne.'GLY' .and. res.ne. 'ACE') then - ishift=ishift-1 - itype(1)=21 - endif - ibeg=0 - else - ishift=ishift+ires-ires_old-1 - endif - ires=ires-ishift+ishift1 - 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) - 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 -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 ') 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 the CM of the last side chain. - call sccenter(ires,iii,sccor) - nres=ires - nsup=nres - nstart_sup=1 - if (itype(nres).ne.10) then - nres=nres+1 - itype(nres)=21 - 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 - 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 - 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 -C Copy the coordinates to reference coordinates - do i=1,2*nres - do j=1,3 - cref(j,i)=c(j,i) - enddo - enddo -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,ires+nres),j=1,3) - enddo - call flush(iout) - call int_from_cart(.true.,.true.) - do i=1,nres - phi_ref(i)=phi(i) - theta_ref(i)=theta(i) - alph_ref(i)=alph(i) - omeg_ref(i)=omeg(i) - enddo - 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,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) - 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.21 .and. itype(i).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 - 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.21) then - do j=1,3 - c(j,1)=c(j,2)+(c(j,3)-c(j,4)) - enddo - endif - if (itype(nres).eq.21) 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/wham/src-NEWSC/readrtns.F b/source/wham/src-NEWSC/readrtns.F deleted file mode 100755 index 006c111..0000000 --- a/source/wham/src-NEWSC/readrtns.F +++ /dev/null @@ -1,779 +0,0 @@ - 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) - 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 - energy_dec=index(controlcard,"ENERGY_DEC").gt.0 - 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) - 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 readi(controlcard,"NGRIDT",NGridT,400) - call reada(controlcard,"STARTGRIDT",StartGridT,200.0d0) - call reada(controlcard,"DELTA_T",Delta_T,1.0d0) - call reada(controlcard,"DELTRGY",deltrgy,5.0d-2) - call readi(controlcard,"RESCALE",rescale_mode,1) - check_conf=index(controlcard,"NO_CHECK_CONF").eq.0 - 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 - call readi(controlcard,'CONSTR_DIST',constr_dist,0) - write (iout,*) "with_dihed_constr ",with_dihed_constr, - & " CONSTR_DIST",constr_dist - refstr = index(controlcard,'REFSTR').gt.0 - pdbref = index(controlcard,'PDBREF').gt.0 - call flush(iout) - 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) - 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 - 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-NEWSC/readrtns.F.org b/source/wham/src-NEWSC/readrtns.F.org deleted file mode 100755 index 1fa6e46..0000000 --- a/source/wham/src-NEWSC/readrtns.F.org +++ /dev/null @@ -1,691 +0,0 @@ - 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-NEWSC/readrtns_compar.F b/source/wham/src-NEWSC/readrtns_compar.F deleted file mode 100755 index 8e03f15..0000000 --- a/source/wham/src-NEWSC/readrtns_compar.F +++ /dev/null @@ -1,160 +0,0 @@ - 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) - 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-NEWSC/rescode.f b/source/wham/src-NEWSC/rescode.f deleted file mode 100755 index b516fed..0000000 --- a/source/wham/src-NEWSC/rescode.f +++ /dev/null @@ -1,32 +0,0 @@ - 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=1,ntyp1 - if (ucase(nam).eq.restyp(i)) then - rescode=i - return - endif - enddo - - else - - do i=1,ntyp1 - if (nam(1:1).eq.onelet(i)) then - rescode=i - return - endif - enddo - - endif - - write (iout,10) iseq,nam - stop - 10 format ('**** Error - residue',i4,' has an unresolved name ',a3) - end - diff --git a/source/wham/src-NEWSC/rmscalc.f b/source/wham/src-NEWSC/rmscalc.f deleted file mode 100755 index 70d9425..0000000 --- a/source/wham/src-NEWSC/rmscalc.f +++ /dev/null @@ -1,156 +0,0 @@ - double precision function rmscalc(ishif,i,j,jcon,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' - 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 - if (lprn) then - write (iout,*) "i",i," j",j," jcont",jcon," ishif",ishif - write (iout,*) "npiece",npiece(j,i) - endif - ii=0 - do l=1,nres - iadded(l)=.false. - enddo - do k=1,npiece(j,i) - if (i.eq.1) then - if (lprn) - & write (iout,*) "Level 1: j=",j,"k=",k," adding fragment", - & ifrag(1,k,j),ifrag(2,k,j) - call cprep(ifrag(1,k,j),ifrag(2,k,j),ishif,ii) -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) - & write (iout,*) "Level",i,": j=",j,"k=",k," kk=",kk, - & " l=",l," adding fragment", - & ifrag(1,l,kk),ifrag(2,l,kk) - call cprep(ifrag(1,l,kk),ifrag(2,l,kk),ishif,ii) - enddo - endif - enddo - if (lprn) then - do k=1,ii - 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 - endif - call fitsq(rms,cc(1,1),creff(1,1),ii,przes,obrot,non_conv) - if (non_conv) then - print *,'Error: FITSQ non-convergent, jcon',jcon - rmscalc=1.0d2 - else if (rms.lt.-1.0d-6) then - print *,'Error: rms^2 = ',rms,jcon - rmscalc = 1.0d2 - else if (rms.ge.1.0d-6 .and. rms.lt.0) then - rmscalc=0.0d0 - else - rmscalc = dsqrt(rms) - endif - return - end -c------------------------------------------------------------------------- - subroutine cprep(if1,if2,ishif,ii) - 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' - 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 -c write (iout,*) "Calling cprep" - do l=if1,if2 -c write (iout,*) "l",l," iadded",iadded(l) - if (l+ishif.gt.1 .and. l+ishif.le.nres .and. .not.iadded(l)) - & then - ii=ii+1 - iadded(l)=.true. - inumber(1,ii)=l - inumber(2,ii)=l+ishif - do m=1,3 - creff(m,ii)=cref(m,l) - cc(m,ii)=c(m,l+ishif) - enddo - endif - enddo - return - end -c------------------------------------------------------------------------- - double precision function rmsnat(jcon) - 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' - double precision przes(3),obrot(3,3) - logical non_conv - integer ishif,i,j - call fitsq(rms,c(1,nstart_sup),cref(1,nstart_sup),nsup, - & przes,obrot,non_conv) - if (non_conv) then - print *,'Error: FITSQ non-convergent, jcon',jcon - rmsnat=1.0d2 - else if (rms.lt.-1.0d-6) then - print *,'Error: rms^2 = ',rms,jcon - rmsnat = 1.0d2 - else if (rms.ge.1.0d-6 .and. rms.lt.0) then - rmsnat=0.0d0 - else - rmsnat = dsqrt(rms) - endif - return - end -c----------------------------------------------------------------------------- - double precision function gyrate(jcon) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.INTERACT' - include 'COMMON.CHAIN' - double precision cen(3),rg - - do j=1,3 - cen(j)=0.0d0 - enddo - - do i=nnt,nct - do j=1,3 - cen(j)=cen(j)+c(j,i) - enddo - enddo - do j=1,3 - cen(j)=cen(j)/dble(nct-nnt+1) - enddo - rg = 0.0d0 - do i = nnt, nct - do j=1,3 - rg = rg + (c(j,i)-cen(j))**2 - enddo - end do - gyrate = dsqrt(rg/dble(nct-nnt+1)) - return - end diff --git a/source/wham/src-NEWSC/secondary.f b/source/wham/src-NEWSC/secondary.f deleted file mode 100755 index 9c9bc7d..0000000 --- a/source/wham/src-NEWSC/secondary.f +++ /dev/null @@ -1,713 +0,0 @@ - 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:' - do j=1,nbfrag - write(iout,*) 'beta ',(bfrag(i,j),i=1,4) - enddo - - do j=1,nhfrag - write(iout,*) 'helix ',(hfrag(i,j),i=1,2) - enddo - - endif - - 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-NEWSC/setup_var.f b/source/wham/src-NEWSC/setup_var.f deleted file mode 100755 index f052400..0000000 --- a/source/wham/src-NEWSC/setup_var.f +++ /dev/null @@ -1,31 +0,0 @@ - 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-NEWSC/slices.F b/source/wham/src-NEWSC/slices.F deleted file mode 100755 index b22ea13..0000000 --- a/source/wham/src-NEWSC/slices.F +++ /dev/null @@ -1,80 +0,0 @@ - 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-NEWSC/store_parm.F b/source/wham/src-NEWSC/store_parm.F deleted file mode 100755 index 0ededff..0000000 --- a/source/wham/src-NEWSC/store_parm.F +++ /dev/null @@ -1,547 +0,0 @@ - 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,j,k,l,m,mm,iparm - -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 -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=1,ntyp - a0thet_all(i,iparm)=a0thet(i) - do j=1,2 - athet_all(j,i,iparm)=athet(j,i) - bthet_all(j,i,iparm)=bthet(j,i) - 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=1,ntyp1 - ithetyp_all(i,iparm)=ithetyp(i) - enddo - do i=1,maxthetyp1 - do j=1,maxthetyp1 - do k=1,maxthetyp1 - aa0thet_all(i,j,k,iparm)=aa0thet(i,j,k) - do l=1,ntheterm - aathet_all(l,i,j,k,iparm)=aathet(l,i,j,k) - enddo - do l=1,ntheterm2 - do m=1,nsingle - bbthet_all(m,l,i,j,k,iparm)=bbthet(m,l,i,j,k) - ccthet_all(m,l,i,j,k,iparm)=ccthet(m,l,i,j,k) - ddthet_all(m,l,i,j,k,iparm)=ddthet(m,l,i,j,k) - eethet_all(m,l,i,j,k,iparm)=eethet(m,l,i,j,k) - enddo - enddo - do l=1,ntheterm3 - do m=1,ndouble - do mm=1,ndouble - ffthet_all(mm,m,l,i,j,k,iparm)=ffthet(mm,m,l,i,j,k) - ggthet_all(mm,m,l,i,j,k,iparm)=ggthet(mm,m,l,i,j,k) - enddo - enddo - enddo - enddo - enddo - enddo -#endif -#ifdef CRYST_SC -c Store the sidechain rotamer parameters - do i=1,ntyp - nlob_all(i,iparm)=nlob(i) - do j=1,nlob(i) - bsc_all(j,i,iparm)=bsc(j,i) - 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 i=1,ntortyp - do j=1,ntortyp - v0_all(i,j,iparm)=v0(i,j) - nterm_all(i,j,iparm)=nterm(i,j) - nlor_all(i,j,iparm)=nlor(i,j) - do k=1,nterm(i,j) - v1_all(k,i,j,iparm)=v1(k,i,j) - v2_all(k,i,j,iparm)=v2(i,i,j) - enddo - do k=1,nlor(i,j) - 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 -c Store the double torsional parameters - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - ntermd1_all(i,j,k,iparm)=ntermd_1(i,j,k) - ntermd2_all(i,j,k,iparm)=ntermd_2(i,j,k) - do l=1,ntermd_1(i,j,k) - v1c_all(1,l,i,j,k,iparm)=v1c(1,l,i,j,k) - v1c_all(2,l,i,j,k,iparm)=v1c(2,l,i,j,k) - v2c_all(1,l,i,j,k,iparm)=v2c(1,l,i,j,k) - v2c_all(2,l,i,j,k,iparm)=v2c(2,l,i,j,k) - enddo - do l=1,ntermd_2(i,j,k) - do m=1,ntermd_2(i,j,k) - v2s_all(l,m,i,j,k,iparm)=v2s(l,m,i,j,k) - enddo - enddo - enddo - enddo - enddo -c Store parameters of the cumulants - do i=1,nloctyp - do j=1,2 - b1_all(j,i,iparm)=b1(j,i) - b1tilde_all(j,i,iparm)=b1tilde(j,i) - b2_all(j,i,iparm)=b2(j,i) - enddo - do j=1,2 - do k=1,2 - cc_all(k,j,i,iparm)=cc(k,j,i) - ctilde_all(k,j,i,iparm)=ctilde(k,j,i) - dd_all(k,j,i,iparm)=dd(k,j,i) - dtilde_all(k,j,i,iparm)=dtilde(k,j,i) - ee_all(k,j,i,iparm)=ee(k,j,i) - enddo - enddo - enddo -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_all(j,i,iparm)=aa(j,i) - bb_all(j,i,iparm)=bb(j,i) - r0_all(j,i,iparm)=r0(j,i) - sigma_all(j,i,iparm)=sigma(j,i) - chi_all(j,i,iparm)=chi(j,i) - chipp_all(j,i,iparm)=chipp(j,i) - augm_all(j,i,iparm)=augm(j,i) - eps_all(j,i,iparm)=eps(j,i) - sigmap1_all(j,i,iparm)=sigmap1(j,i) - sigmap2_all(j,i,iparm)=sigmap2(j,i) - chis_all(j,i,iparm)=chis(j,i) - do k=1,4 - alphasur_all(k,j,i,iparm)=alphasur(k,j,i) - wstate_all(k,j,i,iparm)=wstate(k,j,i) - enddo - nstate_all(j,i,iparm)=nstate(j,i) - do k=1,2 - do l=1,2 - dhead_all(l,k,j,i,iparm)=dhead(l,k,j,i) - enddo - enddo - do k=1,2 - dtail_all(k,j,i,iparm)=dtail(k,j,i) - enddo - epshead_all(j,i,iparm)=epshead(j,i) - rborn_all(j,i,iparm)=rborn(j,i) - do k=1,2 - wqdip_all(k,j,i,iparm)=wqdip(k,j,i) - enddo - wquad_all(j,i,iparm)=wquad(j,i) - alphapol_all(j,i,iparm)=alphapol(j,i) - do k=1,4 - alphiso_all(k,j,i,iparm)=alphiso(k,j,i) - enddo - sigiso1_all(j,i,iparm)=sigiso1(j,i) - sigiso2_all(j,i,iparm)=sigiso2(j,i) - epsintab_all(j,i,iparm)=epsintab(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=1,nsccortyp - do j=1,nsccortyp - - nterm_sccor_all(j,i,iparm)=nterm_sccor(j,i) - 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,j,k,l,m,mm,iparm - -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) -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=1,ntyp - a0thet(i)=a0thet_all(i,iparm) - do j=1,2 - athet(j,i)=athet_all(j,i,iparm) - bthet(j,i)=bthet_all(j,i,iparm) - 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=1,ntyp1 - ithetyp(i)=ithetyp_all(i,iparm) - enddo - do i=1,maxthetyp1 - do j=1,maxthetyp1 - do k=1,maxthetyp1 - aa0thet(i,j,k)=aa0thet_all(i,j,k,iparm) - do l=1,ntheterm - aathet(l,i,j,k)=aathet_all(l,i,j,k,iparm) - enddo - do l=1,ntheterm2 - do m=1,nsingle - bbthet(m,l,i,j,k)=bbthet_all(m,l,i,j,k,iparm) - ccthet(m,l,i,j,k)=ccthet_all(m,l,i,j,k,iparm) - ddthet(m,l,i,j,k)=ddthet_all(m,l,i,j,k,iparm) - eethet(m,l,i,j,k)=eethet_all(m,l,i,j,k,iparm) - enddo - enddo - do l=1,ntheterm3 - do m=1,ndouble - do mm=1,ndouble - ffthet(mm,m,l,i,j,k)=ffthet_all(mm,m,l,i,j,k,iparm) - ggthet(mm,m,l,i,j,k)=ggthet_all(mm,m,l,i,j,k,iparm) - enddo - enddo - enddo - enddo - enddo - enddo -#endif -c Restore the sidechain rotamer parameters -#ifdef CRYST_SC - do i=1,ntyp - nlob(i)=nlob_all(i,iparm) - do j=1,nlob(i) - bsc(j,i)=bsc_all(j,i,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 i=1,ntortyp - do j=1,ntortyp - v0(i,j)=v0_all(i,j,iparm) - nterm(i,j)=nterm_all(i,j,iparm) - nlor(i,j)=nlor_all(i,j,iparm) - do k=1,nterm(i,j) - v1(k,i,j)=v1_all(k,i,j,iparm) - v2(i,i,j)=v2_all(k,i,j,iparm) - enddo - do k=1,nlor(i,j) - 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 -c Restore the double torsional parameters - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - ntermd_1(i,j,k)=ntermd1_all(i,j,k,iparm) - ntermd_2(i,j,k)=ntermd2_all(i,j,k,iparm) - do l=1,ntermd_1(i,j,k) - v1c(1,l,i,j,k)=v1c_all(1,l,i,j,k,iparm) - v1c(2,l,i,j,k)=v1c_all(2,l,i,j,k,iparm) - v2c(1,l,i,j,k)=v2c_all(1,l,i,j,k,iparm) - v2c(2,l,i,j,k)=v2c_all(2,l,i,j,k,iparm) - enddo - do l=1,ntermd_2(i,j,k) - do m=1,ntermd_2(i,j,k) - v2s(l,m,i,j,k)=v2s_all(l,m,i,j,k,iparm) - enddo - enddo - enddo - enddo - enddo -c Restore parameters of the cumulants - do i=1,nloctyp - do j=1,2 - b1(j,i)=b1_all(j,i,iparm) - b1tilde(j,i)=b1tilde_all(j,i,iparm) - b2(j,i)=b2_all(j,i,iparm) - enddo - do j=1,2 - do k=1,2 - cc(k,j,i)=cc_all(k,j,i,iparm) - ctilde(k,j,i)=ctilde_all(k,j,i,iparm) - dd(k,j,i)=dd_all(k,j,i,iparm) - dtilde(k,j,i)=dtilde_all(k,j,i,iparm) - ee(k,j,i)=ee_all(k,j,i,iparm) - enddo - enddo - enddo -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(j,i)=aa_all(j,i,iparm) - bb(j,i)=bb_all(j,i,iparm) - r0(j,i)=r0_all(j,i,iparm) - sigma(j,i)=sigma_all(j,i,iparm) - chi(j,i)=chi_all(j,i,iparm) - chipp(j,i)=chipp_all(j,i,iparm) - augm(j,i)=augm_all(j,i,iparm) - eps(j,i)=eps_all(j,i,iparm) - sigmap1(j,i)=sigmap1_all(j,i,iparm) - sigmap2(j,i)=sigmap2_all(j,i,iparm) - chis(j,i)=chis_all(j,i,iparm) - do k=1,4 - alphasur(k,j,i)=alphasur_all(k,j,i,iparm) - wstate(k,j,i)=wstate_all(k,j,i,iparm) - enddo - nstate(j,i)=nstate_all(j,i,iparm) - do k=1,2 - do l=1,2 - dhead(l,k,j,i)=dhead_all(l,k,j,i,iparm) - enddo - enddo - do k=1,2 - dtail(k,j,i)=dtail_all(k,j,i,iparm) - enddo - epshead(j,i)=epshead_all(j,i,iparm) - rborn(j,i)=rborn_all(j,i,iparm) - do k=1,2 - wqdip(k,j,i)=wqdip_all(k,j,i,iparm) - enddo - wquad(j,i)=wquad_all(j,i,iparm) - alphapol(j,i)=alphapol_all(j,i,iparm) - do k=1,4 - alphiso(k,j,i)=alphiso_all(k,j,i,iparm) - enddo - sigiso1(j,i)=sigiso1_all(j,i,iparm) - sigiso2(j,i)=sigiso2_all(j,i,iparm) - epsintab(j,i)=epsintab_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=1,nsccortyp - do j=1,nsccortyp - - nterm_sccor(j,i)=nterm_sccor_all(j,i,iparm) -c do i=1,20 -c do j=1,20 - 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-NEWSC/timing.F b/source/wham/src-NEWSC/timing.F deleted file mode 100755 index 1012457..0000000 --- a/source/wham/src-NEWSC/timing.F +++ /dev/null @@ -1,163 +0,0 @@ -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-NEWSC/wham_calc1.F b/source/wham/src-NEWSC/wham_calc1.F deleted file mode 100755 index 57a41d3..0000000 --- a/source/wham/src-NEWSC/wham_calc1.F +++ /dev/null @@ -1,1454 +0,0 @@ - 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 MaxBinRms,MaxBinRgy - parameter (MaxBinRms=100,MaxBinRgy=100) - integer MaxHdim -c parameter (MaxHdim=200000) - parameter (MaxHdim=100) - integer maxinde - parameter (maxinde=100) -#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" - integer MaxPoint,MaxPointProc - parameter (MaxPoint=MaxStr, - & MaxPointProc=MaxStr_Proc) - double precision finorm_max,potfac,entmin,entmax,expfac,vf - double precision entfac_min,entfac_min_t - 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), - & fi_p_min(MaxR,MaxT_h,Max_Parm) - double precision sumW_p(0:Max_GridT,Max_Parm), - & sumE_p(0:Max_GridT,Max_Parm),sumEsq_p(0:Max_GridT,Max_Parm), - & sumQ_p(MaxQ1,0:Max_GridT,Max_Parm), - & sumQsq_p(MaxQ1,0:Max_GridT,Max_Parm), - & sumEQ_p(MaxQ1,0:Max_GridT,Max_Parm), - & sumEprim_p(MaxQ1,0:Max_GridT,Max_Parm), - & sumEbis_p(0:Max_GridT,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_all(maxT_h,Max_Parm),entmin_p,entmax_p - integer histent_p(0:2000) - logical lprint /.true./ -#endif - 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), - & fi_min(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_all(maxT_h,Max_Parm),potEmin,potEmin_min,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/, - & 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 - - 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 (iout,*) "Enter WHAM_calc" - call flush(iout) - 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 - do i=1,nParmset - do j=1,nT_h(i) - potEmin_all(j,i)=1.0d10 - enddo - enddo - rgymin=1.0d10 - rmsmin=1.0d10 - rgymax=0.0d0 - rmsmax=0.0d0 - do t=0,MaxN - htot(t)=0 - enddo -#ifdef MPI - do i=1,scount(me1) -#else - do i=1,ntot(islice) -#endif - 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 - if (ind_point(i).lt.0 .or. ind_point(i).gt.MaxHdim) then - write (iout,*) "Error - index exceeds range for point",i, - & " q=",q(j,i)," ind",ind_point(i) -#ifdef MPI - write (iout,*) "Processor",me1 - call flush(iout) - call MPI_Abort(MPI_COMM_WORLD, Ierror, Errcode ) -#endif - stop - endif - enddo ! j - if (ind_point(i).gt.tmax) tmax=ind_point(i) - htot(ind_point(i))=htot(ind_point(i))+1 -#ifdef DEBUG - write (iout,*) "i",i,"q",(q(j,i),j=1,nQ)," ind",ind_point(i), - & " htot",htot(ind_point(i)) - call flush(iout) -#endif - enddo ! i - call flush(iout) - - nbin=nbin1**nQ-1 - write (iout,'(a)') "Numbers of counts in Q bins" - do t=0,tmax - if (htot(t).gt.0) then - write (iout,'(i15,$)') t - 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(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) - rgymin=rgymin_t - rgymax=rgymax_t - rmsmin=rmsmin_t - rmsmax=rmsmax_t -#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,21) -#endif - call restore_parm(iparm) -#ifdef DEBUG - write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc, - & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc, - & wtor_d,wsccor,wbond -#endif - do ib=1,nT_h(iparm) - 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) -#ifdef DEBUG - write (iout,'(3i5,6f5.2,14f12.3)') i,ib,iparm,(ft(l),l=1,6), - & evdw+evdw_t,evdw2,ees,evdw1,ecorr,eel_loc,estr,ebe,escloc, - & etors,etors_d,eello_turn3,eello_turn4,esccor -#endif - -#ifdef SPLITELE - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees - & +wvdwpp*evdw1 - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc - & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#else - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 - & +ft(1)*welec*(ees+evdw1) - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr - & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#endif -#ifdef DEBUG - write (iout,*) i,iparm,1.0d0/(beta_h(ib,iparm)*1.987D-3), - & etot -#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 - v(i,kk,ib,iparm)= - & -beta_h(ib,iparm)*(etot+Econstr) -#ifdef DEBUG - write (iout,'(4i5,4e15.5)') i,kk,ib,iparm, - & etot,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" - entfac_min=1.0d10 -#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 - if (entfac(t).lt.entfac_min) entfac_min=entfac(t) -#ifdef DEBUG - write (iout,*) t,"vmax",vmax," denom",denom,"entfac",entfac(t) -#endif - enddo -c#ifdef MPI -c write (iout,*) "entfac_min before AllReduce",entfac_min -c call MPI_AllReduce(entfac_min,entfac_min_t,1, -c & MPI_DOUBLE_PRECISION,MPI_MAX,WHAM_COMM,IERROR) -c entfac_min=entfac_min_t -c write (iout,*) "entfac_min after AllReduce",entfac_min -c#endif -c#ifdef MPI -c do t=1,scount(me) -c entfac(t)=entfac(t)-entfac_min -c enddo -c#else -c do t=1,ntot(islice) -c entfac(t)=entfac(t)-entfac_min -c enddo -c#endif - do iparm=1,nParmSet - do iib=1,nT_h(iparm) - do ii=1,nR(iib,iparm) -#ifdef MPI - fi_p_min(ii,iib,iparm)=-1.0d10 - do t=1,scount(me) - aux=v(t,ii,iib,iparm)+entfac(t) - if (aux.gt.fi_p_min(ii,iib,iparm)) - & fi_p_min(ii,iib,iparm)=aux - enddo -#else - do t=1,ntot(islice) - aux=v(t,ii,iib,iparm)+entfac(t) - if (aux.gt.fi_min(ii,iib,iparm)) - & fi_min(ii,iib,iparm)=aux - enddo -#endif - enddo ! ii - enddo ! iib - enddo ! iparm -#ifdef MPI -#ifdef DEBUG - write (iout,*) "fi_min before AllReduce" - do i=1,nParmSet - do j=1,nT_h(i) - write (iout,*) (i,j,k,fi_p_min(k,j,i),k=1,nR(j,i)) - enddo - enddo -#endif - call MPI_AllReduce(fi_p_min,fi_min,MaxR*MaxT_h*nParmSet, - & MPI_DOUBLE_PRECISION,MPI_MAX,WHAM_COMM,IERROR) -#ifdef DEBUG - write (iout,*) "fi_min after AllReduce" - do i=1,nParmSet - do j=1,nT_h(i) - write (iout,*) (i,j,k,fi_min(k,j,i),k=1,nR(j,i)) - enddo - enddo -#endif -#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)-fi_min(ii,iib,iparm)) -#ifdef DEBUG - write (iout,'(4i5,4e15.5)') t,ii,iib,iparm, - & v(t,ii,iib,iparm),entfac(t),fi_min(ii,iib,iparm), - & 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)-fi_min(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(iparm) - 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 -#ifdef DEBUG - write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet, - & maxR*MaxT_h*nParmSet - write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD, - & " WHAM_COMM",WHAM_COMM -#endif - 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))-fi_min(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. - -C Determine the minimum free energies -#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,21) -#endif - call restore_parm(iparm) -#ifdef DEBUG - write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc, - & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc, - & wtor_d,wsccor,wbond -#endif - do ib=1,nT_h(iparm) - 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) -#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,edihcnstr -#endif - -#ifdef SPLITELE - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees - & +wvdwpp*evdw1 - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc - & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#else - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 - & +ft(1)*welec*(ees+evdw1) - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr - & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#endif -c write (iout,*) "i",i," ib",ib, -c & " temp",1.0d0/(1.987d-3*beta_h(ib,iparm))," etot",etot, -c & " entfac",entfac(i) - etot=etot-entfac(i)/beta_h(ib,iparm) - if(etot.lt.potEmin_all(ib,iparm)) potEmin_all(ib,iparm)=etot -c write (iout,*) "efree",etot," potEmin",potEmin_all(ib,iparm) - enddo ! ib - enddo ! iparm - enddo ! i -#ifdef DEBUG - write (iout,*) "The potEmin array before reduction" - do i=1,nParmSet - write (iout,*) "Parameter set",i - do j=1,nT_h(i) - write (iout,*) j,PotEmin_all(j,i) - enddo - enddo - write (iout,*) "potEmin_min",potEmin_min -#endif -#ifdef MPI -C Determine the minimum energes for all parameter sets and temperatures - call MPI_AllReduce(potEmin_all(1,1),potEmin_t_all(1,1), - & maxT_h*nParmSet,MPI_DOUBLE_PRECISION,MPI_MIN,WHAM_COMM,IERROR) - do i=1,nParmSet - do j=1,nT_h(i) - potEmin_all(j,i)=potEmin_t_all(j,i) - enddo - enddo -#endif - potEmin_min=potEmin_all(1,1) - do i=1,nParmSet - do j=1,nT_h(i) - if (potEmin_all(j,i).lt.potEmin_min) - & potEmin_min=potEmin_all(j,i) - enddo - enddo -#ifdef DEBUG - write (iout,*) "The potEmin array" - do i=1,nParmSet - write (iout,*) "Parameter set",i - do j=1,nT_h(i) - write (iout,*) j,PotEmin_all(j,i) - enddo - enddo - write (iout,*) "potEmin_min",potEmin_min -#endif - -#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 - 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) - 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) - if (betaT.ge.beta_h(1,iparm)) then - potEmin=potEmin_all(1,iparm) -c write(iout,*) "first",temper,potEmin - else if (betaT.lt.beta_h(nT_h(iparm),iparm)) then - potEmin=potEmin_all(nT_h(iparm),iparm) -c write (iout,*) "last",temper,potEmin - else - do l=1,nT_h(iparm)-1 - if (betaT.le.beta_h(l,iparm) .and. - & betaT.gt.beta_h(l+1,iparm)) then - potEmin=potEmin_all(l,iparm) -c write (iout,*) "l",l, -c & betaT,1.0d0/(1.987D-3*beta_h(l,iparm)), -c & 1.0d0/(1.987D-3*beta_h(l+1,iparm)),temper,potEmin - exit - endif - enddo - endif -c write (iout,*) ib," PotEmin",potEmin -#ifdef SPLITELE - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees - & +wvdwpp*evdw1 - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc - & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr - 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 -#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 - 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 - weight=dexp(-betaT*(etot-potEmin)+entfac(t)) -#ifdef DEBUG - write (iout,*) "iparm",iparm," t",t," temper",temper, - & " etot",etot," entfac",entfac(t), - & " efree",etot-entfac(t)/betaT," potEmin",potEmin, - & " boltz",-betaT*(etot-potEmin)+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) - potEmin=potEmin_all(ib,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) - potEmin=potEmin_all(ib,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 - betaT=1.0d0/(1.987D-3*(startGridT+i*delta_T)) - if (betaT.ge.beta_h(1,iparm)) then - potEmin=potEmin_all(1,iparm) - else if (betaT.lt.beta_h(nT_h(iparm),iparm)) then - potEmin=potEmin_all(nT_h(iparm),iparm) - else - do l=1,nT_h(iparm)-1 - if (betaT.le.beta_h(l,iparm) .and. - & betaT.gt.beta_h(l+1,iparm)) then - potEmin=potEmin_all(l,iparm) - exit - endif - enddo - endif - 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,*) - 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 - end diff --git a/source/wham/src-NEWSC/wham_calc1.F.safe b/source/wham/src-NEWSC/wham_calc1.F.safe deleted file mode 100755 index f51dcc4..0000000 --- a/source/wham/src-NEWSC/wham_calc1.F.safe +++ /dev/null @@ -1,1195 +0,0 @@ - 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) - integer MaxHdim -c parameter (MaxHdim=200000) - 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" - 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 - 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 - - 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 -#ifdef MPI - do i=1,scount(me1) -#else - do i=1,ntot(islice) -#endif - do j=1,nParmSet - if (potE(i,j).le.potEmin) potEmin=potE(i,j) - enddo - if (q(nQ+1,i).lt.rmsmin) rmsmin=q(nQ+1,i) - if (q(nQ+1,i).gt.rmsmax) rmsmax=q(nQ+1,i) - if (q(nQ+2,i).lt.rgymin) rgymin=q(nQ+2,i) - if (q(nQ+2,i).gt.rgymax) rgymax=q(nQ+2,i) - ind_point(i)=0 - do j=nQ,1,-1 - ind=(q(j,i)-dmin+1.0d-8)/delta - if (j.eq.1) then - ind_point(i)=ind_point(i)+ind - else - ind_point(i)=ind_point(i)+nbin1**(j-1)*ind - endif -c write (iout,*) "i",i," j",j," q",q(j,i)," ind_point", -c & ind_point(i) - call flush(iout) - if (ind_point(i).lt.0 .or. ind_point(i).gt.MaxHdim) then - write (iout,*) "Error - index exceeds range for point",i, - & " q=",q(j,i)," ind",ind_point(i) -#ifdef MPI - write (iout,*) "Processor",me1 - call flush(iout) - call MPI_Abort(MPI_COMM_WORLD, Ierror, Errcode ) -#endif - stop - endif - enddo ! j - if (ind_point(i).gt.tmax) tmax=ind_point(i) - htot(ind_point(i))=htot(ind_point(i))+1 -#ifdef DEBUG - write (iout,*) "i",i,"q",(q(j,i),j=1,nQ)," ind",ind_point(i), - & " htot",htot(ind_point(i)) - call flush(iout) -#endif - enddo ! i - call flush(iout) - - nbin=nbin1**nQ-1 - write (iout,'(a)') "Numbers of counts in Q bins" - do t=0,tmax - if (htot(t).gt.0) then - write (iout,'(i15,$)') t - 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) - potEmin=potEmin_t/2 - rgymin=rgymin_t - rgymax=rgymax_t - rmsmin=rmsmin_t - rmsmax=rmsmax_t - write (iout,*) "potEmin",potEmin -#endif - rmsmin=deltrms*dint(rmsmin/deltrms) - rmsmax=deltrms*dint(rmsmax/deltrms) - rgymin=deltrms*dint(rgymin/deltrgy) - rgymax=deltrms*dint(rgymax/deltrgy) - nbin_rms=(rmsmax-rmsmin)/deltrms - nbin_rgy=(rgymax-rgymin)/deltrgy - write (iout,*) "rmsmin",rmsmin," rmsmax",rmsmax," rgymin",rgymin, - & " rgymax",rgymax," nbin_rms",nbin_rms," nbin_rgy",nbin_rgy - nFi=0 - do i=1,nParmSet - do j=1,nT_h(i) - nFi=nFi+nR(j,i) - enddo - enddo - write (iout,*) "nFi",nFi -! Compute the Boltzmann factor corresponing to restrain potentials in different -! simulations. -#ifdef MPI - do i=1,scount(me1) -#else - do i=1,ntot(islice) -#endif -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,21) -#endif - call restore_parm(iparm) -#ifdef DEBUG - write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc, - & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc, - & wtor_d,wsccor,wbond -#endif - do ib=1,nT_h(iparm) - 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) -#ifdef DEBUG - write (iout,'(3i5,6f5.2,14f12.3)') i,ib,iparm,(ft(l),l=1,6), - & evdw+evdw_t,evdw2,ees,evdw1,ecorr,eel_loc,estr,ebe,escloc, - & etors,etors_d,eello_turn3,eello_turn4,esccor -#endif - -#ifdef SPLITELE - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees - & +wvdwpp*evdw1 - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc - & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#else - etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 - & +ft(1)*welec*(ees+evdw1) - & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 - & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 - & +ft(2)*wturn3*eello_turn3 - & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr - & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr -#endif -#ifdef 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 - v(i,kk,ib,iparm)= - & -beta_h(ib,iparm)*(etot-potEmin+Econstr) -#ifdef DEBUG - write (iout,'(4i5,4e15.5)') i,kk,ib,iparm, - & etot,potEmin,etot-potEmin,v(i,kk,ib,iparm) -#endif - enddo ! kk - enddo ! ib - enddo ! iparm - enddo ! i -! Simple iteration to calculate free energies corresponding to all simulation -! runs. - do iter=1,maxit - -! Compute new free-energy values corresponding to the righ-hand side of the -! equation and their derivatives. - write (iout,*) "------------------------fi" -#ifdef MPI - do t=1,scount(me1) -#else - do t=1,ntot(islice) -#endif - vmax=-1.0d+20 - do i=1,nParmSet - do k=1,nT_h(i) - do l=1,nR(k,i) - vf=v(t,l,k,i)+f(l,k,i) - if (vf.gt.vmax) vmax=vf - enddo - enddo - enddo - denom=0.0d0 - do i=1,nParmSet - do k=1,nT_h(i) - do l=1,nR(k,i) - aux=f(l,k,i)+v(t,l,k,i)-vmax - if (aux.gt.-200.0d0) - & denom=denom+snk(l,k,i,islice)*dexp(aux) - enddo - enddo - enddo - entfac(t)=-dlog(denom)-vmax -#ifdef DEBUG - write (iout,*) t,"vmax",vmax," denom",denom,"entfac",entfac(t) -#endif - enddo - do iparm=1,nParmSet - do iib=1,nT_h(iparm) - do ii=1,nR(iib,iparm) -#ifdef MPI - fi_p(ii,iib,iparm)=0.0d0 - do t=1,scount(me) - fi_p(ii,iib,iparm)=fi_p(ii,iib,iparm) - & +dexp(v(t,ii,iib,iparm)+entfac(t)) -#ifdef DEBUG - write (iout,'(4i5,3e15.5)') t,ii,iib,iparm, - & v(t,ii,iib,iparm),entfac(t),fi_p(ii,iib,iparm) -#endif - enddo -#else - fi(ii,iib,iparm)=0.0d0 - do t=1,ntot(islice) - fi(ii,iib,iparm)=fi(ii,iib,iparm) - & +dexp(v(t,ii,iib,iparm)+entfac(t)) - enddo -#endif - enddo ! ii - enddo ! iib - enddo ! iparm - -#ifdef MPI -#ifdef DEBUG - write (iout,*) "fi before MPI_Reduce me",me,' master',master - do iparm=1,nParmSet - do ib=1,nT_h(nparmset) - write (iout,*) "iparm",iparm," ib",ib - write (iout,*) "beta=",beta_h(ib,iparm) - write (iout,'(8e15.5)') (fi_p(i,ib,iparm),i=1,nR(ib,iparm)) - enddo - enddo -#endif - write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet, - & maxR*MaxT_h*nParmSet - write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD, - & " WHAM_COMM",WHAM_COMM - call MPI_Reduce(fi_p(1,1,1),fi(1,1,1),maxR*MaxT_h*nParmSet, - & MPI_DOUBLE_PRECISION, - & MPI_SUM,Master,WHAM_COMM,IERROR) -#ifdef DEBUG - write (iout,*) "fi after MPI_Reduce nparmset",nparmset - do iparm=1,nParmSet - write (iout,*) "iparm",iparm - do ib=1,nT_h(iparm) - write (iout,*) "beta=",beta_h(ib,iparm) - write (iout,'(8e15.5)') (fi(i,ib,iparm),i=1,nR(ib,iparm)) - enddo - enddo -#endif - if (me1.eq.Master) then -#endif - avefi=0.0d0 - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - fi(i,ib,iparm)=-dlog(fi(i,ib,iparm)) - avefi=avefi+fi(i,ib,iparm) - enddo - enddo - enddo - avefi=avefi/nFi - do iparm=1,nParmSet - write (iout,*) "Parameter set",iparm - do ib =1,nT_h(iparm) - write (iout,*) "beta=",beta_h(ib,iparm) - do i=1,nR(ib,iparm) - fi(i,ib,iparm)=fi(i,ib,iparm)-avefi - enddo - write (iout,'(8f10.5)') (fi(i,ib,iparm),i=1,nR(ib,iparm)) - write (iout,'(8f10.5)') (f(i,ib,iparm),i=1,nR(ib,iparm)) - enddo - enddo - -! Compute the norm of free-energy increments. - finorm=0.0d0 - do iparm=1,nParmSet - do ib=1,nT_h(iparm) - do i=1,nR(ib,iparm) - finorm=finorm+dabs(fi(i,ib,iparm)-f(i,ib,iparm)) - f(i,ib,iparm)=fi(i,ib,iparm) - enddo - enddo - enddo - - write (iout,*) 'Iteration',iter,' finorm',finorm - -#ifdef MPI - endif - call MPI_Bcast(f(1,1,1),MaxR*MaxT_h*nParmSet, - & MPI_DOUBLE_PRECISION,Master, - & WHAM_COMM,IERROR) - call MPI_Bcast(finorm,1,MPI_DOUBLE_PRECISION,Master, - & WHAM_COMM,IERROR) -#endif -! Exit, if the increment norm is smaller than pre-assigned tolerance. - if (finorm.lt.fimin) then - write (iout,*) 'Iteration converged' - goto 20 - endif - - enddo ! iter - - 20 continue -! Now, put together the histograms from all simulations, in order to get the -! unbiased total histogram. -#ifdef MPI - do t=0,tmax - hfin_ent_p(t)=0.0d0 - enddo -#else - do t=0,tmax - hfin_ent(t)=0.0d0 - enddo -#endif - write (iout,*) "--------------hist" -#ifdef MPI - do iparm=1,nParmSet - do i=0,nGridT - sumW_p(i,iparm)=0.0d0 - sumE_p(i,iparm)=0.0d0 - sumEbis_p(i,iparm)=0.0d0 - sumEsq_p(i,iparm)=0.0d0 - do j=1,nQ+2 - sumQ_p(j,i,iparm)=0.0d0 - sumQsq_p(j,i,iparm)=0.0d0 - sumEQ_p(j,i,iparm)=0.0d0 - enddo - enddo - enddo - upindE_p=0 -#else - do iparm=1,nParmSet - do i=0,nGridT - sumW(i,iparm)=0.0d0 - sumE(i,iparm)=0.0d0 - sumEbis(i,iparm)=0.0d0 - sumEsq(i,iparm)=0.0d0 - do j=1,nQ+2 - sumQ(j,i,iparm)=0.0d0 - sumQsq(j,i,iparm)=0.0d0 - sumEQ(j,i,iparm)=0.0d0 - enddo - enddo - enddo - upindE=0 -#endif -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) - edihcnstr=0.0d0 - 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 - 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 - 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 -#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 - 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 - weight=dexp(-betaT*(etot-potEmin)+entfac(t)) -#define DEBUG -#ifdef DEBUG - write (iout,*) "iparm",iparm," t",t," betaT",betaT, - & " etot",etot," entfac",entfac(t), - & " weight",weight," ebis",ebis -#endif -#undef DEBUG - 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,*) - 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 - - end diff --git a/source/wham/src-NEWSC/wham_multparm.F b/source/wham/src-NEWSC/wham_multparm.F deleted file mode 100755 index 003b6b4..0000000 --- a/source/wham/src-NEWSC/wham_multparm.F +++ /dev/null @@ -1,277 +0,0 @@ - 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 - call read_general_data(*10) - call flush(iout) - call molread(*10) - call flush(iout) -#ifdef MPI - write (iout,*) "Calling proc_groups" - call proc_groups - write (iout,*) "proc_groups exited" - call flush(iout) -#endif -#ifdef SCALREP - write (iout,*) "1,4 SCSC repulsive interactions sacled down by 10" -#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) - write (iout,*) "Finished READ_EFREE" - call flush(iout) - call read_protein_data(*10) - write (iout,*) "Finished READ_PROTEIN_DATA" - call flush(iout) - if (indpdb.gt.0) then - call promienie - call read_compar - call read_ref_structure(*10) - call proc_cont - call fragment_list - endif - write (iout,*) "Begin read_database" - call flush(iout) - call read_database(*10) - write (iout,*) "Finished read_database" - call flush(iout) - if (separate_parset) nparmset=1 - do islice=1,nslice - if (ntot(islice).gt.0) then -#ifdef MPI - call work_partition(islice,.true.) - write (iout,*) "work_partition OK" - call flush(iout) -#endif - call enecalc(islice,*10) - write (iout,*) "enecalc OK" - call flush(iout) - write (iout,*) "Calling WHAM_calc" - 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-NEWSC/xdrf/Makefile b/source/wham/src-NEWSC/xdrf/Makefile deleted file mode 100644 index f03276e..0000000 --- a/source/wham/src-NEWSC/xdrf/Makefile +++ /dev/null @@ -1,27 +0,0 @@ -# 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-NEWSC/xdrf/ftocstr.c b/source/wham/src-NEWSC/xdrf/ftocstr.c deleted file mode 100644 index ed2113f..0000000 --- a/source/wham/src-NEWSC/xdrf/ftocstr.c +++ /dev/null @@ -1,35 +0,0 @@ - - -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-NEWSC/xdrf/libxdrf.m4 b/source/wham/src-NEWSC/xdrf/libxdrf.m4 deleted file mode 100644 index aecb5b5..0000000 --- a/source/wham/src-NEWSC/xdrf/libxdrf.m4 +++ /dev/null @@ -1,1233 +0,0 @@ -/*____________________________________________________________________________ - | - | 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 = "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-NEWSC/xdrf/libxdrf.m4.org b/source/wham/src-NEWSC/xdrf/libxdrf.m4.org deleted file mode 100644 index b14b374..0000000 --- a/source/wham/src-NEWSC/xdrf/libxdrf.m4.org +++ /dev/null @@ -1,1230 +0,0 @@ -/*____________________________________________________________________________ - | - | 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; - 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+"; - lmode = XDR_ENCODE; - } else { - type = "r"; - lmode = XDR_DECODE; - } - xdrfiles[xdrid] = fopen(filename, type); - 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-NEWSC/xdrf/underscore.m4 b/source/wham/src-NEWSC/xdrf/underscore.m4 deleted file mode 100644 index 4d620a0..0000000 --- a/source/wham/src-NEWSC/xdrf/underscore.m4 +++ /dev/null @@ -1,19 +0,0 @@ -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-NEWSC/xdrf/xdrf.h b/source/wham/src-NEWSC/xdrf/xdrf.h deleted file mode 100644 index dedf5a2..0000000 --- a/source/wham/src-NEWSC/xdrf/xdrf.h +++ /dev/null @@ -1,10 +0,0 @@ -/*_________________________________________________________________ - | - | 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-NEWSC/xread.F b/source/wham/src-NEWSC/xread.F deleted file mode 100755 index ac35de1..0000000 --- a/source/wham/src-NEWSC/xread.F +++ /dev/null @@ -1,187 +0,0 @@ - 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