diff --git a/lib/README b/lib/README index 12c27b2a39..d89490e202 100644 --- a/lib/README +++ b/lib/README @@ -33,8 +33,6 @@ kokkos Kokkos package for GPU and many-core acceleration from Kokkos development team (Sandia) linalg set of BLAS and LAPACK routines needed by USER-ATC package from Axel Kohlmeyer (Temple U) -meam modified embedded atom method (MEAM) potential, MEAM package - from Greg Wagner (Sandia) message client/server communication library via MPI, sockets, files from Steve Plimpton (Sandia) molfile hooks to VMD molfile plugins, used by the USER-MOLFILE package @@ -51,8 +49,6 @@ qmmm quantum mechanics/molecular mechanics coupling interface from Axel Kohlmeyer (Temple U) quip interface to QUIP/libAtoms framework, USER-QUIP package from Albert Bartok-Partay and Gabor Csanyi (U Cambridge) -reax ReaxFF potential, REAX package - from Adri van Duin (Penn State) and Aidan Thompson (Sandia) smd hooks to Eigen library, used by USER-SMD package from Georg Ganzenmueller (Ernst Mach Institute, Germany) voronoi hooks to the Voro++ library, used by compute voronoi/atom command diff --git a/lib/meam/.depend b/lib/meam/.depend deleted file mode 100644 index 0945fba47a..0000000000 --- a/lib/meam/.depend +++ /dev/null @@ -1,9 +0,0 @@ -# dependencies. needed for parallel make -$(DIR)meam_data.o: meam_data.F -$(DIR)meam_cleanup.o: meam_cleanup.F $(DIR)meam_data.o -$(DIR)meam_dens_final.o: meam_dens_final.F $(DIR)meam_data.o -$(DIR)meam_dens_init.o: meam_dens_init.F $(DIR)meam_data.o -$(DIR)meam_force.o: meam_force.F $(DIR)meam_data.o -$(DIR)meam_setup_done.o: meam_setup_done.F $(DIR)meam_data.o -$(DIR)meam_setup_global.o: meam_setup_global.F $(DIR)meam_data.o -$(DIR)meam_setup_param.o: meam_setup_param.F $(DIR)meam_data.o diff --git a/lib/meam/.gitignore b/lib/meam/.gitignore deleted file mode 100644 index 63a7748cf4..0000000000 --- a/lib/meam/.gitignore +++ /dev/null @@ -1 +0,0 @@ -*.mod diff --git a/lib/meam/Install.py b/lib/meam/Install.py deleted file mode 120000 index ffe709d44c..0000000000 --- a/lib/meam/Install.py +++ /dev/null @@ -1 +0,0 @@ -../Install.py \ No newline at end of file diff --git a/lib/meam/Makefile.g95 b/lib/meam/Makefile.g95 deleted file mode 100644 index 91371441bd..0000000000 --- a/lib/meam/Makefile.g95 +++ /dev/null @@ -1,57 +0,0 @@ -# * -# *_________________________________________________________________________* -# * MEAM: MODEFIED EMBEDDED ATOM METHOD * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * AUTHORS: Greg Wagner, Sandia National Laboratories * -# * CONTACT: gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.gfortran - -# ------ FILES ------ - -SRC = meam_data.F meam_setup_done.F meam_setup_global.F meam_setup_param.F meam_dens_init.F meam_dens_final.F meam_force.F meam_cleanup.F - -FILES = $(SRC) Makefile - -# ------ DEFINITIONS ------ - -LIB = libmeam.a -OBJ = $(SRC:.F=.o) fm_exp.o - -# ------ SETTINGS ------ - -F90 = g95 -F90FLAGS = -O -fPIC -ARCHIVE = ar -ARCHFLAG = -rc -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F - $(F90) $(F90FLAGS) -c $< - -%.o:%.c - $(CC) $(F90FLAGS) -c $< - -include .depend -# ------ CLEAN ------ - -clean: - -rm *.o *.mod *~ $(LIB) - -tar: - -tar -cvf ../MEAM.tar $(FILES) diff --git a/lib/meam/Makefile.gfortran b/lib/meam/Makefile.gfortran deleted file mode 100644 index 509e4cebc3..0000000000 --- a/lib/meam/Makefile.gfortran +++ /dev/null @@ -1,61 +0,0 @@ -# * -# *_________________________________________________________________________* -# * MEAM: MODEFIED EMBEDDED ATOM METHOD * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * AUTHORS: Greg Wagner, Sandia National Laboratories * -# * CONTACT: gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.gfortran - -# ------ FILES ------ - -SRC = meam_data.F meam_setup_done.F meam_setup_global.F meam_setup_param.F meam_dens_init.F meam_dens_final.F meam_force.F meam_cleanup.F - -FILES = $(SRC) Makefile - -# ------ DEFINITIONS ------ - -LIB = libmeam.a -OBJ = $(SRC:.F=.o) fm_exp.o - -# ------ SETTINGS ------ - -F90 = gfortran -CC = gcc -F90FLAGS = -O3 -fPIC -ffast-math -ftree-vectorize -fexpensive-optimizations -fno-second-underscore -g -#F90FLAGS = -O -ARCHIVE = ar -ARCHFLAG = -rc -LINK = g++ -LINKFLAGS = -O -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F - $(F90) $(F90FLAGS) -c $< - -%.o:%.c - $(CC) $(F90FLAGS) -c $< - -include .depend -# ------ CLEAN ------ - -clean: - -rm *.o *.mod *~ $(LIB) - -tar: - -tar -cvf ../MEAM.tar $(FILES) diff --git a/lib/meam/Makefile.ifort b/lib/meam/Makefile.ifort deleted file mode 100644 index cd3bca9882..0000000000 --- a/lib/meam/Makefile.ifort +++ /dev/null @@ -1,57 +0,0 @@ -# * -# *_________________________________________________________________________* -# * MEAM: MODEFIED EMBEDDED ATOM METHOD * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * AUTHORS: Greg Wagner, Sandia National Laboratories * -# * CONTACT: gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.ifort - -# ------ FILES ------ - -SRC = meam_data.F meam_setup_done.F meam_setup_global.F meam_setup_param.F meam_dens_init.F meam_dens_final.F meam_force.F meam_cleanup.F - -FILES = $(SRC) Makefile - -# ------ DEFINITIONS ------ - -LIB = libmeam.a -OBJ = $(SRC:.F=.o) fm_exp.o - -# ------ SETTINGS ------ - -F90 = ifort -F90FLAGS = -O -fPIC -ARCHIVE = ar -ARCHFLAG = -rc -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F - $(F90) $(F90FLAGS) -c $< - -%.o:%.c - $(CC) $(F90FLAGS) -c $< - -include .depend -# ------ CLEAN ------ - -clean: - -rm *.o *.mod *~ $(LIB) - -tar: - -tar -cvf ../MEAM.tar $(FILES) diff --git a/lib/meam/Makefile.lammps.empty b/lib/meam/Makefile.lammps.empty deleted file mode 100644 index 10394b68ad..0000000000 --- a/lib/meam/Makefile.lammps.empty +++ /dev/null @@ -1,5 +0,0 @@ -# Settings that the LAMMPS build will import when this package library is used - -meam_SYSINC = -meam_SYSLIB = -meam_SYSPATH = diff --git a/lib/meam/Makefile.lammps.gfortran b/lib/meam/Makefile.lammps.gfortran deleted file mode 100644 index fa62c997dc..0000000000 --- a/lib/meam/Makefile.lammps.gfortran +++ /dev/null @@ -1,5 +0,0 @@ -# Settings that the LAMMPS build will import when this package library is used - -meam_SYSINC = -meam_SYSLIB = -lgfortran -meam_SYSPATH = diff --git a/lib/meam/Makefile.lammps.glory b/lib/meam/Makefile.lammps.glory deleted file mode 100644 index 153e699b72..0000000000 --- a/lib/meam/Makefile.lammps.glory +++ /dev/null @@ -1,5 +0,0 @@ -# Settings that the LAMMPS build will import when this package library is used - -meam_SYSINC = -meam_SYSLIB = -lifcore -lsvml -lompstub -limf -meam_SYSPATH = -L/opt/intel-11.1.046/lib/intel64 diff --git a/lib/meam/Makefile.lammps.ifort b/lib/meam/Makefile.lammps.ifort deleted file mode 100644 index bd4d98f929..0000000000 --- a/lib/meam/Makefile.lammps.ifort +++ /dev/null @@ -1,5 +0,0 @@ -# Settings that the LAMMPS build will import when this package library is used - -meam_SYSINC = -meam_SYSLIB = -lifcore -lsvml -lompstub -limf -meam_SYSPATH = -L/opt/intel/fce/10.0.023/lib diff --git a/lib/meam/Makefile.mpi b/lib/meam/Makefile.mpi deleted file mode 100644 index fd3dbde555..0000000000 --- a/lib/meam/Makefile.mpi +++ /dev/null @@ -1,61 +0,0 @@ -# * -# *_________________________________________________________________________* -# * MEAM: MODEFIED EMBEDDED ATOM METHOD * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * AUTHORS: Greg Wagner, Sandia National Laboratories * -# * CONTACT: gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.empty - -# ------ FILES ------ - -SRC = meam_data.F meam_setup_done.F meam_setup_global.F meam_setup_param.F meam_dens_init.F meam_dens_final.F meam_force.F meam_cleanup.F - -FILES = $(SRC) Makefile - -# ------ DEFINITIONS ------ - -LIB = libmeam.a -OBJ = $(SRC:.F=.o) fm_exp.o - -# ------ SETTINGS ------ - -F90 = mpifort -CC = mpicc -F90FLAGS = -O3 -fPIC -#F90FLAGS = -O -ARCHIVE = ar -ARCHFLAG = -rc -LINK = mpicxx -LINKFLAGS = -O -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F - $(F90) $(F90FLAGS) -c $< - -%.o:%.c - $(CC) $(F90FLAGS) -c $< - -include .depend -# ------ CLEAN ------ - -clean: - -rm *.o *.mod *~ $(LIB) - -tar: - -tar -cvf ../MEAM.tar $(FILES) diff --git a/lib/meam/Makefile.pgf90 b/lib/meam/Makefile.pgf90 deleted file mode 100644 index 32ce909f48..0000000000 --- a/lib/meam/Makefile.pgf90 +++ /dev/null @@ -1,57 +0,0 @@ -# * -# *_________________________________________________________________________* -# * MEAM: MODEFIED EMBEDDED ATOM METHOD * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * AUTHORS: Greg Wagner, Sandia National Laboratories * -# * CONTACT: gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.pgf90 - -# ------ FILES ------ - -SRC = meam_data.F meam_setup_done.F meam_setup_global.F meam_setup_param.F meam_dens_init.F meam_dens_final.F meam_force.F meam_cleanup.F - -FILES = $(SRC) Makefile - -# ------ DEFINITIONS ------ - -LIB = libmeam.a -OBJ = $(SRC:.F=.o) fm_exp.o - -# ------ SETTINGS ------ - -F90 = pgf90 -F90FLAGS = -O -fPIC -ARCHIVE = ar -ARCHFLAG = -rc -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F - $(F90) $(F90FLAGS) -c $< - -%.o:%.c - $(CC) $(F90FLAGS) -c $< - -include .depend -# ------ CLEAN ------ - -clean: - -rm *.o *.mod *~ $(LIB) - -tar: - -tar -cvf ../MEAM.tar $(FILES) diff --git a/lib/meam/Makefile.serial b/lib/meam/Makefile.serial deleted file mode 120000 index c52fbcb986..0000000000 --- a/lib/meam/Makefile.serial +++ /dev/null @@ -1 +0,0 @@ -Makefile.gfortran \ No newline at end of file diff --git a/lib/meam/Makefile.tbird b/lib/meam/Makefile.tbird deleted file mode 100644 index 7253d8305b..0000000000 --- a/lib/meam/Makefile.tbird +++ /dev/null @@ -1,59 +0,0 @@ -# * -# *_________________________________________________________________________* -# * MEAM: MODEFIED EMBEDDED ATOM METHOD * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * AUTHORS: Greg Wagner, Sandia National Laboratories * -# * CONTACT: gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.glory - -# ------ FILES ------ - -SRC = meam_data.F meam_setup_done.F meam_setup_global.F meam_setup_param.F meam_dens_init.F meam_dens_final.F meam_force.F meam_cleanup.F - -FILES = $(SRC) Makefile - -# ------ DEFINITIONS ------ - -LIB = libmeam.a -OBJ = $(SRC:.F=.o) fm_exp.o - -# ------ SETTINGS ------ - -F90 = mpif90 -F90FLAGS = -O -fPIC -ARCHIVE = ar -ARCHFLAG = -rc -LINK = g++ -LINKFLAGS = -O -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F - $(F90) $(F90FLAGS) -c $< - -%.o:%.c - $(CC) $(F90FLAGS) -c $< - -include .depend -# ------ CLEAN ------ - -clean: - -rm *.o *.mod *~ $(LIB) - -tar: - -tar -cvf ../MEAM.tar $(FILES) diff --git a/lib/meam/README b/lib/meam/README deleted file mode 100644 index b3111c1317..0000000000 --- a/lib/meam/README +++ /dev/null @@ -1,51 +0,0 @@ -MEAM (modified embedded atom method) library - -Greg Wagner, Sandia National Labs -gjwagne at sandia.gov -Jan 2007 - -This library is in implementation of the MEAM potential, specifically -designed to work with LAMMPS. - -------------------------------------------------- - -This directory has source files to build a library that LAMMPS -links against when using the MEAM package. - -This library must be built with a F90 compiler, before LAMMPS is -built, so LAMMPS can link against it. - -You can type "make lib-meam" from the src directory to see help on how -to build this library via make commands, or you can do the same thing -by typing "python Install.py" from within this directory, or you can -do it manually by following the instructions below. - -Build the library using one of the provided Makefile.* files or create -your own, specific to your compiler and system. For example: - -make -f Makefile.gfortran - -When you are done building this library, two files should -exist in this directory: - -libmeam.a the library LAMMPS will link against -Makefile.lammps settings the LAMMPS Makefile will import - -Makefile.lammps is created by the make command, by copying one of the -Makefile.lammps.* files. See the EXTRAMAKE setting at the top of the -Makefile.* files. - -IMPORTANT: You must examine the final Makefile.lammps to insure it is -correct for your system, else the LAMMPS build will likely fail. - -Makefile.lammps has settings for 3 variables: - -user-meam_SYSINC = leave blank for this package -user-meam_SYSLIB = auxiliary F90 libs needed to link a F90 lib with - a C++ program (LAMMPS) via a C++ compiler -user-meam_SYSPATH = path(s) to where those libraries are - -Because you have a F90 compiler on your system, you should have these -libraries. But you will have to figure out which ones are needed and -where they are. Examples of common configurations are in the -Makefile.lammps.* files. diff --git a/lib/meam/fm_exp.c b/lib/meam/fm_exp.c deleted file mode 100644 index 26d23b2e24..0000000000 --- a/lib/meam/fm_exp.c +++ /dev/null @@ -1,133 +0,0 @@ -/* - Copyright (c) 2012,2013 Axel Kohlmeyer - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - * Neither the name of the nor the - names of its contributors may be used to endorse or promote products - derived from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY -DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND -ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF -THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*/ - -/* faster versions of 2**x, e**x, and 10**x in single and double precision. - * - * Based on the Cephes math library 2.8 - */ - -#include -#include - -/* internal definitions for the fastermath library */ - -/* IEEE 754 double precision floating point data manipulation */ -typedef union -{ - double f; - uint64_t u; - struct {int32_t i0,i1;}; -} udi_t; -#define FM_DOUBLE_BIAS 1023 -#define FM_DOUBLE_EMASK 2146435072 -#define FM_DOUBLE_MBITS 20 -#define FM_DOUBLE_MMASK 1048575 -#define FM_DOUBLE_EZERO 1072693248 - -/* generate 2**num in floating point by bitshifting */ -#define FM_DOUBLE_INIT_EXP(var,num) \ - var.i0 = 0; \ - var.i1 = (((int) num) + FM_DOUBLE_BIAS) << 20 - -/* double precision constants */ -#define FM_DOUBLE_LOG2OFE 1.4426950408889634074 -#define FM_DOUBLE_LOGEOF2 6.9314718055994530942e-1 -#define FM_DOUBLE_LOG2OF10 3.32192809488736234789 -#define FM_DOUBLE_LOG10OF2 3.0102999566398119521e-1 -#define FM_DOUBLE_LOG10OFE 4.3429448190325182765e-1 -#define FM_DOUBLE_SQRT2 1.41421356237309504880 -#define FM_DOUBLE_SQRTH 0.70710678118654752440 - -/* optimizer friendly implementation of exp2(x). - * - * strategy: - * - * split argument into an integer part and a fraction: - * ipart = floor(x+0.5); - * fpart = x - ipart; - * - * compute exp2(ipart) from setting the ieee754 exponent - * compute exp2(fpart) using a pade' approximation for x in [-0.5;0.5[ - * - * the result becomes: exp2(x) = exp2(ipart) * exp2(fpart) - */ - -static const double fm_exp2_q[] = { -/* 1.00000000000000000000e0, */ - 2.33184211722314911771e2, - 4.36821166879210612817e3 -}; -static const double fm_exp2_p[] = { - 2.30933477057345225087e-2, - 2.02020656693165307700e1, - 1.51390680115615096133e3 -}; - -static double fm_exp2(double x) -{ - double ipart, fpart, px, qx; - udi_t epart; - - ipart = floor(x+0.5); - fpart = x - ipart; - FM_DOUBLE_INIT_EXP(epart,ipart); - - x = fpart*fpart; - - px = fm_exp2_p[0]; - px = px*x + fm_exp2_p[1]; - qx = x + fm_exp2_q[0]; - px = px*x + fm_exp2_p[2]; - qx = qx*x + fm_exp2_q[1]; - - px = px * fpart; - - x = 1.0 + 2.0*(px/(qx-px)); - return epart.f*x; -} - -double fm_exp_(double *x) -{ -#if defined(__BYTE_ORDER__) -#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ - return fm_exp2(FM_DOUBLE_LOG2OFE * (*x)); -#endif -#endif - return exp(*x); -} - -/* - * Local Variables: - * mode: c - * compile-command: "make -C .." - * c-basic-offset: 4 - * fill-column: 76 - * indent-tabs-mode: nil - * End: - */ diff --git a/lib/meam/meam_cleanup.F b/lib/meam/meam_cleanup.F deleted file mode 100644 index dce0c6469e..0000000000 --- a/lib/meam/meam_cleanup.F +++ /dev/null @@ -1,26 +0,0 @@ -c Declaration in pair_meam.h: -c -c void meam_cleanup() -c -c Call from PairMEAM destructor -c -c meam_cleanup() -c - - subroutine meam_cleanup - use meam_data - implicit none - - integer dealloc_error - - deallocate(phir,STAT=dealloc_error) - deallocate(phirar,STAT=dealloc_error) - deallocate(phirar1,STAT=dealloc_error) - deallocate(phirar2,STAT=dealloc_error) - deallocate(phirar3,STAT=dealloc_error) - deallocate(phirar4,STAT=dealloc_error) - deallocate(phirar5,STAT=dealloc_error) - deallocate(phirar6,STAT=dealloc_error) - - return - end diff --git a/lib/meam/meam_data.F b/lib/meam/meam_data.F deleted file mode 100644 index 719963bd59..0000000000 --- a/lib/meam/meam_data.F +++ /dev/null @@ -1,87 +0,0 @@ - - module meam_data - - integer, parameter :: maxelt = 5 - real*8 , external :: fm_exp - -c cutforce = force cutoff -c cutforcesq = force cutoff squared - - real*8 cutforce,cutforcesq - -c Ec_meam = cohesive energy -c re_meam = nearest-neighbor distance -c Omega_meam = atomic volume -c B_meam = bulk modulus -c Z_meam = number of first neighbors for reference structure -c ielt_meam = atomic number of element -c A_meam = adjustable parameter -c alpha_meam = sqrt(9*Omega*B/Ec) -c rho0_meam = density scaling parameter -c delta_meam = heat of formation for alloys -c beta[0-3]_meam = electron density constants -c t[0-3]_meam = coefficients on densities in Gamma computation -c rho_ref_meam = background density for reference structure -c ibar_meam(i) = selection parameter for Gamma function for elt i, -c lattce_meam(i,j) = lattce configuration for elt i or alloy (i,j) -c neltypes = maximum number of element type defined -c eltind = index number of pair (similar to Voigt notation; ij = ji) -c phir = pair potential function array -c phirar[1-6] = spline coeffs -c attrac_meam = attraction parameter in Rose energy -c repuls_meam = repulsion parameter in Rose energy -c nn2_meam = 1 if second nearest neighbors are to be computed, else 0 -c zbl_meam = 1 if zbl potential for small r to be use, else 0 -c emb_lin_neg = 1 if linear embedding function for rhob to be used, else 0 -c bkgd_dyn = 1 if reference densities follows Dynamo, else 0 -c Cmin_meam, Cmax_meam = min and max values in screening cutoff -c rc_meam = cutoff distance for meam -c delr_meam = cutoff region for meam -c ebound_meam = factor giving maximum boundary of sceen fcn ellipse -c augt1 = flag for whether t1 coefficient should be augmented -c ialloy = flag for newer alloy formulation (as in dynamo code) -c mix_ref_t = flag to recover "old" way of computing t in reference config -c erose_form = selection parameter for form of E_rose function -c gsmooth_factor = factor determining length of G smoothing region -c vind[23]D = Voight notation index maps for 2 and 3D -c v2D,v3D = array of factors to apply for Voight notation - -c nr,dr = pair function discretization parameters -c nrar,rdrar = spline coeff array parameters - - real*8 Ec_meam(maxelt,maxelt),re_meam(maxelt,maxelt) - real*8 Omega_meam(maxelt),Z_meam(maxelt) - real*8 A_meam(maxelt),alpha_meam(maxelt,maxelt),rho0_meam(maxelt) - real*8 delta_meam(maxelt,maxelt) - real*8 beta0_meam(maxelt),beta1_meam(maxelt) - real*8 beta2_meam(maxelt),beta3_meam(maxelt) - real*8 t0_meam(maxelt),t1_meam(maxelt) - real*8 t2_meam(maxelt),t3_meam(maxelt) - real*8 rho_ref_meam(maxelt) - integer ibar_meam(maxelt),ielt_meam(maxelt) - character*3 lattce_meam(maxelt,maxelt) - integer nn2_meam(maxelt,maxelt) - integer zbl_meam(maxelt,maxelt) - integer eltind(maxelt,maxelt) - integer neltypes - - real*8, allocatable :: phir(:,:) - - real*8, allocatable :: phirar(:,:),phirar1(:,:),phirar2(:,:), - $ phirar3(:,:),phirar4(:,:),phirar5(:,:),phirar6(:,:) - - real*8 attrac_meam(maxelt,maxelt),repuls_meam(maxelt,maxelt) - - real*8 Cmin_meam(maxelt,maxelt,maxelt) - real*8 Cmax_meam(maxelt,maxelt,maxelt) - real*8 rc_meam,delr_meam,ebound_meam(maxelt,maxelt) - integer augt1, ialloy, mix_ref_t, erose_form - integer emb_lin_neg, bkgd_dyn - real*8 gsmooth_factor - integer vind2D(3,3),vind3D(3,3,3) - integer v2D(6),v3D(10) - - integer nr,nrar - real*8 dr,rdrar - - end module diff --git a/lib/meam/meam_dens_final.F b/lib/meam/meam_dens_final.F deleted file mode 100644 index 098b00f296..0000000000 --- a/lib/meam/meam_dens_final.F +++ /dev/null @@ -1,296 +0,0 @@ -c Extern "C" declaration has the form: -c -c void meam_dens_final_(int *, int *, int *, int *, int *, double *, double *, -c int *, int *, int *, -c double *, double *, double *, double *, double *, double *, -c double *, double *, double *, double *, double *, double *, -c double *, double *, double *, double *, double *, int *); -c -c Call from pair_meam.cpp has the form: -c -c meam_dens_final_(&nlocal,&nmax,&eflag_either,&eflag_global,&eflag_atom, -c &eng_vdwl,eatom,ntype,type,fmap, -c &arho1[0][0],&arho2[0][0],arho2b,&arho3[0][0], -c &arho3b[0][0],&t_ave[0][0],&tsq_ave[0][0],gamma,dgamma1, -c dgamma2,dgamma3,rho,rho0,rho1,rho2,rho3,frhop,&errorflag); -c - - subroutine meam_dens_final(nlocal, nmax, - $ eflag_either, eflag_global, eflag_atom, eng_vdwl, eatom, - $ ntype, type, fmap, - $ Arho1, Arho2, Arho2b, Arho3, Arho3b, t_ave, tsq_ave, - $ Gamma, dGamma1, dGamma2, dGamma3, - $ rho, rho0, rho1, rho2, rho3, fp, errorflag) - - use meam_data - implicit none - - integer nlocal, nmax, eflag_either, eflag_global, eflag_atom - integer ntype, type, fmap - real*8 eng_vdwl, eatom, Arho1, Arho2 - real*8 Arho2b, Arho3, Arho3b - real*8 t_ave, tsq_ave - real*8 Gamma, dGamma1, dGamma2, dGamma3 - real*8 rho, rho0, rho1, rho2, rho3 - real*8 fp - integer errorflag - - dimension eatom(nmax) - dimension type(nmax), fmap(ntype) - dimension Arho1(3,nmax), Arho2(6,nmax), Arho2b(nmax) - dimension Arho3(10,nmax), Arho3b(3,nmax), t_ave(3,nmax) - dimension tsq_ave(3,nmax) - dimension Gamma(nmax), dGamma1(nmax), dGamma2(nmax) - dimension dGamma3(nmax), rho(nmax), rho0(nmax) - dimension rho1(nmax), rho2(nmax), rho3(nmax) - dimension fp(nmax) - - integer i, elti - integer m - real*8 rhob, G, dG, Gbar, dGbar, gam, shp(3), shpi(3), Z - real*8 B, denom, rho_bkgd - -c Complete the calculation of density - - do i = 1,nlocal - - elti = fmap(type(i)) - if (elti.gt.0) then - rho1(i) = 0.d0 - rho2(i) = -1.d0/3.d0*Arho2b(i)*Arho2b(i) - rho3(i) = 0.d0 - do m = 1,3 - rho1(i) = rho1(i) + Arho1(m,i)*Arho1(m,i) - rho3(i) = rho3(i) - 3.d0/5.d0*Arho3b(m,i)*Arho3b(m,i) - enddo - do m = 1,6 - rho2(i) = rho2(i) + v2D(m)*Arho2(m,i)*Arho2(m,i) - enddo - do m = 1,10 - rho3(i) = rho3(i) + v3D(m)*Arho3(m,i)*Arho3(m,i) - enddo - - if( rho0(i) .gt. 0.0 ) then - if (ialloy.eq.1) then - if (tsq_ave(1,i) .ne. 0.0d0) then - t_ave(1,i) = t_ave(1,i)/tsq_ave(1,i) - else - t_ave(1,i) = 0.0d0 - endif - if (tsq_ave(2,i) .ne. 0.0d0) then - t_ave(2,i) = t_ave(2,i)/tsq_ave(2,i) - else - t_ave(2,i) = 0.0d0 - endif - if (tsq_ave(3,i) .ne. 0.0d0) then - t_ave(3,i) = t_ave(3,i)/tsq_ave(3,i) - else - t_ave(3,i) = 0.0d0 - endif - else if (ialloy.eq.2) then - t_ave(1,i) = t1_meam(elti) - t_ave(2,i) = t2_meam(elti) - t_ave(3,i) = t3_meam(elti) - else - t_ave(1,i) = t_ave(1,i)/rho0(i) - t_ave(2,i) = t_ave(2,i)/rho0(i) - t_ave(3,i) = t_ave(3,i)/rho0(i) - endif - endif - - Gamma(i) = t_ave(1,i)*rho1(i) - $ + t_ave(2,i)*rho2(i) + t_ave(3,i)*rho3(i) - - if( rho0(i) .gt. 0.0 ) then - Gamma(i) = Gamma(i)/(rho0(i)*rho0(i)) - end if - - Z = Z_meam(elti) - - call G_gam(Gamma(i),ibar_meam(elti), - $ gsmooth_factor,G,errorflag) - if (errorflag.ne.0) return - call get_shpfcn(shp,lattce_meam(elti,elti)) - if (ibar_meam(elti).le.0) then - Gbar = 1.d0 - dGbar = 0.d0 - else - if (mix_ref_t.eq.1) then - gam = (t_ave(1,i)*shp(1)+t_ave(2,i)*shp(2) - $ +t_ave(3,i)*shp(3))/(Z*Z) - else - gam = (t1_meam(elti)*shp(1)+t2_meam(elti)*shp(2) - $ +t3_meam(elti)*shp(3))/(Z*Z) - endif - call G_gam(gam,ibar_meam(elti),gsmooth_factor, - $ Gbar,errorflag) - endif - rho(i) = rho0(i) * G - - if (mix_ref_t.eq.1) then - if (ibar_meam(elti).le.0) then - Gbar = 1.d0 - dGbar = 0.d0 - else - gam = (t_ave(1,i)*shp(1)+t_ave(2,i)*shp(2) - $ +t_ave(3,i)*shp(3))/(Z*Z) - call dG_gam(gam,ibar_meam(elti),gsmooth_factor, - $ Gbar,dGbar) - endif - rho_bkgd = rho0_meam(elti)*Z*Gbar - else - if (bkgd_dyn.eq.1) then - rho_bkgd = rho0_meam(elti)*Z - else - rho_bkgd = rho_ref_meam(elti) - endif - endif - rhob = rho(i)/rho_bkgd - denom = 1.d0/rho_bkgd - - call dG_gam(Gamma(i),ibar_meam(elti),gsmooth_factor,G,dG) - - dGamma1(i) = (G - 2*dG*Gamma(i))*denom - - if( rho0(i) .ne. 0.d0 ) then - dGamma2(i) = (dG/rho0(i))*denom - else - dGamma2(i) = 0.d0 - end if - -c dGamma3 is nonzero only if we are using the "mixed" rule for -c computing t in the reference system (which is not correct, but -c included for backward compatibility - if (mix_ref_t.eq.1) then - dGamma3(i) = rho0(i)*G*dGbar/(Gbar*Z*Z)*denom - else - dGamma3(i) = 0.0 - endif - - B = A_meam(elti)*Ec_meam(elti,elti) - - if( rhob .ne. 0.d0 ) then - if (emb_lin_neg.eq.1 .and. rhob.le.0) then - fp(i) = -B - else - fp(i) = B*(log(rhob)+1.d0) - endif - if (eflag_either.ne.0) then - if (eflag_global.ne.0) then - if (emb_lin_neg.eq.1 .and. rhob.le.0) then - eng_vdwl = eng_vdwl - B*rhob - else - eng_vdwl = eng_vdwl + B*rhob*log(rhob) - endif - endif - if (eflag_atom.ne.0) then - if (emb_lin_neg.eq.1 .and. rhob.le.0) then - eatom(i) = eatom(i) - B*rhob - else - eatom(i) = eatom(i) + B*rhob*log(rhob) - endif - endif - endif - else - if (emb_lin_neg.eq.1) then - fp(i) = -B - else - fp(i) = B - endif - endif - endif - enddo - - return - end - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - subroutine G_gam(Gamma,ibar,gsmooth_factor,G,errorflag) -c Compute G(Gamma) based on selection flag ibar: -c 0 => G = sqrt(1+Gamma) -c 1 => G = exp(Gamma/2) -c 2 => not implemented -c 3 => G = 2/(1+exp(-Gamma)) -c 4 => G = sqrt(1+Gamma) -c -5 => G = +-sqrt(abs(1+Gamma)) - use meam_data , only: fm_exp - implicit none - real*8 Gamma,G - real*8 gsmooth_factor, gsmooth_switchpoint - integer ibar, errorflag - if (ibar.eq.0.or.ibar.eq.4) then - gsmooth_switchpoint = -gsmooth_factor / (gsmooth_factor+1) - if (Gamma.lt.gsmooth_switchpoint) then -c e.g. gsmooth_factor is 99, then: -c gsmooth_switchpoint = -0.99 -c G = 0.01*(-0.99/Gamma)**99 - G = 1/(gsmooth_factor+1) - $ *(gsmooth_switchpoint/Gamma)**gsmooth_factor - G = sqrt(G) - else - G = sqrt(1.d0+Gamma) - endif - else if (ibar.eq.1) then - G = fm_exp(Gamma/2.d0) - else if (ibar.eq.3) then - G = 2.d0/(1.d0+exp(-Gamma)) - else if (ibar.eq.-5) then - if ((1.d0+Gamma).ge.0) then - G = sqrt(1.d0+Gamma) - else - G = -sqrt(-1.d0-Gamma) - endif - else - errorflag = 1 - endif - return - end - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - subroutine dG_gam(Gamma,ibar,gsmooth_factor,G,dG) -c Compute G(Gamma) and dG(gamma) based on selection flag ibar: -c 0 => G = sqrt(1+Gamma) -c 1 => G = fm_exp(Gamma/2) -c 2 => not implemented -c 3 => G = 2/(1+fm_exp(-Gamma)) -c 4 => G = sqrt(1+Gamma) -c -5 => G = +-sqrt(abs(1+Gamma)) - use meam_data , only: fm_exp - real*8 Gamma,G,dG - real*8 gsmooth_factor, gsmooth_switchpoint - integer ibar - if (ibar.eq.0.or.ibar.eq.4) then - gsmooth_switchpoint = -gsmooth_factor / (gsmooth_factor+1) - if (Gamma.lt.gsmooth_switchpoint) then -c e.g. gsmooth_factor is 99, then: -c gsmooth_switchpoint = -0.99 -c G = 0.01*(-0.99/Gamma)**99 - G = 1/(gsmooth_factor+1) - $ *(gsmooth_switchpoint/Gamma)**gsmooth_factor - G = sqrt(G) - dG = -gsmooth_factor*G/(2.0*Gamma) - else - G = sqrt(1.d0+Gamma) - dG = 1.d0/(2.d0*G) - endif - else if (ibar.eq.1) then - G = fm_exp(Gamma/2.d0) - dG = G/2.d0 - else if (ibar.eq.3) then - G = 2.d0/(1.d0+fm_exp(-Gamma)) - dG = G*(2.d0-G)/2 - else if (ibar.eq.-5) then - if ((1.d0+Gamma).ge.0) then - G = sqrt(1.d0+Gamma) - dG = 1.d0/(2.d0*G) - else - G = -sqrt(-1.d0-Gamma) - dG = -1.d0/(2.d0*G) - endif - endif - return - end - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc diff --git a/lib/meam/meam_dens_init.F b/lib/meam/meam_dens_init.F deleted file mode 100644 index 2ca2558135..0000000000 --- a/lib/meam/meam_dens_init.F +++ /dev/null @@ -1,564 +0,0 @@ -c Extern "C" declaration has the form: -c -c void meam_dens_init_(int *, int *, int *, double *, int *, int *, int *, double *, -c int *, int *, int *, int *, -c double *, double *, double *, double *, double *, double *, -c double *, double *, double *, double *, double *, int *); -c -c -c Call from pair_meam.cpp has the form: -c -c meam_dens_init_(&i,&nmax,ntype,type,fmap,&x[0][0], -c &numneigh[i],firstneigh[i],&numneigh_full[i],firstneigh_full[i], -c &scrfcn[offset],&dscrfcn[offset],&fcpair[offset], -c rho0,&arho1[0][0],&arho2[0][0],arho2b, -c &arho3[0][0],&arho3b[0][0],&t_ave[0][0],&tsq_ave[0][0],&errorflag); -c - - subroutine meam_dens_init(i, nmax, - $ ntype, type, fmap, x, - $ numneigh, firstneigh, - $ numneigh_full, firstneigh_full, - $ scrfcn, dscrfcn, fcpair, rho0, arho1, arho2, arho2b, - $ arho3, arho3b, t_ave, tsq_ave, errorflag) - - use meam_data - implicit none - - integer i, nmax, ntype, type, fmap - real*8 x - integer numneigh, firstneigh, numneigh_full, firstneigh_full - real*8 scrfcn, dscrfcn, fcpair - real*8 rho0, arho1, arho2 - real*8 arho2b, arho3, arho3b, t_ave, tsq_ave - integer errorflag - integer j,jn - - dimension x(3,nmax) - dimension type(nmax), fmap(ntype) - dimension firstneigh(numneigh), firstneigh_full(numneigh_full) - dimension scrfcn(numneigh), dscrfcn(numneigh), fcpair(numneigh) - dimension rho0(nmax), arho1(3,nmax), arho2(6,nmax) - dimension arho2b(nmax), arho3(10,nmax), arho3b(3,nmax) - dimension t_ave(3,nmax), tsq_ave(3,nmax) - - errorflag = 0 - -c Compute screening function and derivatives - call getscreen(i, nmax, scrfcn, dscrfcn, fcpair, x, - $ numneigh, firstneigh, - $ numneigh_full, firstneigh_full, - $ ntype, type, fmap) - -c Calculate intermediate density terms to be communicated - call calc_rho1(i, nmax, ntype, type, fmap, x, - $ numneigh, firstneigh, - $ scrfcn, fcpair, rho0, arho1, arho2, arho2b, - $ arho3, arho3b, t_ave, tsq_ave) - - return - end - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - subroutine getscreen(i, nmax, scrfcn, dscrfcn, fcpair, x, - $ numneigh, firstneigh, - $ numneigh_full, firstneigh_full, - $ ntype, type, fmap) - - use meam_data - implicit none - - integer i, nmax - real*8 scrfcn, dscrfcn, fcpair, x - integer numneigh, firstneigh, numneigh_full, firstneigh_full - integer ntype, type, fmap - - dimension scrfcn(numneigh), dscrfcn(numneigh) - dimension fcpair(numneigh), x(3,nmax) - dimension firstneigh(numneigh), firstneigh_full(numneigh_full) - dimension type(nmax), fmap(ntype) - - integer jn,j,kn,k - integer elti,eltj,eltk - real*8 xitmp,yitmp,zitmp,delxij,delyij,delzij,rij2,rij - real*8 xjtmp,yjtmp,zjtmp,delxik,delyik,delzik,rik2,rik - real*8 xktmp,yktmp,zktmp,delxjk,delyjk,delzjk,rjk2,rjk - real*8 xik,xjk,sij,fcij,sfcij,dfcij,sikj,dfikj,cikj - real*8 Cmin,Cmax,delc,ebound,rbound,a,coef1,coef2 - real*8 coef1a,coef1b,coef2a,coef2b - real*8 dcikj - real*8 dC1a,dC1b,dC2a,dC2b - real*8 rnorm,fc,dfc,drinv - - drinv = 1.d0/delr_meam - elti = fmap(type(i)) - - if (elti.gt.0) then - - xitmp = x(1,i) - yitmp = x(2,i) - zitmp = x(3,i) - - do jn = 1,numneigh - j = firstneigh(jn) - - eltj = fmap(type(j)) - if (eltj.gt.0) then - -c First compute screening function itself, sij - xjtmp = x(1,j) - yjtmp = x(2,j) - zjtmp = x(3,j) - delxij = xjtmp - xitmp - delyij = yjtmp - yitmp - delzij = zjtmp - zitmp - rij2 = delxij*delxij + delyij*delyij + delzij*delzij - rij = sqrt(rij2) - if (rij.gt.rc_meam) then - fcij = 0.0 - dfcij = 0.d0 - sij = 0.d0 - else - rnorm = (rc_meam-rij)*drinv - call screen(i, j, nmax, x, rij2, sij, - $ numneigh_full, firstneigh_full, ntype, type, fmap) - call dfcut(rnorm,fc,dfc) - fcij = fc - dfcij = dfc*drinv - endif - -c Now compute derivatives - dscrfcn(jn) = 0.d0 - sfcij = sij*fcij - if (sfcij.eq.0.d0.or.sfcij.eq.1.d0) goto 100 - rbound = ebound_meam(elti,eltj) * rij2 - do kn = 1,numneigh_full - k = firstneigh_full(kn) - if (k.eq.j) goto 10 - eltk = fmap(type(k)) - if (eltk.eq.0) goto 10 - xktmp = x(1,k) - yktmp = x(2,k) - zktmp = x(3,k) - delxjk = xktmp - xjtmp - delyjk = yktmp - yjtmp - delzjk = zktmp - zjtmp - rjk2 = delxjk*delxjk + delyjk*delyjk + delzjk*delzjk - if (rjk2.gt.rbound) goto 10 - delxik = xktmp - xitmp - delyik = yktmp - yitmp - delzik = zktmp - zitmp - rik2 = delxik*delxik + delyik*delyik + delzik*delzik - if (rik2.gt.rbound) goto 10 - xik = rik2/rij2 - xjk = rjk2/rij2 - a = 1 - (xik-xjk)*(xik-xjk) -c if a < 0, then ellipse equation doesn't describe this case and -c atom k can't possibly screen i-j - if (a.le.0.d0) goto 10 - cikj = (2.d0*(xik+xjk) + a - 2.d0)/a - Cmax = Cmax_meam(elti,eltj,eltk) - Cmin = Cmin_meam(elti,eltj,eltk) - if (cikj.ge.Cmax) then - goto 10 -c Note that cikj may be slightly negative (within numerical -c tolerance) if atoms are colinear, so don't reject that case here -c (other negative cikj cases were handled by the test on "a" above) -c Note that we never have 0 ebound*rijsq, atom k is definitely outside the ellipse - rbound = ebound_meam(elti,eltj)*rijsq - - do nk = 1,numneigh_full - k = firstneigh_full(nk) - eltk = fmap(type(k)) - if (k.eq.j) goto 10 - delxjk = x(1,k) - x(1,j) - delyjk = x(2,k) - x(2,j) - delzjk = x(3,k) - x(3,j) - rjksq = delxjk*delxjk + delyjk*delyjk + delzjk*delzjk - if (rjksq.gt.rbound) goto 10 - delxik = x(1,k) - x(1,i) - delyik = x(2,k) - x(2,i) - delzik = x(3,k) - x(3,i) - riksq = delxik*delxik + delyik*delyik + delzik*delzik - if (riksq.gt.rbound) goto 10 - xik = riksq/rijsq - xjk = rjksq/rijsq - a = 1 - (xik-xjk)*(xik-xjk) -c if a < 0, then ellipse equation doesn't describe this case and -c atom k can't possibly screen i-j - if (a.le.0.d0) goto 10 - cikj = (2.d0*(xik+xjk) + a - 2.d0)/a - Cmax = Cmax_meam(elti,eltj,eltk) - Cmin = Cmin_meam(elti,eltj,eltk) - if (cikj.ge.Cmax) then - goto 10 -c note that cikj may be slightly negative (within numerical -c tolerance) if atoms are colinear, so don't reject that case here -c (other negative cikj cases were handled by the test on "a" above) - else if (cikj.le.Cmin) then - sij = 0.d0 - goto 20 - else - delc = Cmax - Cmin - cikj = (cikj-Cmin)/delc - call fcut(cikj,sikj) - endif - sij = sij * sikj - 10 continue - enddo - - 20 continue - - return - end - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - subroutine dsij(i,j,k,jn,nmax,numneigh,rij2,dsij1,dsij2, - $ ntype,type,fmap,x,scrfcn,fcpair) -c Inputs: i,j,k = id's of 3 atom triplet -c jn = id of i-j pair -c rij2 = squared distance between i and j -c Outputs: dsij1 = deriv. of sij w.r.t. rik -c dsij2 = deriv. of sij w.r.t. rjk - use meam_data - implicit none - integer i,j,k,jn,nmax,numneigh - integer elti,eltj,eltk - real*8 rij2,rik2,rjk2,dsij1,dsij2 - integer ntype, type, fmap - real*8 x, scrfcn, fcpair - - dimension type(nmax), fmap(ntype) - dimension x(3,nmax), scrfcn(numneigh), fcpair(numneigh) - - real*8 dxik,dyik,dzik - real*8 dxjk,dyjk,dzjk - real*8 rbound,delc,sij,xik,xjk,cikj,sikj,dfc,a - real*8 Cmax,Cmin,dCikj1,dCikj2 - - sij = scrfcn(jn)*fcpair(jn) - elti = fmap(type(i)) - eltj = fmap(type(j)) - eltk = fmap(type(k)) - Cmax = Cmax_meam(elti,eltj,eltk) - Cmin = Cmin_meam(elti,eltj,eltk) - - dsij1 = 0.d0 - dsij2 = 0.d0 - if ((sij.ne.0.d0).and.(sij.ne.1.d0)) then - rbound = rij2*ebound_meam(elti,eltj) - delc = Cmax-Cmin - dxjk = x(1,k) - x(1,j) - dyjk = x(2,k) - x(2,j) - dzjk = x(3,k) - x(3,j) - rjk2 = dxjk*dxjk + dyjk*dyjk + dzjk*dzjk - if (rjk2.le.rbound) then - dxik = x(1,k) - x(1,i) - dyik = x(2,k) - x(2,i) - dzik = x(3,k) - x(3,i) - rik2 = dxik*dxik + dyik*dyik + dzik*dzik - if (rik2.le.rbound) then - xik = rik2/rij2 - xjk = rjk2/rij2 - a = 1 - (xik-xjk)*(xik-xjk) - if (a.ne.0.d0) then - cikj = (2.d0*(xik+xjk) + a - 2.d0)/a - if (cikj.ge.Cmin.and.cikj.le.Cmax) then - cikj = (cikj-Cmin)/delc - call dfcut(cikj,sikj,dfc) - call dCfunc2(rij2,rik2,rjk2,dCikj1,dCikj2) - a = sij/delc*dfc/sikj - dsij1 = a*dCikj1 - dsij2 = a*dCikj2 - endif - endif - endif - endif - endif - - return - end - - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - subroutine fcut(xi,fc) -c cutoff function - implicit none - real*8 xi,fc - real*8 a - if (xi.ge.1.d0) then - fc = 1.d0 - else if (xi.le.0.d0) then - fc = 0.d0 - else - a = 1.d0-xi - a = a*a - a = a*a - a = 1.d0-a - fc = a*a -c fc = xi - endif - return - end - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - subroutine dfcut(xi,fc,dfc) -c cutoff function and its derivative - implicit none - real*8 xi,fc,dfc,a,a3,a4 - if (xi.ge.1.d0) then - fc = 1.d0 - dfc = 0.d0 - else if (xi.le.0.d0) then - fc = 0.d0 - dfc = 0.d0 - else - a = 1.d0-xi - a3 = a*a*a - a4 = a*a3 - fc = (1.d0-a4)**2 - dfc = 8*(1.d0-a4)*a3 -c fc = xi -c dfc = 1.d0 - endif - return - end - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - subroutine dCfunc(rij2,rik2,rjk2,dCikj) -c Inputs: rij,rij2,rik2,rjk2 -c Outputs: dCikj = derivative of Cikj w.r.t. rij - implicit none - real*8 rij2,rik2,rjk2,dCikj - real*8 rij4,a,b,denom - - rij4 = rij2*rij2 - a = rik2-rjk2 - b = rik2+rjk2 - denom = rij4 - a*a - denom = denom*denom - dCikj = -4*(-2*rij2*a*a + rij4*b + a*a*b)/denom - return - end - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - subroutine dCfunc2(rij2,rik2,rjk2,dCikj1,dCikj2) -c Inputs: rij,rij2,rik2,rjk2 -c Outputs: dCikj1 = derivative of Cikj w.r.t. rik -c dCikj2 = derivative of Cikj w.r.t. rjk - implicit none - real*8 rij2,rik2,rjk2,dCikj1,dCikj2 - real*8 rij4,rik4,rjk4,a,b,denom - - rij4 = rij2*rij2 - rik4 = rik2*rik2 - rjk4 = rjk2*rjk2 - a = rik2-rjk2 - b = rik2+rjk2 - denom = rij4 - a*a - denom = denom*denom - dCikj1 = 4*rij2*(rij4 + rik4 + 2*rik2*rjk2 - 3*rjk4 - 2*rij2*a)/ - $ denom - dCikj2 = 4*rij2*(rij4 - 3*rik4 + 2*rik2*rjk2 + rjk4 + 2*rij2*a)/ - $ denom - return - end - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - - - diff --git a/lib/meam/meam_force.F b/lib/meam/meam_force.F deleted file mode 100644 index 1297eb2170..0000000000 --- a/lib/meam/meam_force.F +++ /dev/null @@ -1,608 +0,0 @@ -c Extern "C" declaration has the form: -c -c void meam_force_(int *, int *, int *, double *, int *, int *, int *, double *, -c int *, int *, int *, int *, double *, double *, -c double *, double *, double *, double *, double *, double *, -c double *, double *, double *, double *, double *, double *, -c double *, double *, double *, double *, double *, double *, int *); -c -c Call from pair_meam.cpp has the form: -c -c meam_force_(&i,&nmax,&eflag_either,&eflag_global,&eflag_atom,&vflag_atom, -c &eng_vdwl,eatom,&ntype,type,fmap,&x[0][0], -c &numneigh[i],firstneigh[i],&numneigh_full[i],firstneigh_full[i], -c &scrfcn[offset],&dscrfcn[offset],&fcpair[offset], -c dgamma1,dgamma2,dgamma3,rho0,rho1,rho2,rho3,frhop, -c &arho1[0][0],&arho2[0][0],arho2b,&arho3[0][0],&arho3b[0][0], -c &t_ave[0][0],&tsq_ave[0][0],&f[0][0],&vatom[0][0],&errorflag); -c - - subroutine meam_force(i, nmax, - $ eflag_either, eflag_global, eflag_atom, vflag_atom, - $ eng_vdwl, eatom, ntype, type, fmap, x, - $ numneigh, firstneigh, numneigh_full, firstneigh_full, - $ scrfcn, dscrfcn, fcpair, - $ dGamma1, dGamma2, dGamma3, rho0, rho1, rho2, rho3, fp, - $ Arho1, Arho2, Arho2b, Arho3, Arho3b, t_ave, tsq_ave, f, - $ vatom, errorflag) - - use meam_data - implicit none - - integer eflag_either, eflag_global, eflag_atom, vflag_atom - integer nmax, ntype, type, fmap - real*8 eng_vdwl, eatom, x - integer numneigh, firstneigh, numneigh_full, firstneigh_full - real*8 scrfcn, dscrfcn, fcpair - real*8 dGamma1, dGamma2, dGamma3 - real*8 rho0, rho1, rho2, rho3, fp - real*8 Arho1, Arho2, Arho2b - real*8 Arho3, Arho3b - real*8 t_ave, tsq_ave, f, vatom - integer errorflag - - dimension eatom(nmax) - dimension type(nmax), fmap(ntype) - dimension x(3,nmax) - dimension firstneigh(numneigh), firstneigh_full(numneigh_full) - dimension scrfcn(numneigh), dscrfcn(numneigh), fcpair(numneigh) - dimension dGamma1(nmax), dGamma2(nmax), dGamma3(nmax) - dimension rho0(nmax), rho1(nmax), rho2(nmax), rho3(nmax), fp(nmax) - dimension Arho1(3,nmax), Arho2(6,nmax), Arho2b(nmax) - dimension Arho3(10,nmax), Arho3b(3,nmax) - dimension t_ave(3,nmax), tsq_ave(3,nmax), f(3,nmax), vatom(6,nmax) - - integer i,j,jn,k,kn,kk,m,n,p,q - integer nv2,nv3,elti,eltj,eltk,ind - real*8 xitmp,yitmp,zitmp,delij(3),delref(3),rij2,rij,rij3 - real*8 delik(3),deljk(3),v(6),fi(3),fj(3) - real*8 Eu,astar,astarp,third,sixth - real*8 pp,phiforce,dUdrij,dUdsij,dUdrijm(3),force,forcem - real*8 B,r,recip,phi,phip,rhop,a - real*8 sij,fcij,dfcij,ds(3) - real*8 a0,a1,a1i,a1j,a2,a2i,a2j - real*8 a3i,a3j,a3i1,a3i2,a3j1,a3j2 - real*8 G,dG,Gbar,dGbar,gam,shpi(3),shpj(3),Z,denom - real*8 ai,aj,ro0i,ro0j,invrei,invrej - real*8 b0,rhoa0j,drhoa0j,rhoa0i,drhoa0i - real*8 b1,rhoa1j,drhoa1j,rhoa1i,drhoa1i - real*8 b2,rhoa2j,drhoa2j,rhoa2i,drhoa2i - real*8 a3,a3a,b3,rhoa3j,drhoa3j,rhoa3i,drhoa3i - real*8 drho0dr1,drho0dr2,drho0ds1,drho0ds2 - real*8 drho1dr1,drho1dr2,drho1ds1,drho1ds2 - real*8 drho1drm1(3),drho1drm2(3) - real*8 drho2dr1,drho2dr2,drho2ds1,drho2ds2 - real*8 drho2drm1(3),drho2drm2(3) - real*8 drho3dr1,drho3dr2,drho3ds1,drho3ds2 - real*8 drho3drm1(3),drho3drm2(3) - real*8 dt1dr1,dt1dr2,dt1ds1,dt1ds2 - real*8 dt2dr1,dt2dr2,dt2ds1,dt2ds2 - real*8 dt3dr1,dt3dr2,dt3ds1,dt3ds2 - real*8 drhodr1,drhodr2,drhods1,drhods2,drhodrm1(3),drhodrm2(3) - real*8 arg,arg1,arg2 - real*8 arg1i1,arg1j1,arg1i2,arg1j2,arg2i2,arg2j2 - real*8 arg1i3,arg1j3,arg2i3,arg2j3,arg3i3,arg3j3 - real*8 dsij1,dsij2,force1,force2 - real*8 t1i,t2i,t3i,t1j,t2j,t3j - - errorflag = 0 - third = 1.0/3.0 - sixth = 1.0/6.0 - -c Compute forces atom i - - elti = fmap(type(i)) - - if (elti.gt.0) then - xitmp = x(1,i) - yitmp = x(2,i) - zitmp = x(3,i) - -c Treat each pair - do jn = 1,numneigh - - j = firstneigh(jn) - eltj = fmap(type(j)) - - if (scrfcn(jn).ne.0.d0.and.eltj.gt.0) then - - sij = scrfcn(jn)*fcpair(jn) - delij(1) = x(1,j) - xitmp - delij(2) = x(2,j) - yitmp - delij(3) = x(3,j) - zitmp - rij2 = delij(1)*delij(1) + delij(2)*delij(2) - $ + delij(3)*delij(3) - if (rij2.lt.cutforcesq) then - rij = sqrt(rij2) - r = rij - -c Compute phi and phip - ind = eltind(elti,eltj) - pp = rij*rdrar + 1.0D0 - kk = pp - kk = min(kk,nrar-1) - pp = pp - kk - pp = min(pp,1.0D0) - phi = ((phirar3(kk,ind)*pp + phirar2(kk,ind))*pp - $ + phirar1(kk,ind))*pp + phirar(kk,ind) - phip = (phirar6(kk,ind)*pp + phirar5(kk,ind))*pp - $ + phirar4(kk,ind) - recip = 1.0d0/r - - if (eflag_either.ne.0) then - if (eflag_global.ne.0) eng_vdwl = eng_vdwl + phi*sij - if (eflag_atom.ne.0) then - eatom(i) = eatom(i) + 0.5*phi*sij - eatom(j) = eatom(j) + 0.5*phi*sij - endif - endif - -c write(1,*) "force_meamf: phi: ",phi -c write(1,*) "force_meamf: phip: ",phip - -c Compute pair densities and derivatives - invrei = 1.d0/re_meam(elti,elti) - ai = rij*invrei - 1.d0 - ro0i = rho0_meam(elti) - rhoa0i = ro0i*fm_exp(-beta0_meam(elti)*ai) - drhoa0i = -beta0_meam(elti)*invrei*rhoa0i - rhoa1i = ro0i*fm_exp(-beta1_meam(elti)*ai) - drhoa1i = -beta1_meam(elti)*invrei*rhoa1i - rhoa2i = ro0i*fm_exp(-beta2_meam(elti)*ai) - drhoa2i = -beta2_meam(elti)*invrei*rhoa2i - rhoa3i = ro0i*fm_exp(-beta3_meam(elti)*ai) - drhoa3i = -beta3_meam(elti)*invrei*rhoa3i - - if (elti.ne.eltj) then - invrej = 1.d0/re_meam(eltj,eltj) - aj = rij*invrej - 1.d0 - ro0j = rho0_meam(eltj) - rhoa0j = ro0j*fm_exp(-beta0_meam(eltj)*aj) - drhoa0j = -beta0_meam(eltj)*invrej*rhoa0j - rhoa1j = ro0j*fm_exp(-beta1_meam(eltj)*aj) - drhoa1j = -beta1_meam(eltj)*invrej*rhoa1j - rhoa2j = ro0j*fm_exp(-beta2_meam(eltj)*aj) - drhoa2j = -beta2_meam(eltj)*invrej*rhoa2j - rhoa3j = ro0j*fm_exp(-beta3_meam(eltj)*aj) - drhoa3j = -beta3_meam(eltj)*invrej*rhoa3j - else - rhoa0j = rhoa0i - drhoa0j = drhoa0i - rhoa1j = rhoa1i - drhoa1j = drhoa1i - rhoa2j = rhoa2i - drhoa2j = drhoa2i - rhoa3j = rhoa3i - drhoa3j = drhoa3i - endif - - if (ialloy.eq.1) then - rhoa1j = rhoa1j * t1_meam(eltj) - rhoa2j = rhoa2j * t2_meam(eltj) - rhoa3j = rhoa3j * t3_meam(eltj) - rhoa1i = rhoa1i * t1_meam(elti) - rhoa2i = rhoa2i * t2_meam(elti) - rhoa3i = rhoa3i * t3_meam(elti) - drhoa1j = drhoa1j * t1_meam(eltj) - drhoa2j = drhoa2j * t2_meam(eltj) - drhoa3j = drhoa3j * t3_meam(eltj) - drhoa1i = drhoa1i * t1_meam(elti) - drhoa2i = drhoa2i * t2_meam(elti) - drhoa3i = drhoa3i * t3_meam(elti) - endif - - nv2 = 1 - nv3 = 1 - arg1i1 = 0.d0 - arg1j1 = 0.d0 - arg1i2 = 0.d0 - arg1j2 = 0.d0 - arg1i3 = 0.d0 - arg1j3 = 0.d0 - arg3i3 = 0.d0 - arg3j3 = 0.d0 - do n = 1,3 - do p = n,3 - do q = p,3 - arg = delij(n)*delij(p)*delij(q)*v3D(nv3) - arg1i3 = arg1i3 + Arho3(nv3,i)*arg - arg1j3 = arg1j3 - Arho3(nv3,j)*arg - nv3 = nv3+1 - enddo - arg = delij(n)*delij(p)*v2D(nv2) - arg1i2 = arg1i2 + Arho2(nv2,i)*arg - arg1j2 = arg1j2 + Arho2(nv2,j)*arg - nv2 = nv2+1 - enddo - arg1i1 = arg1i1 + Arho1(n,i)*delij(n) - arg1j1 = arg1j1 - Arho1(n,j)*delij(n) - arg3i3 = arg3i3 + Arho3b(n,i)*delij(n) - arg3j3 = arg3j3 - Arho3b(n,j)*delij(n) - enddo - -c rho0 terms - drho0dr1 = drhoa0j * sij - drho0dr2 = drhoa0i * sij - -c rho1 terms - a1 = 2*sij/rij - drho1dr1 = a1*(drhoa1j-rhoa1j/rij)*arg1i1 - drho1dr2 = a1*(drhoa1i-rhoa1i/rij)*arg1j1 - a1 = 2.d0*sij/rij - do m = 1,3 - drho1drm1(m) = a1*rhoa1j*Arho1(m,i) - drho1drm2(m) = -a1*rhoa1i*Arho1(m,j) - enddo - -c rho2 terms - a2 = 2*sij/rij2 - drho2dr1 = a2*(drhoa2j - 2*rhoa2j/rij)*arg1i2 - $ - 2.d0/3.d0*Arho2b(i)*drhoa2j*sij - drho2dr2 = a2*(drhoa2i - 2*rhoa2i/rij)*arg1j2 - $ - 2.d0/3.d0*Arho2b(j)*drhoa2i*sij - a2 = 4*sij/rij2 - do m = 1,3 - drho2drm1(m) = 0.d0 - drho2drm2(m) = 0.d0 - do n = 1,3 - drho2drm1(m) = drho2drm1(m) - $ + Arho2(vind2D(m,n),i)*delij(n) - drho2drm2(m) = drho2drm2(m) - $ - Arho2(vind2D(m,n),j)*delij(n) - enddo - drho2drm1(m) = a2*rhoa2j*drho2drm1(m) - drho2drm2(m) = -a2*rhoa2i*drho2drm2(m) - enddo - -c rho3 terms - rij3 = rij*rij2 - a3 = 2*sij/rij3 - a3a = 6.d0/5.d0*sij/rij - drho3dr1 = a3*(drhoa3j - 3*rhoa3j/rij)*arg1i3 - $ - a3a*(drhoa3j - rhoa3j/rij)*arg3i3 - drho3dr2 = a3*(drhoa3i - 3*rhoa3i/rij)*arg1j3 - $ - a3a*(drhoa3i - rhoa3i/rij)*arg3j3 - a3 = 6*sij/rij3 - a3a = 6*sij/(5*rij) - do m = 1,3 - drho3drm1(m) = 0.d0 - drho3drm2(m) = 0.d0 - nv2 = 1 - do n = 1,3 - do p = n,3 - arg = delij(n)*delij(p)*v2D(nv2) - drho3drm1(m) = drho3drm1(m) - $ + Arho3(vind3D(m,n,p),i)*arg - drho3drm2(m) = drho3drm2(m) - $ + Arho3(vind3D(m,n,p),j)*arg - nv2 = nv2 + 1 - enddo - enddo - drho3drm1(m) = (a3*drho3drm1(m) - a3a*Arho3b(m,i)) - $ *rhoa3j - drho3drm2(m) = (-a3*drho3drm2(m) + a3a*Arho3b(m,j)) - $ *rhoa3i - enddo - -c Compute derivatives of weighting functions t wrt rij - t1i = t_ave(1,i) - t2i = t_ave(2,i) - t3i = t_ave(3,i) - t1j = t_ave(1,j) - t2j = t_ave(2,j) - t3j = t_ave(3,j) - - if (ialloy.eq.1) then - - a1i = 0.d0 - a1j = 0.d0 - a2i = 0.d0 - a2j = 0.d0 - a3i = 0.d0 - a3j = 0.d0 - if ( tsq_ave(1,i) .ne. 0.d0 ) then - a1i = drhoa0j*sij/tsq_ave(1,i) - endif - if ( tsq_ave(1,j) .ne. 0.d0 ) then - a1j = drhoa0i*sij/tsq_ave(1,j) - endif - if ( tsq_ave(2,i) .ne. 0.d0 ) then - a2i = drhoa0j*sij/tsq_ave(2,i) - endif - if ( tsq_ave(2,j) .ne. 0.d0 ) then - a2j = drhoa0i*sij/tsq_ave(2,j) - endif - if ( tsq_ave(3,i) .ne. 0.d0 ) then - a3i = drhoa0j*sij/tsq_ave(3,i) - endif - if ( tsq_ave(3,j) .ne. 0.d0 ) then - a3j = drhoa0i*sij/tsq_ave(3,j) - endif - - dt1dr1 = a1i*(t1_meam(eltj)-t1i*t1_meam(eltj)**2) - dt1dr2 = a1j*(t1_meam(elti)-t1j*t1_meam(elti)**2) - dt2dr1 = a2i*(t2_meam(eltj)-t2i*t2_meam(eltj)**2) - dt2dr2 = a2j*(t2_meam(elti)-t2j*t2_meam(elti)**2) - dt3dr1 = a3i*(t3_meam(eltj)-t3i*t3_meam(eltj)**2) - dt3dr2 = a3j*(t3_meam(elti)-t3j*t3_meam(elti)**2) - - else if (ialloy.eq.2) then - - dt1dr1 = 0.d0 - dt1dr2 = 0.d0 - dt2dr1 = 0.d0 - dt2dr2 = 0.d0 - dt3dr1 = 0.d0 - dt3dr2 = 0.d0 - - else - - ai = 0.d0 - if( rho0(i) .ne. 0.d0 ) then - ai = drhoa0j*sij/rho0(i) - end if - aj = 0.d0 - if( rho0(j) .ne. 0.d0 ) then - aj = drhoa0i*sij/rho0(j) - end if - - dt1dr1 = ai*(t1_meam(eltj)-t1i) - dt1dr2 = aj*(t1_meam(elti)-t1j) - dt2dr1 = ai*(t2_meam(eltj)-t2i) - dt2dr2 = aj*(t2_meam(elti)-t2j) - dt3dr1 = ai*(t3_meam(eltj)-t3i) - dt3dr2 = aj*(t3_meam(elti)-t3j) - - endif - -c Compute derivatives of total density wrt rij, sij and rij(3) - call get_shpfcn(shpi,lattce_meam(elti,elti)) - call get_shpfcn(shpj,lattce_meam(eltj,eltj)) - drhodr1 = dGamma1(i)*drho0dr1 - $ + dGamma2(i)* - $ (dt1dr1*rho1(i)+t1i*drho1dr1 - $ + dt2dr1*rho2(i)+t2i*drho2dr1 - $ + dt3dr1*rho3(i)+t3i*drho3dr1) - $ - dGamma3(i)* - $ (shpi(1)*dt1dr1+shpi(2)*dt2dr1+shpi(3)*dt3dr1) - drhodr2 = dGamma1(j)*drho0dr2 - $ + dGamma2(j)* - $ (dt1dr2*rho1(j)+t1j*drho1dr2 - $ + dt2dr2*rho2(j)+t2j*drho2dr2 - $ + dt3dr2*rho3(j)+t3j*drho3dr2) - $ - dGamma3(j)* - $ (shpj(1)*dt1dr2+shpj(2)*dt2dr2+shpj(3)*dt3dr2) - do m = 1,3 - drhodrm1(m) = 0.d0 - drhodrm2(m) = 0.d0 - drhodrm1(m) = dGamma2(i)* - $ (t1i*drho1drm1(m) - $ + t2i*drho2drm1(m) - $ + t3i*drho3drm1(m)) - drhodrm2(m) = dGamma2(j)* - $ (t1j*drho1drm2(m) - $ + t2j*drho2drm2(m) - $ + t3j*drho3drm2(m)) - enddo - -c Compute derivatives wrt sij, but only if necessary - if (dscrfcn(jn).ne.0.d0) then - drho0ds1 = rhoa0j - drho0ds2 = rhoa0i - a1 = 2.d0/rij - drho1ds1 = a1*rhoa1j*arg1i1 - drho1ds2 = a1*rhoa1i*arg1j1 - a2 = 2.d0/rij2 - drho2ds1 = a2*rhoa2j*arg1i2 - $ - 2.d0/3.d0*Arho2b(i)*rhoa2j - drho2ds2 = a2*rhoa2i*arg1j2 - $ - 2.d0/3.d0*Arho2b(j)*rhoa2i - a3 = 2.d0/rij3 - a3a = 6.d0/(5.d0*rij) - drho3ds1 = a3*rhoa3j*arg1i3 - a3a*rhoa3j*arg3i3 - drho3ds2 = a3*rhoa3i*arg1j3 - a3a*rhoa3i*arg3j3 - - if (ialloy.eq.1) then - - a1i = 0.d0 - a1j = 0.d0 - a2i = 0.d0 - a2j = 0.d0 - a3i = 0.d0 - a3j = 0.d0 - if ( tsq_ave(1,i) .ne. 0.d0 ) then - a1i = rhoa0j/tsq_ave(1,i) - endif - if ( tsq_ave(1,j) .ne. 0.d0 ) then - a1j = rhoa0i/tsq_ave(1,j) - endif - if ( tsq_ave(2,i) .ne. 0.d0 ) then - a2i = rhoa0j/tsq_ave(2,i) - endif - if ( tsq_ave(2,j) .ne. 0.d0 ) then - a2j = rhoa0i/tsq_ave(2,j) - endif - if ( tsq_ave(3,i) .ne. 0.d0 ) then - a3i = rhoa0j/tsq_ave(3,i) - endif - if ( tsq_ave(3,j) .ne. 0.d0 ) then - a3j = rhoa0i/tsq_ave(3,j) - endif - - dt1ds1 = a1i*(t1_meam(eltj)-t1i*t1_meam(eltj)**2) - dt1ds2 = a1j*(t1_meam(elti)-t1j*t1_meam(elti)**2) - dt2ds1 = a2i*(t2_meam(eltj)-t2i*t2_meam(eltj)**2) - dt2ds2 = a2j*(t2_meam(elti)-t2j*t2_meam(elti)**2) - dt3ds1 = a3i*(t3_meam(eltj)-t3i*t3_meam(eltj)**2) - dt3ds2 = a3j*(t3_meam(elti)-t3j*t3_meam(elti)**2) - - else if (ialloy.eq.2) then - - dt1ds1 = 0.d0 - dt1ds2 = 0.d0 - dt2ds1 = 0.d0 - dt2ds2 = 0.d0 - dt3ds1 = 0.d0 - dt3ds2 = 0.d0 - - else - - ai = 0.d0 - if( rho0(i) .ne. 0.d0 ) then - ai = rhoa0j/rho0(i) - end if - aj = 0.d0 - if( rho0(j) .ne. 0.d0 ) then - aj = rhoa0i/rho0(j) - end if - - dt1ds1 = ai*(t1_meam(eltj)-t1i) - dt1ds2 = aj*(t1_meam(elti)-t1j) - dt2ds1 = ai*(t2_meam(eltj)-t2i) - dt2ds2 = aj*(t2_meam(elti)-t2j) - dt3ds1 = ai*(t3_meam(eltj)-t3i) - dt3ds2 = aj*(t3_meam(elti)-t3j) - - endif - - drhods1 = dGamma1(i)*drho0ds1 - $ + dGamma2(i)* - $ (dt1ds1*rho1(i)+t1i*drho1ds1 - $ + dt2ds1*rho2(i)+t2i*drho2ds1 - $ + dt3ds1*rho3(i)+t3i*drho3ds1) - $ - dGamma3(i)* - $ (shpi(1)*dt1ds1+shpi(2)*dt2ds1+shpi(3)*dt3ds1) - drhods2 = dGamma1(j)*drho0ds2 - $ + dGamma2(j)* - $ (dt1ds2*rho1(j)+t1j*drho1ds2 - $ + dt2ds2*rho2(j)+t2j*drho2ds2 - $ + dt3ds2*rho3(j)+t3j*drho3ds2) - $ - dGamma3(j)* - $ (shpj(1)*dt1ds2+shpj(2)*dt2ds2+shpj(3)*dt3ds2) - endif - -c Compute derivatives of energy wrt rij, sij and rij(3) - dUdrij = phip*sij - $ + fp(i)*drhodr1 + fp(j)*drhodr2 - dUdsij = 0.d0 - if (dscrfcn(jn).ne.0.d0) then - dUdsij = phi - $ + fp(i)*drhods1 + fp(j)*drhods2 - endif - do m = 1,3 - dUdrijm(m) = fp(i)*drhodrm1(m) + fp(j)*drhodrm2(m) - enddo - -c Add the part of the force due to dUdrij and dUdsij - - force = dUdrij*recip + dUdsij*dscrfcn(jn) - do m = 1,3 - forcem = delij(m)*force + dUdrijm(m) - f(m,i) = f(m,i) + forcem - f(m,j) = f(m,j) - forcem - enddo - -c Tabulate per-atom virial as symmetrized stress tensor - - if (vflag_atom.ne.0) then - fi(1) = delij(1)*force + dUdrijm(1) - fi(2) = delij(2)*force + dUdrijm(2) - fi(3) = delij(3)*force + dUdrijm(3) - v(1) = -0.5 * (delij(1) * fi(1)) - v(2) = -0.5 * (delij(2) * fi(2)) - v(3) = -0.5 * (delij(3) * fi(3)) - v(4) = -0.25 * (delij(1)*fi(2) + delij(2)*fi(1)) - v(5) = -0.25 * (delij(1)*fi(3) + delij(3)*fi(1)) - v(6) = -0.25 * (delij(2)*fi(3) + delij(3)*fi(2)) - - vatom(1,i) = vatom(1,i) + v(1) - vatom(2,i) = vatom(2,i) + v(2) - vatom(3,i) = vatom(3,i) + v(3) - vatom(4,i) = vatom(4,i) + v(4) - vatom(5,i) = vatom(5,i) + v(5) - vatom(6,i) = vatom(6,i) + v(6) - vatom(1,j) = vatom(1,j) + v(1) - vatom(2,j) = vatom(2,j) + v(2) - vatom(3,j) = vatom(3,j) + v(3) - vatom(4,j) = vatom(4,j) + v(4) - vatom(5,j) = vatom(5,j) + v(5) - vatom(6,j) = vatom(6,j) + v(6) - endif - -c Now compute forces on other atoms k due to change in sij - - if (sij.eq.0.d0.or.sij.eq.1.d0) goto 100 - do kn = 1,numneigh_full - k = firstneigh_full(kn) - eltk = fmap(type(k)) - if (k.ne.j.and.eltk.gt.0) then - call dsij(i,j,k,jn,nmax,numneigh,rij2,dsij1,dsij2, - $ ntype,type,fmap,x,scrfcn,fcpair) - if (dsij1.ne.0.d0.or.dsij2.ne.0.d0) then - force1 = dUdsij*dsij1 - force2 = dUdsij*dsij2 - do m = 1,3 - delik(m) = x(m,k) - x(m,i) - deljk(m) = x(m,k) - x(m,j) - enddo - do m = 1,3 - f(m,i) = f(m,i) + force1*delik(m) - f(m,j) = f(m,j) + force2*deljk(m) - f(m,k) = f(m,k) - force1*delik(m) - $ - force2*deljk(m) - enddo - -c Tabulate per-atom virial as symmetrized stress tensor - - if (vflag_atom.ne.0) then - fi(1) = force1*delik(1) - fi(2) = force1*delik(2) - fi(3) = force1*delik(3) - fj(1) = force2*deljk(1) - fj(2) = force2*deljk(2) - fj(3) = force2*deljk(3) - v(1) = -third * (delik(1)*fi(1) + deljk(1)*fj(1)) - v(2) = -third * (delik(2)*fi(2) + deljk(2)*fj(2)) - v(3) = -third * (delik(3)*fi(3) + deljk(3)*fj(3)) - v(4) = -sixth * (delik(1)*fi(2) + deljk(1)*fj(2) + - $ delik(2)*fi(1) + deljk(2)*fj(1)) - v(5) = -sixth * (delik(1)*fi(3) + deljk(1)*fj(3) + - $ delik(3)*fi(1) + deljk(3)*fj(1)) - v(6) = -sixth * (delik(2)*fi(3) + deljk(2)*fj(3) + - $ delik(3)*fi(2) + deljk(3)*fj(2)) - - vatom(1,i) = vatom(1,i) + v(1) - vatom(2,i) = vatom(2,i) + v(2) - vatom(3,i) = vatom(3,i) + v(3) - vatom(4,i) = vatom(4,i) + v(4) - vatom(5,i) = vatom(5,i) + v(5) - vatom(6,i) = vatom(6,i) + v(6) - vatom(1,j) = vatom(1,j) + v(1) - vatom(2,j) = vatom(2,j) + v(2) - vatom(3,j) = vatom(3,j) + v(3) - vatom(4,j) = vatom(4,j) + v(4) - vatom(5,j) = vatom(5,j) + v(5) - vatom(6,j) = vatom(6,j) + v(6) - vatom(1,k) = vatom(1,k) + v(1) - vatom(2,k) = vatom(2,k) + v(2) - vatom(3,k) = vatom(3,k) + v(3) - vatom(4,k) = vatom(4,k) + v(4) - vatom(5,k) = vatom(5,k) + v(5) - vatom(6,k) = vatom(6,k) + v(6) - endif - - endif - endif -c end of k loop - enddo - endif - 100 continue - endif -c end of j loop - enddo - -c else if elti=0, this is not a meam atom - endif - - return - end diff --git a/lib/meam/meam_setup_done.F b/lib/meam/meam_setup_done.F deleted file mode 100644 index c94bce8b44..0000000000 --- a/lib/meam/meam_setup_done.F +++ /dev/null @@ -1,1041 +0,0 @@ -c Declaration in pair_meam.h: -c -c void meam_setup_done(double *) -c -c Call from pair_meam.cpp: -c -c meam_setup_done(&cutmax) -c - - subroutine meam_setup_done(cutmax) - use meam_data - implicit none - - real*8 cutmax - - integer nv2, nv3, m, n, p - -c Force cutoff - cutforce = rc_meam - cutforcesq = cutforce*cutforce - -c Pass cutoff back to calling program - cutmax = cutforce - -c Augment t1 term - t1_meam(:) = t1_meam(:) + augt1 * 3.d0/5.d0 * t3_meam(:) - -c Compute off-diagonal alloy parameters - call alloyparams - -c indices and factors for Voight notation - nv2 = 1 - nv3 = 1 - do m = 1,3 - do n = m,3 - vind2D(m,n) = nv2 - vind2D(n,m) = nv2 - nv2 = nv2+1 - do p = n,3 - vind3D(m,n,p) = nv3 - vind3D(m,p,n) = nv3 - vind3D(n,m,p) = nv3 - vind3D(n,p,m) = nv3 - vind3D(p,m,n) = nv3 - vind3D(p,n,m) = nv3 - nv3 = nv3+1 - enddo - enddo - enddo - - v2D(1) = 1 - v2D(2) = 2 - v2D(3) = 2 - v2D(4) = 1 - v2D(5) = 2 - v2D(6) = 1 - - v3D(1) = 1 - v3D(2) = 3 - v3D(3) = 3 - v3D(4) = 3 - v3D(5) = 6 - v3D(6) = 3 - v3D(7) = 1 - v3D(8) = 3 - v3D(9) = 3 - v3D(10) = 1 - - nv2 = 1 - do m = 1,neltypes - do n = m,neltypes - eltind(m,n) = nv2 - eltind(n,m) = nv2 - nv2 = nv2+1 - enddo - enddo - -c Compute background densities for reference structure - call compute_reference_density - -c Compute pair potentials and setup arrays for interpolation - nr = 1000 - dr = 1.1*rc_meam/nr - call compute_pair_meam - - return - end - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c Fill off-diagonal alloy parameters - subroutine alloyparams - use meam_data - implicit none - integer i,j,k - real*8 eb - -c Loop over pairs - do i = 1,neltypes - do j = 1,neltypes -c Treat off-diagonal pairs -c If i>j, set all equal to ij, set equal to the iebound, -c atom k definitely lies outside the screening function ellipse (so -c there is no need to calculate its effects). Here, compute it for all -c triplets (i,j,k) so that ebound(i,j) is the maximized over k - do i = 1,neltypes - do j = 1,neltypes - do k = 1,neltypes - eb = (Cmax_meam(i,j,k)*Cmax_meam(i,j,k)) - $ /(4.d0*(Cmax_meam(i,j,k)-1.d0)) - ebound_meam(i,j) = max(ebound_meam(i,j),eb) - enddo - enddo - enddo - - return - end - -c----------------------------------------------------------------------- -c compute MEAM pair potential for each pair of element types -c - - subroutine compute_pair_meam - use meam_data - implicit none - - real*8 r, temp - integer j,a,b,nv2 - real*8 astar,frac,phizbl - integer n,nmax,Z1,Z2 - real*8 arat,rarat,scrn,scrn2 - real*8 phiaa,phibb,phitmp - real*8 C,s111,s112,s221,S11,S22 - - real*8, external :: phi_meam - real*8, external :: zbl - real*8, external :: compute_phi - -c check for previously allocated arrays and free them - if(allocated(phir)) deallocate(phir) - if(allocated(phirar)) deallocate(phirar) - if(allocated(phirar1)) deallocate(phirar1) - if(allocated(phirar2)) deallocate(phirar2) - if(allocated(phirar3)) deallocate(phirar3) - if(allocated(phirar4)) deallocate(phirar4) - if(allocated(phirar5)) deallocate(phirar5) - if(allocated(phirar6)) deallocate(phirar6) - -c allocate memory for array that defines the potential - allocate(phir(nr,(neltypes*(neltypes+1))/2)) - -c allocate coeff memory - - allocate(phirar(nr,(neltypes*(neltypes+1))/2)) - allocate(phirar1(nr,(neltypes*(neltypes+1))/2)) - allocate(phirar2(nr,(neltypes*(neltypes+1))/2)) - allocate(phirar3(nr,(neltypes*(neltypes+1))/2)) - allocate(phirar4(nr,(neltypes*(neltypes+1))/2)) - allocate(phirar5(nr,(neltypes*(neltypes+1))/2)) - allocate(phirar6(nr,(neltypes*(neltypes+1))/2)) - -c loop over pairs of element types - nv2 = 0 - do a = 1,neltypes - do b = a,neltypes - nv2 = nv2 + 1 - -c loop over r values and compute - do j = 1,nr - - r = (j-1)*dr - - phir(j,nv2) = phi_meam(r,a,b) - -c if using second-nearest neighbor, solve recursive problem -c (see Lee and Baskes, PRB 62(13):8564 eqn.(21)) - if (nn2_meam(a,b).eq.1) then - call get_Zij(Z1,lattce_meam(a,b)) - call get_Zij2(Z2,arat,scrn,lattce_meam(a,b), - $ Cmin_meam(a,a,b),Cmax_meam(a,a,b)) - -c The B1, B2, and L12 cases with NN2 have a trick to them; we need to -c compute the contributions from second nearest neighbors, like a-a -c pairs, but need to include NN2 contributions to those pairs as -c well. - if (lattce_meam(a,b).eq.'b1'.or. - $ lattce_meam(a,b).eq.'b2'.or. - $ lattce_meam(a,b).eq.'l12'.or. - $ lattce_meam(a,b).eq.'dia') then - rarat = r*arat - -c phi_aa - phiaa = phi_meam(rarat,a,a) - call get_Zij(Z1,lattce_meam(a,a)) - call get_Zij2(Z2,arat,scrn,lattce_meam(a,a), - $ Cmin_meam(a,a,a),Cmax_meam(a,a,a)) - nmax = 10 - if (scrn.gt.0.0) then - do n = 1,nmax - phiaa = phiaa + - $ (-Z2*scrn/Z1)**n * phi_meam(rarat*arat**n,a,a) - enddo - endif - -c phi_bb - phibb = phi_meam(rarat,b,b) - call get_Zij(Z1,lattce_meam(b,b)) - call get_Zij2(Z2,arat,scrn,lattce_meam(b,b), - $ Cmin_meam(b,b,b),Cmax_meam(b,b,b)) - nmax = 10 - if (scrn.gt.0.0) then - do n = 1,nmax - phibb = phibb + - $ (-Z2*scrn/Z1)**n * phi_meam(rarat*arat**n,b,b) - enddo - endif - - if (lattce_meam(a,b).eq.'b1'. - $ or.lattce_meam(a,b).eq.'b2'. - $ or.lattce_meam(a,b).eq.'dia') then -c Add contributions to the B1 or B2 potential - call get_Zij(Z1,lattce_meam(a,b)) - call get_Zij2(Z2,arat,scrn,lattce_meam(a,b), - $ Cmin_meam(a,a,b),Cmax_meam(a,a,b)) - phir(j,nv2) = phir(j,nv2) - - $ Z2*scrn/(2*Z1) * phiaa - call get_Zij2(Z2,arat,scrn2,lattce_meam(a,b), - $ Cmin_meam(b,b,a),Cmax_meam(b,b,a)) - phir(j,nv2) = phir(j,nv2) - - $ Z2*scrn2/(2*Z1) * phibb - - else if (lattce_meam(a,b).eq.'l12') then -c The L12 case has one last trick; we have to be careful to compute -c the correct screening between 2nd-neighbor pairs. 1-1 -c second-neighbor pairs are screened by 2 type 1 atoms and two type -c 2 atoms. 2-2 second-neighbor pairs are screened by 4 type 1 -c atoms. - C = 1.d0 - call get_sijk(C,a,a,a,s111) - call get_sijk(C,a,a,b,s112) - call get_sijk(C,b,b,a,s221) - S11 = s111 * s111 * s112 * s112 - S22 = s221**4 - phir(j,nv2) = phir(j,nv2) - - $ 0.75*S11*phiaa - 0.25*S22*phibb - - endif - - else - nmax = 10 - do n = 1,nmax - phir(j,nv2) = phir(j,nv2) + - $ (-Z2*scrn/Z1)**n * phi_meam(r*arat**n,a,b) - enddo - endif - - endif - -c For Zbl potential: -c if astar <= -3 -c potential is zbl potential -c else if -3 < astar < -1 -c potential is linear combination with zbl potential -c endif - if (zbl_meam(a,b).eq.1) then - astar = alpha_meam(a,b) * (r/re_meam(a,b) - 1.d0) - if (astar.le.-3.d0) then - phir(j,nv2) = zbl(r,ielt_meam(a),ielt_meam(b)) - else if (astar.gt.-3.d0.and.astar.lt.-1.d0) then - call fcut(1-(astar+1.d0)/(-3.d0+1.d0),frac) - phizbl = zbl(r,ielt_meam(a),ielt_meam(b)) - phir(j,nv2) = frac*phir(j,nv2) + (1-frac)*phizbl - endif - endif - - enddo - -c call interpolation - call interpolate_meam(nv2) - - enddo - enddo - - return - end - - -c----------------------------------------------------------------------c -c Compute MEAM pair potential for distance r, element types a and b -c - real*8 recursive function phi_meam(r,a,b)result(phi_m) - use meam_data - implicit none - - - integer a,b - real*8 r - real*8 a1,a2,a12 - real*8 t11av,t21av,t31av,t12av,t22av,t32av - real*8 G1,G2,s1(3),s2(3),s12(3),rho0_1,rho0_2 - real*8 Gam1,Gam2,Z1,Z2 - real*8 rhobar1,rhobar2,F1,F2 - real*8 rhoa01,rhoa11,rhoa21,rhoa31 - real*8 rhoa02,rhoa12,rhoa22,rhoa32 - real*8 rho01,rho11,rho21,rho31 - real*8 rho02,rho12,rho22,rho32 - real*8 scalfac,phiaa,phibb - real*8 Eu - real*8 arat,scrn,scrn2 - integer Z12, errorflag - integer n,nmax,Z1nn,Z2nn - character*3 latta,lattb - real*8 rho_bkgd1, rho_bkgd2 - - real*8, external :: erose - -c Equation numbers below refer to: -c I. Huang et.al., Modelling simul. Mater. Sci. Eng. 3:615 - -c get number of neighbors in the reference structure -c Nref(i,j) = # of i's neighbors of type j - call get_Zij(Z12,lattce_meam(a,b)) - - call get_densref(r,a,b,rho01,rho11,rho21,rho31, - $ rho02,rho12,rho22,rho32) - -c if densities are too small, numerical problems may result; just return zero - if (rho01.le.1e-14.and.rho02.le.1e-14) then - phi_m = 0.0 - return - endif - -c calculate average weighting factors for the reference structure - if (lattce_meam(a,b).eq.'c11') then - if (ialloy.eq.2) then - t11av = t1_meam(a) - t12av = t1_meam(b) - t21av = t2_meam(a) - t22av = t2_meam(b) - t31av = t3_meam(a) - t32av = t3_meam(b) - else - scalfac = 1.0/(rho01+rho02) - t11av = scalfac*(t1_meam(a)*rho01 + t1_meam(b)*rho02) - t12av = t11av - t21av = scalfac*(t2_meam(a)*rho01 + t2_meam(b)*rho02) - t22av = t21av - t31av = scalfac*(t3_meam(a)*rho01 + t3_meam(b)*rho02) - t32av = t31av - endif - else -c average weighting factors for the reference structure, eqn. I.8 - call get_tavref(t11av,t21av,t31av,t12av,t22av,t32av, - $ t1_meam(a),t2_meam(a),t3_meam(a), - $ t1_meam(b),t2_meam(b),t3_meam(b), - $ r,a,b,lattce_meam(a,b)) - endif - -c for c11b structure, calculate background electron densities - if (lattce_meam(a,b).eq.'c11') then - latta = lattce_meam(a,a) - if (latta.eq.'dia') then - rhobar1 = ((Z12/2)*(rho02+rho01))**2 + - $ t11av*(rho12-rho11)**2 + - $ t21av/6.0*(rho22+rho21)**2 + - $ 121.0/40.*t31av*(rho32-rho31)**2 - rhobar1 = sqrt(rhobar1) - rhobar2 = (Z12*rho01)**2 + 2.0/3.0*t21av*rho21**2 - rhobar2 = sqrt(rhobar2) - else - rhobar2 = ((Z12/2)*(rho01+rho02))**2 + - $ t12av*(rho11-rho12)**2 + - $ t22av/6.0*(rho21+rho22)**2 + - $ 121.0/40.*t32av*(rho31-rho32)**2 - rhobar2 = sqrt(rhobar2) - rhobar1 = (Z12*rho02)**2 + 2.0/3.0*t22av*rho22**2 - rhobar1 = sqrt(rhobar1) - endif - else -c for other structures, use formalism developed in Huang's paper -c -c composition-dependent scaling, equation I.7 -c If using mixing rule for t, apply to reference structure; else -c use precomputed values - if (mix_ref_t.eq.1) then - Z1 = Z_meam(a) - Z2 = Z_meam(b) - if (ibar_meam(a).le.0) then - G1 = 1.d0 - else - call get_shpfcn(s1,lattce_meam(a,a)) - Gam1 = (s1(1)*t11av+s1(2)*t21av+s1(3)*t31av)/(Z1*Z1) - call G_gam(Gam1,ibar_meam(a),gsmooth_factor,G1,errorflag) - endif - if (ibar_meam(b).le.0) then - G2 = 1.d0 - else - call get_shpfcn(s2,lattce_meam(b,b)) - Gam2 = (s2(1)*t12av+s2(2)*t22av+s2(3)*t32av)/(Z2*Z2) - call G_gam(Gam2,ibar_meam(b),gsmooth_factor,G2,errorflag) - endif - rho0_1 = rho0_meam(a)*Z1*G1 - rho0_2 = rho0_meam(b)*Z2*G2 - endif - Gam1 = (t11av*rho11+t21av*rho21+t31av*rho31) - if (rho01 < 1.0d-14) then - Gam1 = 0.0d0 - else - Gam1 = Gam1/(rho01*rho01) - endif - Gam2 = (t12av*rho12+t22av*rho22+t32av*rho32) - if (rho02 < 1.0d-14) then - Gam2 = 0.0d0 - else - Gam2 = Gam2/(rho02*rho02) - endif - call G_gam(Gam1,ibar_meam(a),gsmooth_factor,G1,errorflag) - call G_gam(Gam2,ibar_meam(b),gsmooth_factor,G2,errorflag) - if (mix_ref_t.eq.1) then - rho_bkgd1 = rho0_1 - rho_bkgd2 = rho0_2 - else - if (bkgd_dyn.eq.1) then - rho_bkgd1 = rho0_meam(a)*Z_meam(a) - rho_bkgd2 = rho0_meam(b)*Z_meam(b) - else - rho_bkgd1 = rho_ref_meam(a) - rho_bkgd2 = rho_ref_meam(b) - endif - endif - rhobar1 = rho01/rho_bkgd1*G1 - rhobar2 = rho02/rho_bkgd2*G2 - - endif - -c compute embedding functions, eqn I.5 - if (rhobar1.eq.0.d0) then - F1 = 0.d0 - else - if (emb_lin_neg.eq.1 .and. rhobar1.le.0) then - F1 = -A_meam(a)*Ec_meam(a,a)*rhobar1 - else - F1 = A_meam(a)*Ec_meam(a,a)*rhobar1*log(rhobar1) - endif - endif - if (rhobar2.eq.0.d0) then - F2 = 0.d0 - else - if (emb_lin_neg.eq.1 .and. rhobar2.le.0) then - F2 = -A_meam(b)*Ec_meam(b,b)*rhobar2 - else - F2 = A_meam(b)*Ec_meam(b,b)*rhobar2*log(rhobar2) - endif - endif - -c compute Rose function, I.16 - Eu = erose(r,re_meam(a,b),alpha_meam(a,b), - $ Ec_meam(a,b),repuls_meam(a,b),attrac_meam(a,b),erose_form) - -c calculate the pair energy - if (lattce_meam(a,b).eq.'c11') then - latta = lattce_meam(a,a) - if (latta.eq.'dia') then - phiaa = phi_meam(r,a,a) - phi_m = (3*Eu - F2 - 2*F1 - 5*phiaa)/Z12 - else - phibb = phi_meam(r,b,b) - phi_m = (3*Eu - F1 - 2*F2 - 5*phibb)/Z12 - endif - else if (lattce_meam(a,b).eq.'l12') then - phiaa = phi_meam(r,a,a) -c account for second neighbor a-a potential here... - call get_Zij(Z1nn,lattce_meam(a,a)) - call get_Zij2(Z2nn,arat,scrn,lattce_meam(a,a), - $ Cmin_meam(a,a,a),Cmax_meam(a,a,a)) - nmax = 10 - if (scrn.gt.0.0) then - do n = 1,nmax - phiaa = phiaa + - $ (-Z2nn*scrn/Z1nn)**n * phi_meam(r*arat**n,a,a) - enddo - endif - phi_m = Eu/3. - F1/4. - F2/12. - phiaa - else -c -c potential is computed from Rose function and embedding energy - phi_m = (2*Eu - F1 - F2)/Z12 -c - endif - -c if r = 0, just return 0 - if (r.eq.0.d0) then - phi_m = 0.d0 - endif - - return - end - -c----------------------------------------------------------------------c -c Compute background density for reference structure of each element - subroutine compute_reference_density - use meam_data - implicit none - - integer a,Z,Z2,errorflag - real*8 gam,Gbar,shp(3) - real*8 rho0,rho0_2nn,arat,scrn - -c loop over element types - do a = 1,neltypes - - Z = Z_meam(a) - if (ibar_meam(a).le.0) then - Gbar = 1.d0 - else - call get_shpfcn(shp,lattce_meam(a,a)) - gam = (t1_meam(a)*shp(1)+t2_meam(a)*shp(2) - $ +t3_meam(a)*shp(3))/(Z*Z) - call G_gam(gam,ibar_meam(a),gsmooth_factor, - $ Gbar,errorflag) - endif - -c The zeroth order density in the reference structure, with -c equilibrium spacing, is just the number of first neighbors times -c the rho0_meam coefficient... - rho0 = rho0_meam(a)*Z - -c ...unless we have unscreened second neighbors, in which case we -c add on the contribution from those (accounting for partial -c screening) - if (nn2_meam(a,a).eq.1) then - call get_Zij2(Z2,arat,scrn,lattce_meam(a,a), - $ Cmin_meam(a,a,a),Cmax_meam(a,a,a)) - rho0_2nn = rho0_meam(a)*fm_exp(-beta0_meam(a)*(arat-1)) - rho0 = rho0 + Z2*rho0_2nn*scrn - endif - - rho_ref_meam(a) = rho0*Gbar - - enddo - - return - end - -c----------------------------------------------------------------------c -c Shape factors for various configurations - subroutine get_shpfcn(s,latt) - implicit none - real*8 s(3) - character*3 latt - if (latt.eq.'fcc'.or.latt.eq.'bcc'. - $ or.latt.eq.'b1'.or.latt.eq.'b2') then - s(1) = 0.d0 - s(2) = 0.d0 - s(3) = 0.d0 - else if (latt.eq.'hcp') then - s(1) = 0.d0 - s(2) = 0.d0 - s(3) = 1.d0/3.d0 - else if (latt.eq.'dia') then - s(1) = 0.d0 - s(2) = 0.d0 - s(3) = 32.d0/9.d0 - else if (latt.eq.'dim') then - s(1) = 1.d0 - s(2) = 2.d0/3.d0 -c s(3) = 1.d0 - s(3) = 0.4d0 - else - s(1) = 0.0 -c call error('Lattice not defined in get_shpfcn.') - endif - return - end -c------------------------------------------------------------------------------c -c Average weighting factors for the reference structure - subroutine get_tavref(t11av,t21av,t31av,t12av,t22av,t32av, - $ t11,t21,t31,t12,t22,t32, - $ r,a,b,latt) - use meam_data - implicit none - real*8 t11av,t21av,t31av,t12av,t22av,t32av - real*8 t11,t21,t31,t12,t22,t32,r - integer a,b - character*3 latt - real*8 rhoa01,rhoa02,a1,a2,rho01,rho02 - -c For ialloy = 2, no averaging is done - if (ialloy.eq.2) then - t11av = t11 - t21av = t21 - t31av = t31 - t12av = t12 - t22av = t22 - t32av = t32 - else - if (latt.eq.'fcc'.or.latt.eq.'bcc'.or.latt.eq.'dia' - $ .or.latt.eq.'hcp'.or.latt.eq.'b1' - $ .or.latt.eq.'dim'.or.latt.eq.'b2') then -c all neighbors are of the opposite type - t11av = t12 - t21av = t22 - t31av = t32 - t12av = t11 - t22av = t21 - t32av = t31 - else - a1 = r/re_meam(a,a) - 1.d0 - a2 = r/re_meam(b,b) - 1.d0 - rhoa01 = rho0_meam(a)*fm_exp(-beta0_meam(a)*a1) - rhoa02 = rho0_meam(b)*fm_exp(-beta0_meam(b)*a2) - if (latt.eq.'l12') then - rho01 = 8*rhoa01 + 4*rhoa02 - t11av = (8*t11*rhoa01 + 4*t12*rhoa02)/rho01 - t12av = t11 - t21av = (8*t21*rhoa01 + 4*t22*rhoa02)/rho01 - t22av = t21 - t31av = (8*t31*rhoa01 + 4*t32*rhoa02)/rho01 - t32av = t31 - else -c call error('Lattice not defined in get_tavref.') - endif - endif - endif - return - end -c------------------------------------------------------------------------------c -c Number of neighbors for the reference structure - subroutine get_Zij(Zij,latt) - implicit none - integer Zij - character*3 latt - if (latt.eq.'fcc') then - Zij = 12 - else if (latt.eq.'bcc') then - Zij = 8 - else if (latt.eq.'hcp') then - Zij = 12 - else if (latt.eq.'b1') then - Zij = 6 - else if (latt.eq.'dia') then - Zij = 4 - else if (latt.eq.'dim') then - Zij = 1 - else if (latt.eq.'c11') then - Zij = 10 - else if (latt.eq.'l12') then - Zij = 12 - else if (latt.eq.'b2') then - Zij = 8 - else -c call error('Lattice not defined in get_Zij.') - endif - return - end - -c------------------------------------------------------------------------------c -c Zij2 = number of second neighbors, a = distance ratio R1/R2, and S = second -c neighbor screening function for lattice type "latt" - - subroutine get_Zij2(Zij2,a,S,latt,cmin,cmax) - implicit none - integer Zij2 - real*8 a,S,cmin,cmax - character*3 latt - real*8 rratio,C,x,sijk - integer numscr - - if (latt.eq.'bcc') then - Zij2 = 6 - a = 2.d0/sqrt(3.d0) - numscr = 4 - else if (latt.eq.'fcc') then - Zij2 = 6 - a = sqrt(2.d0) - numscr = 4 - else if (latt.eq.'dia') then - Zij2 = 12 - a = sqrt(8.d0/3.d0) - numscr = 1 - if (cmin.lt.0.500001) then -c call error('can not do 2NN MEAM for dia') - endif - else if (latt.eq.'hcp') then - Zij2 = 6 - a = sqrt(2.d0) - numscr = 4 - else if (latt.eq.'b1') then - Zij2 = 12 - a = sqrt(2.d0) - numscr = 2 - else if (latt.eq.'l12') then - Zij2 = 6 - a = sqrt(2.d0) - numscr = 4 - else if (latt.eq.'b2') then - Zij2 = 6 - a = 2.d0/sqrt(3.d0) - numscr = 4 - else if (latt.eq.'dim') then -c this really shouldn't be allowed; make sure screening is zero - Zij2 = 0 - a = 1 - S = 0 - return - else -c call error('Lattice not defined in get_Zij2.') - endif - -c Compute screening for each first neighbor - C = 4.d0/(a*a) - 1.d0 - x = (C-cmin)/(cmax-cmin) - call fcut(x,sijk) -c There are numscr first neighbors screening the second neighbors - S = sijk**numscr - - return - end - - -c------------------------------------------------------------------------------c - subroutine get_sijk(C,i,j,k,sijk) - use meam_data - implicit none - real*8 C,sijk - integer i,j,k - real*8 x - x = (C-Cmin_meam(i,j,k))/(Cmax_meam(i,j,k)-Cmin_meam(i,j,k)) - call fcut(x,sijk) - return - end - -c------------------------------------------------------------------------------c -c Calculate density functions, assuming reference configuration - subroutine get_densref(r,a,b,rho01,rho11,rho21,rho31, - $ rho02,rho12,rho22,rho32) - use meam_data - implicit none - real*8 r,rho01,rho11,rho21,rho31,rho02,rho12,rho22,rho32 - real*8 a1,a2 - real*8 rhoa01,rhoa11,rhoa21,rhoa31,rhoa02,rhoa12,rhoa22,rhoa32 - real*8 s(3) - character*3 lat - integer a,b - integer Zij1nn,Zij2nn - real*8 rhoa01nn,rhoa02nn - real*8 arat,scrn,denom - real*8 C,s111,s112,s221,S11,S22 - - a1 = r/re_meam(a,a) - 1.d0 - a2 = r/re_meam(b,b) - 1.d0 - - rhoa01 = rho0_meam(a)*fm_exp(-beta0_meam(a)*a1) - rhoa11 = rho0_meam(a)*fm_exp(-beta1_meam(a)*a1) - rhoa21 = rho0_meam(a)*fm_exp(-beta2_meam(a)*a1) - rhoa31 = rho0_meam(a)*fm_exp(-beta3_meam(a)*a1) - rhoa02 = rho0_meam(b)*fm_exp(-beta0_meam(b)*a2) - rhoa12 = rho0_meam(b)*fm_exp(-beta1_meam(b)*a2) - rhoa22 = rho0_meam(b)*fm_exp(-beta2_meam(b)*a2) - rhoa32 = rho0_meam(b)*fm_exp(-beta3_meam(b)*a2) - - lat = lattce_meam(a,b) - - rho11 = 0.d0 - rho21 = 0.d0 - rho31 = 0.d0 - rho12 = 0.d0 - rho22 = 0.d0 - rho32 = 0.d0 - - call get_Zij(Zij1nn,lat) - - if (lat.eq.'fcc') then - rho01 = 12.d0*rhoa02 - rho02 = 12.d0*rhoa01 - else if (lat.eq.'bcc') then - rho01 = 8.d0*rhoa02 - rho02 = 8.d0*rhoa01 - else if (lat.eq.'b1') then - rho01 = 6*rhoa02 - rho02 = 6*rhoa01 - else if (lat.eq.'dia') then - rho01 = 4*rhoa02 - rho02 = 4*rhoa01 - rho31 = 32.d0/9.d0*rhoa32*rhoa32 - rho32 = 32.d0/9.d0*rhoa31*rhoa31 - else if (lat.eq.'hcp') then - rho01 = 12*rhoa02 - rho02 = 12*rhoa01 - rho31 = 1.d0/3.d0*rhoa32*rhoa32 - rho32 = 1.d0/3.d0*rhoa31*rhoa31 - else if (lat.eq.'dim') then - call get_shpfcn(s,'dim') - rho01 = rhoa02 - rho02 = rhoa01 - rho11 = s(1)*rhoa12*rhoa12 - rho12 = s(1)*rhoa11*rhoa11 - rho21 = s(2)*rhoa22*rhoa22 - rho22 = s(2)*rhoa21*rhoa21 - rho31 = s(3)*rhoa32*rhoa32 - rho32 = s(3)*rhoa31*rhoa31 - else if (lat.eq.'c11') then - rho01 = rhoa01 - rho02 = rhoa02 - rho11 = rhoa11 - rho12 = rhoa12 - rho21 = rhoa21 - rho22 = rhoa22 - rho31 = rhoa31 - rho32 = rhoa32 - else if (lat.eq.'l12') then - rho01 = 8*rhoa01 + 4*rhoa02 - rho02 = 12*rhoa01 - if (ialloy.eq.1) then - rho21 = 8./3.*(rhoa21*t2_meam(a)-rhoa22*t2_meam(b))**2 - denom = 8*rhoa01*t2_meam(a)**2 + 4*rhoa02*t2_meam(b)**2 - if (denom.gt.0.) then - rho21 = rho21/denom * rho01 - endif - else - rho21 = 8./3.*(rhoa21-rhoa22)*(rhoa21-rhoa22) - endif - else if (lat.eq.'b2') then - rho01 = 8.d0*rhoa02 - rho02 = 8.d0*rhoa01 - else -c call error('Lattice not defined in get_densref.') - endif - - if (nn2_meam(a,b).eq.1) then - - call get_Zij2(Zij2nn,arat,scrn,lat, - $ Cmin_meam(a,a,b),Cmax_meam(a,a,b)) - - a1 = arat*r/re_meam(a,a) - 1.d0 - a2 = arat*r/re_meam(b,b) - 1.d0 - - rhoa01nn = rho0_meam(a)*fm_exp(-beta0_meam(a)*a1) - rhoa02nn = rho0_meam(b)*fm_exp(-beta0_meam(b)*a2) - - if (lat.eq.'l12') then -c As usual, L12 thinks it's special; we need to be careful computing -c the screening functions - C = 1.d0 - call get_sijk(C,a,a,a,s111) - call get_sijk(C,a,a,b,s112) - call get_sijk(C,b,b,a,s221) - S11 = s111 * s111 * s112 * s112 - S22 = s221**4 - rho01 = rho01 + 6*S11*rhoa01nn - rho02 = rho02 + 6*S22*rhoa02nn - - else -c For other cases, assume that second neighbor is of same type, -c first neighbor may be of different type - - rho01 = rho01 + Zij2nn*scrn*rhoa01nn - -c Assume Zij2nn and arat don't depend on order, but scrn might - call get_Zij2(Zij2nn,arat,scrn,lat, - $ Cmin_meam(b,b,a),Cmax_meam(b,b,a)) - rho02 = rho02 + Zij2nn*scrn*rhoa02nn - - endif - - endif - - return - end - -c--------------------------------------------------------------------- -c Compute ZBL potential -c - real*8 function zbl(r,z1,z2) - use meam_data , only : fm_exp - implicit none - integer i,z1,z2 - real*8 r,c,d,a,azero,cc,x - dimension c(4),d(4) - data c /0.028171,0.28022,0.50986,0.18175/ - data d /0.20162,0.40290,0.94229,3.1998/ - data azero /0.4685/ - data cc /14.3997/ -c azero = (9pi^2/128)^1/3 (0.529) Angstroms - a = azero/(z1**0.23+z2**0.23) - zbl = 0.0 - x = r/a - do i=1,4 - zbl = zbl + c(i)*fm_exp(-d(i)*x) - enddo - if (r.gt.0.d0) zbl = zbl*z1*z2/r*cc - return - end - -c--------------------------------------------------------------------- -c Compute Rose energy function, I.16 -c - real*8 function erose(r,re,alpha,Ec,repuls,attrac,form) - use meam_data , only : fm_exp - implicit none - real*8 r,re,alpha,Ec,repuls,attrac,astar,a3 - integer form - - erose = 0.d0 - - if (r.gt.0.d0) then - astar = alpha * (r/re - 1.d0) - a3 = 0.d0 - if (astar.ge.0) then - a3 = attrac - else if (astar.lt.0) then - a3 = repuls - endif - if (form.eq.1) then - erose = -Ec*(1+astar+(-attrac+repuls/r)* - $ (astar**3))*fm_exp(-astar) - else if (form.eq.2) then - erose = -Ec * (1 +astar + a3*(astar**3))*fm_exp(-astar) - else - erose = -Ec * (1+ astar + a3*(astar**3)/(r/re))*fm_exp(-astar) - endif - endif - - return - end - -c ----------------------------------------------------------------------- - - subroutine interpolate_meam(ind) - use meam_data - implicit none - - integer j,ind - real*8 drar - -c map to coefficient space - - nrar = nr - drar = dr - rdrar = 1.0D0/drar - -c phir interp - do j = 1,nrar - phirar(j,ind) = phir(j,ind) - enddo - - phirar1(1,ind) = phirar(2,ind)-phirar(1,ind) - phirar1(2,ind) = 0.5D0*(phirar(3,ind)-phirar(1,ind)) - phirar1(nrar-1,ind) = 0.5D0*(phirar(nrar,ind) - $ -phirar(nrar-2,ind)) - phirar1(nrar,ind) = 0.0D0 - do j = 3,nrar-2 - phirar1(j,ind) = ((phirar(j-2,ind)-phirar(j+2,ind)) + - $ 8.0D0*(phirar(j+1,ind)-phirar(j-1,ind)))/12. - enddo - - do j = 1,nrar-1 - phirar2(j,ind) = 3.0D0*(phirar(j+1,ind)-phirar(j,ind)) - - $ 2.0D0*phirar1(j,ind) - phirar1(j+1,ind) - phirar3(j,ind) = phirar1(j,ind) + phirar1(j+1,ind) - - $ 2.0D0*(phirar(j+1,ind)-phirar(j,ind)) - enddo - phirar2(nrar,ind) = 0.0D0 - phirar3(nrar,ind) = 0.0D0 - - do j = 1,nrar - phirar4(j,ind) = phirar1(j,ind)/drar - phirar5(j,ind) = 2.0D0*phirar2(j,ind)/drar - phirar6(j,ind) = 3.0D0*phirar3(j,ind)/drar - enddo - - end - -c--------------------------------------------------------------------- -c Compute Rose energy function, I.16 -c - real*8 function compute_phi(rij, elti, eltj) - use meam_data - implicit none - - real*8 rij, pp - integer elti, eltj, ind, kk - - ind = eltind(elti, eltj) - pp = rij*rdrar + 1.0D0 - kk = pp - kk = min(kk,nrar-1) - pp = pp - kk - pp = min(pp,1.0D0) - compute_phi = ((phirar3(kk,ind)*pp + phirar2(kk,ind))*pp - $ + phirar1(kk,ind))*pp + phirar(kk,ind) - - return - end diff --git a/lib/meam/meam_setup_global.F b/lib/meam/meam_setup_global.F deleted file mode 100644 index d11dec5a4a..0000000000 --- a/lib/meam/meam_setup_global.F +++ /dev/null @@ -1,111 +0,0 @@ -c -c declaration in pair_meam.h: -c -c void meam_setup_global(int *, int *, double *, int *, double *, double *, -c double *, double *, double *, double *, double *, -c double *, double *, double *, double *, double *, -c double *, double *, int *); -c -c call in pair_meam.cpp: -c -c meam_setup_global(&nelements,lat,z,ielement,atwt,alpha,b0,b1,b2,b3, -c alat,esub,asub,t0,t1,t2,t3,rozero,ibar); -c -c - - subroutine meam_setup_global(nelt, lat, z, ielement, atwt, alpha, - $ b0, b1, b2, b3, alat, esub, asub, - $ t0, t1, t2, t3, rozero, ibar) - - use meam_data - implicit none - - integer nelt, lat, ielement, ibar - real*8 z, atwt, alpha, b0, b1, b2, b3 - real*8 alat, esub, asub, t0, t1, t2, t3 - real*8 rozero - - dimension lat(nelt), ielement(nelt), ibar(nelt) - dimension z(nelt), atwt(nelt), alpha(nelt) - dimension b0(nelt), b1(nelt), b2(nelt), b3(nelt) - dimension alat(nelt), esub(nelt), asub(nelt) - dimension t0(nelt), t1(nelt), t2(nelt), t3(nelt), rozero(nelt) - - integer i - real*8 tmplat(maxelt) - - neltypes = nelt - - do i = 1,nelt - - if (lat(i).eq.0) then - lattce_meam(i,i) = 'fcc' - else if (lat(i).eq.1) then - lattce_meam(i,i) = 'bcc' - else if (lat(i).eq.2) then - lattce_meam(i,i) = 'hcp' - else if (lat(i).eq.3) then - lattce_meam(i,i) = 'dim' - else if (lat(i).eq.4) then - lattce_meam(i,i) = 'dia' - else -c unknown - endif - - Z_meam(i) = z(i) - ielt_meam(i) = ielement(i) - alpha_meam(i,i) = alpha(i) - beta0_meam(i) = b0(i) - beta1_meam(i) = b1(i) - beta2_meam(i) = b2(i) - beta3_meam(i) = b3(i) - tmplat(i) = alat(i) - Ec_meam(i,i) = esub(i) - A_meam(i) = asub(i) - t0_meam(i) = t0(i) - t1_meam(i) = t1(i) - t2_meam(i) = t2(i) - t3_meam(i) = t3(i) - rho0_meam(i) = rozero(i) - ibar_meam(i) = ibar(i) - - if (lattce_meam(i,i).eq.'fcc') then - re_meam(i,i) = tmplat(i)/sqrt(2.d0) - elseif (lattce_meam(i,i).eq.'bcc') then - re_meam(i,i) = tmplat(i)*sqrt(3.d0)/2.d0 - elseif (lattce_meam(i,i).eq.'hcp') then - re_meam(i,i) = tmplat(i) - elseif (lattce_meam(i,i).eq.'dim') then - re_meam(i,i) = tmplat(i) - elseif (lattce_meam(i,i).eq.'dia') then - re_meam(i,i) = tmplat(i)*sqrt(3.d0)/4.d0 - else -c error - endif - - enddo - - -c Set some defaults - rc_meam = 4.0 - delr_meam = 0.1 - attrac_meam(:,:) = 0.0 - repuls_meam(:,:) = 0.0 - Cmax_meam(:,:,:) = 2.8 - Cmin_meam(:,:,:) = 2.0 - ebound_meam(:,:) = (2.8d0**2)/(4.d0*(2.8d0-1.d0)) - delta_meam(:,:) = 0.0 - nn2_meam(:,:) = 0 - zbl_meam(:,:) = 1 - gsmooth_factor = 99.0 - augt1 = 1 - ialloy = 0 - mix_ref_t = 0 - emb_lin_neg = 0 - bkgd_dyn = 0 - erose_form = 0 - - return - end - - diff --git a/lib/meam/meam_setup_param.F b/lib/meam/meam_setup_param.F deleted file mode 100644 index cfe7430285..0000000000 --- a/lib/meam/meam_setup_param.F +++ /dev/null @@ -1,204 +0,0 @@ -c -c do a sanity check on index parameters - subroutine meam_checkindex(num,lim,nidx,idx,ierr) - implicit none - integer i,num,lim,nidx,idx(3),ierr - - ierr = 0 - if (nidx.lt.num) then - ierr = 2 - return - endif - - do i=1,num - if ((idx(i).lt.1).or.(idx(i).gt.lim)) then - ierr = 3 - return - endif - enddo - end - -c -c Declaration in pair_meam.h: -c -c void meam_setup_param(int *, double *, int *, int *, int *); -c -c Call in pair_meam.cpp -c -c meam_setup_param(&which,&value,&nindex,index,&errorflag); -c -c -c -c The "which" argument corresponds to the index of the "keyword" array -c in pair_meam.cpp: -c -c 0 = Ec_meam -c 1 = alpha_meam -c 2 = rho0_meam -c 3 = delta_meam -c 4 = lattce_meam -c 5 = attrac_meam -c 6 = repuls_meam -c 7 = nn2_meam -c 8 = Cmin_meam -c 9 = Cmax_meam -c 10 = rc_meam -c 11 = delr_meam -c 12 = augt1 -c 13 = gsmooth_factor -c 14 = re_meam -c 15 = ialloy -c 16 = mixture_ref_t -c 17 = erose_form -c 18 = zbl_meam -c 19 = emb_lin_neg -c 20 = bkgd_dyn - - subroutine meam_setup_param(which, value, nindex, - $ index, errorflag) - - use meam_data - implicit none - - integer which, nindex, index(3), errorflag - real*8 value - integer i1, i2 - - errorflag = 0 - -c 0 = Ec_meam - if (which.eq.0) then - call meam_checkindex(2,maxelt,nindex,index,errorflag) - if (errorflag.ne.0) return - Ec_meam(index(1),index(2)) = value - -c 1 = alpha_meam - else if (which.eq.1) then - call meam_checkindex(2,maxelt,nindex,index,errorflag) - if (errorflag.ne.0) return - alpha_meam(index(1),index(2)) = value - -c 2 = rho0_meam - else if (which.eq.2) then - call meam_checkindex(1,maxelt,nindex,index,errorflag) - if (errorflag.ne.0) return - rho0_meam(index(1)) = value - -c 3 = delta_meam - else if (which.eq.3) then - call meam_checkindex(2,maxelt,nindex,index,errorflag) - if (errorflag.ne.0) return - delta_meam(index(1),index(2)) = value - -c 4 = lattce_meam - else if (which.eq.4) then - call meam_checkindex(2,maxelt,nindex,index,errorflag) - if (errorflag.ne.0) return - if (value.eq.0) then - lattce_meam(index(1),index(2)) = "fcc" - else if (value.eq.1) then - lattce_meam(index(1),index(2)) = "bcc" - else if (value.eq.2) then - lattce_meam(index(1),index(2)) = "hcp" - else if (value.eq.3) then - lattce_meam(index(1),index(2)) = "dim" - else if (value.eq.4) then - lattce_meam(index(1),index(2)) = "dia" - else if (value.eq.5) then - lattce_meam(index(1),index(2)) = 'b1' - else if (value.eq.6) then - lattce_meam(index(1),index(2)) = 'c11' - else if (value.eq.7) then - lattce_meam(index(1),index(2)) = 'l12' - else if (value.eq.8) then - lattce_meam(index(1),index(2)) = 'b2' - endif - -c 5 = attrac_meam - else if (which.eq.5) then - call meam_checkindex(2,maxelt,nindex,index,errorflag) - if (errorflag.ne.0) return - attrac_meam(index(1),index(2)) = value - -c 6 = repuls_meam - else if (which.eq.6) then - call meam_checkindex(2,maxelt,nindex,index,errorflag) - if (errorflag.ne.0) return - repuls_meam(index(1),index(2)) = value - -c 7 = nn2_meam - else if (which.eq.7) then - call meam_checkindex(2,maxelt,nindex,index,errorflag) - if (errorflag.ne.0) return - i1 = min(index(1),index(2)) - i2 = max(index(1),index(2)) - nn2_meam(i1,i2) = value - -c 8 = Cmin_meam - else if (which.eq.8) then - call meam_checkindex(3,maxelt,nindex,index,errorflag) - if (errorflag.ne.0) return - Cmin_meam(index(1),index(2),index(3)) = value - -c 9 = Cmax_meam - else if (which.eq.9) then - call meam_checkindex(3,maxelt,nindex,index,errorflag) - if (errorflag.ne.0) return - Cmax_meam(index(1),index(2),index(3)) = value - -c 10 = rc_meam - else if (which.eq.10) then - rc_meam = value - -c 11 = delr_meam - else if (which.eq.11) then - delr_meam = value - -c 12 = augt1 - else if (which.eq.12) then - augt1 = value - -c 13 = gsmooth - else if (which.eq.13) then - gsmooth_factor = value - -c 14 = re_meam - else if (which.eq.14) then - call meam_checkindex(2,maxelt,nindex,index,errorflag) - if (errorflag.ne.0) return - re_meam(index(1),index(2)) = value - -c 15 = ialloy - else if (which.eq.15) then - ialloy = value - -c 16 = mixture_ref_t - else if (which.eq.16) then - mix_ref_t = value - -c 17 = erose_form - else if (which.eq.17) then - erose_form = value - -c 18 = zbl_meam - else if (which.eq.18) then - call meam_checkindex(2,maxelt,nindex,index,errorflag) - if (errorflag.ne.0) return - i1 = min(index(1),index(2)) - i2 = max(index(1),index(2)) - zbl_meam(i1,i2) = value - -c 19 = emb_lin_neg - else if (which.eq.19) then - emb_lin_neg = value - -c 20 = bkgd_dyn - else if (which.eq.20) then - bkgd_dyn = value - - else - errorflag = 1 - endif - - return - end diff --git a/lib/reax/Install.py b/lib/reax/Install.py deleted file mode 120000 index ffe709d44c..0000000000 --- a/lib/reax/Install.py +++ /dev/null @@ -1 +0,0 @@ -../Install.py \ No newline at end of file diff --git a/lib/reax/Makefile.g95 b/lib/reax/Makefile.g95 deleted file mode 100644 index 55c40daa00..0000000000 --- a/lib/reax/Makefile.g95 +++ /dev/null @@ -1,51 +0,0 @@ -# * -# *_________________________________________________________________________* -# * Fortran Library for Reactive Force Field * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * CONTRIBUTING AUTHORS: Hansohl Cho(MIT), Aidan Thompson(SNL) * -# * and Greg Wagner(SNL) * -# * CONTACT: hansohl@mit.edu, athompson@sandia.gov, gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.gfortran - -# ------ FILES ------ - -SRC = reax_connect.F reax_inout.F reax_lammps.F reax_poten.F reax_reac.F reax_charges.F - -HEADERFILES = reax_defs.h *.blk - -# ------ DEFINITIONS ------ - -LIB = libreax.a -OBJ = $(SRC:.F=.o) - -# ------ SETTINGS ------ - -F90 = g95 -F90FLAGS = -O -fPIC -ARCHIVE = ar -ARCHFLAG = -rc -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F $(HEADERFILES) - $(F90) $(F90FLAGS) -c $< - -# ------ CLEAN ------ - -clean: - -rm *.o $(LIB) diff --git a/lib/reax/Makefile.gfortran b/lib/reax/Makefile.gfortran deleted file mode 100644 index ab42301688..0000000000 --- a/lib/reax/Makefile.gfortran +++ /dev/null @@ -1,51 +0,0 @@ -# * -# *_________________________________________________________________________* -# * Fortran Library for Reactive Force Field * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * CONTRIBUTING AUTHORS: Hansohl Cho(MIT), Aidan Thompson(SNL) * -# * and Greg Wagner(SNL) * -# * CONTACT: hansohl@mit.edu, athompson@sandia.gov, gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.gfortran - -# ------ FILES ------ - -SRC = reax_connect.F reax_inout.F reax_lammps.F reax_poten.F reax_reac.F reax_charges.F - -HEADERFILES = reax_defs.h *.blk - -# ------ DEFINITIONS ------ - -LIB = libreax.a -OBJ = $(SRC:.F=.o) - -# ------ SETTINGS ------ - -F90 = gfortran -F90FLAGS = -O3 -fPIC -fno-second-underscore -ARCHIVE = ar -ARCHFLAG = -rc -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F $(HEADERFILES) - $(F90) $(F90FLAGS) -c $< - -# ------ CLEAN ------ - -clean: - -rm *.o $(LIB) diff --git a/lib/reax/Makefile.ifort b/lib/reax/Makefile.ifort deleted file mode 100644 index 1760cb9c6a..0000000000 --- a/lib/reax/Makefile.ifort +++ /dev/null @@ -1,51 +0,0 @@ -# * -# *_________________________________________________________________________* -# * Fortran Library for Reactive Force Field * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * CONTRIBUTING AUTHORS: Hansohl Cho(MIT), Aidan Thompson(SNL) * -# * and Greg Wagner(SNL) * -# * CONTACT: hansohl@mit.edu, athompson@sandia.gov, gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.ifort - -# ------ FILES ------ - -SRC = reax_connect.F reax_inout.F reax_lammps.F reax_poten.F reax_reac.F reax_charges.F - -HEADERFILES = reax_defs.h *.blk - -# ------ DEFINITIONS ------ - -LIB = libreax.a -OBJ = $(SRC:.F=.o) - -# ------ SETTINGS ------ - -F90 = ifort -F90FLAGS = -O -fPIC -ARCHIVE = ar -ARCHFLAG = -rc -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F $(HEADERFILES) - $(F90) $(F90FLAGS) -c $< - -# ------ CLEAN ------ - -clean: - -rm *.o $(LIB) diff --git a/lib/reax/Makefile.lammps.empty b/lib/reax/Makefile.lammps.empty deleted file mode 100644 index 758755f3c8..0000000000 --- a/lib/reax/Makefile.lammps.empty +++ /dev/null @@ -1,5 +0,0 @@ -# Settings that the LAMMPS build will import when this package library is used - -reax_SYSINC = -reax_SYSLIB = -reax_SYSPATH = diff --git a/lib/reax/Makefile.lammps.gfortran b/lib/reax/Makefile.lammps.gfortran deleted file mode 100644 index f5da63bc38..0000000000 --- a/lib/reax/Makefile.lammps.gfortran +++ /dev/null @@ -1,5 +0,0 @@ -# Settings that the LAMMPS build will import when this package library is used - -reax_SYSINC = -reax_SYSLIB = -lgfortran -reax_SYSPATH = diff --git a/lib/reax/Makefile.lammps.ifort b/lib/reax/Makefile.lammps.ifort deleted file mode 100644 index 69ac12606d..0000000000 --- a/lib/reax/Makefile.lammps.ifort +++ /dev/null @@ -1,6 +0,0 @@ -# Settings that the LAMMPS build will import when this package library is used - -reax_SYSINC = -reax_SYSLIB = -lifcore -reax_SYSPATH = - diff --git a/lib/reax/Makefile.mpi b/lib/reax/Makefile.mpi deleted file mode 100644 index 142f7e9bc6..0000000000 --- a/lib/reax/Makefile.mpi +++ /dev/null @@ -1,51 +0,0 @@ -# * -# *_________________________________________________________________________* -# * Fortran Library for Reactive Force Field * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * CONTRIBUTING AUTHORS: Hansohl Cho(MIT), Aidan Thompson(SNL) * -# * and Greg Wagner(SNL) * -# * CONTACT: hansohl@mit.edu, athompson@sandia.gov, gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.empty - -# ------ FILES ------ - -SRC = reax_connect.F reax_inout.F reax_lammps.F reax_poten.F reax_reac.F reax_charges.F - -HEADERFILES = reax_defs.h *.blk - -# ------ DEFINITIONS ------ - -LIB = libreax.a -OBJ = $(SRC:.F=.o) - -# ------ SETTINGS ------ - -F90 = mpifort -F90FLAGS = -O3 -fPIC -ARCHIVE = ar -ARCHFLAG = -rc -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F $(HEADERFILES) - $(F90) $(F90FLAGS) -c $< - -# ------ CLEAN ------ - -clean: - -rm *.o $(LIB) diff --git a/lib/reax/Makefile.pgf90 b/lib/reax/Makefile.pgf90 deleted file mode 100644 index dfc17eca11..0000000000 --- a/lib/reax/Makefile.pgf90 +++ /dev/null @@ -1,51 +0,0 @@ -# * -# *_________________________________________________________________________* -# * Fortran Library for Reactive Force Field * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * CONTRIBUTING AUTHORS: Hansohl Cho(MIT), Aidan Thompson(SNL) * -# * and Greg Wagner(SNL) * -# * CONTACT: hansohl@mit.edu, athompson@sandia.gov, gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.pgf90 - -# ------ FILES ------ - -SRC = reax_connect.F reax_inout.F reax_lammps.F reax_poten.F reax_reac.F reax_charges.F - -HEADERFILES = reax_defs.h *.blk - -# ------ DEFINITIONS ------ - -LIB = libreax.a -OBJ = $(SRC:.F=.o) - -# ------ SETTINGS ------ - -F90 = pgf90 -F90FLAGS = -O -fPIC -ARCHIVE = ar -ARCHFLAG = -rc -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F $(HEADERFILES) - $(F90) $(F90FLAGS) -c $< - -# ------ CLEAN ------ - -clean: - -rm *.o $(LIB) diff --git a/lib/reax/Makefile.redsky b/lib/reax/Makefile.redsky deleted file mode 100644 index f51a15d1f1..0000000000 --- a/lib/reax/Makefile.redsky +++ /dev/null @@ -1,51 +0,0 @@ -# * -# *_________________________________________________________________________* -# * Fortran Library for Reactive Force Field * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * CONTRIBUTING AUTHORS: Hansohl Cho(MIT), Aidan Thompson(SNL) * -# * and Greg Wagner(SNL) * -# * CONTACT: hansohl@mit.edu, athompson@sandia.gov, gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.ifort - -# ------ FILES ------ - -SRC = reax_connect.F reax_inout.F reax_lammps.F reax_poten.F reax_reac.F reax_charges.F - -HEADERFILES = reax_defs.h *.blk - -# ------ DEFINITIONS ------ - -LIB = libreax.a -OBJ = $(SRC:.F=.o) - -# ------ SETTINGS ------ - -F90 = mpif90 -F90FLAGS = -O -fPIC -ARCHIVE = ar -ARCHFLAG = -rc -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F $(HEADERFILES) - $(F90) $(F90FLAGS) -c $< - -# ------ CLEAN ------ - -clean: - -rm *.o $(LIB) diff --git a/lib/reax/Makefile.serial b/lib/reax/Makefile.serial deleted file mode 120000 index c52fbcb986..0000000000 --- a/lib/reax/Makefile.serial +++ /dev/null @@ -1 +0,0 @@ -Makefile.gfortran \ No newline at end of file diff --git a/lib/reax/Makefile.tbird b/lib/reax/Makefile.tbird deleted file mode 100644 index f51a15d1f1..0000000000 --- a/lib/reax/Makefile.tbird +++ /dev/null @@ -1,51 +0,0 @@ -# * -# *_________________________________________________________________________* -# * Fortran Library for Reactive Force Field * -# * DESCRIPTION: SEE READ-ME * -# * FILE NAME: Makefile * -# * CONTRIBUTING AUTHORS: Hansohl Cho(MIT), Aidan Thompson(SNL) * -# * and Greg Wagner(SNL) * -# * CONTACT: hansohl@mit.edu, athompson@sandia.gov, gjwagne@sandia.gov * -# *_________________________________________________________________________*/ - -SHELL = /bin/sh - -# which file will be copied to Makefile.lammps - -EXTRAMAKE = Makefile.lammps.ifort - -# ------ FILES ------ - -SRC = reax_connect.F reax_inout.F reax_lammps.F reax_poten.F reax_reac.F reax_charges.F - -HEADERFILES = reax_defs.h *.blk - -# ------ DEFINITIONS ------ - -LIB = libreax.a -OBJ = $(SRC:.F=.o) - -# ------ SETTINGS ------ - -F90 = mpif90 -F90FLAGS = -O -fPIC -ARCHIVE = ar -ARCHFLAG = -rc -USRLIB = -SYSLIB = - -# ------ MAKE PROCEDURE ------ - -lib: $(OBJ) - $(ARCHIVE) $(ARFLAGS) $(LIB) $(OBJ) - @cp $(EXTRAMAKE) Makefile.lammps - -# ------ COMPILE RULES ------ - -%.o:%.F $(HEADERFILES) - $(F90) $(F90FLAGS) -c $< - -# ------ CLEAN ------ - -clean: - -rm *.o $(LIB) diff --git a/lib/reax/README b/lib/reax/README deleted file mode 100644 index f21a470618..0000000000 --- a/lib/reax/README +++ /dev/null @@ -1,78 +0,0 @@ -ReaxFF library - -Aidan Thompson, Sandia National Labs -athomps at sandia.gov -Jan 2008 - -This library is an implementation of the ReaxFF potential, -specifically designed to work with LAMMPS. It is derived from Adri van -Duin's original serial code, with intervening incarnations in CMDF and -GRASP. - -------------------------------------------------- - -This directory has source files to build a library that LAMMPS -links against when using the REAX package. - -This library must be built with a F90 compiler, before LAMMPS is -built, so LAMMPS can link against it. - -You can type "make lib-reax" from the src directory to see help on how -to build this library via make commands, or you can do the same thing -by typing "python Install.py" from within this directory, or you can -do it manually by following the instructions below. - -Build the library using one of the provided Makefile.* files or create -your own, specific to your compiler and system. For example: - -make -f Makefile.gfortran - -When you are done building this library, two files should -exist in this directory: - -libreax.a the library LAMMPS will link against -Makefile.lammps settings the LAMMPS Makefile will import - -Makefile.lammps is created by the make command, by copying one of the -Makefile.lammps.* files. See the EXTRAMAKE setting at the top of the -Makefile.* files. - -IMPORTANT: You must examine the final Makefile.lammps to insure it is -correct for your system, else the LAMMPS build will likely fail. - -Makefile.lammps has settings for 3 variables: - -user-reax_SYSINC = leave blank for this package -user-reax_SYSLIB = auxiliary F90 libs needed to link a F90 lib with - a C++ program (LAMMPS) via a C++ compiler -user-reax_SYSPATH = path(s) to where those libraries are - -Because you have a F90 compiler on your system, you should have these -libraries. But you will have to figure out which ones are needed and -where they are. Examples of common configurations are in the -Makefile.lammps.* files. - -------------------------------------------------- - -Additional build notes: - -The include file reax_defs.h is used by both the ReaxFF library source -files and the LAMMPS pair_reax.cpp source file (in package src/REAX). -It contains dimensions of statically-allocated arrays created by the -ReaxFF library. The size of these arrays must be set small enough to -avoid exceeding the available machine memory, and large enough to fit -the actual data generated by ReaxFF. If you change the values in -reax_defs.h, you must first rebuild the library and then rebuild -LAMMPS. - -This library is called by functions in pair_reax.cpp. The C++ to -FORTRAN function calls in pair_reax.cpp assume that FORTRAN object -names are converted to C object names by appending an underscore -character. This is generally the case, but on machines that do not -conform to this convention, you will need to modify either the C++ -code or your compiler settings. The name conversion is handled by the -preprocessor macro called FORTRAN in the file pair_reax_fortran.h, -which is included by pair_reax.cpp. Different definitions of this -macro can be obtained by adding a machine-specific macro definition to -the CCFLAGS variable in your your LAMMPS Makefile e.g. -D_IBM. See -pair_reax_fortran.h for more info. diff --git a/lib/reax/cbka.blk b/lib/reax/cbka.blk deleted file mode 100644 index 4dbe0a36c6..0000000000 --- a/lib/reax/cbka.blk +++ /dev/null @@ -1,116 +0,0 @@ -#include "reax_defs.h" - implicit real*8 (a-h,o-z),integer(i-n) - parameter (nneighmax=NNEIGHMAXDEF) - parameter (nat=NATDEF) !Max number of atoms - parameter (nattot=NATTOTDEF) !Max number of global atoms - parameter (nsort=NSORTDEF) !Max number of atom types - parameter (mbond=MBONDDEF) !Max number of bonds connected to one atom - parameter (na1mx3=3*nat) !3*max number of atoms - parameter (navib=NAVIBDEF) !for 2nd derivatives - parameter (nbotym=NBOTYMDEF) !Max number of bond types - parameter (nvatym=NVATYMDEF) !Max number of valency angle types - parameter (ntotym=NTOTYMDEF) !Max number of torsion angle types - parameter (nhbtym=NHBTYMDEF) !Max number of hydrogen bond types - parameter (nodmtym=NODMTYMDEF) !Max number of off-diagonal Morse types - parameter (nboallmax=NBOALLMAXDEF) !Max number of all bonds - parameter (nbomax=NBOMAXDEF) !Max number of bonds - parameter (nhbmax=NHBMAXDEF) !Max number of hydrogen bonds - parameter (nvamax=NVAMAXDEF) !Max number of valency angles - parameter (nopmax=NOPMAXDEF) !Max number of out of plane angles - parameter (ntomax=NTOMAXDEF) !Max number of torsion angles - parameter (npamax=NPAMAXDEF) !Max number of general parameters in force field - parameter (nmolmax=NMOLMAXDEF) !Max number of molecules in system - parameter (nmolset=NMOLSETDEF) !Max number of molecules in training set - parameter (mrestra=MRESTRADEF) !Max number of restraints - parameter (mtreg=MTREGDEF) !Max number of temperature regimes - parameter (mtzone=MTZONEDEF) !Max number of temperature zones - parameter (mvreg=MVREGDEF) !Max number of volume regimes - parameter (mvzone=MVZONEDEF) !Max number of volume zones - parameter (mereg=MEREGDEF) !Max number of electric field regimes - parameter (mezone=MEZONEDEF) !Max number of electric field zones - character*1 qr,qrset,qresi2 - character*2 qaset,qadd - character*3 qresi1 - character*5 qlabel,qffty,qbgfaxes,qbgfsgn,qresi3 - character*20 qkeyw - character*25 qfile - character*40 qffield,qformat,qstrana2 - character*60 qremark,qremset,qmolset - character*200 qstrana1 - common - $/cbka/ dhbdc(nhbmax,3,3),cp(nat,3), - $ cadd(nat,3),d2(3*navib,3*navib), - $ veladd(3,nat), - $ aold(3,nat),dic(3,nat),pvdw1(nsort,nsort), - $ pvdw2(nsort,nsort),angimp(nat,6), - $ yt(na1mx3),pt(na1mx3),gi(na1mx3),enmolset(nmolset), - $ ai(na1mx3),bi(na1mx3),yi(na1mx3),pn(na1mx3),tbo(nat), - $ chgbgf(nattot), - $ abo2(nat),bor4(nat),bos(nbomax), - $ eldef(nat),vradic(nat), - $ vmo2(nat), - $ ro(nbomax),dbondr(nbomax), - $ dbosidr(nbomax),thgo(nopmax), - $ elmol(nmolmax), - $ elaf(nsort),vpq(nsort), - $ rvdw(nsort),alf(nsort),eps(nsort),chat(nsort), - $ rcore(nsort,nsort),ecore(nsort,nsort),acore(nsort,nsort), - $ vlp2(nsort), - $ valp2(nsort),vincr(nsort), - $ vval3(nsort), - $ vuncor(nbotym), - $ vop(nsort), - $ sigqeq(nsort), - $ rrcha(mrestra), - $ rmstra3(mrestra), - $ rmcha(mrestra), - $ rtcha(mrestra),rvcha(mrestra), - $ v2bo(ntotym),v3bo(ntotym), - $ eel,fctor,elr, - $ presx2,presy2,presz2, - $ tset2, - $ enmol,formol,vvol,tpnrad, - $ delvib, - $ taut2,tincr,xmasmd, - $ gdicmax,parc1,parc2,sumelec, - $ xinh,fsnh,vqnh,snh,ham,errnh,sumhe, - $ swa,swb2,swc0,swc1,swc2,swc3,swc4,swc5,swc6, - $ swc7,plr,endpo2,ccpar, - $ c4,estrmin,endpo,accincr, - $ endpoold,xadd,yadd,zadd,addist,taddmol, - $ Hug_E0, Hug_P0, Hug_V0, xImpVcm, shock_vel, - $ shock_z_sep - common - $/cbka/ - $ ioop(nopmax,9),ifreqset(nmolset), - $ ijk(nat,4),icgeopt(nmolset), - $ irap(50),irdo(50,2), - $ ityadd(nat), - $ nmoloo(nat),iradic(nat),idef(nsort),nasort(nsort), - $ ibgr1(nattot),ibgr2(nattot),idupc(6), - $ imolsta(nat), - $ ncent2(nbomax),irads,nrdd,nrddf,nbiolab,nuge, - $ nbon2,npar,nodmty,ngnh,irac,nincrop, - $ nboty,mdstep, - $ nreac, - $ nbonop,icelo2, - $ iaddfreq,iveladd,invt, - $ noop,ndtau, - $ nelc3,nfc,nsav2,nmmax,ibh2, - $ nmmaxold,nfcold,icellold,imodfile, - $ icelo2old,inmov1,inmov2,nchaold,naa,nadattempt, - $ nequi,iadj, - $ ntest,nmm, - $ nmolo5o,nradcount,nmollset,iflga, - $ iperiod,ibgfversion,iremark,iconne, - $ kx,ky,kz,iexco,iruid,ibity,nvlist, - $ ityrad,iredo,iexx,iexy,iexz,ncellopt, - $ ndata2,nprob,nit,i5758,ingeo,nmoloold,itemp, - $ icgeo,ishock_type,isymm, - $ qadd(nat),qlabel(nattot),qffty(nattot),qresi1(nattot), - $ qresi2(nattot),qresi3(nattot), - $ qremark(20),qformat(20),qr,qffield, - $ qstrana1,qstrana2,qmolset(nmolset) -*********************************************************************** - - diff --git a/lib/reax/cbkabo.blk b/lib/reax/cbkabo.blk deleted file mode 100644 index 957651d002..0000000000 --- a/lib/reax/cbkabo.blk +++ /dev/null @@ -1,4 +0,0 @@ - common - $/cbkabo/ abo(nat) - - diff --git a/lib/reax/cbkatomcoord.blk b/lib/reax/cbkatomcoord.blk deleted file mode 100644 index 711fab85a0..0000000000 --- a/lib/reax/cbkatomcoord.blk +++ /dev/null @@ -1,3 +0,0 @@ - common - $/cbkatomcoord/ id(nat,3),xmasat(nat),vel(3,nat),accel(3,nat) - diff --git a/lib/reax/cbkbo.blk b/lib/reax/cbkbo.blk deleted file mode 100644 index 4c7a552c73..0000000000 --- a/lib/reax/cbkbo.blk +++ /dev/null @@ -1,3 +0,0 @@ - common - $/cbkbo/ bo(nbomax) - diff --git a/lib/reax/cbkboncor.blk b/lib/reax/cbkboncor.blk deleted file mode 100644 index 96d89e3a7e..0000000000 --- a/lib/reax/cbkboncor.blk +++ /dev/null @@ -1,5 +0,0 @@ - common - $/cbkboncor/ dbosindc(nbomax,3,2*mbond+2),dbosidc(nbomax,3,2), - $ bo131(nsort),bo132(nsort),bo133(nsort), - $ ovc(nbotym),v13cor(nbotym) - diff --git a/lib/reax/cbkbopi.blk b/lib/reax/cbkbopi.blk deleted file mode 100644 index c58ba31306..0000000000 --- a/lib/reax/cbkbopi.blk +++ /dev/null @@ -1,3 +0,0 @@ - common - $/cbkbopi/ bopi(nbomax) - diff --git a/lib/reax/cbkbopi2.blk b/lib/reax/cbkbopi2.blk deleted file mode 100644 index f150895b05..0000000000 --- a/lib/reax/cbkbopi2.blk +++ /dev/null @@ -1,3 +0,0 @@ - common - $/cbkbopi2/ bopi2(nbomax) - diff --git a/lib/reax/cbkbosi.blk b/lib/reax/cbkbosi.blk deleted file mode 100644 index 27a73ce884..0000000000 --- a/lib/reax/cbkbosi.blk +++ /dev/null @@ -1,4 +0,0 @@ - common - $/cbkbosi/ bosi(nbomax) - - diff --git a/lib/reax/cbkc.blk b/lib/reax/cbkc.blk deleted file mode 100644 index 2a2519eb2e..0000000000 --- a/lib/reax/cbkc.blk +++ /dev/null @@ -1,5 +0,0 @@ - common - $/cbkc/ c(nat,3),cglobal(nattot,3),itag(nat), - $chgglobal(nattot) - - diff --git a/lib/reax/cbkch.blk b/lib/reax/cbkch.blk deleted file mode 100644 index e3199934be..0000000000 --- a/lib/reax/cbkch.blk +++ /dev/null @@ -1,4 +0,0 @@ - common - $/cbkch/ ch(nat) - - diff --git a/lib/reax/cbkcha.blk b/lib/reax/cbkcha.blk deleted file mode 100644 index 3bcc218711..0000000000 --- a/lib/reax/cbkcha.blk +++ /dev/null @@ -1,5 +0,0 @@ - common - $/cbkcha/ ech,syscha,chisys - $ vfieldx,vfieldy,vfieldz,nmcharge,ioldchg - - diff --git a/lib/reax/cbkcharmol.blk b/lib/reax/cbkcharmol.blk deleted file mode 100644 index 4ffeaf7d28..0000000000 --- a/lib/reax/cbkcharmol.blk +++ /dev/null @@ -1,4 +0,0 @@ - common - $/cbkcharmol/ vmcha(nmolmax), - $ iat1mc(nmolmax),iat2mc(nmolmax) - diff --git a/lib/reax/cbkchb.blk b/lib/reax/cbkchb.blk deleted file mode 100644 index b725afb662..0000000000 --- a/lib/reax/cbkchb.blk +++ /dev/null @@ -1,3 +0,0 @@ - common - $/cbkchb/ chi(nsort),eta(nsort),gam(nsort) - diff --git a/lib/reax/cbkconst.blk b/lib/reax/cbkconst.blk deleted file mode 100644 index e23dbbf20f..0000000000 --- a/lib/reax/cbkconst.blk +++ /dev/null @@ -1,5 +0,0 @@ - - common - $/cbkconst/ dgrrdn,one,half,three,zero,caljou,rgasc,xjouca - $ convmd - diff --git a/lib/reax/cbkcovbon.blk b/lib/reax/cbkcovbon.blk deleted file mode 100644 index b37545c152..0000000000 --- a/lib/reax/cbkcovbon.blk +++ /dev/null @@ -1,7 +0,0 @@ - - - common - $/cbkcovbon/ de2(nbotym),de3(nbotym),psi(nbotym), - $ psp(nbotym), - $ ltripstaball - diff --git a/lib/reax/cbkd.blk b/lib/reax/cbkd.blk deleted file mode 100644 index 4baf7f350e..0000000000 --- a/lib/reax/cbkd.blk +++ /dev/null @@ -1,7 +0,0 @@ - integer Lvirial,Latomvirial - - common - $/cbkd/ d(3,nat),estrain(nat) - - common - $/cbkvirial/ atomvirial(6,nat),virial(6),Lvirial,Latomvirial diff --git a/lib/reax/cbkdbodc.blk b/lib/reax/cbkdbodc.blk deleted file mode 100644 index a3c9722554..0000000000 --- a/lib/reax/cbkdbodc.blk +++ /dev/null @@ -1,3 +0,0 @@ - common - $/cbkdbodc/ dbodc(nbomax,3,2) - diff --git a/lib/reax/cbkdbopi2ndc.blk b/lib/reax/cbkdbopi2ndc.blk deleted file mode 100644 index 94fde9fd07..0000000000 --- a/lib/reax/cbkdbopi2ndc.blk +++ /dev/null @@ -1,6 +0,0 @@ - - - - common - $/cbkdbopi2ndc/ dbopi2ndc(nbomax,3,2*mbond+2) - diff --git a/lib/reax/cbkdbopidc.blk b/lib/reax/cbkdbopidc.blk deleted file mode 100644 index 559c6a77a1..0000000000 --- a/lib/reax/cbkdbopidc.blk +++ /dev/null @@ -1,5 +0,0 @@ - - - common - $/dbopidc/ dbopi2dc(nbomax,3,2),dbopidc(nbomax,3,2) - diff --git a/lib/reax/cbkdbopindc.blk b/lib/reax/cbkdbopindc.blk deleted file mode 100644 index 96285f7c86..0000000000 --- a/lib/reax/cbkdbopindc.blk +++ /dev/null @@ -1,6 +0,0 @@ - - - - common - $/dbopindc/ dbopindc(nbomax,3,2*mbond+2) - diff --git a/lib/reax/cbkdcell.blk b/lib/reax/cbkdcell.blk deleted file mode 100644 index c3f22240a6..0000000000 --- a/lib/reax/cbkdcell.blk +++ /dev/null @@ -1,5 +0,0 @@ - - - common - $/cbkdcell/ dcell(3,nat,27) - diff --git a/lib/reax/cbkdhdc.blk b/lib/reax/cbkdhdc.blk deleted file mode 100644 index e5e4638f28..0000000000 --- a/lib/reax/cbkdhdc.blk +++ /dev/null @@ -1,5 +0,0 @@ - - - common - $/cbkdhdc/ dhdc(nvamax,3,3) - diff --git a/lib/reax/cbkdistan.blk b/lib/reax/cbkdistan.blk deleted file mode 100644 index d752173f24..0000000000 --- a/lib/reax/cbkdistan.blk +++ /dev/null @@ -1,4 +0,0 @@ - common - $/cbkdistan/ axis(3),aaxh,baxh,caxh,iortho - - diff --git a/lib/reax/cbkdrdc.blk b/lib/reax/cbkdrdc.blk deleted file mode 100644 index 1d5615440e..0000000000 --- a/lib/reax/cbkdrdc.blk +++ /dev/null @@ -1,5 +0,0 @@ - - - common - $/cbkdrdc/ drdc(nbomax,3,2) - diff --git a/lib/reax/cbkefield.blk b/lib/reax/cbkefield.blk deleted file mode 100644 index 7991f4b98e..0000000000 --- a/lib/reax/cbkefield.blk +++ /dev/null @@ -1,4 +0,0 @@ - - common - $/cbkefield/ efix,efiy,efiz,c1 - diff --git a/lib/reax/cbkenergies.blk b/lib/reax/cbkenergies.blk deleted file mode 100644 index e0220e88ef..0000000000 --- a/lib/reax/cbkenergies.blk +++ /dev/null @@ -1,7 +0,0 @@ - - common - $/cbkenergies/ eb,eoop,epen,estrc,deda(3),pressu, - $ efi,elp,emol,ea,eres,et,eradbo, - $ ev,eco,ecoa,ehb,sw,ew,ep,ekin - - diff --git a/lib/reax/cbkeregime.blk b/lib/reax/cbkeregime.blk deleted file mode 100644 index 198862e5f1..0000000000 --- a/lib/reax/cbkeregime.blk +++ /dev/null @@ -1,5 +0,0 @@ - character*5 qetype - common - $/cbkeregime/ qetype(mereg,mezone),nnereg(mereg),nerc, - $ ereg(mereg,mezone),nitec(mereg) - diff --git a/lib/reax/cbkff.blk b/lib/reax/cbkff.blk deleted file mode 100644 index 36ffceea0c..0000000000 --- a/lib/reax/cbkff.blk +++ /dev/null @@ -1,9 +0,0 @@ - character*2 qas - common - $/cbkff/ gamcco(nsort,nsort),vpar(npamax),vovun(nsort), - $ stlp(nsort),aval(nsort),vlp1(nsort), - $ vover(nbotym),valp1(nsort), - $ vka(nvatym),qas(nsort),amas(nsort),e1(nbotym), - $ valf(nsort),de1(nbotym),swb,nvs(nvatym,3),nso,nvaty - - diff --git a/lib/reax/cbkfftorang.blk b/lib/reax/cbkfftorang.blk deleted file mode 100644 index 4154e5565d..0000000000 --- a/lib/reax/cbkfftorang.blk +++ /dev/null @@ -1,8 +0,0 @@ - - - - - common - $/cbkfftorang/ v4(ntotym),vconj(ntotym), - $ v1(ntotym),v2(ntotym),v3(ntotym) - diff --git a/lib/reax/cbkh.blk b/lib/reax/cbkh.blk deleted file mode 100644 index 7be7c5d7b3..0000000000 --- a/lib/reax/cbkh.blk +++ /dev/null @@ -1,5 +0,0 @@ - - - common - $/cbkh/ h(nvamax) - diff --git a/lib/reax/cbkhbond.blk b/lib/reax/cbkhbond.blk deleted file mode 100644 index 7a071ef096..0000000000 --- a/lib/reax/cbkhbond.blk +++ /dev/null @@ -1,5 +0,0 @@ - - common - - $/cbkhbond/ hhb(nhbmax) - diff --git a/lib/reax/cbkia.blk b/lib/reax/cbkia.blk deleted file mode 100644 index f7ada0e8fd..0000000000 --- a/lib/reax/cbkia.blk +++ /dev/null @@ -1,6 +0,0 @@ - - - - common - $/cbkia/ ia(nat,mbond+3),iag(nat,mbond+3) - diff --git a/lib/reax/cbkidbo.blk b/lib/reax/cbkidbo.blk deleted file mode 100644 index cc3fb49331..0000000000 --- a/lib/reax/cbkidbo.blk +++ /dev/null @@ -1,7 +0,0 @@ - - - - common - $/cbkidbo/ idbo(nbomax,2*mbond+2),dbondc(nbomax,3,2*mbond+2), - $ idbo1(nbomax) - diff --git a/lib/reax/cbkimove.blk b/lib/reax/cbkimove.blk deleted file mode 100644 index e65bd01e43..0000000000 --- a/lib/reax/cbkimove.blk +++ /dev/null @@ -1,6 +0,0 @@ - - - common - $/cbkimove/ imove(nattot) - - diff --git a/lib/reax/cbkinit.blk b/lib/reax/cbkinit.blk deleted file mode 100644 index 45ac3396a0..0000000000 --- a/lib/reax/cbkinit.blk +++ /dev/null @@ -1,6 +0,0 @@ - - character*40 qruid - common - $/cbkinit/ tsetor,nzero,none,ntwo,nthree,qruid,systime, - $ ustime,two,pi,avognr,axiss(3),pset,rdndgr - diff --git a/lib/reax/cbklonpar.blk b/lib/reax/cbklonpar.blk deleted file mode 100644 index 016888f286..0000000000 --- a/lib/reax/cbklonpar.blk +++ /dev/null @@ -1,5 +0,0 @@ - - - common - $/cbklonpar/ vlp(nat),dvlpdsbo(nat) - diff --git a/lib/reax/cbkmolec.blk b/lib/reax/cbkmolec.blk deleted file mode 100644 index 847ae44edb..0000000000 --- a/lib/reax/cbkmolec.blk +++ /dev/null @@ -1,6 +0,0 @@ - - - - common - $/cbkmolec/ nmolat2(nmolmax,nat),elmol2(nmolmax) - diff --git a/lib/reax/cbknmolat.blk b/lib/reax/cbknmolat.blk deleted file mode 100644 index a89f0f677c..0000000000 --- a/lib/reax/cbknmolat.blk +++ /dev/null @@ -1,6 +0,0 @@ - - - - common - $/cbknmolat/ nmolat(nmolmax,nat) - diff --git a/lib/reax/cbknonbon.blk b/lib/reax/cbknonbon.blk deleted file mode 100644 index c0ec0feaa1..0000000000 --- a/lib/reax/cbknonbon.blk +++ /dev/null @@ -1,6 +0,0 @@ - - - common - $/cbknonbon/ gamwco(nsort,nsort),sw1,p3co(nsort,nsort), - $ p2co(nsort,nsort),p1co(nsort,nsort) - diff --git a/lib/reax/cbknubon2.blk b/lib/reax/cbknubon2.blk deleted file mode 100644 index ecc7eafd47..0000000000 --- a/lib/reax/cbknubon2.blk +++ /dev/null @@ -1,5 +0,0 @@ - - - common - $/cbknubon2/ nubon1(nat,mbond), nubon2(nat,mbond) - diff --git a/lib/reax/cbknvlbo.blk b/lib/reax/cbknvlbo.blk deleted file mode 100644 index b9a3791811..0000000000 --- a/lib/reax/cbknvlbo.blk +++ /dev/null @@ -1,4 +0,0 @@ - common - $/cbknvlbo/ nvlbo(nneighmax*nat) - - diff --git a/lib/reax/cbknvlown.blk b/lib/reax/cbknvlown.blk deleted file mode 100644 index d51ce5531f..0000000000 --- a/lib/reax/cbknvlown.blk +++ /dev/null @@ -1,2 +0,0 @@ - common - $/cbknvlown/ nvlown(nneighmax*nat) diff --git a/lib/reax/cbkpairs.blk b/lib/reax/cbkpairs.blk deleted file mode 100644 index 028b0f2fac..0000000000 --- a/lib/reax/cbkpairs.blk +++ /dev/null @@ -1,4 +0,0 @@ - common - $/cbkpairs/ nvl1(nneighmax*nat),nvl2(nneighmax*nat),nvpair,nvlself - - diff --git a/lib/reax/cbkpres.blk b/lib/reax/cbkpres.blk deleted file mode 100644 index bf14b380c4..0000000000 --- a/lib/reax/cbkpres.blk +++ /dev/null @@ -1,4 +0,0 @@ - - common - $/cbkpres/ presx,presy,presz - diff --git a/lib/reax/cbkqa.blk b/lib/reax/cbkqa.blk deleted file mode 100644 index 63e88e7411..0000000000 --- a/lib/reax/cbkqa.blk +++ /dev/null @@ -1,5 +0,0 @@ - character*2 qa - common - $/cbkqa/ qa(nattot) - - diff --git a/lib/reax/cbkrbo.blk b/lib/reax/cbkrbo.blk deleted file mode 100644 index e9b99f008a..0000000000 --- a/lib/reax/cbkrbo.blk +++ /dev/null @@ -1,5 +0,0 @@ - - - common - $/cbkrbo/ rbo(nbomax),ibsym(nbomax),ib(nbomax,3) - diff --git a/lib/reax/cbkrestr.blk b/lib/reax/cbkrestr.blk deleted file mode 100644 index 15169677e4..0000000000 --- a/lib/reax/cbkrestr.blk +++ /dev/null @@ -1,12 +0,0 @@ - common - $/cbkrestr/ vkrv(mrestra),vrstra(mrestra),vkr2v(mrestra), - $ dismacen(mrestra),rmstra1(mrestra), - $ rrstra(mrestra),vkrst2(mrestra), - $ rmstra2(mrestra),rmstrax(mrestra),rmstray(mrestra), - $ rmstraz(mrestra),cmo(nat,3),vmo1(nat),trstra(mrestra), - $ vkrt(mrestra),vkr2t(mrestra),vkrstr(mrestra), - $ irstrav(mrestra,3),irstra(mrestra,2),itend(mrestra), - $ irstram(mrestra,5),itstart(mrestra),irstrat(mrestra,4), - $ imorph - - diff --git a/lib/reax/cbksrtbon1.blk b/lib/reax/cbksrtbon1.blk deleted file mode 100644 index 9a4d425e18..0000000000 --- a/lib/reax/cbksrtbon1.blk +++ /dev/null @@ -1,13 +0,0 @@ - character*60 qmol - common - $/cbksrtbon1/ dbodr(nbomax),dbopidr(nbomax), - $ dbopi2dr(nbomax), - $ rob1(nsort,nsort),rob2(nsort,nsort), - $ rob3(nsort,nsort), - $ rat(nsort),rapt(nsort),vnq(nsort),bom(nbotym), - $ pdp(nbotym),ptp(nbotym),pdo(nbotym), - $ popi(nbotym),bop1(nbotym),bop2(nbotym),cutoff, - $ nbs(nbotym,2), - $ nsbma2,nsbmax,nboty2,nbonall,qfile(nmolset),qmol - - diff --git a/lib/reax/cbksrthb.blk b/lib/reax/cbksrthb.blk deleted file mode 100644 index ad035f6c05..0000000000 --- a/lib/reax/cbksrthb.blk +++ /dev/null @@ -1,10 +0,0 @@ - - - common - $/cbksrthb/ vhb1(nhbtym),vhb2(nhbtym),rhb(nhbtym), - $ dehb(nhbtym),ihb(nhbmax,8),nhb, - $ nphb(nsort),nhbs(nhbtym,3),nhbty,hbcut, - $ lhbnew - - - diff --git a/lib/reax/cbktorang.blk b/lib/reax/cbktorang.blk deleted file mode 100644 index 3e8c94fd5f..0000000000 --- a/lib/reax/cbktorang.blk +++ /dev/null @@ -1,5 +0,0 @@ - - - common - $/cbktorang/ dargtdc(ntomax,3,4),thg(ntomax) - diff --git a/lib/reax/cbktorsion.blk b/lib/reax/cbktorsion.blk deleted file mode 100644 index 30f984b7df..0000000000 --- a/lib/reax/cbktorsion.blk +++ /dev/null @@ -1,7 +0,0 @@ - - - - common - $/cbktorsion/ nts(ntotym,4),ntoty,ntor,it(ntomax,11) - - diff --git a/lib/reax/cbktregime.blk b/lib/reax/cbktregime.blk deleted file mode 100644 index 06df64e192..0000000000 --- a/lib/reax/cbktregime.blk +++ /dev/null @@ -1,8 +0,0 @@ - common - $/cbktregime/ dttreg(mtreg,mtzone),tdamptreg(mtreg,mtzone), - $ ia1treg(mtreg,mtzone),ia2treg(mtreg,mtzone), - $ tsettreg(mtreg,mtzone),nntreg(mtreg),ittc(mtreg), - $ nittc(mtreg),ifieldz,ifieldx,ifieldy, - $ nrestra,nrestram,nrestrat,nrestrav,ntrc - - diff --git a/lib/reax/cbkvalence.blk b/lib/reax/cbkvalence.blk deleted file mode 100644 index 3e7bee9b60..0000000000 --- a/lib/reax/cbkvalence.blk +++ /dev/null @@ -1,5 +0,0 @@ - - - common - $/cbkvalence/ nval,iv(nvamax,6) - diff --git a/lib/reax/cbkvregime.blk b/lib/reax/cbkvregime.blk deleted file mode 100644 index ed2f5a45e6..0000000000 --- a/lib/reax/cbkvregime.blk +++ /dev/null @@ -1,7 +0,0 @@ - character*5 qvtype - common - $/cbkvregime/ ivsca(mvreg,mvzone),dvvreg(mvreg,mvzone), - $ nnvreg(mvreg),invrc,nitvc(mvreg), - $ qvtype(mvreg,mvzone) - - diff --git a/lib/reax/cellcoord.blk b/lib/reax/cellcoord.blk deleted file mode 100644 index 3cbee22656..0000000000 --- a/lib/reax/cellcoord.blk +++ /dev/null @@ -1,4 +0,0 @@ - - common - $/cellcoord/ tm11,tm21,tm31,tm22,tm32,tm33,angle(3),angles(3) - diff --git a/lib/reax/control.blk b/lib/reax/control.blk deleted file mode 100644 index 4e84f85b9e..0000000000 --- a/lib/reax/control.blk +++ /dev/null @@ -1,12 +0,0 @@ - common - $/control/ vrange,cutof2,cutof3,vlbora,tstep,range,taut,volcha, - $ axis1,axis2,axis3,taup, - $ icpres,nmethod,noutpt,inpt,napp,ianaly,ncha2, - $ nrand,ntscale,itstep,ndebug,icentr,itrout, - $ nchaudixmolo,itrans,nsav, - $ nrep1,ncontrol,nhop2,nsav3,ngeofor,ifreq, - $ nprevrun,maxstp,nvel,nsurp,ncons, - $ ncha,icell,imolde,nchaud -********************************************************************************* - - diff --git a/lib/reax/opt.blk b/lib/reax/opt.blk deleted file mode 100644 index c72df23d5c..0000000000 --- a/lib/reax/opt.blk +++ /dev/null @@ -1,23 +0,0 @@ - parameter (maxdat=5000) - parameter (maxmdat=2500) - parameter (maxkop=2500) - character*80 qff - character*60 qmdat - character*100 qdatid - character*2 qas2 - common - $/opt/ fpar(7,nvatym,40),datopt(maxdat),caldat(maxdat), - $ compdat(maxdat),weightdat(maxdat), - $ devi(maxdat),vkop(maxkop),devkop(maxkop),sdy(3), - $ valpar,valnew,change,vchange, - $ molin(maxmdat,nsort), - $ iboo(nbotym,2),idmo(nodmtym,2),ivao(nvatym,5), - $ itoo(ntotym,7),ihbo(nhbtym,5),iheada(maxmdat), - $ ndatm(maxmdat),iheada2(maxmdat),ichn(3), - $ ikop1(maxkop),ikop2(maxkop),idat(maxdat),mu1(maxkop), - $ mu2(maxkop), - $ ndata,imam,iopt,iheatf,nkop,iagain, - $ qdatid(maxdat),qmdat(maxmdat),qff(250),qas2(nsort) -*********************************************************************** - - diff --git a/lib/reax/reax_charges.F b/lib/reax/reax_charges.F deleted file mode 100644 index 5815501a29..0000000000 --- a/lib/reax/reax_charges.F +++ /dev/null @@ -1,85 +0,0 @@ -********************************************************************** -* * -* REAXFF Reactive force field program * -* * -* Developed and written by Adri van Duin, duin@wag.caltech.edu * -* * -* Copyright (c) 2001-2010 California Institute of Technology * -* * -* This is an open-source program. Feel free to modify its * -* contents. Please keep me informed of any useful modification * -* or addition that you made. Please do not distribute this * -* program to others; if people are interested in obtaining * -* a copy of this program let them contact me first. * -* * -********************************************************************** -************************************************************************ - - subroutine taper(r,r2) - -************************************************************************ -#include "cbka.blk" -#include "cbkconst.blk" -#include "cbkenergies.blk" -#include "cbkinit.blk" -#include "cbknonbon.blk" -************************************************************************ -* * -* Taper function for Coulomb interaction * -* * -************************************************************************ - r3=r2*r - SW=SWC7*R3*R3*R+SWC6*R3*R3+SWC5*R3*R2+SWC4*R2*R2+SWC3*R3+SWC2*R2+ - $SWC1*R+SWC0 - SW1=7.0D0*SWC7*R3*R3+6.0D0*SWC6*R3*R2+5.0D0*SWC5*R2*R2+ - $4.0D0*SWC4*R3+THREE*SWC3*R2+TWO*SWC2*R+SWC1 - return - end -************************************************************************ -************************************************************************ - - subroutine tap7th - -************************************************************************ -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkconst.blk" -#include "cbkd.blk" -#include "cbkff.blk" -#include "cbkh.blk" -#include "control.blk" - -************************************************************************ -* * -* 7th order taper function setup * -* * -************************************************************************ -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In tap7th' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - D1=SWB-SWA - D7=D1**7.0D0 - SWA2=SWA*SWA - SWA3=SWA2*SWA - SWB2=SWB*SWB - SWB3=SWB2*SWB - -************************************************************************ -* 7th order taper function * -************************************************************************ - - SWC7= 20.0D0/D7 - SWC6= -70.0D0*(SWA+SWB)/D7 - SWC5= 84.0D0*(SWA2+3.0D0*SWA*SWB+SWB2)/D7 - SWC4= -35.0D0*(SWA3+9.0D0*SWA2*SWB+9.0D0*SWA*SWB2+SWB3)/D7 - SWC3= 140.0D0*(SWA3*SWB+3.0D0*SWA2*SWB2+SWA*SWB3)/D7 - SWC2=-210.0D0*(SWA3*SWB2+SWA2*SWB3)/D7 - SWC1= 140.0D0*SWA3*SWB3/D7 - SWC0=(-35.0D0*SWA3*SWB2*SWB2+21.0D0*SWA2*SWB3*SWB2- - $7.0D0*SWA*SWB3*SWB3+SWB3*SWB3*SWB)/D7 - - return - END diff --git a/lib/reax/reax_connect.F b/lib/reax/reax_connect.F deleted file mode 100644 index e77875124f..0000000000 --- a/lib/reax/reax_connect.F +++ /dev/null @@ -1,1547 +0,0 @@ -********************************************************************** -* * -* REAXFF Reactive force field program * -* * -* Developed and written by Adri van Duin, duin@wag.caltech.edu * -* * -* Copyright (c) 2001-2010 California Institute of Technology * -* * -* This is an open-source program. Feel free to modify its * -* contents. Please keep me informed of any useful modification * -* or addition that you made. Please do not distribute this * -* program to others; if people are interested in obtaining * -* a copy of this program let them contact me first. * -* * -********************************************************************** -********************************************************************** - - subroutine srtatom - -********************************************************************** -#include "cbka.blk" -#include "cbkatomcoord.blk" -#include "cbkff.blk" -#include "cbkia.blk" -#include "cbkqa.blk" -#include "control.blk" -#include "opt.blk" -#include "small.blk" -********************************************************************** -* * -* Determine atom types in system * -* * -********************************************************************** -* Requires the following variables -* ndebug - opt.blk; determines whether to debug or not; everywhere -* xmasmd - cbka.blk; some sort of atmoic mass?; srtatom, reac.f -* molin - opt.blk; keeps info on?; srtatom -* nso - cbka.blk; number of atoms?; srtatom, inout.f -* nprob - cbka.blk; does?; connect.f, inout.f, reac.f -* nasort - cbka.blk; a sorting array; srtatom -* ia - cbka.blk; atom numbers?; poten.f, inout.f, connect.f, charges.f -* iag - cbka.blk; ; connect.f, inout.f, poten.f, reac.f -* xmasat - cbka.blk; does?; srtatom, reac.f -* amas - cbka.blk; ? ; srtatom, ffinpt, molanal, ovcor -* qa - cbka.blk; some sort of error statement variable?; srtatom, srtbon1, inout.f, radbo -* -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In srtatom' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - - xmasmd=0.0 - do i1=1,nso - molin(nprob,i1)=0 - nasort(i1)=0 - end do - do i1=1,na - ia(i1,1)=0 - iag(i1,1)=0 - do i2=1,nso - if (qa(i1).eq.qas(i2)) then - ia(i1,1)=i2 - iag(i1,1)=i2 - molin(nprob,i2)=molin(nprob,i2)+1 - xmasat(i1)=amas(i2) - xmasmd=xmasmd+amas(i2) - nasort(i2)=nasort(i2)+1 - end if - end do - if (ia(i1,1).eq.0) then - write (*,*)'Unknown atom type: ',qa(i1) - stop 'Unknown atom type' - end if - end do - - return - end -********************************************************************** -********************************************************************** - - subroutine molec - -********************************************************************** -#include "cbka.blk" -#include "cbkdcell.blk" -#include "cbkff.blk" -#include "cbkia.blk" -#include "cbkmolec.blk" -#include "cbknmolat.blk" -#include "control.blk" -#include "small.blk" - dimension nmolo2(nat),iseen(nmolmax),isee2(nmolmax) -********************************************************************** -* * -* Determine changes in molecules * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In molec' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - npreac=0 - - do i1=1,nmolo - natmol=0 - do i2=1,na - if (ia(i2,3+mbond).eq.i1) then - natmol=natmol+1 - nmolat(i1,natmol+1)=i2 - end if - end do - nmolat(i1,1)=natmol - end do - - if (nmolo5.lt.nmolo5o) nradcount=0 !reset reaction counter - do i1=1,nmolo5 - natmol=0 - do i2=1,na - if (iag(i2,3+mbond).eq.i1) then - natmol=natmol+1 - nmolat2(i1,natmol+1)=i2 - end if - end do - nmolat2(i1,1)=natmol - end do - nmolo5o=nmolo5 - - do i1=nmolo+1,nmoloold - do i2=1,nmolat(i1,1) - nmolat(i1,1+i2)=0 - end do - nmolat(i1,1)=0 - end do - - do i1=1,nmolo - elmol(i1)=0.0 - do i2=1,nmolat(i1,1) - ihu=nmolat(i1,i2+1) - ity=ia(ihu,1) - elmol(i1)=elmol(i1)+stlp(ity) - end do - end do - - do i1=1,nmolo5 - elmol2(i1)=0.0 - do i2=1,nmolat2(i1,1) - ihu=nmolat2(i1,i2+1) - ity=iag(ihu,1) - elmol2(i1)=elmol2(i1)+stlp(ity) - end do - end do - - return - end -********************************************************************** -********************************************************************** - - subroutine dista2 (n1,n2,dista,dx,dy,dz) - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" -********************************************************************** -* * -* Determine interatomic distances * -* * -********************************************************************** -c$$$* if (ndebug.eq.1) then -c$$$C* open (65,file='fort.65',status='unknown',access='append') -c$$$* write (65,*) 'In dista2' -c$$$* call timer(65) -c$$$* close (65) -c$$$* end if - - dx=c(n1,1)-c(n2,1) - dy=c(n1,2)-c(n2,2) - dz=c(n1,3)-c(n2,3) - dista=sqrt(dx*dx+dy*dy+dz*dz) - - return - end -********************************************************************** -********************************************************************** - - subroutine srtbon1(lprune,lhb,hbcut_in,lhbnew_in,ltripstaball_in) - -********************************************************************** -#include "cbka.blk" -#include "cbkabo.blk" -#include "cbkbo.blk" -#include "cbkbosi.blk" -#include "cbkbopi.blk" -#include "cbkbopi2.blk" -#include "cbkc.blk" -#include "cbkch.blk" -#include "cbkconst.blk" -#include "cbkdbopidc.blk" -#include "cbkdrdc.blk" -#include "cbkia.blk" -#include "cbknubon2.blk" -#include "cbknvlbo.blk" -#include "cbkpairs.blk" -#include "cbknvlown.blk" -#include "cbkqa.blk" -#include "cbkrbo.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "small.blk" -#include "cbkdbodc.blk" -#include "cbksrtbon1.blk" -#include "cbkff.blk" -#include "cbksrthb.blk" -#include "cbkcovbon.blk" - logical found - integer nboncol(nboallmax) - integer iball(nboallmax,3) - -********************************************************************** -* * -* Determine connections within the molecule * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In srtbon1' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - -c Transfer hbcut, lhbnew, and ltripstaball from C++ calling function - hbcut = hbcut_in - lhbnew = lhbnew_in - ltripstaball = ltripstaball_in - - do i1=1,na - abo(i1)=0.0d0 - end do - nbonall=0 - nbon2=0 - nsbmax=0 - nsbma2=0 - - if (imolde.eq.0) then - - nmolo=0 - nmolo5=0 - end if - if (imolde.eq.0) then - do i1=1,na - do i2=2,mbond+3 - ia(i1,i2)=0 - iag(i1,i2)=0 - end do - end do - - else - - do i1=1,na - do i2=2,mbond+2 - ia(i1,i2)=0 - iag(i1,i2)=0 - end do - end do - - end if - - do i1=1,na - do i2=1,mbond - nubon1(i1,i2)=0 - nubon2(i1,i2)=0 - end do - end do - -* First detect all bonds and create preliminary list - - do 11 ivl=1,nvpair - if (nvlbo(ivl).eq.0) goto 11 !not in bond order range - i1=nvl1(ivl) - i2=nvl2(ivl) - call dista2(i1,i2,dis,dxm,dym,dzm) - ih1=ia(i1,1) - ih2=ia(i2,1) - disdx=dxm/dis - disdy=dym/dis - disdz=dzm/dis - itype=0 - if (ih1.gt.ih2) then - ih1=ia(i2,1) - ih2=ia(i1,1) - end if - do i3=1,nboty2 - if (ih1.eq.nbs(i3,1).and.ih2.eq.nbs(i3,2)) itype=i3 - end do - if (itype.eq.0.and.rat(ih1).gt.zero.and.rat(ih2).gt.zero) then -c$$$ call mdsav(1,qfile(nprob)) - write (*,*)qa(i1),'-',qa(i2),'Fatal: Unknown bond in molecule' - stop - end if - - rhulp=dis/rob1(ih1,ih2) - -********************************************************************** -* * -* Determine bond orders * -* * -********************************************************************** - rh2=zero - rh2p=zero - rh2pp=zero - ehulp=zero - ehulpp=zero - ehulppp=zero - if (rapt(ih1).gt.zero.and.rapt(ih2).gt.zero) then - rhulp2=dis/rob2(ih1,ih2) - rh2p=rhulp2**ptp(itype) - ehulpp=exp(pdp(itype)*rh2p) - end if - if (vnq(ih1).gt.zero.and.vnq(ih2).gt.zero) then - rhulp3=dis/rob3(ih1,ih2) - rh2pp=rhulp3**popi(itype) - ehulppp=exp(pdo(itype)*rh2pp) - end if - - if (rat(ih1).gt.zero.and.rat(ih2).gt.zero) then - rh2=rhulp**bop2(itype) - ehulp=(1.0+cutoff)*exp(bop1(itype)*rh2) - end if - - bor=ehulp+ehulpp+ehulppp - - j1=i1 - j2=i2 - -********************************************************************** -* * -* Determine bond orders * -* * -********************************************************************** - if (bor.gt.cutoff) then - nbonall=nbonall+1 - if (nbonall.gt.nboallmax) then - write (6,*)'nbonall = ',nbonall, - $ ' reax_defs.h::NBOALLMAXDEF = ',NBOALLMAXDEF, - $ ' after',ivl, ' of ',nvpair,' pairs completed.' - stop 'Too many bonds; maybe wrong cell parameters.' - end if - iball(nbonall,1)=itype - iball(nbonall,2)=j1 - iball(nbonall,3)=j2 - - ia(i1,2)=ia(i1,2)+1 - if (ia(i1,2).gt.mbond) then - write (6,*)'ia(i1,2) = ',ia(i1,2), - $ ' reax_defs.h::MBONDDEF = ',MBONDDEF, - $ ' after',ivl, ' of ',nvpair,' pairs completed.' - stop 'Too many bonds on atom. Increase MBONDDEF' - end if - - if (i1.ne.i2) then - ia(i2,2)=ia(i2,2)+1 - if (ia(i2,2).gt.mbond) then - write (6,*)'ia(i1,2) = ',ia(i1,2), - $ ' reax_defs.h::MBONDDEF = ',MBONDDEF, - $ ' after',ivl, ' of ',nvpair,' pairs completed.' - stop 'Too many bonds on atom. Increase MBONDDEF' - end if - endif - - ia(i1,ia(i1,2)+2)=i2 - ia(i2,ia(i2,2)+2)=i1 - if (abs(de1(iball(nbonall,1))).gt.-0.01) then - nubon2(i1,ia(i1,2))=nbonall - nubon2(i2,ia(i2,2))=nbonall - else - nbonall=nbonall-1 !Inorganics - end if - end if - 11 continue - -********************************************************************** -* * -* lprune controls level of bond-pruning performed to increase * -* performance. For correct results, it should be set to 4. * -* However, making it smaller can speed up * -* force calculation and may not have a big effect on forces. * -* Setting it to 0 turns off pruning, useful for debugging. * -* * -********************************************************************** -********************************************************************* -* * -* lhb controls whether or not to unprune ghost bonds that * -* may possibly form ghost hydrogen bonds. * -* Setting it to 1 causes unpruning, and so is the safe option. * -* If lprune = 0, then pruning is not used, results are exact * -* and lhb has no effect. * -* * -********************************************************************** - if (lprune .gt. 0) then -********************************************************************** -* * -* Eliminate bonds that are not in 1-6 interaction * -* with local atom, or closer. * -* Need additional sweep to catch possible hydrogen bonds * -* * -********************************************************************** - - ntmp0 = 0 - ntmp1 = 0 - ntmp2 = 0 - ntmp3 = 0 - ntmp4 = 0 - ntmp5 = 0 - ntmp6 = 0 - ntmphb = 0 - -* color 1 are bonds with two local atoms -* color 2 are bonds with one local atom -* color 3 are bonds adjacent to bond with one local atom - - do i1 = 1,nbonall - if (iball(i1,2).le.na_local) then - if (iball(i1,3).le.na_local) then - nboncol(i1) = 1 - ntmp1 = ntmp1+1 - else - nboncol(i1) = 2 - ntmp2 = ntmp2+1 - endif - else if (iball(i1,3).le.na_local) then - nboncol(i1) = 2 - ntmp2 = ntmp2+1 - else - nboncol(i1) = 0 - endif - end do - - if (lprune .ge. 3) then - do i1 = 1,nbonall - if (nboncol(i1).eq.2) then - if (iball(i1,2).le.na_local) then - i3=iball(i1,3) - else - i3=iball(i1,2) - endif - - do i4 = 1,ia(i3,2) - i5=nubon2(i3,i4) - if (nboncol(i5).eq.0) then - nboncol(i5)=3 - ntmp3 = ntmp3+1 - endif - end do - endif - end do - endif -* color 4 bonds are part of a 1-4 interaction with local atom - - if (lprune .ge. 4) then - do i1 = 1,nbonall - if (nboncol(i1).eq.3) then -* One end definitely has a bond of color 2 -* Find it and color bonds on other end 4 - i3=iball(i1,2) - i3b=0 - do i4 = 1,ia(i3,2) - i5=nubon2(i3,i4) - if (nboncol(i5).eq.2) then - i3b=iball(i1,3) - endif - end do - - if (i3b.eq.0) then - i3=iball(i1,3) - i3b=0 - do i4 = 1,ia(i3,2) - i5=nubon2(i3,i4) - if (nboncol(i5).eq.2) then - i3b=iball(i1,2) - endif - end do - endif - - if (i3b.eq.0) then - stop 'Could not find color 2 from color 3 bond' - endif - - do i4 = 1,ia(i3b,2) - i5=nubon2(i3b,i4) - if (nboncol(i5).eq.0) then - nboncol(i5)=4 - ntmp4 = ntmp4+1 - endif - end do - - endif - end do - endif - -* color 5 bonds are part of a 1-5 interaction with local atom - - if (lprune .ge. 5) then - do i1 = 1,nbonall - if (nboncol(i1).eq.4) then -* One end definitely has a bond of color 3 -* Find it and color bonds on other end 5 - i3=iball(i1,2) - i3b=0 - do i4 = 1,ia(i3,2) - i5=nubon2(i3,i4) - if (nboncol(i5).eq.3) then - i3b=iball(i1,3) - endif - end do - - if (i3b.eq.0) then - i3=iball(i1,3) - i3b=0 - do i4 = 1,ia(i3,2) - i5=nubon2(i3,i4) - if (nboncol(i5).eq.3) then - i3b=iball(i1,2) - endif - end do - endif - - if (i3b.eq.0) then - stop 'Could not find color 3 from color 4 bond' - endif - - do i4 = 1,ia(i3b,2) - i5=nubon2(i3b,i4) - if (nboncol(i5).eq.0) then - nboncol(i5)=5 - ntmp5 = ntmp5+1 - endif - end do - - endif - end do - endif - -* color 6 bonds are part of a 1-6 interaction with local atom - - if (lprune .ge. 6) then - do i1 = 1,nbonall - if (nboncol(i1).eq.5) then -* One end definitely has a bond of color 4 -* Find it and color bonds on other end 6 - i3=iball(i1,2) - i3b=0 - do i4 = 1,ia(i3,2) - i5=nubon2(i3,i4) - if (nboncol(i5).eq.4) then - i3b=iball(i1,3) - endif - end do - - if (i3b.eq.0) then - i3=iball(i1,3) - i3b=0 - do i4 = 1,ia(i3,2) - i5=nubon2(i3,i4) - if (nboncol(i5).eq.4) then - i3b=iball(i1,2) - endif - end do - endif - - if (i3b.eq.0) then - stop 'Could not find color 4 from color 5 bond' - endif - - do i4 = 1,ia(i3b,2) - i5=nubon2(i3b,i4) - if (nboncol(i5).eq.0) then - nboncol(i5)=6 - ntmp6 = ntmp6+1 - endif - end do - - endif - end do - endif - -* Catch all the possible hydrogen bonds -* This section replicates the logic used in srthb() - if (lhb .eq. 1) then -c Outer loop must be Verlet list, because ia() does not store Verlet entries, -c but it does store bond entries in nubon2() - do ivl=1,nvpair !Use Verlet-list to find donor-acceptor pairs - - j1=nvl1(ivl) - j2=nvl2(ivl) - ihhb1=nphb(ia(j1,1)) - ihhb2=nphb(ia(j2,1)) - - if (ihhb1.gt.ihhb2) then !Make j1 donor(H) atom and j2 acceptor(O) atom - j2=nvl1(ivl) - j1=nvl2(ivl) - ihhb1=nphb(ia(j1,1)) - ihhb2=nphb(ia(j2,1)) - end if - -* Only need to compute bonds where j1 is local - if (j1 .le. na_local) then - - if (ihhb1.eq.1.and.ihhb2.eq.2) then - call dista2(j1,j2,dishb,dxm,dym,dzm) - if (dishb.lt.hbcut) then - do i23=1,ia(j1,2) !Search for acceptor atoms bound to donor atom - if (nboncol(nubon2(j1,i23)).eq.0) then - j3=ia(j1,2+i23) - if (nphb(ia(j3,1)).eq.2.and.j3.ne.j2) then - nboncol(nubon2(j1,i23))=-1 - ntmphb = ntmphb+1 - endif - endif - end do - end if - end if - end if - end do - end if - -* Compact the list, removing all uncolored bonds - - nbon = 0 - do i1 = 1,nbonall - if (nboncol(i1).eq.0) then - ntmp0=ntmp0+1 - else - nbon = nbon+1 - - if (nbon.gt.nbomax) then - write (6,*)nbon,nbomax - write (6,*)'nbon = ',nbon,' reax_defs.h::NBOMAXDEF = ', - $ NBOMAXDEF,' after',i1, ' of ',nbonall, - $ ' initial bonds completed.' - stop 'Too many pruned bonds; increase NBOMAXDEF' - end if - - - ib(nbon,1) = iball(i1,1) - ib(nbon,2) = iball(i1,2) - ib(nbon,3) = iball(i1,3) - endif - end do - -********************************************************************** -* * -* Do not perform ghost-bond pruning * -* * -********************************************************************** - - else - - nbon = 0 - do i1 = 1,nbonall - nbon = nbon+1 - - if (nbon.gt.nbomax) then - write (6,*)nbon,nbomax - write (6,*)'nbon = ',nbon,' reax_defs.h::NBOMAXDEF = ', - $ NBOMAXDEF,' after',i1, ' of ',nbonall, - $ ' initial bonds completed.' - stop 'Too many pruned bonds; increase NBOMAXDEF' - end if - - ib(nbon,1) = iball(i1,1) - ib(nbon,2) = iball(i1,2) - ib(nbon,3) = iball(i1,3) - end do - - endif - - do i1=1,na - do i2=2,mbond+2 - ia(i1,i2)=0 - iag(i1,i2)=0 - end do - end do - -* Generate full set of bond data structures - - do 10 i0 = 1,nbon - i1 = ib(i0,2) - i2 = ib(i0,3) - call dista2(i1,i2,dis,dxm,dym,dzm) -* do 10 i1=1,na-1 -* do 10 i2=i1+1,na -* call dista2(i1,i2,dis,dxm,dym,dzm) - ih1=ia(i1,1) - ih2=ia(i2,1) -* if (dis.gt.5.0*rob) goto 10 - disdx=dxm/dis - disdy=dym/dis - disdz=dzm/dis - itype=0 - if (ih1.gt.ih2) then - ih1=ia(i2,1) - ih2=ia(i1,1) - end if - do i3=1,nboty2 - if (ih1.eq.nbs(i3,1).and.ih2.eq.nbs(i3,2)) itype=i3 - end do - if (itype.eq.0.and.rat(ih1).gt.zero.and.rat(ih2).gt.zero) then -c$$$ call mdsav(1,qfile(nprob)) - write (*,*)qa(i1),'-',qa(i2),'Fatal: Unknown bond in molecule' - stop - end if - - rhulp=dis/rob1(ih1,ih2) - -********************************************************************** -* * -* Determine bond orders * -* * -********************************************************************** - rh2=zero - rh2p=zero - rh2pp=zero - ehulp=zero - ehulpp=zero - ehulppp=zero - if (rapt(ih1).gt.zero.and.rapt(ih2).gt.zero) then - rhulp2=dis/rob2(ih1,ih2) - rh2p=rhulp2**ptp(itype) - ehulpp=exp(pdp(itype)*rh2p) - end if - if (vnq(ih1).gt.zero.and.vnq(ih2).gt.zero) then - rhulp3=dis/rob3(ih1,ih2) - rh2pp=rhulp3**popi(itype) - ehulppp=exp(pdo(itype)*rh2pp) - end if - - if (rat(ih1).gt.zero.and.rat(ih2).gt.zero) then - rh2=rhulp**bop2(itype) - ehulp=(1.0+cutoff)*exp(bop1(itype)*rh2) - end if - - bor=ehulp+ehulpp+ehulppp - borsi=ehulp - borpi=ehulpp - borpi2=ehulppp - dbordrob=bop2(itype)*bop1(itype)*rh2*(1.0/dis)*ehulp+ - $ptp(itype)*pdp(itype)*rh2p*(1.0/dis)*ehulpp+ - $popi(itype)*pdo(itype)*rh2pp*(1.0/dis)*ehulppp - dborsidrob=bop2(itype)*bop1(itype)*rh2*(1.0/dis)*ehulp - dborpidrob=ptp(itype)*pdp(itype)*rh2p*(1.0/dis)*ehulpp - dborpi2drob=popi(itype)*pdo(itype)*rh2pp*(1.0/dis)*ehulppp - - nbon2=nbon2+1 - j1=i1 - j2=i2 - -********************************************************************** -* * -* Determine bond orders * -* * -********************************************************************** - ib(i0,1)=itype - ib(i0,2)=j1 - ib(i0,3)=j2 - ibsym(i0)=ivl - drdc(i0,1,1)=disdx - drdc(i0,2,1)=disdy - drdc(i0,3,1)=disdz - drdc(i0,1,2)=-disdx - drdc(i0,2,2)=-disdy - drdc(i0,3,2)=-disdz - abo(i1)=abo(i1)+bor-cutoff - if (i1.ne.i2) abo(i2)=abo(i2)+bor-cutoff - bo(i0)=bor-cutoff - bos(i0)=bor-cutoff - bosi(i0)=borsi-cutoff - bopi(i0)=borpi - bopi2(i0)=borpi2 - rbo(i0)=dis - dbodr(i0)=dbordrob -* dbosidr(i0)=dborsidrob - dbopidr(i0)=dborpidrob - dbopi2dr(i0)=dborpi2drob - dbodc(i0,1,1)=dbodr(i0)*drdc(i0,1,1) - dbodc(i0,2,1)=dbodr(i0)*drdc(i0,2,1) - dbodc(i0,3,1)=dbodr(i0)*drdc(i0,3,1) - dbodc(i0,1,2)=dbodr(i0)*drdc(i0,1,2) - dbodc(i0,2,2)=dbodr(i0)*drdc(i0,2,2) - dbodc(i0,3,2)=dbodr(i0)*drdc(i0,3,2) -* dbosidc(i0,1,1)=dbosidr(i0)*drdc(i0,1,1) -* dbosidc(i0,2,1)=dbosidr(i0)*drdc(i0,2,1) -* dbosidc(i0,3,1)=dbosidr(i0)*drdc(i0,3,1) -* dbosidc(i0,1,2)=dbosidr(i0)*drdc(i0,1,2) -* dbosidc(i0,2,2)=dbosidr(i0)*drdc(i0,2,2) -* dbosidc(i0,3,2)=dbosidr(i0)*drdc(i0,3,2) - dbopidc(i0,1,1)=dbopidr(i0)*drdc(i0,1,1) - dbopidc(i0,2,1)=dbopidr(i0)*drdc(i0,2,1) - dbopidc(i0,3,1)=dbopidr(i0)*drdc(i0,3,1) - dbopidc(i0,1,2)=dbopidr(i0)*drdc(i0,1,2) - dbopidc(i0,2,2)=dbopidr(i0)*drdc(i0,2,2) - dbopidc(i0,3,2)=dbopidr(i0)*drdc(i0,3,2) - dbopi2dc(i0,1,1)=dbopi2dr(i0)*drdc(i0,1,1) - dbopi2dc(i0,2,1)=dbopi2dr(i0)*drdc(i0,2,1) - dbopi2dc(i0,3,1)=dbopi2dr(i0)*drdc(i0,3,1) - dbopi2dc(i0,1,2)=dbopi2dr(i0)*drdc(i0,1,2) - dbopi2dc(i0,2,2)=dbopi2dr(i0)*drdc(i0,2,2) - dbopi2dc(i0,3,2)=dbopi2dr(i0)*drdc(i0,3,2) - ia(i1,2)=ia(i1,2)+1 - if (i1.ne.i2) ia(i2,2)=ia(i2,2)+1 - ia(i1,ia(i1,2)+2)=i2 - ia(i2,ia(i2,2)+2)=i1 - if (ia(i1,2).gt.nsbma2) nsbma2=ia(i1,2) - if (ia(i2,2).gt.nsbma2) nsbma2=ia(i2,2) - if (bor.gt.cutof3) then - iag(i1,2)=iag(i1,2)+1 - iag(i2,2)=iag(i2,2)+1 - iag(i1,iag(i1,2)+2)=i2 - iag(i2,iag(i2,2)+2)=i1 - nubon1(i1,iag(i1,2))=i0 - nubon1(i2,iag(i2,2))=i0 - if (iag(i1,2).gt.nsbmax) nsbmax=iag(i1,2) - if (iag(i2,2).gt.nsbmax) nsbmax=iag(i2,2) - end if - nubon2(i1,ia(i1,2))=i0 - nubon2(i2,ia(i2,2))=i0 - - 10 continue - -********************************************************************** -* * -* Sort molecules * -* * -********************************************************************** - imolde = 1 - if (imolde.eq.1) return !fixed molecular definitions - - FOUND=.FALSE. - DO 31 K1=1,NA - IF (IA(K1,3+mbond).EQ.0) FOUND=.TRUE. - 31 IF (IA(K1,3+mbond).GT.NMOLO) NMOLO=IA(K1,3+mbond) - IF (.NOT.FOUND) GOTO 32 -************************************************************************ -* * -* Molecule numbers are assigned. No restrictions are made for the * -* sequence of the numbers in the connection table. * -* * -************************************************************************ - N3=1 - 34 N2=N3 - NMOLO=NMOLO+1 - if (nmolo.gt.nmolmax) then - write (*,*)nmolmax - write (*,*)'Too many molecules in system; increase nmolmax' - write (*,*)'nmolmax = ',nmolmax - write (*,*)'nmolo = ',nmolo - write (*,*)'n2 = ',n2 - stop 'Too many molecules in system' - end if - IA(N2,3+mbond)=NMOLO - 37 FOUND=.FALSE. - DO 36 N1=N2+1,NA - IF (IA(N1,3+mbond).NE.0) GOTO 36 - DO 35 L=1,mbond - IF (IA(N1,l+2).EQ.0) GOTO 36 - IF (IA(IA(N1,l+2),3+mbond).EQ.NMOLO) THEN - FOUND=.TRUE. - IA(N1,3+mbond)=NMOLO - GOTO 36 - ENDIF - 35 CONTINUE - 36 CONTINUE - IF (FOUND) GOTO 37 - DO 33 N3=N2+1,NA - 33 IF (IA(N3,3+mbond).EQ.0) GOTO 34 -************************************************************************ -* * -* The assigned or input molecule numbers are checked for their * -* consistency. * -* * -************************************************************************ - 32 FOUND=.FALSE. - DO 42 N1=1,NA - DO 41 L=1,mbond - IF (IA(N1,L+2).EQ.0) GOTO 42 - IF (IA(IA(N1,L+2),3+mbond).NE.IA(N1,3+mbond)) THEN - FOUND=.TRUE. - ENDIF - 41 CONTINUE - 42 CONTINUE - IF (FOUND) THEN - write (7,1000)NA,qmol - do i1=1,NA - write (7,1100)i1,ia(i1,1),(ia(i1,2+i2),i2=1,nsbmax), - $ia(i1,3+mbond) - end do - write (7,*)tm11,tm22,tm33,angle(1),angle(2),angle(3) - STOP' Mol.nrs. not consistent; maybe wrong cell parameters' - end if -********************************************************************** -* * -* Sort molecules again * -* This sort is on iag, enforces bond order cutoff * -* * -********************************************************************** - FOUND=.FALSE. - DO 61 K1=1,NA - IF (IAG(K1,3+mbond).EQ.0) FOUND=.TRUE. - 61 IF (IAG(K1,3+mbond).GT.NMOLO5) NMOLO5=IAG(K1,3+mbond) - IF (.NOT.FOUND) GOTO 62 -************************************************************************ -* * -* Molecule numbers are assigned. No restrictions are made for the * -* sequence of the numbers in the connection table. * -* * -************************************************************************ - N3=1 - 64 N2=N3 - NMOLO5=NMOLO5+1 - if (nmolo5.gt.nmolmax) stop 'Too many molecules in system' - IAG(N2,3+mbond)=NMOLO5 - 67 FOUND=.FALSE. - DO 66 N1=N2+1,NA - IF (IAG(N1,3+mbond).NE.0) GOTO 66 - DO 65 L=1,mbond - IF (IAG(N1,l+2).EQ.0) GOTO 66 - IF (IAG(IAG(N1,l+2),3+mbond).EQ.NMOLO5) THEN - FOUND=.TRUE. - IAG(N1,3+mbond)=NMOLO5 - GOTO 66 - ENDIF - 65 CONTINUE - 66 CONTINUE - IF (FOUND) GOTO 67 - DO 63 N3=N2+1,NA - 63 IF (IAG(N3,3+mbond).EQ.0) GOTO 64 -************************************************************************ -* * -* The assigned or input molecule numbers are checked for their * -* consistency. * -* * -************************************************************************ - 62 FOUND=.FALSE. - DO 72 N1=1,NA - DO 71 L=1,mbond - IF (IAG(N1,L+2).EQ.0) GOTO 72 - IF (IAG(IAG(N1,L+2),3+mbond).NE.IAG(N1,3+mbond)) THEN - FOUND=.TRUE. - ENDIF - 71 CONTINUE - 72 CONTINUE - IF (FOUND) THEN - write (7,1000)NA,qmol - do i1=1,NA - write (7,1100)i1,iag(i1,1),(iag(i1,2+i2),i2=1,nsbmax), - $iag(i1,3+mbond) - end do - write (7,*)tm11,tm22,tm33,angle(1),angle(2),angle(3) - STOP' Mol.nrs. not consistent; maybe wrong cell parameters' - ENDIF - -********************************************************************** -* * -* Format part * -* * -********************************************************************** - 1000 format (i3,2x,a60) - 1100 format (8i3) - end -********************************************************************** -********************************************************************** - - subroutine srtang - -********************************************************************** -#include "cbka.blk" -#include "cbkbo.blk" -#include "cbknubon2.blk" -#include "cbkff.blk" -#include "cbkia.blk" -#include "cbkrbo.blk" -#include "cbkvalence.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "small.blk" - - dimension a(3),b(3),j(3) - dimension ityva(100) - -********************************************************************** -* * -* Find valency angles in molecule * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In srtang' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - - nval=0 - if (nvaty.eq.0) return - do iindexatom=1,na - inumbonds=ia(iindexatom,2) - do jindexbond=1,inumbonds-1 - jindexbondlist = nubon2(iindexatom,jindexbond) - if (bo(jindexbondlist).lt.cutof2) goto 51 - k4=ib(jindexbondlist,2) - k5=ib(jindexbondlist,3) - do kindexbond=jindexbond+1,inumbonds - kindexbondlist = nubon2(iindexatom,kindexbond) - iju=0 - if (bo(kindexbondlist).lt.cutof2) goto 50 - if (bo(jindexbondlist)*bo(kindexbondlist).lt.0.001) goto 50 - k7=ib(kindexbondlist,2) - k8=ib(kindexbondlist,3) - -* Exclude angles that have no local atoms. -* Angles with non-local center atom are not needed for angle -* energies, but are needed to construct torsions. - if ( k4 .le. na_local .or. - $ k5 .le. na_local .or. - $ k7 .le. na_local .or. - $ k8 .le. na_local) then - - if (k4.eq.k7.and.k5.eq.k8.and.k4.ne.k8.and.k5.ne.k7) then - nval=nval+1 - iv(nval,2)=k5 - iv(nval,3)=k4 - iv(nval,4)=k8 - iv(nval,5)=jindexbondlist - iv(nval,6)=kindexbondlist - nval=nval+1 - iv(nval,2)=k4 - iv(nval,3)=k5 - iv(nval,4)=k7 - iv(nval,5)=jindexbondlist - iv(nval,6)=kindexbondlist - iju=2 - write(6,*) 'Aaaah!' - end if - if (iju.eq.2) goto 50 - - if (k4.eq.k8.and.k5.eq.k7.and.k4.ne.k7.and.k5.ne.k8) then - nval=nval+1 - iv(nval,2)=k5 - iv(nval,3)=k4 - iv(nval,4)=k7 - iv(nval,5)=jindexbondlist - iv(nval,6)=kindexbondlist - nval=nval+1 - iv(nval,2)=k4 - iv(nval,3)=k5 - iv(nval,4)=k8 - iv(nval,5)=jindexbondlist - iv(nval,6)=kindexbondlist - iju=2 - write(6,*) 'Aaaah!' - end if - if (iju.eq.2) goto 50 - - if (k4.eq.k7) then - nval=nval+1 - iv(nval,2)=k5 - iv(nval,3)=k4 - iv(nval,4)=k8 - iv(nval,5)=jindexbondlist - iv(nval,6)=kindexbondlist - iju=1 - end if - if (iju.eq.1) goto 50 - - if (k4.eq.k8) then - nval=nval+1 - iv(nval,2)=k5 - iv(nval,3)=k4 - iv(nval,4)=k7 - iv(nval,5)=jindexbondlist - iv(nval,6)=kindexbondlist - iju=1 - end if - if (iju.eq.1) goto 50 - - if (k5.eq.k7) then - nval=nval+1 - iv(nval,2)=k4 - iv(nval,3)=k5 - iv(nval,4)=k8 - iv(nval,5)=jindexbondlist - iv(nval,6)=kindexbondlist - iju=1 - end if - if (iju.eq.1) goto 50 - - if (k5.eq.k8) then - nval=nval+1 - iv(nval,2)=k4 - iv(nval,3)=k5 - iv(nval,4)=k7 - iv(nval,5)=jindexbondlist - iv(nval,6)=kindexbondlist - iju=1 - end if - if (iju.eq.1) goto 50 - - write (6,*)'nval = ',nval, - $ ' after',iindexatom, ' of ',na,' atoms completed.' - stop 'Adjacent bonds did not make an angle' - - endif - - 50 continue - - if (nval.gt.nvamax) then - write (6,*)'nval = ',nval,' reax_defs.h::NVAMAXDEF = ', - $ NVAMAXDEF, - $ ' after',iindexatom, ' of ',na,' atoms completed.' - stop 'Too many valency angles. Increase NVAMAXDEF' - endif - - if (iju.gt.0) then -********************************************************************** -* * -* Determine force field types of angles * -* * -********************************************************************** - ityva(1)=0 - ih1=ia(iv(nval,2),1) - ih2=ia(iv(nval,3),1) - ih3=ia(iv(nval,4),1) - if (ih3.lt.ih1) then - ih3=ia(iv(nval,2),1) - ih2=ia(iv(nval,3),1) - ih1=ia(iv(nval,4),1) - end if - - nfound=0 - do i3=1,nvaty - if (ih1.eq.nvs(i3,1).and.ih2.eq.nvs(i3,2).and. - $ih3.eq.nvs(i3,3)) then - nfound=nfound+1 - ityva(nfound)=i3 - end if - end do - - if (ityva(1).eq.0.or.abs(vka(ityva(1))).lt.0.001) then !Valence angle does not exist in force field;ignore - nval=nval-1 - ihul=0 - else - iv(nval,1)=ityva(1) - ihul=1 - - do i3=1,nfound-1 !Found multiple angles of the same type - nval=nval+1 - iv(nval,1)=ityva(i3+1) - do i4=2,6 - iv(nval,i4)=iv(nval-1,i4) - end do - - end do - - end if - - if (iju.eq.2) then - ityva(1)=0 - ih1=ia(iv(nval-ihul,2),1) - ih2=ia(iv(nval-ihul,3),1) - ih3=ia(iv(nval-ihul,4),1) - if (ih3.lt.ih1) then - ih3=ia(iv(nval-ihul,2),1) - ih2=ia(iv(nval-ihul,3),1) - ih1=ia(iv(nval-ihul,4),1) - end if - - nfound=0 - do i3=1,nvaty - if (ih1.eq.nvs(i3,1).and.ih2.eq.nvs(i3,2).and. - $ih3.eq.nvs(i3,3)) then - nfound=nfound+1 - ityva(nfound)=i3 - end if - end do - - if (ityva(1).eq.0.or.abs(vka(ityva(1))).lt.0.001) then !Valence angle does not exist in force field;ignore - if (ihul.eq.1) then - do i3=1,6 - iv(nval-1,i3)=iv(nval,i3) - end do - end if - nval=nval-1 - else - iv(nval-ihul,1)=ityva(1) - - do i3=1,nfound-1 !Found multiple angles of the same type - nval=nval+1 - iv(nval,1)=ityva(i3+1) - do i4=2,6 - iv(nval,i4)=iv(nval-1,i4) - end do - - end do - - end if - - end if - - end if - - end do - 51 continue - end do - end do - - nbonop=0 - - return - end -********************************************************************** -********************************************************************** - - subroutine srttor - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkbo.blk" -#include "cbkrbo.blk" -#include "cbkia.blk" -#include "cbktorsion.blk" -#include "cbkvalence.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "small.blk" -#include "cbknubon2.blk" -********************************************************************** -* * -* Find torsion angles in molecule * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$ open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In srttor' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - ntor=0 - if (ntoty.eq.0) return - do 61 i1=1,nbon - k2=ib(i1,2) - k3=ib(i1,3) -c Only compute interaction if both atoms local -c are local or else flip a coin - if (k2 .gt. na_local) go to 61 - if (k3 .gt. na_local) then - if (itag(k2) .lt. itag(k3)) go to 61 - if (itag(k2) .eq. itag(k3)) then - if(c(k2,3) .gt. c(k3,3)) go to 61 - if(c(k2,3) .eq. c(k3,3) .and. - $ c(k2,2) .gt. c(k3,2)) go to 61 - if(c(k2,3) .eq. c(k3,3) .and. - $ c(k2,2) .eq. c(k3,2) .and. - $ c(k2,1) .gt. c(k3,1)) go to 61 - endif - endif - - iob1=ia(k2,2) - iob2=ia(k3,2) - do 60 i2=1,iob1 !Atoms connected to k2 - k4=ia(k2,2+i2) - ibo2=nubon2(k2,i2) - do 60 i3=1,iob2 !Atoms connected to k3 - k5=ia(k3,2+i3) - ibo3=nubon2(k3,i3) - bopr=bo(i1)*bo(ibo2)*bo(ibo3) - if (bopr.gt.cutof2.and.k2.ne.k5.and.k3.ne.k4.and.k4.ne.k5) then - - ntor=ntor+1 - it(ntor,2)=k4 - it(ntor,3)=k2 - it(ntor,4)=k3 - it(ntor,5)=k5 - it(ntor,6)=ibo2 - it(ntor,7)=i1 - it(ntor,8)=ibo3 - -********************************************************************** -* * -* Determine force field types of torsion angles * -* * -********************************************************************** - ity=0 - ih1=ia(it(ntor,2),1) - ih2=ia(it(ntor,3),1) - ih3=ia(it(ntor,4),1) - ih4=ia(it(ntor,5),1) - - if (ih2.gt.ih3) then - ih1=ia(it(ntor,5),1) - ih2=ia(it(ntor,4),1) - ih3=ia(it(ntor,3),1) - ih4=ia(it(ntor,2),1) - end if - - if (ih2.eq.ih3.and.ih4.lt.ih1) then - ih1=ia(it(ntor,5),1) - ih2=ia(it(ntor,4),1) - ih3=ia(it(ntor,3),1) - ih4=ia(it(ntor,2),1) - end if - - do i4=1,ntoty - if (ih1.eq.nts(i4,1).and.ih2.eq.nts(i4,2).and.ih3.eq.nts(i4,3) - $.and.ih4.eq.nts(i4,4)) ity=i4 - end do - - if (ity.eq.0) then - do i4=1,ntoty - if (nts(i4,1).eq.0.and.ih2.eq.nts(i4,2).and.ih3.eq.nts(i4,3) - $.and.nts(i4,4).eq.0) ity=i4 - end do - end if - - if (ity.eq.0) then - ntor=ntor-1 !Torsion angle does not exist in force field: ignore - else - it(ntor,1)=ity - end if - - end if - - 60 continue - 61 continue - - if (ntor.gt.ntomax) stop 'Too many torsion angles' -* do i1=1,ntor -* write (41,'(20i4)')i1,it(i1,1),it(i1,2),it(i1,3), -* $it(i1,4),it(i1,5),it(i1,6),it(i1,7),it(i1,8) -* end do - - return - end -********************************************************************** -********************************************************************** - - subroutine srtoop - -********************************************************************** -#include "cbka.blk" -#include "cbkbo.blk" -#include "cbkrbo.blk" -#include "cbkvalence.blk" -#include "control.blk" -#include "small.blk" -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In srtoop' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if -********************************************************************** -* * -* Find out of plane angles in molecule * -* * -********************************************************************** - noop=0 - do i1=1,nval - k2=iv(i1,2) - k3=iv(i1,3) - k4=iv(i1,4) - k5=iv(i1,5) - k6=iv(i1,6) - do i2=1,nbon - k7=ib(i2,2) - k8=ib(i2,3) - if (bo(i2).gt.cutof2) then - if (k7.eq.k3.and.k8.ne.k4.and.k8.ne.k2) then - noop=noop+1 - ioop(noop,2)=k8 - ioop(noop,3)=k3 - ioop(noop,4)=k2 - ioop(noop,5)=k4 - ioop(noop,6)=i2 - ioop(noop,7)=iv(i1,5) - ioop(noop,8)=iv(i1,6) - ioop(noop,9)=i1 - end if - if (k8.eq.k3.and.k7.ne.k4.and.k7.ne.k2) then - noop=noop+1 - ioop(noop,2)=k7 - ioop(noop,3)=k3 - ioop(noop,4)=k2 - ioop(noop,5)=k4 - ioop(noop,6)=i2 - ioop(noop,7)=iv(i1,5) - ioop(noop,8)=iv(i1,6) - ioop(noop,9)=i1 - end if - end if - end do - end do - - do i1=1,noop - call caltor(ioop(i1,2),ioop(i1,3),ioop(i1,4),ioop(i1,5),hoop) - end do - -********************************************************************** - return - end -********************************************************************** - -********************************************************************** - - subroutine srthb - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkbo.blk" -#include "cbkconst.blk" -#include "cbkia.blk" -#include "cbkrbo.blk" -#include "cbksrthb.blk" -#include "control.blk" -#include "small.blk" -#include "cbkpairs.blk" -#include "cbknvlown.blk" -#include "cbknubon2.blk" -********************************************************************** -* * -* Find hydrogen bonds in molecule * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$ open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In srthb' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - nhb=0 -********************************************************************** -* * -* Locate donor/acceptor bonds * -* * -********************************************************************** -c Outer loop must be Verlet list, because ia() does not store Verlet entries, -c but it does store bond entries in nubon2() -c -c The problem with using the nvlown ownership criterion -c is that it would require that we unprune every bond that is within -c certain distance, as well as its first and second neighbor bonds. -c -c For the ownership criterion based on H atom location no unpruning is required. -c Apparently lprune=4 is sufficient here, implying that we need to capture first and -c second neighbor bonds of the O-H bond, and of course we need to include all hydrogen -c bond partners within hbcut. -c - - do 20 ivl=1,nvpair !Use Verlet-list to find donor-acceptor pairs - - j1=nvl1(ivl) - j2=nvl2(ivl) - ity1=ia(j1,1) - ity2=ia(j2,1) - ihhb1=nphb(ia(j1,1)) - ihhb2=nphb(ia(j2,1)) - - if (ihhb1.gt.ihhb2) then !Make j1 donor(H) atom and j2 acceptor(O) atom - j2=nvl1(ivl) - j1=nvl2(ivl) - ity1=ia(j1,1) - ity2=ia(j2,1) - ihhb1=nphb(ia(j1,1)) - ihhb2=nphb(ia(j2,1)) - end if - -* Only need to compute bonds where j1 is local - if (j1 .le. na_local) then - - if (ihhb1.eq.1.and.ihhb2.eq.2) then - call dista2(j1,j2,dishb,dxm,dym,dzm) - if (dishb.lt.hbcut) then - do 10 i23=1,ia(j1,2) !Search for acceptor atoms bound to donor atom - j3=ia(j1,2+i23) - ity3=ia(j3,1) - nbohb=nubon2(j1,i23) - if (nphb(ity3).eq.2.and.j3.ne.j2.and.bo(nbohb).gt.0.01) then -********************************************************************** -* * -* Accept hydrogen bond and find hydrogen bond type * -* * -********************************************************************** - nhb=nhb+1 - - if (nhb.gt.nhbmax) then - write (*,*)nhb,nhbmax - write (*,*)'Maximum number of hydrogen bonds exceeded' - stop 'Maximum number of hydrogen bonds exceeded' - end if - - ihb(nhb,1)=0 - - do i3=1,nhbty - if (ity3.eq.nhbs(i3,1).and.ity1.eq.nhbs(i3,2).and.ity2.eq. - $nhbs(i3,3)) ihb(nhb,1)=i3 - end do - - if (ihb(nhb,1).eq.0) then !Hydrogen bond not in force field - nhb=nhb-1 -* write (*,*)'Warning: added hydrogen bond ',ity3,ity1,ity2 -* nhbty=nhbty+1 -* nhbs(nhbty,1)=ity3 -* nhbs(nhbty,2)=ity1 -* nhbs(nhbty,3)=ity2 -* rhb(nhbty)=2.70 -* dehb(nhbty)=zero -* vhb1(nhbty)=5.0 -* vhb2(nhbty)=20.0 -* ihb(nhb,1)=nhbty - end if - - ihb(nhb,2)=j3 - ihb(nhb,3)=j1 - ihb(nhb,4)=j2 - ihb(nhb,5)=nbohb - ihb(nhb,6)=k1 - ihb(nhb,7)=k2 - ihb(nhb,8)=k3 -* write (64,*)nhb,ihb(nhb,1),j3,j1,j2,nbohb,k1,k2,k3,bo(nbohb), -* $dishb - - end if - - 10 continue - - end if - end if - end if - 20 end do - -* stop 'end in srthb' - return - end -********************************************************************** diff --git a/lib/reax/reax_defs.h b/lib/reax/reax_defs.h deleted file mode 100644 index e28533fa9b..0000000000 --- a/lib/reax/reax_defs.h +++ /dev/null @@ -1,70 +0,0 @@ -#define PORTABLECOMMENTFLAG -#ifndef PORTABLECOMMENTFLAG -// This is just a way to have portable comments -// for both C++ and FORTRAN preprocessing. - /* ///:EOH~ */ - /* */ - /* This file contains array dimension parameters for all the main */ - /* ReaxFF data structures, some of which need to be directly accessed */ - /* by Grasp C++ functions. If they are set too small, the calculation */ - /* will run out of allocated memory. If they are set too big, the machine */ - /* will not be able to allocate enough memory. */ - /* */ - - /* NNEIGHMAXDEF = Max number of neighbors / NATDEF */ - /* NATDEF = Max number of atoms */ - /* NATTOTDEF = Max number of global atoms */ - /* NSORTDEF = Max number of atom types */ - /* MBONDDEF = Max number of bonds connected to one atom */ - /* NAVIBDEF = for 2nd derivatives */ - /* NBOTYMDEF = Max number of bond types */ - /* NVATYMDEF = Max number of valency angle types */ - /* NTOTYMDEF = Max number of torsion angle types */ - /* NHBTYMDEF = Max number of hydrogen bond types */ - /* NODMTYMDEF = Max number of off-diagonal Morse types */ - /* NBOALLMAXDEF = Max number of all bonds */ - /* NBOMAXDEF = Max number of bonds */ - /* NHBMAXDEF = Max number of hydrogen bonds */ - /* NVAMAXDEF = Max number of valency angles */ - /* NOPMAXDEF = Max number of out of plane angles */ - /* NTOMAXDEF = Max number of torsion angles */ - /* NPAMAXDEF = Max number of general parameters in force field */ - /* NMOLMAXDEF = Max number of molecules in system */ - /* NMOLSETDEF = Max number of molecules in training set */ - /* MRESTRADEF = Max number of restraints */ - /* MTREGDEF = Max number of temperature regimes */ - /* MTZONEDEF = Max number of temperature zones */ - /* MVREGDEF = Max number of volume regimes */ - /* MVZONEDEF = Max number of volume zones */ - /* MEREGDEF = Max number of electric field regimes */ - /* MEZONEDEF = Max number of electric field zones */ -#endif - -#define NNEIGHMAXDEF 120 -#define NATDEF 40000 -#define NATTOTDEF 39744 -#define NSORTDEF 20 -#define MBONDDEF 20 -#define NAVIBDEF 50 -#define NBOTYMDEF 200 -#define NVATYMDEF 200 -#define NTOTYMDEF 200 -#define NHBTYMDEF 200 -#define NODMTYMDEF 20 -#define NBOALLMAXDEF 180000 -#define NBOMAXDEF 90000 -#define NHBMAXDEF 400000 -#define NVAMAXDEF 300000 -#define NOPMAXDEF 00010 -#define NTOMAXDEF 65000 -#define NPAMAXDEF 50 -#define NMOLMAXDEF 2000 -#define NMOLSETDEF 1500 -#define MRESTRADEF 100 -#define MTREGDEF 100 -#define MTZONEDEF 5 -#define MVREGDEF 100 -#define MVZONEDEF 6 -#define MEREGDEF 100 -#define MEZONEDEF 3 - diff --git a/lib/reax/reax_inout.F b/lib/reax/reax_inout.F deleted file mode 100644 index 944400a968..0000000000 --- a/lib/reax/reax_inout.F +++ /dev/null @@ -1,3870 +0,0 @@ -********************************************************************** -* * -* REAXFF Reactive force field program * -* * -* Developed and written by Adri van Duin, duin@wag.caltech.edu * -* * -* Copyright (c) 2001-2010 California Institute of Technology * -* * -* This is an open-source program. Feel free to modify its * -* contents. Please keep me informed of any useful modification * -* or addition that you made. Please do not distribute this * -* program to others; if people are interested in obtaining * -* a copy of this program let them contact me first. * -* * -********************************************************************** -********************************************************************** - - subroutine ffinpt - -********************************************************************** -#include "cbka.blk" -#include "cbkboncor.blk" -#include "cbkconst.blk" -#include "cbkcovbon.blk" -#include "cbkff.blk" -#include "cbkfftorang.blk" -#include "cbknonbon.blk" -#include "cbksrthb.blk" -#include "cbktorsion.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "opt.blk" -#include "valang.blk" -#include "cbksrtbon1.blk" -#include "cbkchb.blk" - dimension rcore2(nsort),ecore2(nsort),acore2(nsort) -********************************************************************** -* * -* Read in force field * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In ffinpt' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - open (4,file='ffield.reax',status='old') - rewind (4) - iline=0 - read (4,'(a40)',end=990,err=990)qffield - iline=iline+1 -********************************************************************** -* * -* Read in general force field parameters * -* * -********************************************************************** - read (4,1100,end=990,err=990)npar - iline=iline+1 - do i1=1,npar - read (4,1300,end=990,err=990)vpar(i1) - iline=iline+1 - end do - cutoff=0.01*vpar(30) - swa=vpar(12) - if (abs(swa).gt.0.01) write (*,*) - $'Warning: non-zero value for lower Taper-radius cutoff' - swb=vpar(13) - if (swb.lt.zero) stop - $'Negative value for upper Taper-radius cutoff' - if (swb.lt.5.0) write (*,*) - $'Warning: very low value for upper Taper-radius cutoff:',swb -********************************************************************** -* * -* Read in atom type data * -* * -********************************************************************** - read (4,1100,end=990,err=990) nso - iline=iline+1 - read (4,*,end=990,err=990) - iline=iline+1 - read (4,*,end=990,err=990) - iline=iline+1 - read (4,*,end=990,err=990) - iline=iline+1 - if (nso.gt.nsort) stop 'Maximum number of atom types exceeded' - do i1=1,nso - read (4,1200,end=990,err=990)qas(i1),rat(i1),aval(i1),amas(i1), - $rvdw(i1),eps(i1),gam(i1),rapt(i1),stlp(i1) - iline=iline+1 - read (4,1250,end=990,err=990)alf(i1),vop(i1),valf(i1), - $valp1(i1),valp2(i1),chi(i1),eta(i1),vnphb - iline=iline+1 - read (4,1250,end=990,err=990)vnq(i1),vlp1(i1),vincr(i1), - $bo131(i1),bo132(i1),bo133(i1),sigqeq(i1),default - iline=iline+1 - read (4,1250,end=990,err=990)vovun(i1),vval1(i1),vrom, - $vval3(i1),vval4(i1),rcore2(i1),ecore2(i1),acore2(i1) - iline=iline+1 - idef(i1)=int(default) - nphb(i1)=int(vnphb) - end do -********************************************************************** -* * -* Calculate van der Waals and Coulomb pair-parameters * -* * -********************************************************************** - do i1=1,nso - do i2=1,nso - rcore(i1,i2)=sqrt(rcore2(i1)*rcore2(i2)) - ecore(i1,i2)=sqrt(ecore2(i1)*ecore2(i2)) - acore(i1,i2)=sqrt(acore2(i1)*acore2(i2)) - p1co(i1,i2)=sqrt(4.0*rvdw(i1)*rvdw(i2)) - p2co(i1,i2)=sqrt(eps(i1)*eps(i2)) - p3co(i1,i2)=sqrt(alf(i1)*alf(i2)) - gamwh=sqrt(vop(i1)*vop(i2)) - gamwco(i1,i2)=1.0/gamwh**vpar(29) - gamch=sqrt(gam(i1)*gam(i2)) - gamcco(i1,i2)=1.0/gamch**3 - rob1(i1,i2)=0.50*(rat(i1)+rat(i2)) - rob2(i1,i2)=0.50*(rapt(i1)+rapt(i2)) - rob3(i1,i2)=0.50*(vnq(i1)+vnq(i2)) - end do - end do -********************************************************************** -* * -* Read in bond type data * -* * -********************************************************************** - read (4,1100,end=990,err=990)nboty - iline=iline+1 - read (4,*,end=990,err=990) - iline=iline+1 - if (2*nboty.gt.nbotym) stop 'Maximum nr. of bond types exceeded' - ih=0 - do i1=1,nboty - ih=ih+1 - read (4,1400,end=990,err=990)nbs(ih,1),nbs(ih,2),de1(ih), - $de2(ih),de3(ih),psi(ih),pdo(ih),v13cor(ih),popi(ih),vover(ih) - iline=iline+1 - read (4,1450,end=990,err=990)psp(ih),pdp(ih),ptp(ih), - $bom(ih),bop1(ih),bop2(ih),ovc(ih),vuncor(ih) - iline=iline+1 - if (nbs(ih,1).ne.nbs(ih,2)) then - ih=ih+1 - nbs(ih,1)=nbs(ih-1,2) - nbs(ih,2)=nbs(ih-1,1) - de1(ih)=de1(ih-1) - de2(ih)=de2(ih-1) - de3(ih)=de3(ih-1) - psi(ih)=psi(ih-1) - pdo(ih)=pdo(ih-1) - v13cor(ih)=v13cor(ih-1) - vover(ih)=vover(ih-1) - psp(ih)=psp(ih-1) - pdp(ih)=pdp(ih-1) - ptp(ih)=ptp(ih-1) - bop1(ih)=bop1(ih-1) - bop2(ih)=bop2(ih-1) -* bop3(ih)=bop3(ih-1) -* bop4(ih)=bop4(ih-1) - bom(ih)=bom(ih-1) - popi(ih)=popi(ih-1) - ovc(ih)=ovc(ih-1) - end if - end do - nboty2=ih -********************************************************************** -* * -* Read in off-diagonal parameters * -* * -********************************************************************** - read (4,1100,end=990,err=990)nodmty - iline=iline+1 - if (nodmty.gt.nodmtym) - $stop 'Maximum nr. of off-diagonal Morse types exceeded' - ih=0 - do i1=1,nodmty - ih=ih+1 - read (4,1400,end=990,err=990)nodm1,nodm2,deodmh,rodmh,godmh, - $rsig,rpi,rpi2 - iline=iline+1 - if (rsig.gt.zero) rob1(nodm1,nodm2)=rsig - if (rsig.gt.zero) rob1(nodm2,nodm1)=rsig - if (rpi.gt.zero) rob2(nodm1,nodm2)=rpi - if (rpi.gt.zero) rob2(nodm2,nodm1)=rpi - if (rpi2.gt.zero) rob3(nodm1,nodm2)=rpi2 - if (rpi2.gt.zero) rob3(nodm2,nodm1)=rpi2 - if (rodmh.gt.zero) p1co(nodm1,nodm2)=2.0*rodmh - if (rodmh.gt.zero) p1co(nodm2,nodm1)=2.0*rodmh - if (deodmh.gt.zero) p2co(nodm1,nodm2)=deodmh - if (deodmh.gt.zero) p2co(nodm2,nodm1)=deodmh - if (godmh.gt.zero) p3co(nodm1,nodm2)=godmh - if (godmh.gt.zero) p3co(nodm2,nodm1)=godmh - end do -********************************************************************** -* * -* Read in valency angle and conjugation type data * -* * -********************************************************************** - read (4,1100,end=990,err=990)nvaty - iline=iline+1 - if (nvaty.gt.nvatym) - $stop 'Maximum nr. of valency angle types exceeded' - do i1=1,nvaty - read (4,1500,end=990,err=990)nvs(i1,1),nvs(i1,2), - $nvs(i1,3),th0(i1),vka(i1),vka3(i1),vka8(i1),vkac(i1),vkap(i1), - $vval2(i1) - iline=iline+1 - end do -********************************************************************** -* * -* Read in torsion angle type data * -* * -********************************************************************** - read (4,1100,end=990,err=990)ntoty - iline=iline+1 - if (ntoty.gt.ntotym) - $stop 'Maximum nr. of torsion angle types exceeded' - do i1=1,ntoty - read (4,1600,end=990,err=990)nts(i1,1),nts(i1,2),nts(i1,3), - $nts(i1,4),v1(i1), - $v2(i1),v3(i1),v4(i1),vconj(i1),v2bo(i1),v3bo(i1) - iline=iline+1 - end do -********************************************************************** -* * -* Read in hydrogen bond type data * -* * -********************************************************************** - read (4,1100,end=990,err=990)nhbty - iline=iline+1 - if (nhbty.gt.nhbtym) - $stop 'Maximum nr. of hydrogen bond types exceeded' - do i1=1,nhbty - read (4,1500,end=990,err=990)nhbs(i1,1),nhbs(i1,2), - $nhbs(i1,3),rhb(i1),dehb(i1),vhb1(i1),vhb2(i1) - iline=iline+1 - end do -********************************************************************** -* * -* Calculate vdWaals interaction parameters * -* * -********************************************************************** - do i1=1,nso - do i2=1,nso - rr=(rvdw(i1)+rvdw(i2)) - rr2=rr*rr - eps2=sqrt(eps(i1)*eps(i2)) - rr6=rr2*rr2*rr2 - pvdw1(i1,i2)=eps2*rr6*rr6 - pvdw1(i2,i1)=eps2*rr6*rr6 - pvdw2(i1,i2)=2.0*eps2*rr6 - pvdw2(i2,i1)=2.0*eps2*rr6 - end do - end do -********************************************************************** -* * -* Error part * -* * -********************************************************************** - goto 999 - 990 write (*,*)'Error or end-of-file reading unit 4 on line:',iline - stop - 999 continue - close(4) -********************************************************************** -* * -* Format part * -* * -********************************************************************** - 1100 format (i3,2x,a2,3x,3d22.15) - 1200 format (1x,a2,10f9.4) - 1250 format (3x,10f9.4) - 1300 format (f10.4) - 1400 format (2i3,8f9.4) - 1450 format (6x,8f9.4) - 1500 format (3i3,7f9.4) - 1600 format (4i3,7f9.4) - return - end -********************************************************************** -*********************************************************************** - - subroutine mdsav(node) - -*********************************************************************** -#include "cbka.blk" -#include "cbkabo.blk" -#include "cbkatomcoord.blk" -#include "cbkbo.blk" -#include "cbkc.blk" -#include "cbkch.blk" -#include "cbkconst.blk" -#include "cbkdistan.blk" -#include "cbkenergies.blk" -#include "cbkia.blk" -#include "cbkinit.blk" -#include "cbklonpar.blk" -#include "cbknubon2.blk" -#include "cbkqa.blk" -#include "cbktregime.blk" -#include "cbksrtbon1.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "opt.blk" -#include "small.blk" - - dimension idum(mbond+3),bodum(mbond+3),qat2(2) - character*25 qfileh - character*33 qfile2 - character*4 qext - character*6 qmdfi - character *7 var - character *3 qat2,pepname - character *1 qrtemp -************************************************************************ -* * -* Save coordinates, velocities and accelerations of MD-system * -* * -************************************************************************ -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In mdsav' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - -************************************************************************ -c -c This is just for test purposes -c -************************************************************************ -c$$$ write(6,*) '***************************' -c$$$ write(6,*) 'mdsav node number is ',node -c$$$ write(6,*) '***************************' - return - - - qfileh='Unknown' - qmdfi='moldyn' - pepname=' ' - ipeptide=0 - if (ni.eq.2) qmdfi='molsav' - - if (iopt.eq.0) then - - do i1=1,mbond+3 - idum(i1)=nzero - bodum(i1)=zero - end do -C if (napp.eq.1) -C $open (7,file='fort.7',status='unknown',access='append') - if (napp.ne.1) - $open (7,file='fort.7',status='unknown') - nsbmaxh=5*((nsbmax/5)+1) - write (7,100)na,qmol,mdstep,nsbmaxh - if (nbiolab.eq.1) write (67,101)na,qmol - do i1=1,na - bosum=0.0 - do i3=1,nsbmax - if (iag(i1,2+i3).gt.0) bosum=bosum+bo(nubon1(i1,i3)) - end do - if (nsbmax.lt.5) then - write (7,200)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)), - $(idum(i2),i2=1,5-iag(i1,2)), - $iag(i1,3+mbond),(bo(nubon1(i1,i2)),i2=1,iag(i1,2)), - $(bodum(i2),i2=1,5-iag(i1,2)),abo(i1),vlp(i1),ch(i1) - if (nbiolab.eq.1) then !Delphi-connection table output - write (67,201)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)) - end if - else if (nsbmax.lt.10) then - write (7,210)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)), - $(idum(i2),i2=1,10-iag(i1,2)), - $iag(i1,3+mbond),(bo(nubon1(i1,i2)),i2=1,iag(i1,2)), - $(bodum(i2),i2=1,10-iag(i1,2)),abo(i1),vlp(i1),ch(i1) - else if (nsbmax.lt.15) then - write (7,220)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)), - $(idum(i2),i2=1,15-iag(i1,2)), - $iag(i1,3+mbond),(bo(nubon1(i1,i2)),i2=1,iag(i1,2)), - $(bodum(i2),i2=1,15-iag(i1,2)),abo(i1),vlp(i1),ch(i1) - else if (nsbmax.lt.20) then - write (7,230)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)), - $(idum(i2),i2=1,20-iag(i1,2)), - $iag(i1,3+mbond),(bo(nubon1(i1,i2)),i2=1,iag(i1,2)), - $(bodum(i2),i2=1,20-iag(i1,2)),abo(i1),vlp(i1),ch(i1) - else if (nsbmax.lt.25) then - write (7,240)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)), - $(idum(i2),i2=1,25-iag(i1,2)), - $iag(i1,3+mbond),(bo(nubon1(i1,i2)),i2=1,iag(i1,2)), - $(bodum(i2),i2=1,25-iag(i1,2)),abo(i1),vlp(i1),ch(i1) - else if (nsbmax.gt.25) then - write (7,250)i1,iag(i1,1),(iag(i1,2+i2),i2=1,iag(i1,2)), - $(idum(i2),i2=1,35-iag(i1,2)), - $iag(i1,3+mbond),(bo(nubon1(i1,i2)),i2=1,iag(i1,2)), - $(bodum(i2),i2=1,35-iag(i1,2)),abo(i1),vlp(i1),ch(i1) - end if - end do - boss=zero - vlps=0.0 -C if (napp.eq.1) -C $open (8,file='fort.8',status='unknown',access='append') - if (napp.ne.1) - $open (8,file='fort.8',status='unknown') - nsbmaxh=5*((nsbma2/5)+1) - write (8,100)na,qmol,mdstep,nsbmaxh - chsum=0.0 - do i1=1,na - bosum=0.0 - do i3=1,nsbma2 - if (ia(i1,2+i3).gt.0) bosum=bosum+bo(nubon2(i1,i3)) - end do - if (nsbma2.lt.5) then - write (8,200)i1,ia(i1,1),(ia(i1,2+i2),i2=1,ia(i1,2)), - $(idum(i2),i2=1,5-ia(i1,2)), - $ia(i1,3+mbond),(bo(nubon2(i1,i2)),i2=1,ia(i1,2)), - $(bodum(i2),i2=1,5-ia(i1,2)),abo(i1),vlp(i1),ch(i1) - else if (nsbma2.lt.10) then - write (8,210)i1,ia(i1,1),(ia(i1,2+i2),i2=1,ia(i1,2)), - $(idum(i2),i2=1,10-ia(i1,2)), - $ia(i1,3+mbond),(bo(nubon2(i1,i2)),i2=1,ia(i1,2)), - $(bodum(i2),i2=1,10-ia(i1,2)),abo(i1),vlp(i1),ch(i1) - else if (nsbma2.lt.15) then - write (8,220)i1,ia(i1,1),(ia(i1,2+i2),i2=1,ia(i1,2)), - $(idum(i2),i2=1,15-ia(i1,2)), - $ia(i1,3+mbond),(bo(nubon2(i1,i2)),i2=1,ia(i1,2)), - $(bodum(i2),i2=1,15-ia(i1,2)),abo(i1),vlp(i1),ch(i1) - else if (nsbma2.lt.20) then - write (8,230)i1,ia(i1,1),(ia(i1,2+i2),i2=1,ia(i1,2)), - $(idum(i2),i2=1,20-ia(i1,2)), - $ia(i1,3+mbond),(bo(nubon2(i1,i2)),i2=1,ia(i1,2)), - $(bodum(i2),i2=1,20-ia(i1,2)),abo(i1),vlp(i1),ch(i1) - else if (nsbma2.lt.25) then - write (8,240)i1,ia(i1,1),(ia(i1,2+i2),i2=1,ia(i1,2)), - $(idum(i2),i2=1,25-ia(i1,2)), - $ia(i1,3+mbond),(bo(nubon2(i1,i2)),i2=1,ia(i1,2)), - $(bodum(i2),i2=1,25-ia(i1,2)),abo(i1),vlp(i1),ch(i1) - end if - boss=boss+bosum/2.0 - vlps=vlps+vlp(i1) - chsum=chsum+ch(i1) - end do - write (7,*)2.0*boss,vlps,2.0*boss+2.0*vlps,chsum - close(8) - close(7) - - end if - - if (noutpt.eq.0) then - write (var,'(f7.4)')float(mdstep/nsav)/1d4 - if (ni.eq.0) open (unit=67,file=qmdfi//var(3:7), - $status='unknown') - write (67,300)qmol - do i1=1,na - write (67,400)i1,qa(i1),(c(i1,i2),i2=1,3) - end do - write (67,*) - close(67) - end if - - if (noutpt.eq.2) then -C open (88,file='moldyn.bgf',status='unknown',access='append') - call writebgf(88) - close (88) - end if - - if ((ni.eq.1.and.iopt.eq.0).or.(ni.eq.1.and.iopt.eq.1.and. - $iflga.eq.1)) then - qrtemp=qr - if (qr.eq.'I') qr='C' - if (qfileh.eq.' ') then - write (*,*)'Warning: no file name given; use Unknown' - qfileh='Unknown' - end if - qfile2=qfileh - if (imodfile.eq.0) then - istart=1 - qstrana1(1:25)=qfileh - call stranal(istart,iend,vout,iout,1) - qfile2=qfileh(istart:iend-1)//".geo" - end if - call writegeo(98) - - if (imodfile.eq.1.or.iopt.eq.0) then - open (88,file=qfile2,status='unknown') - call writegeo(88) - close (88) - end if - - qr=qrtemp - - if (iopt.eq.0) then - - do i1=1,na - write (56,410) i1,ch(i1) - write (55,410) i1,chgbgf(i1) - end do -********************************************************************** -* * -* Write .pdb output file * -* * -********************************************************************** - open (unit=47,file='output.pdb',status='unknown') - do i1=1,na - write (47,412)'ATOM ',i1,qa(i1),pepname,ipeptide,c(i1,1), - $c(i1,2),c(i1,3),1.0,2.2,qa(i1) - end do - write (47,*) 'TER' - write (47,*) 'END' - close (47) - - if (nsurp.eq.0) then - if (kx.gt.0.or.ky.gt.0.or.kz.gt.0) then - qrtemp=qr -********************************************************************** -* * -* Write crystal structure including periodic images * -* * -********************************************************************** -* mux=(1+kx+kx) -* muy=(1+ky+ky) -* muz=(1+kz+kz) -* qr='F' -* write (86,'(2x,a1,1x,a60)')qr,qmol -* qr=qrtemp -* write (86,'(3f10.4)')mux*axiss(1),muy*axiss(2),muz*axiss(3) -* write (86,'(3f10.4)')angle(1),angle(2),angle(3) -* do i1=1,na -* write (86,'(i4,1x,a2,3x,3d22.15)')i1,qa(i1),(c(i1,i2),i2=1,3) -* end do -* nhulp=na+1 -* do k1=-kx,kx -* do k2=-ky,ky -* do k3=-kz,kz -* if (k1.ne.0.or.k2.ne.0.or.k3.ne.0) then -* do i1=1,na -* cx=c(i1,1)+k1*tm11 -* cy=c(i1,2)+k1*tm21+k2*tm22 -* cz=c(i1,3)+k1*tm31+k2*tm32+k3*tm33 -* write (86,'(i4,1x,a2,3x,3d22.15)')nhulp,qa(i1),cx,cy,cz -* nhulp=nhulp+1 -* end do -* end if -* end do -* end do -* end do -* write (86,*) -********************************************************************** -* * -* Write crystal structure with extra unit cells * -* * -********************************************************************** - mux=1+iexx - muy=1+iexy - muz=1+iexz - qr='F' - write (85,'(2x,a1,1x,a60)')qr,qmol - qr=qrtemp - write (85,'(3f10.4)')mux*axiss(1),muy*axiss(2),muz*axiss(3) - write (85,'(3f10.4)')angle(1),angle(2),angle(3) - do i1=1,na - write (85,'(i4,1x,a2,3x,3d22.15)')i1,qa(i1),(c(i1,i2),i2=1,3) - end do - nhulp=na+1 - do k1=0,iexx - do k2=0,iexy - do k3=0,iexz - if (k1.ne.0.or.k2.ne.0.or.k3.ne.0) then - do i1=1,na - cx=c(i1,1)+k1*tm11 - cy=c(i1,2)+k1*tm21+k2*tm22 - cz=c(i1,3)+k1*tm31+k2*tm32+k3*tm33 - write (85,'(i4,1x,a2,3x,3d22.15)')nhulp,qa(i1),cx,cy,cz - nhulp=nhulp+1 - end do - end if - end do - end do - end do - write (85,*) - - end if - end if - end if - - end if - - if (ni.eq.0.or.ni.eq.2) then -********************************************************************** -* * -* Write ASCII trajectory file * -* * -********************************************************************** - if (ni.eq.0) open(unit=66,file=qmdfi//'.vel',status='unknown') - if (ni.eq.2) then - write (var,'(f7.4)')float(mdstep/nsav3)/1d4 - open (unit=66,file=qmdfi//var(3:7),status='unknown') - end if - write (66,500)axis(1),axis(2),axis(3) - write (66,550)angle(1),angle(2),angle(3) - write (66,600)na,((c(i,j),j=1,3),qlabel(i),i=1,na) - write (66,700)((vel(j,i),j=1,3),i=1,na) - write (66,800)((accel(j,i),j=1,3),i=1,na) - write (66,900)((aold(j,i),j=1,3),i=1,na) - write (66,1000)tempmd - write (66,1050) - close (66) - end if - if (ni.ne.2.and.iopt.eq.0) then - -C open (unit=68,file='xmolout',status='unknown',access='append') - write (68,1200)na - write (68,1300)qmol,mdstep+nit+nprevrun,estrc, - $axis(1),axis(2),axis(3),angle(1),angle(2),angle(3) - do i1=1,na - if (ixmolo.eq.0) write (68,1400)qa(i1),(c(i1,i2),i2=1,3) - if (ixmolo.eq.1) write (68,1400)qa(i1),(c(i1,i2),i2=1,3), - $(vel(i2,i1)/1e+10,i2=1,3),iag(i1,3+mbond) - if (ixmolo.eq.2) write (68,1401)qa(i1),(c(i1,i2),i2=1,3), - $iag(i1,3+mbond) - end do - close (68) - - if (itrout.ne.0) then -C open (unit=69,file='xmolout2',status='unknown',access='append') - write (69,1200)na - write (69,1300)qmol,mdstep+nit+nprevrun,estrc, - $axis(1),axis(2),axis(3),angle(1),angle(2),angle(3) - do i1=1,na - if (ixmolo.eq.0) write (69,1400)qa(i1),(cp(i1,i2),i2=1,3) - if (ixmolo.eq.1) write (69,1400)qa(i1),(cp(i1,i2),i2=1,3), - $(vel(i2,i1)/1e+10,i2=1,3),iag(i1,3+mbond) - if (ixmolo.eq.2) write (68,1401)qa(i1),(c(i1,i2),i2=1,3), - $iag(i1,3+mbond) - end do - close (69) - end if - - call molanal - end if -********************************************************************** -* * -* Generate BIOGRAF output-file * -* * -********************************************************************** - if ((ni.eq.1.and.iopt.eq.0).or.(ni.eq.1.and.iopt.eq.1.and. - $iflga.eq.1)) then - - if (qfileh.eq.' ') then - write (*,*)'Warning: no file name given; use Unknown' - qfileh='Unknown' - end if - qfile2=qfileh - if (imodfile.eq.0) then - istart=1 - qstrana1(1:25)=qfileh - call stranal(istart,iend,vout,iout,1) - qfile2=qfileh(istart:iend-1)//".bgf" - end if - call writebgf(90) - - if (imodfile.eq.1.or.iopt.eq.0) then - open (88,file=qfile2,status='unknown') - call writebgf(88) - close (88) - end if - - end if - - return -********************************************************************** -* * -* Format part * -* * -********************************************************************** - 100 format (i4,1x,a40,'Iteration:',i8,' #Bonds:',i4) - 101 format (i3,2x,a40) - 200 format (8i4,8f7.3) - 201 format (8i3) - 210 format (13i4,13f7.3) - 220 format (18i4,18f7.3) - 230 format (23i4,23f7.3) - 240 format (28i4,28f7.3) - 250 format (38i4,38f7.3) - 300 format (2x,a1,1x,a60) - 301 format (2x,a1,1x,f6.2,a60) - 302 format (2x,a1,1x,2f6.2,a60) - 310 format (2x,a1,1x,a60) - 320 format (3f10.4) - 400 format (i4,1x,a2,3x,3(d21.14,1x),1x,a5,1x,i5) - 410 format (i4,f12.6) - 412 format(A6,I5,1x,A2,3x,A3,2x,i4,4x,3f8.3,f6.2,f6.2,4x,2x,A6) - 500 format (1x,'Lattice parameters:',/(3f15.8)) - 550 format (3f15.8) - 600 format (i4,1x,'Atom coordinates (Angstrom):',/ - $(3d24.15,1x,a5)) - 700 format (1x,'Atom velocities (Angstrom/s):',/(3d24.15)) - 800 format (1x,'Atom accelerations (Angstrom/s**2):',/(3d24.15)) - 900 format (1x,'Previous atom accelerations:',/(3d24.15)) - 1000 format (1x,'MD-temperature (K):',/(1d24.15)) - 1050 format (1x,'Connections, bond orders and lone pairs:') - 1100 format (8i3,8f8.4) - 1200 format (i4) - 1300 format (a40,i6,f12.4,6f7.2) - 1400 format (a2,3f10.5,3f15.5,i6) - 1401 format (a2,3f10.5,i6) - 1500 format ('BIOGRF',i4) - 1600 format ('XTLGRF',i4) - 1700 format ('DESCRP ',a60) - 1800 format ('REMARK ',a60) - 1900 format ('FFIELD ',a40) - 2000 format ('RUTYPE ',a40) - 2100 format ('CRYSTX ',6f11.5) - 2200 format ('CELLS ',6i5) - 2300 format ('# At1 At2 R12 Force1 Force2 ', - $'dR12/dIteration(MD only)') - 2400 format ('BOND RESTRAINT ',2i4,f8.4,f8.2,f8.5,f10.7) - 2500 format ('# At1 At2 At3 Angle Force1 Force2', - $' dAngle/dIteration (MD only)') - 2600 format ('ANGLE RESTRAINT ',3i4,2f8.2,f8.4,f9.6) - 2700 format ('# At1 At2 At3 At3 Angle Force1 ', - $'Force2 dAngle/dIteration (MD only)') - 2800 format ('TORSION RESTRAINT ',4i4,2f8.2,f8.4,f9.6) - 2900 format ('FORMAT ATOM (a6,1x,i5,1x,a5,1x,a3,1x,a1,1x,a5,', - $'3f10.5,1x,a5,i3,i2,1x,f8.5)') - 3000 format ('HETATM',1x,i5,1x,a5,1x,a3,1x,a1,1x,a5,3f10.5,1x, - $a5,i3,i2,1x,f8.5) - 3100 format ('FORMAT CONECT (a6,12i6)') - 3200 format ('CONECT',12i6) - 3300 format ('UNIT ENERGY kcal') - 3400 format ('ENERGY',5x,f14.6) - 3500 format ('END') - end - -************************************************************************ -************************************************************************ - - subroutine readc - -************************************************************************ -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkcha.blk" -#include "cbkconst.blk" -#include "cbkdistan.blk" -#include "cbkinit.blk" -#include "cbktregime.blk" -#include "control.blk" -#include "opt.blk" -#include "small.blk" - - character*6 qident - character*20 qhulp -* dimension qident(100) -************************************************************************ -* * -* Read control file * -* * -************************************************************************ -c$$$c if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$c write (65,*) 'In readc' -c$$$c call timer(65) -c$$$c close (65) -c$$$c end if - if (mdstep.gt.0.or.nit.gt.0) nmmsav=nmm -************************************************************************ -* * -* Set default values * -* * -************************************************************************ - nreac=0 - axis1=200.0d0 - axis2=200.0d0 - axis3=200.0d0 - cutof2=0.001d0 - cutof3=0.300d0 - tsetor=298.0d0 - tset2=298.0d0 - pset=0.0d0 - tincr=0.0d0 - tstep=0.5d0 -* swa=0.0 !Moved to force field -* swb=12.5 !Moved to force field - taut=2.5d0 - taut2=2.5d0 - ndtau=50000 - taup=500.0d0 - vqnd=100.0d0 - errnh=1.0d0 - range=2.5d0 - maxstp=1000 - nequi=0 - nmethod=3 - ncha=3 - ncha2=1 - nchaud=1 - nvlist=25 - nrep1=5 - nsav=50 - icheck=0 - ivels=0 - itfix=0 - ncontrol=25 - noutpt=0 - napp=0 - nsurp=0 - ncons=2 - nrand=0 - nmm=0 - endpo=1.0d0 - endpo2=1.0d0 - nfc=50 - nsav2=50 - nmmax=50 - i5758=0 - parc1=1.0d0 - parc2=0.001d0 - icell=0 - ingeo=1 - ccpar=1.0005d0 - icelo2=0 - nrdd=0 - nrddf=200000 - nbiolab=0 -c ngeofor=0 - nincrop=0 - accerr=2.50d0 - vrange=2.50d0 - vlbora=5.00d0 - nsav3=1000 - nhop2=25 - nprevrun=0 - ndebug=0 - volcha=10.00d0 - ixmolo=0 - inpt=0 - iconne=0 - imolde=0 - ianaly=0 - icentr=0 - itrans=0 - itrout=0 - tpnrad=300.0d0 - ityrad=3 - iexx=1 - iexy=1 - iexz=1 - syscha=0.00d0 - inmov1=0 - inmov2=0 - vfield=0.00d0 - itstep=0 - ifreq=0 - isymm=1 - icpres=0 - delvib=0.0001d0 -c shock variables - shock_vel = 2.d0 ! impact velocity for shock simulations (nm/ps) - shock_z_sep = 10.0d0 ! separation z value to apply initial velocities in shocks - ishock_type = 0.0d0 ! shock type. 0: simple impact; 1: compressing c axis -c Hugoniostat variables - Hug_E0 = 0.d0 ! Reference energy - Hug_P0 = 0.d0 ! Reference pressure - Hug_V0 = 0.d0 ! Reference volume -c Shear flow simulations for viscosity - xImpVcm = 1.d0 ! velocity applied in shear simulations (in nm/ps), left half mover at -xImpVcm and right at +xImpVcm -c$$$************************************************************************ -c$$$* * -c$$$* Read control-file * -c$$$* * -c$$$************************************************************************ -c$$$ open (10,file='control',status='old') -c$$$ 10 read (10,'(a20)',end=20,err=30)qhulp -c$$$ if (qhulp(1:1).eq.'#') goto 10 -c$$$ read (qhulp,*,err=30)vhulp -c$$$ read (qhulp,'(8x,a6)',err=30)qident -c$$$ if (qident.eq.'Hug_V0') Hug_P0=vhulp -c$$$ if (qident.eq.'Hug_P0') Hug_V0=vhulp -c$$$ if (qident.eq.'Hug_E0') Hug_E0=vhulp -c$$$ if (qident.eq.'shea_v') xImpVcm=vhulp -c$$$ if (qident.eq.'shok_t') ishock_type=int(vhulp) -c$$$ if (qident.eq.'shok_z') shock_z_sep=vhulp -c$$$ if (qident.eq.'shok_v') shock_vel=vhulp -c$$$ if (qident.eq.'nreac') nreac=int(vhulp) -c$$$ if (qident.eq.'axis1') axis1=vhulp -c$$$ if (qident.eq.'axis2') axis2=vhulp -c$$$ if (qident.eq.'axis3') axis3=vhulp -c$$$ if (qident.eq.'cutof2') cutof2=vhulp -c$$$ if (qident.eq.'cutof3') cutof3=vhulp -c$$$ if (qident.eq.'mdtemp') tsetor=vhulp -c$$$ if (qident.eq.'mdtem2') tset2=vhulp -c$$$ if (qident.eq.'mdpres') pset=vhulp*0.001 -c$$$ if (qident.eq.'tincr') tincr=vhulp -c$$$ if (qident.eq.'tstep') tstep=vhulp -c$$$* if (qident.eq.'lowtap') swa=vhulp !Moved to force field -c$$$* if (qident.eq.'uptap') swb=vhulp !Moved to force field -c$$$ if (qident.eq.'tdamp1') taut=vhulp -c$$$ if (qident.eq.'tdamp2') taut2=vhulp -c$$$ if (qident.eq.'ntdamp') ndtau=int(vhulp) -c$$$ if (qident.eq.'pdamp1') taup=vhulp -c$$$ if (qident.eq.'tdhoov') vqnd=vhulp -c$$$ if (qident.eq.'achoov') errnh=vhulp/100.0 -c$$$ if (qident.eq.'range') range=vhulp -c$$$ if (qident.eq.'nmdit') maxstp=int(vhulp) -c$$$ if (qident.eq.'nmdeqi') nequi=int(vhulp) -c$$$ if (qident.eq.'imdmet') nmethod=int(vhulp) -c$$$ if (qident.eq.'icharg') ncha=int(vhulp) - nchaold=ncha -c$$$ if (qident.eq.'ichaen') ncha2=int(vhulp) -c$$$ if (qident.eq.'ichupd') nchaud=int(vhulp) -c$$$ if (qident.eq.'iout1') nrep1=int(vhulp) -c$$$ if (qident.eq.'iout2') nsav=int(vhulp) -c$$$ if (qident.eq.'icheck') ntest=int(vhulp) -c$$$ if (qident.eq.'ivels') nvel=int(vhulp) -c$$$ if (qident.eq.'itfix') ntscale=int(vhulp) -c$$$ if (qident.eq.'irecon') ncontrol=int(vhulp) -c$$$ if (qident.eq.'iout3') noutpt=int(vhulp) -c$$$ if (qident.eq.'iappen') napp=int(vhulp) -c$$$ if (qident.eq.'isurpr') nsurp=int(vhulp) -c$$$ if (qident.eq.'itdmet') ncons=int(vhulp) -c$$$ if (qident.eq.'iravel') nrand=int(vhulp) -c$$$ if (qident.eq.'imetho') nmm=int(vhulp) -c$$$ if (qident.eq.'endmm') endpo=vhulp - endpoold=endpo -c$$$ if (qident.eq.'endmd') endpo2=vhulp -c$$$ if (qident.eq.'imaxmo') nfc=int(vhulp) - nfcold=nfc -c$$$ if (qident.eq.'iout4') nsav2=int(vhulp) -c$$$ if (qident.eq.'imaxit') nmmax=int(vhulp) - nmmaxold=nmmax -c$$$ if (qident.eq.'iout5') i5758=int(vhulp) -c$$$ if (qident.eq.'parsca') parc1=vhulp -c$$$ if (qident.eq.'parext') parc2=vhulp -c$$$ if (qident.eq.'icelop') icell=int(vhulp) - icellold=icell -c$$$ if (qident.eq.'igeopt') ingeo=int(vhulp) -c$$$ if (qident.eq.'celopt') ccpar=vhulp -c$$$ if (qident.eq.'icelo2') icelo2=int(vhulp) - icelo2old=icelo2 -c$$$ if (qident.eq.'ideve1') nrdd=int(vhulp) -c$$$ if (qident.eq.'ideve2') nrddf=int(vhulp) -c$$$ if (qident.eq.'ibiola') nbiolab=int(vhulp) -c$$$c if (qident.eq.'igeofo') ngeofor=int(vhulp) -c$$$ if (qident.eq.'iincop') nincrop=int(vhulp) -c$$$ if (qident.eq.'accerr') accincr=vhulp -c$$$ if (qident.eq.'iout6') nsav3=int(vhulp) -c$$$ if (qident.eq.'irten') nhop2=int(vhulp) -c$$$ if (qident.eq.'npreit') nprevrun=int(vhulp) -c$$$ if (qident.eq.'idebug') ndebug=int(vhulp) -c$$$ if (qident.eq.'volcha') volcha=vhulp -c$$$ if (qident.eq.'ixmolo') ixmolo=int(vhulp) -c$$$ if (qident.eq.'inpt') inpt=int(vhulp) -c$$$ if (qident.eq.'iconne') iconne=int(vhulp) -c$$$ if (qident.eq.'imolde') imolde=int(vhulp) -c$$$ if (qident.eq.'ianaly') ianaly=int(vhulp) -c$$$ if (qident.eq.'icentr') icentr=int(vhulp) -c$$$ if (qident.eq.'itrans') itrans=int(vhulp) -c$$$ if (qident.eq.'itrout') itrout=int(vhulp) -c$$$ if (qident.eq.'nvlist') nvlist=int(vhulp) -c$$$ if (qident.eq.'vrange') vrange=vhulp -c$$$ if (qident.eq.'vlbora') vlbora=vhulp -c$$$ if (qident.eq.'tpnrad') tpnrad=vhulp -c$$$ if (qident.eq.'ityrad') ityrad=int(vhulp) -c$$$ if (qident.eq.'iexx') iexx=int(vhulp) -c$$$ if (qident.eq.'iexy') iexy=int(vhulp) -c$$$ if (qident.eq.'iexz') iexz=int(vhulp) -c$$$ if (qident.eq.'syscha') syscha=vhulp -c$$$ if (qident.eq.'inmov1') inmov1=int(vhulp) -c$$$ if (qident.eq.'inmov2') inmov2=int(vhulp) -c$$$ if (qident.eq.'itstep') itstep=int(vhulp) -c$$$ if (qident.eq.'ifreq') ifreq=int(vhulp) -c$$$ if (qident.eq.'isymm') isymm=int(vhulp) -c$$$ if (qident.eq.'icpres') icpres=int(vhulp) -c$$$ if (qident.eq.'delvib') delvib=vhulp -c$$$ goto 10 -c$$$ 20 continue - close (10) - axis(1)=axis1 - axis(2)=axis2 - axis(3)=axis3 - if (axiss(1).gt.zero) then - axis(1)=axiss(1) - axis(2)=axiss(2) - axis(3)=axiss(3) - end if - if (tincr.lt.0.0001.and.tincr.gt.-0.0001) tset=tsetor - iequi=1 - if (nequi.gt.0) iequi=0 - if (iopt.eq.1.and.napp.eq.1) then - stop 'No fort.7 and fort.8 append with iopt=1 !' - end if - if (mdstep.gt.0.or.nit.gt.0) nmm=nmmsav - if (mdstep.gt.0.and.itstep.eq.1) then - tstepmax=tstep - tstep=tstep*(tsetor/tempmd) - if (tstep.gt.tstepmax) tstep=tstepmax - end if - tstep=1.0d-15*tstep - taus=taut - taut=1.0d-15*taut - taut2=1.0d-15*taut2 - taup=1.0d-15*taup - ts2=tstep/2.0 - ts22=tstep*ts2 - return - 30 continue - write (*,*)'Error reading control-file' - stop 'Error reading control-file' -************************************************************************ -* * -* Format part * -* * -************************************************************************ - 1050 format (f7.3) - 1055 format (f7.4) - 1056 format (f9.4) - 1060 format (i8) - 1070 format (f7.5) - end -************************************************************************ -************************************************************************ - - subroutine staint - -************************************************************************ -#include "cbka.blk" -#include "cbkdcell.blk" -#include "cbkqa.blk" -#include "control.blk" -#include "small.blk" -#include "cbkc.blk" -#include "cbkconst.blk" - dimension bvt(nat,4) -************************************************************************ -* * -* Generate cartesian coordinates from internal coordinate input * -* * -************************************************************************ -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In staint' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - k=0 - 10 read (3,1200,end=20,err=20)(ijk(k+1,k1),k1=1,3),k2,qa(k+1), - $bvt(k+1,3),bvt(k+1,2),bvt(k+1,1) - qlabel(k+1)=qa(k+1) - qresi1(k+1)=' ' - qresi2(k+1)=' ' - qresi3(k+1)=' ' - qffty(k+1)=' ' - if (k2.ne.k+1) then - write (*,*)'Wrong order in internal coordinates at atom:',k2 - goto 20 -* stop 'Wrong order in internal coordinates' - end if - k=k+1 - if (k.gt.nat) then - write (*,*)na,nat - stop 'Maximum number of atoms exceeded' - end if - goto 10 - 20 continue - na=k - -************************************************************************ -* * -* CALCULATION OF CARTESIAN COORDINATES FROM INTERNAL COORDINAATES * -* * -************************************************************************ - - 12 C(1,1)=ZERO - C(1,2)=ZERO - C(1,3)=ZERO - C(2,1)=BVT(2,1) - C(2,2)=ZERO - C(2,3)=ZERO - HR=(BVT(3,2)-90.0D0)*DGRRDN - C(3,1)=C(2,1)+BVT(3,1)*SIN(HR) - C(3,2)=BVT(3,1)*COS(HR) - C(3,3)=ZERO - DO 32 K1=4,NA - J=IJK(K1,2) - KB=K1-1 - XH=C(J,1) - YH=C(J,2) - ZH=C(J,3) - DO 13 K2=1,KB - C(K2,1)=C(K2,1)-XH - C(K2,2)=C(K2,2)-YH - C(K2,3)=C(K2,3)-ZH - DO 13 K3=1,3 - 13 IF (ABS(C(K2,K3)).LT.1.0D-15) C(K2,K3)=1.0D-15 - K=IJK(K1,3) - P2=C(K,2)*C(K,2)+C(K,3)*C(K,3) - IF (P2.NE.ZERO) THEN - P=SQRT(P2) - Q=SQRT(C(K,1)*C(K,1)+P2) - SA=C(K,2)/P - CA=C(K,3)/P - SB=-C(K,1)/Q - CB=P/Q - ELSE - SA=ZERO - CA=ONE - SB=ONE - CB=ZERO - ENDIF - DO 16 K2=1,KB - AZ=C(K2,1) - BZ=C(K2,2) - C(K2,1)=AZ*CB+BZ*SB*SA+C(K2,3)*SB*CA - C(K2,2)=BZ*CA-C(K2,3)*SA - 16 C(K2,3)=-AZ*SB+BZ*CB*SA+C(K2,3)*CB*CA - IF (C(K,3).LE.ZERO) THEN - DO 17 K2=1,KB - 17 C(K2,3)=-C(K2,3) - ENDIF - I=IJK(K1,1) - IF (1.0D5*ABS(C(I,1)).LE.ABS(C(I,2))) THEN - T1=HALF*PI - ELSE - YX=ABS(C(I,2)/C(I,1)) - T1=ATAN(YX) - ENDIF - IF (C(I,1).GE.ZERO.AND.C(I,2).LT.ZERO) T1=TWO*PI-T1 - IF (C(I,1).LT.ZERO.AND.C(I,2).GE.ZERO) T1=PI-T1 - IF (C(I,1).LT.ZERO.AND.C(I,2).LT.ZERO) T1=T1+PI - DO 31 K2=1,KB - IF (C(K2,1).EQ.ZERO.AND.C(K2,2).EQ.ZERO) GOTO 31 - IF (1.0D5*ABS(C(K2,1)).LT.ABS(C(K2,2))) THEN - T2=HALF*PI - ELSE - YX=ABS(C(K2,2)/C(K2,1)) - T2=ATAN(YX) - ENDIF - IF (C(K2,1).GE.ZERO.AND.C(K2,2).LT.ZERO) T2=TWO*PI-T2 - IF (C(K2,1).LT.ZERO.AND.C(K2,2).GE.ZERO) T2=PI-T2 - IF (C(K2,1).LT.ZERO.AND.C(K2,2).LT.ZERO) T2=T2+PI - T3=T2-T1 - IF (T3.LT.ZERO)T3=T3+TWO*PI - RZ=SQRT(C(K2,1)*C(K2,1)+C(K2,2)*C(K2,2)) - C(K2,1)=RZ*COS(T3) - C(K2,2)=RZ*SIN(T3) - 31 CONTINUE - HR=(BVT(K1,2)-90.0D0)*DGRRDN - HT=BVT(K1,3)*DGRRDN - CHR=COS(HR) - C(K1,1)=BVT(K1,1)*CHR*COS(HT) - C(K1,2)=BVT(K1,1)*CHR*SIN(HT) - 32 C(K1,3)=C(IJK(K1,3),3)+BVT(K1,1)*SIN(HR) - - return - 1200 FORMAT(4I3,1X,A2,3F10.5,4X,I1,F10.5) - end -************************************************************************ -************************************************************************ - - subroutine outint - -************************************************************************ -#include "cbka.blk" -#include "cbkabo.blk" -#include "cbkbo.blk" -#include "cbkconst.blk" -#include "cbkia.blk" -#include "cbkinit.blk" -#include "cbknubon2.blk" -#include "cbkqa.blk" -#include "cbktregime.blk" -#include "control.blk" -#include "small.blk" -#include "cbksrtbon1.blk" -************************************************************************ -* * -* Output internal coordinates * -* * -************************************************************************ - dimension dvdc(3,3),dargdc(3,3) -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In outint' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - write (91,50)qmol - open (82,file='output.MOP',status='unknown') - write (82,*) - write (82,'(a40)')qmol - write (82,*) - close (82) - -* IF (NMOLO.GT.1) THEN -* WRITE(6,*)' OUTPUT INTERNAL COORDINATES NOT POSSIBLE FOR ', -* $'CALCULATION ON MORE THAN ONE MOLECULE' -* RETURN -* END IF - -************************************************************************ -* * -* Output of internal coordinates. * -* First 3 atoms of other input file. * -* * -************************************************************************ - N1=1 - N2=2 - N3=3 -C open (82,file='output.MOP',status='unknown',access='append') - write(91,100)N1,qa(n1) - write(82,'(2x,a2,f12.6,i3,f12.6,i3,f12.6,i3,1x,3i4)')qa(n1), - $zero,nzero,zero,nzero,zero,nzero,nzero,nzero,nzero - call dista2(n1,n2,rr,dx,dy,dz) - write(91,200)N1,N2,qa(n2),RR - write(82,'(2x,a2,f12.6,i3,f12.6,i3,f12.6,i3,1x,3i4)')qa(n2), - $rr,none,zero,nzero,zero,nzero,n1,nzero,nzero - close (82) - - call dista2(n2,n3,rr,dx,dy,dz) - hv=zero - call calvalres(n1,n2,n3,arg,hv,dvdc,dargdc) - WRITE(91,300)N1,N2,N3,qa(n3),rdndgr*HV,RR -C open (82,file='output.MOP',status='unknown',access='append') - write(82,'(2x,a2,f12.6,i3,f12.6,i3,f12.6,i3,1x,3i4)')qa(n3), - $rr,none,rdndgr*hv,none,zero,nzero,n2,n1,nzero - close (82) - - naih=3 - - do i1=naih+1,na - bomax=zero - j1=0 - do i2=1,ia(i1,2) - iob=ia(i1,2+i2) - ncubo=nubon2(i1,i2) - if (bo(ncubo).gt.bomax.and.iob.lt.i1) then - bomax=bo(ncubo) - j1=iob - end if - end do - if (j1.eq.0) j1=i1-1 - call dista2(j1,i1,rr,dx,dy,dz) - - bomax=zero - j2=0 - do i2=1,ia(j1,2) - iob=ia(j2,2+i2) - ncubo=nubon2(j1,i2) - if (bo(ncubo).gt.bomax.and.iob.lt.i1.and. - $abo(iob).gt.bo(ncubo)+0.2) then - bomax=bo(ncubo) - j2=iob - end if - end do - if (j2.eq.0) j2=i1-2 - if (j2.eq.j1) j2=j2+1 - - call calvalres(j2,j1,i1,arg,hh,dvdc,dargdc) - - bomax=zero - j3=0 - do i2=1,ia(j2,2) - iob=ia(j2,2+i2) - ncubo=nubon2(j2,i2) - if (bo(ncubo).gt.bomax.and.iob.lt.i1.and.iob.ne.j1) then - bomax=bo(ncubo) - j3=iob - end if - end do - if (j3.eq.0) j3=i1-3 - if (j3.eq.j2.and.j3.ne.j1-1) j3=j3+1 - if (j3.eq.j2.and.j3.ne.j1-2) j3=j3+2 - if (j3.eq.j1.and.j3.ne.j2-1) j3=j3+1 - if (j3.eq.j1.and.j3.ne.j2-2) j3=j3+2 - - call caltor(j3,j2,j1,i1,ht) - - write(91,400)j3,j2,j1,i1,qa(i1),ht,rdndgr*hh,rr -C open (82,file='output.MOP',status='unknown',access='append') - write(82,'(2x,a2,f12.6,i3,f12.6,i3,f12.6,i3,1x,3i4)')qa(i1), - $rr,none,rdndgr*hh,none,ht,none,j1,j2,j3 - close (82) - end do - - close(82) - return - 50 format (' I',2x,a60) - 100 FORMAT(9X,I3,1x,a2) - 200 FORMAT(6X,2I3,1x,a2,20X,F10.5) - 300 FORMAT(3X,3I3,1x,a2,10X,2F10.5) - 400 FORMAT(4I3,1x,a2,3F10.5) - - end -************************************************************************ -************************************************************************ - - subroutine outres - -************************************************************************ -#include "cbka.blk" -#include "cbkbo.blk" -#include "cbkch.blk" -#include "cbkd.blk" -#include "cbkenergies.blk" -#include "cbkh.blk" -#include "cbkimove.blk" -#include "cbkrbo.blk" -#include "cbktorang.blk" -#include "cbktorsion.blk" -#include "cbktregime.blk" -#include "cbkvalence.blk" -#include "control.blk" -#include "opt.blk" -#include "small.blk" -#include "cbkinit.blk" - -************************************************************************ -* * -* Output molecular data * -* * -************************************************************************ - dimension isort(100),iad1(100),iad2(100),iad3(100),iad4(100) - character*60 qm2 -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In outres' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - read (9,100,end=50)idata,qm2 -* if (qm2.ne.qmol) then -* write (*,*)'Wrong molecule in outres-file' -* write (*,*)qmol -* write (*,*)qm2 -* return -* end if - do 25 i1=1,idata - read (9,200)isort(i1),iad1(i1),iad2(i1),iad3(i1),iad4(i1) - ndata2=ndata2+1 - - if (isort(i1).eq.1) then -* do i2=1,nbon -* if (ib(i2,2).eq.iad1(i1).and.ib(i2,3).eq.iad2(i1)) then -* if (iopt.ne.1) write (81,*)iad1(i1),iad2(i1),rbo(i2) -* caldat(ndata2)=rbo(i2) -* end if -* end do - call dista2(iad1(i1),iad2(i1),dish,dx,dy,dz) - write (81,*)iad1(i1),iad2(i1),dish - caldat(ndata2)=dish - end if - - if (isort(i1).eq.2) then - do i2=1,nval - if (iv(i2,2).eq.iad1(i1).and.iv(i2,3).eq.iad2(i1).and. - $iv(i2,4).eq.iad3(i1)) then - if (iopt.ne.1) write (81,*)iad1(i1),iad2(i1), - $iad3(i1),h(i2)*rdndgr - caldat(ndata2)=h(i2)*rdndgr - end if - end do - end if - - if (isort(i1).eq.3) then - do i2=1,ntor - if (it(i2,2).eq.iad1(i1).and.it(i2,3).eq.iad2(i1).and. - $it(i2,4).eq.iad3(i1).and.it(i2,5).eq.iad4(i1)) then - if (iopt.ne.1) write (81,*)iad1(i1),iad2(i1),iad3(i1),iad4(i1), - $abs(thg(i2)) - caldat(ndata2)=abs(thg(i2)) - end if - end do - end if - - if (isort(i1).eq.4) then - if (iopt.ne.1) write (81,*)estrmin - caldat(ndata2)=estrmin - end if - - if (isort(i1).eq.5) then - if (iopt.ne.1) write (81,*)estrmin - caldat(ndata2)=estrmin - end if - - if (isort(i1).eq.6) then - if (iopt.ne.1) write (81,*)iad1(i1),axiss(iad1(i1)) - caldat(ndata2)=axiss(iad1(i1)) - end if - - if (isort(i1).eq.7) then - if (iopt.ne.1) write (81,*)eco - caldat(ndata2)=eco - end if - - if (isort(i1).eq.8) then - do i2=1,nbon - if (ib(i2,2).eq.iad1(i1).and.ib(i2,3).eq.iad2(i1)) then - if (iopt.ne.1) write (81,*)iad1(i1),iad2(i1),bo(i2) - caldat(ndata2)=bo(i2) - end if - end do - end if - - if (isort(i1).eq.9) then - if (iopt.ne.1) write (81,*)ch(iad1(i1)) - caldat(ndata2)=ch(iad1(i1)) - end if - - if (isort(i1).eq.10) then - rmsg=0.0 - nmovh=0 - do i2=1,na - do i3=1,3 - rmsg=rmsg+imove(i2)*d(i3,i2)*d(i3,i2) - nmovh=nmovh+imove(i2) - end do - end do - rmsg=sqrt(rmsg/float(nmovh*3)) - - if (iopt.ne.1) write (81,*)rmsg - caldat(ndata2)=rmsg - end if - - if (isort(i1).eq.11) then - if (iopt.ne.1) write (81,*)1000.0*pressu - caldat(ndata2)=1000.0*pressu - end if - - 25 continue - - 50 return -************************************************************************ -* * -* Format part * -* * -************************************************************************ - 100 format (i3,a60) - 200 format (5i3) - end -************************************************************************ -************************************************************************ - - subroutine readgeo - -************************************************************************ -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkconst.blk" -#include "cbkdistan.blk" -#include "cbkinit.blk" -#include "cbkqa.blk" -#include "cbksrtbon1.blk" -#include "cbktregime.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "small.blk" - character*80 qromb - character*25 qfileh -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In readgeo' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - - if (ngeofor.eq.-1) return - -********************************************************************** -* * -* Read in system geometry * -* * -********************************************************************** - if (ngeofor.eq.0) then - call readdelphi (qfileh,iend,naold) - namov=na - end if - - if (ngeofor.eq.1) then - call readbgf(iend,naold) - end if - - - - if (ngeofor.eq.2) then -********************************************************************** -* * -* Read in free format (xmol) geometry * -* * -********************************************************************** - qr='1' - read (3,'(i6)')na - namov=na - read (3,'(a60)')qmol - do i1=1,na - read (3,'(a80)')qromb - ifirstchar=80 - do i2=1,80 - if (qromb(i2:i2).ne.' '.and.i2.lt.ifirstchar) ifirstchar=i2 - end do - read (qromb(ifirstchar:80),'(a2)')qa(i1) - read (qromb(ifirstchar+2:80),*)c(i1,1),c(i1,2),c(i1,3) - qlabel(i1)=qa(i1) - qresi1(i1)=' ' - qresi2(i1)=' ' - qresi3(i1)=' ' - qffty(i1)=' ' - end do - ibity=1 - axiss(1)=-1.0 - end if - - - if (ngeofor.eq.3) then -********************************************************************** -* * -* Read in ChemDraw CC1-file * -* * -********************************************************************** - qr='1' - read (3,*)na - namov=na - read (3,'(a60)')qmol - do i1=1,na - read (3,'(2x,a2,5x,3f12.6)')qa(i1),c(i1,1),c(i1,2),c(i1,3) - end do - end if - - if (ngeofor.eq.4) then -********************************************************************** -* * -* Read in .pdb-format * -* * -********************************************************************** - qr='C' - call readpdb(iendf) - namov=na - ibity=1 - axiss(1)=-1.0 - qfile(nprob)=qmol - if (iendf.eq.1) stop 'End-of-file while reading in .pdb' - end if - -********************************************************************** -* * -* Set up periodic system * -* * -********************************************************************** - axis(1)=axiss(1) - axis(2)=axiss(2) - axis(3)=axiss(3) - angle(1)=angles(1) - angle(2)=angles(2) - angle(3)=angles(3) - if (axiss(1).lt.zero) then - axis(1)=axis1 - axis(2)=axis2 - axis(3)=axis3 - angle(1)=90.0 - angle(2)=90.0 - angle(3)=90.0 - end if - halfa=angle(1)*dgrrdn - hbeta=angle(2)*dgrrdn - hgamma=angle(3)*dgrrdn - sinalf=sin(halfa) - cosalf=cos(halfa) - sinbet=sin(hbeta) - cosbet=cos(hbeta) - cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) - if (cosphi.gt.1.0) cosphi=1.0 - sinphi=sqrt(one-cosphi*cosphi) - tm11=axis(1)*sinbet*sinphi - tm21=axis(1)*sinbet*cosphi - tm31=axis(1)*cosbet - tm22=axis(2)*sinalf - tm32=axis(2)*cosalf - tm33=axis(3) - - return - end -************************************************************************ -************************************************************************ - - subroutine readdelphi (qfileh,iend,naold) - -************************************************************************ -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkconst.blk" -#include "cbkd.blk" -#include "cbkdcell.blk" -#include "cbkdistan.blk" -#include "cbkff.blk" -#include "cbkh.blk" -#include "cbkinit.blk" -#include "cbkqa.blk" -#include "cbkrestr.blk" -#include "cbksrtbon1.blk" -#include "cbktregime.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "opt.blk" -#include "small.blk" - character*25 qfileh -********************************************************************** -* * -* Read in geometries in Delphi-format (xyz) * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In readdelphi' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - - if (imodfile.eq.1) then - open (3,file=qfileh,status='old') - end if - nmmax=nmmaxold - nfc=nfcold - ibity=1 - iredo=1 - endpo=endpoold - icell=icellold - icelo2=icelo2old - iend=0 - read (3,1000,end=900)qr,qmol -********************************************************************** -* * -* Read in restraint information (optional) * -* * -********************************************************************** - if (qr.eq.'R'.or.qr.eq.'P'.or.qr.eq.'X') then - qmol=qmol(7:60) - qmolset(nuge)=qmol - read (18,1070,end=4,err=4) nrestra - do i1=1,nrestra - read (18,1090)irstra(i1,1),irstra(i1,2),rrstra(i1),vkrstr(i1), - $vkrst2(i1),rrcha(i1) - end do - 4 continue - end if -********************************************************************** -* * -* Read in torsion restraint information (optional) * -* * -********************************************************************** - if (qr.eq.'T'.or.qr.eq.'X') then - if (qr.eq.'T') then - qmol=qmol(7:60) - qmolset(nuge)=qmol - end if - read (28,1070,end=6,err=6) nrestrat - do i1=1,nrestrat - read (28,1091)irstrat(i1,1),irstrat(i1,2),irstrat(i1,3), - $irstrat(i1,4),trstra(i1),vkrt(i1),vkr2t(i1),rtcha(i1) - end do - 6 continue - end if -********************************************************************** -* * -* Read in valency angle restraint information (optional) * -* * -********************************************************************** - if (qr.eq.'V') then - qmol=qmol(7:60) - qmolset(nuge)=qmol - read (38,1070,end=7,err=7) nrestrav - do i1=1,nrestrav - read (38,1092)irstrav(i1,1),irstrav(i1,2),irstrav(i1,3), - $vrstra(i1),vkrv(i1),vkr2v(i1) - end do - 7 continue - end if -********************************************************************** -* * -* Read in geometry * -* * -********************************************************************** - ibh2=0 - iequi=1 - iexco=0 - if (nequi.gt.0) iequi=0 - axiss(1)=-1.0 - - if (qr.eq.'O'.or.qr.eq.'L') stop 'Not xyz-format' - - if (qr.eq.'I') then !Delphi internal coordinates - if (nsurp.ge.2) stop 'Int.coordinates only with 1 gemetry' - call staint - goto 20 - end if - - if (qr.eq.'B') then !Previous geometry with volume reduction - read (3,*) - vred=(1.0-0.01*volcha)**(0.33333) - iexco=1 - na=naold - do i1=1,3 - qmol=qmol - axiss(i1)=vred*axis(i1) - angles(i1)=angle(i1) - do i2=1,na - c(i2,i1)=vred*c(i2,i1) - end do - end do - - halfa=angles(1)*dgrrdn - hbeta=angles(2)*dgrrdn - hgamma=angles(3)*dgrrdn - sinalf=sin(halfa) - cosalf=cos(halfa) - sinbet=sin(hbeta) - cosbet=cos(hbeta) - cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) - if (cosphi.gt.1.0) cosphi=1.0 - sinphi=sqrt(one-cosphi*cosphi) - tm11=axiss(1)*sinbet*sinphi - tm21=axiss(1)*sinbet*cosphi - tm31=axiss(1)*cosbet - tm22=axiss(2)*sinalf - tm32=axiss(2)*cosalf - tm33=axiss(3) - kx=int(2.0*swb/tm11) - ky=int(2.0*swb/tm22) - kz=int(2.0*swb/tm33) - ibity=2 - - goto 20 - end if - - if (qr.eq.'S') then !Previous geometry with volume expansion - read (3,*) - vexp=(1.0+0.01*volcha)**(0.33333) - na=naold - iexco=1 - do i1=1,3 - qmol=qmol - axiss(i1)=vexp*axis(i1) - angles(i1)=angle(i1) - do i2=1,na - c(i2,i1)=vexp*c(i2,i1) - end do - end do - - halfa=angles(1)*dgrrdn - hbeta=angles(2)*dgrrdn - hgamma=angles(3)*dgrrdn - sinalf=sin(halfa) - cosalf=cos(halfa) - sinbet=sin(hbeta) - cosbet=cos(hbeta) - cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) - if (cosphi.gt.1.0) cosphi=1.0 - sinphi=sqrt(one-cosphi*cosphi) - tm11=axiss(1)*sinbet*sinphi - tm21=axiss(1)*sinbet*cosphi - tm31=axiss(1)*cosbet - tm22=axiss(2)*sinalf - tm32=axiss(2)*cosalf - tm33=axiss(3) - kx=int(2.0*swb/tm11) - ky=int(2.0*swb/tm22) - kz=int(2.0*swb/tm33) - ibity=2 - - goto 20 - end if - - if (qr.eq.'F'.or.qr.eq.'Y'.or.qr.eq.'3'.or.qr.eq.'5'. - $or.qr.eq.'P') then - kx=0 - ky=0 - kz=0 - ibity=2 - read(3,1005)axiss(1),axiss(2),axiss(3) - read(3,1005)angles(1),angles(2),angles(3) - - halfa=angles(1)*dgrrdn - hbeta=angles(2)*dgrrdn - hgamma=angles(3)*dgrrdn - sinalf=sin(halfa) - cosalf=cos(halfa) - sinbet=sin(hbeta) - cosbet=cos(hbeta) - cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) - if (cosphi.gt.1.0) cosphi=1.0 - sinphi=sqrt(one-cosphi*cosphi) - tm11=axiss(1)*sinbet*sinphi - tm21=axiss(1)*sinbet*cosphi - tm31=axiss(1)*cosbet - tm22=axiss(2)*sinalf - tm32=axiss(2)*cosalf - tm33=axiss(3) - kx=int(2.0*swb/tm11) - ky=int(2.0*swb/tm22) - kz=int(2.0*swb/tm33) - - end if - - if (qr.eq.'M'.or.qr.eq.'A') then - nmmsav=nmm - nmm=2 - end if - - if (qr.eq.'A') nmm=1 - - if (qr.eq.'D') then - endpo=endpo/25 - nmmax=nmmax*5 - qruid='HIGH PRECISION' - end if - - if (qr.eq.'H') then - nmmax=nmmax/10 - qruid='LOW PRECISION' - end if - - if (qr.eq.'1'.or.qr.eq.'5') then - nmm=1 - nmmax=1 - qruid='SINGLE POINT' - end if - - if (qr.eq.'Y') then - icell=0 - qruid='NO CELL OPT' - end if - - 10 read (3,1100,end=20,err=20)ir,qa(na+1),(c(na+1,i2),i2=1,3) - qlabel(na+1)=qa(na+1) - qresi1(na+1)=' ' - qresi2(na+1)=' ' - qresi3(na+1)=' ' - qffty(na+1)=' ' - if (ir.eq.0) goto 20 - na=na+1 - - if (na.gt.nat) then - write (*,*)'Maximum number of atom exceeded ',na,nat - stop 'Maximum number of atoms exceeded' - end if - - goto 10 - 20 continue - - if (imodfile.eq.1) close (3) - - return - 900 iend=1 - return - 1000 format (2x,a1,1x,a60) - 1005 format (3f10.4) - 1070 format (i3) - 1090 format (2i4,2f8.4,f8.6,f10.8) - 1091 format (4i4,2f8.4,3f8.6) - 1092 format (3i4,2f8.4,2f8.6) - 1100 format (i4,1x,a2,3x,3d22.15,1x,a5,1x,i5) - end -************************************************************************ -************************************************************************ - - subroutine readbgf(iendf,naold) - -************************************************************************ -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkcha.blk" -#include "cbkcharmol.blk" -#include "cbkconst.blk" -#include "cbkd.blk" -#include "cbkdcell.blk" -#include "cbkdistan.blk" -#include "cbkenergies.blk" -#include "cbkff.blk" -#include "cbkh.blk" -#include "cbkimove.blk" -#include "cbkinit.blk" -#include "cbkqa.blk" -#include "cbkrestr.blk" -#include "cbksrtbon1.blk" -#include "cbktregime.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "opt.blk" -#include "small.blk" - character*80 qromb - character*2 qrom - character*5 quen - character*5 qlabhulp - character*25 qfileh - character*200 qhulp -********************************************************************** -* * -* Read in BIOGRAF-geometry * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In readbgf' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - - iendf=0 - ienread=0 - iredo=0 - qremark(1)=' ' - enmol=zero - formol=zero -c$$$ if (imodfile.eq.1) then -c$$$ open (3,file=qfileh,status='old') -c$$$ end if - open (3,file='fort.3',status='old') - read (3,'(a40)',end=900)qromb - ibity=0 - if (qromb(1:6).eq.'BIOGRF') ibity=1 - if (qromb(1:6).eq.'XTLGRF') ibity=2 - if (ibity.eq.0) then - write (*,*)qromb(1:6) - stop 'Unknown Biograf-file' - end if - read (qromb,'(6x,i4)')ibgfversion - if (ibity.eq.1) qr='C' - if (ibity.eq.2) qr='F' - iremark=0 - iformat=0 - iline=0 - iexco=0 - iruid=1 - vvol=1.0 - nmcharge=0 - nmmax=nmmaxold - nfc=nfcold - ncha=nchaold - endpo=endpoold - icell=icellold - icelo2=icelo2old - axiss(1)=-1.0 - - 30 read (3,'(a200)',end=46,err=40)qhulp - qstrana1(1:200)=qhulp - iline=iline+1 - irecog=0 - - if (qhulp(1:6).eq.'DESCRP') then - read (qhulp,'(7x,a40)',end=46,err=46)qmol - irecog=1 - end if - - if (qhulp(1:6).eq.'REMARK') then - if (iremark.lt.20) iremark=iremark+1 - read (qhulp,'(7x,a40)',end=46,err=46)qremark(iremark) - irecog=1 - end if - - if (qhulp(1:6).eq.'FORMAT') then - if (iformat.lt.20) iformat=iformat+1 - read(qhulp,'(7x,a40)',end=46,err=46)qformat(iformat) - irecog=1 - end if - - if (qhulp(1:7).eq.'VCHANGE') then - read (qhulp(8:60),*)vvol - vred=(1.0+(vvol-1.0))**(0.33333333) - iexco=1 - na=naold - qmol=qmol - do i1=1,3 - axiss(i1)=vred*axis(i1) - angles(i1)=angle(i1) - do i2=1,na - cglobal(i2,i1)=vred*cglobal(i2,i1) - end do - end do - - halfa=angles(1)*dgrrdn - hbeta=angles(2)*dgrrdn - hgamma=angles(3)*dgrrdn - sinalf=sin(halfa) - cosalf=cos(halfa) - sinbet=sin(hbeta) - cosbet=cos(hbeta) - cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) - if (cosphi.gt.1.0) cosphi=1.0 - sinphi=sqrt(one-cosphi*cosphi) - tm11=axiss(1)*sinbet*sinphi - tm21=axiss(1)*sinbet*cosphi - tm31=axiss(1)*cosbet - tm22=axiss(2)*sinalf - tm32=axiss(2)*cosalf - tm33=axiss(3) - kx=int(2.0*swb/tm11) - ky=int(2.0*swb/tm22) - kz=int(2.0*swb/tm33) - ibity=2 - irecog=1 - end if - - if (qhulp(1:7).eq.'VCHANGX') then - read (qhulp(8:60),*)vvol - vred=vvol - iexco=1 - na=naold - qmol=qmol - do i1=1,3 - axiss(i1)=axis(i1) - angles(i1)=angle(i1) - do i2=1,na - cglobal(i2,i1)=cglobal(i2,i1) - end do - end do - - axiss(1)=vred*axiss(1) - do i2=1,na - cglobal(i2,1)=vred*cglobal(i2,1) - end do - - halfa=angles(1)*dgrrdn - hbeta=angles(2)*dgrrdn - hgamma=angles(3)*dgrrdn - sinalf=sin(halfa) - cosalf=cos(halfa) - sinbet=sin(hbeta) - cosbet=cos(hbeta) - cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) - if (cosphi.gt.1.0) cosphi=1.0 - sinphi=sqrt(one-cosphi*cosphi) - tm11=axiss(1)*sinbet*sinphi - tm21=axiss(1)*sinbet*cosphi - tm31=axiss(1)*cosbet - tm22=axiss(2)*sinalf - tm32=axiss(2)*cosalf - tm33=axiss(3) - kx=int(2.0*swb/tm11) - ky=int(2.0*swb/tm22) - kz=int(2.0*swb/tm33) - ibity=2 - irecog=1 - end if - - if (qhulp(1:7).eq.'VCHANGY') then - read (qhulp(8:60),*)vvol - vred=vvol - iexco=1 - na=naold - qmol=qmol - do i1=1,3 - axiss(i1)=axis(i1) - angles(i1)=angle(i1) - do i2=1,na - cglobal(i2,i1)=cglobal(i2,i1) - end do - end do - - axiss(2)=vred*axiss(2) - do i2=1,na - cglobal(i2,2)=vred*cglobal(i2,2) - end do - - halfa=angles(1)*dgrrdn - hbeta=angles(2)*dgrrdn - hgamma=angles(3)*dgrrdn - sinalf=sin(halfa) - cosalf=cos(halfa) - sinbet=sin(hbeta) - cosbet=cos(hbeta) - cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) - if (cosphi.gt.1.0) cosphi=1.0 - sinphi=sqrt(one-cosphi*cosphi) - tm11=axiss(1)*sinbet*sinphi - tm21=axiss(1)*sinbet*cosphi - tm31=axiss(1)*cosbet - tm22=axiss(2)*sinalf - tm32=axiss(2)*cosalf - tm33=axiss(3) - kx=int(2.0*swb/tm11) - ky=int(2.0*swb/tm22) - kz=int(2.0*swb/tm33) - ibity=2 - irecog=1 - end if - - if (qhulp(1:7).eq.'VCHANGZ') then - read (qhulp(8:60),*)vvol - vred=vvol - iexco=1 - na=naold - qmol=qmol - - do i1=1,3 - axiss(i1)=axis(i1) - angles(i1)=angle(i1) - do i2=1,na - cglobal(i2,i1)=cglobal(i2,i1) - end do - end do - - axiss(3)=vred*axiss(3) - do i2=1,na - cglobal(i2,3)=vred*cglobal(i2,3) - end do - - halfa=angles(1)*dgrrdn - hbeta=angles(2)*dgrrdn - hgamma=angles(3)*dgrrdn - sinalf=sin(halfa) - cosalf=cos(halfa) - sinbet=sin(hbeta) - cosbet=cos(hbeta) - cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) - if (cosphi.gt.1.0) cosphi=1.0 - sinphi=sqrt(one-cosphi*cosphi) - tm11=axiss(1)*sinbet*sinphi - tm21=axiss(1)*sinbet*cosphi - tm31=axiss(1)*cosbet - tm22=axiss(2)*sinalf - tm32=axiss(2)*cosalf - tm33=axiss(3) - kx=int(2.0*swb/tm11) - ky=int(2.0*swb/tm22) - kz=int(2.0*swb/tm33) - ibity=2 - irecog=1 - end if - - if (qhulp(1:6).eq.'CRYSTX') then - read (qhulp,'(8x,6f11.5)',end=46,err=46)axiss(1), - $axiss(2),axiss(3),angles(1),angles(2),angles(3) - kx=0 - ky=0 - kz=0 - halfa=angles(1)*dgrrdn - hbeta=angles(2)*dgrrdn - hgamma=angles(3)*dgrrdn - sinalf=sin(halfa) - cosalf=cos(halfa) - sinbet=sin(hbeta) - cosbet=cos(hbeta) - cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) - if (cosphi.gt.1.0) cosphi=1.0 - sinphi=sqrt(one-cosphi*cosphi) - tm11=axiss(1)*sinbet*sinphi - tm21=axiss(1)*sinbet*cosphi - tm31=axiss(1)*cosbet - tm22=axiss(2)*sinalf - tm32=axiss(2)*cosalf - tm33=axiss(3) - kx=int(2.0*swb/tm11) - ky=int(2.0*swb/tm22) - kz=int(2.0*swb/tm33) - qr='F' - if (nmmax.eq.1.and.nmmaxold.gt.1) qr='5' - if (icell.eq.0.and.icellold.gt.0) qr='Y' - ibity=2 - irecog=1 - end if - - if (qhulp(1:6).eq.'PERIOD') then - read (qhulp,'(7x,i3)',end=46,err=46)iperiod - irecog=1 - end if - - if (qhulp(1:4).eq.'AXES') then - read (qhulp,'(7x,a3)',end=46,err=46)qbgfaxes - irecog=1 - end if - - if (qhulp(1:6).eq.'SGNAME') then - read (qhulp,'(7x,a3)',end=46,err=46)qbgfsgn - irecog=1 - end if - -* if (qhulp(1:5).eq.'CELLS') then -* read (qhulp,'(7x,*)',end=40,err=40)kx,ky,kz -* irecog=1 -* end if - - if (qhulp(1:6).eq.'HETATM') then - if (ibgfversion.lt.400) then - read (qhulp, - $'(7x,i5,1x,a5,1x,a3,1x,a1,1x,a5,3f10.5,1x,a5,i3,i2,1x,f8.5)' - $,end=40,err=40) - $ir,qlabel(na+1),qresi1(na+1),qresi2(na+1),qresi3(na+1), - $cglobal(na+1,1),cglobal(na+1,2), - $cglobal(na+1,3),qffty(na+1),ibgr1(na+1),ibgr2(na+1), - $chgglobal(na+1) - else - stop 'Unsupported Biograf-version' - end if - qlabhulp=qlabel(na+1) - if (qlabhulp(1:1).eq.' ') qlabhulp=qlabhulp(2:5) - if (qlabhulp(1:1).eq.' ') qlabhulp=qlabhulp(2:4) - if (qlabhulp(1:1).eq.' ') qlabhulp=qlabhulp(2:3) - if (qlabhulp(1:1).eq.'C ') qa(na+1)='C ' - if (qlabhulp(1:2).eq.'Ca') qa(na+1)='Ca' - if (qlabhulp(1:2).eq.'Cl') qa(na+1)='Cl' - if (qlabhulp(1:2).eq.'Cu') qa(na+1)='Cu' - if (qlabhulp(1:2).eq.'Co') qa(na+1)='Co' - if (qlabhulp(1:1).eq.'H ') qa(na+1)='H ' - if (qlabhulp(1:2).eq.'He') qa(na+1)='He' - if (qlabhulp(1:1).eq.'N ') qa(na+1)='N ' - if (qlabhulp(1:2).eq.'Ni') qa(na+1)='Ni' - if (qlabhulp(1:1).eq.'O ') qa(na+1)='O ' - if (qlabhulp(1:1).eq.'B ') qa(na+1)='B ' - if (qlabhulp(1:1).eq.'F ') qa(na+1)='F ' - if (qlabhulp(1:2).eq.'Fe') qa(na+1)='Fe' - if (qlabhulp(1:1).eq.'P ') qa(na+1)='P ' - if (qlabhulp(1:1).eq.'S ') qa(na+1)='S ' - if (qlabhulp(1:1).eq.'Y ') qa(na+1)='Y ' - if (qlabhulp(1:2).eq.'Al ') qa(na+1)='Al' - if (qlabhulp(1:2).eq.'Au ') qa(na+1)='Au' - if (qlabhulp(1:2).eq.'Si') qa(na+1)='Si' - if (qlabhulp(1:2).eq.'Pt') qa(na+1)='Pt' - if (qlabhulp(1:2).eq.'Mo') qa(na+1)='Mo' - if (qlabhulp(1:2).eq.'Mg') qa(na+1)='Mg' - if (qlabhulp(1:2).eq.'Ar') qa(na+1)='Ar' - if (qlabhulp(1:2).eq.'Zr') qa(na+1)='Zr' - if (qlabhulp(1:2).eq.'Ti') qa(na+1)='Ti' - if (qlabhulp(1:2).eq.'Ru') qa(na+1)='Ru' - if (qlabhulp(1:2).eq.'Ba') qa(na+1)='Ba' - if (qlabhulp(1:2).eq.'Bi') qa(na+1)='Bi' - if (qlabhulp(1:2).eq.'Li') qa(na+1)='Li' - if (qlabhulp(1:2).eq.'V ') qa(na+1)='V ' - if (qlabhulp(1:2).eq.'X ') qa(na+1)='X ' - na=na+1 - if (na.gt.nattot) then - write (*,*)'Number of atoms:read ',na - write (*,*)'Maximum number of atoms: ',nattot - stop - $'Maximum number of atoms exceeded; increase nattot in cbka.blk' - end if - irecog=1 - end if - - if (qhulp(1:6).eq.'RUTYPE') then !run-type identifiers - irecrun=0 - read (qhulp,'(7x,a40)',end=46,err=46)qruid - - if (qruid(1:10).eq.'NORMAL RUN') then - iruid=0 - irecrun=1 - end if - - if (qruid(1:14).eq.'HIGH PRECISION') then - endpo=endpo/25 - nmmax=nmmax*5 - qr='D' - iruid=1 - irecrun=1 - end if - - if (qruid(1:13).eq.'LOW PRECISION') then - nmmax=nmmax/10 - qr='H' - iruid=1 - irecrun=1 - end if - - if (qruid(1:12).eq.'SINGLE POINT') then - iruid=1 - nmmax=1 - qr='1' - if (ibity.eq.2) qr='5' - irecrun=1 - end if - - if (qruid(1:11).eq.'NO CELL OPT') then - iruid=1 - icell=0 - if (ibity.eq.2) qr='Y' - irecrun=1 - end if - - if (qruid(1:8).eq.'CELL OPT') then - iruid=1 - icell=1 - iexco=0 !Override from VCHANGE - read (qruid,'(8x,i6)',end=46,err=46)ncellopt - if (ncellopt.eq.2) icell=2 !cell optimisation during energy minimisation - if (ncellopt.eq.3) icelo2=4 !c/a optimisation - if (ncellopt.eq.4) icelo2=1 !only a optimisation - if (ncellopt.eq.5) icelo2=2 !only b optimisation - if (ncellopt.eq.6) icelo2=3 !only c optimisation - if (ncellopt.eq.7) then - icelo2=4 !c/a optimisation - icell=2 !cell optimisation during energy minimisation - end if - if (ibity.eq.2) qr='F' - irecrun=1 - end if - - if (qruid(1:6).eq.'MAXMOV') then - iruid=1 - read (qruid,'(6x,i6)',end=46,err=46)nfc - irecrun=1 - end if - - if (qruid(1:4).eq.'REDO') then - iruid=1 - read (qruid,'(4x,i6)',end=46,err=46)iredo - irecrun=1 - end if - - if (qruid(1:5).eq.'MAXIT') then - iruid=1 - read (qruid,'(6x,i6)',end=46,err=46)nmmax - if (qruid(14:18).eq.'ENDPO') then - read (qruid,'(18x,f6.3)',end=46,err=46)endpo - end if - irecrun=1 - end if - if (qruid(1:5).eq.'ENDPO') then - iruid=1 - read (qruid,'(6x,f6.3)',end=46,err=46)endpo - irecrun=1 - end if - - if (qruid(1:9).eq.'CHARGEMET') then - iruid=1 - read (qruid,'(9x,i6)',end=46,err=46)ncha - irecrun=1 - end if - - if (irecrun.eq.0) then - write (*,*)'Warning: ignored RUTYPE identifier ',qruid(1:12) - end if - - irecog=1 - end if - - if (qhulp(1:14).eq.'BOND RESTRAINT') then - nrestra=nrestra+1 - istart=15 - call stranal(istart,iend,vout,iout,1) - irstra(nrestra,1)=iout - istart=iend - call stranal(istart,iend,vout,iout,1) - irstra(nrestra,2)=iout - istart=iend - call stranal(istart,iend,vout,iout,1) - rrstra(nrestra)=vout - istart=iend - call stranal(istart,iend,vout,iout,1) - vkrstr(nrestra)=vout - istart=iend - call stranal(istart,iend,vout,iout,1) - vkrst2(nrestra)=vout - istart=iend - call stranal(istart,iend,vout,iout,1) - rrcha(nrestra)=vout - istart=iend - call stranal(istart,iend,vout,iout,1) - itstart(nrestra)=iout - istart=iend - call stranal(istart,iend,vout,iout,1) - itend(nrestra)=iout - istart=iend -* read (qhulp,'(15x,2i4,f8.4,f8.2,f8.5,f10.7)',end=46,err=46) -* $irstra(nrestra,1),irstra(nrestra,2),rrstra(nrestra), -* $vkrstr(nrestra),vkrst2(nrestra),rrcha(nrestra) - qr='R' - irecog=1 - end if - - if (qhulp(1:15).eq.'ANGLE RESTRAINT') then - nrestrav=nrestrav+1 - read (qhulp,'(16x,3i4,2f8.2,f8.4,f9.6)',end=46,err=46) - $irstrav(nrestrav,1),irstrav(nrestrav,2),irstrav(nrestrav,3), - $vrstra(nrestrav),vkrv(nrestrav),vkr2v(nrestrav), - $rvcha(nrestrav) - qr='V' - irecog=1 - end if - - if (qhulp(1:17).eq.'TORSION RESTRAINT') then - nrestrat=nrestrat+1 - read (qhulp,'(18x,4i4,2f8.2,f8.4,f9.6)',end=46,err=46) - $irstrat(nrestrat,1),irstrat(nrestrat,2),irstrat(nrestrat,3), - $irstrat(nrestrat,4),trstra(nrestrat),vkrt(nrestrat), - $vkr2t(nrestrat),rtcha(nrestrat) - qr='T' - irecog=1 - end if - - if (qhulp(1:16).eq.'MASCEN RESTRAINT') then - nrestram=nrestram+1 - istart=17 - call stranal(istart,iend,vout,iout,1) - istart=iend - irstram(nrestram,1)=0 - if (qstrana2.eq.'x') irstram(nrestram,1)=1 - if (qstrana2.eq.'y') irstram(nrestram,1)=2 - if (qstrana2.eq.'z') irstram(nrestram,1)=3 - if (qstrana2.eq.'p') irstram(nrestram,1)=4 !fixed center of mass - if (irstram(nrestram,1).eq.0) - $stop 'Error in mass centre restraint' - call stranal(istart,iend,vout,iout,1) - istart=iend - irstram(nrestram,2)=iout - call stranal(istart,iend,vout,iout,1) - istart=iend - irstram(nrestram,3)=iout - call stranal(istart,iend,vout,iout,1) - istart=iend - rmstra1(nrestram)=vout - call stranal(istart,iend,vout,iout,1) - istart=iend - if (irstram(nrestram,1).le.3) irstram(nrestram,4)=iout - if (irstram(nrestram,1).eq.4) rmstra2(nrestram)=vout - call stranal(istart,iend,vout,iout,1) - istart=iend - if (irstram(nrestram,1).le.3) irstram(nrestram,5)=iout - if (irstram(nrestram,1).eq.4) rmstra3(nrestram)=vout - call stranal(istart,iend,vout,iout,1) - istart=iend - if (irstram(nrestram,1).le.3) rmstra2(nrestram)=vout - call stranal(istart,iend,vout,iout,1) - istart=iend - if (irstram(nrestram,1).le.3) rmstra3(nrestram)=vout - call stranal(istart,iend,vout,iout,1) - istart=iend - if (irstram(nrestram,1).le.3) rmcha(nrestram)=vout - irecog=1 - end if - - if (qhulp(1:9).eq.'MOLCHARGE') then - nmcharge=nmcharge+1 - istart=10 - call stranal(istart,iend,vout,iout,1) - istart=iend - iat1mc(nmcharge)=iout - call stranal(istart,iend,vout,iout,1) - istart=iend - iat2mc(nmcharge)=iout - call stranal(istart,iend,vout,iout,1) - istart=iend - vmcha(nmcharge)=vout - irecog=1 - end if - - if (qhulp(1:8).eq.'FIXATOMS') then - istart=9 - call stranal(istart,iend,vout,iout,1) - if1=iout - istart=iend - call stranal(istart,iend,vout,iout,1) - if2=iout - do i12=if1,if2 - imove(i12)=0 - end do - irecog=1 - end if - - if (qhulp(1:11).eq.'UNIT ENERGY') then - eenconv=zero - read (qhulp,'(14x,a5)',end=46,err=46)quen - if (quen.eq.'eV') eenconv=23.0408 - if (quen.eq.'EV') eenconv=23.0408 - if (quen.eq.'ev') eenconv=23.0408 - if (quen.eq.'h') eenconv=627.5 - if (quen.eq.'H') eenconv=627.5 - if (quen.eq.'kcal') eenconv=1.0 - if (quen.eq.'kCal') eenconv=1.0 - if (quen.eq.'KCAL') eenconv=1.0 - if (eenconv.eq.zero) then - write (*,*)quen,': unknown energy unit; assuming kcal/mol' - eenconv=1.0 - end if - irecog=1 - end if - - if (qhulp(1:6).eq.'ENERGY') then - read (qhulp(7:80),*,end=46,err=46)enmol - ienread=1 - irecog=1 - end if - - if (qhulp(1:6).eq.'GEOUPD') then - icgeopt(nprob)=0 - icgeo=0 - irecog=1 - end if - - if (qhulp(1:9).eq.'NO GEOUPD') then - icgeopt(nprob)=1 - icgeo=1 - irecog=1 - end if - - if (qhulp(1:9).eq.'FREQUENCY') then - ifreqset(nprob)=1 - ifreq=1 - irecog=1 - end if - -* if (qhulp(1:5).eq.'FORCE') then -* read (qhulp(6:80),*,end=46,err=46)formol -* ienread=1 -* irecog=1 -* end if - - if (qhulp(1:6).eq.'FFIELD') goto 30 - if (qhulp(1:6).eq.'CONECT') goto 30 - if (qhulp(1:5).eq.'ORDER') goto 30 - if (qhulp(1:1).eq.'#') goto 30 - if (qhulp(1:3).eq.'END') goto 45 - - if (irecog.eq.0) then - write (*,*)'Warning: ignored line starting with: ',qhulp(1:10) - end if - - goto 30 - - 40 write (*,*)'Error on line ',iline+1,' of Biograf-input' - stop - 45 read (3,*,err=46,end=46) - 46 continue - if (ienread.eq.1) then - if (eenconv.eq.zero) then - write (*,*)'No energy unit given; assuming kcal/mol' - eenconv=1.0 - end if - enmol=enmol*eenconv !Convert energies to kcal/mol - end if - - namov=0 !calculate number of moving atoms - do i1=1,na - if (imove(i1).eq.1) namov=namov+1 - end do - - if (imodfile.eq.1) close (3) - return - 900 iendf=1 - return - end -************************************************************************ -************************************************************************ - - subroutine readpdb (iendf) - -************************************************************************ -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkqa.blk" -#include "control.blk" -#include "opt.blk" -#include "small.blk" -#include "cbksrtbon1.blk" - character*200 qhulp -********************************************************************** -* * -* Read in .pdb-geometry * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In readpdb' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - iendf=1 - qmol='pdb_in' - 5 read (3,'(a200)',end=10,err=900) qhulp - qstrana1(1:200)=qhulp - istart=1 - call stranal(istart,iend,vout,iout,1) - istart=iend - - if (qstrana2(1:6).eq.'HEADER') then - call stranal(istart,iend,vout,iout,1) - istart=iend - qmol=qstrana2(1:20) - end if - - if (qstrana2(1:6).eq.'HETATM'.or.qstrana2(1:4).eq.'ATOM') then - call stranal(istart,iend,vout,iout,1) - istart=iend - call stranal(istart,iend,vout,iout,1) - istart=iend - qa(na+1)=qstrana2(1:2) - call stranal(istart,iend,vout,iout,1) - istart=iend - call stranal(istart,iend,vout,iout,1) - istart=iend - call stranal(istart,iend,vout,iout,1) - istart=iend - c(na+1,1)=vout - call stranal(istart,iend,vout,iout,1) - istart=iend - c(na+1,2)=vout - call stranal(istart,iend,vout,iout,1) - istart=iend - c(na+1,3)=vout - na=na+1 - end if - - if (qstrana2(1:3).eq.'END'.or.qstrana2(2:4).eq.'END') then - iendf=0 - goto 10 - end if - - goto 5 - 10 continue - return - 900 write (*,*)'Error reading in .pdb-format' - stop 'Error reading in .pdb-format' - end -************************************************************************ -************************************************************************ - - subroutine readtreg - -************************************************************************ -#include "cbka.blk" -#include "cbktregime.blk" -#include "control.blk" -#include "small.blk" - dimension isumattreg(mtreg) - character*200 qrom -********************************************************************** -* * -* Read in temperature regime * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In readtreg' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - ntrc=0 - open (19,file='tregime.in',status='old',err=60) - 10 read (19,'(a200)',end=50,err=900)qrom - qstrana1(1:200)=qrom - if (qrom(1:1).eq.'#') goto 10 - istart=1 - ntrc=ntrc+1 - if (ntrc.gt.mtreg) then - write (*,*)'Too many temperature regimes in tregime.in;', - $' inrease mtreg in cbka.blk' - stop 'Too many temperature regimes in tregime.in' - end if - call stranal(istart,iend,vout,iout,1) - nittc(ntrc)=iout - istart=iend - - if (ntrc.gt.1) then - if (nittc(ntrc).lt.nittc(ntrc-1)) then - ntrc=ntrc-1 - write (*,*)'Warning: wrong order or empty line in tregime.in' - write (*,*)'Ignored lines below iteration:',nittc(ntrc) - goto 50 - end if - end if - - call stranal(istart,iend,vout,iout,1) - nntreg(ntrc)=iout - if (nntreg(ntrc).gt.mtzone) then - write (*,*)'Too many temperature zones in tregime.in;', - $' inrease mtzone in cbka.blk' - stop 'Too many temperature zones in tregime.in' - end if - istart=iend - isumattreg(ntrc)=0 - do i1=1,nntreg(ntrc) - call stranal(istart,iend,vout,iout,1) - ia1treg(ntrc,i1)=iout - istart=iend - call stranal(istart,iend,vout,iout,1) - ia2treg(ntrc,i1)=iout - istart=iend - isumattreg(ntrc)=isumattreg(ntrc)+1+ia2treg(ntrc,i1)- - $ia1treg(ntrc,i1) - call stranal(istart,iend,vout,iout,1) - tsettreg(ntrc,i1)=vout - istart=iend - call stranal(istart,iend,vout,iout,1) - tdamptreg(ntrc,i1)=vout - istart=iend - call stranal(istart,iend,vout,iout,1) - dttreg(ntrc,i1)=vout - istart=iend - end do - goto 10 - 50 continue - close (19) - 60 continue -********************************************************************** -* * -* Check consistency temperature programs in tregime.in * -* * -********************************************************************** - if (ntrc.gt.0) then - do i1=1,ntrc - if (isumattreg(i1).ne.na) then - write (*,*)'Inconsistency in temperature regime nr.',i1 - write (*,*)'Number of atoms defined in tregime.in:', - $isumattreg(i1) - write (*,*)'Number of atoms in system:',na - stop 'Inconsistency in tregime.in' - end if - end do - end if - - return - 900 stop 'Error reading tregime.in' - end -************************************************************************ -************************************************************************ - - subroutine readvreg - -************************************************************************ -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkvregime.blk" -#include "control.blk" - character*200 qrom -********************************************************************** -* * -* Read in volume regime * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In readvreg' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - nvrc=0 - open (19,file='vregime.in',status='old',err=60) - 10 read (19,'(a200)',end=50,err=900)qrom - qstrana1(1:200)=qrom - if (qrom(1:1).eq.'#') goto 10 - istart=1 - nvrc=nvrc+1 - if (nvrc.gt.mvreg) then - write (*,*)'Too many volume regimes in vregime.in;', - $' inrease mvreg in cbka.blk' - stop 'Too many volume regimes in vregime.in' - end if - - call stranal(istart,iend,vout,iout,1) - nitvc(nvrc)=iout - istart=iend - - if (nvrc.gt.1) then - if (nitvc(nvrc).lt.nitvc(nvrc-1)) then - nvrc=nvrc-1 - write (*,*)'Warning: wrong order or empty line in vregime.in' - write (*,*)'Ignored lines below iteration:',nitvc(nvrc) - goto 50 - end if - end if - - call stranal(istart,iend,vout,iout,1) - nnvreg(nvrc)=iout - if (nnvreg(nvrc).gt.mvzone) then - write (*,*)'Too many volume regimes in vregime.in;', - $' inrease mvzone in cbka.blk' - stop 'Too many volume zones in vregime.in' - end if - istart=iend - do i1=1,nnvreg(nvrc) - call stranal(istart,iend,vout,iout,1) - if (qstrana2(1:1).ne.'a'.and.qstrana2(1:1).ne.'b'.and. - $qstrana2(1:1).ne.'c'.and.qstrana2(1:4).ne.'alfa'.and. - $qstrana2(1:4).ne.'beta'.and.qstrana2(1:5).ne.'gamma') then - write (*,*)qstrana2 - write (*,*)'Invalid cell parameter type in vregime.in ;', - $' use a,b,c,alfa,beta or gamma' - stop 'Invalid cell parameter type in vregime.in' - end if - qvtype(nvrc,i1)=qstrana2 - istart=iend - call stranal(istart,iend,vout,iout,1) - dvvreg(nvrc,i1)=vout - istart=iend - call stranal(istart,iend,vout,iout,1) - ivsca(nvrc,i1)=1 - if (qstrana2(1:1).eq.'n') ivsca(nvrc,i1)=0 - istart=iend - end do - goto 10 - 50 continue - close (19) - 60 continue - return - 900 stop 'Error reading vregime.in' - end -************************************************************************ -************************************************************************ - - subroutine readereg - -************************************************************************ -#include "cbka.blk" -#include "cbkeregime.blk" -#include "control.blk" - character*200 qrom -********************************************************************** -* * -* Read in electric field regime * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In readereg' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - nerc=0 - open (19,file='eregime.in',status='old',err=60) - 10 read (19,'(a200)',end=50,err=900)qrom - qstrana1(1:200)=qrom - if (qrom(1:1).eq.'#') goto 10 - istart=1 - nerc=nerc+1 - if (nerc.gt.mereg) then - write (*,*)'Too many electric field regimes in eregime.in;', - $' inrease mereg in cbka.blk' - stop 'Too many electric field regimes in eregime.in' - end if - call stranal(istart,iend,vout,iout,1) - nitec(nerc)=iout - - if (nerc.gt.1) then - if (nitec(nerc).lt.nitec(nerc-1)) then - nerc=nerc-1 - write (*,*)'Warning: wrong order or empty line in eregime.in' - write (*,*)'Ignored lines below iteration:',nitec(nerc) - goto 50 - end if - end if - - istart=iend - call stranal(istart,iend,vout,iout,1) - nnereg(nerc)=iout - if (nnereg(nerc).gt.mezone) then - write (*,*)'Too many electric field zones in eregime.in;', - $' inrease mezone in cbka.blk' - stop 'Too many electric field zones in vregime.in' - end if - istart=iend - do i1=1,nnereg(nerc) - call stranal(istart,iend,vout,iout,1) - if (qstrana2(1:1).ne.'x'.and.qstrana2(1:1).ne.'y'.and. - $qstrana2(1:1).ne.'z') then - write (*,*)qstrana2 - write (*,*)'Invalid field direction in eregime.in ;', - $' use x,y or z' - stop 'Invalid field direction in eregime.in' - end if - qetype(nerc,i1)=qstrana2 - istart=iend - call stranal(istart,iend,vout,iout,1) - ereg(nerc,i1)=vout - istart=iend - end do - goto 10 - 50 continue - close (19) - 60 continue - return - 900 stop 'Error reading vregime.in' - end -************************************************************************ -************************************************************************ - - subroutine readaddmol - -************************************************************************ -#include "cbka.blk" -#include "cbkatomcoord.blk" -#include "cbkc.blk" -#include "cbkff.blk" -#include "cbkh.blk" -#include "control.blk" - character*80 qromb - character*200 qhulp - character*5 qlabhulp -********************************************************************** -* * -* Read in molecule coordinates. This molecule will be added to * -* the system at regular intervals * -* Accepts only .bgf-format * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In readaddmol' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if -********************************************************************** -* * -* Set default values * -* * -********************************************************************** - iaddfreq=-1 !frequency of molecule addition; <0: no addition - xadd=-9000.0 !x-coordinate for added molecule; <-5000.0: random - yadd=-9000.0 !y-coordinate for added molecule; <-5000.0: random - zadd=-9000.0 !z-coordinate for added molecule; <-5000.0: random - iveladd=1 !1: random initial velocities; 2: read in velocities - !from addmol.vel - addist=-1.00 !Minimum distance between added molecule and rest - !of system. < 0.0: do not check - nadattempt=10 !Number of attempts at adding the molecule - taddmol=-1.0 !Temperature added molecule. <0.0: system temperature - open (19,file='addmol.bgf',status='old',err=60) - read (19,'(a40)',end=900,err=900)qromb - if (qromb(1:6).ne.'BIOGRF') then - write (*,*)'addmol.bgf should start with BIOGRF' - stop 'addmol.bgf should start with BIOGRF' - end if - naa=0 - iline=0 - 30 read (19,'(a200)',end=900,err=900)qhulp - irecog=0 - iline=iline+1 - - if (qhulp(1:6).eq.'DESCRP') then - irecog=1 - end if - - if (qhulp(1:6).eq.'FORMAT') then - irecog=1 - end if - - if (qhulp(1:6).eq.'REMARK') then - irecog=1 - end if - - if (qhulp(1:6).eq.'HETATM') then - irecog=1 - read (qhulp,'(7x,i5,1x,a5,1x,3x,1x,1x,1x,5x,3f10.5)' - $,end=900,err=900) - $ir,qlabhulp,cadd(naa+1,1),cadd(naa+1,2),cadd(naa+1,3) - if (qlabhulp(1:1).eq.' ') qlabhulp=qlabhulp(2:5) - if (qlabhulp(1:1).eq.' ') qlabhulp=qlabhulp(2:4) - if (qlabhulp(1:1).eq.' ') qlabhulp=qlabhulp(2:3) - if (qlabhulp(1:1).eq.'C ') qadd(naa+1)='C ' - if (qlabhulp(1:2).eq.'Ca') qadd(naa+1)='Ca' - if (qlabhulp(1:2).eq.'Cl') qadd(naa+1)='Cl' - if (qlabhulp(1:2).eq.'Cu') qadd(naa+1)='Cu' - if (qlabhulp(1:2).eq.'Co') qadd(naa+1)='Co' - if (qlabhulp(1:1).eq.'H ') qadd(naa+1)='H ' - if (qlabhulp(1:2).eq.'He') qadd(naa+1)='He' - if (qlabhulp(1:1).eq.'N ') qadd(naa+1)='N ' - if (qlabhulp(1:2).eq.'Ni') qadd(naa+1)='Ni' - if (qlabhulp(1:1).eq.'O ') qadd(naa+1)='O ' - if (qlabhulp(1:1).eq.'B ') qadd(naa+1)='B ' - if (qlabhulp(1:1).eq.'F ') qadd(naa+1)='F ' - if (qlabhulp(1:2).eq.'Fe') qadd(naa+1)='Fe' - if (qlabhulp(1:1).eq.'P ') qadd(naa+1)='P ' - if (qlabhulp(1:1).eq.'S ') qadd(naa+1)='S ' - if (qlabhulp(1:1).eq.'Y ') qadd(naa+1)='Y ' - if (qlabhulp(1:2).eq.'Al') qadd(naa+1)='Al' - if (qlabhulp(1:2).eq.'Au') qadd(naa+1)='Au' - if (qlabhulp(1:2).eq.'Si') qadd(naa+1)='Si' - if (qlabhulp(1:2).eq.'Pt') qadd(naa+1)='Pt' - if (qlabhulp(1:2).eq.'Mo') qadd(naa+1)='Mo' - if (qlabhulp(1:2).eq.'Mg') qadd(naa+1)='Mg' - if (qlabhulp(1:2).eq.'Ar') qadd(naa+1)='Ar' - if (qlabhulp(1:2).eq.'Zr') qadd(naa+1)='Zr' - if (qlabhulp(1:2).eq.'Ba') qadd(naa+1)='Ba' - if (qlabhulp(1:2).eq.'X ') qadd(naa+1)='X ' - ityadd(naa+1)=0 - do i1=1,nso !Find force field type - if (qadd(naa+1).eq.qas(i1)) ityadd(naa+1)=i1 - end do - if (ityadd(naa+1).eq.0) then - write (*,*) 'Unknown atom type:',qadd(naa+1) - stop 'Unknown atom type' - end if - naa=naa+1 - end if - - if (qhulp(1:7).eq.'FREQADD') then - irecog=1 - read (qhulp,'(8x,i6)',end=900,err=900) iaddfreq - end if - - if (qhulp(1:6).eq.'VELADD') then - irecog=1 - read (qhulp,'(8x,i6)',end=900,err=900) iveladd - end if - - if (qhulp(1:6).eq.'STARTX') then - irecog=1 - read (qhulp,'(7x,f8.2)',end=900,err=900) xadd - end if - - if (qhulp(1:6).eq.'STARTY') then - irecog=1 - read (qhulp,'(7x,f8.2)',end=900,err=900) yadd - end if - - if (qhulp(1:6).eq.'STARTZ') then - irecog=1 - read (qhulp,'(7x,f8.2)',end=900,err=900) zadd - end if - - if (qhulp(1:6).eq.'ADDIST') then - irecog=1 - read (qhulp,'(7x,f8.2)',end=900,err=900) addist - end if - - if (qhulp(1:8).eq.'NATTEMPT') then - irecog=1 - read (qhulp,'(9x,i6)',end=900,err=900) nadattempt - end if - - if (qhulp(1:7).eq.'TADDMOL') then - irecog=1 - read (qhulp,'(8x,f8.2)',end=900,err=900) taddmol - end if - - if (qhulp(1:6).eq.'FFIELD') goto 30 - if (qhulp(1:6).eq.'CONECT') goto 30 - if (qhulp(1:5).eq.'ORDER') goto 30 - if (qhulp(1:1).eq.'#') goto 30 - if (qhulp(1:3).eq.'END') goto 45 - - if (irecog.eq.0) then - write (*,*)'Warning: ignored line starting with: ',qhulp(1:10) - end if - - goto 30 - - 45 continue - close (19) - if (iveladd.eq.2) then - open (19,file='addmol.vel',status='old',err=800) - read (19,*) - read (19,'(3d24.15)',err=850,end=850) - $((veladd(j,i),j=1,3),i=1,naa) - close (19) - end if -************************************************************************ -* * -* Place molecule at origin * -* * -************************************************************************ - ccx=0.0 - ccy=0.0 - ccz=0.0 - do i1=1,naa - ccx=ccx+cadd(i1,1)/float(naa) - ccy=ccy+cadd(i1,2)/float(naa) - ccz=ccz+cadd(i1,3)/float(naa) - end do - do i1=1,naa - cadd(i1,1)=cadd(i1,1)-ccx - cadd(i1,2)=cadd(i1,2)-ccy - cadd(i1,3)=cadd(i1,3)-ccz - end do - - 60 continue - return - 800 stop 'Error opening addmol.vel' - 850 stop 'Error or end of file reading addmol.vel' - 900 write (*,*)'Error or end-of-file reading addmol.bgf on line:', - $iline - return - end -************************************************************************ -********************************************************************** - - subroutine writegeo(nunit1) - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkconst.blk" -#include "cbkqa.blk" -#include "cbkrestr.blk" -#include "cbktregime.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "opt.blk" -#include "small.blk" -#include "cbksrtbon1.blk" -#include "cbkinit.blk" -********************************************************************** -* * -* Copy new geometries to unit nunit1 * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In writegeo' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - if (axiss(1).lt.zero) then - if (nrestra.eq.0.and.nrestrat.eq.0.and. - $nrestrav.eq.0) - $write (nunit1,300)qr,qmol - if (nrestra.gt.0) write (nunit1,301)qr, - $rrstra(1),qmol - if (nrestrav.gt.0) write (nunit1,301)qr, - $vrstra(1),qmol - if (nrestrat.gt.0) write (nunit1,301)qr, - $trstra(1),qmol - else - write (nunit1,310)qr,qmol - write (nunit1,320)axiss(1),axiss(2),axiss(3) - write (nunit1,320)angles(1),angles(2),angles(3) - end if - do i1=1,na - if (nbiolab.ne.1) write (nunit1,400)i1,qa(i1),(c(i1,i2),i2=1,3) - if (nbiolab.eq.1) write (nunit1,401)i1,qa(i1),(c(i1,i2),i2=1,3) !Delphi-format - end do - if (nbiolab.ne.1) write (nunit1,*) - - return - - 300 format (2x,a1,1x,a60) - 301 format (2x,a1,1x,f6.2,a60) - 310 format (2x,a1,1x,a60) - 320 format (3f10.4) - 400 format (i4,1x,a2,3x,3(d21.14,1x),1x,a5,1x,i5) - 401 format (i3,2x,a2,3x,3(d21.14,1x),1x,a5,1x,i5) - end -********************************************************************** -********************************************************************** - - subroutine writebgf(nunit1) - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkcha.blk" -#include "cbkcharmol.blk" -#include "cbkconst.blk" -#include "cbkenergies.blk" -#include "cbkia.blk" -#include "cbkimove.blk" -#include "cbkinit.blk" -#include "cbkqa.blk" -#include "cbkrestr.blk" -#include "cbktregime.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "opt.blk" -#include "cbksrtbon1.blk" -#include "small.blk" - - dimension qdir(3) - character*2 qt - character*1 qdir -********************************************************************** -* * -* Copy new Biograf-geometries to unit nunit1 * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In newbgf' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - irom=1 - qdir(1)='x' - qdir(2)='y' - qdir(3)='z' - ibgfversion=200 - if (ibity.eq.1) write (nunit1,1500)ibgfversion - if (ibity.eq.2) write (nunit1,1600)ibgfversion -* if (qr.ne.'F'.and.qr.ne.'5'.and.qr.ne.'Y') -* $write (nunit1,1500)ibgfversion -* if (qr.eq.'F'.or.qr.eq.'5'.or.qr.eq.'Y') -* $write (nunit1,1600)ibgfversion - write (nunit1,1700)qmol -* write (nunit1,1700)qkeyw(nprob) - do i1=1,iremark - write (nunit1,1800)qremark(i1) - end do - qruid='NORMAL RUN' - if (iruid.eq.0) then - write (nunit1,2000) - else - if (abs(endpo-endpoold).gt.1e-5) write (nunit1,2010)endpo - if (nmmax.ne.nmmaxold) write (nunit1,2020)nmmax - if (nfc.ne.nfcold) write (nunit1,2030)nfc - if (ncha.ne.nchaold) write (nunit1,2036)ncha - if (iredo.gt.1) write (nunit1,2035)iredo - if (icell.ne.icellold) then - if (icell.eq.0) write (nunit1,2033) - if (icell.gt.0) write (nunit1,2034)ncellopt - end if - end if - if (iexco.ne.0.and.nsurp.gt.0) then - write (nunit1,2040)vvol - write (nunit1,3500) - write (nunit1,*) - return - end if - if (nmcharge.gt.0) then - do i3=1,nmcharge - write (nunit1,2050)iat1mc(i3),iat2mc(i3),vmcha(i3) - end do - end if - - ims=0 - do i1=1,na - if (ims.eq.0.and.imove(i1).eq.0) then - if1=i1 - ims=1 - end if - if (ims.eq.1.and.imove(i1).eq.1) then - write (nunit1,2060)if1,i1-1 - ims=0 - end if - end do - if (ims.eq.1) then - write (nunit1,2060)if1,na - end if - -* if (qr.eq.'F'.or.qr.eq.'5'.or.qr.eq.'Y') - if (ibity.eq.2) - $write (nunit1,2100)axiss(1),axiss(2),axiss(3),angles(1), - $angles(2),angles(3) - - if (nrestra.gt.0) write (nunit1,2300) - do i2=1,nrestra - write (nunit1,2400) - $irstra(i2,1),irstra(i2,2),rrstra(i2), - $vkrstr(i2),vkrst2(i2),rrcha(i2),itstart(i2),itend(i2) - end do - - if (nrestrav.gt.0) write (nunit1,2500) - do i2=1,nrestrav - write (nunit1,2600) - $irstrav(i2,1),irstrav(i2,2),irstrav(i2,3), - $vrstra(i2),vkrv(i2),vkr2v(i2),zero - end do - - if (nrestrat.gt.0) write (nunit1,2700) - do i2=1,nrestrat - write (nunit1,2800) - $irstrat(i2,1),irstrat(i2,2),irstrat(i2,3), - $irstrat(i2,4),trstra(i2),vkrt(i2), - $vkr2t(i2),zero - end do - - if (nrestram.gt.0) write (nunit1,2810) - do i2=1,nrestram - write (nunit1,2820) - $qdir(irstram(i2,1)),irstram(i2,2),irstram(i2,3), - $rmstra1(i2),irstram(i2,4),irstram(i2,5),rmstra2(i2), - $rmstra3(i2),rmcha(i2) - end do - - if (icgeo.eq.0.and.ingeo.eq.0) write (nunit1,2830) - if (icgeo.eq.1.and.ingeo.eq.1) write (nunit1,2840) - if (ifreq.eq.1) write (nunit1,2850) - write (nunit1,2900) - do i2=1,na - write (nunit1,3000)i2,qa(i2),c(i2,1),c(i2,2),c(i2,3), - $qa(i2),irom,irom,chgbgf(i2) - end do - write (nunit1,3100) - if (nsurp.lt.2) then - do i1=1,na - write (nunit1,3200)i1,(iag(i1,2+i2),i2=1,iag(i1,2)) - end do - write (nunit1,3300) - write (nunit1,3400)estrc - end if - - write (nunit1,3500) - write (nunit1,*) - - return - 1500 format ('BIOGRF',i4) - 1600 format ('XTLGRF',i4) - 1700 format ('DESCRP ',a60) - 1800 format ('REMARK ',a60) - 1900 format ('FFIELD ',a40) - 2000 format ('RUTYPE NORMAL RUN') - 2010 format ('RUTYPE ENDPO',f6.3) - 2020 format ('RUTYPE MAXIT',i6) - 2030 format ('RUTYPE MAXMOV',i6) - 2033 format ('RUTYPE NO CELL OPT') - 2034 format ('RUTYPE CELL OPT',i6) - 2035 format ('RUTYPE REDO',i6) - 2036 format ('RUTYPE CHARGEMET',i6) - 2040 format ('VCHANGE',f8.4) - 2050 format ('MOLCHARGE',2i4,f6.2) - 2060 format ('FIXATOMS',2i6) - 2100 format ('CRYSTX ',6f11.5) - 2200 format ('CELLS ',6i5) - 2300 format ('# At1 At2 R12 Force1 Force2 ', - $'dR12/dIter(MD) Start (MD) End (MD)') - 2400 format ('BOND RESTRAINT ',2i4,f8.4,f8.2,f8.4,1x,f10.7,2i8) - 2500 format ('# At1 At2 At3 Angle Force1 Force2', - $' dAngle/dIteration (MD only)') - 2600 format ('ANGLE RESTRAINT ',3i4,2f8.2,f8.4,f9.6) - 2700 format ('# At1 At2 At3 At3 Angle Force1 ', - $'Force2 dAngle/dIteration (MD only)') - 2800 format ('TORSION RESTRAINT ',4i4,2f8.2,f8.4,f9.6) - 2810 format ('# x/y/z At1 At2 R At3 At4 Force1', - $' Force2 dR/dIteration (MD only)') - 2820 format ('MASCEN RESTRAINT ',a1,1x,2i4,f8.2,2i4,2f8.2,f9.6) - 2830 format ('GEOUPD') - 2840 format ('NO GEOUPD') - 2850 format ('FREQUENCY') - 2900 format ('FORMAT ATOM (a6,1x,i5,1x,a5,1x,a3,1x,a1,1x,a5,', - $'3f10.5,1x,a5,i3,i2,1x,f8.5)') - 3000 format ('HETATM',1x,i5,1x,a2,3x,1x,3x,1x,1x,1x,5x,3f10.5,1x, - $a5,i3,i2,1x,f8.5) - 3100 format ('FORMAT CONECT (a6,12i6)') - 3200 format ('CONECT',12i6) - 3300 format ('UNIT ENERGY kcal') - 3400 format ('ENERGY',5x,f14.6) - 3500 format ('END') - - end -********************************************************************** -********************************************************************** - - subroutine writeen(tottime,sum1,sdev,sdeva,sum12,sumt,sump, - $sumtt,tmax,eaver,eav2,eav3,etot2,ediff) -********************************************************************** -#include "cbka.blk" -#include "cbkcha.blk" -#include "cbkenergies.blk" -#include "cbkrestr.blk" -#include "cbktorang.blk" -#include "cbktorsion.blk" -#include "cbktregime.blk" -#include "control.blk" -#include "small.blk" - - dimension disres(mrestra) -********************************************************************** -* * -* Write out MD statistics to units 71,73 and 76 * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In writeen' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - - if (nrep1.gt.1) - $sdev=sqrt((sum12-sum1*sum1/float(nrep1))/float(nrep1-1)) - eavn=eaver/float(mdstep) - if (mdstep.gt.1) - $sdeva=sqrt((eav3-eav2*eav2/float(mdstep))/float(mdstep-1)) -C open (71,file='fort.71',status='unknown',access='append') -C open (73,file='fort.73',status='unknown',access='append') - write (71,'(i8,2i4,1x,19(f10.2,1x))')mdstep+nprevrun,nmolo, - $nmolo5,estrc,ekin,estrc+ekin,tempmd,sum1/float(nrep1),eavn, - $sumt/float(nrep1),tmax,sump/float(nrep1),sdev,sdeva,tset, - $tstep*1d+15,rmsg,tottime - write (73,'(i8,1x,14(f10.2,1x))')mdstep+nprevrun,eb,ea,elp, - $emol,ev,ecoa,ehb,et,eco,ew,ep,ech,efi - close (71) - close (73) - - if ((sumt/float(nrep1)).gt.tset) then - if (invt.eq.0) write (*,*)'Switched to NVT in iteration',mdstep - invt=1 - end if - -C if (nrestra.gt.0.or.nrestrat.gt.0) -C $open (76,file='fort.76',status='unknown',access='append') - - if (nrestra.gt.0) then - do i2=1,nrestra - call dista2(irstra(i2,1),irstra(i2,2),disres(i2),dx,dy,dz) - end do -C open (76,file='fort.76',status='unknown',access='append') - write (76,'(i8,1x,40f12.4)')mdstep,eres,estrc, - $(rrstra(i2),disres(i2),i2=1,nrestra) - end if - - if (nrestrat.gt.0) then -C open (76,file='fort.76',status='unknown',access='append') - do i2=1,nrestrat - do i3=1,ntor - ih1=irstrat(i2,1) - ih2=irstrat(i2,2) - ih3=irstrat(i2,3) - ih4=irstrat(i2,4) - if (ih1.eq.it(i3,2).and.ih2.eq.it(i3,3).and.ih3.eq.it(i3,4) - $.and.ih4.eq.it(i3,5)) ittr=i3 - end do - write (76,'(i8,1x,40f12.4)')mdstep,eres, - $trstra(i2),thg(ittr) - end do - end if - - if (nrestra.gt.0.or.nrestrat.gt.0) close(76) - - if (nrestram.gt.0) then -C open (76,file='fort.76',status='unknown',access='append') - do i2=1,nrestram - write (76,'(2i8,1x,20f12.4)')mdstep,i2,eres,rmstra1(i2), - $dismacen(i2) - end do - close (76) - end if - - return - end -********************************************************************** -************************************************************************ - - subroutine molanal - -************************************************************************ -#include "cbka.blk" -#include "cbkbo.blk" -#include "cbkconst.blk" -#include "cbkdcell.blk" -#include "cbkff.blk" -#include "cbkia.blk" -#include "cbkrbo.blk" -#include "control.blk" -#include "opt.blk" -#include "small.blk" -#include "cbksrtbon1.blk" - dimension iam(nat,mbond+3),nmolata(nmolmax,nat) - dimension molfra(nmolmax,nsort),ndup(nmolmax) - character*40 qmolan1 - character*100 qmolan - logical found -************************************************************************ -* * -* Analyse and output molecular fragments * -* * -************************************************************************ -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In molanal' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - - do i1=1,nmolmax - do i2=1,nsort - molfra(i1,i2)=0 - end do - ndup(i1)=1 - end do - - do i1=1,na - do i2=1,mbond+3 - iam(i1,i2)=0 - end do - end do -************************************************************************ -* * -* Create connection table based on corrected bond orders * -* * -************************************************************************ - do i1=1,nbon - if (bo(i1).gt.cutof3) then - j1=ib(i1,2) - j2=ib(i1,3) - iam(j1,2)=iam(j1,2)+1 - iam(j1,2+iam(j1,2))=j2 - iam(j2,2)=iam(j2,2)+1 - iam(j2,2+iam(j2,2))=j1 - end if - end do -********************************************************************** -* * -* Find molecules * -* * -********************************************************************** - nmolo6=0 - found=.FALSE. - DO 61 k1=1,na - IF (iam(K1,3+mbond).EQ.0) found=.TRUE. - 61 IF (iam(K1,3+mbond).GT.nmolo6) nmolo6=iam(K1,3+mbond) - IF (.NOT.FOUND) GOTO 62 -************************************************************************ -* * -* Molecule numbers are assigned. No restrictions are made for the * -* sequence of the numbers in the connection table. * -* * -************************************************************************ - N3=1 - 64 N2=N3 - nmolo6=nmolo6+1 - if (nmolo6.gt.nmolmax) stop 'Too many molecules in system' - iam(N2,3+mbond)=nmolo6 - 67 FOUND=.FALSE. - DO 66 N1=N2+1,na - IF (iam(N1,3+mbond).NE.0) GOTO 66 - DO 65 L=1,mbond - IF (iam(N1,l+2).EQ.0) GOTO 66 - IF (iam(iam(N1,l+2),3+mbond).EQ.nmolo6) THEN - FOUND=.TRUE. - iam(N1,3+mbond)=nmolo6 - GOTO 66 - ENDIF - 65 CONTINUE - 66 CONTINUE - IF (FOUND) GOTO 67 - DO 63 N3=N2+1,NA - 63 if (iam(N3,3+mbond).eq.0) goto 64 -************************************************************************ -* * -* The assigned or input molecule numbers are checked for their * -* consistency. * -* * -************************************************************************ - 62 FOUND=.FALSE. - DO 72 N1=1,NA - DO 71 L=1,mbond - IF (iam(N1,L+2).EQ.0) GOTO 72 - IF (iam(iam(N1,L+2),3+mbond).NE.iam(N1,3+mbond)) THEN - FOUND=.TRUE. - ENDIF - 71 CONTINUE - 72 CONTINUE - IF (FOUND) THEN - write (7,'(i4,a40)')na,qmol - do i1=1,na - write (7,'(40i4)')i1,iam(i1,1),(iam(i1,2+i2),i2=1,nsbmax), - $iam(i1,3+mbond) - end do - STOP' Mol.nrs. not consistent; maybe wrong cell parameters' - ENDIF - - do i1=1,nmolo6 - natmol=0 - do i2=1,na - if (iam(i2,3+mbond).eq.i1) then - natmol=natmol+1 - nmolata(i1,natmol+1)=i2 - end if - end do - nmolata(i1,1)=natmol - end do -************************************************************************ -* * -* Analyze molecules * -* * -************************************************************************ - do i1=1,nmolo6 - do i2=1,nmolata(i1,1) - i3=nmolata(i1,1+i2) - ityp=ia(i3,1) - molfra(i1,ityp)=molfra(i1,ityp)+1 - end do - end do - - do i1=1,nmolo6 - isee=0 - do i2=1,nmolo6 - isee2=1 - do i3=1,nso - if (molfra(i1,i3).ne.molfra(i2,i3)) isee2=0 - end do - if (isee2.eq.1.and.i1.gt.i2.and.isee.eq.0) then !molecule type already exists - ndup(i2)=ndup(i2)+1 - ndup(i1)=0 - isee=1 - end if - - end do - end do - -C open (45,file='molfra.out',status='unknown',access='append') - if (mdstep.eq.0) write (45,100)cutof3 - write (45,110) - ntotmol=0 - ntotat=0 - vtotmass=zero - do i1=1,nmolo6 - if (ndup(i1).gt.0) then -* write (45,110)i1,(molfra(i1,i2),i2=1,nso),ndup(i1) - ntotmol=ntotmol+ndup(i1) - qmolan=' ' - qmolan1=' ' - istart=-4 - ihulp=0 - vmass=zero - do i2=1,nso - vmass=vmass+molfra(i1,i2)*amas(i2) - ntotat=ntotat+molfra(i1,i2)*ndup(i1) - if (molfra(i1,i2).gt.0) then - istart=istart+6 - iend=istart+5 - if (molfra(i1,i2).gt.1) then - write (qmolan(istart:iend),'(a2,i3)')qas(i2),molfra(i1,i2) - else - write (qmolan(istart:iend-2),'(a2)')qas(i2) - end if - end if - end do - ihulp=1 - do i2=1,iend - if (qmolan(i2:i2).ne.' ') then - qmolan1(ihulp:ihulp)=qmolan(i2:i2) - ihulp=ihulp+1 - end if - end do - -* write (45,120)ndup(i1),qmolan(1:iend),vmass - write (45,120)mdstep,ndup(i1),qmolan1,vmass - vtotmass=vtotmass+ndup(i1)*vmass - end if - end do - write (45,*)'Total number of molecules:',ntotmol - write (45,*)'Total number of atoms:',ntotat - write (45,*)'Total system mass:',vtotmass - close (45) - return - 100 format('Bond order cutoff:',f6.4) - 110 format('Iteration Freq. Molecular formula',15x,'Molecular mass') - 120 format(i8,i4,' x ',a35,f10.4) - end -************************************************************************ -************************************************************************ - - subroutine stranal(istart,iend,vout,iout,icheck) - -************************************************************************ -#include "cbka.blk" -#include "cbkconst.blk" -#include "opt.blk" - - character*1 qchar - dimension qchar(5) -********************************************************************** -* * -* Analyze string for special characters; find words in string * -* * -********************************************************************** - qchar(1)=' ' - qchar(2)='/' - - ifound1=0 - do i1=istart,200 - ifound2=0 - do i2=1,icheck - - if (qstrana1(i1:i1).eq.qchar(i2)) then - ifound2=1 - if (ifound1.eq.1) then !End of word - iend=i1 - goto 10 - end if - - end if - - end do - - if (ifound2.eq.0.and.ifound1.eq.0) then !Start of word - istart2=i1 - ifound1=1 - end if - - end do - - 10 continue - qstrana2=' ' - vout=zero - iout=0 - - if (ifound1.eq.1) then - qstrana2=qstrana1(istart2:iend-1) - istart=istart2 - vout=zero - read (qstrana2,*,end=20,err=20) vout - 20 iout=int(vout) - end if - - return - end -************************************************************************ -********************************************************************** - - subroutine dipmom(naold,dpmm,xdip,ydip,zdip,xdir,ydir,zdir) - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkch.blk" -#include "cbkconst.blk" -#include "control.blk" -#include "small.blk" -********************************************************************** -* * -* Calculate and output dipole moment * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In dipmom' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if -************************************************************************ -* * -* CONVERSION FACTOR TO DEBYE UNITS IS CALCULATED * -* THE CALCULATION IS INITIALIZED * -* * -************************************************************************ - - ELCHG=1.60217733D-19 ! [C] = [As] - CLIGHT=2.99792458D8 ! [m/s] - DBCONV=ONE/(CLIGHT*ELCHG*1.0D11) - - CHCPX=ZERO - CHCPY=ZERO - CHCPZ=ZERO - CHCMX=ZERO - CHCMY=ZERO - CHCMZ=ZERO - XDIP=ZERO - YDIP=ZERO - ZDIP=ZERO - XGRD=ZERO - YGRD=ZERO - ZGRD=ZERO -************************************************************************ -* * -* CALCULATION OF MAGNITUDE AND CENTRES OF POSITIVE AND NEGATIVE * -* CHARGES * -* * -************************************************************************ - - if (na.eq.0) na=naold - CHRG=ZERO - DO 4 K1=1,NA - CHK1=CH(K1) - IF (CHK1.EQ.ZERO) GOTO 4 - IF (CHK1.LT.ZERO) GOTO 3 - CHRG=CHRG+CHK1 - CHCPX=CHCPX+CHK1*C(K1,1) - CHCPY=CHCPY+CHK1*C(K1,2) - CHCPZ=CHCPZ+CHK1*C(K1,3) - GOTO 4 - 3 CHCMX=CHCMX-CHK1*C(K1,1) - CHCMY=CHCMY-CHK1*C(K1,2) - CHCMZ=CHCMZ-CHK1*C(K1,3) - 4 CONTINUE - -************************************************************************ -* * -* CALCULATION OF DISTANCE BETWEEN CENTRES AND OF DIPOLE MOMENT * -* IN DEBIJE UNITS * -* * -************************************************************************ - - CHDSTX=CHCPX-CHCMX - CHDSTY=CHCPY-CHCMY - CHDSTZ=CHCPZ-CHCMZ - DPMM=SQRT(CHDSTX*CHDSTX+CHDSTY*CHDSTY+CHDSTZ*CHDSTZ)/DBCONV - IF(DPMM.LT.1.0D-4)RETURN - XDIP=HALF*(CHCPX+CHCMX)/CHRG - YDIP=HALF*(CHCPY+CHCMY)/CHRG - ZDIP=HALF*(CHCPZ+CHCMZ)/CHRG - GRTST=MAX(CHDSTX,CHDSTY,CHDSTZ) - XDIR=-CHDSTX/GRTST - YDIR=-CHDSTY/GRTST - ZDIR=-CHDSTZ/GRTST - open (64,file='dipole.out',status='unknown') - write (64,100)dpmm,xdip,ydip,zdip,xdir,ydir,zdir - close (64) - - 100 format ('Dipole moment (Debye):',f12.4,' Location:',3f12.4, - $' Direction (-side):',3f12.4) - return - end -************************************************************************ -********************************************************************** - - subroutine readtraj(ivels) - -********************************************************************** -#include "cbka.blk" -#include "cbkatomcoord.blk" -#include "cbkc.blk" -#include "cbkconst.blk" -#include "cbkdistan.blk" -#include "cbktregime.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "small.blk" -#include "cbkinit.blk" -********************************************************************** -* * -* Read in trajectory file * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In readtraj' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - - open(unit=66,file='moldyn.vel',status='old',err=10) - ivels=1 - read (66,*) - read (66,100)aaxis,baxis,caxis - read (66,100)angles(1),angles(2),angles(3) - if (qr.eq.'F'.or.qr.eq.'P'.or.ngeofor.eq.1) then - axis(1)=aaxis - axis(2)=baxis - axis(3)=caxis - axiss(1)=axis(1) - axiss(2)=axis(2) - axiss(3)=axis(3) - angle(1)=angles(1) - angle(2)=angles(2) - angle(3)=angles(3) - halfa=angle(1)*dgrrdn - hbeta=angle(2)*dgrrdn - hgamma=angle(3)*dgrrdn - sinalf=sin(halfa) - cosalf=cos(halfa) - sinbet=sin(hbeta) - cosbet=cos(hbeta) - cosphi=(cos(hgamma)-cosalf*cosbet)/(sinalf*sinbet) - if (cosphi.gt.1.0) cosphi=1.0 - sinphi=sqrt(one-cosphi*cosphi) - tm11=axis(1)*sinbet*sinphi - tm21=axis(1)*sinbet*cosphi - tm31=axis(1)*cosbet - tm22=axis(2)*sinalf - tm32=axis(2)*cosalf - tm33=axis(3) - end if - if (aaxis.ne.axis(1).or.baxis.ne.axis(2).or.caxis.ne.axis(3)) - $stop 'Wrong cell parameters in moldyn.vel' - read (66,200)nan - if (nan.ne.na) stop 'Wrong number of atoms in moldyn.vel-file' - if (nbiolab.eq.1) write (*,*)'Warning: using labels in vels-file' - read (66,250)((c(i,j),j=1,3),qlabel(i),i=1,na) - read (66,*) - read (66,300)((vel(j,i),j=1,3),i=1,na) - read (66,*) - read (66,300)((accel(j,i),j=1,3),i=1,na) - read (66,*) - read (66,300,end=10,err=10)((aold(j,i),j=1,3),i=1,na) - read (66,*) - read (66,300,end=10,err=10)tempmd - read (66,*) - read (66,350,end=10,err=10)nsbma2 - 10 continue -********************************************************************** -* * -* Format part * -* * -********************************************************************** - 100 format(3d15.8) - 200 format(i4) - 250 format(3d24.15,1x,a5) - 300 format(3d24.15) - 350 format(i3) - 400 format (8i3,8f8.4) - return - end -********************************************************************** diff --git a/lib/reax/reax_lammps.F b/lib/reax/reax_lammps.F deleted file mode 100644 index 116e88827d..0000000000 --- a/lib/reax/reax_lammps.F +++ /dev/null @@ -1,392 +0,0 @@ -********************************************************************** -* * -* REAXFF Reactive force field program * -* * -* Developed and written by Adri van Duin, duin@wag.caltech.edu * -* * -* Copyright (c) 2001-2010 California Institute of Technology * -* * -* This is an open-source program. Feel free to modify its * -* contents. Please keep me informed of any useful modification * -* or addition that you made. Please do not distribute this * -* program to others; if people are interested in obtaining * -* a copy of this program let them contact me first. * -* * -********************************************************************** -********************************************************************** - - subroutine getswb(swb_tmp) - -********************************************************************** -#include "cbka.blk" -#include "cbkff.blk" - real*8 swb_tmp - -********************************************************************** -* * -* Report the value of swb * -* * -********************************************************************** - - swb_tmp = swb - - return - end - -********************************************************************** - - subroutine getswa(swa_tmp) - -********************************************************************** -#include "cbka.blk" -#include "cbkff.blk" - real*8 swa_tmp - -********************************************************************** -* * -* Report the value of swa * -* * -********************************************************************** - - swa_tmp = swa - - return - end - -********************************************************************** - - subroutine getvrange(vrange_tmp) - -********************************************************************** -#include "cbka.blk" -#include "control.blk" - real*8 vrange_tmp - -********************************************************************** -* * -* Report the value of vrange * -* * -********************************************************************** - - vrange_tmp = vrange - - return - end - -********************************************************************** - - subroutine getnvlist(nvlist_tmp) - -********************************************************************** -#include "cbka.blk" - integer nvlist_tmp - -********************************************************************** -* * -* Report the value of nvlist * -* * -********************************************************************** - - nvlist_tmp = nvlist - - return - end - -********************************************************************** - - subroutine getvlbora(vlbora_tmp) - -********************************************************************** -#include "cbka.blk" -#include "control.blk" - real*8 vlbora_tmp - -********************************************************************** -* * -* Report the value of vlbora * -* * -********************************************************************** - - vlbora_tmp = vlbora - - return - end - -********************************************************************** - - subroutine getnval(nval_tmp) - -********************************************************************** -#include "cbka.blk" -#include "cbkvalence.blk" - integer nval_tmp - -********************************************************************** -* * -* Report the value of nval * -* * -********************************************************************** - - nval_tmp = nval - - return - end - -********************************************************************** - - subroutine getntor(ntor_tmp) - -********************************************************************** -#include "cbka.blk" -#include "cbktorsion.blk" - integer ntor_tmp - -********************************************************************** -* * -* Report the value of ntor * -* * -********************************************************************** - - ntor_tmp = ntor - - return - end - - -********************************************************************** - - subroutine getnhb(nhb_tmp) - -********************************************************************** -#include "cbka.blk" -#include "cbksrthb.blk" - integer nhb_tmp - -********************************************************************** -* * -* Report the value of nhb * -* * -********************************************************************** - - nhb_tmp = nhb - - return - end - - -********************************************************************** - - subroutine getnbonall(nbonall_tmp) - -********************************************************************** -#include "cbka.blk" -#include "cbksrtbon1.blk" - integer nbonall_tmp - -********************************************************************** -* * -* Report the value of nbonall * -* * -********************************************************************** - - nbonall_tmp = nbonall - - return - end - - -********************************************************************** - - subroutine getnneighmax(nneighmax_tmp) - -********************************************************************** -#include "cbka.blk" - integer nneighmax_tmp - -********************************************************************** -* * -* Report the value of nneighmax * -* * -********************************************************************** - - nneighmax_tmp = nneighmax - - return - end - -********************************************************************** - - subroutine getnat(nat_tmp) - -********************************************************************** -#include "cbka.blk" - integer nat_tmp - -********************************************************************** -* * -* Report the value of nat * -* * -********************************************************************** - - nat_tmp = nat - - return - end - -********************************************************************** - - subroutine getnattot(nattot_tmp) - -********************************************************************** -#include "cbka.blk" - integer nattot_tmp - -********************************************************************** -* * -* Report the value of nattot * -* * -********************************************************************** - - nattot_tmp = nattot - - return - end - -********************************************************************** - - subroutine getnsort(nsort_tmp) - -********************************************************************** -#include "cbka.blk" - integer nsort_tmp - -********************************************************************** -* * -* Report the value of nsort * -* * -********************************************************************** - - nsort_tmp = nsort - - return - end - -********************************************************************** - - subroutine getmbond(mbond_tmp) - -********************************************************************** -#include "cbka.blk" - integer mbond_tmp - -********************************************************************** -* * -* Report the value of mbond * -* * -********************************************************************** - - mbond_tmp = mbond - - return - end - -********************************************************************** - - subroutine getnso(nso_tmp) - -********************************************************************** -#include "cbka.blk" -#include "cbkff.blk" - integer nso_tmp - -********************************************************************** -* * -* Report the value of nso * -* * -********************************************************************** - - nso_tmp = nso - - return - end - - -********************************************************************** - - subroutine setngeofor(ngeofor_tmp) - -********************************************************************** -#include "cbka.blk" -#include "control.blk" - integer ngeofor_tmp - -********************************************************************** -* * -* Set value of ngeofor -* * -********************************************************************** - - ngeofor = ngeofor_tmp - return - end - -********************************************************************** - - subroutine getnsbmax(nsbmax_tmp) - -********************************************************************** -#include "cbka.blk" -#include "cbksrtbon1.blk" - integer nsbmax_tmp - -********************************************************************** -* * -* Report the value of nsbmax * -* * -********************************************************************** - - nsbmax_tmp = nsbmax - - return - end - -********************************************************************** - - subroutine getnsbma2(nsbma2_tmp) - -********************************************************************** -#include "cbka.blk" -#include "cbksrtbon1.blk" - integer nsbma2_tmp - -********************************************************************** -* * -* Report the value of nsbma2 * -* * -********************************************************************** - - nsbma2_tmp = nsbma2 - - return - end - -********************************************************************** - - subroutine getcutof3(cutof3_tmp) - -********************************************************************** -#include "cbka.blk" -#include "control.blk" - real*8 cutof3_tmp - -********************************************************************** -* * -* Report the value of cutof3 * -* * -********************************************************************** - - cutof3_tmp = cutof3 - - return - end - diff --git a/lib/reax/reax_poten.F b/lib/reax/reax_poten.F deleted file mode 100644 index 2228f8546b..0000000000 --- a/lib/reax/reax_poten.F +++ /dev/null @@ -1,3985 +0,0 @@ -********************************************************************** -* * -* REAXFF Reactive force field program * -* * -* Developed and written by Adri van Duin, duin@wag.caltech.edu * -* * -* Copyright (c) 2001-2010 California Institute of Technology * -* * -* This is an open-source program. Feel free to modify its * -* contents. Please keep me informed of any useful modification * -* or addition that you made. Please do not distribute this * -* program to others; if people are interested in obtaining * -* a copy of this program let them contact me first. * -* * -********************************************************************** -******************************************************************** - - subroutine calval - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkdhdc.blk" -#include "cbkdrdc.blk" -#include "cbkh.blk" -#include "cbkrbo.blk" -#include "cbkvalence.blk" -#include "cellcoord.blk" -#include "control.blk" - dimension a(3),b(3),j(3),dradc(3,3),drbdc(3,3),dtdc(3,3), - $dargdc(3,3),dndc(3,3),dadc(3),dbdc(3) -********************************************************************** -* * -* Calculate valency angles and their derivatives to cartesian * -* coordinates * -* Valency angle energies are calculated in valang * -* * -********************************************************************** -********************************************************************** -* Description of variables used in this routine. -* -* ndebug: stored in cbka.blk; control-parameter -* third: local variable -* twothird: local variable -* dadc(3): local array; stores derivative distance to cartesians -* dbdc(3): local array; stores derivative distance to cartesians -* i1: local do-loop counter -* i2: local do-loop counter -* k1: local do-loop counter -* k2: local do-loop counter -* dradc(3,3): local array; stores derivatives bond lengths to -* cartesians -* drbdc(3,3): local array; stores derivatives bond lengths to -* cartesians -* nval: stored in cbka.blk; number of valence angles -* ity: local integer; atom type -* iv(nvalmax,6): stored in cbka.blk; valence angle identifiers -* j(3): local integer array; stores valence angle atom numbers -* la: local integer: stores bond numbers in valence angle -* lb: local integer: stores bond numbers in valence angle -* ivl1: local integer; stores symmetric copy number of bond -* ivl2: local integer; stores symmetric copy number of bond -* ibsym(nbomax): stored in cbka.blk; symmetric copy number of bond -* isign1: local integer; -1 or 1 -* isign2: local integer; -1 or 1 -* rla: local variable; stores bond length for bond la -* rlb: local variable; stores bond length for bond lb -* rbo(nbomax): stored in cbka.blk; stores bond lengths -* ix1,iy1,iz1,ix2,iy2,iz2: local integers; periodic cell shifts -* a(3): local variable; distance in x,y and z-direction between atoms -* b(3): local variable; distance in x,y and z-direction between atoms -* c(nat,3): stored in cbka.blk; cartesian coordinate array -* tm11,tm21,tm22,tm31,tm32,tm33: stored in cbka.blk; periodic cell -* matrix -* poem: local variable; product of bond lengths -* tel: local variable; cross-product of x,y and z-interatomic -* distances -* arg: local variable; cosine of angle between bonds a and b -* arg2: local variable; square of arg -* s1ma22: local variable; used to check whether angle gets to 180 -* degrees -* s1ma2: local variable; square root of s1ma22 -* hl: local variable; angle (in radians) between bonds a and b -* h(nvamax): stored in cbka.blk; angle (in radians) between bonds a -* and b -* ib(nbomax,3): stored in cbka.blk: bond distance identifiers -* drdc(nbomax,3,2): stored in cbka.blk; derivatives bond distances -* to cartesian coordinates -* dndc(3,3): local variable; temporary storage for calculating -* derivatives of valence angle to cartesians -* dtdc(3,3): local variable; temporary storage for calculating -* derivatives of valence angle to cartesians -* dargdc(3,3): local variable; temporary storage for calculating -* derivatives of valence angle to cartesians -* dhdc(nvamax,3,3): stored in cbka.blk; derivatives of valence angle -* to cartesians -* -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In calval' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - - third=1.0/3.0 - twothird=2.0/3.0 - dadc(1)=-1.0 - dadc(2)=1.0 - dadc(3)=0.0 - dbdc(1)=0.0 - dbdc(2)=1.0 - dbdc(3)=-1.0 - do k1=1,3 - do k2=1,3 - dradc(k1,k2)=0.0 - drbdc(k1,k2)=0.0 - end do - end do - if (nval.eq.0) return - - do 10 i1=1,nval - ity=iv(i1,1) - j(1)=iv(i1,2) - j(2)=iv(i1,3) - j(3)=iv(i1,4) -********************************************************************** -* * -* Determine valency angle * -* * -********************************************************************** - la=iv(i1,5) - lb=iv(i1,6) - ivl1=ibsym(la) - ivl2=ibsym(lb) - isign1=1 - isign2=1 - rla=rbo(la) - rlb=rbo(lb) - - call dista2(j(2),j(1),dis,a(1),a(2),a(3)) - call dista2(j(2),j(3),dis,b(1),b(2),b(3)) - - poem=rla*rlb - tel=a(1)*b(1)+a(2)*b(2)+a(3)*b(3) - arg=tel/poem - arg2=arg*arg - s1ma22=1.0-arg2 - if (s1ma22.lt.1.0d-10) s1ma22=1.0d-10 - s1ma2=sqrt(s1ma22) - if (arg.gt.1.0) arg=1.0 - if (arg.lt.-1.0) arg=-1.0 - hl=acos(arg) - h(i1)=hl -********************************************************************** -* * -* Calculate derivative valency angle to cartesian coordinates * -* * -********************************************************************** - if (j(1).eq.ib(la,2)) then - do k1=1,3 - dradc(k1,1)=drdc(la,k1,1) - dradc(k1,2)=drdc(la,k1,2) - end do - else - do k1=1,3 - dradc(k1,1)=drdc(la,k1,2) - dradc(k1,2)=drdc(la,k1,1) - end do - end if - if (j(2).eq.ib(lb,2)) then - do k1=1,3 - drbdc(k1,2)=drdc(lb,k1,1) - drbdc(k1,3)=drdc(lb,k1,2) - end do - else - do k1=1,3 - drbdc(k1,2)=drdc(lb,k1,2) - drbdc(k1,3)=drdc(lb,k1,1) - end do - end if - do k1=1,3 - do k2=1,3 - dndc(k1,k2)=rla*drbdc(k1,k2)+rlb*dradc(k1,k2) - dtdc(k1,k2)=a(k1)*dbdc(k2)+b(k1)*dadc(k2) - dargdc(k1,k2)=(dtdc(k1,k2)-arg*dndc(k1,k2))/poem - dhdc(i1,k1,k2)=-dargdc(k1,k2)/s1ma2 - end do - end do - - 10 continue - - return - end -********************************************************************** -********************************************************************** - - subroutine boncor - -********************************************************************** -#include "cbka.blk" -#include "cbkabo.blk" -#include "cbkc.blk" -#include "cbkbo.blk" -#include "cbkboncor.blk" -#include "cbkbosi.blk" -#include "cbkbopi.blk" -#include "cbkbopi2.blk" -#include "cbkconst.blk" -#include "cbkdbopi2ndc.blk" -#include "cbkdbopidc.blk" -#include "cbkdbopindc.blk" -#include "cbkff.blk" -#include "cbkia.blk" -#include "cbkidbo.blk" -#include "cbknubon2.blk" -#include "cbkrbo.blk" -#include "control.blk" -#include "small.blk" -#include "cbkdbodc.blk" -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In boncor' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if -********************************************************************** -* * -* Correction for overcoordination and 1-3 bond orders * -* * -********************************************************************** -********************************************************************** -* Description of variables used in this routine. -* -* ndebug: stored in cbka.blk; control-parameter -* i1: local do-loop counter -* i2: local do-loop counter -* k1: local do-loop counter -* k2: local do-loop counter -* nbon: stored in cbka.blk; number of bonds in system -* ibt: local integer; stores bond type -* ib(nbomax,3): stored in cbka.blk: bond distance identifiers -* j1: local integer; stores atom number 1st atom in bond -* j2: local integer; stores atom number 2nd atom in bond -* ovc(nbotym): stored in cbka.blk: force field parameter for -* overcoordination correction -* v13cor(nbotym): stored in cbka.blk: force field parameter for -* 1-3 bond order correction -* idbo1(nbomax): stored in cbka.blk; number of atoms in the -* derivative of the bond order -* idbo(nbomax,2*mbond): stored in cbka.blk; atom numbers of the -* atoms in the derivative of the bond order -* dbondc(nbomax,3,2*mbond): stored in cbka.blk; derivative of -* corrected total bond orders to cartesians -* dbosindc(nbomax,3,2*mbond): stored in cbka.blk; derivative of -* corrected sigma bond orders to cartesians -* dbopindc(nbomax,3,2*mbond): stored in cbka.blk; derivative of -* corrected pi bond orders to cartesians -* dbopi2ndc(nbomax,3,2*mbond): stored in cbka.blk; derivative of -* corrected double pi bond orders to cartesians -* dbodc(nbomax,3,2): stored in cbka.blk; derivative of -* uncorrected total bond orders to cartesians -* dbosidc(nbomax,3,2): stored in cbka.blk; derivative of -* uncorrected sigma bond orders to cartesians -* dbopidc(nbomax,3,2): stored in cbka.blk; derivative of -* uncorrected pi bond orders to cartesians -* dbopi2dc(nbomax,3,2): stored in cbka.blk; derivative of -* uncorrected double pi bond orders to cartesians -* boo: local variable; storage of uncorrected total bond order -* bo(nbomax): stored in cbka.blk; total bond order -* bopi(nbomax): stored in cbka.blk; pi bond order -* bopi2(nbomax): stored in cbka.blk; double pi bond order -* bopio: local variable; storage of uncorrected pi bond order -* bopi2o: local variable; storage of uncorrected double pi bond order -* iti: local integer; atom type first atom in bond -* itj: local integer; atom type second atom in bond -* ia(nat,mbond+3): stored in cbka.blk; connection table without bond -* order cutoff -* aboi: local variable: total bond order around atom i -* aboj: local variable: total bond order around atom j -* abo(nat): stored in cbka.blk; total bond order around atoms -* vp131: local variable; force field cross-term -* vp132: local variable; force field cross-term -* vp133: local variable; force field cross-term -* bo131(nsort): stored in cbka.blk; force field parameter for 1-3 -* bond order correction -* bo132(nsort): stored in cbka.blk; force field parameter for 1-3 -* bond order correction -* bo133(nsort): stored in cbka.blk; force field parameter for 1-3 -* bond order correction -* corrtot:local variable; total correction on bond order -* dbodsboi1: local variable; derivative of bond order to sum of bond -* orders around atom i -* dbodsboj1: local variable; derivative of bond order to sum of bond -* orders around atom j -* ovi: local variable; overcoordination on atom i -* ovj: local variable; overcoordination on atom j -* aval(nat): stored in cbka.blk; nr. of valence electrons on atom -* exphu1: local variable; stores exponential -* exphu2: local variable; stores exponential -* exp11: local variable; stores exponential -* exp21: local variable; stores exponential -* vpar(npamax): stored in cbka.blk: general parameters -* exphu12: local variable; stores sum of exponential -* ovcor: local variable; temporary storage for BO/ovcor corr. -* huli: local variable; temporary storage for BO/ovcor corr. -* hulj: local variable; temporary storage for BO/ovcor corr. -* corr1: local variable; temporary storage for BO/ovcor corr. -* corr2: local variable; temporary storage for BO/ovcor corr. -* dbodsboi2: local variable; derivative of 1-3 BO correction to sum -* of bond orders around atom i -* dbodsboj2: local variable; derivative of 1-3 BO correction to sum -* of bond orders around atom i -* bocor1: local variable; 1-3 bond order correction -* bocor2: local variable; 1-3 bond order correction -* ovi2: local variable; overcoordination on atom i with reference to -* total number of electrons on atom i, including lone -* pairs -* ovj2: local variable; overcoordination on atom j with reference to -* total number of electrons on atom j, including lone -* pairs -* valf(nsort): stored in cbka.blk; total number of electrons on -* atom, including lone pairs -* cor1: local variable; temporary storage for BO/1-3 bond corr. -* cor2: local variable; temporary storage for BO/1-3 bond corr. -* exphu3: local variable; storage exponential -* exphu4: local variable; storage exponential -* corrtot2: local variable; square of corrtot -* dbodboo: local variable; derivative of corrected total bond order to -* uncorrected bond order -* dbopidbopio: local variable; derivative of corrected pi bond order -* to uncorrected pi bond order -* dbopidboo: local variable; derivative of corrected pi bond order -* to uncorrected total bond order -* dbopi2dbopi2o: local variable; derivative of corrected double pi bond order -* to uncorrected double pi bond order -* dbopi2dboo: local variable; derivative of corrected double pi bond order -* to uncorrected total bond order -* dbodsboit: local variable; derivative of total bond order to sum -* of bond orders around atom i -* dbodsbojt: local variable; derivative of total bond order to sum -* of bond orders around atom j -* vhui: local variable; temporary storage -* vhuj: local variable; temporary storage -* dbopidsboit: local variable; derivative of pi bond order to sum -* of bond orders around atom i -* dbopidsbojt: local variable; derivative of pi bond order to sum -* of bond orders around atom j -* dbopi2dsboit: local variable; derivative of pi bond order to sum -* of bond orders around atom i -* dbopi2dsbojt: local variable; derivative of pi bond order to sum -* of bond orders around atom j -* nco: local integer; counter for number of atoms in derivative -* ihl: local integer; helps to access right dbodc-term -* nubon2(nat,mbond): stored in cbka.blk; stored bond number as a -* function of atom number and connection number -* iob: local integer; atom number of second atom in bond -* ncubo: local integer; stores number of current bond -* na: stored in cbka.blk: number of atoms in system -* zero: stored in cbka.blk: value 0.00 -* -********************************************************************** - do 10 i1=1,nbon - ibt=ib(i1,1) - j1=ib(i1,2) - j2=ib(i1,3) - if (ovc(ibt).lt.0.001.and.v13cor(ibt).lt.0.001) then - idbo1(i1)=2 - idbo(i1,1)=j1 - idbo(i1,2)=j2 - do k1=1,3 - dbondc(i1,k1,1)=dbodc(i1,k1,1) - dbondc(i1,k1,2)=dbodc(i1,k1,2) - dbosindc(i1,k1,1)=dbosidc(i1,k1,1) - dbosindc(i1,k1,2)=dbosidc(i1,k1,2) - dbopindc(i1,k1,1)=dbopidc(i1,k1,1) - dbopindc(i1,k1,2)=dbopidc(i1,k1,2) - dbopi2ndc(i1,k1,1)=dbopi2dc(i1,k1,1) - dbopi2ndc(i1,k1,2)=dbopi2dc(i1,k1,2) - end do - goto 10 - end if - boo=bo(i1) - bopio=bopi(i1) - bopi2o=bopi2(i1) - iti=ia(j1,1) - itj=ia(j2,1) - aboi=abo(j1) - aboj=abo(j2) - vp131=sqrt(bo131(iti)*bo131(itj)) - vp132=sqrt(bo132(iti)*bo132(itj)) - vp133=sqrt(bo133(iti)*bo133(itj)) - corrtot=1.0 - dbodsboi1=zero - dbodsboj1=zero - if (ovc(ibt).gt.0.001) then - ovi=aboi-aval(iti) - ovj=aboj-aval(itj) - -********************************************************************** -* * -* Correction for overcoordination * -* * -********************************************************************** - exphu1=exp(-vpar(2)*ovi) - exphu2=exp(-vpar(2)*ovj) - exp11=exp(-vpar(1)*ovi) - exp21=exp(-vpar(1)*ovj) - exphu12=(exphu1+exphu2) - ovcor=-(1.0/vpar(2))*log(0.50*exphu12) -* huli=((1.0/ovc(ibt))*aval(iti)+exp11+exp21) -* hulj=((1.0/ovc(ibt))*aval(itj)+exp11+exp21) - huli=aval(iti)+exp11+exp21 - hulj=aval(itj)+exp11+exp21 - corr1=huli/(huli+ovcor) - corr2=hulj/(hulj+ovcor) - corrtot=0.50*(corr1+corr2) - - dbodsboi1=0.50*(-vpar(1)*exp11/(huli+ovcor)- - $(corr1/(huli+ovcor))* - $(-vpar(1)*exp11+exphu1/exphu12)-vpar(1)*exp11/(hulj+ovcor)- - $(corr2/(hulj+ovcor))*(-vpar(1)*exp11+exphu1/exphu12)) - dbodsboj1=0.50*(-vpar(1)*exp21/(huli+ovcor)- - $(corr1/(huli+ovcor))* - $(-vpar(1)*exp21+exphu2/exphu12)-vpar(1)*exp21/(hulj+ovcor)- - $(corr2/(hulj+ovcor))*(-vpar(1)*exp21+exphu2/exphu12)) - end if -********************************************************************** -* * -* Correction for 1-3 bond orders * -* * -********************************************************************** - dbodsboi2=zero - dbodsboj2=zero - bocor1=1.0 - bocor2=1.0 - if (v13cor(ibt).gt.0.001) then - ovi2=aboi-vval3(iti) !Modification for metal surfaces - ovj2=aboj-vval3(itj) -* ovi2=aboi-valf(iti) -* ovj2=aboj-valf(itj) -* ovi2=aboi-aval(iti) -* ovj2=aboj-aval(itj) - cor1=vp131*boo*boo-ovi2 - cor2=vp131*boo*boo-ovj2 -* exphu3=v13cor(ibt)*exp(-vp132*cor1+vp133) -* exphu4=v13cor(ibt)*exp(-vp132*cor2+vp133) - exphu3=exp(-vp132*cor1+vp133) - exphu4=exp(-vp132*cor2+vp133) - bocor1=1.0/(1.0+exphu3) - bocor2=1.0/(1.0+exphu4) - dbodsboi2=-bocor1*bocor1*bocor2*vp132*exphu3 - dbodsboj2=-bocor1*bocor2*bocor2*vp132*exphu4 - end if - - bo(i1)=boo*corrtot*bocor1*bocor2 - if (bo(i1).lt.1e-10) bo(i1)=zero - corrtot2=corrtot*corrtot - bopi(i1)=bopio*corrtot2*bocor1*bocor2 - bopi2(i1)=bopi2o*corrtot2*bocor1*bocor2 - if (bopi(i1).lt.1e-10) bopi(i1)=zero - if (bopi2(i1).lt.1e-10) bopi2(i1)=zero - - dbodboo=corrtot*bocor1*bocor2+corrtot* - $bocor1*bocor1*bocor2*boo*vp132*vp131*2.0*boo*exphu3+ - $corrtot*bocor1*bocor2*bocor2*boo* - $vp132*vp131*exphu4*2.0*boo - - dbopidbopio=corrtot2*bocor1*bocor2 - - dbopidboo=corrtot2* - $bocor1*bocor1*bocor2*boo*vp132*vp131*2.0*bopio*exphu3+ - $corrtot2*bocor1*bocor2*bocor2*boo* - $vp132*vp131*exphu4*2.0*bopio - - dbopi2dbopi2o=corrtot2*bocor1*bocor2 - - dbopi2dboo=corrtot2* - $bocor1*bocor1*bocor2*boo*vp132*vp131*2.0*bopi2o*exphu3+ - $corrtot2*bocor1*bocor2*bocor2*boo* - $vp132*vp131*exphu4*2.0*bopi2o - - dbodsboit=boo*dbodsboi1*bocor1*bocor2+boo*corrtot*dbodsboi2 - dbodsbojt=boo*dbodsboj1*bocor1*bocor2+boo*corrtot*dbodsboj2 - - vhui=2.0*corrtot*dbodsboi1*bocor1*bocor2+corrtot2*dbodsboi2 - vhuj=2.0*corrtot*dbodsboj1*bocor1*bocor2+corrtot2*dbodsboj2 - dbopidsboit=bopio*vhui - dbopidsbojt=bopio*vhuj - - dbopi2dsboit=bopi2o*vhui - dbopi2dsbojt=bopi2o*vhuj - -********************************************************************** -* * -* Calculate bond order derivatives * -* * -********************************************************************** - idbo1(i1)=2+ia(j1,2)+ia(j2,2) - idbo(i1,1)=j1 - idbo(i1,2)=j2 - nco=0 - do k1=1,3 - dbondc(i1,k1,1)=dbodc(i1,k1,1)*dbodboo - dbondc(i1,k1,2)=dbodc(i1,k1,2)*dbodboo -* dbosindc(i1,k1,1)=dbosidc(i1,k1,1)*dbosidboo -* dbosindc(i1,k1,2)=dbosidc(i1,k1,2)*dbosidboo - dbopindc(i1,k1,1)=dbopidc(i1,k1,1)*dbopidbopio+ - $dbodc(i1,k1,1)*dbopidboo - dbopindc(i1,k1,2)=dbopidc(i1,k1,2)*dbopidbopio+ - $dbodc(i1,k1,2)*dbopidboo - dbopi2ndc(i1,k1,1)=dbopi2dc(i1,k1,1)*dbopi2dbopi2o+ - $dbodc(i1,k1,1)*dbopi2dboo - dbopi2ndc(i1,k1,2)=dbopi2dc(i1,k1,2)*dbopi2dbopi2o+ - $dbodc(i1,k1,2)*dbopi2dboo - end do - do i2=1,ia(j1,2) - ihl=0 - iob=ia(j1,2+i2) - if (iob.lt.j1) ihl=1 - ncubo=nubon2(j1,i2) - idbo(i1,2+nco+1)=iob - do k1=1,3 - dbondc(i1,k1,1)=dbondc(i1,k1,1)+dbodc(ncubo,k1,1+ihl)*dbodsboit - dbondc(i1,k1,2+nco+1)=dbodc(ncubo,k1,2-ihl)*dbodsboit - -* dbosindc(i1,k1,1)=dbosindc(i1,k1,1)+ -* $dbodc(ncubo,k1,1+ihl)*dbosidsboit -* dbosindc(i1,k1,2+nco+1)=dbodc(ncubo,k1,2-ihl)*dbosidsboit - - dbopindc(i1,k1,1)=dbopindc(i1,k1,1)+ - $dbodc(ncubo,k1,1+ihl)*dbopidsboit - dbopindc(i1,k1,2+nco+1)=dbodc(ncubo,k1,2-ihl)*dbopidsboit - - dbopi2ndc(i1,k1,1)=dbopi2ndc(i1,k1,1)+ - $dbodc(ncubo,k1,1+ihl)*dbopi2dsboit - dbopi2ndc(i1,k1,2+nco+1)=dbodc(ncubo,k1,2-ihl)*dbopi2dsboit - - end do - nco=nco+1 - end do - do i2=1,ia(j2,2) - ihl=0 - iob=ia(j2,2+i2) - if (iob.lt.j2) ihl=1 - ncubo=nubon2(j2,i2) - idbo(i1,2+nco+1)=iob - do k1=1,3 - - dbondc(i1,k1,2)=dbondc(i1,k1,2)+dbodc(ncubo,k1,1+ihl)*dbodsbojt - dbondc(i1,k1,2+nco+1)=dbodc(ncubo,k1,2-ihl)*dbodsbojt - -* dbosindc(i1,k1,2)=dbosindc(i1,k1,2)+ -* $dbodc(ncubo,k1,1+ihl)*dbosidsbojt -* dbosindc(i1,k1,2+nco+1)=dbodc(ncubo,k1,2-ihl)*dbosidsbojt - - dbopindc(i1,k1,2)=dbopindc(i1,k1,2)+ - $dbodc(ncubo,k1,1+ihl)*dbopidsbojt - dbopindc(i1,k1,2+nco+1)=dbodc(ncubo,k1,2-ihl)*dbopidsbojt - - dbopi2ndc(i1,k1,2)=dbopi2ndc(i1,k1,2)+ - $dbodc(ncubo,k1,1+ihl)*dbopi2dsbojt - dbopi2ndc(i1,k1,2+nco+1)=dbodc(ncubo,k1,2-ihl)*dbopi2dsbojt - - end do - nco=nco+1 - end do - - 10 continue - - do i1=1,na - abo(i1)=zero - end do -* do i1=1,na -* do i2=1,ia(i1,2) -* iob=ia(i1,2+i2) -* ncubo=nubon2(i1,i2) -* abo(i1)=abo(i1)+bo(ncubo) -* end do -* end do - do i1=1,nbon - j1=ib(i1,2) - j2=ib(i1,3) - abo(j1)=abo(j1)+bo(i1) - if (j1.ne.j2) abo(j2)=abo(j2)+bo(i1) - end do - - 15 continue - return - end -********************************************************************** -********************************************************************** - - subroutine lonpar - -********************************************************************** -#include "cbka.blk" -#include "cbkabo.blk" -#include "cbkconst.blk" -#include "cbkc.blk" -#include "cbkd.blk" -#include "cbkdcell.blk" -#include "cbkenergies.blk" -#include "cbkff.blk" -#include "cbkia.blk" -#include "cbkidbo.blk" -#include "cbklonpar.blk" -#include "cbknubon2.blk" -#include "control.blk" -#include "small.blk" - dimension virial_tmp(3,3),virialsym(6) -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In lonpar' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if -********************************************************************** -* * -* Calculate lone pair energy and first derivatives * -* * -********************************************************************** - elp=zero - do i1=1,na -********************************************************************** -* * -* Determine number of lone pairs on atoms -* * -********************************************************************** - ity=ia(i1,1) - voptlp=0.50*(stlp(ity)-aval(ity)) - vlp(i1)=zero - vund=abo(i1)-stlp(ity) - vlph=2.0*int(vund/2.0) - vlpex=vund-vlph - vp16h=vpar(16)-1.0 - - expvlp=exp(-vpar(16)*(2.0+vlpex)*(2.0+vlpex)) - dvlpdsbo(i1)=-vpar(16)*2.0*(2.0+vlpex)*expvlp - vlp(i1)=expvlp-int(vund/2.0) -* expvlp=exp(-vpar(16)*(2.0+vlpex)) -* dvlpdsbo(i1)=-vpar(16)*expvlp -* expvlp=exp(-6.0*((-0.50*vlpex)**vpar(16))) -* vlp(i1)=(1.0-expvlp)-int(vund/2.0) -* dvlpdsbo(i1)=-0.5*6.0*vpar(16)*((-0.5*vlpex)**vp16h)* -* $expvlp -********************************************************************** -* * -* Calculate lone pair energy * -* * -********************************************************************** - if (i1 .le. na_local) then - - diffvlp=voptlp-vlp(i1) - exphu1=exp(-75.0*diffvlp) - hulp1=1.0/(1.0+exphu1) - elph=vlp1(ity)*diffvlp*hulp1 -* elph=vlp1(ity)*diffvlp - delpdvlp=-vlp1(ity)*hulp1-vlp1(ity)*diffvlp*hulp1*hulp1* - $75.0*exphu1 - - elp=elp+elph - estrain(i1)=estrain(i1)+elph !atom energy - - delpdsbo=delpdvlp*dvlpdsbo(i1) -********************************************************************** -* * -* Calculate first derivative of lone pair energy to * -* cartesian coordinates * -* * -********************************************************************** - do i3=1,ia(i1,2) - iob=ia(i1,2+i3) - ncubo=nubon2(i1,i3) - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - do k1=1,3 - ftmp = delpdsbo*dbondc(ncubo,k1,i4) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ncubo) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - endif - - end do - endif - - end do - - return - end -********************************************************************** -********************************************************************** - - subroutine covbon - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkabo.blk" -#include "cbkbo.blk" -#include "cbkbosi.blk" -#include "cbkbopi.blk" -#include "cbkbopi2.blk" -#include "cbkconst.blk" -#include "cbkcovbon.blk" -#include "cbkd.blk" -#include "cbkdbopi2ndc.blk" -#include "cbkdbopindc.blk" -#include "cbkdcell.blk" -#include "cbkenergies.blk" -#include "cbkff.blk" -#include "cbkia.blk" -#include "cbkidbo.blk" -#include "cbknubon2.blk" -#include "cbkqa.blk" -#include "cbkrbo.blk" -#include "control.blk" -#include "small.blk" - dimension virial_tmp(3,3),virialsym(6) -********************************************************************** -* * -* Calculate bond energy and first derivatives * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In covbon' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - eb=0.0d0 - if (nbon.eq.0) return -********************************************************************** -* * -* Calculate bond energies * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write(65,*) 'Bond forces' -c$$$ write(65,*) 'nbon = ',nbon -c$$$ endif - - do 20 i1=1,nbon - - boa=bo(i1) -* if (boa.lt.cutof2) goto 20 - j1=ib(i1,2) - j2=ib(i1,3) - -c Only compute interaction if both atoms -c are local or else flip a coin - if (j1 .gt. na_local) go to 20 - if (j2 .gt. na_local) then - if (itag(j1) .lt. itag(j2)) go to 20 - if (itag(j1) .eq. itag(j2)) then - if(c(j1,3) .gt. c(j2,3)) go to 20 - if(c(j1,3) .eq. c(j2,3) .and. - $ c(j1,2) .gt. c(j2,2)) go to 20 - if(c(j1,3) .eq. c(j2,3) .and. - $ c(j1,2) .eq. c(j2,2) .and. - $ c(j1,1) .gt. c(j2,1)) go to 20 - endif - endif - vsymm=1.0 - if (j1.eq.j2) vsymm=0.5 - - bopia=bopi(i1) - bopi2a=bopi2(i1) - bosia=boa-bopia-bopi2a - if (bosia.lt.zero) bosia=zero - it1=ia(j1,1) - it2=ia(j2,1) - ibt=ib(i1,1) - de1h=vsymm*de1(ibt) - de2h=vsymm*de2(ibt) - de3h=vsymm*de3(ibt) - - bopo1=bosia**psp(ibt) - exphu1=exp(psi(ibt)*(1.0-bopo1)) - ebh=-de1h*bosia*exphu1-de2h*bopia-de3h*bopi2a - - debdbo=-de1h*exphu1+de1h*exphu1*psp(ibt)*psi(ibt)*bopo1 - debdbopi=-de2h - debdbopi2=-de3h - - eb=eb+ebh - estrain(j1)=estrain(j1)+0.50*ebh !1st atom energy - estrain(j2)=estrain(j2)+0.50*ebh !2nd atom energy - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i2=1,idbo1(i1) - ihu=idbo(i1,i2) - do k1=1,3 - ftmp = debdbo*(dbondc(i1,k1,i2)-dbopindc(i1,k1,i2)- - $dbopi2ndc(i1,k1,i2))+ - $debdbopi*dbopindc(i1,k1,i2)+ - $debdbopi2*dbopi2ndc(i1,k1,i2) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(i1) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i2=1,idbo1(i1) - ihu=idbo(i1,i2) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - -********************************************************************** -* * -* Stabilisation terminal triple bond in CO * -* * -********************************************************************** - if (boa.lt.1.00) goto 20 -* Stabilization for all triple bonds (not just for CO) in ReaxFF combustion FF - if (ltripstaball.eq.1 .or. - $ (qa(j1).eq.'C '.and.qa(j2).eq.'O ').or. - $ (qa(j1).eq.'O '.and.qa(j2).eq.'C ')) then - - ba=(boa-2.50)*(boa-2.50) - exphu=exp(-vpar(8)*ba) - oboa=abo(j1)-boa - obob=abo(j2)-boa - exphua1=exp(-vpar(4)*oboa) - exphub1=exp(-vpar(4)*obob) - ovoab=abo(j1)-aval(it1)+abo(j2)-aval(it2) - exphuov=exp(vpar(5)*ovoab) - hulpov=1.0/(1.0+25.0*exphuov) - - estriph=vpar(11)*exphu*hulpov*(exphua1+exphub1) - - eb=eb+estriph - estrain(j1)=estrain(j1)+0.50*estriph !1st atom energy - estrain(j2)=estrain(j2)+0.50*estriph !2nd atom energy - - decobdbo=vpar(4)*vpar(11)*exphu*hulpov*(exphua1+exphub1) - $-2.0*vpar(11)*vpar(8)*(boa-2.50)*hulpov*exphu* - $(exphua1+exphub1) - decobdboua=-25.0*vpar(5)*vpar(11)*exphu*exphuov*hulpov*hulpov* - $(exphua1+exphub1)-vpar(11)*exphu*vpar(4)*hulpov*exphua1 - decobdboub=-25.0*vpar(5)*vpar(11)*exphu*exphuov*hulpov*hulpov* - $(exphua1+exphub1)-vpar(11)*exphu*vpar(4)*hulpov*exphub1 - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i2=1,idbo1(i1) - ihu=idbo(i1,i2) - do k1=1,3 - ftmp = decobdbo*dbondc(i1,k1,i2) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(i1) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i2=1,idbo1(i1) - ihu=idbo(i1,i2) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - do i3=1,ia(j1,2) - iob=ia(j1,2+i3) - ncubo=nubon2(j1,i3) - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - do k1=1,3 - ftmp = decobdboua*dbondc(ncubo,k1,i4) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ncubo) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - end do - - do i3=1,ia(j2,2) - iob=ia(j2,2+i3) - ncubo=nubon2(j2,i3) - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - do k1=1,3 - ftmp = decobdboub*dbondc(ncubo,k1,i4) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ncubo) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - end do - - endif - - 20 continue - - return - end -********************************************************************** -********************************************************************** - - subroutine ovcor - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkabo.blk" -#include "cbkbo.blk" -#include "cbkbopi.blk" -#include "cbkbopi2.blk" -#include "cbkconst.blk" -#include "cbkd.blk" -#include "cbkdbopi2ndc.blk" -#include "cbkdbopindc.blk" -#include "cbkdcell.blk" -#include "cbkenergies.blk" -#include "cbkff.blk" -#include "cbkia.blk" -#include "cbkidbo.blk" -#include "cbklonpar.blk" -#include "cbknubon2.blk" -#include "cbkrbo.blk" -#include "control.blk" -#include "small.blk" -********************************************************************** -* * -* Calculate atom energy * -* Correction for over- and undercoordinated atoms * -* * -********************************************************************** - dimension vlptemp(nat) - dimension virial_tmp(3,3),virialsym(6) -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In ovcor' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - do i1=1,na - ity1=ia(i1,1) - vlptemp(i1)=vlp(i1) - if (amas(ity1).gt.21.0) vlptemp(i1)=0.50*(stlp(ity1)-aval(ity1)) !Only for 1st-row elements - end do - 25 ea=zero - eaot=zero - eaut=zero - epen=0.0 - - do 30 i1=1,na_local - ity1=ia(i1,1) - dfvl=1.0 - if (amas(ity1).gt.21.0) dfvl=0.0 !Only for 1st-row elements -********************************************************************** -* * -* Calculate overcoordination energy * -* Valency is corrected for lone pairs * -* * -********************************************************************** - - voptlp=0.50*(stlp(ity1)-aval(ity1)) - diffvlph=dfvl*(voptlp-vlptemp(i1)) -********************************************************************** -* * -* Determine coordination neighboring atoms * -* * -********************************************************************** - sumov=0.0 - sumov2=0.0 - do i3=1,ia(i1,2) - iat2=ia(i1,2+i3) - ity2=ia(iat2,1) - ncubo=nubon2(i1,i3) - if (bo(ncubo).gt.0.0) then - ibt=ib(ncubo,1) - voptlp2=0.50*(stlp(ity2)-aval(ity2)) - diffvlp2=dfvl*(voptlp2-vlptemp(iat2)) - sumov=sumov+(bopi(ncubo)+bopi2(ncubo))* - $(abo(iat2)-aval(ity2)-diffvlp2) - sumov2=sumov2+vover(ibt)*de1(ibt)*bo(ncubo) - endif - end do - - exphu1=exp(vpar(32)*sumov) - vho=1.0/(1.0+vpar(33)*exphu1) - diffvlp=diffvlph*vho - - vov1=abo(i1)-aval(ity1)-diffvlp - dvov1dsumov=diffvlph*vpar(32)*vpar(33)*vho*vho*exphu1 - exphuo=exp(vovun(ity1)*vov1) - hulpo=1.0/(1.0+exphuo) - - hulpp=(1.0/(vov1+aval(ity1)+1e-8)) - - eah=sumov2*hulpp*hulpo*vov1 - deadvov1=-sumov2*hulpp*hulpp*vov1*hulpo+ - $sumov2*hulpp*hulpo-sumov2*hulpp*vov1*vovun(ity1)* - $hulpo*hulpo*exphuo - - ea=ea+eah - estrain(i1)=estrain(i1)+eah !atom energy -********************************************************************** -* * -* Calculate first derivative of overcoordination energy to * -* cartesian coordinates * -* * -********************************************************************** - do i3=1,ia(i1,2) - iob=ia(i1,2+i3) - ncubo=nubon2(i1,i3) - if (bo(ncubo).gt.0.0) then - ibt=ib(ncubo,1) - deadbo=vover(ibt)*de1(ibt)*hulpp*hulpo*vov1 - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - do k1=1,3 - ftmp = deadvov1*(1.0+dfvl*vho*dvlpdsbo(i1))* - $dbondc(ncubo,k1,i4)+deadbo*dbondc(ncubo,k1,i4) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ncubo) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - endif - end do - - do i2=1,ia(i1,2) - - iat2=ia(i1,2+i2) - ity2=ia(iat2,1) - nbosa=nubon2(i1,i2) - if (bo(nbosa).gt.0.0) then - deadvov2=deadvov1*dvov1dsumov*(bopi(nbosa)+bopi2(nbosa)) - - voptlp2=0.50*(stlp(ity2)-aval(ity2)) - diffvlp2=dfvl*(voptlp2-vlptemp(iat2)) - deadpibo=deadvov1*dvov1dsumov*(abo(iat2)-aval(ity2)-diffvlp2) - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i4=1,idbo1(nbosa) - ihu=idbo(nbosa,i4) - do k1=1,3 - ftmp = deadpibo*(dbopindc(nbosa,k1,i4)+ - $dbopi2ndc(nbosa,k1,i4)) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(nbosa) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i4=1,idbo1(nbosa) - ihu=idbo(nbosa,i4) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - endif - - do i3=1,ia(iat2,2) - iob=ia(iat2,2+i3) - ncubo=nubon2(iat2,i3) - if (bo(ncubo).gt.0.0) then - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - do k1=1,3 - ftmp = deadvov2*(1.0+dfvl*dvlpdsbo(iat2))* - $dbondc(ncubo,k1,i4) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ncubo) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - endif - end do - - endif - - end do - -********************************************************************** -* * -* Calculate undercoordination energy * -* * -********************************************************************** - if (valp1(ity1).lt.zero) goto 30 !skip undercoordination - exphu2=exp(vpar(10)*sumov) - vuhu1=1.0+vpar(9)*exphu2 - hulpu2=1.0/vuhu1 - - exphu3=-exp(vpar(7)*vov1) - hulpu3=-(1.0+exphu3) - - dise2=valp1(ity1) - exphuu=exp(-vovun(ity1)*vov1) - hulpu=1.0/(1.0+exphuu) - eahu=dise2*hulpu*hulpu2*hulpu3 - deaudvov1=dise2*hulpu2*vovun(ity1)*hulpu*hulpu*exphuu*hulpu3- - $dise2*hulpu*hulpu2*vpar(7)*exphu3 - - ea=ea+eahu - estrain(i1)=estrain(i1)+eahu !atom energy - - deaudsumov=-dise2*hulpu*vpar(9)*vpar(10)*hulpu3*exphu2* - $hulpu2*hulpu2 - -********************************************************************** -* * -* Calculate first derivative of atom energy to cartesian * -* coordinates * -* * -********************************************************************** - - do i3=1,ia(i1,2) - iob=ia(i1,2+i3) - ncubo=nubon2(i1,i3) - if (bo(ncubo).gt.0.0) then - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - do k1=1,3 - ftmp = deaudvov1*(1.0+dfvl*vho*dvlpdsbo(i1))* - $dbondc(ncubo,k1,i4) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ncubo) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - endif - end do - - do i2=1,ia(i1,2) - - iat2=ia(i1,2+i2) - ity2=ia(iat2,1) - nbosa=nubon2(i1,i2) - if (bo(nbosa).gt.0.0) then - deadvov2=(deaudsumov+dvov1dsumov*deaudvov1)* - $(bopi(nbosa)+bopi2(nbosa)) - - voptlp2=0.50*(stlp(ity2)-aval(ity2)) - diffvlp2=dfvl*(voptlp2-vlptemp(iat2)) - deadpibo1=(dvov1dsumov*deaudvov1+deaudsumov)* - $(abo(iat2)-aval(ity2)-diffvlp2) - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i4=1,idbo1(nbosa) - ihu=idbo(nbosa,i4) - do k1=1,3 - ftmp = deadpibo1* - $(dbopindc(nbosa,k1,i4)+dbopi2ndc(nbosa,k1,i4)) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(nbosa) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i4=1,idbo1(nbosa) - ihu=idbo(nbosa,i4) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - do i3=1,ia(iat2,2) - iob=ia(iat2,2+i3) - ncubo=nubon2(iat2,i3) - if (bo(ncubo).gt.0.0) then - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - do k1=1,3 - ftmp = deadvov2*(1.0+dfvl*dvlpdsbo(iat2))* - $dbondc(ncubo,k1,i4) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ncubo) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - endif - end do - - endif - - end do - - - 30 continue - -********************************************************************** -* * -* Calculate correction for C2 * -* * -********************************************************************** - if (abs(vpar(6)).gt.0.001) then - do 40 i1=1,na_local - ity1=ia(i1,1) - vov4=abo(i1)-aval(ity1) - - do i2=1,ia(i1,2) - iat2=ia(i1,2+i2) - nbohu=nubon2(i1,i2) - if (bo(nbohu).gt.0.0) then - - ibt=ib(nbohu,1) - elph=zero - deahu2dbo=zero - deahu2dsbo=zero - vov3=bo(nbohu)-vov4-0.040*(vov4**4) - if (vov3.gt.3.0) then - elph=vpar(6)*(vov3-3.0)*(vov3-3.0) - deahu2dbo=2.0*vpar(6)*(vov3-3.0) - deahu2dsbo=2.0*vpar(6)*(vov3-3.0)*(-1.0- - $0.16*(vov4**3)) - end if - - elp=elp+elph - estrain(i1)=estrain(i1)+elph !atom energy - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i3=1,idbo1(nbohu) - ihu=idbo(nbohu,i3) - do k1=1,3 - ftmp = deahu2dbo*dbondc(nbohu,k1,i3) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(nbohu) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i3=1,idbo1(nbohu) - ihu=idbo(nbohu,i3) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - do i3=1,ia(i1,2) - iob=ia(i1,2+i3) - ncubo=nubon2(i1,i3) - if (bo(ncubo).gt.0.0) then - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - do k1=1,3 - ftmp = deahu2dsbo*dbondc(ncubo,k1,i4) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ncubo) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - end if - end do - - end if - end do - - 40 continue - end if - - return - end -********************************************************************** -********************************************************************** - - subroutine molen - -********************************************************************** -#include "cbka.blk" -#include "cbkbo.blk" -#include "cbkconst.blk" -#include "cbkc.blk" -#include "cbkd.blk" -#include "cbkenergies.blk" -#include "cbkff.blk" -#include "cbkia.blk" -#include "cbkidbo.blk" -#include "cbknmolat.blk" -#include "cbknubon2.blk" -#include "control.blk" -#include "small.blk" - dimension virial_tmp(3,3),virialsym(6) -********************************************************************** -* * -* Calculate molecular energy and first derivatives * -* Only used to prevent creating virtual electrons * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In molen' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - emol=zero - return - do i1=1,nmolo - - enelm=0.0 - do i2=1,na - if (ia(i2,3+mbond).eq.i1) then - it1=ia(i2,1) - enelm=enelm+aval(it1) - end if - end do - - na1m=nmolat(i1,1) - - enelm=2*int(enelm*0.50) -* enelm=elmol(i1) - bomsum=zero - do i2=1,na1m - ihu=nmolat(i1,i2+1) - do i3=1,ia(ihu,2) - ihu2=nubon2(ihu,i3) - bomsum=bomsum+bo(ihu2) - end do - end do - diff=(bomsum-enelm) - exphu=exp(-vpar(37)*diff) - exphu2=1.0/(1.0+15.0*exphu) - emolh=zero - demoldsbo=zero - emolh=vpar(38)*exphu2 - emol=emol+emolh - demoldsbo=vpar(38)*vpar(37)*15.0*exphu2*exphu2*exphu - - do i2=1,na1m - ihu1=nmolat(i1,i2+1) - do i3=1,ia(ihu1,2) - iob=ia(ihu1,2+i3) - ncubo=nubon2(ihu1,i3) - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - do k1=1,3 - ftmp = demoldsbo*dbondc(ncubo,k1,i4) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ncubo) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i4=1,idbo1(ncubo) - ihu=idbo(ncubo,i4) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - end do - end do - - - end do - - - return - end -********************************************************************** -********************************************************************** - - subroutine valang - -********************************************************************** -#include "cbka.blk" -#include "cbkabo.blk" -#include "cbkbo.blk" -#include "cbkbopi.blk" -#include "cbkbopi2.blk" -#include "cbkconst.blk" -#include "cbkc.blk" -#include "cbkd.blk" -#include "cbkdbopi2ndc.blk" -#include "cbkdbopindc.blk" -#include "cbkdcell.blk" -#include "cbkdhdc.blk" -#include "cbkenergies.blk" -#include "cbkff.blk" -#include "cbkh.blk" -#include "cbkia.blk" -#include "cbkidbo.blk" -#include "cbklonpar.blk" -#include "cbknubon2.blk" -#include "cbkvalence.blk" -#include "control.blk" -#include "valang.blk" -#include "small.blk" - dimension j(3) - dimension virial_tmp(3,3),virialsym(6) -********************************************************************** -* * -* Calculate valency angle energies and first derivatives * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In valang' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if -* eco=0.0 - ev=0.0 - ecoa=0.0 - if (nval.eq.0) return - - do 10 i1=1,nval - ity=iv(i1,1) - j(1)=iv(i1,2) - j(2)=iv(i1,3) - j(3)=iv(i1,4) - - if (j(2) .le. na_local) then - - la=iv(i1,5) - lb=iv(i1,6) - boa=bo(la)-cutof2 - bob=bo(lb)-cutof2 - if (boa.lt.zero.or.bob.lt.zero) goto 10 - - hl=h(i1) ! Calculated earlier in routine calval -********************************************************************** -* * -* Calculate valency angle energy * -* * -********************************************************************** - nbocen=ia(j(2),2) - sbo2=0.0 - vmbo=1.0 - - do i2=1,nbocen - ibv=nubon2(j(2),i2) - if (bo(ibv).gt.0.0) then - vmbo=vmbo*exp(-bo(ibv)**8) - sbo2=sbo2+bopi(ibv)+bopi2(ibv) - endif - end do - - ity2=ia(j(2),1) -* exbo=abo(j(2))-stlp(ia(j(2),1)) - exbo=abo(j(2))-valf(ity2) -* if (exbo.gt.zero) exbo=zero -* expov=exp(vka8(ity)*exbo) -* expov2=exp(-vpar(13)*exbo) -* htov1=2.0+expov2 -* htov2=1.0+expov+expov2 -* evboadj=htov1/htov2 - evboadj=1.0 - expun=exp(-vkac(ity)*exbo) - expun2=exp(vpar(15)*exbo) - htun1=2.0+expun2 - htun2=1.0+expun+expun2 - evboadj2=vval4(ity2)-(vval4(ity2)-1.0)*htun1/htun2 -********************************************************************** -* * -* Calculate number of lone pairs * -* * -********************************************************************** - dsbo2dvlp=(1.0-vmbo) - vlpadj=zero - exlp1=abo(j(2))-stlp(ia(j(2),1)) - exlp2=2.0*int(exlp1/2.0) - exlp=exlp1-exlp2 - if (exlp.lt.zero) then -* expvlp=exp(-vpar(16)*(2.0+exlp)*(2.0+exlp)) -* vlpadj=expvlp-int(exlp1/2.0) -* dsbo2dvlp=(1.0-vmbo)*(1.0-vpar(34)*2.0* -* $(2.0+exlp)*vpar(16)*expvlp) - vlpadj=vlp(j(2)) - dsbo2dvlp=(1.0-vmbo)*(1.0+vpar(34)*dvlpdsbo(j(2))) - end if - - sbo2=sbo2+(1.0-vmbo)*(-exbo-vpar(34)*vlpadj) - dsbo2dvmbo=exbo+vpar(34)*vlpadj - - sbo2h=sbo2 - powv=vpar(17) - if (sbo2.le.0.0) sbo2h=0.0 - if (sbo2.gt.0.0.and.sbo2.le.1.0) sbo2h=sbo2**powv - if (sbo2.gt.1.0.and.sbo2.lt.2.0) sbo2h=2.0-(2.0-sbo2)**powv - if (sbo2.gt.2.0) sbo2h=2.0 - thba=th0(ity) - expsbo=exp(-vpar(18)*(2.0-sbo2h)) - thetao=180.0-thba*(1.0-expsbo) - - thetao=thetao*dgrrdn - thdif=(thetao-hl) - thdi2=thdif*thdif - dthsbo=dgrrdn*thba*vpar(18)*expsbo - if (sbo2.lt.0.0) dthsbo=zero - if (sbo2.gt.0.0.and.sbo2.le.1.0) - $dthsbo=powv*(sbo2**(powv-1.0))*dgrrdn*thba*vpar(18)*expsbo - if (sbo2.gt.1.0.and.sbo2.lt.2.0) - $dthsbo=powv*((2.0-sbo2)**(powv-1.0))*dgrrdn*thba*vpar(18)*expsbo - if (sbo2.gt.2.0) dthsbo=zero - - exphu=vka(ity)*exp(-vka3(ity)*thdi2) - exphu2=vka(ity)-exphu - if (vka(ity).lt.zero) exphu2=exphu2-vka(ity) !To avoid linear Me-H-Me angles (6/6/06) - boap=boa**vval2(ity) - boap2=boa**(vval2(ity)-1.0) - bobp=bob**vval2(ity) - bobp2=bob**(vval2(ity)-1.0) - exa=exp(-vval1(ity2)*boap) - exb=exp(-vval1(ity2)*bobp) - dexadboa=vval2(ity)*vval1(ity2)*exa*boap2 - dexbdbob=vval2(ity)*vval1(ity2)*exb*bobp2 - exa2=(1.0-exa) - exb2=(1.0-exb) - - evh=evboadj2*evboadj*exa2*exb2*exphu2 - devdlb=evboadj2*evboadj*dexbdbob*exa2*exphu2 - devdla=evboadj2*evboadj*dexadboa*exb2*exphu2 - devdsbo=2.0*evboadj2*evboadj*dthsbo*exa2*exb2* - $vka3(ity)*thdif*exphu - devdh=-2.0*evboadj2*evboadj*exa2*exb2*vka3(ity)*thdif*exphu - - devdsbo2= - $evboadj*exa2*exb2*exphu2*(vval4(ity2)-1.0)*(-vpar(15)*expun2/htun2 - $+htun1*(vpar(15)*expun2-vkac(ity)*expun)/(htun2*htun2)) - -* devdsbo2=-evboadj2*exa2*exb2*exphu2*(vpar(13)*expov2/htov2+ -* $htov1*(vka8(ity)*expov-vpar(13)*expov2)/(htov2*htov2))+ -* $evboadj*exa2*exb2*exphu2*(vpar(14)-1.0)*(-vpar(15)*expun2/htun2 -* $+htun1*(vpar(15)*expun2-vkac(ity)*expun)/(htun2*htun2)) - - if (j(2) .le. na_local) then - ev=ev+evh - estrain(j(2))=estrain(j(2))+evh !central atom energy - endif - -* write (64,'(4i8,18f8.2)')mdstep,j(1),j(2),j(3),sbo2,sbo2h, -* $thetao*rdndgr,hl*rdndgr,bo(la),bo(lb),bopi(la), -* $vlp(j(2)),exbo,vlpadj,vmbo,evh,ev,vka(ity) -********************************************************************** -* * -* Calculate penalty for two double bonds in valency angle * -* * -********************************************************************** - exbo=abo(j(2))-aval(ia(j(2),1)) - expov=exp(vpar(22)*exbo) - expov2=exp(-vpar(21)*exbo) - htov1=2.0+expov2 - htov2=1.0+expov+expov2 - ecsboadj=htov1/htov2 - exphu1=exp(-vpar(20)*(boa-2.0)*(boa-2.0)) - exphu2=exp(-vpar(20)*(bob-2.0)*(bob-2.0)) - - epenh=vkap(ity)*ecsboadj*exphu1*exphu2 - estrain(j(2))=estrain(j(2))+epenh - epen=epen+epenh - decoadboa=-2.0*vpar(20)*epenh*(boa-2.0) - decoadbob=-2.0*vpar(20)*epenh*(bob-2.0) - - decdsbo2=-vkap(ity)*exphu1*exphu2*(vpar(21)*expov2/htov2+htov1* - $(vpar(22)*expov-vpar(21)*expov2)/(htov2*htov2)) -********************************************************************** -* * -* Calculate valency angle conjugation energy * -* * -********************************************************************** - unda=abo(j(1))-boa -* ovb=abo(j(2))-valf(ia(j(2),1)) - ovb=abo(j(2))-vval3(ia(j(2),1)) !Modification for Ru 7/6/2004 - - undc=abo(j(3))-bob - ba=(boa-1.50)*(boa-1.50) - bb=(bob-1.50)*(bob-1.50) - exphua=exp(-vpar(31)*ba) - exphub=exp(-vpar(31)*bb) - exphuua=exp(-vpar(39)*unda*unda) - exphuob=exp(vpar(3)*ovb) - exphuuc=exp(-vpar(39)*undc*undc) - hulpob=1.0/(1.0+exphuob) - ecoah=vka8(ity)*exphua*exphub*exphuua*exphuuc*hulpob - decodbola=-2.0*vka8(ity)*(boa-1.50)*vpar(31)*exphua*exphub - $*exphuua*exphuuc*hulpob+vpar(39)*vka8(ity)*exphua*exphub* - $exphuua*exphuuc*hulpob*2.0*unda - decodbolb=-2.0*vka8(ity)*(bob-1.50)*vpar(31)*exphua*exphub - $*exphuua*exphuuc*hulpob+vpar(39)*vka8(ity)*exphua*exphub* - $exphuua*exphuuc*hulpob*2.0*undc - decodboua=-2.0*unda*vka8(ity)*vpar(39)*exphua*exphub - $*exphuua*exphuuc*hulpob - decodbouc=-2.0*undc*vka8(ity)*vpar(39)*exphua*exphub - $*exphuua*exphuuc*hulpob - decodboob=-vka8(ity)*exphua*exphub*exphuua*exphuuc*hulpob* - $hulpob*vpar(3)*exphuob -* decodboob=zero -* decodboua=zero -* decodbouc=zero - - ecoa=ecoa+ecoah - estrain(j(2))=estrain(j(2))+ecoah !central atom energy - -********************************************************************** -* * -* Calculate derivative valency energy to cartesian coordinates * -* * -********************************************************************** - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do k1=1,3 - do k2=1,3 - ftmp = devdh*dhdc(i1,k1,k2) - d(k1,j(k2))=d(k1,j(k2))+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(j(k2),k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/3 - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do k2=1,3 - ihu=j(k2) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i2=1,idbo1(la) - ihu=idbo(la,i2) - do k1=1,3 - ftmp = (devdla+decoadboa+decodbola)* - $dbondc(la,k1,i2) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(la) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i2=1,idbo1(la) - ihu=idbo(la,i2) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i2=1,idbo1(lb) - ihu=idbo(lb,i2) - do k1=1,3 - ftmp = (devdlb+decoadbob+decodbolb)* - $dbondc(lb,k1,i2) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(lb) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i2=1,idbo1(lb) - ihu=idbo(lb,i2) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - do i2=1,nbocen - j5=ia(j(2),2+i2) - ibv=nubon2(j(2),i2) - if (bo(ibv).gt.0.0) then - dvmbodbo=-vmbo*8.0*bo(ibv)**7 - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i3=1,idbo1(ibv) - ihu=idbo(ibv,i3) - do k1=1,3 - ftmp = (-dsbo2dvlp*devdsbo+devdsbo2+decdsbo2 - $+dvmbodbo*dsbo2dvmbo*devdsbo)* - $dbondc(ibv,k1,i3)+devdsbo*(dbopindc(ibv,k1,i3)+ - $dbopi2ndc(ibv,k1,i3)) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ibv) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i3=1,idbo1(ibv) - ihu=idbo(ibv,i3) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - endif - end do - - do i2=1,ia(j(1),2) - j5=ia(j(1),2+i2) - ibv=nubon2(j(1),i2) - if (bo(ibv).gt.0.0) then - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i3=1,idbo1(ibv) - ihu=idbo(ibv,i3) - do k1=1,3 - ftmp = decodboua*dbondc(ibv,k1,i3) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ibv) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i3=1,idbo1(ibv) - ihu=idbo(ibv,i3) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - endif - end do - - do i2=1,ia(j(2),2) - j5=ia(j(2),2+i2) - ibv=nubon2(j(2),i2) - if (bo(ibv).gt.0.0) then - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i3=1,idbo1(ibv) - ihu=idbo(ibv,i3) - do k1=1,3 - ftmp = decodboob*dbondc(ibv,k1,i3) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ibv) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i3=1,idbo1(ibv) - ihu=idbo(ibv,i3) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - endif - end do - - do i2=1,ia(j(3),2) - j5=ia(j(3),2+i2) - ibv=nubon2(j(3),i2) - if (bo(ibv).gt.0.0) then - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i3=1,idbo1(ibv) - ihu=idbo(ibv,i3) - do k1=1,3 - ftmp = decodbouc*dbondc(ibv,k1,i3) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ibv) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i3=1,idbo1(ibv) - ihu=idbo(ibv,i3) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - endif - end do - - endif - - 10 continue - - return - end -********************************************************************** -********************************************************************** - - subroutine hbond - -********************************************************************** -#include "cbka.blk" -#include "cbkbo.blk" -#include "cbkconst.blk" -#include "cbkc.blk" -#include "cbkd.blk" -#include "cbkdcell.blk" -#include "cbkenergies.blk" -#include "cbkidbo.blk" -#include "cbksrthb.blk" -#include "control.blk" -#include "cbkhbond.blk" -#include "small.blk" - dimension drda(3),j(3),dvdc(3,3),dargdc(3,3) - dimension virial_tmp(3,3),virialsym(6) -********************************************************************** -* * -* Calculate hydrogen bond energies and first derivatives * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In hbond' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - ehb=zero - do 10 i1=1,nhb - ityhb=ihb(i1,1) - j(1)=ihb(i1,2) - j(2)=ihb(i1,3) - j(3)=ihb(i1,4) - la=ihb(i1,5) - boa=bo(la) - call dista2(j(2),j(3),rda,dxm,dym,dzm) - drda(1)=dxm/rda - drda(2)=dym/rda - drda(3)=dzm/rda - call calvalhb(j(1),j(2),j(3),ix,iy,iz,arg,hhb(i1),dvdc,dargdc) - rhu1=rhb(ityhb)/rda - rhu2=rda/rhb(ityhb) - sinhu=sin(hhb(i1)/2.0) - sin2=sinhu*sinhu - exphu1=exp(-vhb1(ityhb)*boa) - exphu2=exp(-vhb2(ityhb)*(rhu1+rhu2-2.0)) - if (lhbnew .eq. 0) then - ehbh=(1.0-exphu1)*dehb(ityhb)*exphu2*sin2*sin2*sin2*sin2 - else - ehbh=(1.0-exphu1)*dehb(ityhb)*exphu2*sin2*sin2 - endif - ehb=ehb+ehbh - estrain(j(2))=estrain(j(2))+ehbh !2nd atom energy - -********************************************************************** -* * -* Calculate first derivatives * -* * -********************************************************************** - if (lhbnew .eq. 0) then - dehbdbo=vhb1(ityhb)*exphu1*dehb(ityhb)*exphu2*sin2*sin2* - $ sin2*sin2 - dehbdv=(1.0-exphu1)*dehb(ityhb)*exphu2* - $ 4.0*sin2*sin2*sin2*sinhu*cos(hhb(i1)/2.0) - dehbdrda=(1.0-exphu1)*dehb(ityhb)*sin2*sin2*sin2*sin2* - $ vhb2(ityhb)*(rhb(ityhb)/(rda*rda)-1.0/rhb(ityhb))*exphu2 - else - dehbdbo=vhb1(ityhb)*exphu1*dehb(ityhb)*exphu2*sin2*sin2 - dehbdv=(1.0-exphu1)*dehb(ityhb)*exphu2* - $ 2.0*sin2*sinhu*cos(hhb(i1)/2.0) - dehbdrda=(1.0-exphu1)*dehb(ityhb)*sin2*sin2* - $ vhb2(ityhb)*(rhb(ityhb)/(rda*rda)-1.0/rhb(ityhb))*exphu2 - endif - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do k1=1,3 - ftmp = dehbdrda*drda(k1) - d(k1,j(2))=d(k1,j(2))+ftmp - d(k1,j(3))=d(k1,j(3))-ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ - $ ftmp*c(j(2),k1p)-ftmp*c(j(3),k1p) - end do - endif - - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/2 - do k1 = 1,6 - vtmp = virialsym(k1)*frac - ihu = j(2) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - ihu = j(3) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - endif - - endif - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do k1=1,3 - do k2=1,3 - ftmp = dehbdv*dvdc(k1,k2) - d(k1,j(k2))=d(k1,j(k2))+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(j(k2),k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/3 - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do k2=1,3 - ihu=j(k2) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i2=1,idbo1(la) - ihu=idbo(la,i2) - do k1=1,3 - ftmp = dehbdbo*dbondc(la,k1,i2) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(la) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i2=1,idbo1(la) - ihu=idbo(la,i2) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - 10 continue - return - end - -********************************************************************** -********************************************************************** - - subroutine torang - -********************************************************************** -#include "cbka.blk" -#include "cbkabo.blk" -#include "cbkbo.blk" -#include "cbkbopi.blk" -#include "cbkc.blk" -#include "cbkconst.blk" -#include "cbkd.blk" -#include "cbkdbopindc.blk" -#include "cbkdcell.blk" -#include "cbkdhdc.blk" -#include "cbkdrdc.blk" -#include "cbkenergies.blk" -#include "cbkff.blk" -#include "cbkfftorang.blk" -#include "cbkh.blk" -#include "cbkia.blk" -#include "cbkidbo.blk" -#include "cbkinit.blk" -#include "cbknubon2.blk" -#include "cbkrbo.blk" -#include "cbktorang.blk" -#include "cbktorsion.blk" -#include "cbktregime.blk" -#include "cbkvalence.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "small.blk" - - DIMENSION A(3),DRDA(3),DADC(4),DRADC(3,4),DRBDC(3,4), - $DRCDC(3,4),DHDDC(3,4),DHEDC(3,4),DRVDC(3,4),DTDC(3,4), - $DNDC(3,4) - dimension j(4),dh1rdc(3,3),dh2rdc(3,3),dargdc(3,3) - dimension virial_tmp(3,3),virialsym(6) -********************************************************************** -* * -* Calculate torsion angle energies and first derivatives * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In torang' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - do k1=1,3 - do k2=1,4 - dhddc(k1,k2)=0.0 - dhedc(k1,k2)=0.0 - dradc(k1,k2)=0.0 - drbdc(k1,k2)=0.0 - drcdc(k1,k2)=0.0 - end do - end do - et=0.0 - eth12=0.0 - eco=0.0 - dadc(1)=1.0 - dadc(2)=0.0 - dadc(3)=0.0 - dadc(4)=-1.0 - if (ntor.eq.0) return - - do 10 i1=1,ntor - j(1)=it(i1,2) - j(2)=it(i1,3) - j(3)=it(i1,4) - j(4)=it(i1,5) - - ity=it(i1,1) - la=it(i1,6) - lb=it(i1,7) - lc=it(i1,8) - call calvalres(j(1),j(2),j(3),arg1,ht1,dh1rdc,dargdc) - call calvalres(j(2),j(3),j(4),arg2,ht2,dh2rdc,dargdc) - boa=bo(la)-cutof2 - bob=bo(lb)-cutof2 - boc=bo(lc)-cutof2 - if (boa.lt.zero.or.bob.lt.zero.or.boc.lt.zero) - $goto 10 - r42=0.0 - ivl1=ibsym(la) - ivl2=ibsym(lb) - ivl3=ibsym(lc) - isign1=1 - isign2=1 - isign3=1 - rla=rbo(la) - rlb=rbo(lb) - - call dista2(j(1),j(4),r4,a(1),a(2),a(3)) -********************************************************************** -* * -* Determine torsion angle * -* * -********************************************************************** - d142=r4*r4 - rla=rbo(la) - rlb=rbo(lb) - rlc=rbo(lc) - coshd=cos(ht1) - coshe=cos(ht2) - sinhd=sin(ht1) - sinhe=sin(ht2) - poem=2.0*rla*rlc*sinhd*sinhe - poem2=poem*poem - tel=rla*rla+rlb*rlb+rlc*rlc-d142-2.0*(rla*rlb*coshd-rla*rlc* - $coshd*coshe+rlb*rlc*coshe) - if (poem.lt.1e-20) poem=1e-20 - arg=tel/poem - if (arg.gt.1.0) arg=1.0 - if (arg.lt.-1.0) arg=-1.0 - arg2=arg*arg - thg(i1)=acos(arg)*rdndgr - k1=j(1) - k2=j(2) - k3=j(3) - k4=j(4) - call dista2(k3,k2,dis,x3,y3,z3) - y32z32=y3*y3+z3*z3 - wort1=sqrt(y32z32)+1e-6 - wort2=sqrt(y32z32+x3*x3)+1e-6 -* if (wort1.lt.1e-6) wort1=1e-6 -* if (wort2.lt.1e-6) wort2=1e-6 - sinalf=y3/wort1 - cosalf=z3/wort1 - sinbet=x3/wort2 - cosbet=wort1/wort2 - call dista2(k1,k2,dis,x1,y1,z1) - x1=x1*cosbet-y1*sinalf*sinbet-z1*cosalf*sinbet - y1=y1*cosalf-z1*sinalf - wort3=sqrt(x1*x1+y1*y1)+1e-6 -* if (wort3.lt.1e-6) wort3=1e-6 - singam=y1/wort3 - cosgam=x1/wort3 - call dista2(k4,k2,dis,x4,y4,z4) - x4=x4*cosbet-y4*sinalf*sinbet-z4*cosalf*sinbet - y4=y4*cosalf-z4*sinalf - y4=x4*singam-y4*cosgam - if (y4.gt.0.0) thg(i1)=-thg(i1) - if (thg(i1).lt.-179.999999d0) thg(i1)=-179.999999d0 - if (thg(i1).gt.179.999999d0) thg(i1)=179.999999d0 - th2=thg(i1)*dgrrdn -********************************************************************** -* * -* Calculate torsion angle energy * -* * -********************************************************************** - exbo1=abo(j(2))-valf(ia(j(2),1)) - exbo2=abo(j(3))-valf(ia(j(3),1)) - htovt=exbo1+exbo2 - expov=exp(vpar(26)*htovt) - expov2=exp(-vpar(25)*(htovt)) - htov1=2.0+expov2 - htov2=1.0+expov+expov2 - etboadj=htov1/htov2 - - btb2=bopi(lb)-1.0+etboadj - bo2t=1.0-btb2 - bo2p=bo2t*bo2t - bocor2=exp(v4(ity)*bo2p) - - hsin=sinhd*sinhe - ethhulp=0.50*v1(ity)*(1.0+arg)+v2(ity)*bocor2*(1.0-arg2)+ - $v3(ity)*(0.50+2.0*arg2*arg-1.50*arg) - - exphua=exp(-vpar(24)*boa) - exphub=exp(-vpar(24)*bob) - exphuc=exp(-vpar(24)*boc) - bocor4=(1.0-exphua)*(1.0-exphub)*(1.0-exphuc) - eth=hsin*ethhulp*bocor4 - - detdar=hsin*bocor4*(0.50*v1(ity)-2.0*v2(ity)*bocor2*arg+ - $v3(ity)*(6.0*arg2-1.5d0)) - detdhd=coshd*sinhe*bocor4*ethhulp - detdhe=sinhd*coshe*bocor4*ethhulp - - detdboa=vpar(24)*exphua*(1.0-exphub)*(1.0-exphuc)*ethhulp*hsin - detdbopib=-bocor4*2.0*v4(ity)*v2(ity)* - $bo2t*bocor2*(1.0-arg2)*hsin - detdbob=vpar(24)*exphub*(1.0-exphua)* - $(1.0-exphuc)*ethhulp*hsin - detdboc=vpar(24)*exphuc*(1.0-exphua)* - $(1.0-exphub)*ethhulp*hsin - - detdsbo1=-(detdbopib)* - $(vpar(25)*expov2/htov2+htov1* - $(vpar(26)*expov-vpar(25)*expov2)/(htov2*htov2)) - - et=et+eth - estrain(j(2))=estrain(j(2))+0.50*eth !2nd atom energy - estrain(j(3))=estrain(j(3))+0.50*eth !3rd atom energy - -********************************************************************** -* * -* Calculate conjugation energy * -* * -********************************************************************** - ba=(boa-1.50)*(boa-1.50) - bb=(bob-1.50)*(bob-1.50) - bc=(boc-1.50)*(boc-1.50) - exphua1=exp(-vpar(28)*ba) - exphub1=exp(-vpar(28)*bb) - exphuc1=exp(-vpar(28)*bc) - sbo=exphua1*exphub1*exphuc1 - dbohua=-2.0*(boa-1.50)*vpar(28)*exphua1*exphub1*exphuc1 - dbohub=-2.0*(bob-1.50)*vpar(28)*exphua1*exphub1*exphuc1 - dbohuc=-2.0*(boc-1.50)*vpar(28)*exphua1*exphub1*exphuc1 - arghu0=(arg2-1.0)*sinhd*sinhe - ehulp=vconj(ity)*(arghu0+1.0) - ecoh=ehulp*sbo - decodar=sbo*vconj(ity)*2.0*arg*sinhd*sinhe - decodbola=dbohua*ehulp - decodbolb=dbohub*ehulp - decodbolc=dbohuc*ehulp - decodhd=coshd*sinhe*vconj(ity)*sbo*(arg2-1.0) - decodhe=coshe*sinhd*vconj(ity)*sbo*(arg2-1.0) - - eco=eco+ecoh - estrain(j(2))=estrain(j(2))+0.50*ecoh !2nd atom energy - estrain(j(3))=estrain(j(3))+0.50*ecoh !3rd atom energy - - 1 continue -********************************************************************** -* * -* Calculate derivative torsion angle and conjugation energy * -* to cartesian coordinates * -* * -********************************************************************** - SINTH=SIN(THG(i1)*DGRRDN) - IF (SINTH.GE.0.0.AND.SINTH.LT.1.0D-10) SINTH=1.0D-10 - IF (SINTH.LT.0.0.AND.SINTH.GT.-1.0D-10) SINTH=-1.0D-10 - IF (j(1).EQ.IB(LA,2)) THEN - DO K1=1,3 - DRADC(K1,1)=DRDC(LA,K1,1) - DRADC(K1,2)=DRDC(LA,K1,2) - end do - ELSE - DO K1=1,3 - DRADC(K1,1)=DRDC(LA,K1,2) - DRADC(K1,2)=DRDC(LA,K1,1) - end do - ENDIF - IF (j(2).EQ.IB(LB,2)) THEN - DO K1=1,3 - DRBDC(K1,2)=DRDC(LB,K1,1) - DRBDC(K1,3)=DRDC(LB,K1,2) - end do - ELSE - DO K1=1,3 - DRBDC(K1,2)=DRDC(LB,K1,2) - DRBDC(K1,3)=DRDC(LB,K1,1) - end do - ENDIF - IF (j(3).EQ.IB(LC,2)) THEN - DO K1=1,3 - DRCDC(K1,3)=DRDC(LC,K1,1) - DRCDC(K1,4)=DRDC(LC,K1,2) - end do - ELSE - DO K1=1,3 - DRCDC(K1,3)=DRDC(LC,K1,2) - DRCDC(K1,4)=DRDC(LC,K1,1) - end do - ENDIF - - do k1=1,3 - dhddc(1,k1)=dh1rdc(1,k1) - dhddc(2,k1)=dh1rdc(2,k1) - dhddc(3,k1)=dh1rdc(3,k1) - dhedc(1,k1+1)=dh2rdc(1,k1) - dhedc(2,k1+1)=dh2rdc(2,k1) - dhedc(3,k1+1)=dh2rdc(3,k1) - end do - -********************************************************************** -* write (64,*)j(1),j(2),j(3),j(4) -* do k1=1,3 -* write (64,'(10f12.4)')(dh1rdc(k1,k2),k2=1,3), -* $(dhdc(ld,k1,k2),k2=1,3),(dhddc(k1,k2),k2=1,4) -* write (64,'(10f12.4)')(dh2rdc(k1,k2),k2=1,3), -* $(dhdc(le,k1,k2),k2=1,3),(dhedc(k1,k2),k2=1,4) -* end do -* write (64,*) -********************************************************************** - HTRA=RLA+COSHD*(RLC*COSHE-RLB) - HTRB=RLB-RLA*COSHD-RLC*COSHE - HTRC=RLC+COSHE*(RLA*COSHD-RLB) - HTHD=RLA*SINHD*(RLB-RLC*COSHE) - HTHE=RLC*SINHE*(RLB-RLA*COSHD) - HNRA=RLC*SINHD*SINHE - HNRC=RLA*SINHD*SINHE - HNHD=RLA*RLC*COSHD*SINHE - HNHE=RLA*RLC*SINHD*COSHE - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - DO K1=1,3 - DRDA(K1)=A(K1)/R4 - DO K2=1,4 - DRVDC(K1,K2)=DRDA(K1)*DADC(K2) - DTDC(K1,K2)=2.0*(DRADC(K1,K2)*HTRA+DRBDC(K1,K2)*HTRB+DRCDC(K1,K2 - $)*HTRC-DRVDC(K1,K2)*R4+DHDDC(K1,K2)*HTHD+DHEDC(K1,K2)*HTHE) - DNDC(K1,K2)=2.0*(DRADC(K1,K2)*HNRA+DRCDC(K1,K2)*HNRC+DHDDC(K1,K2 - $)*HNHD+DHEDC(K1,K2)*HNHE) - DARGTDC(i1,K1,K2)=(DTDC(K1,K2)-ARG*DNDC(K1,K2))/POEM - - ftmp = DARGTDC(i1,K1,K2)*detdar+ - $dargtdc(i1,k1,k2)*decodar+(detdhd+decodhd)*dhddc(k1,k2)+ - $(detdhe+decodhe)*dhedc(k1,k2) - D(K1,J(K2))=D(K1,J(K2))+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(j(k2),k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/4 - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do k2=1,4 - ihu=j(k2) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i2=1,idbo1(la) - ihu=idbo(la,i2) - do k1=1,3 - ftmp = dbondc(la,k1,i2)*(detdboa+decodbola) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(la) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i2=1,idbo1(la) - ihu=idbo(la,i2) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i2=1,idbo1(lb) - ihu=idbo(lb,i2) - do k1=1,3 - ftmp = dbondc(lb,k1,i2)*(detdbob+decodbolb) - $ +dbopindc(lb,k1,i2)*detdbopib - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(lb) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i2=1,idbo1(lb) - ihu=idbo(lb,i2) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i2=1,idbo1(lc) - ihu=idbo(lc,i2) - do k1=1,3 - ftmp = dbondc(lc,k1,i2)*(detdboc+decodbolc) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(lc) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i2=1,idbo1(lc) - ihu=idbo(lc,i2) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - do i2=1,ia(j(2),2) - iob=ia(j(2),2+i2) - ncubo=nubon2(j(2),i2) - if (bo(ncubo).gt.0.0) then - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i3=1,idbo1(ncubo) - ihu=idbo(ncubo,i3) - do k1=1,3 - ftmp = detdsbo1*dbondc(ncubo,k1,i3) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ncubo) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i3=1,idbo1(ncubo) - ihu=idbo(ncubo,i3) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - endif - end do - - do i2=1,ia(j(3),2) - iob=ia(j(3),2+i2) - ncubo=nubon2(j(3),i2) - if (bo(ncubo).gt.0.0) then - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do i3=1,idbo1(ncubo) - ihu=idbo(ncubo,i3) - do k1=1,3 - ftmp = detdsbo1*dbondc(ncubo,k1,i3) - d(k1,ihu)=d(k1,ihu)+ftmp - - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k1,k1p)=virial_tmp(k1,k1p)+ftmp*c(ihu,k1p) - end do - endif - - end do - end do - - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/idbo1(ncubo) - do k1 = 1,6 - vtmp = virialsym(k1)*frac - do i3=1,idbo1(ncubo) - ihu=idbo(ncubo,i3) - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - end do - endif - - endif - - endif - end do - - 10 continue - - return - end -********************************************************************** -********************************************************************** - - subroutine nonbon - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkch.blk" -#include "cbkconst.blk" -#include "cbkd.blk" -#include "cbkdcell.blk" -#include "cbkenergies.blk" -#include "cbkff.blk" -#include "cbkia.blk" -#include "cbknonbon.blk" -#include "cbkpairs.blk" -#include "cbknvlown.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "small.blk" - - dimension a(3),da(6) - dimension virial_tmp(3,3),virialsym(6) -********************************************************************** -* * -* Calculate vdWaals and Coulomb energies and derivatives * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In nonbon' -c$$$ call timer(65) -c$$$ end if - - ew=0.0 - ep=0.0 - - c1c=332.0638 - third=one/three - fothird=4.0/3.0 - twothird=2.0/3.0 - h15=(vpar(29)-1.0)/vpar(29) - - nptmp=0 - nstmp=0 - do 10 ivl=1,nvpair-nvlself -c Use precomputed midpoint criterion to decide if interaction is owned. - if (nvlown(ivl).eq.1) then - - i1=nvl1(ivl) - i2=nvl2(ivl) - - call dista2(i1,i2,rr,a(1),a(2),a(3)) - if (rr.gt.swb.or.rr.lt.0.001) goto 10 - - ity1=ia(i1,1) - ity2=ia(i2,1) - imol1=iag(i1,3+mbond) - imol2=iag(i2,3+mbond) - rr2=rr*rr - - sw=1.0 - sw1=0.0 - call taper(rr,rr2) -********************************************************************** -* * -* Calculate vdWaals energy * -* * -********************************************************************** - p1=p1co(ity1,ity2) - p2=p2co(ity1,ity2) - p3=p3co(ity1,ity2) - hulpw=(rr**vpar(29)+gamwco(ity1,ity2)) - rrw=hulpw**(1.0/vpar(29)) - h1=exp(p3*(1.0-rrw/p1)) - h2=exp(0.50*p3*(1.0-rrw/p1)) - - ewh=p2*(h1-2.0*h2) - rrhuw=rr**(vpar(29)-1.0) - dewdr=(p2*p3/p1)*(h2-h1)*rrhuw*(hulpw**(-h15)) - -********************************************************************** -* * -* Calculate Coulomb energy * -* * -********************************************************************** - q1q2=ch(i1)*ch(i2) - hulp1=(rr2*rr+gamcco(ity1,ity2)) - eph=c1c*q1q2/(hulp1**third) - depdr=-c1c*q1q2*rr2/(hulp1**fothird) -********************************************************************** -* * -* Taper correction * -* * -********************************************************************** - ephtap=eph*sw - depdrtap=depdr*sw+eph*sw1 - ewhtap=ewh*sw - dewdrtap=dewdr*sw+ewh*sw1 - -* write (64,*)i1,i2,p1,p2,p3,gamwco(ity1,ity2),vpar(29),ewh,ew - ew=ew+ewhtap - ep=ep+ephtap - estrain(i1)=estrain(i1)+0.50*(ewhtap+ephtap) !1st atom energy - estrain(i2)=estrain(i2)+0.50*(ewhtap+ephtap) !2nd atom energy - -********************************************************************** -* * -* Calculate derivatives vdWaals energy to cartesian * -* coordinates * -* * -********************************************************************** - - if (Lvirial.eq.1) then - do k1=1,3 - do k2=1,3 - virial_tmp(k1,k2) = 0.0 - end do - end do - endif - - do k4=1,3 - ftmp = (dewdrtap+depdrtap)*(a(k4)/rr) - d(k4,i1)=d(k4,i1)+ftmp - d(k4,i2)=d(k4,i2)-ftmp - if (Lvirial.eq.1) then - do k1p=1,3 - virial_tmp(k4,k1p)=virial_tmp(k4,k1p)+ - $ ftmp*c(i1,k1p)-ftmp*c(i2,k1p) - end do - endif - end do - - if (Lvirial.eq.1) then - virialsym(1) = virial_tmp(1,1) - virialsym(2) = virial_tmp(2,2) - virialsym(3) = virial_tmp(3,3) - virialsym(4) = virial_tmp(1,2) - virialsym(5) = virial_tmp(1,3) - virialsym(6) = virial_tmp(2,3) - do k1 = 1,6 - virial(k1) = virial(k1) + virialsym(k1) - end do - - if (Latomvirial.eq.1) then - frac = 1.0d0/2 - do k1 = 1,6 - vtmp = virialsym(k1)*frac - ihu=i1 - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - ihu=i2 - atomvirial(k1,ihu) = atomvirial(k1,ihu) + vtmp - end do - endif - - endif - - endif - - 10 continue - - return - end - -********************************************************************** -********************************************************************** - - subroutine efield - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkch.blk" -#include "cbkcha.blk" -#include "cbkd.blk" -#include "cbkefield.blk" -#include "cbkenergies.blk" -#include "cbktregime.blk" -#include "control.blk" -#include "small.blk" -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In efield' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if -********************************************************************** -* * -* Electric field * -* * -********************************************************************** - efi=0.0 - efix=0.0 - efiy=0.0 - efiz=0.0 - c1c=332.0638 !Coulomb energy conversion - c1=23.02 !conversion from kcal to eV - - if (ifieldx.eq.1) then - do i1=1,na - efih=vfieldx*c1*c1c*ch(i1)*c(i1,1) - efix=efix+efih - estrain(i1)=estrain(i1)+efih !atom energy - - defidc=c1*c1c*vfieldx*ch(i1) - d(1,i1)=d(1,i1)+defidc - end do - end if - - if (ifieldy.eq.1) then - do i1=1,na - efih=vfieldy*c1*c1c*ch(i1)*c(i1,2) - efiy=efiy+efih - estrain(i1)=estrain(i1)+efih !atom energy - - defidc=c1*c1c*vfieldy*ch(i1) - d(2,i1)=d(2,i1)+defidc - end do - end if - - if (ifieldz.eq.1) then - do i1=1,na - efih=vfieldz*c1*c1c*ch(i1)*c(i1,3) - efiz=efiz+efih - estrain(i1)=estrain(i1)+efih !atom energy - - defidc=c1*c1c*vfieldz*ch(i1) - d(3,i1)=d(3,i1)+defidc - end do - end if - - efi=efix+efiy+efiz - return - end -********************************************************************** -********************************************************************** - - subroutine restraint - -********************************************************************** -#include "cbka.blk" -#include "cbkatomcoord.blk" -#include "cbkc.blk" -#include "cbkconst.blk" -#include "cbkd.blk" -#include "cbkenergies.blk" -#include "cbkrestr.blk" -#include "cbktorang.blk" -#include "cbktorsion.blk" -#include "cbktregime.blk" -#include "control.blk" -#include "small.blk" -#include "cbkinit.blk" - dimension drda(3),j(4),dhrdc(3,3),dargdc(3,3) -********************************************************************** -* * -* Calculate distance restraint energy * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In restraint' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - do i1=1,nrestra - ih1=irstra(i1,1) - ih2=irstra(i1,2) - if (itend(i1).eq.0.or.(mdstep.gt.itstart(i1).and.mdstep.lt. - $itend(i1))) then - call dista2(ih1,ih2,rr,dx,dy,dz) - diffr=rr-rrstra(i1) -* diffr=rrstra(i1) - exphu=exp(-vkrst2(i1)*(diffr*diffr)) - erh=vkrstr(i1)*(1.0-exphu) - deresdr=2.0*vkrst2(i1)*diffr*vkrstr(i1)*exphu -* deresdr=-2.0*vkrst2(i1)*diffr*vkrstr(i1)*exphu - eres=eres+erh - drda(1)=dx/rr - drda(2)=dy/rr - drda(3)=dz/rr - do k1=1,3 - d(k1,ih1)=d(k1,ih1)+deresdr*drda(k1) - d(k1,ih2)=d(k1,ih2)-deresdr*drda(k1) - end do - end if - end do - -********************************************************************** -* * -* Calculate angle restraint energy * -* * -********************************************************************** - do i1=1,nrestrav - j(1)=irstrav(i1,1) - j(2)=irstrav(i1,2) - j(3)=irstrav(i1,3) - ittr=0 -* do i2=1,nval -* if (j(1).eq.iv(i2,2).and.j(2).eq.iv(i2,3).and.j(3).eq.iv(i2,4)) -* $ittr=i2 -* end do -* if (ittr.eq.0) stop 'Wrong valence angle restraint' - call calvalres(j(1),j(2),j(3),arg,hr,dhrdc,dargdc) - vaval=hr*rdndgr - diffv=-(vaval-vrstra(i1))*dgrrdn - exphu=exp(-vkr2v(i1)*(diffv*diffv)) - erh=vkrv(i1)*(1.0-exphu) - deresdv=-2.0*vkr2v(i1)*diffv*vkrv(i1)*exphu - eres=eres+erh - do k1=1,3 - do k2=1,3 - d(k1,j(k2))=d(k1,j(k2))+deresdv*dhrdc(k1,k2) - end do - end do - - end do - -********************************************************************** -* * -* Calculate torsion restraint energy * -* * -********************************************************************** - do i1=1,nrestrat - j(1)=irstrat(i1,1) - j(2)=irstrat(i1,2) - j(3)=irstrat(i1,3) - j(4)=irstrat(i1,4) - ittr=0 - do i2=1,ntor - if (j(1).eq.it(i2,2).and.j(2).eq.it(i2,3).and.j(3).eq.it(i2,4) - $.and.j(4).eq.it(i2,5)) ittr=i2 - if (j(4).eq.it(i2,2).and.j(3).eq.it(i2,3).and.j(2).eq.it(i2,4) - $.and.j(1).eq.it(i2,5)) ittr=i2 - end do - if (ittr.eq.0) then - write (*,*)'Wrong torsion restraint' - write (*,*)i1,j(1),j(2),j(3),j(4) - stop 'Wrong torsion restraint' - end if - vtor=thg(ittr) - difft=-(vtor-trstra(i1))*dgrrdn - exphu=exp(-vkr2t(i1)*(difft*difft)) - erh=vkrt(i1)*(1.0-exphu) - deresdt=2.0*vkr2t(i1)*difft*vkrt(i1)*exphu - if (vtor.lt.zero) deresdt=-deresdt - eres=eres+erh - do k1=1,3 - do k2=1,4 - d(k1,j(k2))=d(k1,j(k2))+deresdt*dargtdc(ittr,k1,k2) - end do - end do - - end do -********************************************************************** -* * -* Calculate mass centre restraint energy * -* * -********************************************************************** - do i1=1,nrestram - j1=irstram(i1,2) - j2=irstram(i1,3) - j3=irstram(i1,4) - j4=irstram(i1,5) - kdir=irstram(i1,1) - cmx1=0.0 - cmy1=0.0 - cmz1=0.0 - cmx2=0.0 - cmy2=0.0 - cmz2=0.0 - summas1=0.0 - summas2=0.0 - do i2=j1,j2 - cmx1=cmx1+c(i2,1)*xmasat(i2) - cmy1=cmy1+c(i2,2)*xmasat(i2) - cmz1=cmz1+c(i2,3)*xmasat(i2) - summas1=summas1+xmasat(i2) - end do - cmx1=cmx1/summas1 - cmy1=cmy1/summas1 - cmz1=cmz1/summas1 - if (mdstep.lt.2) then - rmstrax(i1)=cmx1 - rmstray(i1)=cmy1 - rmstraz(i1)=cmz1 - end if - if (kdir.le.3) then - do i2=j3,j4 - cmx2=cmx2+c(i2,1)*xmasat(i2) - cmy2=cmy2+c(i2,2)*xmasat(i2) - cmz2=cmz2+c(i2,3)*xmasat(i2) - summas2=summas2+xmasat(i2) - end do - cmx2=cmx2/summas2 - cmy2=cmy2/summas2 - cmz2=cmz2/summas2 - end if - if (kdir.eq.1) dist=cmx1-cmx2 - if (kdir.eq.2) dist=cmy1-cmy2 - if (kdir.eq.3) dist=cmz1-cmz2 - if (kdir.eq.4) then - distx=cmx1-rmstrax(i1) - disty=cmy1-rmstray(i1) - distz=cmz1-rmstraz(i1) - dist=sqrt(distx*distx+disty*disty+distz*distz) - end if - dismacen(i1)=dist - dist=dist-rmstra1(i1) - erh=rmstra2(i1)*dist*dist - deresdr=2.0*dist*rmstra2(i1) -* exphu=exp(-rmstra3(i1)*(dist*dist)) -* erh=rmstra2(i1)*(1.0-exphu) -* deresdr=2.0*rmstra3(i1)*dist*rmstra2(i1)*exphu - eres=eres+erh - if (kdir.le.3) then - do i2=j1,j2 - d(kdir,i2)=d(kdir,i2)+deresdr*xmasat(i2)/summas1 - end do - do i2=j3,j4 - d(kdir,i2)=d(kdir,i2)-deresdr*xmasat(i2)/summas2 - end do - end if - if (kdir.eq.4.and.mdstep.gt.5) then - do i2=j1,j2 - d(1,i2)=d(1,i2)+deresdr*(distx/dist)*(xmasat(i2)/summas1) - d(2,i2)=d(2,i2)+deresdr*(disty/dist)*(xmasat(i2)/summas1) - d(3,i2)=d(3,i2)+deresdr*(distz/dist)*(xmasat(i2)/summas1) - end do - end if - end do -********************************************************************** -* * -* Calculate morphing energy * -* * -********************************************************************** - if (imorph.eq.1) then - distot=zero - do i1=1,na - dmx=c(i1,1)-cmo(i1,1) - dmy=c(i1,2)-cmo(i1,2) - dmz=c(i1,3)-cmo(i1,3) - dism=sqrt(dmx*dmx+dmy*dmy+dmz*dmz) - distot=distot+dism -* exphu=exp(-vmo2(i1)*(dism*dism)) -* erh=vmo1(i1)*(1.0-exphu) - erh=vmo1(i1)*dism - eres=eres+erh -* deresddis=2.0*vmo2(i1)*dism*vmo1(i1)*exphu - deresddis=vmo1(i1) - drda1=dmx/dism - drda2=dmy/dism - drda3=dmz/dism - d(1,i1)=d(1,i1)+deresddis*drda1 - d(2,i1)=d(2,i1)+deresddis*drda2 - d(3,i1)=d(3,i1)+deresddis*drda3 - end do - - end if - - - return - end -********************************************************************** -******************************************************************** - - subroutine calvalres (ja1,ja2,ja3,arg,hr,dhrdc,dargdc) - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" - dimension a(3),b(3),j(3),dradc(3,3),drbdc(3,3),dtdc(3,3), - $dargdc(3,3),dndc(3,3),dadc(3),dbdc(3),dhrdc(3,3) -********************************************************************** -* * -* Calculate valency angles and their derivatives to cartesian * -* coordinates for restraint calculations * -* * -********************************************************************** -c$$$* if (ndebug.eq.1) then -c$$$C* open (65,file='fort.65',status='unknown',access='append') -c$$$* write (65,*) 'In calvalres' -c$$$* call timer(65) -c$$$* close (65) -c$$$* end if - - dadc(1)=-1.0 - dadc(2)=1.0 - dadc(3)=0.0 - dbdc(1)=0.0 - dbdc(2)=1.0 - dbdc(3)=-1.0 - do k1=1,3 - do k2=1,3 - dradc(k1,k2)=0.0 - drbdc(k1,k2)=0.0 - end do - end do -********************************************************************** -* * -* Determine valency angle * -* * -********************************************************************** - call dista2(ja1,ja2,rla,dx1,dy1,dz1) - call dista2(ja2,ja3,rlb,dx2,dy2,dz2) - - a(1)=-dx1 - a(2)=-dy1 - a(3)=-dz1 - b(1)=dx2 - b(2)=dy2 - b(3)=dz2 - poem=rla*rlb - tel=a(1)*b(1)+a(2)*b(2)+a(3)*b(3) - arg=tel/poem - arg2=arg*arg - s1ma22=1.0-arg2 - if (s1ma22.lt.1.0d-10) s1ma22=1.0d-10 - s1ma2=sqrt(s1ma22) - if (arg.gt.1.0) arg=1.0 - if (arg.lt.-1.0) arg=-1.0 - hr=acos(arg) -********************************************************************** -* * -* Calculate derivative valency angle to cartesian coordinates * -* * -********************************************************************** - do k1=1,3 - dradc(k1,1)=-a(k1)/rla - dradc(k1,2)=a(k1)/rla - end do - - do k1=1,3 - drbdc(k1,2)=b(k1)/rlb - drbdc(k1,3)=-b(k1)/rlb - end do - - do k1=1,3 - do k2=1,3 - dndc(k1,k2)=rla*drbdc(k1,k2)+rlb*dradc(k1,k2) - dtdc(k1,k2)=a(k1)*dbdc(k2)+b(k1)*dadc(k2) - dargdc(k1,k2)=(dtdc(k1,k2)-arg*dndc(k1,k2))/poem - dhrdc(k1,k2)=-dargdc(k1,k2)/s1ma2 - end do - end do - - 10 continue - - return - end -********************************************************************** -******************************************************************** - - subroutine calvalhb (ja1,ja2,ja3,ix,iy,iz,arg,hr,dhrdc,dargdc) - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" - dimension a(3),b(3),j(3),dradc(3,3),drbdc(3,3),dtdc(3,3), - $dargdc(3,3),dndc(3,3),dadc(3),dbdc(3),dhrdc(3,3) -********************************************************************** -* * -* Calculate valency angles and their derivatives to cartesian * -* coordinates for hydrogen bond calculations * -* * -********************************************************************** -c$$$* if (ndebug.eq.1) then -c$$$* open (65,file='fort.65',status='unknown',access='append') -c$$$* write (65,*) 'In calvalhb' -c$$$* call timer(65) -c$$$* close (65) -c$$$* end if - - dadc(1)=-1.0 - dadc(2)=1.0 - dadc(3)=0.0 - dbdc(1)=0.0 - dbdc(2)=1.0 - dbdc(3)=-1.0 - do k1=1,3 - do k2=1,3 - dradc(k1,k2)=0.0 - drbdc(k1,k2)=0.0 - end do - end do -********************************************************************** -* * -* Determine valency angle * -* * -********************************************************************** - call dista2(ja1,ja2,rla,dx1,dy1,dz1) - call dista2(ja2,ja3,rlb,dx2,dy2,dz2) - - a(1)=-dx1 - a(2)=-dy1 - a(3)=-dz1 - b(1)=dx2 - b(2)=dy2 - b(3)=dz2 - poem=rla*rlb - tel=a(1)*b(1)+a(2)*b(2)+a(3)*b(3) - arg=tel/poem - arg2=arg*arg - s1ma22=1.0-arg2 - if (s1ma22.lt.1.0d-10) s1ma22=1.0d-10 - s1ma2=sqrt(s1ma22) - if (arg.gt.1.0) arg=1.0 - if (arg.lt.-1.0) arg=-1.0 - hr=acos(arg) -********************************************************************** -* * -* Calculate derivative valency angle to cartesian coordinates * -* * -********************************************************************** - do k1=1,3 - dradc(k1,1)=-a(k1)/rla - dradc(k1,2)=a(k1)/rla - end do - - do k1=1,3 - drbdc(k1,2)=b(k1)/rlb - drbdc(k1,3)=-b(k1)/rlb - end do - - do k1=1,3 - do k2=1,3 - dndc(k1,k2)=rla*drbdc(k1,k2)+rlb*dradc(k1,k2) - dtdc(k1,k2)=a(k1)*dbdc(k2)+b(k1)*dadc(k2) - dargdc(k1,k2)=(dtdc(k1,k2)-arg*dndc(k1,k2))/poem - dhrdc(k1,k2)=-dargdc(k1,k2)/s1ma2 - end do - end do - - 10 continue - - return - end -********************************************************************** -********************************************************************** - - subroutine caltor(ja1,ja2,ja3,ja4,ht) - -********************************************************************** -#include "cbka.blk" -#include "cbkenergies.blk" -#include "cbktregime.blk" -#include "control.blk" -#include "cbkinit.blk" - DIMENSION A(3),DRDA(3),DADC(4),DRADC(3,4),DRBDC(3,4), - $DRCDC(3,4),DHDDC(3,4),DHEDC(3,4),DRVDC(3,4),DTDC(3,4), - $DNDC(3,4) - dimension j(4),dvdc1(3,3),dargdc1(3,3),dvdc2(3,3),dargdc2(3,3) -********************************************************************** -* * -* Calculate torsion angle (for internal coordinates output) * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In caltor' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - do k1=1,3 - do k2=1,4 - dhddc(k1,k2)=0.0 - dhedc(k1,k2)=0.0 - dradc(k1,k2)=0.0 - drbdc(k1,k2)=0.0 - drcdc(k1,k2)=0.0 - end do - end do - et=0.0 - eco=0.0 - dadc(1)=1.0 - dadc(2)=0.0 - dadc(3)=0.0 - dadc(4)=-1.0 - call dista2(ja1,ja2,rla,dx1,dy1,dz1) - call dista2(ja2,ja3,rlb,dx2,dy2,dz2) - call dista2(ja3,ja4,rlc,dx2,dy2,dz2) - call dista2(ja1,ja4,r4,dx2,dy2,dz2) - call calvalres(ja1,ja2,ja3,arg1,h1,dvdc1,dargdc1) - call calvalres(ja2,ja3,ja4,arg2,h2,dvdc2,dargdc2) -********************************************************************** -* * -* Determine torsion angle * -* * -********************************************************************** - d142=r4*r4 - coshd=cos(h1) - coshe=cos(h2) - sinhd=sin(h1) - sinhe=sin(h2) - poem=2.0*rla*rlc*sinhd*sinhe - poem2=poem*poem - tel=rla*rla+rlb*rlb+rlc*rlc-d142-2.0*(rla*rlb*coshd-rla*rlc* - $coshd*coshe+rlb*rlc*coshe) - arg=tel/poem - if (arg.gt.1.0) arg=1.0 - if (arg.lt.-1.0) arg=-1.0 - arg2=arg*arg - ht=acos(arg)*rdndgr - k1=ja1 - k2=ja2 - k3=ja3 - k4=ja4 - call dista2(k3,k2,dis,x3,y3,z3) - y32z32=y3*y3+z3*z3 - wort1=sqrt(y32z32)+1e-6 - wort2=sqrt(y32z32+x3*x3)+1e-6 - sinalf=y3/wort1 - cosalf=z3/wort1 - sinbet=x3/wort2 - cosbet=wort1/wort2 - call dista2(k1,k2,dis,x1,y1,z1) - x1=x1*cosbet-y1*sinalf*sinbet-z1*cosalf*sinbet - y1=y1*cosalf-z1*sinalf - wort3=sqrt(x1*x1+y1*y1)+1e-6 - singam=y1/wort3 - cosgam=x1/wort3 - call dista2(k4,k2,dis,x4,y4,z4) - x4=x4*cosbet-y4*sinalf*sinbet-z4*cosalf*sinbet - y4=y4*cosalf-z4*sinalf - y4=x4*singam-y4*cosgam - if (y4.gt.0.0) ht=-ht - if (ht.lt.-179.999999d0) ht=-179.999999d0 - if (ht.gt.179.999999d0) ht=179.999999d0 - - return - end -********************************************************************** diff --git a/lib/reax/reax_reac.F b/lib/reax/reax_reac.F deleted file mode 100644 index 73c625d7f1..0000000000 --- a/lib/reax/reax_reac.F +++ /dev/null @@ -1,312 +0,0 @@ -********************************************************************** -* * -* REAXFF Reactive force field program * -* * -* Developed and written by Adri van Duin, duin@wag.caltech.edu * -* * -* Copyright (c) 2001-2010 California Institute of Technology * -* * -* This is an open-source program. Feel free to modify its * -* contents. Please keep me informed of any useful modification * -* or addition that you made. Please do not distribute this * -* program to others; if people are interested in obtaining * -* a copy of this program let them contact me first. * -* * -********************************************************************** -********************************************************************** -* * -* REAXFF Reactive force field program * -* * -* Developed and written by Adri van Duin, duin@wag.caltech.edu * -* * -* Copyright (c) 2001-2010 California Institute of Technology * -* * -* This is an open-source program. Feel free to modify its * -* contents. Please keep me informed of any useful modification * -* or addition that you made. Please do not distribute this * -* program to others; if people are interested in obtaining * -* a copy of this program let them contact me first. * -* * -********************************************************************** -********************************************************************** - - subroutine encalc - -********************************************************************** -#include "cbka.blk" -#include "cbkc.blk" -#include "cbkcha.blk" -#include "cbkconst.blk" -#include "cbkd.blk" -#include "cbkdcell.blk" -#include "cbkenergies.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "small.blk" -********************************************************************** -* * -* Calculate energy and first derivatives * -* * -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In encalc' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if - estrc=0.0 - do i1=1,na - do i2=1,3 - d(i2,i1)=0.0 - estrain(i1)=0.0 - end do - end do - eb=zero - ea=zero - elp=zero - emol=zero - ev=zero - ehb=zero - ecoa=zero - epen=zero - et=zero - eco=zero - eres=zero - eradbo=zero - efi=zero - - if(Lvirial.eq.1) then - do k1 = 1,6 - virial(k1) = zero - end do - endif - - if (Latomvirial.eq.1) then - do i1=1,na - do i2=1,6 - atomvirial(i2,i1)=0.0 - end do - end do - endif - - call boncor - call lonpar - call covbon - call ovcor - - call srtang !Determine valency angles - call srttor !Determine torsion angles -* call srtoop !Determine out of plane angles - call srthb !Determine hydrogen bonds - - call calval - call valang - -* call oopang - - call torang - call hbond - !print *, 'called hbond' - !print *, nchaud - - call nonbon - call efield - - call restraint - -c -c Use this to print out fort.73-style energies -c It only works correctly in serial mode -c -c write (6,'(i8,1x,14(f21.10,1x))')mdstep+nprevrun,eb,ea,elp, -c $emol,ev+epen,ecoa,ehb,et,eco,ew,ep,ech,efi - - estrc=eb+ea+elp+ev+ecoa+emol+epen+et+ehb+eco+ew+ep+ncha2*ech+efi - if (estrc.gt.zero) return - if (estrc.le.zero) then - goto 10 - else - write (*,*)mdstep - write (92,*)eb,ea,elp,ev,ecoa,emol,epen,eoop,et,eco,ew, - $ep,ech,eres,eradbo - stop 'Energy not a number' - end if - - 10 continue - return - end -********************************************************************** -********************************************************************** - - subroutine reaxinit - -********************************************************************** -#include "cbka.blk" -#include "cbkatomcoord.blk" -#include "cbkc.blk" -#include "cbkcha.blk" -#include "cbkconst.blk" -#include "cbkdcell.blk" -#include "cbkdistan.blk" -#include "cbkenergies.blk" -#include "cbkia.blk" -#include "cbkimove.blk" -#include "cbkinit.blk" -#include "cbktregime.blk" -#include "cellcoord.blk" -#include "control.blk" -#include "opt.blk" -#include "small.blk" -********************************************************************** -c$$$ if (ndebug.eq.1) then -c$$$C open (65,file='fort.65',status='unknown',access='append') -c$$$ write (65,*) 'In init' -c$$$ call timer(65) -c$$$ close (65) -c$$$ end if -********************************************************************** -* * -* Initialize variables * -* * -********************************************************************** - convmd=4.184*1.0d26 - pi=3.14159265 - avognr=6.0221367d23 - rdndgr=180.0/pi - dgrrdn=1.0/rdndgr - rgasc=8.314510 - caljou=4.184 - xjouca=1.0/caljou - ech=zero - zero=0.0 - one=1.0 - two=2.0 - three=3.0 - half=one/two - nzero=0 - none=1 - ntwo=2 - nthree=3 - invt=0 - ndata2=0 - iheatf=0 - nradcount=0 - itemp=1 - xinh=zero - ifieldx=0 - ifieldy=0 - ifieldz=0 - mdstep=0 - kx=0 - ky=0 - kz=0 - nit=0 - nbon=0 - angle(1)=90.0 - angle(2)=90.0 - angle(3)=90.0 - axiss(1)=zero - axiss(2)=zero - axiss(3)=zero - do i1=1,nat - id(i1,1)=0 - id(i1,2)=0 - id(i1,3)=0 - end do - icgeo=0 - sumhe=zero - ustime=zero - systime=zero - vpmax=zero - vpmin=zero - dseed=0 - iagain=0 - do i1=1,nat - do i2=1,mbond+3 - ia(i1,i2)=0 - iag(i1,i2)=0 - end do - end do - - ioldchg=0 - na=0 - nrestra=0 - nrestrav=0 - nrestrat=0 - nrestram=0 - tset=tsetor - tm11=axis(1) - tm21=zero - tm31=zero - tm22=axis(2) - tm32=zero - tm33=axis(3) - qruid='NORMAL RUN' -c$$$ do i1=1,nat -c$$$ imove(i1)=1 -c$$$ end do - -********************************************************************** -* * -* Write file headers * -* * -********************************************************************** -Cc open (71,file='fort.71',status='unknown',access='append') -c write (71,10) -c close (71) -Cc open (73,file='fort.73',status='unknown',access='append') -c write (73,20) -c close (73) -c if (ntrc.gt.0) then -Cc open (75,file='fort.75',status='unknown',access='append') -c write (75,30) -c close (75) -c end if -c if (nmethod.eq.4) then -Cc open (59,file='fort.59',status='unknown',access='append') -c write (59,40) -c close (59) -c end if - - return -********************************************************************** -* * -* Format part * -* * -********************************************************************** - 10 format (' Iter. Nmol Epot Ekin Etot ', - $' T(K) Eaver(block) Eaver(total) Taver Tmax ', - $' Pres(MPa) sdev(Epot) sdev(Eaver) Tset Timestep', - $' RMSG Totaltime') - 20 format (' Iter. Ebond Eatom Elp Emol', - $' Eval Ecoa Ehbo Etors Econj', - $' Evdw Ecoul Echarge Efield') - 30 format (' Iter. Tsys Tzone1 Tset1 Tzone2 Tset2') - 40 format (' Iter. a b c px', - $'(MPa) py(MPa) pz(MPa) pset(MPa) Volume ') - end -********************************************************************** -************************************************************************ - -c subroutine timer(nunit) - -************************************************************************ -c#include "cbka.blk" -c#include "cbkinit.blk" -c real timear -c real tarray(2) -c#ifdef _IBM -c call dtime_(tarray,timear) -c#else -c call dtime(tarray,timear) -c#endif - -c ustime=ustime+tarray(1) -c systime=systime+tarray(2) -c write (nunit,100)ustime,systime,ustime+systime -c return -c 100 format ('User time:',f20.4,' System time:',f20.4, -c $' Total time:',f20.4) -c end -************************************************************************ -************************************************************************ diff --git a/lib/reax/small.blk b/lib/reax/small.blk deleted file mode 100644 index 9ec66b6e17..0000000000 --- a/lib/reax/small.blk +++ /dev/null @@ -1,5 +0,0 @@ - common - $/rsmall/ tset,dseed,tempmd,ts2,ts22,nmolo,nmolo5,nbon,na,namov, - $ na_local - - diff --git a/lib/reax/valang.blk b/lib/reax/valang.blk deleted file mode 100644 index c4b0027b8a..0000000000 --- a/lib/reax/valang.blk +++ /dev/null @@ -1,9 +0,0 @@ - - - - common - $/cbkvalang/ vval1(nsort),vval2(nvatym), - $ vval4(nsort),vkac(nvatym),vkap(nvatym), - $ vka3(nvatym),vka8(nvatym),th0(nvatym) - -